home *** CD-ROM | disk | FTP | other *** search
/ RISC DISC 1 / RISC_DISC_1.iso / pd_share / code / smalltalk / !GNUst / st / Behavior < prev    next >
Encoding:
Text File  |  1991-09-13  |  11.2 KB  |  464 lines
  1. "======================================================================
  2. |
  3. |   Behavior Method Definitions
  4. |
  5.  ======================================================================"
  6.  
  7.  
  8. "======================================================================
  9. |
  10. | Copyright (C) 1990, 1991 Free Software Foundation, Inc.
  11. | Written by Steve Byrne.
  12. |
  13. | This file is part of GNU Smalltalk.
  14. |
  15. | GNU Smalltalk is free software; you can redistribute it and/or modify it
  16. | under the terms of the GNU General Public License as published by the Free
  17. | Software Foundation; either version 1, or (at your option) any later version.
  18. | 
  19. | GNU Smalltalk is distributed in the hope that it will be useful, but WITHOUT
  20. | ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
  21. | FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more
  22. | details.
  23. | 
  24. | You should have received a copy of the GNU General Public License along with
  25. | GNU Smalltalk; see the file COPYING.  If not, write to the Free Software
  26. | Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  
  27. |
  28.  ======================================================================"
  29.  
  30.  
  31. "
  32. |     Change Log
  33. | ============================================================================
  34. | Author       Date       Change 
  35. | sbb         12 Sep 91      Fixed isBytes and isWords so that subclassing for
  36. |              things like Dictionary works properly.
  37. |
  38. | sbyrne     25 Apr 89      created.
  39. |
  40. "
  41.  
  42. Object subclass: #Behavior
  43.        instanceVariableNames: 'superClass subClasses 
  44.                                methodDictionary instanceSpec'
  45.        classVariableNames: ''
  46.        poolDictionaries: ''
  47.        category: nil.
  48.  
  49. Behavior comment: 
  50. 'I am the parent class of all "class" type methods.  My instances know
  51. about the subclass/superclass relationships between classes, contain
  52. the description that instances are created from, and hold the method
  53. dictionary that''s associated with each class.  I provide methods for
  54. compiling methods, modifying the class inheritance hierarchy, examining the
  55. method dictionary, and iterating over the class hierarchy.' !
  56.  
  57. CFunctionDescs at: #CFunctionGensym put: 1!
  58.  
  59. !Behavior class methodsFor: 'C interface'!
  60.  
  61. defineCFunc: cFuncNameString
  62.   withSelectorArgs: selectorAndArgs
  63.   forClass: aClass 
  64.   returning: returnTypeSymbol 
  65.   args: argsArray
  66.     | stream gensym descriptor |
  67.     "This is pretty complex.  What I want to provide is a very efficient way
  68.      of calling a C function.  I create a descriptor object that holds the
  69.      relevant information regarding the C function.  I then compile the
  70.      method that's to be invoked to call the C function.  This method uses the
  71.      primitive #255 to perform the actual call-out.  To let the primitive
  72.      know which descriptor to use, I arrange for the first and only method
  73.      literal of the compiled method to be an association that contains as
  74.      its value the C function descriptor object.  I add new associations to
  75.      the global shared pool 'CFunctionDescs', and reference the newly
  76.      generated key in the text of the compiled method."
  77.     gensym _ Symbol intern: ('CFunction' , CFunctionGensym printString).
  78.     CFunctionGensym _ CFunctionGensym + 1.
  79.     descriptor _ self makeDescriptorFor: cFuncNameString
  80.                       returning: returnTypeSymbol
  81.                   withArgs: argsArray.
  82.     CFunctionDescs at: gensym put: descriptor.
  83.     stream _ WriteStream on: (String new: 5).
  84.     stream nextPutAll: selectorAndArgs.    
  85.     stream nextPutAll:
  86. '
  87.     <primitive: 255>
  88.     ^'.
  89.     gensym printOn: stream.
  90.     aClass compile: stream contents
  91. !!
  92.  
  93.  
  94.  
  95. !Behavior methodsFor: 'creating method dictionary'!
  96.  
  97. methodDictionary: aDictionary
  98.     methodDictionary _ aDictionary
  99. !
  100.  
  101. addSelector: selector withMethod: compiledMethod
  102.     methodDictionary at: selector put: compiledMethod
  103. !
  104.  
  105. removeSelector: selector
  106.     methodDictionary removeKey: selector
  107. !
  108.  
  109. compile: code
  110.     (code isKindOf: PositionableStream)
  111.         ifTrue: [ code _ code contents ].
  112.     (code isMemberOf: String)
  113.         ifFalse: [ code _ code asString ].
  114.     self compileString: code
  115. !
  116.  
  117. compile: code notifying: requestor
  118.     self notYetImplemented
  119. !
  120.  
  121. recompile: selector
  122.     self compile: (self sourceCodeAt: selector)
  123. !
  124.  
  125. decompile: selector
  126.     | method source |
  127.     method _ self compiledMethodAt: selector.
  128.     source _ method methodSourceString.
  129.     source isNil
  130.         ifTrue: [ ^self error: 'decompiler can''t decompile methods without source (yet)' ]
  131.     ifFalse: [ ^source ]
  132. !
  133.  
  134. edit: selector
  135.     | method sourceFile sourcePos |
  136.     method _ self compiledMethodAt: selector.
  137.     sourceFile _ method methodSourceFile.
  138.     sourceFile isNil
  139.         ifTrue: [ ^self error: 'decompiler can''t decompile methods without source (yet)' ].
  140.     sourcePos _ method methodSourcePos.
  141.     Smalltalk system: 'emacs -l st -smalltalk ', sourceFile, ' ', sourcePos printString
  142. !
  143.  
  144. compileAll
  145.     methodDictionary keysDo: [ :selector | self recompile: selector ]
  146. !
  147.  
  148. compileAllSubclasses
  149.     self allSubclassesDo: [ :subclass | subclass compileAll ]
  150. !!
  151.  
  152.  
  153.  
  154. !Behavior methodsFor: 'creating a class hierarchy'!
  155.  
  156. superclass: aClass
  157.     superClass _ aClass
  158. !
  159.  
  160. addSubclass: aClass
  161.     subClasses isNil ifTrue: [ subClasses _ Array new: 0 ].
  162.     subClasses _ subClasses copyWithout: aClass. "remove old class if any"
  163.     subClasses _ subClasses copyWith: aClass
  164. !
  165.  
  166. removeSubclass: aClass
  167.     subClasses _ subClasses copyWithout: aClass
  168. !!
  169.  
  170.  
  171.  
  172. !Behavior methodsFor: 'accessing the methodDictionary'!
  173.  
  174. selectors
  175.     methodDictionary isNil
  176.         ifTrue: [ ^Set new ]
  177.     ifFalse: [ ^methodDictionary keys ]
  178. !
  179.  
  180. allSelectors
  181.     | aSet |
  182.     aSet _ self selectors.
  183.     self allSuperclassesDo:
  184.         [ :superclass | aSet addAll: superclass selectors ].
  185.     ^aSet
  186. !
  187.  
  188. compiledMethodAt: selector
  189.     "Return the compiled method associated with selector, from the local
  190.     method dictionary.  Error if not found."
  191.     ^methodDictionary at: selector
  192. !
  193.  
  194. sourceCodeAt: selector
  195.     | method |
  196.     method _ self compiledMethodAt: selector.
  197.     ^method methodSourceString
  198. !
  199.  
  200. sourceMethodAt: selector
  201.     "This is too dependent on the original implementation"
  202.     self shouldNotImplement
  203. !!
  204.  
  205.  
  206.  
  207. !Behavior methodsFor: 'accessing instances and variables'!
  208.  
  209. allInstances
  210.     "Returns a set of all instances of the receiver"
  211.     | aSet |
  212.     aSet _ Set new.
  213.     self allInstancesDo: [ :anInstance | aSet add: anInstance ].
  214.     ^aSet
  215. !
  216.  
  217. instanceCount
  218.     | count anInstance |
  219.     count _ 0.
  220.     anInstance _ self someInstance.
  221.     [ anInstance notNil ]
  222.         whileTrue: [ count _ count + 1.
  223.                  anInstance _ anInstance nextInstance ].    
  224.     ^count
  225. !
  226.     
  227. instVarNames
  228.     self subclassResponsibility "### is this right?  Why is it here instead of
  229.                                  in ClassDescription?"
  230. !
  231.  
  232. subclassInstVarNames
  233.     self subclassResponsibility
  234. !
  235.  
  236. allInstVarNames
  237.     self subclassResponsibility
  238. !
  239.  
  240. classVarNames
  241.     self subclassResponsibility 
  242. !
  243.  
  244. allClassVarNames
  245.     self subclassResponsibility
  246. !
  247.  
  248. sharedPools
  249.     self subclassResponsibility
  250. !
  251.  
  252. allSharedPools
  253.     self subclassResponsibility
  254. !!
  255.  
  256.  
  257.  
  258. !Behavior methodsFor: 'accessing class hierarchy'!
  259.  
  260. subclasses
  261.     subClasses isNil
  262.     ifTrue: [ ^Set new ]
  263.     ifFalse: [ ^subClasses asSet ]
  264. !
  265.  
  266. allSubclasses
  267.     | aSet |
  268.     aSet _ Set new.
  269.     self allSubclassesDo: [ :subclass | aSet addAll: subclass subclasses ].
  270.     ^aSet
  271. !
  272.  
  273. withAllSubclasses
  274.     | aSet |
  275.     aSet _ Set with: self.
  276.     self allSubclassesDo: 
  277.         [ :subclass | aSet addAll: (subclass withAllSubclasses)    ].
  278.     ^aSet
  279. !
  280.  
  281. superclass
  282.     ^superClass
  283. !
  284.  
  285. allSuperclasses
  286.     | supers |
  287.     supers _ OrderedCollection new.
  288.     self allSuperclassesDo:
  289.         [ :superclass | supers addLast: superclass ].
  290.     ^supers
  291. !!
  292.  
  293.  
  294.  
  295. !Behavior methodsFor: 'testing the method dictionary'!
  296.  
  297. hasMethods
  298.     ^methodDictionary notNil and: [ methodDictionary size ~= 0 ]
  299. !
  300.  
  301. includesSelector: selector
  302.     "Returns true if the local method dictionary"
  303.     ^methodDictionary notNil and: [ methodDictionary includesKey: selector ]
  304. !
  305.  
  306. canUnderstand: selector
  307.     (self includesSelector: selector)
  308.         ifTrue: [ ^true ].
  309.     self allSuperclassesDo:
  310.         [ :superclass | (superclass includesSelector: selector)
  311.                         ifTrue: [ ^true ] ].
  312.     ^false
  313. !
  314.  
  315. whichClassIncludesSelector: selector
  316.     self allSuperclassesDo:
  317.         [ :superclass | (superclass includesSelector: selector)
  318.                         ifTrue: [ ^superclass ] ].
  319.     ^nil
  320. !
  321.  
  322. whichSelectorsAccess: instVarName
  323.     self notYetImplemented
  324. !
  325.  
  326. whichSelectorsReferTo: anObject
  327.     self notYetImplemented
  328. !
  329.  
  330. scopeHas: name ifTrue: aBlock
  331.     self notYetImplemented
  332. !!
  333.  
  334.  
  335.  
  336. !Behavior methodsFor: 'testing the form of the instances'!
  337.  
  338. isPointers
  339.     "Due to our representation bit 30 is inverted, so we invert the sense
  340.     of this test, and things work out fine."
  341.     ^(self instanceSpec bitAt: 30) = 0
  342. !
  343.  
  344. isBits
  345.     ^self isPointers not
  346. !
  347.  
  348. isBytes
  349.     ^self isPointers not & self isWords not
  350. !
  351.  
  352. isWords
  353.     ^self isPointers not & ((self instanceSpec bitAt: 29) ~= 0)
  354. !
  355.  
  356. isFixed
  357.     ^self isVariable not
  358. !
  359.  
  360. isVariable
  361.     ^(self instanceSpec bitAt: 28) ~= 0
  362. !
  363.  
  364. instSize
  365.     ^self instanceSpec bitAnd: 16r0FFFFFFF
  366. !!
  367.  
  368.  
  369.  
  370. !Behavior methodsFor: 'testing the class hierarchy'!
  371.  
  372. inheritsFrom: aClass
  373.     "Returns true if aClass is a superclass of the receiver"
  374.     | sc |
  375.     sc _ self.
  376.     [ sc _ sc superclass.
  377.       sc isNil ]
  378.         whileFalse:
  379.         [ sc == aClass ifTrue: [ ^true ] ].
  380.     ^false
  381. !
  382.  
  383. kindOfSubclass
  384.     self isVariable
  385.         ifTrue: [ self isBytes ifTrue: [ ^'variableByteSubclass: ' ].
  386.               self isPointers
  387.             ifTrue: [ ^'variableSubclass: ' ]
  388.             ifFalse: [ ^'variableWordSubclass: ' ] ]
  389.     ifFalse: [ ^'subclass: ' ]
  390. !!
  391.  
  392.  
  393.  
  394. !Behavior methodsFor: 'enumerating'!
  395.  
  396. allSubclassesDo: aBlock
  397.     "### I hope this means all direct subclasses"
  398.     subClasses notNil
  399.     ifTrue: [ subClasses do: [ :subclass | aBlock value: subclass ] ]
  400. !
  401.  
  402. allSuperclassesDo: aBlock
  403.     | class superclass |
  404.     class _ self.
  405.     [ superclass _ class superclass.
  406.       class _ superclass.
  407.       superclass notNil ] whileTrue:
  408.           [ aBlock value: superclass ]
  409. !
  410.  
  411. allInstancesDo: aBlock
  412.     | anInstance |
  413.     anInstance _ self someInstance.
  414.     [ anInstance notNil ]
  415.         whileTrue: [ aBlock value: anInstance.
  416.                  anInstance _ anInstance nextInstance ]
  417. !
  418.  
  419. allSubinstancesDo: aBlock
  420.     self allSubclassesDo:
  421.         [ :subclass | subclass allInstancesDo: aBlock ]
  422. !
  423.  
  424. selectSubclasses: aBlock
  425.     | aSet |
  426.     aSet _ Set new.
  427.     self allSubclassesDo: [ :subclass | (aBlock value: subclass)
  428.                                             ifTrue: [ aSet add: subclass ] ].
  429.     ^aSet
  430. !
  431.  
  432. selectSuperclasses: aBlock
  433.     | aSet |
  434.     aSet _ Set new.
  435.     self allSuperclassesDo: [ :superclass | (aBlock value: superclass)
  436.                                             ifTrue: [ aSet add: superclass ] ].
  437.     ^aSet
  438. !!
  439.  
  440.  
  441.  
  442.  
  443. !Behavior methodsFor: 'private'!
  444.  
  445. instanceSpec
  446.     ^instanceSpec
  447. !
  448.  
  449. setInstanceSpec: variableBoolean
  450.   words: wordsBoolean
  451.   pointers: pointersBoolean
  452.   instVars: anIntegerSize
  453.     instanceSpec _ 0.
  454.     "Due to our representation bit 30 is inverted, so we invert the sense
  455.     of this test, and things work out fine."
  456.     pointersBoolean
  457.         ifFalse: [ instanceSpec _ instanceSpec bitOr: ( 1 bitShift: 30 ) ].
  458.     wordsBoolean
  459.         ifTrue: [ instanceSpec _ instanceSpec bitOr: ( 1 bitShift: 29 ) ].
  460.     variableBoolean
  461.         ifTrue: [ instanceSpec _ instanceSpec bitOr: ( 1 bitShift: 28 ) ].
  462.     instanceSpec _ instanceSpec bitOr: (anIntegerSize bitAnd: 16r0FFFFFFF).
  463. !!
  464.