'From Squeak 2.3 of January 14, 1999 on 25 January 1999 at 10:15:17 am'! "Change Set: ThingLab-Predefs Date: 23 January 1999 Organizer: Dan Ingalls This file includes all the ThingLab methods which alter existing Squeak classes. It should be filed in before ThingLab.cs, which is the set of independently added classes comprising ThingLab."! Model subclass: #ThingLabBrowser instanceVariableNames: 'prototypeClass prototypeClassNameList prototypeClassListIndex prototype aspect aspectListIndex tool toolListIndex filter filterListIndex text displayObject ' classVariableNames: 'TextMenu ' poolDictionaries: '' category: 'ThingLab-Windows'! !Object methodsFor: 'error handling' stamp: 'di 1/18/1999 19:52'! doesNotUnderstand: aMessage "Handle the fact that there was an attempt to send the given message to the receiver but the receiver does not understand this message (typically sent from the machine when a message is sent to the receiver and no method is defined for that selector)." "Unless the receiver has an error handler defined for the active process, report to the user that the receiver does not understand the argument, aMessage, as a message." "Testing: (3 activeProcess)" | handler errorString | "added ThingLab code follows: " (self tryCompilingThingLabCodeFor: aMessage selector) ifTrue: [^self perform: aMessage selector withArguments: aMessage arguments]. (Preferences autoAccessors and: [self tryToDefineVariableAccess: aMessage]) ifTrue: [^ aMessage sentTo: self]. errorString _ 'Message not understood: ', aMessage selector. (handler _ Processor activeProcess errorHandler) notNil ifTrue: [handler value: errorString value: self] ifFalse: [Debugger openContext: thisContext label: errorString contents: thisContext shortStack]. ^ aMessage sentTo: self! ! !Object methodsFor: 'ThingLab inheritance'! asPrototype | f | "make me be a prototype" self isPrototype "If I'm already a prototype, just return myself. Otherwise make a new class for me and return my new self." ifTrue: [^self]. "crock - if I am an object, add some spare fields" f _ (self class == Object ifTrue: ['part1 part2 part3 part4 part5 part6 part7 part8 part9 part10 part11 part12 part13 part14 part15 part16'] ifFalse: ['']). ^self asPrototypeWithFields: f! ! !Object methodsFor: 'ThingLab inheritance'! asPrototypeWithFields: f | name cl fieldDescriptions n | "make me be a prototype with additional fields f" self isPrototype ifTrue: [self error: 'I am already a prototype'] ifFalse: [ "make a new class for me" name _ FillInTheBlank request: 'I need a name!!'. self class subclass: name asSymbol instanceVariableNames: f classVariableNames: '' poolDictionaries: '' category: 'Prototypes'. cl _ Smalltalk at: name asSymbol. cl classvars init. cl md close. "initialize types of new fields to spare" fieldDescriptions _ cl prototype fieldDescriptions. self class instSize + 1 to: cl instSize do: [:i | n _ (fieldDescriptions at: i) name. fieldDescriptions at: i put: (SpareField name: n index: i)]. cl prototype copyFieldsFrom: self. ^cl prototype]! ! !Object methodsFor: 'ThingLab inheritance'! bePrototype "I am a prototype. Initialize myself" | cl superPrototype | cl _ self class. "copy inherited fields if any" (cl == Object) | (cl superclass == Object) ifFalse: "perform inherited merges" [superPrototype _ cl superclass prototype. 1 to: superPrototype class instSize do: [:i | self instVarAt: i put: (superPrototype instVarAt: i) recopy]. superPrototype merges do: [:m | m mergePartsFor: self]]! ! !Object methodsFor: 'ThingLab inheritance'! bePrototypeDefinition "I am the prototype for a ThingLab object definition. Initialize myself" self bePrototype. self doNotIndexPrototype ifFalse: [ThingLabObject definitions at: self prototypeName put: self]! ! !Object methodsFor: 'ThingLab inheritance'! bePrototypeInstance "I am the prototype for a ThingLab object. Initialize myself" self bePrototype. self doNotIndexPrototype ifFalse: [ThingLabObject instances at: self prototypeName put: self]! ! !Object methodsFor: 'ThingLab inheritance'! canUnderstand: op | fieldDescriptions name | "Return true if one of my superclasses can understand op. Compile a forwarder if necessary." (self class canUnderstand: op) ifTrue: [^true]. fieldDescriptions _ self fieldDescriptions. name _ nil. 1 to: self class instSize do: [:i | (((fieldDescriptions at: i) isSuperclassPart) and: [((self instVarAt: i) canUnderstand: op)]) ifTrue: [name == nil == false ifTrue: [self error: 'conflicting inherited messages'] ifFalse: [name _ (fieldDescriptions at: i) name]]]. name == nil ifTrue: [^false]. "compile a message forwarder" self compileForwarderFor: op to: name! ! !Object methodsFor: 'ThingLab inheritance'! coerce: anObject "a generalization of the coerce: messages in the number hierarchy -- coerce anObject to be an instance of my class." anObject class==self class ifTrue: [^anObject]. anObject allSuperclassParts do: [:s | s class == self class ifTrue: [^s]]. self error: 'warning - weirdness in coerce: ... proceed to do something plausible'. ^anObject! ! !Object methodsFor: 'ThingLab inheritance'! compileForwarderFor: op to: name | strm vec | strm _ WriteStream on: (String new: 200). op numArgs = 0 ifTrue: [strm nextPutAll: op. strm nextPutAll: ' ^'. strm nextPutAll: name. strm space. strm nextPutAll: op. self class compile: strm contents classified: 'Forwarders'] ifFalse: [ "break up op into keywords" vec _ (op copyReplaceAll: ':' with: ': ') asTokens. 1 to: vec size do: [:i | strm nextPutAll: (vec at: i). strm nextPutAll: ' arg'. strm print: i. strm space]. strm nextPutAll: '^'. strm nextPutAll: name. strm space. 1 to: vec size do: [:i | strm nextPutAll: (vec at: i). strm nextPutAll: ' arg'. strm print: i. strm space]. strm nextPutAll: ''. self class compile: strm contents classified: 'Forwarders']! ! !Object methodsFor: 'ThingLab inheritance'! doNotIndexPrototype "return true if I am an instance of an abstract ThingLab class" ^ #(Object ThingLabObject ThingLabDefinition ThingLabInstance) includes: self class name! ! !Object methodsFor: 'ThingLab inheritance'! isPrototype "return true if I am the prototypical instance of my class" ^self == self class prototype! ! !Object methodsFor: 'ThingLab inheritance'! prototypeName ^self class name! ! !Object methodsFor: 'ThingLab fields'! absoluteReferences: refs self forInstVarNamesIn: refs setNameAndIndex: [:name :i | (AbsoluteReference name: name asSymbol index: i) insertIn: self]! ! !Object methodsFor: 'ThingLab fields'! allSuperclassParts "return a set of all my superclass parts" | set | set _ Set new. self allSuperclassPartsInto: set. ^set! ! !Object methodsFor: 'ThingLab fields'! allSuperclassPartsInto: set "auxiliary message for Object allSuperclassParts" self superclassParts do: [:s | set add: s. s allSuperclassPartsInto: set]! ! !Object methodsFor: 'ThingLab fields'! atomic "return true if I am considered to have no parts by ThingLab" ^ self class isBits! ! !Object methodsFor: 'ThingLab fields'! field: n replaceWith: value "replace a field" self fieldDescriptions do: [:f | n = f name ifTrue: [self instVarAt: f index put: value. ^self]]. self error: 'field name not found'! ! !Object methodsFor: 'ThingLab fields'! fieldDescription: n self fieldDescriptions do: [:f | f name = n ifTrue: [^f]]. self error: 'field not found'! ! !Object methodsFor: 'ThingLab fields'! fieldDescriptions "return an array of my instance field descriptions" ^self class prototypeFieldDescriptions! ! !Object methodsFor: 'ThingLab fields'! forInstVarNamesIn: stringOfNames setNameAndIndex: nameBlock | names instvars | names _ Scanner new scanFieldNames: stringOfNames. instvars _ self class allInstVarNames. 1 to: instvars size do: [:i | (names includes: (instvars at: i)) ifTrue: [nameBlock value: (instvars at: i) value: i]]! ! !Object methodsFor: 'ThingLab fields'! hasChangeableParts "return true if I have parts that are allowed to be of different classes" ^false! ! !Object methodsFor: 'ThingLab fields'! nameFor: path "if the part at the end of 'path' has a label, return a symbol that is its name; otherwise nil. If there are multiple labels, return the first one found." ^self nameFor: path checkedPaths: Set new! ! !Object methodsFor: 'ThingLab fields'! nameFor: path checkedPaths: checkedPaths "if the part at the end of 'path' has a label, return a symbol that is its name; otherwise nil. If there are multiple labels, return the first one found." | label extension | path isEmpty ifTrue: [^nil]. (checkedPaths includes: path) ifTrue: [^nil]. checkedPaths add: path. self constraints do: [:c | c isLabelConstraint ifTrue: [c valuePath=path ifTrue: [^(c labelPath applyTo: self) asSymbol]]]. self merges do: [:m | extension _ path withinOneOf: m paths. extension notNil ifTrue: [m paths do: [:p | label _ self nameFor: (p concat: extension) checkedPaths: checkedPaths. label notNil ifTrue: [^label]]]]. ^(self perform: path firstName) nameFor: (path tail)! ! !Object methodsFor: 'ThingLab fields'! parts | fieldDescriptions parts | fieldDescriptions _ self fieldDescriptions. parts _ OrderedCollection new. 1 to: fieldDescriptions size do: [:i | (fieldDescriptions at: i) isPart ifTrue: [parts add: (self instVarAt: i)]]. ^parts! ! !Object methodsFor: 'ThingLab fields'! parts: pts self forInstVarNamesIn: pts setNameAndIndex: [:name :i | (PartDescription name: name asSymbol index: i) insertIn: self]! ! !Object methodsFor: 'ThingLab fields'! pathTo: object "return a path to object, or nil if not found" | part partPath | self==object ifTrue: [^EmptyPath]. self fieldDescriptions do: [:f | part _ self instVarAt: f index. partPath _ part pathTo: object. partPath notNil ifTrue: [^f asPath concat: partPath]]. ^nil! ! !Object methodsFor: 'ThingLab fields'! primitives: prims self forInstVarNamesIn: prims setNameAndIndex: [:name :i | (PrimitiveDescription name: name asSymbol index: i) insertIn: self]! ! !Object methodsFor: 'ThingLab fields'! realFieldDescriptions "Return fieldDescriptions without trailing spares" | properties lastReal | properties _ self fieldDescriptions. "Only eliminate TRAILING spares - lest numbering get confused" lastReal _ properties findLast: [:prop | prop isSpare not]. ^ properties copyFrom: 1 to: lastReal! ! !Object methodsFor: 'ThingLab fields'! relativeReferences: refs self forInstVarNamesIn: refs setNameAndIndex: [:name :i | (RelativeReference name: name asSymbol index: i) insertIn: self]! ! !Object methodsFor: 'ThingLab fields'! replace: path with: value "replace the field at the end of path" self replace: path with: value merges: Set new! ! !Object methodsFor: 'ThingLab fields'! replace: path with: value merges: merges "replace the field at the end of path. merges is a set of merges already checked - this prevents infinite looping. For use by replace:with: message" "first replace the field indicated by path itself" self replacePath: path with: value. "now check for any other paths to the field" self merges do: [:merge | self replace: path with: value merges: merges forMerge: merge. self replaceParts: path with: value merges: merges forMerge: merge]! ! !Object methodsFor: 'ThingLab fields'! replace: path with: value merges: merges forMerge: merge "replace the field at the end of path for the particular merge constraint merge. merges is a set of merges already checked - this prevents infinite looping. For use by replace:with:merges: message" ((merges includes: merge) or: [(merge hasPath: path) not]) ifFalse: [merges add: merge. merge paths do: [:p | self replace: p with: value merges: merges]]! ! !Object methodsFor: 'ThingLab fields'! replaceParts: path with: value merges: merges forMerge: merge "the field at the end of path is being merged for the merge constraint merge. check for any parts of the field which have been merged, and replace each of them with the appropriate part from value. merges is a set of merges already checked - this prevents infinite looping. For use by replace:with:merges: message" | difference part | (merges includes: merge) ifFalse: [merge paths do: [:p | difference _ p within: path. difference notNil ifTrue: [merges add: merge. part _ difference applyTo: value. merge paths do: [:pp | self replace: pp with: part merges: merges]. ^self] "stop checking paths" ]]! ! !Object methodsFor: 'ThingLab fields'! replacePath: path with: value "replace the field at the end of path, ignoring my merges but not those of my parts. For use by replace:with: message" | firstName tail | firstName _ path firstName. tail _ path tail. tail isEmpty ifTrue: [self field: firstName replaceWith: value] ifFalse: [(self perform: firstName) replace: tail with: value]! ! !Object methodsFor: 'ThingLab fields'! spares: s self forInstVarNamesIn: s setNameAndIndex: [:name :i | (SpareField name: name asSymbol index: i) insertIn: self]! ! !Object methodsFor: 'ThingLab fields'! superclassParts | fieldDescriptions parts | self updateSometime. "should also include parts for superclasses on normal Smalltalk chain?" fieldDescriptions _ self fieldDescriptions. parts _ OrderedCollection new. 1 to: fieldDescriptions size do: [:i | (fieldDescriptions at: i) isSuperclassPart ifTrue: [parts add: (self instVarAt: i)]]. ^parts! ! !Object methodsFor: 'ThingLab fields'! superclasses: supers self forInstVarNamesIn: supers setNameAndIndex: [:name :i | (SuperclassDescription name: name asSymbol index: i) insertIn: self]! ! !Object methodsFor: 'ThingLab message handling'! compileAssignCodeFor: sel fields: fields "compile code to initialize the values of one or more parts. sel should be of the form assign.part1.subpart: part2.subpart.subsubpart: part3: fields is a collection of arrays of my field properties corresponding to those subparts to be initialized" | encoder args statements fs f1 arg assignNode path assignSel returnNode block methodNode | encoder _ Encoder new init: self class context: nil notifying: self. args _ OrderedCollection new. statements _ OrderedCollection new. 1 to: fields size do: [:i | fs _ fields at: i. arg _ encoder bindTemp: 't' , i printString. args add: arg. "if fs is of length 1, then compile code to initialize that field; otherwise pass the buck" fs size =1 ifTrue: [f1 _ fs first. assignNode _ f1 makeAssignNode: arg encoder: encoder] ifFalse: [path _ ((fs copyFrom: 1 to: fs size-1) collect: [:f | f name]) asPath. assignSel _ ('assign.' , fs last name , ':') asSymbol. assignNode _ MessageNode new receiver: (path code: encoder) selector: assignSel arguments: (Array with: arg) precedence: assignSel precedence from: encoder]. statements add: assignNode]. returnNode _ ReturnNode new expr: (encoder encodeVariable: 'self'). statements add: returnNode. block _ BlockNode new statements: statements returns: true. methodNode _ MethodNode new selector: sel arguments: args precedence: sel precedence temporaries: #() block: block encoder: encoder primitive: 0. methodNode compileIn: self class! ! !Object methodsFor: 'ThingLab message handling'! compileCopyCodeFor: sel fields: fields "compile code to return a copy of myself with changed values for some of my parts or subparts. Other parts in the copy may need to be altered to satisfy constraints. Does not change the receiver. sel should be of the form copy.part1.subpart: part2.subpart.subsubpart: part3: " | encoder args copyNode setNode returnNode block methodNode | "cheap and (one hopes) temporary hack -- just copy myself and do a set" encoder _ Encoder new init: self class context: nil notifying: self. args _ ((1 to: fields size) collect: [:i | encoder bindTemp: 't' , i printString]). copyNode _ MessageNode new receiver: (encoder encodeVariable: 'self') selector: #recopy arguments: Array new precedence: #recopy precedence from: encoder. setNode _ MessageNode new receiver: copyNode selector: ('set.' , (sel copyFrom: 6 to: sel size)) asSymbol arguments: args precedence: sel precedence from: encoder. returnNode _ ReturnNode new expr: setNode. block _ BlockNode new statements: (Array with: returnNode) returns: true. methodNode _ MethodNode new selector: sel arguments: args precedence: sel precedence temporaries: #() block: block encoder: encoder primitive: 0. methodNode compileIn: self class! ! !Object methodsFor: 'ThingLab message handling'! compileDeltaCodeFor: sel fields: fields "compile code to return a copy of myself with incremented values for some of my parts or subparts. Other parts in the copy may need to be altered to satisfy constraints. Does not change the receiver. sel should be of the form delta.part1.subpart: part2.subpart.subsubpart: part3: " | encoder args incrementedFields copyNode returnNode block methodNode paths| encoder _ Encoder new init: self class context: nil notifying: self. args _ (1 to: fields size) collect: [:i | encoder bindTemp: 't' , i printString]. paths _ self getPathsForKeywordSelector: (sel copyFrom: 7 to: sel size) asSymbol. incrementedFields _(1 to: fields size) collect: [:i | MessageNode new receiver: ((paths at: i) code: encoder) selector: #+ arguments: (Array with: (args at: i)) precedence: #+ precedence from: encoder]. copyNode _ MessageNode new receiver: (encoder encodeVariable: 'self') selector: ('copy.' , (sel copyFrom: 7 to: sel size)) asSymbol arguments: incrementedFields precedence: sel precedence from: encoder. returnNode _ ReturnNode new expr: copyNode. block _ BlockNode new statements: (Array with: returnNode) returns: true. methodNode _ MethodNode new selector: sel arguments: args precedence: sel precedence temporaries: #() block: block encoder: encoder primitive: 0. methodNode compileIn: self class! ! !Object methodsFor: 'ThingLab message handling'! compileOpSetCodeFor: sel fields: fields "temporary (?) kludge - like set, but specially handled when relocating paths. Used only to wake up constraints on operators." | encoder args setNode returnNode block methodNode | encoder _ Encoder new init: self class context: nil notifying: self. args _ ((1 to: fields size) collect: [:i | encoder bindTemp: 't' , i printString]). setNode _ MessageNode new receiver: (encoder encodeVariable: 'self') selector: ('set.' , (sel copyFrom: 9 to: sel size)) asSymbol arguments: args precedence: sel precedence from: encoder. returnNode _ ReturnNode new expr: (encoder encodeVariable: 'self'). block _ BlockNode new statements: (Array with: setNode with: returnNode) returns: true. methodNode _ MethodNode new selector: sel arguments: args precedence: sel precedence temporaries: #() block: block encoder: encoder primitive: 0. methodNode compileIn: self class! ! !Object methodsFor: 'ThingLab message handling'! compilePrimitiveSetCodeFor: sel fields: fields "compile code to set the values of one or more parts. sel should be of the form primitiveSet.part1.subpart: part2.subpart.subsubpart: part3: fields is a collection of arrays of my field properties corresponding to those subparts to be set" | encoder args statements fs f1 arg primitiveSetNode path primitiveSetSel returnNode block methodNode | encoder _ Encoder new init: self class context: nil notifying: self. args _ OrderedCollection new. statements _ OrderedCollection new. 1 to: fields size do: [:i | fs _ fields at: i. arg _ encoder bindTemp: 't' , i printString. args add: arg. "if fs is of length 1, then compile code to set that field; otherwise pass the buck" fs size =1 ifTrue: [f1 _ fs first. primitiveSetNode _ f1 makePrimitiveSetNode: arg sample: (self perform: f1 name) encoder: encoder] ifFalse: [path _ ((fs copyFrom: 1 to: fs size-1) collect: [:f | f name]) asPath. primitiveSetSel _ ('primitiveSet.' , fs last name , ':') asSymbol. primitiveSetNode _ MessageNode new receiver: (path code: encoder) selector: primitiveSetSel arguments: (Array with: arg) precedence: primitiveSetSel precedence from: encoder]. statements add: primitiveSetNode]. returnNode _ ReturnNode new expr: (encoder encodeVariable: 'self'). statements add: returnNode. block _ BlockNode new statements: statements returns: true. methodNode _ MethodNode new selector: sel arguments: args precedence: sel precedence temporaries: #() block: block encoder: encoder primitive: 0. methodNode compileIn: self class! ! !Object methodsFor: 'ThingLab message handling'! compileRetrieveCodeFor: sel field: field "compile code to retrieve a part" | encoder returnNode block methodNode | encoder _ Encoder new init: self class context: nil notifying: self. returnNode _ ReturnNode new expr: (field makeRetrieveNode: encoder). block _ BlockNode new statements: (Array with: returnNode) returns: true. methodNode _ MethodNode new selector: field name arguments: #() precedence: sel precedence temporaries: #() block: block encoder: encoder primitive: 0. methodNode compileIn: self class! ! !Object methodsFor: 'ThingLab message handling'! compileSetCodeFor: sel fields: fields "compile code to change the values of some of my parts. other parts may need to be altered to satisfy constraints. sel should be of the form set.part1.subpart: part2.subpart.subsubpart: part3: fields is a collection of arrays of my field properties corresponding to those subparts to be set" | planner encoder args statements fs tempName arg changeMessage primitiveSetSel primitiveSetNode returnNode block methodNode | planner _ ConstraintSatisfactionPlanner for: self. encoder _ planner encoder. args _ OrderedCollection new. statements _ OrderedCollection new. 1 to: fields size do: [:i | fs _ fields at: i. tempName _ 't' , i printString. arg _ encoder bindTemp: tempName. args add: arg. "make a message that describes the change being made, tell the planner about it, and add methods from affected constraints. Hack: the change might be made using a copyFrom: or an assignment. Since MessagePlans don't compile assignments correctly, just use a primitiveSet. message (done below), and fool the planner by saying that the MessagePlan is compileTimeOnly." changeMessage _ MessagePlan new context: self receiver: (fs collect: [:f | f name]) asPath constraint: nil owner: EmptyPath keywords: #('alter') arguments: #() uniqueState: true referenceOnly: false compileTimeOnly: true. planner addMethod: changeMessage. changeMessage addMethods: planner]. "delete duplicate messages" planner deleteDuplicates. "first add a set statement to to collection of statements" primitiveSetSel _ ('primitiveSet.' , (sel copyFrom: 7 to: sel size)) asSymbol. primitiveSetNode _ MessageNode new receiver: (encoder encodeVariable: 'self') selector: primitiveSetSel arguments: args precedence: primitiveSetSel precedence from: encoder. statements add: primitiveSetNode. statements addAll: (self buildPlan: planner). returnNode _ ReturnNode new expr: (encoder encodeVariable: 'self'). statements add: returnNode. block _ BlockNode new statements: statements returns: true. methodNode _ MethodNode new selector: sel arguments: args precedence: sel precedence temporaries: #() block: block encoder: encoder primitive: 0. methodNode compileIn: self class! ! !Object methodsFor: 'ThingLab message handling'! getFieldsForKeywordSelector: sel "sel should be of the form part1.subpart: part2.subpart.subsubpart: part3: check that I have subparts of the appropriate names. If so, return a collection of arrays of Fields matching the keywords in sel; otherwise return nil" | fields arrayOfFields | arrayOfFields _ OrderedCollection new. sel keywords do: [:k | fields _ self getFieldsForPath: k pathFromDottedSelector. fields isNil ifTrue: [^nil] ifFalse: [arrayOfFields add: fields]]. ^arrayOfFields! ! !Object methodsFor: 'ThingLab message handling'! getFieldsForPath: path "check that I have a subpart corresponding to path. If so, return a matching array of Fields; otherwise return nil" | firstName matchingField part subFields | path isEmpty ifTrue: [^Array new]. firstName _ path firstName. self fieldDescriptions do: [:f | f name==firstName ifTrue: [matchingField _ f]]. matchingField isNil ifTrue: [^nil]. part _ self perform: firstName. subFields _ part getFieldsForPath: path tail. subFields isNil ifTrue: [^nil] ifFalse: [^(Array with: matchingField) , subFields]! ! !Object methodsFor: 'ThingLab message handling'! getPathsForKeywordSelector: sel "sel should be of the form part1.subpart: part2.subpart.subsubpart: part3: check that I have subparts of the appropriate names. If so, return a collection of paths matching the keywords in sel; otherwise return nil" | path arrayOfPaths | arrayOfPaths _ OrderedCollection new. sel keywords do: [:k | path _ k pathFromDottedSelector. path isNil ifTrue: [^nil] ifFalse: [arrayOfPaths add: path]]. ^arrayOfPaths! ! !Object methodsFor: 'ThingLab message handling'! shouldCompileCodeFor: sel prefix: prefix "check if I should compile code for sel. sel should be of the form prefix.part1.subpart: part2.subpart.subsubpart: part3: If I should, return a collection of arrays of my field properties corresponding to those subparts; otherwise return nil" | shortSel fields | sel isKeyword ifFalse: [^nil]. sel size<(prefix size+3) ifTrue: [^nil]. "selector must be at least prefix.x: ..." (sel copyFrom: 1 to: prefix size+1) = (prefix , '.') ifFalse: [^nil]. shortSel _ (sel copyFrom: prefix size+2 to: sel size) asSymbol. fields _ self getFieldsForKeywordSelector: shortSel. fields==nil ifTrue: [self error: 'couldn''t find field names for selector ' , sel]. ^fields! ! !Object methodsFor: 'ThingLab message handling'! shouldCompileRetrieveCodeFor: sel "check if I should compile code to retrieve a part for selector sel. If yes, return the corresponding field; otherwise return nil" sel isUnary ifFalse: [^nil]. "check if there is a field of the appropriate name" self fieldDescriptions do: [:f | f name==sel ifTrue: [^f]]. ^nil! ! !Object methodsFor: 'ThingLab message handling'! tryCompilingThingLabCodeFor: sel "try compiling ThingLab code for selector sel. Return true if successful" | f | f _ self shouldCompileRetrieveCodeFor: sel. f notNil ifTrue: [self compileRetrieveCodeFor: sel field: f. ^true]. f _ self shouldCompileCodeFor: sel prefix: 'copy'. f notNil ifTrue: [self compileCopyCodeFor: sel fields: f. ^true]. f _ self shouldCompileCodeFor: sel prefix: 'set'. f notNil ifTrue: [self compileSetCodeFor: sel fields: f. ^true]. f _ self shouldCompileCodeFor: sel prefix: 'opSet'. f notNil ifTrue: [self compileOpSetCodeFor: sel fields: f. ^true]. f _ self shouldCompileCodeFor: sel prefix: 'delta'. f notNil ifTrue: [self compileDeltaCodeFor: sel fields: f. ^true]. f _ self shouldCompileCodeFor: sel prefix: 'assign'. f notNil ifTrue: [self compileAssignCodeFor: sel fields: f. ^true]. f _ self shouldCompileCodeFor: sel prefix: 'primitiveSet'. f notNil ifTrue: [self compilePrimitiveSetCodeFor: sel fields: f. ^true]. ^false! ! !Object methodsFor: 'ThingLab constraints'! activateLabelConstraints: label context: context path: path rootPart: rootPart planner: planner "wake up all label constraints for 'label' " | part newPath | self constraints do: [:c | c addLabelMethods: label context: context owner: path rootPart: rootPart planner: planner]. self fieldDescriptions do: [:f | f isPart ifTrue: [part _ self perform: f name. newPath _ path add: f name. part activateLabelConstraints: label context: context path: newPath rootPart: rootPart planner: planner]]! ! !Object methodsFor: 'ThingLab constraints'! addConstraint: c self class addPrototypeConstraint: c! ! !Object methodsFor: 'ThingLab constraints'! buildPlan: planner "Build a list of statements to be invoked to satisfy some constraints. First try working forwards, then backwards, and then try the method for circular methods. Each of these methods returns a collection of methods (in parse tree form), which will be empty if there was nothing left to do." | statements forwards backwards circular checks | forwards _ self workForwards: planner. backwards _ self workBackwards: planner. circular _ self circularMethod: planner. checks _ self checksFor: planner. planner noMethods ifFalse: [self error: 'I couldn''t figure out a constraint satisfaction method']. statements _ OrderedCollection new. statements addAll: forwards. statements addAll: circular. statements addAll: backwards. statements addAll: checks. ^statements! ! !Object methodsFor: 'ThingLab constraints'! checkAndSatisfyConstraints: path "The part at the end of path has just been added. Check all constraints. If some aren't satisfied, then invoke constraint satisfaction" | planner m t receiver | self checkConstraints ifTrue: [^self "all constraints satisfied"]. planner _ ConstraintSatisfactionPlanner for: self. m _ MessagePlan new context: self receiver: path constraint: nil owner: EmptyPath keywords: #('check') arguments: #() uniqueState: false referenceOnly: true compileTimeOnly: true. m addMethods: planner. "delete duplicate messages" planner deleteDuplicates. t _ self complexMethod: m planner: planner. receiver _ t receiver applyTo: self. "horrible kludge - do this twice to get around bug in constraint satisfier" receiver perform: t selector. receiver perform: t selector! ! !Object methodsFor: 'ThingLab constraints'! checkConstraint: bool "complain if constraint isn't satisfied. Eventually, change this to identify who is complaining." bool ifFalse: [self error: 'constraint not satisfied']! ! !Object methodsFor: 'ThingLab constraints'! checkConstraints "check if all my constraints are satisfied (overridden by ThingLabObject)" ^true! ! !Object methodsFor: 'ThingLab constraints'! checksFor: planner "Some methods remain after other techniques (including relaxation) have been tried. All the constraints for the remaining methods should now be satisfied. However, the program hasn't been able to deduce this at compile time. Put in code for run-time checks." | encoder method checks checkNode | checks _ OrderedCollection new. planner noMethods ifTrue: [^checks]. encoder _ planner encoder. [planner noMethods] whileFalse: [method _ planner firstMethod. checkNode _ MessageNode new receiver: (encoder encodeVariable: 'self') selector: #checkConstraint: arguments: (Array with: (method testCode: planner encoder)) precedence: #checkConstraint: precedence from: encoder. checks add: checkNode. method checked: planner]. ^checks! ! !Object methodsFor: 'ThingLab constraints'! complexMethod: message planner: planner "Compile a method for receiving message. A simple linear plan could not be used. Ask the message to find all the methods that might need to be invoked to satisfy the constraints. After accumulating the set of methods, build a plan by seeing which of them actually need to be used." "First try working forwards, then backwards, and then try the method for circular methods. Each of these methods returns a collection of methods (in parse tree form), which will be empty if there was nothing left to do." | statements method messageCopy transform | statements _ self buildPlan: planner. method _ message makeMethod: statements temps: planner temps encoder: planner encoder. method compileIn: self class. messageCopy _ message noBackPointerCopy. "make a transformed message from the method" transform _ MessagePlan new context: nil receiver: EmptyPath constraint: nil owner: EmptyPath keywords: method selector keywords arguments: message arguments uniqueState: message uniqueState referenceOnly: message referenceOnly compileTimeOnly: message compileTimeOnly. "save this message in my dictionary of constraint satisfaction methods" self methods at: messageCopy put: transform. ^transform! ! !Object methodsFor: 'ThingLab constraints'! constraintDifference: other "compare myself with other and return an error" ^(self = other) asError! ! !Object methodsFor: 'ThingLab constraints'! constraints ^self class prototypeConstraints! ! !Object methodsFor: 'ThingLab constraints'! deleteConstraint: c self class deletePrototypeConstraint: c! ! !Object methodsFor: 'ThingLab constraints'! equalityConstraint: paths 1 to: paths size - 1 do: [:i | self equalityConstraint: (paths at: i) and: (paths at: i + 1)]! ! !Object methodsFor: 'ThingLab constraints'! equalityConstraint: path1 and: path2 ^Constraint owner: self rule: path1 nameString , ' = ' , path2 nameString methods: (Array with: path1 primitiveSetLast , ' ' , path2 nameString with: path2 primitiveSetLast , ' ' , path1 nameString)! ! !Object methodsFor: 'ThingLab constraints'! expand: message planner: planner "If message is a compile time message, expand it. Kludge - for now, the kinds of compile time messages are simply build in." | keyword r | keyword _ message keywords at: 1. r _ message receivingObject. keyword = 'moveby:' ifTrue: [r expandMove: message planner: planner. ^self]. keyword = 'scaleby:' ifTrue: [r expandMove: message planner: planner. ^self]. keyword = 'fixedLocation' ifTrue: [r expandFixedLocation: message planner: planner. ^self]. (keyword size > 12 and: [(keyword copyFrom: 1 to: 12) = 'moveInserter']) ifTrue: [r expandMoveAttacher: message planner: planner attachers: r inserters. ^self]. (keyword size > 15 and: [(keyword copyFrom: 1 to: 15) = 'moveConstrainer']) ifTrue: [r expandMoveAttacher: message planner: planner attachers: r constrainers. ^self]. planner addMethod: message! ! !Object methodsFor: 'ThingLab constraints'! expandFixedLocation: message planner: planner "send this message to each of my parts" | m | self fieldDescriptions do: [:f | f isPart ifTrue: [m _ MessagePlan new context: message context receiver: (message receiver add: f name) constraint: message constraint owner: message owner keywords: message keywords arguments: message arguments uniqueState: message uniqueState referenceOnly: message referenceOnly compileTimeOnly: message compileTimeOnly. (self instVarAt: f index) expand: m planner: planner]]! ! !Object methodsFor: 'ThingLab constraints'! expandMove: message planner: planner "send this message to each of my parts" | m | self fieldDescriptions do: [:f | f isPart ifTrue: [m _ MessagePlan new context: message context receiver: (message receiver add: f name) constraint: message constraint owner: message owner keywords: message keywords arguments: message arguments uniqueState: message uniqueState referenceOnly: message referenceOnly compileTimeOnly: message compileTimeOnly. (self instVarAt: f index) expand: m planner: planner]]! ! !Object methodsFor: 'ThingLab constraints' stamp: 'di 1/21/1999 20:47'! expandMoveAttacher: message planner: planner attachers: attachers "The keyword will have the attacher number built in. Extract the number of the attacher" | n strm char digits move fix | strm _ ReadStream on: (message keywords at: 1). char _ strm next. [char isDigit] whileFalse: [char _ strm next]. digits _ WriteStream on: (String new: 200). [char isDigit] whileTrue: [digits nextPut: char. char _ strm next]. n _ digits contents asNumber. "if this is attacher #1 move the entire object" n = 1 ifTrue: [move _ MessagePlan new context: message context receiver: message receiver constraint: message constraint owner: message owner keywords: #('moveby:' ) arguments: message arguments uniqueState: true referenceOnly: false compileTimeOnly: false. message context expand: move planner: planner] ifFalse: [ "fix the attachers already in position, and move all the remaining ones" 1 to: n - 1 do: [:i | fix _ MessagePlan new context: message context receiver: (message receiver concat: (attachers at: i)) constraint: message constraint owner: message owner keywords: #('fixedLocation' ) arguments: #() uniqueState: true referenceOnly: false compileTimeOnly: true. message context expand: fix planner: planner]. n to: attachers size do: [:i | move _ MessagePlan new context: message context receiver: (message receiver concat: (attachers at: i)) constraint: message constraint owner: message owner keywords: #('moveby:' ) arguments: message arguments uniqueState: true referenceOnly: false compileTimeOnly: false. message context expand: move planner: planner]]! ! !Object methodsFor: 'ThingLab constraints'! expandScale: message planner: planner "send this message to each of my parts" | m | self fieldDescriptions do: [:f | f isPart ifTrue: [m _ MessagePlan new context: message context receiver: (message receiver add: f name) constraint: message constraint owner: message owner keywords: message keywords arguments: message arguments uniqueState: message uniqueState referenceOnly: message referenceOnly compileTimeOnly: message compileTimeOnly. (self instVarAt: f index) expand: m planner: planner]]! ! !Object methodsFor: 'ThingLab constraints'! foregroundSelector: showSelector message: message | | ^nil "Return a selector for showing my moving foreground, or nil"! ! !Object methodsFor: 'ThingLab constraints'! forgetConstraintMethods self forgetOwnConstraintMethods! ! !Object methodsFor: 'ThingLab constraints'! forgetOwnConstraintMethods self methods init. self instancePathsDict init. (self isMemberOf: ThingLabObject) ifTrue: [^self]. (self isKindOf: ThingLabObject) ifTrue: [self class removeSelectorSimply: #checkConstraints]! ! !Object methodsFor: 'ThingLab constraints'! hasLabelConstraints "return true if I or one of my subparts has a label constraint" self constraints do: [:c | c isLabelConstraint ifTrue: [^true]]. 1 to: self class instSize do: [:i | (self instVarAt: i) hasLabelConstraints ifTrue: [^true]]. ^false! ! !Object methodsFor: 'ThingLab constraints'! makeMethodFor: message "Compile a method for receiving message" | planner | planner _ ConstraintSatisfactionPlanner for: self. message arguments do: [:a | planner encoder bindTemp: a]. self expand: message planner: planner. "If there is only one message in the planner's queue, and if that message doesn't interact with any of my constraints or merges, then use a simple method." (self testSimple: planner) ifTrue: [^self simpleMethod: message planner: planner]. "situation not simple - find all the relevant messages. Note that a copy of the planner is used because stuff is being added during the 'do:' " planner methodsDo: [:m | m addMethods: planner]. "delete duplicate messages" planner deleteDuplicates. "if there is only 1 message in the planner's queue, use a cheap method" planner nMethods = 1 ifTrue: [^self oneMessageMethod: message planner: planner] ifFalse: [^self complexMethod: message planner: planner]! ! !Object methodsFor: 'ThingLab constraints'! methods "Return my dictionary of constraint satisfaction methods. The dictionary consists of messages on the name side of the dictionary, and on the value side the corresponding transformed messages" ^ self class prototypeMethods! ! !Object methodsFor: 'ThingLab constraints'! oneMessageMethod: message planner: planner | messageCopy statements method transform | messageCopy _ message noBackPointerCopy. statements _ Array with: (planner firstMethod code: planner encoder). method _ message makeMethod: statements temps: #() encoder: planner encoder. method compileIn: self class. transform _ MessagePlan new context: nil receiver: EmptyPath constraint: nil owner: EmptyPath keywords: method selector keywords arguments: message arguments uniqueState: message uniqueState referenceOnly: message referenceOnly compileTimeOnly: message compileTimeOnly. self methods at: messageCopy put: transform. ^transform! ! !Object methodsFor: 'ThingLab constraints'! preferenceSort: paths "The argument 'paths' is a collection of paths to some of my subparts. Sort them by preference as to which part should be changed when there is a choice. For the moment, this is done in a simple but very inefficient way, by running the constraint satisfier on the object and seeing what gets changed in preference to what." | planner changeMessage forwards backwards method unorderedPaths orderedPaths allPaths | planner _ ConstraintSatisfactionPlanner for: self. "add a message that pretends to tweak each path" paths do: [:p | changeMessage _ MessagePlan new context: self receiver: p constraint: nil owner: EmptyPath keywords: #('alter') arguments: #() uniqueState: true referenceOnly: false compileTimeOnly: true. planner addMethod: changeMessage. changeMessage addMethods: planner]. planner deleteDuplicates. forwards _ OrderedCollection new. "work forwards" [(method _ planner findSendable) notNil] whileTrue: [forwards add: method. method sentNext: planner]. "work backwards" backwards _ OrderedCollection new. [(method _ planner findPostponable) notNil] whileTrue: [backwards addFirst: method. method postponed: planner]. "now look through the plan to order the paths" unorderedPaths _ paths copy. allPaths _ unorderedPaths collect: [:p | planner allPathsTo: p]. orderedPaths _ OrderedCollection new. (forwards , backwards) reverseDo: [:m | unorderedPaths with: allPaths do: [:u :all | (all includes: m receiver) & (orderedPaths includes: u) not ifTrue: [orderedPaths add: u]]]. "add any leftovers (is this ever necessary??)" unorderedPaths do: [:p | (orderedPaths includes: p) ifFalse: [orderedPaths add: p]]. ^orderedPaths! ! !Object methodsFor: 'ThingLab constraints'! simpleMethod: message planner: planner | copy queuedMessage receiver firstName tail field subMessage subTransform transform | copy _ message noBackPointerCopy. "Since the planner's queue is simple, just make a method which consists of sending its message on to my part." queuedMessage _ planner firstMethod noBackPointerCopy. receiver _ queuedMessage receiver. receiver isEmpty ifTrue: [self methods at: copy put: queuedMessage. ^queuedMessage]. firstName _ receiver firstName. tail _ receiver tail. field _ self perform: firstName. subMessage _ MessagePlan new context: field receiver: tail constraint: nil owner: EmptyPath keywords: queuedMessage keywords arguments: queuedMessage arguments uniqueState: queuedMessage uniqueState referenceOnly: queuedMessage referenceOnly compileTimeOnly: queuedMessage compileTimeOnly. subTransform _ field transform: subMessage. transform _ MessagePlan new context: nil receiver: ((Array with: firstName) asPath concat: subTransform receiver) constraint: nil owner: EmptyPath keywords: subTransform keywords arguments: subTransform arguments uniqueState: subTransform uniqueState referenceOnly: subTransform referenceOnly compileTimeOnly: subTransform compileTimeOnly. self methods at: copy put: transform. ^transform! ! !Object methodsFor: 'ThingLab constraints'! testSimple: planner "return true if there is only one method in the planner, and if that method doesn't interact with any of my constraints or merges" | method firstName firstPath part | planner nMethods=1 ifFalse: [^false]. planner nMethods=1 ifFalse: [^false]. method _ planner firstMethod. method receiver isEmpty ifTrue: [^true]. "method is simple if the first name of its receiver doesn't overlap any of my constraints or merges, and if the affected part doesn't have any label constraints or parts that can change class" firstName _ method receiver firstName. firstPath _ (Array with: firstName) asPath. part _ self perform: firstName. part hasLabelConstraints ifTrue: [^false]. part hasChangeableParts ifTrue: [^false]. self constraints do: [:c | (c overlaps: firstPath) ifTrue: [^false]]. self merges do: [:m | (m overlaps: firstPath) ifTrue: [^false]]. ^true! ! !Object methodsFor: 'ThingLab constraints'! transform: message "return a new message which takes my constraints into account" "first check if there is already an appropriate method" ^ self methods at: message ifAbsent: [self makeMethodFor: message]! ! !Object methodsFor: 'ThingLab constraints'! withinTolerance: other "test whether I am close to other (for purposes of constraint satisfaction). Redefined for various numeric objects" ^self=other! ! !Object methodsFor: 'ThingLab constraints'! workBackwards: planner | toInvoke method | toInvoke _ OrderedCollection new. planner noMethods ifTrue: [^toInvoke]. [(method _ planner findPostponable) notNil] whileTrue: [toInvoke addFirst: method. method postponed: planner]. ^toInvoke collect: [:m | m code: planner encoder]! ! !Object methodsFor: 'ThingLab constraints'! workForwards: planner | toInvoke method | toInvoke _ OrderedCollection new. planner noMethods ifTrue: [^toInvoke]. [(method _ planner findSendable) notNil] whileTrue: [toInvoke add: method. method sentNext: planner]. ^toInvoke collect: [:m | m code: planner encoder]! ! !Object methodsFor: 'ThingLab relaxation'! circularMethod: planner planner noMethods ifTrue: [^OrderedCollection new]. "A linear ordering for the messages in planner couldn't be found. The default is to use relaxation." ^Relaxer new circularMethod: self planner: planner! ! !Object methodsFor: 'ThingLab relaxation'! largestRelaxablePart: path "return a path to the largest of my subparts that can be relaxed" ^self largestRelaxablePart: path prefixPath: EmptyPath! ! !Object methodsFor: 'ThingLab relaxation'! largestRelaxablePart: path prefixPath: prefix "return a path to the largest of my subparts that can be relaxed. the default is that I am not relaxable - ask my part" | firstName | path isEmpty ifTrue: [^prefix]. firstName _ path firstName. ^(self perform: firstName) largestRelaxablePart: path tail prefixPath: (prefix add: firstName)! ! !Object methodsFor: 'ThingLab relaxation'! minChange "minimum allowable change during relaxation" ^0.001! ! !Object methodsFor: 'ThingLab relaxation'! newRelaxer "return a new relaxer - overridden by Bridges of various sorts" ^Relaxer new! ! !Object methodsFor: 'ThingLab picture definition'! compileFrameOrNilMethod: origin "compile a method that computes my frame, taking account of the bitmap picture" | strm | strm _ WriteStream on: (String new: 200). strm nextPutAll: 'enclosingFrameOrNil "automatically compiled method to compute my enclosingFrame" | picFrame superFrame | picFrame _ ('. origin codeTo: strm. strm nextPutAll: ') + PictureForm offset extent: PictureForm width @ PictureForm height. superFrame _ super enclosingFrameOrNil. superFrame == nil ifTrue: [^picFrame] ifFalse: [^picFrame merge: superFrame]'. self class quickCompile: strm contents! ! !Object methodsFor: 'ThingLab picture definition'! compileShowPictureMethod: origin "Init method to show picture and call inherited method" | strm | strm _ WriteStream on: (String new: 200). strm nextPutAll: 'showPicture: medium'; cr. strm tab; nextPutAll: 'super showPicture: medium.'; cr. strm tab; nextPutAll: 'PictureForm displayOn: medium at: '. origin codeTo: strm. strm nextPutAll: ' rule: Form paint'. self class quickCompile: strm contents! ! !Object methodsFor: 'ThingLab picture definition'! picture: aForm origin: originPath "initialize my picture" self class findOrAddClassVarName: #PictureForm. self class classPool at: #PictureForm put: aForm. self compileShowPictureMethod: originPath. self compileFrameOrNilMethod: originPath! ! !Object methodsFor: 'ThingLab showing'! formats "return a vector of formats in which I can show myself" ^ Format defaultFormats! ! !Object methodsFor: 'ThingLab showing'! name | t | t _ self class name. self isPrototype ifTrue: [^t , ' prototype']. ('AEIOU' includes: t first) ifTrue: [^'an ' , t]. ^'a ' , t! ! !Object methodsFor: 'ThingLab showing'! printFieldStructure: strm | fieldDescriptions | fieldDescriptions _ self fieldDescriptions. 1 to: fieldDescriptions size do: [:i | (fieldDescriptions at: i) printFieldStructure: strm field: (self instVarAt: i)]! ! !Object methodsFor: 'ThingLab showing'! printFields: strm | fieldDescriptions | fieldDescriptions _ self fieldDescriptions. 1 to: fieldDescriptions size do: [:i | (fieldDescriptions at: i) printField: strm field: (self instVarAt: i)]! ! !Object methodsFor: 'ThingLab showing'! printTableOfFields: strm "print my name and fields" self class instSize = 0 ifTrue: [self printOn: strm] ifFalse: [strm nextPutAll: self name. strm indent. self printFields: strm. strm unindent]! ! !Object methodsFor: 'ThingLab showing'! showDeleted: window | rect | rect _ self enclosingFrame. window fill: rect mask: Form white. self showPicture: window. window reverse: rect! ! !Object methodsFor: 'ThingLab showing' stamp: 'di 1/21/1999 20:16'! showGrayBorder: aMedium "draw a gray border around me" aMedium border: (self enclosingFrame expandBy: 2) width: 2 fillColor: Color gray! ! !Object methodsFor: 'ThingLab showing'! showPicture: medium 1 to: self class instSize do: [:i | (self instVarAt: i) showPicture: medium]! ! !Object methodsFor: 'ThingLab showing'! showStructure: window "print my class name, superclass, fields, and properties" | strm constraints merges | strm _ IndentingStream new. strm nextPutAll: 'Class '. strm nextPutAll: self class name. strm indent. self class == Object ifFalse: [strm cr; nextPutAll: 'Superclass'. strm indent; cr; nextPutAll: self class superclass name. strm unindent]. strm cr; nextPutAll: 'Parts'. strm indent. self printFieldStructure: strm. strm unindent. constraints _ self constraints. constraints size > 0 ifTrue: [strm cr; nextPutAll: 'Constraints'; indent. constraints do: [:c | strm cr. c printOn: strm]. strm unindent]. merges _ self merges. merges size > 0 ifTrue: [strm cr; nextPutAll: 'Merges'; indent. merges do: [:c | strm cr. c printOn: strm]. strm unindent]. ^ strm contents asText! ! !Object methodsFor: 'ThingLab showing'! showValues: ignored | strm | strm _ IndentingStream new. self printTableOfFields: strm. ^ strm contents asText! ! !Object methodsFor: 'ThingLab showing'! thingString "return a string to show in a printer." ^self storeString! ! !Object methodsFor: 'ThingLab editing'! addPart: x "add new part x and return the path to it" ^self addPart: x fieldNameOrNil: nil! ! !Object methodsFor: 'ThingLab editing'! addPart: newPart fieldNameOrNil: n "add new part 'newPart' and return the path to it" | p className fields descrClass name f | self isPrototype ifFalse: [self error: 'I am not a prototype']. self forgetConstraintMethods. fields _ self fieldDescriptions. 1 to: fields size do: "look for a spare field" [:i | (fields at: i) isSpare ifTrue: ["if n is nil, make up a name for the field" n isNil ifTrue: [className _ newPart class name. name _ ((className copyFrom: 1 to: 1) asLowercase , (className copyFrom: 2 to: className size) , i printString) asSymbol] ifFalse: [name _ n]. descrClass _ newPart atomic ifTrue: [PrimitiveDescription] ifFalse: [PartDescription]. f _ descrClass name: name index: i. f insertIn: self. self field: f name replaceWith: newPart. self class renameInstVarAt: f index name: f name. p _ f asPath. newPart relocatePaths: p. ^p]]. self addSpareFields. ^self addPart: newPart fieldNameOrNil: n! ! !Object methodsFor: 'ThingLab editing'! addSpareFields "increase my instance size" | inc oldSize strm newFields | inc _ 10. "bulk allocation of new fields" oldSize _ self class instSize. strm _ WriteStream on: (String new: 100). 1 to: inc do: [:i | strm nextPutAll: ' part'; print: i+oldSize]. newFields _ strm contents. "add the new fields (kludge: message works with multiple fields ...)" self class addInstVarName: newFields. "note that I am now another object!!" self class markNewPrototypeFieldsAsSpare! ! !Object methodsFor: 'ThingLab editing'! addTo: editedObject selectionMerges: selectionMerges attachers: attachers "I am being added to some edited object. Return the path to me" | insertPath | insertPath _ editedObject addPart: self. 1 to: attachers size do: [:i | (selectionMerges at: i) == nil ifFalse: [editedObject merge: (Array with: (selectionMerges at: i) with: (insertPath concat: (attachers at: i)))]]. ^insertPath! ! !Object methodsFor: 'ThingLab editing'! computedLocation ^self enclosingFrame center! ! !Object methodsFor: 'ThingLab editing'! constrainers "return a vector of paths to attachers used when using me to constrain an existing part in an object being edited" ^ self class prototypeConstrainers! ! !Object methodsFor: 'ThingLab editing'! constrainers: array self class setPrototypeConstrainers: (array collect: [:element | element asPath]). self forgetConstraintMethods! ! !Object methodsFor: 'ThingLab editing'! containsPoint: pt self parts do: [:p | (p containsPoint: pt) ifTrue: [^true]]. ^false! ! !Object methodsFor: 'ThingLab editing'! deletePath: path "delete the field at the end of path" | difference | self merges do: [:merge | "Check for any other paths to the field. This needs to be done before deleting the field indicated by path itself, since these merges will otherwise be deleted" difference _ path withinOneOf: merge paths. difference notNil ifTrue: [merge paths do: [:p | self deletePathNoCheck: (p concat: difference)]]]. self deletePathNoCheck: path! ! !Object methodsFor: 'ThingLab editing'! deletePathFromSets: path "The object at the end of path is being deleted. Check sets of paths and remove paths that would point to nonexistent parts. Uses instVarAt: for speed" 1 to: self class instSize do: [:i | (self instVarAt: i) deletePathFromSets: path]! ! !Object methodsFor: 'ThingLab editing'! deletePathNoCheck: path "Delete the field at the end of path (ignoring merges). For use by deletePath: message" | firstName tail f | firstName _ path firstName. tail _ path tail. f _ self fieldDescription: firstName. "if f is spare, then it's already deleted" f isSpare ifTrue: [^self]. tail isEmpty ifTrue: [self isPrototype ifFalse: [self error: 'I am not a prototype']. f deleteFrom: self. self constraints copy do: [:c | c deleteFrom: self ifOverlaps: path]. self merges copy do: [:m | m deleteFrom: self ifOverlaps: path]. self deletePathFromSets: path. self forgetConstraintMethods. self field: firstName replaceWith: nil "should also check descendants"] ifFalse: [(self perform: firstName) tryDeleting: tail owner: self name: firstName]! ! !Object methodsFor: 'ThingLab editing'! editingToolsFor: format "return a vector of classes of editing tools" format isPicture ifFalse: [^ Array new]. ^ (Array with: Inserter with: Deleter with: Constrainer) , (Array with: MergingMover with: Mover with: TextEditor)! ! !Object methodsFor: 'ThingLab editing'! enclosingFrame "return my frame if I can find it, otherwise make one up" | f | f _ self enclosingFrameOrNil. f == nil ifTrue: [^ -1000@-1000 extent: 1@1]. ^f! ! !Object methodsFor: 'ThingLab editing'! enclosingFrameOrNil "return my frame if I can find it, otherwise nil" | f pFrame | f_ nil. self parts do: [:p | pFrame _ p enclosingFrameOrNil. pFrame == nil ifFalse: [f == nil ifTrue: [f _ pFrame] ifFalse: [f _ f merge: pFrame]]]. ^f! ! !Object methodsFor: 'ThingLab editing'! inserters "return a vector of paths to attachers used when inserting me in another object" ^ self class prototypeInserters! ! !Object methodsFor: 'ThingLab editing'! inserters: array self class setPrototypeInserters: (array collect: [:element | element asPath]). self forgetConstraintMethods! ! !Object methodsFor: 'ThingLab editing'! instancePaths: cl "return a vector of paths to instances of class cl or its subclasses" "First check if I'm an instance of cl. If not, then check in my dictionary of instance paths to see if there is an entry for cl. If that fails too, then find a path to each of my parts which is an instance of cl. If there is more than one path to that part, put only one of them in the vector." | instancePathsDict partsDict paths prefix subPaths strm subPart part | (self isMemberOf: cl) ifTrue: [^Array with: EmptyPath]. instancePathsDict _ self instancePathsDict. paths _ instancePathsDict at: cl ifAbsent: [nil]. paths notNil ifTrue: [^paths]. "avoid problem of multiple paths to a part by indexing by part" partsDict _ IdentityDictionary new. self fieldDescriptions do: [:f | f isPart ifTrue: [subPaths _ (self perform: f name) instancePaths: cl. prefix _ f asPath. part _ self instVarAt: f index. subPaths do: [:p | subPart _ p applyTo: part. partsDict at: subPart put: (prefix concat: p)]]]. strm _ WriteStream on: (Array new: 10). partsDict do: [:x | strm nextPut: x]. paths _ strm contents. instancePathsDict at: cl put: paths. ^paths! ! !Object methodsFor: 'ThingLab editing'! instancePathsDict "return a dictionary of paths to my parts which are instances of some class. This dictionary is indexed by class" ^ self class prototypeInstancePathsDict! ! !Object methodsFor: 'ThingLab editing'! isInserter "return true if I designate an inserter (default is false)" ^false! ! !Object methodsFor: 'ThingLab editing'! relocatePaths: prefix "Prefix all my relative reference paths with prefix, and ask my subparts to do so as well. Since relatively few fields are relocatable, it might be more efficient to compile a special message when an object has such fields." self fieldDescriptions do: [:f | f relocatePathFor: self prefix: prefix]. 1 to: self class instSize do: [:i | (self instVarAt: i) relocatePaths: prefix]! ! !Object methodsFor: 'ThingLab editing'! stickyPaths: editedObject "return a collection of paths to parts I should stick to" ^editedObject instancePaths: self class! ! !Object methodsFor: 'ThingLab editing'! stickyPathsForInsert: editedObject "I am an attacher for an object being inserted in editedObject. Return a collection of paths to parts I should stick to." ^self stickyPaths: editedObject! ! !Object methodsFor: 'ThingLab editing'! tryDeleting: path owner: owner name: name "The default is that I must be a prototype to do deleting. If I am not a prototype, tell my owner to delete me." self isPrototype ifTrue: [self deletePath: path] ifFalse: [owner deletePath: (AccessPath new names: (Array with: name))]! ! !Object methodsFor: 'ThingLab editing'! usefulClasses ^ThingLabObject instances keys asSortedCollection! ! !Object methodsFor: 'ThingLab merges'! addMerge: m self class addPrototypeMerge: m! ! !Object methodsFor: 'ThingLab merges'! deleteMerge: m self class deletePrototypeMerge: m! ! !Object methodsFor: 'ThingLab merges'! merge: vec "vec is an array of paths. Merge all the parts referred to by these paths." | paths constraint obj f | paths _ vec collect: [:element | element asPath]. "Check if these are primitive parts. In this case, use equality constraints." obj _ (paths at: 1) allButLast applyTo: self. f _ obj fieldDescription: (paths at: 1) names last. f isPrimitive ifTrue: [self equalityConstraint: paths. ^self]. constraint _ MergeConstraint new. constraint pathsGet: paths. constraint insertIn: self! ! !Object methodsFor: 'ThingLab merges'! mergeWith: other "return the result of a destructive merge" self updateSometime. self==other ifTrue: [^self]. self==nil ifTrue: [^other]. other==nil ifTrue: [^self]. (self class==other class) | (self class inheritsFrom: other class) ifTrue: [1 to: other class instSize do: [:i | self instVarAt: i put: ((self instVarAt: i) mergeWith: (other instVarAt: i))]. ^self]. (other class inheritsFrom: self class) ifTrue: [^other mergeWith: self]. "incomplete ... need to check for superclass subparts" self superclassParts do: [:part | part class==other class ifTrue: [^self]]. other superclassParts do: [:part | part class==self class ifTrue: [^other mergeWith: self]]. self error: 'classes not compatable for merging' "other problems: should always give preference to receiver of this message if there are conflicts?"! ! !Object methodsFor: 'ThingLab merges'! merges ^self class prototypeMerges! ! !Object methodsFor: 'ThingLab recompiling messages'! interpret: keyword with: arg1 | message transform target | "make up a compile-time message, transform it, and send it" message _ MessagePlan new context: self receiver: EmptyPath constraint: nil owner: EmptyPath keywords: (Array with: keyword) arguments: #('arg1' ) uniqueState: true referenceOnly: false compileTimeOnly: false. transform _ self transform: message. target _ transform receiver applyTo: self. ^target perform: transform selector with: arg1! ! !Object methodsFor: 'ThingLab recompiling messages'! invertmoveby: pt self interpret: 'moveby:' with: 0 @ 0 - pt! ! !Object methodsFor: 'ThingLab recompiling messages'! invertscaleby: s self interpret: 'scaleby:' with: 1.0 / s! ! !Object methodsFor: 'ThingLab recompiling messages'! moveby: pt self interpret: 'moveby:' with: pt! ! !Object methodsFor: 'ThingLab recompiling messages'! scaleby: s self interpret: 'scaleby:' with: s! ! !Object methodsFor: 'ThingLab copying'! changeValue: t "Crock. like copyFieldsFrom:, but interpreted as making me semialterable rather than unalterable. See Message sentNext:" self copyFieldsFrom: t! ! !Object methodsFor: 'ThingLab copying'! copyFieldsFrom: other | fields f newObject | "recursively copy fields from other" fields _ self fieldDescriptions. 1 to: fields size do: [:i | f _ (fields at: i). f isPart ifTrue: [(self instVarAt: i) copyFieldsFrom: (other instVarAt: i)] ifFalse: [f isPrimitive ifTrue: [self instVarAt: i put: (other instVarAt: i)]]]. other class isVariable ifTrue: [self class isVariable ifFalse: [self error: 'incompatable classes']. newObject _ self class new: other basicSize. 1 to: self class instSize do: [:index | newObject instVarAt: index put: (self instVarAt: index)]. "For now just store indexed parts - will lose merges if there are any" 1 to: other basicSize do: [:index | newObject basicAt: index put: (other basicAt: index) recopy]. self become: newObject]! ! !Object methodsFor: 'ThingLab copying'! copyFieldsFrom: other scaledBy: s | message transform | self copyFieldsFrom: other. message _ MessagePlan new context: self receiver: EmptyPath constraint: nil owner: EmptyPath keywords: #('scaleby:' ) arguments: #('delta' ) uniqueState: true referenceOnly: false compileTimeOnly: false. transform _ self transform: message. (transform receiver applyTo: self) perform: transform selector with: s! ! !Object methodsFor: 'ThingLab copying'! recopy "return a complete topological copy of myself" ^self recopy: IdentityDictionary new! ! !Object methodsFor: 'ThingLab copying'! recopy: dict "return a complete topological copy of myself. dict is an IdentityDictionary, consisting on the left hand side of original objects, and on the right of copies." | newObject class index | class _ self class. class==Object ifTrue: [^self]. "check if a copy has already been made" newObject _ dict at: self ifAbsent: [nil]. newObject notNil ifTrue: [^newObject]. "need to make a new copy" class isVariable ifTrue: [index _ self basicSize. newObject _ class basicNew: index. dict at: self put: newObject. [index > 0] whileTrue: [newObject basicAt: index put: ((self basicAt: index) recopy: dict). index _ index - 1]] ifFalse: [newObject _ class basicNew. dict at: self put: newObject]. index _ class instSize. [index > 0] whileTrue: [newObject instVarAt: index put: ((self instVarAt: index) recopy: dict). index _ index - 1]. ^newObject! ! !Object methodsFor: 'ThingLab fileIn/fileOut'! constraintCodeTo: strm self constraints do: [:c | c fileOutOn: strm forOwner: self]! ! !Object methodsFor: 'ThingLab fileIn/fileOut'! editingCodeTo: strm "Add code that declares my inserters and constrainers" (self inserters size = 1 and: [self inserters first = EmptyPath]) ifFalse: [strm nextPutAll: self class name , ' prototype inserters: #('. self inserters do: [:path | strm nextPut: $'. path printNamesOn: strm. strm nextPut: $'; space]. strm nextPutAll: ')!!'; cr; cr]. (self constrainers size = 1 and: [self constrainers first = EmptyPath]) ifFalse: [strm nextPutAll: self class name , ' prototype constrainers: #('. self constrainers do: [:path | strm nextPut: $'. path printNamesOn: strm. strm nextPut: $'; space]. strm nextPutAll: ')!!'; cr; cr]! ! !Object methodsFor: 'ThingLab fileIn/fileOut'! fieldAssignCodeTo: strm "Add code that initializes my fields" | index part | self realFieldDescriptions do: [:f | index _ f index. part _ self instVarAt: index. "put out code to make sure that the field's class exists" strm nextPut: $#; nextPutAll: part class name; nextPutAll: ' lookupClass!!'; cr. strm nextPutAll: self class name; nextPutAll: ' prototype instVarAt: '. index printOn: strm. strm nextPutAll: ' put: '. part storeOn: strm. strm nextPutAll: '!!'; cr; cr]! ! !Object methodsFor: 'ThingLab fileIn/fileOut'! fieldDescriptionCodeTo: strm "Add code that classifies my fields" | parts primitives spares n | parts _ SortedCollection new. primitives _ SortedCollection new. spares _ SortedCollection new. self realFieldDescriptions do: [:f | n _ f name. f isPart ifTrue: [parts add: n] ifFalse: [f isPrimitive ifTrue: [primitives add: n] ifFalse: [f isSpare ifTrue: [spares add: n] ifFalse: [self error: 'unknown field type']]]]. parts isEmpty ifFalse: [strm nextPutAll: self class name , ' prototype parts: '''. parts do: [:x | strm nextPutAll: x; space]. strm nextPutAll: '''!!'; cr]. primitives isEmpty ifFalse: [strm nextPutAll: self class name , ' prototype primitives: '''. primitives do: [:x | strm nextPutAll: x; space]. strm nextPutAll: '''!!'; cr]. spares isEmpty ifFalse: [strm nextPutAll: self class name , ' prototype spares: '''. spares do: [:x | strm nextPutAll: x; space]. strm nextPutAll: '''!!'; cr]. strm cr.! ! !Object methodsFor: 'ThingLab fileIn/fileOut'! fileOutClassDefinitionOn: fileStream fileStream nextPutAll: self class cleanDefinition; nextPut: $!!; cr; cr.! ! !Object methodsFor: 'ThingLab fileIn/fileOut'! fileOutPrototype "file out my class, adding statements to re-create my prototype" | fileStream | fileStream _ self makeFileOutFile. self fileOutClassDefinitionOn: fileStream. self fileOutStateOn: fileStream. fileStream close. self class removeFromChanges! ! !Object methodsFor: 'ThingLab fileIn/fileOut'! fileOutStateOn: fileStream "file out any user-defined methods, and then code to rebuild my field descriptions, instance state, inserters and constrainers, and constraints and merges" self class organization categories do: [:cat | self class fileOutCategory: cat on: fileStream moveSource: false toFile: 0]. fileStream cr; cr. self fieldDescriptionCodeTo: fileStream. self fieldAssignCodeTo: fileStream. self editingCodeTo: fileStream. self constraintCodeTo: fileStream. self mergeCodeTo: fileStream! ! !Object methodsFor: 'ThingLab fileIn/fileOut'! makeFileOutFile | nameString fileStream | nameString _ FillInTheBlank request: 'File out on' initialAnswer: self prototypeName , '.st' . fileStream _ FileStream newFileNamed: nameString. fileStream timeStamp. ^fileStream! ! !Object methodsFor: 'ThingLab fileIn/fileOut'! mergeCodeTo: strm "add code to re-generate all my merges" self merges do: [:m | m mergeCodeTo: strm for: self]. "add code that asks all my subparts to check that all their merges have been done (needed since the 'fieldAssignCodeTo:' method doesn't handle shared substructure) " strm nextPutAll: self class name , ' prototype performAllMerges!!'; cr! ! !Object methodsFor: 'ThingLab fileIn/fileOut'! performAllMerges "Tell all my subparts to check that all their merges have been done (needed since the 'fieldAssignCodeTo:' method doesn't handle shared substructure) Note that in the recursion parts must be done first" 1 to: self class instSize do: [:i | (self instVarAt: i) performAllMerges]. self merges do: [:m | m mergePartsFor: self]! ! !Object methodsFor: 'ThingLab fileIn/fileOut'! readThingFrom: str! ! !Object methodsFor: 'ThingLab reminders'! needToUpdate "reminders left in code about needed updates" self error: 'needs to be updated'.! ! !Object methodsFor: 'ThingLab reminders'! toFix "junk to fix: ThingLabBrowserView v40open is an obsolete message for use with ST80V40. When everything is converted to V41, this message, along with class ListViewWithBlock, can be removed. Also update PictureView topMedium. "! ! !Object methodsFor: 'ThingLab reminders'! updateSometime "code that works, but that should be fixed sometime"! ! !Object methodsFor: 'ThingLab obsolete stuff'! commonSuperclassOfParts: paths "find the nearest common superclass of all the parts at the end of paths" | commmonSuperclass otherClass | commmonSuperclass _ ((paths at: 1) applyTo: self) class. 2 to: paths size do: [:i | otherClass _ ((paths at: i) applyTo: self) class. otherClass == commmonSuperclass ifFalse: ["find nearest common ancestor" [otherClass inheritsFrom: commmonSuperclass] whileFalse: [commmonSuperclass _ commmonSuperclass superclass]]]. ^commmonSuperclass! ! !Object methodsFor: 'ThingLab obsolete stuff'! oldMerge: vec "this is the old version of the 'merge:' message" "check if these are primitive parts. In this case, use equality constraints." | paths constraint cl sameClass otherClass obj newPaths f | paths _ vec collect: [:element | element asPath]. obj _ (paths at: 1) allButLast applyTo: self. f _ obj fieldDescription: (paths at: 1) names last. f isPrimitive ifTrue: [self equalityConstraint: paths] ifFalse: [ "since objects must be of the same class to merge, if necessary create a series of merges" cl _ ((paths at: 1) applyTo: self) class. sameClass _ true. 2 to: paths size do: [:i | otherClass _ ((paths at: i) applyTo: self) class. otherClass == cl ifFalse: [sameClass _ false "find nearest common ancestor". [otherClass inheritsFrom: cl] whileFalse: [cl _ cl superclass]]]. sameClass ifTrue: [constraint _ MergeConstraint new "simple case - all objects to be merged are of the same class". constraint pathsGet: paths. constraint insertIn: self] ifFalse: [cl instSize = 0 ifTrue: [self error: 'vacuous merge'] ifFalse: [ "complex case - for each part inherited from the nearest common ancestor, merge the corresponding parts" cl prototype fieldDescriptions do: [:fp | newPaths _ paths collect: [:p | p concat: fp asPath]. self merge: newPaths]]]]! ! !Object methodsFor: 'ThingLab obsolete stuff'! partsHaveCommonSubclass: paths "Check the class of all the parts referred to by the paths. Return true if the class of one of them is the same or a subclass of the class of the rest." | commonSubclass otherClass | commonSubclass _ ((paths at: 1) applyTo: self) class. 2 to: paths size do: [:i | otherClass _ ((paths at: i) applyTo: self) class. (commonSubclass == otherClass) | (commonSubclass inheritsFrom: otherClass) ifTrue: ["no problem"] ifFalse: [(otherClass inheritsFrom: commonSubclass) ifTrue: [commonSubclass _ otherClass] ifFalse: [^false]]]. ^true! ! !Object methodsFor: 'ThingLab obsolete stuff'! weirdMerge: vec "vec is an array of paths. Merge all the parts referred to by these paths." "Uglies: if one of the paths is of the form ... mumble superclasspart then merge in mumble instead of mumble superclasspart." | paths shortenedPaths short continue constraint obj f | paths _ vec collect: [:element | element asPath]. "Check if these are primitive parts. In this case, use equality constraints." obj _ (paths at: 1) allButLast applyTo: self. f _ obj fieldDescription: (paths at: 1) names last. f isPrimitive ifTrue: [self equalityConstraint: paths. ^self]. "get rid of the links to superclassparts at the end of paths" shortenedPaths _ paths collect: [:p | short _ p. continue _ true. [continue] whileTrue: [obj _ short allButLast applyTo: self. continue _ (obj fieldDescription: short names last) isSuperclassPart. continue ifTrue: [short _ short allButLast]]. short]. constraint _ MergeConstraint new. constraint pathsGet: shortenedPaths. constraint insertIn: self! ! !Behavior methodsFor: 'ThingLab'! addPrototypeConstraint: c "the default is that my instances can have no constraints" self error: 'I cannot have any constraints'! ! !Behavior methodsFor: 'ThingLab'! addPrototypeMerge: m "the default is that my instances can have no merges" self error: 'I cannot have any merges'! ! !Behavior methodsFor: 'ThingLab'! deletePrototypeConstraint: c "the default is that my instances can have no constraints" self error: 'I cannot have any constraints'! ! !Behavior methodsFor: 'ThingLab'! deletePrototypeMerge: m "the default is that my instances can have no merges" self error: 'I cannot have any merges'! ! !Behavior methodsFor: 'ThingLab'! generateSelector: prefix "generate a new selector" | i sel | i _ 1. sel _ (prefix , i printString) asSymbol. [methodDict includesKey: sel] whileTrue: [i _ i+1. sel _ (prefix , i printString) asSymbol]. ^sel! ! !Behavior methodsFor: 'ThingLab'! parseTreeAt: messageSelector ^ self parseTreeForMethod: (methodDict at: messageSelector) at: messageSelector! ! !Behavior methodsFor: 'ThingLab'! parseTreeForMethod: method at: messageSelector ^ self decompilerClass new decompile: messageSelector in: self method: method! ! !Behavior methodsFor: 'ThingLab'! prototype "return my prototypical instance - overridden in ThingLabObject" ^self new! ! !Behavior methodsFor: 'ThingLab'! prototypeConstrainers "return a collection of paths to attachers used when using me to constrain an existing part in an object being edited" ^Array with: EmptyPath! ! !Behavior methodsFor: 'ThingLab'! prototypeConstraints "the default is that my instances have no constraints" ^Array new! ! !Behavior methodsFor: 'ThingLab'! prototypeFieldDescriptions "return an array of field descriptions for my instances. The default is that all fields are primitives" | p instvars superFields | self instSize=0 ifTrue: [^#()]. instvars _ self allInstVarNames. p _ Array new: instvars size. "copy inherited fields" superFields _ self superclass prototypeFieldDescriptions. 1 to: superFields size do: [:i | p at: i put: (superFields at: i)]. superFields size + 1 to: p size do: [:i | p at: i put: (PrimitiveDescription name: (instvars at: i) asSymbol index: i)]. ^p! ! !Behavior methodsFor: 'ThingLab'! prototypeInserters "return a collection of paths to attachers used when inserting me in another object" ^Array with: EmptyPath! ! !Behavior methodsFor: 'ThingLab'! prototypeInstancePathsDict "return a dictionary for keeping track of paths to instances of a given class in my instances. This is a dummy message here (the dictionary is thrown away each time). Overridden in ThingLabObject" ^Dictionary new! ! !Behavior methodsFor: 'ThingLab'! prototypeMerges "the default is that my instances have no merges" ^Array new! ! !Behavior methodsFor: 'ThingLab'! prototypeMethods "return a dictionary for keeping track of constraint satisfaction methods. This is a dummy message here (the dictionary is thrown away each time). Overridden in ThingLabObject" ^Dictionary new! ! !Behavior methodsFor: 'ThingLab' stamp: 'di 1/22/1999 12:28'! quickCompile: code "compile code, but don't keep source code or log in changes" ^ self compileUnlogged: code classified: 'all' notifying: nil! ! !Behavior methodsFor: 'ThingLab'! recopy: dict ^self! ! !Behavior methodsFor: 'ThingLab'! setPrototypeConstrainers: c "the default is that I am the constrainer - need to make an instance of ThingLabObject to change this" self error: 'cannot set constrainers'! ! !Behavior methodsFor: 'ThingLab'! setPrototypeInserters: i "the default is that I am the inserter - need to make an instance of ThingLabObject to change this" self error: 'cannot set inserters'! ! !Boolean methodsFor: 'ThingLab'! recopy: dict ^self! ! !Character methodsFor: 'ThingLab'! recopy: dict ^self! ! !ClassDescription methodsFor: 'ThingLab'! renameInstVarAt: index name: newName "rename my instance variable at index. Normally a dangerous thing to do - used by ThingLab to recycle spare fields" instanceVariables at: index-superclass instSize put: newName asString! ! !Class methodsFor: 'ThingLab'! findOrAddClassVarName: aSymbol classPool _ self classPool. "might be nil" (classPool includesKey: aSymbol) ifFalse: [classPool declare: aSymbol from: Undeclared]! ! !ArrayedCollection class methodsFor: 'ThingLab'! prototype "kludge to get around system bug ... ArrayedCollection new doesn't work" self==ArrayedCollection ifTrue: [^self basicNew] ifFalse: [^super prototype]! ! !Collection methodsFor: 'ThingLab'! atomic "return true if I am considered to have no parts by ThingLab (weird for collections ...)" ^true! ! !Array methodsFor: 'ThingLab'! asPath ^AccessPath new names: self! ! !CompiledMethod class methodsFor: 'class initialization' stamp: 'di 1/18/1999 20:00'! nullSourceDescriptor ^ #(0 0 0 0).! ! !DisplayMedium methodsFor: 'displaying' stamp: 'di 1/21/1999 20:44'! drawLine: sourceForm from: beginPoint to: endPoint rule: anInteger fillColor: aForm ^ self drawLine: sourceForm from: beginPoint to: endPoint clippingBox: self boundingBox rule: anInteger fillColor: aForm! ! !DisplayMedium methodsFor: 'ThingLab'! displayParagraph: para at: pt para displayOn: self at: pt! ! !False methodsFor: 'ThingLab'! asError ^1.0! ! !Form methodsFor: 'ThingLab'! changeExtent: newExtent "change my extent, growing or shrinking the bitmap as needed" | oldForm | newExtent = (width@height) ifTrue: [^self "no change needed"]. oldForm _ self copy. self extent: newExtent. oldForm displayOn: self! ! !Form methodsFor: 'ThingLab'! storeString "override default behavior to return a string with only ascii characters" | strm | strm _ WriteStream on: (String new: 500). self storeOn: strm base: 10. ^strm contents! ! !Number methodsFor: 'ThingLab'! constraintDifference: other "compare two numbers and return an error indicating how close they are" ^self asFloat - other asFloat! ! !Number methodsFor: 'ThingLab'! mergeWith: other self updateSometime. (other == nil or: [other isKindOf: Number]) ifTrue: [^self "take on my state as the result of the merge"]. self error: 'classes not compatable for merging'! ! !Number methodsFor: 'ThingLab'! recopy: dict ^self! ! !Number methodsFor: 'ThingLab'! relaxationSolveSelector ^ #solveNumber! ! !Float methodsFor: 'ThingLab'! fixedPrintString: nDecimals "return my print string with nDecimals digits after the decimal point" | strm fractionPart | strm _ WriteStream on: (String new: 20). self < 0 ifTrue: [strm nextPut: $-]. self abs truncated printOn: strm. strm nextPut: $. . fractionPart _ (self abs fractionPart * (10 raisedToInteger: nDecimals)) rounded printString. nDecimals - fractionPart size timesRepeat: [strm nextPut: $0]. strm nextPutAll: fractionPart. ^strm contents! ! !Float methodsFor: 'ThingLab'! withinTolerance: other ^(self-other) abs <= 1.0e-4! ! !Integer methodsFor: 'ThingLab'! withinTolerance: other ^self=other! ! !OrderedCollection methodsFor: 'thinglab'! excluding: oldElement "like copyWithout: , but only excludes first element equal to oldElement" | newCollection notFound | newCollection _ self species new: self size. notFound _ true. self do: [:each | (oldElement = each) & notFound ifTrue: [notFound _ false] ifFalse: [newCollection add: each]]. ^newCollection! ! !Paragraph methodsFor: 'thinglab fixes'! displaySafeOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: ruleInteger mask: aForm "This special message does not disturb state. It is only invoked by displayMedia." | saveDest saveClip saveComp saveRule saveMask | "save state" saveDest _ destinationForm. saveClip _ clippingRectangle. saveComp _ compositionRectangle. saveRule _ rule. saveMask _ mask. "display" destinationForm _ aDisplayMedium. clippingRectangle _ clipRectangle intersect: (clippingRectangle translateBy: aDisplayPoint-compositionRectangle origin). rule _ ruleInteger. mask _ aForm. compositionRectangle moveTo: aDisplayPoint. (lastLine == nil or: [lastLine < 1]) ifTrue: [self composeAll]. self displayLines: (1 to: lastLine). "restore state" destinationForm _ saveDest. clippingRectangle _ saveClip. compositionRectangle _ saveComp. rule _ saveRule. mask _ saveMask.! ! !Paragraph class methodsFor: 'instance creation' stamp: 'di 1/23/1999 12:13'! withText: aText style: aTextStyle compositionRectangle: compRect clippingRectangle: clipRect ^ self withText: aText style: aTextStyle compositionRectangle: compRect clippingRectangle: clipRect foreColor: Color black backColor: Color white! ! !ParseNode methodsFor: 'ThingLab'! isLoadSelf ^false! ! !ParseNode methodsFor: 'ThingLab'! recode: encoder "return a copy of me encoded for the new encoder" ^self relocatePaths: EmptyPath encoder: encoder! ! !ParseNode methodsFor: 'ThingLab'! relocatePaths: ownerPath encoder: encoder "return a new ParseNode with access paths relocated for new owner" ^self relocatePaths: ownerPath encoder: encoder specialVars: Dictionary new! ! !ParseNode methodsFor: 'ThingLab'! relocatePaths: ownerPath encoder: encoder specialVars: specialVars "return a new ParseNode with access paths relocated for new owner" self subclassResponsibility! ! !AssignmentNode methodsFor: 'ThingLab'! makePathFor: owner "Return a path to the variable that I assign into" ^variable asPath! ! !AssignmentNode methodsFor: 'ThingLab'! relocatePaths: ownerPath encoder: encoder specialVars: specialVars "return a new AssignmentNode with access paths relocated for new owner" ^self class new variable: (variable relocatePaths: ownerPath encoder: encoder specialVars: specialVars) value: (value relocatePaths: ownerPath encoder: encoder specialVars: specialVars)! ! !BlockNode methodsFor: 'ThingLab' stamp: 'di 1/23/1999 12:54'! relocatePaths: ownerPath encoder: encoder specialVars: specialVars "return a new BlockNode with access paths relocated for new owner" arguments do: [:a | encoder findOrBindBlockArg: a key]. ^self class new arguments: (arguments collect: [:a | a relocatePaths: ownerPath encoder: encoder specialVars: specialVars]) statements: (statements collect: [:s | s relocatePaths: ownerPath encoder: encoder specialVars: specialVars]) returns: returns from: encoder! ! !BlockNode methodsFor: 'ThingLab'! statements ^statements! ! !CascadeNode methodsFor: 'ThingLab'! relocatePaths: ownerPath encoder: encoder specialVars: specialVars "return a new CascadeNode with access paths relocated for new owner" ^self class new receiver: (receiver relocatePaths: ownerPath encoder: encoder specialVars: specialVars) messages: (messages collect: [:m | m relocatePaths: ownerPath encoder: encoder specialVars: specialVars])! ! !Encoder methodsFor: 'ThingLab'! findOrBindBlockArg: name "message for use with ThingLab - allows repeatedly finding or binding an argument of a BlockNode whose paths are being relocated" | node | node _ scopeTable at: name ifAbsent: [self bindTemp: name]. node isTemp ifFalse: [self error: 'name in use - not a temp']. ^node! ! !Encoder methodsFor: 'ThingLab'! targetClass ^class! ! !LiteralNode methodsFor: 'ThingLab'! relocatePaths: ownerPath encoder: encoder specialVars: specialVars ^encoder encodeLiteral: key! ! !MessageNode methodsFor: 'ThingLab'! arguments ^arguments! ! !MessageNode methodsFor: 'ThingLab'! asPath "I should be part of code representing a path to a subpart. Return the corresponding path." | symbol | symbol _ selector key asSymbol. symbol numArgs=0 ifFalse: [self error: 'not a path']. ^receiver asPath add: symbol! ! !MessageNode methodsFor: 'ThingLab'! makePathFor: owner "I should be part of code representing a path to a subpart. Return the corresponding path. If my selector sets the state of one of the subpart's fields, include it in the returned path. Ignore 'primitiveSet.' , 'set.' , and similar junk in selectors" | str period lastChar sel receiverPath | str _ selector key. period _ str findLast: [:c | c=$.]. "period is 0 if there isn't a period in str" lastChar _ str last=$: ifTrue: [str size-1] ifFalse: [str size]. sel _ (str copyFrom: period+1 to: lastChar) asSymbol. receiverPath _ receiver asPath. (receiverPath applyTo: owner) fieldDescriptions do: [:f | f name=sel ifTrue: [^receiverPath add: sel]]. ^receiverPath! ! !MessageNode methodsFor: 'ThingLab'! ordinaryRelocatePaths: ownerPath encoder: encoder specialVars: specialVars "return a new MessageNode with access paths relocated for new owner" ^self class new receiver: (receiver relocatePaths: ownerPath encoder: encoder specialVars: specialVars) selector: (selector relocatePaths: ownerPath encoder: encoder specialVars: specialVars) arguments: (arguments collect: [:a | a relocatePaths: ownerPath encoder: encoder specialVars: specialVars]) precedence: precedence! ! !MessageNode methodsFor: 'ThingLab'! receiver ^receiver! ! !MessageNode methodsFor: 'ThingLab'! relocatePaths: ownerPath encoder: encoder specialVars: specialVars "return a new MessageNode with access paths relocated for new owner - kludged to change selector rather than receiver if selector is a opSet.something " | sel str node | ownerPath names size<2 ifTrue: [^self ordinaryRelocatePaths: ownerPath encoder: encoder specialVars: specialVars]. sel _ selector key. (sel size>8 and: ['opSet.' = (sel copyFrom: 1 to: 8)]) ifFalse: [^self ordinaryRelocatePaths: ownerPath encoder: encoder specialVars: specialVars]. "build a new selector, patching in all but the first name on ownerPath" str _ 'opSet.'. ownerPath tail names do: [:n | str _ str , n , '.']. str _ str , (sel copyFrom: 9 to: sel size). node _ self class new receiver: (receiver relocatePaths: ownerPath first encoder: encoder specialVars: specialVars) selector: (encoder encodeSelector: str asSymbol) arguments: (arguments collect: [:a | a relocatePaths: ownerPath encoder: encoder specialVars: specialVars]) precedence: precedence. "add code to retrieve the stuff on ownerPath tail" ownerPath tail names do: [:n | node _ self class new receiver: node selector: (encoder encodeSelector: n) arguments: Array new precedence: n precedence]. ^node! ! !MessageNode methodsFor: 'ThingLab'! selector ^selector! ! !MethodNode methodsFor: 'ThingLab'! block ^block! ! !MethodNode methodsFor: 'ThingLab' stamp: 'di 1/18/1999 20:02'! compileIn: class class addSelector: self selector withMethod: (self generate: CompiledMethod nullSourceDescriptor)! ! !MethodNode methodsFor: 'ThingLab'! encoder ^encoder! ! !PluggableListMorph methodsFor: 'model access' stamp: 'di 1/20/1999 05:00'! getCurrentSelectionIndex "Answer the index of the current selection." | index | getIndexSelector == nil ifTrue: [^ 0]. (index _ model perform: getIndexSelector) ifNotNil: [^ index]. ^ 0! ! !PluggableListView methodsFor: 'model access' stamp: 'di 1/20/1999 20:27'! getCurrentSelectionIndex "Answer the index of the current selection." | index | getSelectionSelector == nil ifTrue: [^ 0]. (index _ model perform: getSelectionSelector) ifNotNil: [^ index]. ^ 0! ! !PluggableListView methodsFor: 'model access' stamp: 'di 1/21/1999 20:57'! getMenu: shiftKeyDown "Answer the menu for this text view, supplying an empty menu to be filled in. If the menu selector takes an extra argument, pass in the current state of the shift key." | menu aMenu | getMenuSelector == nil ifTrue: [^ nil]. getMenuSelector numArgs = 0 ifTrue: [aMenu _ model perform: getMenuSelector. getMenuTitleSelector ifNotNil: [aMenu title: (model perform: getMenuTitleSelector)]. ^ aMenu]. menu _ CustomMenu new. getMenuSelector numArgs = 1 ifTrue: [aMenu _ model perform: getMenuSelector with: menu. getMenuTitleSelector ifNotNil: [aMenu title: (model perform: getMenuTitleSelector)]. ^ aMenu]. getMenuSelector numArgs = 2 ifTrue: [aMenu _ model perform: getMenuSelector with: menu with: shiftKeyDown. getMenuTitleSelector ifNotNil: [aMenu title: (model perform: getMenuTitleSelector)]. ^ aMenu]. ^ self error: 'The getMenuSelector must be a 1- or 2-keyword symbol'! ! !PluggableTextView methodsFor: 'model access' stamp: 'di 1/23/1999 06:25'! getMenu: shiftKeyDown "Answer the menu for this text view, supplying an empty menu to be filled in. If the menu selector takes an extra argument, pass in the current state of the shift key." | menu | getMenuSelector == nil ifTrue: [^ nil]. getMenuSelector numArgs = 0 ifTrue: [^ model perform: getMenuSelector]. menu _ CustomMenu new. getMenuSelector numArgs = 1 ifTrue: [^ model perform: getMenuSelector with: menu]. getMenuSelector numArgs = 2 ifTrue: [^ model perform: getMenuSelector with: menu with: shiftKeyDown]. ^ self error: 'The getMenuSelector must be a 1- or 2-keyword symbol'! ! !Point methodsFor: 'ThingLab'! computedLocation ^self! ! !Point methodsFor: 'ThingLab'! containsPoint: pt ^self enclosingFrame containsPoint: pt! ! !Point methodsFor: 'ThingLab'! copyFieldsFrom: pt x _ pt x. y _ pt y! ! !Point methodsFor: 'ThingLab'! enclosingFrameOrNil ^self - 5 corner: self + 6! ! !Point methodsFor: 'ThingLab'! expandFixedLocation: message planner: planner planner addMethod: (MessagePlan new context: message context receiver: message receiver constraint: message constraint owner: message owner keywords: #('primitiveFix') arguments: message arguments uniqueState: message uniqueState referenceOnly: message referenceOnly compileTimeOnly: message compileTimeOnly)! ! !Point methodsFor: 'ThingLab'! expandMove: message planner: planner planner addMethod: (MessagePlan new context: message context receiver: message receiver constraint: message constraint owner: message owner keywords: #('primitiveMoveby:') arguments: message arguments uniqueState: message uniqueState referenceOnly: message referenceOnly compileTimeOnly: message compileTimeOnly)! ! !Point methodsFor: 'ThingLab'! expandScale: message planner: planner planner add: (MessagePlan new context: message context receiver: message receiver constraint: message constraint owner: message owner keywords: #('primitiveScaleby:') arguments: message arguments uniqueState: message uniqueState referenceOnly: message referenceOnly compileTimeOnly: message compileTimeOnly)! ! !Point methodsFor: 'ThingLab'! largestRelaxablePart: path prefixPath: prefix | | ^prefix "return a path to the largest of my subparts that can be relaxed. I am relaxable."! ! !Point methodsFor: 'ThingLab'! line: pt ^ThingLabLine point1: self point2: pt! ! !Point methodsFor: 'ThingLab'! mergeWith: other self updateSometime. (other == nil or: [other class == Point]) ifFalse: [ "take on my state as the result of the merge" self error: 'classes not compatable for merging']! ! !Point methodsFor: 'ThingLab'! primitiveMoveby: delta x _ x + delta x. y _ y + delta y! ! !Point methodsFor: 'ThingLab'! primitiveScaleby: s x _ x*s. y _ y*s! ! !Point methodsFor: 'ThingLab'! printTableOfFields: strm self printOn: strm! ! !Point methodsFor: 'ThingLab'! relaxationSolveSelector ^ #solvePoint! ! !Point methodsFor: 'ThingLab'! rotate: sin cos: cos ^Point new x: (cos * x + (sin * y)) rounded y: (cos * y - (sin * x)) rounded! ! !Point methodsFor: 'ThingLab'! showPicture: medium DotForShow displayOn: medium at: self! ! !Point methodsFor: 'ThingLab'! thingString ^self printString! ! !Point methodsFor: 'ThingLab'! withinTolerance: other ^(self-other) abs <= (1@1)! ! !Point methodsFor: 'ThingLab' stamp: 'di 1/24/1999 11:15'! x: newX x _ newX! ! !Point methodsFor: 'ThingLab' stamp: 'di 1/24/1999 11:15'! y: newY y _ newY! ! !Point class methodsFor: 'ThingLab'! initializePrototype "make Point into a ThingLab thing" "Point initializePrototype" | pt | self findOrAddClassVarName: #PointFieldDescriptions. self findOrAddClassVarName: #PointPrototype. self findOrAddClassVarName: #DotForShow. PointFieldDescriptions _ super prototypeFieldDescriptions. pt _ 10@10. pt bePrototypeInstance. pt primitives: 'x y'. DotForShow _ Form dotOfSize: 5. PointPrototype _ pt! ! !Point class methodsFor: 'ThingLab'! prototype self==Point ifTrue: [^PointPrototype] ifFalse: [^super prototype]! ! !Point class methodsFor: 'ThingLab'! prototypeFieldDescriptions ^PointFieldDescriptions! ! !Rectangle methodsFor: 'ThingLab'! enclosingFrameOrNil ^self! ! !Rectangle methodsFor: 'ThingLab'! printTableOfFields: strm strm nextPut: $(. self printOn: strm. strm nextPut: $)! ! !Rectangle methodsFor: 'ThingLab' stamp: 'di 1/21/1999 19:25'! showPicture: medium "show a light gray rectangle if I've been turned inside out" | r | origin<=corner ifTrue: [medium border: (self insetBy: (0@0 corner: -1@-1)) width: 2 fillColor: Color black] ifFalse: [r _ (origin min: corner) corner: (origin max: corner). medium border: r width: 1 fillColor: Color gray]! ! !Rectangle class methodsFor: 'ThingLab'! initializePrototype "make Rectangle into a ThingLab thing" "Rectangle initializePrototype" | rect | self findOrAddClassVarName: #RectangleFieldDescriptions. self findOrAddClassVarName: #RectanglePrototype. self findOrAddClassVarName: #RectangleInserters. RectangleFieldDescriptions _ super prototypeFieldDescriptions. rect _ self origin: 10 @ 10 corner: 30 @ 22. "golden ratio rectangle" rect bePrototypeInstance. rect parts: 'origin corner'. RectangleInserters _ Array with: 'origin' asPath with: 'corner' asPath. RectanglePrototype _ rect! ! !Rectangle class methodsFor: 'ThingLab'! prototype self==Rectangle ifTrue: [^RectanglePrototype] ifFalse: [^super prototype]! ! !Rectangle class methodsFor: 'ThingLab'! prototypeFieldDescriptions ^RectangleFieldDescriptions! ! !Rectangle class methodsFor: 'ThingLab'! prototypeInserters ^RectangleInserters! ! !ReturnNode methodsFor: 'ThingLab'! relocatePaths: ownerPath encoder: encoder specialVars: specialVars "return a new ReturnNode with access paths relocated for new owner" ^self class new expr: (expr relocatePaths: ownerPath encoder: encoder specialVars: specialVars)! ! !Scanner methodsFor: 'multi-character scans' stamp: 'di 1/18/1999 19:44'! xLetter "Form a word or keyword." "Modified to allow embedded dots'" | type | buffer reset. [((type _ typeTable at: hereChar asciiValue) == #xLetter or: [type == #xDigit]) or: [type == #period and: [aheadChar isLetter]]] whileTrue: ["open code step for speed" buffer nextPut: hereChar. hereChar _ aheadChar. source atEnd ifTrue: [aheadChar _ 30 asCharacter "doit"] ifFalse: [aheadChar _ source next]]. (type == #colon or: [type = #xColon and: [aheadChar ~= $=]]) ifTrue: [buffer nextPut: self step. tokenType _ #keyword] ifFalse: [tokenType _ #word]. token _ buffer contents! ! !ScreenController methodsFor: 'nested menus' stamp: 'di 1/18/1999 20:15'! openMenu ^ SelectionMenu labelList: #( 'keep this menu up' 'browser' 'workspace' 'file list' 'transcript' 'selector finder' 'simple change sorter' 'dual change sorter' 'project (mvc)' 'project (morphic)' 'project (construction)' 'ThingLab browser' 'ThingLab definer' ) lines: #(1 6 8 11) selections: #(durableOpenMenu openBrowser openWorkspace openFileList openTranscript openSelectorBrowser openSimpleChangeSorter openChangeManager openProject openMorphicProject openConstructionProject openThingLabBrowser openThingLabObjectDefiner) " ScreenController new openMenu startUp "! ! !ScreenController methodsFor: 'ThingLab' stamp: 'di 1/20/1999 14:17'! openThingLabBrowser ThingLabBrowser open! ! !ScreenController methodsFor: 'ThingLab'! openThingLabObjectDefiner ObjectDefinerView open! ! !SelectorNode methodsFor: 'ThingLab'! relocatePaths: ownerPath encoder: encoder specialVars: specialVars ^encoder encodeSelector: key! ! !Set methodsFor: 'thinglab'! copyFieldsFrom: other self init. other do: [:x | self add: x recopy]! ! !Set methodsFor: 'thinglab'! init "Clean me out and shrink by half" self become: (self species new: (self basicSize // 2 max: 8))! ! !String methodsFor: 'system primitives' stamp: 'di 1/23/1999 11:35'! numArgs "Answer either the number of arguments that the receiver would take if considered a selector. Answer -1 if it couldn't be a selector. Note that currently this will answer -1 for anything begining with an uppercase letter even though the system will accept such symbols as selectors. It is intended mostly for the assistance of spelling correction." "Tweaked to allow embedded periods for ThingLab" | firstChar numColons | firstChar _ self at: 1. firstChar isLetter ifTrue: [ firstChar isUppercase ifTrue: [ ^ -1 ]. numColons _ 0. self do: [ :ch | (ch tokenish or: [ch = $.]) ifFalse: [ ^ -1 ]. (ch = $:) ifTrue: [numColons _ numColons + 1] ]. ^ (self last = $:) ifTrue: [ numColons > 0 ifTrue: [ numColons ] ifFalse: [ -1 ] ] ifFalse: [ numColons > 0 ifTrue: [ -1 ] ifFalse: [ 0 ] ] ]. firstChar isSpecial ifTrue: [self size = 1 ifTrue: [^ 1]. self size > 2 ifTrue: [^ -1]. ^ (self at: 2) isSpecial ifTrue: [1] ifFalse: [-1]]. self = #- ifTrue: [ ^ 1 ]. ^ -1.! ! !String methodsFor: 'ThingLab'! asPath ^self asTokens asPath! ! !String methodsFor: 'ThingLab'! asTokens ^ Scanner new scanTokens: self! ! !String methodsFor: 'ThingLab' stamp: 'di 1/23/1999 11:49'! clonePrototype "Look up the class that I name and return a copy of its prototype" ^self lookupClass prototype recopy! ! !String methodsFor: 'ThingLab'! getArg: n "I should be a declaration string. Return the n-th argument, or an empty string if none" | a | a _ Parser new parseArgsAndTemps: self getSelectorAndArgs notifying: nil. a size < n ifTrue: [^''] ifFalse: [^a at: n]! ! !String methodsFor: 'ThingLab'! getFieldClass | i | "I should be a field declaration string. Return the field class" i _ self indexOf: Character space. i = 0 ifTrue: [self error: 'bad declaration']. ^Smalltalk at: (self copyFrom: i+1 to: self size) asSymbol! ! !String methodsFor: 'ThingLab'! getFieldName | i | "I should be a field declaration string. Return the field name" i _ self indexOf: $:. i = 0 ifTrue: [self error: 'bad declaration']. ^self copyFrom: 1 to: i-1! ! !String methodsFor: 'ThingLab'! getReceiverName | i | "I should be a declaration string. Return the receiver name" i _ self indexOf: Character space. i = 0 ifTrue: [self error: 'bad declaration']. ^(self copyFrom: 1 to: i-1) asSymbol! ! !String methodsFor: 'ThingLab'! getSelector "I should be a declaration string. Return the selector" ^Parser new parseSelector: self getSelectorAndArgs! ! !String methodsFor: 'ThingLab'! getSelectorAndArgs | i | "I should be a declaration string. Return everything after the receiver name" i _ self indexOf: Character space. i = 0 ifTrue: [self error: 'bad declaration']. ^self copyFrom: i+1 to: self size! ! !String methodsFor: 'ThingLab' stamp: 'di 1/22/1999 12:25'! lookupClass "Look up the class that I name and return it. If the class is not found, try to find an appropriate file and file it in. Look for a directory named 'things', and look there first, and then in the current directory" | cl fileName fullFileName dirList | cl _ Smalltalk at: self asSymbol ifAbsent: [nil]. cl notNil ifTrue: [^cl]. fileName _ self , '.st'. (FileDirectory default includesKey: 'things') ifTrue: [dirList _ Array with: (FileDirectory default directoryNamed: 'things') with: FileDirectory default] ifFalse: [dirList _ Array with: FileDirectory default]. dirList do: [:d | (d includesKey: fileName) ifTrue: [fullFileName _ d fullNameFor: fileName. (FileStream readOnlyFileNamed: fullFileName) fileIn. ^ Smalltalk at: self asSymbol]]. self error: 'couldn''t find a thing definition file'! ! !String methodsFor: 'ThingLab' stamp: 'di 1/18/1999 19:54'! pathFromDottedSelector "I should be a string consisting of unary selectors separated by periods. Return a path consisting of these unary selectors" | withoutColon strm names | withoutColon _ (self last=$:) ifTrue: [self copyFrom: 1 to: self size-1] ifFalse: [self]. (withoutColon includes: $:) ifTrue: [self error: 'bad selector']. strm _ ReadStream on: withoutColon. names _ Array new. [strm atEnd] whileFalse: [names _ names copyWith: (strm upTo: $.) asSymbol]. ^AccessPath new names: names! ! !Symbol methodsFor: 'ThingLab'! isUnary "Answer whether the receiver is a unary message selector." ^(self at: 1) isLetter and: [(self includes: $:) not]! ! !Symbol methodsFor: 'ThingLab'! precedence "1 => unary selector, 2 => binary selector, and 3 => keyword selector." ^self isInfix ifTrue: [2] ifFalse: [self isKeyword ifTrue: [3] ifFalse: [1]]! ! !Symbol methodsFor: 'ThingLab'! recopy: dict ^self! ! !Text methodsFor: 'ThingLab'! asNumberOrNil ^ string size=0 ifTrue: [nil] ifFalse: [string asNumber]! ! !Text methodsFor: 'ThingLab'! textExtent "assuming no wraparound, return the extent of my text" | lastNonSeparator para | "delete trailing separators" lastNonSeparator _ string size. [(string at: lastNonSeparator) isSeparator] whileTrue: [lastNonSeparator _ lastNonSeparator-1]. para _ Paragraph withText: (self copyFrom: 1 to: lastNonSeparator) style: TextStyle default. ^para compositionRectangle extent! ! !True methodsFor: 'ThingLab'! asError ^0.0! ! !UndefinedObject methodsFor: 'ThingLab'! prototype "only Behaviors should be sent the message prototype ... message defined here to check for the common error of asking for the prototype when the definition hasn't been filed in yet" self error: 'prototype requested for an undefined class'! ! !UndefinedObject methodsFor: 'ThingLab'! recopy: dict ^self! ! !UndefinedObject methodsFor: 'ThingLab'! thingString ^ ''! ! !VariableNode methodsFor: 'ThingLab'! asPath key='self' ifTrue: [^EmptyPath] ifFalse: [^AccessPath new names: (Array with: name asSymbol)]! ! !VariableNode methodsFor: 'ThingLab'! isInstVar "Answer true if this describes an instance variable" code < 0 ifTrue: [^code = LdInstType negated]. code > 255 ifTrue: [^code between: LdInstType * 256 and: LdInstType * 256 + 255]. ^code between: (CodeBases at: 1) and: (CodeBases at: 1) + (CodeLimits at: 1) - 1! ! !VariableNode methodsFor: 'ThingLab'! isLoadSelf ^key='self'! ! !VariableNode methodsFor: 'ThingLab'! key ^key! ! !VariableNode methodsFor: 'ThingLab'! relocatePaths: ownerPath encoder: encoder specialVars: specialVars "return a new VariableNode with access paths relocated for new owner" (specialVars includesKey: key) ifTrue: [^specialVars at: key]. self==NodeSelf ifTrue: [^ownerPath code: encoder]. self isInstVar ifTrue: [^(ownerPath add: key asSymbol) code: encoder]. ^encoder encodeVariable: name! ! !WriteStream methodsFor: 'ThingLab'! removeTrailingBlanks "remove all trailing blanks from my end" [self isEmpty not and: [(collection at: position) = $ ]] whileTrue: [self position: position-1]! !