diff --git a/.gitmodules b/.gitmodules index 4a6d6231f5..c4aeca3812 100644 --- a/.gitmodules +++ b/.gitmodules @@ -643,6 +643,9 @@ [submodule "vendor/grammars/lua.tmbundle"] path = vendor/grammars/lua.tmbundle url = https://github.com/textmate/lua.tmbundle +[submodule "vendor/grammars/m3"] + path = vendor/grammars/m3 + url = https://github.com/newgrammars/m3 [submodule "vendor/grammars/make.tmbundle"] path = vendor/grammars/make.tmbundle url = https://github.com/textmate/make.tmbundle @@ -739,6 +742,9 @@ [submodule "vendor/grammars/python-django.tmbundle"] path = vendor/grammars/python-django.tmbundle url = https://github.com/textmate/python-django.tmbundle +[submodule "vendor/grammars/quake"] + path = vendor/grammars/quake + url = https://github.com/newgrammars/quake [submodule "vendor/grammars/r.tmbundle"] path = vendor/grammars/r.tmbundle url = https://github.com/textmate/r.tmbundle diff --git a/grammars.yml b/grammars.yml index c68d4c22d7..ec642cbf47 100755 --- a/grammars.yml +++ b/grammars.yml @@ -541,6 +541,8 @@ vendor/grammars/logtalk.tmbundle: - source.logtalk vendor/grammars/lua.tmbundle: - source.lua +vendor/grammars/m3: +- source.modula-3 vendor/grammars/make.tmbundle: - source.makefile vendor/grammars/mako-tmbundle: @@ -613,6 +615,8 @@ vendor/grammars/protobuf-tmbundle: vendor/grammars/python-django.tmbundle: - source.python.django - text.html.django +vendor/grammars/quake: +- source.quake vendor/grammars/r.tmbundle: - source.r - text.tex.latex.rd diff --git a/lib/linguist/languages.yml b/lib/linguist/languages.yml index 542826b009..15de0b37c1 100755 --- a/lib/linguist/languages.yml +++ b/lib/linguist/languages.yml @@ -2831,6 +2831,17 @@ Modula-2: tm_scope: source.modula2 ace_mode: text language_id: 234 +Modula-3: + type: programming + extensions: + - ".i3" + - ".ig" + - ".m3" + - ".mg" + color: "#223388" + ace_mode: text + tm_scope: source.modula-3 + language_id: 564743864 Module Management System: type: programming extensions: @@ -3735,6 +3746,15 @@ QMake: - qmake ace_mode: text language_id: 306 +Quake: + type: programming + filenames: + - m3makefile + - m3overrides + color: "#882233" + ace_mode: text + tm_scope: source.quake + language_id: 375265331 R: type: programming color: "#198CE7" diff --git a/samples/Modula-3/DiGraph.ig b/samples/Modula-3/DiGraph.ig new file mode 100644 index 0000000000..b09325ceb8 --- /dev/null +++ b/samples/Modula-3/DiGraph.ig @@ -0,0 +1,350 @@ +(* Copyright (C) 1992, Digital Equipment Corporation *) +(* All rights reserved. *) +(* See the file COPYRIGHT for a full description. *) +(* *) +(* Last modified on Thu Sep 5 12:17:52 PDT 1996 by detlefs *) + +GENERIC INTERFACE DiGraph(NodeVal, EdgeVal); + +(* A parameterized directed graph abstraction. + + Requires: + NodeVal.T: TYPE + NodeVal.Hash: PROCEDURE(nv: NodeVal.T; lessThan: CARDINAL): CARDINAL; + NodeVal.Equal: PROCEDURE(nv1, nv2: NodeVal.T): BOOLEAN; + NodeVal.Compare: PROCEDURE(nv1, nv2: NodeVal.T): [-1..1]; + + NodeVal.Equal(n1, n2) => NodeVal.Hash(n1, m) = NodeVal.Hash(n2, m) + NodeVal.Equal(n1, n2) <=> NodeVal.Compare(n1, n2) = 0 + + + A DiGraph.T represents a directed graph whose nodes and edges are + labelled with values of types NodeVal and EdgeVal, respectively. + A DiGraph.T is initially empty; clients are allowed to add and + delete nodes and edges. Observer functions allow clients to obtain + the nth predecessor or successor of a node, or to iterate over + all the predecessors or successors. The most interesting function + provided by DiGraph is TransitiveClose; this is a generalized + transitive closure algorithm that can, with appropriate arguments, + add sufficient edges to transitively close a graph or, + alternatively, compute the shortest paths in a graph whose edges + are labelled with integers. + + The representation of DiGraph.T requires that the NodeVal type + provides hash and comparison operations. A hash table maps NodeVal + values into nodes in the graph. Nodes contain lists of edges to + successors and predecessors. Because of this edge-list + implementation, this implementation of DiGraph is biased towards + sparse graphs. + + I hope eventually to have this interface support a number of + interesting graph algorithms, and to modify it to use the new + Vesta/Vulcan method of parameterization. Any contributions of + work on this code is strongly welcomed. + + Index: graph; directed graph; network; transitive closure; relation +*) + + +IMPORT Wr, RefList; + +EXCEPTION + NoSuchNode; NoSuchEdge; DupNode; DupEdge; RangeFault; BadSemiGroup; + +TYPE + (* Used in transitive closure. *) + ClosedSemiRing = OBJECT + plusIdent, bottom: EdgeVal.T; + METHODS + init(): ClosedSemiRing; + plus(ev1, ev2: EdgeVal.T): EdgeVal.T; + times(ev1, ev2: EdgeVal.T): EdgeVal.T; + closure(ev: EdgeVal.T): EdgeVal.T; + END (* OBJECT *); + + (* These are used in printing. *) + (* A PrintProc should take a node or edge and print it on 'wr', and print + exactly 'width' characters on 'wr', truncating or padding with blanks as + necessary. *) + NodePrintProc = PROCEDURE(wr: Wr.T; nv: NodeVal.T; width: CARDINAL); + EdgePrintProc = PROCEDURE(wr: Wr.T; exists: BOOLEAN; ev: EdgeVal.T; + width: CARDINAL); + (* The 'exists' argument indicates whether an edge exists. *) + +TYPE + EdgeMapProc = PROCEDURE(n1: NodeVal.T; e: EdgeVal.T; n2: NodeVal.T); + NodeMapProc = PROCEDURE(n: NodeVal.T); + + +TYPE + EdgePublic = OBJECT + from, to: Node; + value: EdgeVal.T; + END (* OBJECT *); + Edge <: EdgePublic; + + NodePublic = OBJECT + value: NodeVal.T; + END (* OBJECT *); + Node <: NodePublic; + + TPublic = OBJECT + METHODS + init(csr: ClosedSemiRing := NIL; + undoable := FALSE): T; + (* Creates a new, empty graph (one with no nodes or edges.) + "csr" is the closed semi-ring to use for transitive closure + operations, and "undoable" indicates that operations should be + undoable. + *) + + nodeSize(): CARDINAL; + (* Returns the number of nodes in 'self'. *) + + edgeSize(): CARDINAL; + (* Returns the number of edges in 'self'. *) + + nodeExists(nv: NodeVal.T): BOOLEAN; + (* Returns TRUE iff there exists a node 'n' in the 'g' such that + NodeVal.Equal(n, nv) = TRUE. *) + + addNode(nv: NodeVal.T) RAISES { DupNode }; + (* If self.nodeExists(nv), raises NodeExists and does not modify 'self'. + Otherwise, adds a node with value 'nv' (and no successors or + predecessors) to 'self'. + *) + + deleteNode(nv: NodeVal.T) RAISES { NoSuchNode}; + (* If self.nodeExists(nv), deletes the node associated with 'nv' + and all incoming edges to and outgoing edges from that node from + 'self'. Otherwise, raises NoSuchNode and does not modify 'self'. + *) + + addEdge(node1: NodeVal.T; edgeVal: EdgeVal.T; node2: NodeVal.T; + addNodes := FALSE) + RAISES { NoSuchNode, DupEdge }; + (* If 'addNodes' is FALSE, and either of self.nodeExists(node1) or + self.nodeExists(node2) is FALSE, then raises NoSuchNode. If 'addNodes' + is TRUE, adds 'node1' and/or 'node2' to 'self' if necessary to + ensure that self.nodeExists(node1) and self.nodeExists(node2). Next, if + self.edgeExists(node1, node2), raises EdgeExists ('self' is not + modified in this case, since if a node was added in the first + step then there could not have been an edge between the input + nodes.). Otherwise, creates such an edge in 'self' and gives + it the value 'edgeVal.' + *) + + edgeExists(node1, node2: NodeVal.T): BOOLEAN; + (* If self.nodeExists(node1) and self.nodeExists(node2) and an edge is + presently defined between the nodes associated with those values in + 'self', returns TRUE; otherwise, returns FALSE. + *) + + getEdge(node1, node2: NodeVal.T; VAR (*OUT*) ev: EdgeVal.T): BOOLEAN; + (* If self.nodeExists(node1) and self.nodeExists(node2) and an edge is + presently defined between the nodes associated with those values in + 'self', returns TRUE and sets 'ev' to the value of that edge; otherwise, + returns FALSE. + *) + + edgeValue(node1, node2: NodeVal.T): EdgeVal.T + RAISES { NoSuchNode, NoSuchEdge }; + (* If NOT self.nodeExists(node1) or self.nodeExists(node2), raises + NoSuchNode and does not modify 'self'. If the nodes exist but + NOT self.edgeExists(node1, node2), raises NoSuchEdge and does not + modify 'self'. Otherwise, if the nodes and an edge exist, returns the + value associated with that edge. + *) + + + deleteEdge(node1, node2: NodeVal.T) RAISES { NoSuchNode, NoSuchEdge }; + (* If NOT self.nodeExists(node1) or NOT self.nodeExists(node2), raises + NoSuchNode and does not modify 'self'. If the nodes exist but + NOT self.edgeExists(node1, node2), raises NoSuchEdge and does not + modify 'self'. Finally, if the nodes and an edge exist, deletes the + edge between the nodes. + *) + + + setEdge(node1: NodeVal.T; edgeVal: EdgeVal.T; node2: NodeVal.T) + RAISES { NoSuchNode }; + (* If NOT self.nodeExists(node1) or NOT self.nodeExists(node2), raises + NoSuchNode and does not modify 'self'. If the nodes exist but + NOT self.edgeExists(node1, node2), creates a new edge between 'node1' + and 'node2' with value 'edgeVal.' If an edge already exists between the + nodes, sets its value to 'edgeVal.' + *) + + changeEdge(node1: NodeVal.T; edgeVal: EdgeVal.T; node2: NodeVal.T) + RAISES { NoSuchNode, NoSuchEdge }; + (* If NOT self.nodeExists(node1) or NOT self.nodeExists(node2), raises + NoSuchNode and does not modify 'self'. If the nodes exist but + NOT self.edgeExists(node1, node2), raises NoSuchEdge and does not + modify 'self'. Finally, if the nodes and an edge exist, + changes the value of the edge to 'edgeVal.' + *) + + nSucc(nodeVal: NodeVal.T): CARDINAL RAISES { NoSuchNode }; + (* If self.nodeExists(nodeVal), returns the number of successors + of that node; otherwise, signals NoSuchNode. + *) + + getSuccN(nodeVal: NodeVal.T; n: CARDINAL): NodeVal.T + RAISES { NoSuchNode, RangeFault }; + (* If self.nodeExists(nodeVal) and that node has 'n'-1 or more successors, + returns the NodeVal associated with the 'n'-th (0-based) successor. + If NOT self.nodeExists(nodeVal), raises NoSuchNode; if n < 0 or n >= the + number of successors of the node associated with 'nodeVal', raises + RangeFault. + *) + + getSuccIter(nodeVal: NodeVal.T): NodeIter RAISES { NoSuchNode }; + (* If self.nodeExists(nodeVal), returns a NodeIter that will yield all the + successors of that node (assuming that the graph is not modified during + the iteration.) If NOT self.nodeExists(nodeVal), raises NoSuchNode. + *) + + getSuccList(nodeVal: NodeVal.T): RefList.T (* OF Edge *) + RAISES { NoSuchNode }; + (* Returns the list of edges emanating from "nodeVal". *) + + nPred(nodeVal: NodeVal.T): CARDINAL RAISES { NoSuchNode }; + (* If self.nodeExists(nodeVal), returns the number of successors + of that node; otherwise, signals NoSuchNode. + *) + + getPredN(nodeVal: NodeVal.T; n: CARDINAL): NodeVal.T + RAISES { NoSuchNode, RangeFault }; + (* If self.nodeExists(nodeVal) and that node has 'n'-1 or more + predecessors, returns the NodeVal associated with the 'n'-th + (0-based) predecessor. If NOT self.nodeExists(nodeVal), raises + NoSuchNode; if n < 0 or n >= the number of predecessors of the + node associated with 'nodeVal', raises RangeFault. + *) + + + getPredIter(nodeVal: NodeVal.T): NodeIter RAISES { NoSuchNode }; + (* If self.nodeExists(nodeVal), returns a NodeIter that will yield all the + predecessors of that node (assuming that the graph is not + modified during the iteration.) If NOT + self.nodeExists(nodeVal), raises NoSuchNode. + *) + + getPredList(nodeVal: NodeVal.T): RefList.T (* OF Edge *) + RAISES { NoSuchNode }; + (* Returns the list of edges terminating at "nodeVal". *) + + mapOverNodes(nmp: NodeMapProc) RAISES ANY; + (* Applies 'nmp' to every Node in 'self.' *) + + mapOverEdges(emp: EdgeMapProc) RAISES ANY; + (* Applies 'emp' to every edge in 'self.' *) + + transitiveClose(edgeChange: EdgeMapProc := NIL): BOOLEAN; + + (* Modifies 'self' so that the final value of 'self' is the + transitive closure of the initial value. If "csr" is + non-"NIL", then it must specify a valid "closed semi-ring" on + the edge type. See Section 5.5, p. 198, "The Design and + Analysis of Computer Algorithms", by Aho, Hopcroft, and Ullman, + Addison-Wesley, 1974 for a complete explanation. If "csr" is + "NIL", then it is a checked runtime if "EdgeVal" is any type + other than "NULL"; if "EdgeVal" is "NULL", then + "transitiveClose" closes the graph by inserting "NIL"-valued + edges as necessary. + + Actually, one addition has been made to the algorithm in AHU: a + closed semi-ring may specify a distinguished element "etBottom" + of the "EdgeVal" type that is 'contagious' in the plus and + times operations; if transitive closure gives any edge the + value "etBottom", then "transitiveClose" stops and returns + "FALSE". OTherwise, completes the closure and returns "TRUE". + Typically "etBottom" is returned by the closure operation. + + To give a concrete example, assume that the edge values are + non-negative real numbers, and we want to compute the shortest + paths between nodes. Here we use MIN as the 'Plus' operation + of the semi-ring, addition as the 'Times' operation, and + +infinity as the identity of the Plus operation. More specifically: + + 'etPlusIdent': +infinity + + 'etPlus': Returns the minimum of 'e1' and 'e2', unless one of 'e1' + or 'e2' is 'etPlusIdent', in which case returns the other. + + 'etTimes': confusingly, here, addition. Returns the sum of + 'e1' and 'e2', unless one is 'etPlusIdent' in which case it + returns that. + + 'etClosure': In general, should be + etPlus(etTimesIdent, e, etTimes(e, e), etTimes(e, etTimes(e, e)), ...) + where 'etTimesIdent' is the identity element for the times + operator. In our example, Times is addition, so the identity + is 0, so the closure operation is + MIN(0, e, e+e, e+e+e, ...) + or 0. + + If we did the same problem over all real numbers, not just + non-negative numbers, we could use 'etBottom' to detect + negative-weight cycles. 'etBottom' is would represent -infinity, + and we could make 'etClosure(e)' return 'etBottom' when 'e' is + negative. + *) + + addEdgeAndClose(n1: NodeVal.T; ev: EdgeVal.T; n2: NodeVal.T; + addNodes := FALSE; + edgeChange: EdgeMapProc := NIL): BOOLEAN; + (* "Conceptually" adds an edge of value 'ev' between 'n1' and 'n2', and + transitively closes the graph according to the closed semi-ring 'csr'. + That is, uses the "Plus" operation of csr to compute the new value of + the edge from the old one, if any, and added edge value, and propogates + any changes made through the graph. + *) + + topSort(VAR (*OUT*) nodes: REF ARRAY OF NodeVal.T): BOOLEAN; + (* If the graph is acyclic, returns "TRUE" and sets "nodes" to be + an array containing all the nodes in a topological order; that + is, if there is an edge from node "a" to node "b" in the graph, + then "a" precedes "b" in the array. If the graph contains a + cycle, returns "FALSE" and sets "nodes" to be an array + containing a cycle. *) + + printAsMatrix(wr: Wr.T; + np: NodePrintProc; ep: EdgePrintProc; + between, colWidth: CARDINAL; + absentEV: EdgeVal.T); + (* Prints "self" in adjacency matrix form. That is, prints a + matrix whose rows and columns are labelled with node values and + whose cells are labelled with edge values. printAsMatrix + writes its output to "wr", and calls "np" and "ep" to do the + printing. "np" is called with "wr", a "NodeVal", and "colwidth" + as arguments. "ep" is called with "wr", a BOOLEAN that is TRUE + IFF there is an edge between the nodes corresponding by the + cell in the matrix, the EdgeVal for that cell if it exists + (else "absentEV"), and "colWidth". The order of the nodes in + the rows and columns is determined by the NodeVal.Compare + passed to New. + *) + + push(); + (* Saves a state of the graph. Requires the graph to be undoable. *) + pop(); + (* Requires the graph to be undoable and for there to be a + previously saved state; restores that state. *) + + END (* OBJECT *); + T <: TPublic; + + (* Node Iterators. *) + NodeIter = OBJECT + METHODS + next(VAR nv: NodeVal.T): BOOLEAN; + (* If there are Nodes in 'self' that have not yet been yielded, returns + TRUE and sets 'next' to the next node to be yielded. Otherwise, the + iteration is complete and FALSE is returned. + *) + END (* OBJECT *); + +END DiGraph. + + diff --git a/samples/Modula-3/DiGraph.mg b/samples/Modula-3/DiGraph.mg new file mode 100644 index 0000000000..fe6b419055 --- /dev/null +++ b/samples/Modula-3/DiGraph.mg @@ -0,0 +1,1052 @@ +(* Copyright (C) 1992, Digital Equipment Corporation *) +(* All rights reserved. *) +(* See the file COPYRIGHT for a full description. *) +(* *) +(* Last modified on Thu Sep 5 12:16:01 PDT 1996 by detlefs *) + +GENERIC MODULE DiGraph(NodeVal, EdgeVal); +(* The DiGraph type is parameterized over the types of the nodes and the + edges. *) + +IMPORT RefList, Wr, Word, RefRefTbl, RefListSort, RefSeq; + +IMPORT Thread; +<*FATAL Wr.Failure, Thread.Alerted*> + +TYPE + NodeValRef = REF NodeVal.T; + +REVEAL + Node = NodePublic BRANDED OBJECT + succ, pred: RefList.T (* Of Edge *); + misc: INTEGER; + END; +TYPE + NodeArr = REF ARRAY OF Node; +REVEAL + Edge = EdgePublic BRANDED OBJECT + nextValue : EdgeVal.T (* used in transitive closure *); + END; + + T = TPublic BRANDED OBJECT + nodeTbl: RefRefTbl.T; (* map from REF NodeVal's to nodes. *) + edges: CARDINAL := 0; + csr: ClosedSemiRing; + undoable: BOOLEAN; + undoSP: CARDINAL; + undoStack: REF ARRAY OF UndoRec; + + METHODS + nodeValToNode(nodeVal: NodeVal.T; addNodes: BOOLEAN): Node + RAISES { NoSuchNode } := NodeValToNode; + makeNodeArray(): NodeArr := MakeNodeArray; + + OVERRIDES + init := TInit; + nodeSize := NodeSize; + edgeSize := EdgeSize; + nodeExists := NodeExists; + addNode := AddNode; + deleteNode := DeleteNode; + edgeExists := EdgeExists; + getEdge := GetEdge; + edgeValue := EdgeValue; + addEdge := AddEdge; + deleteEdge := DeleteEdge; + setEdge := SetEdge; + changeEdge := ChangeEdge; + nSucc := NSucc; + getSuccN := GetSuccN; + getSuccIter := GetSuccIter; + getSuccList := GetSuccList; + nPred := NPred; + getPredN := GetPredN; + getPredIter := GetPredIter; + getPredList := GetPredList; + mapOverEdges := MapOverEdges; + mapOverNodes := MapOverNodes; + transitiveClose := TransitiveClose; + addEdgeAndClose := AddEdgeAndClose; + topSort := TopSort; + printAsMatrix := PrintAsMatrix; + push := Push; + pop := Pop; + END; + + +TYPE + NodeIterImpl = NodeIter BRANDED OBJECT + list: RefList.T; (* Uniterated remainder of edge list. *) + toNotFrom: BOOLEAN; (* TRUE IF this is a 'succ' iter, FALSE if 'pred' *) + OVERRIDES + next := NodeIterNext; + END (* OBJECT *); + + UndoType = { Mark, AddNode, DeleteNode, AddEdge, DeleteEdge, EdgeVal }; + UndoRec = RECORD + type: UndoType; + n: Node; + e: Edge; + ev: EdgeVal.T; + END (* RECORD *); + + +PROCEDURE TInit(self: T; csr: ClosedSemiRing; undoable: BOOLEAN): T = + BEGIN + self.nodeTbl := NEW(RefRefTbl.Default, + keyHash := NodeValRefHash, + keyEqual := NodeValRefEqual).init(); + self.edges := 0; + self.csr := csr; + self.undoable := undoable; + IF undoable THEN + self.undoSP := 0; + self.undoStack := NEW(REF ARRAY OF UndoRec, 100) + END (* IF *); + RETURN self; + END TInit; + +PROCEDURE NodeValRefHash(<*UNUSED*> t: RefRefTbl.T; + READONLY key: REFANY): Word.T = + BEGIN + RETURN NodeVal.Hash(NARROW(key, NodeValRef)^); + END NodeValRefHash; + +PROCEDURE NodeValRefEqual(<*UNUSED*> t: RefRefTbl.T; + READONLY key1, key2: REFANY): BOOLEAN = + BEGIN + RETURN NodeVal.Equal(NARROW(key1, NodeValRef)^, + NARROW(key2, NodeValRef)^); + END NodeValRefEqual; + + +(* Should be INLINE *) +PROCEDURE NodeSize(self: T): CARDINAL = + BEGIN + RETURN self.nodeTbl.size() + END NodeSize; + + +(* Should be INLINE *) +PROCEDURE EdgeSize(self: T): CARDINAL = + BEGIN + RETURN self.edges; + END EdgeSize; + + +PROCEDURE NodeExists(self: T; nodeVal: NodeVal.T): BOOLEAN = + VAR dummyVal: REFANY; + BEGIN + WITH nvr = NEW(NodeValRef) DO + nvr^ := nodeVal; + RETURN self.nodeTbl.get(nvr, dummyVal); + END (* WITH *); + END NodeExists; + + +PROCEDURE AddNode(self: T; nodeVal: NodeVal.T) RAISES { DupNode } = + VAR n: Node; + dummy: BOOLEAN; + BEGIN + IF self.nodeExists(nodeVal) THEN RAISE DupNode END; + n := NEW(Node, value := nodeVal, succ := NIL, pred := NIL); + WITH nvr = NEW(NodeValRef) DO + nvr^ := nodeVal; + dummy := self.nodeTbl.put(nvr, n); + <*ASSERT NOT dummy*> + END (* WITH *); + IF self.undoable THEN PushUndo(self, UndoType.AddNode, n) END (* IF *) + END AddNode; + + +PROCEDURE DeleteNode(self: T; nodeVal: NodeVal.T) RAISES { NoSuchNode } = + VAR node: Node; + edge: Edge; + preds, succs: RefList.T (* Of Edge *); + dummy: BOOLEAN; + resultRA: REFANY; + BEGIN + (* This raises an exception if the node doesn't exist. *) + node := self.nodeValToNode(nodeVal, FALSE); + + VAR nvr := NEW(NodeValRef); BEGIN + nvr^ := nodeVal; + dummy := self.nodeTbl.delete(nvr, resultRA); + (* If NodeValToNode said it was there, it ought to be there. *) + <*ASSERT dummy*> + END (* WITH *); + IF self.undoable THEN + PushUndo(self, UndoType.DeleteNode, node) + END (* IF *); + + (* Delete node from the 'succs' list of each of its predecessors. *) + preds := node.pred; + WHILE preds # NIL DO + edge := preds.head; + dummy := DeleteFromEdgeList(edge.from.succ, FALSE, node); + <*ASSERT dummy*> + IF self.undoable THEN + PushUndo(self, UndoType.DeleteEdge, NIL, edge) + END (* IF *); + DEC(self.edges); + preds := preds.tail + END; + (* ...and also from the 'preds' list of each of its successors. *) + succs := node.succ; + WHILE succs # NIL DO + edge := succs.head; + dummy := DeleteFromEdgeList(edge.to.pred, TRUE, node); + <*ASSERT dummy*> + IF self.undoable THEN + PushUndo(self, UndoType.DeleteEdge, NIL, edge) + END (* IF *); + DEC(self.edges); + succs := succs.tail + END; + + END DeleteNode; + + +(* INTERNAL *) + +(* Returns a NodeArr (Array.T OF Node) of all the nodes. If 'cp' is + non-NIL, uses it to sort the array. *) + +PROCEDURE MakeNodeArray(self: T): NodeArr = + VAR newArr := NEW(NodeArr, self.nodeTbl.size()); + iter := self.nodeTbl.iterate(); + nodeVal, node: REFANY; + rl: RefList.T := NIL; + BEGIN + WHILE iter.next(nodeVal, node) DO + rl := RefList.Cons(node, rl) + END (* WHILE *); + rl := RefListSort.SortD(rl, NodeCompare); + VAR i := 0; BEGIN + WHILE rl # NIL DO + newArr[i] := rl.head; INC(i); rl := rl.tail + END (* WHILE *) + END (* BEGIN *); + RETURN newArr + END MakeNodeArray; + +PROCEDURE NodeCompare(node1Ref, node2Ref: REFANY): [-1..1] = + VAR + node1, node2: Node; + BEGIN + node1 := NARROW(node1Ref, Node); + node2 := NARROW(node2Ref, Node); + RETURN NodeVal.Compare(node1.value, node2.value); + END NodeCompare; + + +(* EXTERNAL *) + +PROCEDURE AddEdge(self: T; + node1: NodeVal.T; edgeVal: EdgeVal.T; node2: NodeVal.T; + addNodes: BOOLEAN := FALSE) + RAISES { NoSuchNode, DupEdge } = + VAR + newEdge: Edge; + fromNode, toNode: Node; + edgeDummy: Edge; + BEGIN + (* These raise NoSuchNode when necessary. *) + fromNode := self.nodeValToNode(node1, addNodes); + toNode := self.nodeValToNode(node2, addNodes); + + (* Check to see if an edge exists... *) + IF FindEdge(fromNode, toNode, edgeDummy) THEN RAISE DupEdge END; + newEdge := NEW(Edge, value := edgeVal, from := fromNode, to := toNode); + fromNode.succ := RefList.Cons(newEdge, fromNode.succ); + toNode.pred := RefList.Cons(newEdge, toNode.pred); + INC(self.edges); + IF self.undoable THEN + PushUndo(self, UndoType.AddEdge, NIL, newEdge) + END (* IF *) + END AddEdge; + + +(* INTERNAL *) +(* If addNodes is FALSE, and either of self.nodeExists(node1) or + self.nodeExists(node2) is FALSE, then raises "NoSuchNode." Otherwise, adds + nodes corresponding to the values 'node1' and 'node2' to 'g' if no + such nodes already exist, and returns those nodes in 'fromNode' and + 'toNode', respectively. +*) +PROCEDURE NodeValToNode(self: T; nodeVal: NodeVal.T; + addNodes: BOOLEAN): Node + RAISES { NoSuchNode } = + VAR nodeRA: REFANY; + BEGIN + WITH nvr = NEW(NodeValRef) DO + nvr^ := nodeVal; + IF NOT self.nodeTbl.get(nvr, nodeRA) THEN + IF addNodes THEN + self.addNode(nodeVal); <*NOWARN*> + VAR dummy := self.nodeTbl.get(nvr, nodeRA); BEGIN + <*ASSERT dummy*> + RETURN nodeRA + END (* BEGIN *) + ELSE + RAISE NoSuchNode; + END (* IF *); + ELSE + RETURN nodeRA + END (* IF *); + END (* WITH *); + END NodeValToNode; + + +(* EXTERNAL *) + +PROCEDURE EdgeExists(self: T; node1, node2: NodeVal.T): BOOLEAN = + VAR + fromNode, toNode: Node; + edgeDummy: Edge; + BEGIN + TRY + fromNode := self.nodeValToNode(node1, FALSE); + toNode := self.nodeValToNode(node2, FALSE); + EXCEPT + | NoSuchNode => RETURN FALSE; + END; + RETURN FindEdge(fromNode, toNode, edgeDummy); + END EdgeExists; + + +PROCEDURE GetEdge(self: T; node1, node2: NodeVal.T; + VAR ev: EdgeVal.T): BOOLEAN = + VAR fromNode, toNode: Node; + edge: Edge; + BEGIN + TRY + fromNode := self.nodeValToNode(node1, FALSE); + toNode := self.nodeValToNode(node2, FALSE); + EXCEPT + | NoSuchNode => RETURN FALSE; + END; + IF NOT FindEdge(fromNode, toNode, edge) THEN + RETURN FALSE; + ELSE + ev := edge.value; + RETURN TRUE; + END (* IF *); + END GetEdge; + + +(* INTERNAL *) + +(* Requires that 'fromNode' and 'toNode' are nodes in 'g'. If no edge + exists between 'fromNode' and 'toNode', returns FALSE; if such an edge + does exist, return TRUE and the value of that edge in 'edgeVal'. +*) +PROCEDURE FindEdge(fromNode, toNode: Node; + VAR (*OUT*) edge: Edge): BOOLEAN = + VAR + succs: RefList.T (* OF Edge *); + BEGIN + succs := fromNode.succ; + WHILE succs # NIL DO + edge := succs.head; + IF edge.to = toNode THEN RETURN TRUE; END; + succs := succs.tail + END; + RETURN FALSE; + END FindEdge; + + +(* EXTERNAL *) + +PROCEDURE EdgeValue(self: T; node1, node2: NodeVal.T): EdgeVal.T + RAISES { NoSuchNode, NoSuchEdge } = + VAR + fromNode, toNode: Node; + edge: Edge; + BEGIN + (* These raise NoSuchNode. *) + fromNode := self.nodeValToNode(node1, FALSE); + toNode := self.nodeValToNode(node2, FALSE); + IF NOT FindEdge(fromNode, toNode, edge) THEN + RAISE NoSuchEdge; + ELSE + RETURN edge.value; + END; + END EdgeValue; + + +PROCEDURE DeleteEdge(self: T; node1, node2: NodeVal.T) + RAISES { NoSuchNode, NoSuchEdge } = + VAR + fromNode, toNode: Node; + foundFrom, foundTo: BOOLEAN; + BEGIN + (* These raise NoSuchNode. *) + fromNode := self.nodeValToNode(node1, FALSE); + toNode := self.nodeValToNode(node2, FALSE); + + IF self.undoable THEN + VAR edge: Edge; BEGIN + IF FindEdge(fromNode, toNode, edge) THEN + PushUndo(self, UndoType.DeleteEdge, NIL, edge) + ELSE + RAISE NoSuchEdge + END (* IF *) + END (* BEGIN *) + END (* IF *); + + foundFrom := DeleteFromEdgeList(fromNode.succ, FALSE, toNode); + foundTo := DeleteFromEdgeList(toNode.pred, TRUE, fromNode); + IF foundFrom THEN + <*ASSERT foundTo*> + DEC(self.edges) + ELSE + <*ASSERT NOT foundTo*> + RAISE NoSuchEdge; + END; + END DeleteEdge; + + +(* INTERNAL *) + +(* Attempts to deletes an edge whose "target" is 'targetNode' from + 'realEdges'. If 'targetIsFromNode' is TRUE, "target" is interpreted + to mean the "from" field of an edge, else the "to" field. Returns + TRUE iff found and deleted a matching edge. *) + +PROCEDURE DeleteFromEdgeList(VAR realEdges: RefList.T (* Of Edge *); + targetIsFromNode: BOOLEAN; + targetNode: Node): BOOLEAN = + VAR edges, prevEdges: RefList.T (* Of Edge *); + edge: Edge; + BEGIN + prevEdges := NIL; + IF realEdges = NIL THEN RETURN FALSE; END; + edges := realEdges; + WHILE edges # NIL DO + edge := edges.head; + IF targetIsFromNode AND (edge.from = targetNode) THEN + IF prevEdges = NIL THEN realEdges := edges.tail + ELSE prevEdges.tail := edges.tail + END; + RETURN TRUE; + ELSIF (NOT targetIsFromNode) AND (edge.to = targetNode) THEN + IF prevEdges = NIL THEN realEdges := edges.tail + ELSE prevEdges.tail := edges.tail + END; + RETURN TRUE; + END; + prevEdges := edges; edges := edges.tail; + END; + RETURN FALSE; + END DeleteFromEdgeList; + + +(* EXTERNAL *) + +PROCEDURE ChangeEdge(self: T; node1: NodeVal.T; + edgeVal: EdgeVal.T; node2: NodeVal.T) + RAISES { NoSuchNode, NoSuchEdge } = + VAR + fromNode, toNode: Node; + edge: Edge; + BEGIN + (* These raise NoSuchNode. *) + fromNode := self.nodeValToNode(node1, FALSE); + toNode := self.nodeValToNode(node2, FALSE); + IF NOT FindEdge(fromNode, toNode, edge) THEN + RAISE NoSuchEdge; + ELSE + IF self.undoable THEN PushEdgeVal(self, edge, edge.value) END (* IF *); + edge.value := edgeVal; + END; + END ChangeEdge; + + +PROCEDURE SetEdge(self: T; node1: NodeVal.T; + edgeVal: EdgeVal.T; node2: NodeVal.T) + RAISES { NoSuchNode } = + VAR + fromNode, toNode: Node; + edge: Edge; + BEGIN + (* These raise NoSuchNode. *) + fromNode := self.nodeValToNode(node1, FALSE); + toNode := self.nodeValToNode(node2, FALSE); + IF NOT FindEdge(fromNode, toNode, edge) THEN + edge := NEW(Edge, value := edgeVal, from := fromNode, to := toNode); + fromNode.succ := RefList.Cons(edge, fromNode.succ); + toNode.pred := RefList.Cons(edge, toNode.pred); + IF self.undoable THEN + PushUndo(self, UndoType.AddEdge, NIL, edge) + END (* IF *); + INC(self.edges); + ELSE + IF self.undoable THEN PushEdgeVal(self, edge, edge.value) END (* IF *); + edge.value := edgeVal; + END; + END SetEdge; + + +PROCEDURE NSucc(self: T; nodeVal: NodeVal.T): CARDINAL + RAISES { NoSuchNode } = + BEGIN + RETURN RefList.Length(self.nodeValToNode(nodeVal, FALSE).succ); + END NSucc; + + +PROCEDURE GetSuccN(self: T; nodeVal: NodeVal.T; n: CARDINAL): NodeVal.T + RAISES { NoSuchNode, RangeFault } = + VAR + node: Node; + BEGIN + node := self.nodeValToNode(nodeVal, FALSE); + IF (n < 0) OR (n >= RefList.Length(node.succ)) THEN + RAISE RangeFault; + ELSE + RETURN NARROW(RefList.Nth(node.succ, n), Edge).to.value; + END; + END GetSuccN; + +PROCEDURE GetSuccIter(self: T; nodeVal: NodeVal.T): NodeIter + RAISES { NoSuchNode } = + VAR + node: Node; + ni: NodeIter; + BEGIN + node := self.nodeValToNode(nodeVal, FALSE); + ni := NEW(NodeIterImpl, toNotFrom := TRUE, list := node.succ); + RETURN ni; + END GetSuccIter; + +PROCEDURE GetSuccList(self: T; nodeVal: NodeVal.T): RefList.T + RAISES { NoSuchNode } = + VAR node: Node; BEGIN + node := self.nodeValToNode(nodeVal, FALSE); + RETURN node.succ + END GetSuccList; + +PROCEDURE NPred(self: T; nodeVal: NodeVal.T): CARDINAL + RAISES { NoSuchNode } = + BEGIN + RETURN RefList.Length(self.nodeValToNode(nodeVal, FALSE).pred); + END NPred; + +PROCEDURE GetPredN(self: T; nodeVal: NodeVal.T; n: CARDINAL): NodeVal.T + RAISES { NoSuchNode, RangeFault } = + VAR + node: Node; + BEGIN + node := self.nodeValToNode(nodeVal, FALSE); + IF (n < 0) OR (n >= RefList.Length(node.pred)) THEN + RAISE RangeFault; + ELSE + RETURN NARROW(RefList.Nth(node.pred, n), Edge).from.value; + END; + END GetPredN; + +PROCEDURE GetPredIter(self: T; nodeVal: NodeVal.T): NodeIter + RAISES { NoSuchNode } = + VAR + node: Node; + ni: NodeIter; + BEGIN + node := self.nodeValToNode(nodeVal, FALSE); + ni := NEW(NodeIterImpl, toNotFrom := FALSE, list := node.pred); + RETURN ni; + END GetPredIter; + +PROCEDURE GetPredList(self: T; nodeVal: NodeVal.T): RefList.T + RAISES { NoSuchNode } = + VAR node: Node; BEGIN + node := self.nodeValToNode(nodeVal, FALSE); + RETURN node.succ + END GetPredList; + +PROCEDURE NodeIterNext(self: NodeIterImpl; VAR next: NodeVal.T): BOOLEAN = + VAR + edge: Edge; + BEGIN + IF self.list = NIL THEN RETURN FALSE; END; + edge := self.list.head; + self.list := self.list.tail; + IF self.toNotFrom THEN + next := edge.to.value; + ELSE + next := edge.from.value; + END; + RETURN TRUE; + END NodeIterNext; + + +(*==================== Whole-Graph Iteration ====================*) + +PROCEDURE SetMiscs(g: T; i: INTEGER) = + VAR iter := g.nodeTbl.iterate(); + nodeVal, nodeRA: REFANY; + BEGIN + WHILE iter.next(nodeVal, nodeRA) DO + VAR node: Node := nodeRA; BEGIN + node.misc := i + END (* BEGIN *) + END (* WHILE *) + END SetMiscs; + +PROCEDURE MapOverEdges(self: T; emp: EdgeMapProc) RAISES ANY = + VAR iter := self.nodeTbl.iterate(); nodeVal, nodeRA: REFANY; BEGIN + SetMiscs(self, 0); + WHILE iter.next(nodeVal, nodeRA) DO + DfsEdges(nodeRA, emp) + END (* WHILE *); + SetMiscs(self, 0); + END MapOverEdges; + +PROCEDURE DfsEdges(node: Node; emp: EdgeMapProc) RAISES ANY = + BEGIN + IF node.misc = 0 THEN + VAR succs := node.succ; BEGIN + WHILE succs # NIL DO + VAR e: Edge := succs.head; BEGIN + emp(node.value, e.value, e.to.value); + node.misc := 1; + DfsEdges(e.to, emp); + END (* BEGIN *); + succs := succs.tail + END (* WHILE *) + END (* BEGIN *) + END (* IF *); + END DfsEdges; + + +PROCEDURE MapOverNodes(self: T; nmp: NodeMapProc) = + VAR iter := self.nodeTbl.iterate(); nodeValRA, nodeRA: REFANY; BEGIN + WHILE iter.next(nodeValRA, nodeRA) DO + VAR nodeVal: NodeValRef := nodeValRA; BEGIN + nmp(nodeVal^) + END (* BEGIN *) + END (* WHILE *) + END MapOverNodes; + +(* +PROCEDURE DfsNodes(ra: REFANY; <*UNUSED*> key: REFANY; + VAR nodeRA: REFANY): BOOLEAN RAISES ANY = + BEGIN + WITH node = NARROW(nodeRA, Node), + nmpRR = NARROW(ra, NMPRefRec) DO + DfsNodesMap(node, nmpRR.proc); + END (* WITH *); + RETURN FALSE; + END DfsNodes; + +PROCEDURE DfsNodesMap(n: Node; nmp: NodeMapProc) RAISES ANY = + VAR succs: RefList.T (* OF Edge *); + BEGIN + IF n.misc = 1 THEN RETURN; + ELSE + n.misc := 1; + nmp(n.value); + succs := n.succ; + WHILE succs # NIL DO + VAR e: Edge := succs.head; BEGIN + DfsNodesMap(e.to, nmp); + END (* BEGIN *) + END (* WHILE *) + END (* IF *); + END DfsNodesMap; +*) + +(*====================== Transitive closure ======================*) +(* Modifies 'g' so that the final value of 'g' is the transitive closure + of the initial value. If all of etPlus, etTimes, etPlusIdent, and + etTimesIdent are NIL, then edge with value NIL is added between nodes + 'n1' and 'n2' iff no edge connected them in the original value of 'g', + but a path between 'n1' and 'n2' did exist in that original value. + If any of the optional arguments are non-NIL, all must be, and they + must form a "closed semi-ring" on the edge type. We then run algorithm + 5.5, p. 198, "The Design and Analysis of Computer Algorithms", by Aho, + Hopcroft, and Ullman, Addison-Wesley, 1974. +*) + + +PROCEDURE TransitiveClose(self: T; edgeChange: EdgeMapProc := NIL): BOOLEAN = + VAR nodei, nodej, nodek: Node; + edge, kkedge, ikedge, ijedge, kjedge: Edge; + kkValClosure, ikVal, oldijVal, newijVal, kjVal: EdgeVal.T; + succs: RefList.T (* OF Edge *); + nodeArr: NodeArr; + nNodes: CARDINAL; + BEGIN + <*ASSERT self.csr # NIL *> + (* Repack the array so we can index the nodes. *) + nodeArr := self.makeNodeArray(); + nNodes := self.nodeSize(); + (* I'm going to code up an algorithm that assumes a sparse graph, + where most of the values are represented by the lack of an edge + (which corresponds to self.csr.plusIdent). We might want to + measure the number of edges against the number of nodes, and + decide whether to do a "dense" version, in which we allocate an + n^2 array... *) + FOR k := 0 TO nNodes-1 DO + nodek := nodeArr[k]; + + IF NOT FindEdge(nodek, nodek, kkedge) THEN + kkValClosure := self.csr.closure(self.csr.plusIdent); + ELSE + kkValClosure := self.csr.closure(kkedge.value); + END; + IF kkValClosure = self.csr.bottom THEN RETURN FALSE END (* IF *); + + FOR i := 0 TO nNodes-1 DO + nodei := nodeArr[i]; + + IF NOT FindEdge(nodei, nodek, ikedge) THEN + ikVal := self.csr.plusIdent; + ELSE + ikVal := ikedge.value; + END; + + FOR j := 0 TO nNodes-1 DO + nodej := nodeArr[j]; + IF NOT FindEdge(nodei, nodej, ijedge) THEN + oldijVal := self.csr.plusIdent; + ELSE + oldijVal := ijedge.value; + END; + + IF NOT FindEdge(nodek, nodej, kjedge) THEN + kjVal := self.csr.plusIdent; + ELSE + kjVal := kjedge.value; + END; + + newijVal := self.csr.plus( + oldijVal, + self.csr.times(ikVal, + self.csr.times(kkValClosure, + kjVal))); + IF (newijVal # self.csr.plusIdent) THEN + (* There needs to be an edge... *) + IF (oldijVal = self.csr.plusIdent) THEN + (* ...but there was no edge before, so make one. *) + ijedge := NEW(Edge); + (* To make sure rest of this iteration is right. *) + ijedge.value := self.csr.plusIdent; + ijedge.nextValue := newijVal; + ijedge.from := nodei; + ijedge.to := nodej; + nodei.succ := RefList.Cons(ijedge, nodei.succ); + nodej.pred := RefList.Cons(ijedge, nodej.pred); + IF self.undoable THEN + PushUndo(self, UndoType.AddEdge, NIL, ijedge) + END (* IF *); + IF edgeChange # NIL THEN + edgeChange(nodei.value, ijedge.value, nodej.value) + END (* IF *); + INC(self.edges); + ELSE + (* ...and there is. *) + ijedge.nextValue := newijVal; + END; + END; + END; + END; + + (* Now update the 'values' of the edges to the 'nextValues.' *) + FOR i := 0 TO nNodes-1 DO + nodei := nodeArr[i]; + succs := nodei.succ; + WHILE succs # NIL DO + edge := succs.head; + IF self.undoable AND edge.value # edge.nextValue THEN + PushEdgeVal(self, edge, edge.value) + END (* IF *); + edge.value := edge.nextValue; + succs := succs.tail + END; + END + END; + RETURN TRUE + END TransitiveClose; + +PROCEDURE AddEdgeAndClose(self: T; + n1: NodeVal.T; ev: EdgeVal.T; n2: NodeVal.T; + addNodes := FALSE; + edgeChange: EdgeMapProc := NIL): BOOLEAN = + VAR oldVal, newVal: EdgeVal.T; BEGIN + <*ASSERT self.csr # NIL *> + IF addNodes THEN + IF NOT NodeExists(self, n1) THEN + AddNode(self, n1) <*NOWARN*> + END (* IF *); + IF NOT NodeExists(self, n2) THEN + AddNode(self, n2) <*NOWARN*> + END (* IF *) + END (* IF *); + IF NOT self.getEdge(n1, n2, oldVal) THEN + oldVal := self.csr.plusIdent; + END (* IF *); + newVal := self.csr.plus(oldVal, ev); + IF oldVal = newVal THEN + RETURN TRUE + ELSIF newVal = self.csr.bottom THEN + RETURN FALSE + ELSE + IF edgeChange # NIL THEN edgeChange(n1, newVal, n2) END (* IF *); + self.setEdge(n1, newVal, n2); <*NOWARN*> + RETURN CloseOnPreds(self, newVal, n1, n2, edgeChange) AND + CloseOnSuccs(self, newVal, n1, n2, edgeChange) + END (* IF *); + END AddEdgeAndClose; + + +PROCEDURE CloseOnPreds(self: T; newVal: EdgeVal.T; + n1, n2: NodeVal.T; + edgeChange: EdgeMapProc): BOOLEAN = + VAR ni: NodeIter := self.getPredIter(n1); <*NOWARN*> + pred: NodeVal.T; + oldEdge, predEdge, newEdge: EdgeVal.T; + BEGIN + WHILE ni.next(pred) DO + predEdge := self.edgeValue(pred, n1); <*NOWARN*> + IF NOT self.getEdge(pred, n2, oldEdge) THEN + oldEdge := self.csr.plusIdent; + END (* IF *); + newEdge := self.csr.plus(oldEdge, self.csr.times(predEdge, newVal)); + IF newEdge # self.csr.plusIdent THEN + IF pred = n2 THEN + (* We have a cycle! Set the edges between n1 and n2 to the closure + of the edge we we about to add. *) + VAR closeVal := self.csr.closure(newEdge); BEGIN + IF closeVal = self.csr.bottom THEN + RETURN FALSE + ELSE + IF NOT self.addEdgeAndClose(n1, closeVal, n2, + FALSE, edgeChange) THEN + RETURN FALSE + END (* IF *); + IF NOT self.addEdgeAndClose(n2, closeVal, n1, + FALSE, edgeChange) THEN + RETURN FALSE + END (* IF *); + END (* IF *) + END (* WITH *); + ELSE + IF NOT self.addEdgeAndClose(pred, newEdge, n2, + FALSE, edgeChange) THEN + RETURN FALSE + END (* IF *) + END (* IF *) + END (* IF *) + END (* WHILE *); + RETURN TRUE + END CloseOnPreds; + +PROCEDURE CloseOnSuccs(self: T; newVal: EdgeVal.T; + n1, n2: NodeVal.T; + edgeChange: EdgeMapProc): BOOLEAN = + VAR ni: NodeIter := self.getSuccIter(n2); <*NOWARN*> + succ: NodeVal.T; + oldEdge, succEdge, newEdge: EdgeVal.T; + BEGIN + WHILE ni.next(succ) DO + succEdge := self.edgeValue(n2, succ); <*NOWARN*> + IF NOT self.getEdge(n1, succ, oldEdge) THEN + oldEdge := self.csr.plusIdent; + END (* IF *); + newEdge := self.csr.plus(oldEdge, self.csr.times(newVal, succEdge)); + IF newEdge # self.csr.plusIdent THEN + IF n1 = succ THEN + (* We have a cycle! Set the edges between n1 and n2 to the closure + of the edge we we about to add. *) + VAR closeVal := self.csr.closure(newEdge); BEGIN + IF closeVal = self.csr.bottom THEN + RETURN FALSE + ELSE + IF NOT self.addEdgeAndClose(n1, closeVal, n2, + FALSE, edgeChange) THEN + RETURN FALSE + END (* IF *); + IF NOT self.addEdgeAndClose(n2, closeVal, n1, + FALSE, edgeChange) THEN + RETURN FALSE + END (* IF *); + END (* IF *) + END (* WITH *); + ELSE + IF NOT self.addEdgeAndClose(n1, newEdge, succ, + FALSE, edgeChange) THEN + RETURN FALSE + END (* IF *) + END (* IF *); + END (* IF *); + END (* WHILE *); + RETURN TRUE + END CloseOnSuccs; + +PROCEDURE TopSort(self: T; + VAR (*OUT*) res: REF ARRAY OF NodeVal.T): BOOLEAN = + VAR nodes := NEW(REF ARRAY OF Node, self.nodeSize()); + cycle := NEW(RefSeq.T).init(); + cur := LAST(nodes^); + (* Returns TRUE and sets "res" only if it finds a cycle; + otherwise, filles in "nodes" right to left. *) + PROCEDURE TopSortWork(n: Node): BOOLEAN = + BEGIN + IF Word.And(n.misc, 2) # 0 THEN + WHILE cycle.getlo() # n DO EVAL cycle.remlo() END (* WHILE *); + res := NEW(REF ARRAY OF NodeVal.T, cycle.size()); + FOR k := 0 TO LAST(res^) DO + res[k] := NARROW(cycle.get(k), Node).value + END (* FOR *); + RETURN TRUE + ELSIF Word.And(n.misc, 1) # 0 THEN + RETURN FALSE + ELSE + cycle.addhi(n); n.misc := 2; + VAR succ := n.succ; BEGIN + WHILE succ # NIL DO + VAR e: Edge := succ.head; BEGIN + IF TopSortWork(e.to) THEN RETURN TRUE END (* IF *) + END (* BEGIN *); + succ := succ.tail + END (* WHILE *) + END (* BEGIN *); + EVAL cycle.remhi(); + nodes[cur] := n; DEC(cur); + n.misc := 1; + RETURN FALSE + END (* IF *) + END TopSortWork; + BEGIN + SetMiscs(self, 0); + (* First, find the roots. *) + VAR iter := self.nodeTbl.iterate(); nodeValRA, nodeRA: REFANY; BEGIN + WHILE iter.next(nodeValRA, nodeRA) DO + VAR node: Node := nodeRA; BEGIN + IF TopSortWork(node) THEN RETURN FALSE END (* IF *) + END (* BEGIN *) + END (* WHILE *) + END (* BEGIN *); + res := NEW(REF ARRAY OF NodeVal.T, self.nodeSize()); + FOR i := 0 TO LAST(res^) DO res[i] := nodes[i].value END (* FOR *); + RETURN TRUE + END TopSort; + + +(*******************************************************************) + +PROCEDURE PrintAsMatrix(self: T; wr: Wr.T; + np: NodePrintProc; + ep: EdgePrintProc; + between, colWidth: CARDINAL; + absentEV: EdgeVal.T) = + VAR + nodei, nodej: Node; + edge: Edge; + nodeArr: NodeArr; + nNodes: CARDINAL; + BEGIN + (* Repack the array so we can index the nodes. *) + nodeArr := self.makeNodeArray(); + nNodes := self.nodeSize(); + (* Print the top line *) + FOR i := 1 TO colWidth+1 DO Wr.PutChar(wr, ' '); END; + FOR i := 0 TO nNodes-1 DO + FOR j := 1 TO between DO Wr.PutChar(wr, ' '); END; + nodei := nodeArr[i]; + np(wr, nodei.value, colWidth); + END; + Wr.PutChar(wr, '\n'); + FOR i := 1 TO colWidth+between DO Wr.PutChar(wr, ' '); END; + Wr.PutChar(wr, '+'); + FOR i := 1 TO nNodes*colWidth + (nNodes-1)*between DO + Wr.PutChar(wr, '-'); + END; + Wr.PutChar(wr, '\n'); + + FOR i := 0 TO nNodes-1 DO + nodei := nodeArr[i]; + np(wr, nodei.value, colWidth); + FOR j := 1 TO between DO Wr.PutChar(wr, ' '); END; + Wr.PutChar(wr, '|'); + FOR j := 0 TO nNodes-1 DO + nodej := nodeArr[j]; + IF FindEdge(nodei, nodej, edge) THEN + ep(wr, TRUE, edge.value, colWidth); + ELSE + ep(wr, FALSE, absentEV, colWidth); + END; + FOR k := 1 TO between DO Wr.PutChar(wr, ' '); END; + END; + Wr.PutChar(wr, '\n'); + END; + END PrintAsMatrix; + +PROCEDURE PushUndo(self: T; type: UndoType; n: Node; e: Edge := NIL) = + BEGIN + ExpandIfNeed(self); + WITH top = self.undoStack[self.undoSP] DO + top.type := type; top.n := n; top.e := e + END (* WITH *); + INC(self.undoSP) + END PushUndo; + +PROCEDURE PushEdgeVal(self: T; e: Edge; ev: EdgeVal.T) = + BEGIN + ExpandIfNeed(self); + WITH top = self.undoStack[self.undoSP] DO + top.type := UndoType.EdgeVal; top.e := e; top.ev := ev + END (* WITH *); + INC(self.undoSP) + END PushEdgeVal; + +PROCEDURE ExpandIfNeed(self: T) = + BEGIN + IF self.undoSP = NUMBER(self.undoStack^) THEN + VAR new := NEW(REF ARRAY OF UndoRec, 2*self.undoSP); BEGIN + SUBARRAY(new^, 0, self.undoSP) := self.undoStack^; + self.undoStack := new + END (* BEGIN *); + END (* IF *) + END ExpandIfNeed; + +PROCEDURE Push(self: T) = + BEGIN + <*ASSERT self.undoable *> + PushUndo(self, UndoType.Mark, NIL); + END Push; + +PROCEDURE Pop(self: T) = + <*FATAL DupEdge, DupNode, NoSuchNode, NoSuchEdge *> + BEGIN + self.undoable := FALSE; + LOOP + IF self.undoSP < NUMBER(self.undoStack^) THEN + self.undoStack[self.undoSP].n := NIL; + self.undoStack[self.undoSP].e := NIL + END (* IF *); + DEC(self.undoSP); + WITH top = self.undoStack[self.undoSP] DO + CASE top.type OF + | UndoType.Mark => + EXIT + | UndoType.AddNode => + self.deleteNode(top.n.value) + | UndoType.DeleteNode => + self.addNode(top.n.value) + | UndoType.AddEdge => + self.deleteEdge(top.e.from.value, top.e.to.value) + | UndoType.DeleteEdge => + self.addEdge(top.e.from.value, top.e.value, top.e.to.value) + | UndoType.EdgeVal => + top.e.value := top.ev + END (* CASE *) + END (* WITH *) + END (* LOOP *); + self.undoable := TRUE + END Pop; + +BEGIN +END DiGraph. + + diff --git a/samples/Modula-3/Rd.i3 b/samples/Modula-3/Rd.i3 new file mode 100644 index 0000000000..0cda33e40e --- /dev/null +++ b/samples/Modula-3/Rd.i3 @@ -0,0 +1,359 @@ +(* Copyright (C) 1989, Digital Equipment Corporation *) +(* All rights reserved. *) +(* See the file COPYRIGHT for a full description. *) +(* Last modified on Mon Nov 8 17:21:08 PST 1993 by mcjones *) +(* modified on Tue Jul 6 13:05:03 PDT 1993 by wobber *) +(* modified on Tue Jun 15 09:42:56 1993 by gnelson *) +(* modified on Wed Apr 22 16:41:35 PDT 1992 by kalsow *) +(* modified on Mon Dec 24 01:10:09 1990 by muller *) + + +(* An "Rd.T" (or ``reader'') is a character input stream. The basic + operation on a reader is "GetChar", which returns the source + character at the ``current position'' and advances the current + position by one. Some readers are ``seekable'', which means that + they also allow setting the current position anywhere in the + source. For example, readers from random access files are + seekable; readers from terminals and sequential files are not. + \index{character input stream} + \index{input stream} + \index{stream!input} + \index{reader} + + Some readers are ``intermittent'', which means that the source of + the reader trickles in rather than being available to the + implementation all at once. For example, the input stream from an + interactive terminal is intermittent. An intermittent reader is + never seekable. + + Abstractly, a reader "rd" consists of + +| len(rd) `the number of source characters` +| src(rd) `a sequence of length "len(rd)+1"` +| cur(rd) `an integer in the range "[0..len(rd)]"` +| avail(rd) `an integer in the range "[cur(rd)..len(rd)+1]"` +| closed(rd) `a boolean` +| seekable(rd) `a boolean` +| intermittent(rd) `a boolean` + + These values are not necessarily directly represented in the data + fields of a reader object. In particular, for an intermittent + reader, "len(rd)" may be unknown to the implementation. But in + principle the values determine the state of the reader. + + The sequence "src(rd)" is zero-based: "src(rd)[i]" is valid for "i" + from 0 to "len(rd"). The first "len(rd)" elements of "src" are the + characters that are the source of the reader. The final element is + a special value "eof" used to represent end-of-file. The value + "eof" is not a character. + + The value of "cur(rd)" is the index in "src(rd)" of the next + character to be returned by "GetChar", unless "cur(rd) = len(rd)", + in which case a call to "GetChar" will raise the exception + "EndOfFile". + + The value of "avail(rd)" is important for intermittent readers: the + elements whose indexes in "src(rd)" are in the range + "[cur(rd)..avail(rd)-1]" are available to the implementation and + can be read by clients without blocking. If the client tries to + read further, the implementation will block waiting for the other + characters. If "rd" is not intermittent, then "avail(rd)" is equal + to "len(rd)+1". If "rd" is intermittent, then "avail(rd)" can + increase asynchronously, although the procedures in this interface + are atomic with respect to such increases. + + The definitions above encompass readers with infinite sources. If + "rd" is such a reader, then "len(rd)" and "len(rd)+1" are both + infinity, and there is no final "eof" value. + + Every reader is a monitor; that is, it contains an internal lock + that is acquired and held for each operation in this interface, so + that concurrent operations will appear atomic. For faster, + unmonitored access, see the "UnsafeRd" interface. + + If you are implementing a long-lived reader class, such as a pipe + or TCP stream, the index of the reader may eventually overflow, + causing the program to crash with a bounds fault. We recommend + that you provide an operation to reset the reader index, which the + client can call periodically. *) + +INTERFACE Rd; + +IMPORT AtomList; +FROM Thread IMPORT Alerted; + +TYPE T <: ROOT; + +EXCEPTION EndOfFile; Failure(AtomList.T); + +(* Since there are many classes of readers, there are many ways that a + reader can break---for example, the connection to a terminal can be + broken, the disk can signal a read error, etc. All problems of + this sort are reported by raising the exception "Failure". The + documentation of a reader class should specify what failures the + class can raise and how they are encoded in the argument to + "Failure". + + Illegal operations cause a checked runtime error. *) + +PROCEDURE GetChar(rd: T): CHAR + RAISES {EndOfFile, Failure, Alerted}; +(* Return the next character from "rd". More precisely, this is + equivalent to the following, in which "res" is a local variable of + type "CHAR": *) +(* +| IF closed(rd) THEN `Cause checked runtime error` END; +| `Block until "avail(rd) > cur(rd)"`; +| IF cur(rd) = len(rd) THEN +| RAISE EndOfFile +| ELSE +| res := src(rd)[cur(rd)]; INC(cur(rd)); RETURN res +| END +*) + +PROCEDURE GetWideChar(rd: T): WIDECHAR + RAISES {EndOfFile, Failure, Alerted}; +(* IF closed(rd) THEN `Cause checked runtime error` END; + Return the next wide character from "rd". Two 8-bit bytes are + read from "rd" and concatenated in little-endian order to + form a 16-bit character. That is, the first byte read will be the + low-order 8 bits of the result and the second byte will be the + high-order 8 bits. *) + +(* Many operations on a reader can wait indefinitely. For example, + "GetChar" can wait if the user is not typing. In general these waits + are alertable, so each procedure that might wait includes + "Thread.Alerted" in its "RAISES" clause. *) + +PROCEDURE EOF(rd: T): BOOLEAN RAISES {Failure, Alerted}; +(* Return "TRUE" iff "rd" is at end-of-file. More precisely, this is + equivalent to: *) +(* +| IF closed(rd) THEN `Cause checked runtime error` END; +| `Block until "avail(rd) > cur(rd)"`; +| RETURN cur(rd) = len(rd) +*) + +(* Notice that on an intermittent reader, "EOF" can block. For example, if + there are no characters buffered in a terminal reader, "EOF" must wait + until the user types one before it can determine whether he typed the + special key signalling end-of-file. If you are using "EOF" in an + interactive input loop, the right sequence of operations is: + \begin{enumerate} + \item prompt the user; + \item call "EOF", which probably waits on user input; + \item presuming that "EOF" returned "FALSE", read the user's input. + \end{enumerate} *) + +PROCEDURE UnGetChar(rd: T) RAISES {}; +(* ``Push back'' the last character read from "rd", so that the next + call to "GetChar" will read it again. More precisely, this is + equivalent to the following: *) +(* +| IF closed(rd) THEN `Cause checked runtime error` END; +| IF cur(rd) > 0 THEN DEC(cur(rd)) END + + except there is a special rule: "UngetChar(rd)" is guaranteed to work only + if "GetChar(rd)" or "EOF(rd)" was the last operation on "rd". Thus + "UngetChar" cannot be called twice in a row, or after "Seek". + If this rule is violated, the implementation is allowed (but + not required) to cause a checked runtime error. *) + +CONST UnGetCapacity = 8; +TYPE UnGetCount = [ 0 .. UnGetCapacity ]; + +PROCEDURE UnGetCharMulti(rd: T; n: UnGetCount:= 1): CARDINAL (* Number actually ungotten.*); +(* Like UnGetChar, but try to push back the last n characters. Can accumulate at + least MIN(UnGetCapacity,Index(rd)) ungotten and not reread characters. + UnGetCharMulti reserves the right to exceed this on some calls. Result may be less + than n, if this would be exceeded. +*) + +PROCEDURE CharsReady(rd: T): CARDINAL RAISES {Failure}; +(* Return some number of characters that can be read without + indefinite waiting. The ``end of file marker'' counts as one + character for this purpose, so "CharsReady" will return 1, not 0, + if "EOF(rd)" is true. More precisely, this is equivalent to the + following: *) +(* +| IF closed(rd) THEN `Cause checked runtime error` END; +| IF avail(rd) = cur(rd) THEN +| RETURN 0 +| ELSE +| RETURN `some number in the range "[1~..~avail(rd) - cur(rd)]"` +| END; +*) + +(* Warning: "CharsReady" can return a result less than "avail(rd) - + cur(rd)"; also, more characters might trickle in just as + "CharsReady" returns. So the code to flush buffered input without + blocking requires a loop: + +| LOOP +| n := Rd.CharsReady(rd); +| IF n = 0 THEN EXIT END; +| FOR i := 1 TO n DO EVAL Rd.GetChar(rd) END +| END; +*) + +PROCEDURE GetSub(rd: T; VAR (*OUT*) str: ARRAY OF CHAR) + : CARDINAL RAISES {Failure, Alerted}; +(* Read from "rd" into "str" until "rd" is exhausted or "str" is + filled. More precisely, this is equivalent to the following, in + which "i" is a local variable: *) +(* +| IF closed(rd) THEN `Cause checked runtime error` END; +| i := 0; +| WHILE i # NUMBER(str) AND NOT EOF(rd) DO +| str[i] := GetChar(rd); INC(i) +| END; +| RETURN i +*) + +PROCEDURE GetWideSub(rd: T; VAR (*OUT*) str: ARRAY OF WIDECHAR) + : CARDINAL RAISES {Failure, Alerted}; +(* Read from "rd" into "str" until "rd" is exhausted or "str" is + filled. More precisely, this is equivalent to the following, in + which "i" is a local variable: *) +(* +| IF closed(rd) THEN `Cause checked runtime error` END; +| i := 0; +| WHILE i # NUMBER(str) AND NOT EOF(rd) DO +| str[i] := GetWideChar(rd); INC(i) +| END; +| RETURN i +*) + +PROCEDURE GetSubLine(rd: T; VAR (*OUT*) str: ARRAY OF CHAR) + : CARDINAL RAISES {Failure, Alerted}; +(* Read from "rd" into "str" until a newline is read, "rd" is + exhausted, or "str" is filled. More precisely, this is equivalent + to the following, in which "i" is a local variable: *) +(* +| IF closed(rd) AND NUMBER(str) > 0 THEN `Cause checked runtime error` END; +| i := 0; +| WHILE +| i # NUMBER(str) AND +| (i = 0 OR str[i-1] # '\n') AND +| NOT EOF(rd) +| DO +| str[i] := GetChar(rd); INC(i) +| END; +| RETURN i +*) + +(* Note that "GetLine" strips the terminating line break, while + "GetSubLine" does not. *) + +PROCEDURE GetWideSubLine(rd: T; VAR (*OUT*) str: ARRAY OF WIDECHAR) + : CARDINAL RAISES {Failure, Alerted}; +(* Read from "rd" into "str" until a newline is read, "rd" is + exhausted, or "str" is filled. *) + +PROCEDURE GetText(rd: T; len: CARDINAL): TEXT + RAISES {Failure, Alerted}; +(* Read from "rd" until it is exhausted or "len" characters have been + read, and return the result as a "TEXT". More precisely, this is + equivalent to the following, in which "i" and "res" are local + variables: *) +(* +| IF closed(rd) THEN `Cause checked runtime error` END; +| res := ""; i := 0; +| WHILE i # len AND NOT EOF(rd) DO +| res := res & Text.FromChar(GetChar(rd)); +| INC(i) +| END; +| RETURN res +*) + +PROCEDURE GetWideText(rd: T; len: CARDINAL): TEXT + RAISES {Failure, Alerted}; +(* Read from "rd" until it is exhausted or "len" wide characters have been + read, and return the result as a "TEXT". More precisely, this is + equivalent to the following, in which "i" and "res" are local + variables: *) +(* +| IF closed(rd) THEN `Cause checked runtime error` END; +| res := ""; i := 0; +| WHILE i # len AND NOT EOF(rd) DO +| res := res & Text.FromWideChar(GetChar(rd)); +| INC(i) +| END; +| RETURN res +*) + +PROCEDURE GetLine(rd: T): TEXT + RAISES {EndOfFile, Failure, Alerted}; +(* If "EOF(rd)" then raise "EndOfFile". Otherwise, read characters + until a line break is read or "rd" is exhausted, and return the + result as a "TEXT"---but discard the line break if it is present. + A line break is either {\tt \char'42\char'134n\char'42} or {\tt + \char'42\char'134r\char'134n\char'42} More precisely, this is + equivalent to the following, in which "ch" and "res" are local + variables: *) +(* +| IF closed(rd) THEN `Cause checked runtime error` END; +| IF EOF(rd) THEN RAISE EndOfFile END; +| res := ""; ch := '\000'; (* any char but newline *) +| WHILE ch # '\n' AND NOT EOF(rd) DO +| ch := GetChar(rd); +| IF ch = '\n' THEN +| IF NOT Text.Empty(res) AND +| Text.GetChar(res, Text.Length(res)-1) = '\r' THEN +| res := Text.Sub(res, 0, Text.Length(res)-1) +| END +| ELSE +| res := res & Text.FromChar(ch) +| END +| RETURN res +*) + +PROCEDURE GetWideLine(rd: T): TEXT + RAISES {EndOfFile, Failure, Alerted}; +(* If "EOF(rd)" then raise "EndOfFile". Otherwise, read wide characters + until a line break is read or "rd" is exhausted, and return the + result as a "TEXT"---but discard the line break if it is present. + A line break is either {\tt \char'42\char'134n\char'42} or {\tt + \char'42\char'134r\char'134n\char'42}. *) + +PROCEDURE Seek(rd: T; n: CARDINAL) RAISES {Failure, Alerted}; +(* This is equivalent to: *) +(* +| IF closed(rd) OR NOT seekable(rd) THEN +| `Cause checked runtime error` +| END; +| cur(rd) := MIN(n, len(rd)) +*) + +PROCEDURE Close(rd: T) RAISES {Failure, Alerted}; +(* Release any resources associated with "rd" and set "closed(rd) := + TRUE". The documentation of a procedure that creates a reader + should specify what resources are released when the reader is + closed. This leaves "rd" closed even if it raises an exception, + and is a no-op if "rd" is closed. *) + +PROCEDURE Index(rd: T): CARDINAL RAISES {}; +(* This is equivalent to: *) +(* +| IF closed(rd) THEN `Cause checked runtime error` END; +| RETURN cur(rd) +*) + +PROCEDURE Length(rd: T): INTEGER RAISES {Failure, Alerted}; +(* This is equivalent to: *) +(* +| IF closed(rd) THEN +| `Cause checked runtime error` +| END; +| RETURN len(rd) + + If "len(rd)" is unknown to the implementation of an intermittent + reader, "Length(rd)" returns -1. *) + +PROCEDURE Intermittent(rd: T): BOOLEAN RAISES {}; +PROCEDURE Seekable(rd: T): BOOLEAN RAISES {}; +PROCEDURE Closed(rd: T): BOOLEAN RAISES {}; +(* Return "intermittent(rd)", "seekable(rd)", and "closed(rd)", + respectively. These can be applied to closed readers. *) + +END Rd. diff --git a/samples/Modula-3/Rd.m3 b/samples/Modula-3/Rd.m3 new file mode 100644 index 0000000000..154069e146 --- /dev/null +++ b/samples/Modula-3/Rd.m3 @@ -0,0 +1,811 @@ +(* Copyright (C) 1989, Digital Equipment Corporation *) +(* All rights reserved. *) +(* See the file COPYRIGHT for a full description. *) + +(* Last modified on Thu Jan 26 13:58:35 PST 1995 by kalsow *) +(* modified on Fri Jun 18 18:12:46 PDT 1993 by wobber *) +(* modified on Tue Jun 15 13:41:05 1993 by gnelson *) +(* modified on Mon May 31 06:25:34 PDT 1993 by swart *) +(* modified on Mon Apr 26 17:22:58 PDT 1993 by mcjones *) +(* modified on Tue Apr 21 15:56:06 PDT 1992 by muller *) + +(* This module is very similar to the Wr module, so we will list +its code with only a few comments. *) + +MODULE Rd EXPORTS Rd, RdClass, UnsafeRd; +IMPORT Text, Text8, Thread, Word; +FROM Thread IMPORT Alerted; + +REVEAL + Private = Thread.Mutex BRANDED OBJECT END; + +(* FastGetChar and GetChar are identical except that GetChar acquires + and releases the lock while FastGetChar assumes it is already held. *) + +(* It is invariant that for a closed reader "rd", "rd.buff = NIL" and + "rd.lo = rd.cur = rd.hi". Therefore the check that "rd" is ready need + not inspect "rd.closed" on the fast path. *) + +PROCEDURE Init(rd: T) = +(* Class-independent initialize rd, including private fields revealed herein. *) + + BEGIN + rd.buff := NIL; + rd.Ungetbuff := NIL; + rd.Waitingbuff := NIL; + rd.st := 0; + rd.Ungetst := 0; + rd.Waitingst := 0; + rd.cur := 0; + rd.lo := 0; + rd.hi := 0; + rd.Ungetlo := 0; + rd.Ungethi := 0; + rd.Waitinglo := 0; + rd.Waitinghi := 0; + rd.closed := TRUE; + END Init; + +<* UNUSED *> PROCEDURE Check(rd: T): BOOLEAN (* It's OK. *) = + (* Check some invariants on rd. *) + + BEGIN + IF rd.closed + THEN + (* V4. *) + IF rd.buff # NIL + THEN RETURN FALSE END; + IF rd.lo # 0 + THEN RETURN FALSE END; + IF rd.hi # 0 + THEN RETURN FALSE END; + ELSE + IF rd.Ungetbuff # NIL + AND rd.Ungetbuff # rd.buff + AND rd.Ungetlo < rd.Ungethi + AND rd.Ungethi # rd.lo + THEN RETURN FALSE + END; + (* V2. *) + IF rd.cur < rd.lo + THEN RETURN FALSE END; + IF rd.cur > rd.hi + THEN RETURN FALSE END; + (* V3. *) + IF rd.intermittent AND rd.seekable THEN RETURN FALSE END; + END; + RETURN TRUE + END Check; + +PROCEDURE NextBuff(rd: T; dontBlock: BOOLEAN): SeekResult + RAISES {Failure, Alerted} = + (* rd is locked, not closed, and rd.cur=rd.hi. *) + (* If we are now in the unget buffer, switch to the waiting buffer. + Otherwise, save characters as needed in the unget buffer, then use + seek to get the next regular buffer. + *) + VAR LByteCt, LByteCtUnget: CARDINAL; + VAR LUngetlo, LUngethi, LUngetst: CARDINAL; + VAR LResult: SeekResult; + VAR LUngetbuff: ARRAY [0..UnGetCapacity-1] OF CHAR; + BEGIN + (*<* ASSERT Check(rd) *>*) + IF rd.Ungetbuff # NIL (* There is an unget buffer, *) + AND rd.Ungetbuff = rd.buff + (* and it is current, which implies we are now off its right end. *) + THEN (* Make the waiting buffer current. *) + rd.buff := rd.Waitingbuff; + rd.st := rd.Waitingst; + rd.lo := rd.Waitinglo; + rd.hi := rd.Waitinghi; + rd.Waitingbuff := NIL; (* Defensive. *) + (* The unget buffer will remain unchanged, in case UngetChar requires + us to back up into it again. *) + (*<* ASSERT Check(rd) *>*) + IF rd.cur < rd.hi THEN (*<* ASSERT Check(rd) *>*) RETURN SeekResult.Ready + END; + END; + + (* We are not in the unget buffer. Need to seek, but first, save some + chars to go in the new unget buffer. We have to save them before + seeking, but won't know until after, whether to alter the real unget + buffer and its subscripts. So do the saving in locals for now. *) + IF rd.buff # NIL + THEN (* There are some chars to save. *) + IF rd.hi - rd.lo >= UnGetCapacity + THEN (* Current buffer contains at least UnGetCapacity chars. Save the + last UnGetCapacity of them in locals. Don't save anything from + Ungetbuff. *) + LUngethi := rd.hi; + LUngetlo := rd.hi - UnGetCapacity; + LUngetst := 0; + LUngetbuff + := SUBARRAY(rd.buff^, LUngetlo - rd.lo + rd.st, UnGetCapacity); + ELSE + (* Here, buff has fewer chars than UnGetCapacity. *) + IF rd.Ungetbuff = NIL OR rd.Ungetlo >= rd.Ungethi + THEN (* Unallocated or empty unget buffer. Save only from the current + buffer. *) + LByteCt := rd.hi - rd.lo; + LUngetst := UnGetCapacity - LByteCt; + LUngetlo := rd.lo; + LUngethi := rd.hi; + SUBARRAY(LUngetbuff, LUngetst, LByteCt) + := SUBARRAY(rd.buff^, rd.st, LByteCt); + ELSE (* Save chars for the unget buffer from both its current contents + (shifted left) and the current buffer. *) + LByteCt := rd.hi - rd.lo; + LByteCtUnget := rd.Ungethi - rd.Ungetlo; + IF LByteCt + LByteCtUnget > UnGetCapacity + THEN (* Push some bytes off the left of the unget buffer. *) + LByteCtUnget := UnGetCapacity - LByteCt; + LUngetst := 0; + LUngetlo := rd.hi - UnGetCapacity; + ELSE + LUngetst := UnGetCapacity - LByteCt - LByteCtUnget; + LUngetlo := rd.hi - LByteCt - LByteCtUnget; + END; + LUngethi := rd.hi; + SUBARRAY ( LUngetbuff, LUngetst, LByteCtUnget) + := SUBARRAY + (rd.Ungetbuff^, UnGetCapacity - LByteCtUnget, LByteCtUnget); + SUBARRAY ( LUngetbuff, UnGetCapacity - LByteCt, LByteCt) + := SUBARRAY (rd.buff^, rd.st, LByteCt); + END + END + END; + + (* Try to get the next buffer from class implementation: *) + LResult := rd.seek(rd.cur, dontBlock); + (* seek methods vary in what they do with buff at EOF. E.g., FileRd + advances to a new but empty buffer (lo=hi=cur=len), but TextRd leaves + lo=0, preserving the text for subsequent seek back inside it. We want + to update the Unget buffer only if seek advanced lo. *) + IF rd.lo = LUngethi + THEN (* Update the unget buffer. *) + IF rd.Ungetbuff = NIL + THEN rd.Ungetbuff := NEW (REF ARRAY OF CHAR, UnGetCapacity); + END; + rd.Ungetst := LUngetst; + rd.Ungetlo := LUngetlo; + rd.Ungethi := LUngethi; + rd.Ungetbuff^ := LUngetbuff; + END; + (*<* ASSERT Check(rd) *>*) + RETURN LResult; + END NextBuff; + +<*INLINE*> +PROCEDURE GetChar (rd: T): CHAR + RAISES {EndOfFile, Failure, Alerted} = + BEGIN + LOCK rd DO + RETURN FastGetChar(rd); + END + END GetChar; + +<*INLINE*> +PROCEDURE FastGetChar(rd: T): CHAR + RAISES {EndOfFile, Failure, Alerted} = + (* rd is locked *) + VAR res: CHAR; + BEGIN + IF rd.closed THEN Die() END; + IF rd.cur = rd.hi THEN + IF NextBuff(rd, dontBlock:= FALSE) = SeekResult.Eof THEN RAISE EndOfFile END + END; + res := rd.buff[rd.st + (rd.cur - rd.lo)]; + INC(rd.cur); + RETURN res + END FastGetChar; + +<*INLINE*> +PROCEDURE GetWideChar (rd: T): WIDECHAR + RAISES {EndOfFile, Failure, Alerted} = + BEGIN + LOCK rd DO + RETURN FastGetWideChar(rd); + END + END GetWideChar; + +<*INLINE*> +PROCEDURE FastGetWideChar(rd: T): WIDECHAR + RAISES {EndOfFile, Failure, Alerted} = + (* rd is locked *) + VAR ch: WIDECHAR; + BEGIN + IF rd.closed THEN Die() END; + IF NOT GetWC (rd, ch) THEN RAISE EndOfFile; END; + RETURN ch; + END FastGetWideChar; + +<*INLINE*> +PROCEDURE GetWC(rd: T; VAR(*OUT*) ch: WIDECHAR): BOOLEAN + RAISES {Failure, Alerted} = + (* rd is locked and not closed. *) + VAR c1, c2: CHAR; + BEGIN + + IF rd.cur = rd.hi THEN + IF NextBuff (rd, dontBlock:= FALSE) = SeekResult.Eof THEN RETURN FALSE; END; + END; + c1 := rd.buff[rd.st + (rd.cur - rd.lo)]; + INC(rd.cur); + + IF rd.cur # rd.hi THEN + c2 := rd.buff[rd.st + (rd.cur - rd.lo)]; + INC(rd.cur); + ELSIF NextBuff (rd, dontBlock:= FALSE) = SeekResult.Eof THEN + c2 := '\x00'; + ELSE + c2 := rd.buff[rd.st + (rd.cur - rd.lo)]; + INC(rd.cur); + END; + + ch := VAL (Word.LeftShift (ORD (c2), 8) + ORD (c1), WIDECHAR); + RETURN TRUE; + END GetWC; + +PROCEDURE GetSub (rd: T; VAR (*out*) str: ARRAY OF CHAR): CARDINAL + RAISES {Failure, Alerted} = + BEGIN + LOCK rd DO + RETURN FastGetSub(rd, str); + END + END GetSub; + +PROCEDURE FastGetSub (rd: T; VAR (*out*) str: ARRAY OF CHAR): CARDINAL + RAISES {Failure, Alerted} = + VAR NextStr, Hi, AvailInBuff, Ct: INTEGER; + BEGIN + IF rd.closed THEN Die() END; + NextStr := 0; + Hi := NUMBER(str); + LOOP + IF NextStr >= Hi THEN (* We filled str. *) EXIT END; + AvailInBuff := rd.hi - rd.cur; + IF AvailInBuff <= 0 THEN + IF NextBuff (rd, dontBlock:= FALSE) = SeekResult.Eof THEN EXIT + ELSE AvailInBuff := rd.hi - rd.cur; + END; + END; + Ct := MIN (Hi-NextStr, AvailInBuff); + SUBARRAY(str, NextStr, Ct) + := SUBARRAY(rd.buff^, rd.st + (rd.cur - rd.lo), Ct); + INC (NextStr, Ct); + INC (rd.cur, Ct); + END (* LOOP *); + RETURN NextStr; + END FastGetSub; + +PROCEDURE GetWideSub (rd: T; VAR (*out*) str: ARRAY OF WIDECHAR): CARDINAL + RAISES {Failure, Alerted} = + BEGIN + LOCK rd DO + RETURN FastGetWideSub(rd, str); + END; + END GetWideSub; + +PROCEDURE FastGetWideSub (rd: T; VAR (*out*) str: ARRAY OF WIDECHAR): CARDINAL + RAISES {Failure, Alerted} = + VAR len := 0; WCh: WIDECHAR; + BEGIN + IF rd.closed THEN Die() END; + WHILE (len < NUMBER (str)) AND GetWC (rd, WCh) DO + str[len] := WCh; INC (len); + END; + RETURN len; + END FastGetWideSub; + +PROCEDURE GetSubDefault (rd: T; VAR (*out*) str: ARRAY OF CHAR): CARDINAL + RAISES {Failure, Alerted} = + (* rd is locked and not closed. *) + VAR i := 0; BEGIN + LOOP + (* i chars have been read into str *) + IF i = NUMBER(str) THEN EXIT END; + IF rd.cur = rd.hi THEN + IF NextBuff (rd, dontBlock:= FALSE) = SeekResult.Eof THEN EXIT END + END; + (* rd.lo <= rd.cur < rd.hi *) + VAR n := MIN(rd.hi - rd.cur, NUMBER(str) - i); BEGIN + SUBARRAY(str, i, n) := + SUBARRAY(rd.buff^, rd.cur - rd.lo + rd.st, n); + INC(i, n); + INC(rd.cur, n) + END + END; + RETURN i + END GetSubDefault; + +(* EOF and FastEOF are identical except that EOF acquires and releases + the reader lock while FastEOF assumes it is already held. *) + +<*INLINE*> +PROCEDURE EOF (rd: T): BOOLEAN + RAISES {Failure, Alerted} = + (* rd is unlocked *) + BEGIN + LOCK rd DO + RETURN FastEOF(rd); + END + END EOF; + +<*INLINE*> +PROCEDURE FastEOF (rd: T): BOOLEAN + RAISES {Failure, Alerted} = + BEGIN + (* rd is locked *) + IF rd.closed THEN Die() END; + IF rd.cur # rd.hi THEN + RETURN FALSE + ELSE + RETURN NextBuff (rd, dontBlock:= FALSE) = SeekResult.Eof + END + END FastEOF; + +PROCEDURE UnGetChar(rd: T) RAISES {} = + BEGIN + LOCK rd DO EVAL FastUnGetCharMulti (rd, 1) END; + (* Just silently fail if can't do it. This duplicates + original behaviour. *) + END UnGetChar; + +PROCEDURE FastUnGetChar(rd: T) RAISES {} = +(* Like Rd.FastUnGetChar, but rd must be locked. *) + BEGIN + EVAL FastUnGetCharMulti (rd, 1) + (* Just silently fail if can't do it. This duplicates + original behaviour. *) + END FastUnGetChar; + +PROCEDURE UnGetCharMulti(rd: T; n: UnGetCount:= 1): CARDINAL (* Number actually ungotten.*)= + BEGIN + LOCK rd DO RETURN FastUnGetCharMulti (rd, n) END; + END UnGetCharMulti; + +PROCEDURE FastUnGetCharMulti(rd: T; n: UnGetCount:= 1) + : CARDINAL (* Number actually ungotten.*) = + VAR result, avail: CARDINAL; + BEGIN + IF rd.closed THEN Die() END; + (*<* ASSERT Check(rd) *>*) + IF rd.cur - n >= rd.lo THEN (* Can do this within buff. *) + DEC(rd.cur, n); + (*<* ASSERT Check(rd) *>*) + RETURN n + ELSE (* First Unget what we can within rd.buff. *) + result := rd.cur - rd.lo; + rd.cur := rd.lo; + DEC (n, result); + (* Now look for saved ungettable characters. *) + IF rd.Ungetbuff # NIL (* We have an unget buffer *) + AND rd.Ungetbuff # rd.buff (* It is not the current buffer. *) + AND rd.Ungethi > rd.Ungetlo (* It is not empty. *) + THEN (* Make the current buff waiting, *) + rd.Waitingbuff := rd.buff; + rd.Waitingst := rd.st; + rd.Waitinglo := rd.lo; + rd.Waitinghi := rd.hi; + (* and back up to the unget buffer. *) + rd.buff := rd.Ungetbuff; + rd.st := rd.Ungetst; + rd.lo := rd.Ungetlo; + rd.hi := rd.Ungethi; + (* Unget within the now-current unget buffer. *) + avail := rd.hi - rd.lo; + n := MIN (n, avail); + DEC (rd.cur, n); + INC (result, n); + (*<* ASSERT Check(rd) *>*) + RETURN result + ELSE (* We have no more stored bytes to unget. *) + (*<* ASSERT Check(rd) *>*) + RETURN result + END + END + END FastUnGetCharMulti; + +PROCEDURE CharsReady(rd: T): CARDINAL + RAISES {Failure} = + <*FATAL Thread.Alerted*> + BEGIN + LOCK rd DO + IF rd.closed THEN Die() END; + IF rd.cur = rd.hi THEN + IF NextBuff (rd, dontBlock:= TRUE) = SeekResult.Eof THEN RETURN 1 END + END; + RETURN rd.hi - rd.cur; + END; + END CharsReady; + +PROCEDURE FastCharsReady(rd: T): CARDINAL + RAISES {Failure} = + <*FATAL Thread.Alerted*> + BEGIN + IF rd.closed THEN Die() END; + IF rd.cur = rd.hi THEN + IF NextBuff (rd, dontBlock:= TRUE) = SeekResult.Eof THEN RETURN 1 END + END; + RETURN rd.hi - rd.cur; + END FastCharsReady; + +PROCEDURE Index(rd: T): CARDINAL = + BEGIN + LOCK rd DO + IF rd.closed THEN Die() END; + RETURN rd.cur + END; + END Index; + +PROCEDURE FastIndex(rd: T): CARDINAL = + BEGIN + IF rd.closed THEN Die() END; + RETURN rd.cur + END FastIndex; + +PROCEDURE Length(rd: T): INTEGER + RAISES {Failure, Alerted} = + BEGIN + LOCK rd DO + IF rd.closed THEN Die() END; + RETURN rd.length() + END + END Length; + +PROCEDURE FastLength(rd: T): INTEGER + RAISES {Failure, Alerted} = + BEGIN + IF rd.closed THEN Die() END; + RETURN rd.length() + END FastLength; + +PROCEDURE Seek(rd: T; n: CARDINAL) + RAISES {Failure, Alerted} = + BEGIN + LOCK rd DO + (*<* ASSERT Check(rd) *>*) + IF rd.closed OR NOT rd.seekable THEN Die() END; + IF n < rd.lo OR n > rd.hi THEN + EVAL rd.seek(n, dontBlock:= FALSE); + rd.Ungetlo := 0; (* Empty the unget buffer, but keep it allocated. *) + rd.Ungethi := 0; + rd.Waitingbuff := NIL; (* Redundant? *) + ELSE + rd.cur := n; + END; + (*<* ASSERT Check(rd) *>*) + END + END Seek; + +PROCEDURE Close(rd: T) + RAISES {Failure, Alerted} = + BEGIN + LOCK rd DO FastClose (rd); END; + END Close; + +PROCEDURE FastClose(rd: T) + RAISES {Failure, Alerted} = + BEGIN + IF NOT rd.closed THEN + TRY + rd.close() + FINALLY + rd.closed := TRUE; + rd.cur := rd.hi; + rd.lo := rd.hi; + rd.buff := NIL; + rd.Ungetlo := 0; + rd.Ungethi := 0; + END + END + END FastClose; + +PROCEDURE GetSubLine (rd: T; VAR(*out*) str: ARRAY OF CHAR): CARDINAL + RAISES {Failure, Alerted} = + VAR i: CARDINAL := 0; + BEGIN + LOCK rd DO + IF rd.closed AND NUMBER(str) > 0 THEN Die () END; + LOOP + (* i chars have been read into str *) + IF i = NUMBER (str) THEN RETURN i END; + IF rd.cur = rd.hi THEN + IF NextBuff (rd, dontBlock:= FALSE) = SeekResult.Eof THEN RETURN i END + END; + (* rd is ready *) + VAR + n := MIN (rd.hi, rd.cur + NUMBER (str) - i) - rd.lo + rd.st; + j := rd.cur - rd.lo + rd.st; + BEGIN + WHILE (j # n) AND (rd.buff[j] # '\n') DO INC (j) END; + VAR + rd_cur := rd.cur - rd.lo + rd.st; + k := j - rd_cur; + BEGIN + SUBARRAY (str, i, k) := SUBARRAY (rd.buff^, rd_cur, k); + INC (i, k); + INC (rd.cur, k); + END; + IF (j # n) THEN + (* we found a newline *) + str[i] := '\n'; + INC (i); + INC (rd.cur); + RETURN i; + END; + END; + END; + END; + END GetSubLine; + +PROCEDURE GetWideSubLine (rd: T; VAR(*out*) str: ARRAY OF WIDECHAR): CARDINAL + RAISES {Failure, Alerted} = + VAR i: CARDINAL := 0; ch: WIDECHAR; + BEGIN + LOCK rd DO + IF rd.closed AND NUMBER(str) > 0 THEN Die () END; + WHILE (i < NUMBER (str)) AND GetWC (rd, ch) DO + str[i] := ch; INC (i); + IF ch = W'\n' THEN RETURN i; END; + END; + RETURN i; + END; + END GetWideSubLine; + +PROCEDURE GetText (rd: T; length: CARDINAL): TEXT + RAISES { Failure, Alerted } = + VAR txt: TEXT; + BEGIN + LOCK rd DO + IF rd.closed THEN Die () END; + + IF (rd.lo <= rd.cur) AND (rd.hi - rd.cur >= length) THEN + (* the bytes we need are already in the buffer *) + txt := Text.FromChars ( + SUBARRAY (rd.buff^, rd.cur - rd.lo + rd.st, length)); + INC (rd.cur, length); + + ELSIF (NOT rd.intermittent) THEN + (* we know how long the reader is... *) + VAR + len := MIN (length, rd.length () - rd.cur); + txt8 := Text8.Create (len); + BEGIN + txt := txt8; + EVAL FastGetSub (rd, SUBARRAY (txt8.contents^, 0, len)); + END; + + ELSE (* general case *) + txt := SlowGetText (rd, length); + END; + END; + RETURN txt; + END GetText; + +TYPE Buffer = REF RECORD next: Buffer; buf: ARRAY [0..2039] OF CHAR END; + +PROCEDURE SlowGetText (rd: T; length: CARDINAL): TEXT + RAISES { Failure, Alerted } = + VAR + copied: CARDINAL := 0; + head : Buffer := NIL; + tail : Buffer := NIL; + BEGIN + + (* build a list of buffers *) + LOOP + IF (copied = length) THEN EXIT END; + VAR b := NEW (Buffer, next := NIL); BEGIN + IF (head = NIL) + THEN head := b; + ELSE tail.next := b; + END; + tail := b; + END; + VAR + n := MIN (length - copied, NUMBER (tail.buf)); + i := FastGetSub (rd, SUBARRAY (tail.buf, 0, n)); + BEGIN + INC (copied, i); + IF (i < n) THEN EXIT END; + END; + END; + + (* assemble the result *) + VAR + txt := Text8.Create (copied); + i := 0; + n : INTEGER; + BEGIN + WHILE (head # NIL) DO + n := MIN (copied - i, NUMBER (head.buf)); + SUBARRAY (txt.contents^, i, n) := SUBARRAY (head.buf, 0, n); + head := head.next; + INC (i, n); + END; + RETURN txt; + END; + END SlowGetText; + +PROCEDURE GetWideText(rd: T; len: CARDINAL): TEXT + RAISES {Failure, Alerted} = + VAR + res, tmp: TEXT; + i, j, n_read: CARDINAL; + buf: ARRAY [0..127] OF WIDECHAR; + BEGIN + IF (len <= NUMBER (buf)) THEN + i := GetWideSub(rd, SUBARRAY(buf, 0, len)); + RETURN Text.FromWideChars (SUBARRAY(buf, 0, i)); + ELSE + res := NIL; n_read := 0; + WHILE (n_read < len) DO + i := MIN (NUMBER (buf), len - n_read); + j := GetWideSub(rd, SUBARRAY (buf, 0, i)); + INC (n_read, j); + IF (j > 0) THEN + tmp := Text.FromWideChars (SUBARRAY (buf, 0, j)); + IF (res = NIL) THEN res := tmp; ELSE res := res & tmp; END; + END; + IF (j < i) THEN EXIT; END; + END; + IF (res = NIL) THEN res := ""; END; + RETURN res; + END; + END GetWideText; + +PROCEDURE GetLine (rd: T): TEXT + RAISES {EndOfFile, Failure, Alerted} = + VAR txt := ""; j, n: INTEGER; + BEGIN + LOCK rd DO + IF rd.closed THEN Die () END; + LOOP (* INV: txt contains the partial result *) + IF rd.cur = rd.hi THEN + IF NextBuff (rd, dontBlock:= FALSE) = SeekResult.Eof THEN + IF (Text.Length (txt) > 0) THEN RETURN txt END; + RAISE EndOfFile; + END; + END; + (* rd is ready *) + n := rd.hi - rd.lo + rd.st; + j := rd.cur - rd.lo + rd.st; + WHILE (j # n) AND rd.buff[j] # '\n' DO INC(j) END; + VAR rd_cur := rd.cur - rd.lo + rd.st; + len := j - rd_cur; + BEGIN + IF len >= 1 AND j # n AND rd.buff[j-1] = '\r' THEN + (* segment ends in \r\n *) + txt := txt & Text.FromChars (SUBARRAY (rd.buff^, rd_cur, len-1)); + INC (rd.cur, len+1); + RETURN txt; + ELSIF j # n THEN + (* segment ends in \n *) + txt := txt & Text.FromChars (SUBARRAY (rd.buff^, rd_cur, len)); + INC (rd.cur, len+1); + IF NOT Text.Empty(txt) AND + Text.GetChar(txt, Text.Length(txt)-1) = '\r' THEN + txt := Text.Sub(txt, 0, Text.Length(txt)-1) + END; + RETURN txt; + ELSE + (* segment does not contain line break *) + txt := txt & Text.FromChars (SUBARRAY (rd.buff^, rd_cur, len)); + INC (rd.cur, len); + END; + END; + END; (* LOOP *) + END; + END GetLine; + +PROCEDURE GetWideLine (rd: T): TEXT + RAISES {EndOfFile, Failure, Alerted} = + VAR + txt, tmp : TEXT := NIL; + len : CARDINAL := 0; + last_ch, ch: WIDECHAR := W'\x0000'; + buf : ARRAY [0..127] OF WIDECHAR; + BEGIN + LOCK rd DO + IF rd.closed THEN Die () END; + last_ch := W' '; + LOOP + IF FastEOF(rd) THEN + IF (txt = NIL) AND (len = 0) THEN RAISE EndOfFile; END; + EXIT; + END; + ch := FastGetWideChar (rd); + IF (ch = W'\n') THEN EXIT; END; + IF len >= NUMBER (buf) THEN + tmp := Text.FromWideChars (buf); + IF (txt = NIL) THEN txt := tmp; ELSE txt := txt & tmp; END; + len := 0; + END; + buf[len] := ch; INC (len); + last_ch := ch; + END; + END; + + IF (ch = W'\n') AND (last_ch = W'\r') AND (len > 0) THEN + (* remove the carriage return before allocating the text *) + DEC (len); last_ch := W' '; + END; + IF (len > 0) THEN + tmp := Text.FromWideChars (SUBARRAY (buf, 0, len)); + IF (txt = NIL) THEN txt := tmp; ELSE txt := txt & tmp; END; + END; + IF (txt = NIL) THEN txt := ""; END; + IF (ch = W'\n') AND (last_ch = W'\r') THEN + txt := Text.Sub (txt, 0, Text.Length (txt) - 1); + END; + RETURN txt; + END GetWideLine; + +PROCEDURE Intermittent (rd: T): BOOLEAN = + BEGIN + LOCK rd DO + RETURN (rd.intermittent); + END; + END Intermittent; + +PROCEDURE FastIntermittent(rd: T): BOOLEAN RAISES {} = + BEGIN + RETURN (rd.intermittent); + END FastIntermittent; + +PROCEDURE Seekable (rd: T): BOOLEAN = + BEGIN + LOCK rd DO + RETURN (rd.seekable); + END; + END Seekable; + +PROCEDURE FastSeekable(rd: T): BOOLEAN RAISES {}= + BEGIN + RETURN (rd.seekable); + END FastSeekable; + +PROCEDURE Closed (rd: T): BOOLEAN = + BEGIN + LOCK rd DO + RETURN (rd.closed); + END; + END Closed; + +PROCEDURE FastClosed(rd: T): BOOLEAN RAISES {}= + BEGIN + RETURN (rd.closed); + END FastClosed; + +PROCEDURE Lock (rd: T) = + BEGIN + Thread.Acquire (rd) + END Lock; + +PROCEDURE Unlock (rd: T) = + BEGIN + Thread.Release (rd) + END Unlock; + +PROCEDURE LengthDefault (<*UNUSED*> rd: T): INTEGER = + BEGIN + <*NOWARN*> Die() + END LengthDefault; + +PROCEDURE CloseDefault(<*UNUSED*> rd: T) = + BEGIN + END CloseDefault; + +(*---------------------------------------------------------- internal ---*) + +EXCEPTION FatalError; + +PROCEDURE Die() = + <* FATAL FatalError *> + BEGIN + RAISE FatalError; + END Die; + +BEGIN +END Rd. diff --git a/samples/Modula-3/RdClass.i3 b/samples/Modula-3/RdClass.i3 new file mode 100644 index 0000000000..971d5757b2 --- /dev/null +++ b/samples/Modula-3/RdClass.i3 @@ -0,0 +1,200 @@ +(* Copyright (C) 1989, Digital Equipment Corporation *) +(* All rights reserved. *) +(* See the file COPYRIGHT for a full description. *) + +(* Last modified on Fri Jun 18 16:18:48 PDT 1993 by wobber *) +(* modified on Tue Jun 15 10:07:07 1993 by gnelson *) +(* modified on Fri May 21 09:50:56 PDT 1993 by swart *) +(* modified on Mon Apr 26 17:22:23 PDT 1993 by mcjones *) +(* modified on Wed Nov 6 10:45:09 PST 1991 by kalsow *) +(* modified on Fri Sep 28 23:12:34 1990 by muller *) + + +(* The RdClass interface is analogous to the WrClass interface. It +reveals that every reader contains a buffer of characters together +with methods for managing the buffer. New reader classes are created +by importing RdClass (to gain access to the buffer and the methods) +and then defining a subclass of Rd.T whose methods provide the new +class's behavior. The opaque type Private hides irrelevant details of +the class-independent code. *) + +INTERFACE RdClass; +IMPORT Rd; +FROM Thread IMPORT Alerted; +FROM Rd IMPORT Failure; + +TYPE + Private <: ROOT; + SeekResult = {Ready, WouldBlock, Eof}; + +REVEAL + Rd.T = + Private BRANDED OBJECT + buff : REF ARRAY OF CHAR := NIL; + Ungetbuff : REF ARRAY OF CHAR := NIL; + Waitingbuff : REF ARRAY OF CHAR := NIL; + st : CARDINAL; (* index into buff *) + Ungetst : CARDINAL; (* index into Ungetbuff *) + Waitingst : CARDINAL; (* index into WaitingBuff *) + cur : CARDINAL := 0; (* index into src(rd) *) + lo, hi : CARDINAL := 0; (* indexes into src(rd) *) + Ungetlo, Ungethi : CARDINAL := 0; (* indexes into src(rd) *) + Waitinglo, Waitinghi : CARDINAL := 0; (* indexes into src(rd) *) + closed: BOOLEAN := TRUE; (* init method of the subtype should set + this to FALSE *) + seekable, intermittent: BOOLEAN; + METHODS + seek (n: CARDINAL; dontBlock: BOOLEAN): SeekResult + RAISES {Failure, Alerted}; + (* ^rd is locked and not closed. *) + getSub (VAR a: ARRAY OF CHAR): CARDINAL + RAISES {Failure, Alerted} := GetSubDefault; + (* ^rd is locked and not closed. *) + length (): INTEGER RAISES {Failure, Alerted} := LengthDefault; + (* ^rd is locked and not closed. *) + close () RAISES {Failure, Alerted} := CloseDefault; + END; + +(* Let rd be a reader, abstractly given by len(rd), src(rd), cur(rd), +avail(rd), closed(rd), seekable(rd), and intermittent(rd). The data +fields cur, closed, seekable, and intermittent in the object represent +the corresponding abstract attributes of rd. The buff, st, lo, and hi +fields represent a buffer that contains part of src(rd), the rest of +which is represented in some class-specific way. + +More precisely, we say that the state of the representation is valid +if conditions V1 through V4 hold: + +V1. the characters of buff in the range [st .. st+(hi-lo)] accurately + reflect src. That is, for all i in [rd.lo .. rd.hi-1], + + rd.buff[rd.st + i - rd.lo] = src(rd)[i] + +V2. the cur field is in or just past the end of the occupied part of the + buffer, that is: + + rd.lo <= rd.cur <= rd.hi + +V3. the reader does not claim to be both intermittent and seekable: + + NOT (rd.intermittent AND rd.seekable) + +It is possible that buff = NIL in a valid state, since the range of +i's in V1 may be empty; for example, in case lo = hi. + +V4. if closed(rd) then rd.buff = NIL AND rd.lo = rd.hi + +If rd is valid and cur(rd) is less than rd.hi, we say the reader +is ready. More precisely, rd is ready if: + + NOT rd.closed AND rd.buff # NIL AND rd.lo <= rd.cur < rd.hi + +If the state is ready, then Rd.GetChar can be implemented by fetching +from the buffer. Together V1, V2, and V4 imply that if rd.cur # rd.hi +then rd.buff # NIL and NOT rd.closed. Therefore a valid reader is ready +if "rd.cur # rd.hi". + +The class-independent code modifies rd.cur, but no other variables +revealed in this interface (except that "Rd.Close" modifies "rd.lo" and +"rd.cur" and sets "rd.buff" to NIL in order to maintain invariant V4). The +class-independent code locks the reader before calling any methods. + +Here are the specifications for the methods: + +The basic purpose of the seek method is to make the reader ready. To +seek to a position n, the class-independent code checks whether the reader +would be ready with rd.cur = n and if so, simply sets rd.cur to n. +If not, it calls rd.seek supplying the position n as argument. +As in the case of writers, the seek method can be called even for an +unseekable reader in the special case of advancing to the next buffer. + +The fields with names beginning with "Unget" describe a buffer of characters +retained in case they need to be reused by UngetChar. The fields with names +beginning with "Waiting" are a buffer once supplied by class-dependent code +but temporarily suspended while characters originally saved in the unget +and then ungotten are being returned. If NIL#Ungetbuff=buff, we are accessing +previously ungotten characters from Ungetbuff^, and Waitingbuff is the buffer +most recently provided by seek. Otherwise, buff is the buffer most recently +provided by seek. Either way, the fast path in class-independent code for +getting characters works the same, using buff, st, lo, and hi, as in the +earlier implementation, and ignoring the other buffer fields. + +Similarly, (class-dependent) seek method bodies use only these same fields. +Only UngetChar and class-independent code surrounding seek method calls need +be aware of the additional two buffer pointers and their subscripts. + +There is a wrinkle to support the implementation of CharsReady. If rd +is ready, the class-independent code can handle the call to +CharsReady(rd) without calling any methods (since there is at least +one character ready in the buffer), but if rd.cur = rd.hi, then the +class independent code needs to find out from the class implementation +whether any characters are ready in the next buffer. Using the seek +method to advance to the next buffer won't do, since this could block, +and CharsReady isn't supposed to block. Therefore, the seek method +takes a boolean argument saying whether blocking is allowed. If +blocking is forbidden and the next buffer isn't ready, the method +returns the special value WouldBlock; this allows the +class-independent code to return zero from CharsReady. The "dontBlock" +boolean should be "TRUE" only if the seek method is being used to advance +to the next buffer. + +More precisely, given a valid state where + + (n # rd.hi) => rd.seekable +AND (dontBlock => n = rd.hi) + +the call res := rd.seek(n, dontBlock) establishes a valid state. +Furthermore, if res = Ready then rd is ready and rd.cur = n; +while if res = Eof, then rd.cur = len(rd); and finally if res = WouldBlock +then dontBlock was TRUE and avail(rd) = cur(rd). + +The getSub method is used to implement Rd.GetSub and is +called with the reader lock held and the reader not closed. Efficient +implementations override this method to avoid unnecessary copying by reading +directly from the reader source, bypassing the reader buffer. The default +implementation is correct for any class, but always copies through +the reader buffer. + +The length method returns the length of a non-intermittent reader. +That is: Given a valid state in which rd.intermittent is FALSE, the +call rd.length() returns len(rd) without changing the state of rd. An +intermittent reader may return the length if it is known, or -1. + +The close method releases all resources associated with rd. The exact +meaning of this is class-specific. "Rd.Close" sets the "buff" field +to "NIL", so the method need not do this. When the method is +called the state will be valid; validity is not required when the +method returns (since after it returns, the class-independent code +will set the closed bit in the reader, which makes the rest of +the state irrelevant). + +The remainder of the interface is similar to the corresponding part +of the WrClass interface: *) + +PROCEDURE Init(rd: Rd.T); +(* Class-independent initialize rd, including private fields revealed herein. *) + +PROCEDURE Lock(rd: Rd.T) RAISES {}; +(* The reader rd must be unlocked; lock it and make its state valid. *) + +PROCEDURE Unlock(rd: Rd.T) RAISES {}; +(* The reader rd must be locked and valid; unlock it and restore the +private invariant of the reader implementation. *) + +PROCEDURE GetSubDefault(rd: Rd.T; VAR (*OUT*) str: ARRAY OF CHAR): CARDINAL + RAISES {Failure, Alerted}; + (* rd is locked and not closed. *) +(* Implement "getSub" by copying from the buffer, calling the "seek" + method as necessary. Clients can override this in order to + achieve greater efficiency; for example, by copying directly + from the source of the reader into "str". *) + +PROCEDURE LengthDefault(rd: Rd.T): INTEGER RAISES {Failure, Alerted}; +(* The procedure LengthDefault causes a checked runtime error; this +represents an error in the (non-intermittent) class implementation. *) + +PROCEDURE CloseDefault(rd: Rd.T) RAISES {Failure, Alerted}; +(* The procedure CloseDefault is a no-op. *) + +END RdClass. + diff --git a/samples/Quake/filenames/m3makefile b/samples/Quake/filenames/m3makefile new file mode 100644 index 0000000000..645aefca79 --- /dev/null +++ b/samples/Quake/filenames/m3makefile @@ -0,0 +1,52 @@ +% Copyright (C) 1992, Digital Equipment Corporation +% All rights reserved. +% See the file COPYRIGHT for a full description. +% +% Last modified on Thu Dec 1 09:42:32 PST 1994 by kalsow +% modified on Tue Aug 24 15:08:42 PDT 1993 by heydon +% modified on Mon May 24 12:00:19 PDT 1993 by swart +% modified on Fri May 7 12:06:08 PDT 1993 by mjordan +% modified on Thu Dec 31 16:23:49 PST 1992 by mcjones +% modified on Wed May 20 21:18:03 PDT 1992 by muller +% modified on Fri Feb 28 13:50:29 PST 1992 by meehan + +import ("m3core") + +%----------------------------------------------- machine dependent packages --- + +include_dir ("os") +include_dir ("random") +include_dir ("uid") + +%--------------------------------------------- machine independent packages --- + +include_dir ("rw") +include_dir ("fmtlex") +include_dir ("list") +include_dir ("sx") +% include_dir ("types") % which no longer has an m3makefile +include_dir ("arith") +include_dir ("geometry") +include_dir ("statistics") +include_dir ("formatter") +include_dir ("params") +include_dir ("property") +include_dir ("table") +include_dir ("atom") +include_dir ("sortedtable") +include_dir ("sort") +include_dir ("sequence") +include_dir ("etimer") +include_dir ("bundleintf") +include_dir ("perftool") +include_dir ("pqueue") +include_dir ("sqrt") +%include_dir ("config") % see m3quake/MxConfig instead +include_dir ("pickle") +include_dir ("text") +include_dir ("hash") + +% m3_option ("-times") + +Library ("m3") + diff --git a/samples/Quake/filenames/m3overrides b/samples/Quake/filenames/m3overrides new file mode 100644 index 0000000000..6087405737 --- /dev/null +++ b/samples/Quake/filenames/m3overrides @@ -0,0 +1,3 @@ +include(ROOT & "/m3overrides") +M3_FRONT_FLAGS += "-vsdebug" +_M3BUNDLE_OVERRIDE = "T" diff --git a/vendor/README.md b/vendor/README.md index cae50c95db..2da2286473 100644 --- a/vendor/README.md +++ b/vendor/README.md @@ -228,6 +228,7 @@ This is a list of grammars that Linguist selects to provide syntax highlighting - **Mirah:** [atom/language-ruby](https://github.com/atom/language-ruby) - **Modelica:** [BorisChumichev/modelicaSublimeTextPackage](https://github.com/BorisChumichev/modelicaSublimeTextPackage) - **Modula-2:** [harogaston/Sublime-Modula-2](https://github.com/harogaston/Sublime-Modula-2) +- **Modula-3:** [newgrammars/m3](https://github.com/newgrammars/m3) - **Monkey:** [gingerbeardman/monkey.tmbundle](https://github.com/gingerbeardman/monkey.tmbundle) - **MoonScript:** [leafo/moonscript-tmbundle](https://github.com/leafo/moonscript-tmbundle) - **MQL4:** [mqsoft/MQL5-sublime](https://github.com/mqsoft/MQL5-sublime) @@ -299,6 +300,7 @@ This is a list of grammars that Linguist selects to provide syntax highlighting - **q:** [komsit37/sublime-q](https://github.com/komsit37/sublime-q) - **QMake:** [textmate/cpp-qt.tmbundle](https://github.com/textmate/cpp-qt.tmbundle) - **QML:** [skozlovf/Sublime-QML](https://github.com/skozlovf/Sublime-QML) +- **Quake:** [newgrammars/quake](https://github.com/newgrammars/quake) - **R:** [textmate/r.tmbundle](https://github.com/textmate/r.tmbundle) - **Racket:** [soegaard/racket-highlight-for-github](https://github.com/soegaard/racket-highlight-for-github) - **RAML:** [atom/language-yaml](https://github.com/atom/language-yaml) diff --git a/vendor/grammars/m3 b/vendor/grammars/m3 new file mode 160000 index 0000000000..05e38bf044 --- /dev/null +++ b/vendor/grammars/m3 @@ -0,0 +1 @@ +Subproject commit 05e38bf044ccb5aa4f36bfd0c9c5dbbff3e710c0 diff --git a/vendor/grammars/quake b/vendor/grammars/quake new file mode 160000 index 0000000000..f97d81dc4e --- /dev/null +++ b/vendor/grammars/quake @@ -0,0 +1 @@ +Subproject commit f97d81dc4ef3a144dee46a898dde59d272c26db9 diff --git a/vendor/licenses/grammar/m3.txt b/vendor/licenses/grammar/m3.txt new file mode 100644 index 0000000000..d306e87d27 --- /dev/null +++ b/vendor/licenses/grammar/m3.txt @@ -0,0 +1,35 @@ +--- +type: grammar +name: m3 +license: bsd-3-clause +--- +BSD 3-Clause License + +Copyright (c) 2018, newgrammars +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +* Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + diff --git a/vendor/licenses/grammar/quake.txt b/vendor/licenses/grammar/quake.txt new file mode 100644 index 0000000000..a7fa1578bd --- /dev/null +++ b/vendor/licenses/grammar/quake.txt @@ -0,0 +1,34 @@ +--- +type: grammar +name: quake +license: bsd-3-clause +--- +BSD 3-Clause License + +Copyright (c) 2018, newgrammars +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +* Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.