1(* 2 Copyright (c) 2009, 2015, 2016 David C.J. Matthews 3 4 This library is free software; you can redistribute it and/or 5 modify it under the terms of the GNU Lesser General Public 6 License version 2.1 as published by the Free Software Foundation. 7 8 This library is distributed in the hope that it will be useful, 9 but WITHOUT ANY WARRANTY; without even the implied warranty of 10 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 11 Lesser General Public License for more details. 12 13 You should have received a copy of the GNU Lesser General Public 14 License along with this library; if not, write to the Free Software 15 Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 16*) 17 18functor ExportTree( 19structure STRUCTVALS : STRUCTVALSIG 20structure PRETTY: PRETTYSIG 21): EXPORTTREESIG = 22struct 23 open PRETTY STRUCTVALS 24 25(* 26 datatype ptProperties = 27 PTprint of FixedInt.int -> pretty (* Print the tree *) 28 | PTtype of types (* Type of an expression *) 29 | PTdeclaredAt of location (* Declaration location for id. *) 30 | PTopenedAt of location (* When an identifier comes from an "open" the location of the open. *) 31 | PTstructureAt of location (* When an identifier comes from open S or S.a the declaration of S. *) 32 | PTreferences of bool * location list (* The references to the ID. The first is true if this is exported. *) 33 | PTparent of unit -> exportTree 34 | PTpreviousSibling of unit -> exportTree 35 | PTnextSibling of unit -> exportTree 36 | PTfirstChild of unit -> exportTree 37 | PTbreakPoint of bool ref 38 | PTcompletions of string list 39 withtype exportTree = location * ptProperties list *) 40 local 41 open Address 42 fun cast p = toAddress(toMachineWord p) 43 in 44 type ptProperties = address 45 type exportTree = location * ptProperties list 46 47 fun PTbreakPoint(bpt: bool ref): ptProperties = cast(0w0, bpt) 48 and PTcompletions(sl: string list): ptProperties = cast(0w1, sl) 49 and PTdeclaredAt(loc: location): ptProperties = cast(0w2, loc) 50 and PTdefId(id: FixedInt.int): ptProperties = cast(0w3, id) 51 and PTfirstChild(entry: unit -> exportTree): ptProperties = cast(0w4, entry) 52 and PTnextSibling(entry: unit -> exportTree): ptProperties = cast(0w5, entry) 53 and PTopenedAt(loc: location): ptProperties = cast(0w6, loc) 54 and PTparent(entry: unit -> exportTree): ptProperties = cast(0w7, entry) 55 and PTpreviousSibling(entry: unit -> exportTree): ptProperties = cast(0w8, entry) 56 and PTprint(pr: FixedInt.int -> pretty): ptProperties = cast(0w9, pr) 57 and PTreferences(exp: bool, locs: location list): ptProperties = cast(0w10, exp, locs) 58 and PTrefId(id: FixedInt.int): ptProperties = cast(0w11, id) 59 and PTstructureAt(loc: location): ptProperties = cast(0w12, loc) 60 and PTtype(typ: types): ptProperties = cast(0w13, typ) 61 end 62 63 (* This representation is exported so we have to use a *) 64 65 type navigation = 66 {parent: (unit -> exportTree) option, 67 next: (unit -> exportTree) option, 68 previous: (unit -> exportTree) option} 69 70 (* Navigate within a list *) 71 fun exportList _ [] = [] 72 | exportList(exp, parent) sl = 73 let 74 fun getEntry(this as (s :: sl), getPrevious) () = 75 exp( 76 { 77 parent = parent, 78 previous = getPrevious, 79 (* If we have a successor then that is the entry and 80 its predecessor returns here. *) 81 next = 82 case sl of 83 [] => NONE 84 | t => SOME(getEntry(t, SOME(getEntry(this, getPrevious)))) 85 }, 86 s 87 ) 88 | getEntry _ () = raise Empty 89 in 90 [PTfirstChild (getEntry(sl, NONE))] 91 end 92 93 fun exportNavigationProps{parent, previous, next} = 94 let 95 fun mapProps(_, NONE) = [] | mapProps(f, SOME v) = [f v] 96 in 97 (* Common properties for navigation and printing. *) 98 mapProps(PTparent, parent) @ 99 mapProps(PTpreviousSibling, previous) @ 100 mapProps(PTnextSibling, next) 101 end 102 103 fun getStringAsTree (navigation, s: string, location: location, otherProps) = 104 (location, otherProps @ exportNavigationProps navigation @ [PTprint(fn _ => PrettyString s)]) 105 106 (* Tag used to indicate the root tree node in the compiler arguments. *) 107 val rootTreeTag: navigation Universal.tag = Universal.tag() 108 109 (* Map value locations into properties. This is used for a reference to 110 an id. *) 111 fun mapLocationProps locs = 112 let 113 fun prop (DeclaredAt loc) = PTdeclaredAt loc 114 | prop (OpenedAt loc) = PTopenedAt loc 115 | prop (StructureAt loc) = PTstructureAt loc 116 | prop (SequenceNo id) = PTrefId id 117 in 118 List.map prop locs 119 end 120 121 (* Defining location. This sequence Id is a PTdefId. 122 Leave PTdeclaredAt for the moment although it's probably unnecessary 123 since this is the declaration location. *) 124 fun definingLocationProps locs = 125 let 126 fun prop (DeclaredAt loc, l) = PTdeclaredAt loc :: l 127 | prop (SequenceNo id, l) = PTdefId id :: l 128 | prop (_, l) = l 129 in 130 List.foldl prop [] locs 131 end 132 133 (* Types that can be shared. *) 134 structure Sharing = 135 struct 136 type types = types 137 and locationProp = locationProp 138 and pretty = pretty 139 and ptProperties = ptProperties 140 end 141 142end; 143