1 "

     2  COPYRIGHT (c) 1989-93 by Claus Gittinger

     3                All Rights Reserved

     4 

     5  This software is furnished under a license and may be used

     6  only in accordance with the terms of that license and with the

     7  inclusion of the above copyright notice.   This software may not

     8  be provided or otherwise made available to, or used by, any

     9  other person.  No title to or ownership of the software is

    10  hereby transferred.

    11 "

    12 

    13 ClassDescription subclass:#Class

    14        instanceVariableNames:'classvars comment subclasses'

    15        classVariableNames:'updatingChanges'

    16        poolDictionaries:''

    17        category:'Kernel-Classes'

    18 !

    19 

    20 Class comment:'

    21 

    22 COPYRIGHT (c) 1989-93 by Claus Gittinger

    23               All Rights Reserved

    24 

    25 This class adds more functionality to classes; minimum stuff has already

    26 been defined in Behavior; this one adds naming, categories etc.

    27 also changes management and recompilation is defined here.

    28 

    29 For a minimum system, the compiler generates classes as instances of

    30 Behavior - this excludes all name, source info etc., however, the more 

    31 usual case is to create instances of Class.

    32 

    33 Instance variables:

    34 

    35 classvars       <String>        the names of the class variables

    36 comment         <String>        the classes comment

    37 subclasses      <Collection>    cached collection of subclasses

    38                                 (currently unused - but will be soon)

    39 

    40 Class variables:

    41 

    42 updatingChanges <Boolean>       true if the changes-file shall be updated

    43 

    44 WARNING: layout known by compiler and runtime system

    45 

    46 %W% %E%

    47 written Spring 89 by claus

    48 '!

    49 

    50 !Class class methodsFor:'initialization'!

    51 

    52 initialize

    53     "the classvariable 'updatingChanges' controls if changes are put

    54      into the changes-file; normally this variable is set to true, but

    55      for example during fileIn or when changes are applied, it is set to false

    56      to prevent changes file from getting too much junk."

    57      

    58     updatingChanges := true

    59 ! !

    60 

    61 !Class class methodsFor:'creating new classes'!

    62 

    63 new

    64     "creates and returs a new class"

    65 

    66     |newClass|

    67 

    68     newClass := super new.

    69     newClass setComment:(self comment)

    70                category:(self category).

    71     ^ newClass

    72 ! !

    73 

    74 !Class methodsFor:'autoload check'!

    75 

    76 autoload

    77     "force autoloading - do nothing here; redefined in Autoload;

    78      see comment there"

    79 

    80     ^ self

    81 ! !

    82 

    83 !Class methodsFor:'subclass creation'!

    84 

    85 subclass:t instanceVariableNames:f

    86               classVariableNames:d

    87                 poolDictionaries:s

    88                         category:cat

    89 

    90     "create a new class as a subclass of an existing class (the receiver).

    91      The subclass will have indexed variables if the receiving-class has."

    92 

    93     self isVariable ifFalse:[

    94         ^ self class

    95             name:t

    96             inEnvironment:Smalltalk

    97             subclassOf:self

    98             instanceVariableNames:f

    99             variable:false

   100             words:true

   101             pointers:true

   102             classVariableNames:d

   103             poolDictionaries:s

   104             category:cat

   105             comment:nil

   106             changed:false

   107     ].

   108     self isPointers ifTrue:[

   109         ^ self

   110             variableSubclass:t

   111             instanceVariableNames:f

   112             classVariableNames:d

   113             poolDictionaries:s

   114             category:cat

   115     ].

   116     self isBytes ifTrue:[

   117         ^ self

   118             variableByteSubclass:t

   119             instanceVariableNames:f

   120             classVariableNames:d

   121             poolDictionaries:s

   122             category:cat

   123     ].

   124     self isLongs ifTrue:[

   125         ^ self

   126             variableLongSubclass:t

   127             instanceVariableNames:f

   128             classVariableNames:d

   129             poolDictionaries:s

   130             category:cat

   131     ].

   132     self isFloats ifTrue:[

   133         ^ self

   134             variableFloatSubclass:t

   135             instanceVariableNames:f

   136             classVariableNames:d

   137             poolDictionaries:s

   138             category:cat

   139     ].

   140     self isDoubles ifTrue:[

   141         ^ self

   142             variableDoubleSubclass:t

   143             instanceVariableNames:f

   144             classVariableNames:d

   145             poolDictionaries:s

   146             category:cat

   147     ].

   148     "only word is left over"

   149     ^ self

   150         variableWordSubclass:t

   151         instanceVariableNames:f

   152         classVariableNames:d

   153         poolDictionaries:s

   154         category:cat

   155 !

   156 

   157 variableSubclass:t

   158         instanceVariableNames:f

   159         classVariableNames:d

   160         poolDictionaries:s

   161         category:cat

   162 

   163     "create a new class as a subclass of an existing class (the receiver) 

   164      in which the subclass has indexable pointer variables"

   165 

   166     self isVariable ifTrue:[

   167         self isPointers ifFalse:[

   168             ^ self error:

   169                 'cannot make a variable pointer subclass of a variable non-pointer class'

   170         ]

   171     ].

   172 

   173     ^ self class

   174         name:t

   175         inEnvironment:Smalltalk

   176         subclassOf:self

   177         instanceVariableNames:f

   178         variable:true

   179         words:false

   180         pointers:true

   181         classVariableNames:d

   182         poolDictionaries:s

   183         category:cat

   184         comment:nil

   185         changed:false

   186 !

   187 

   188 variableByteSubclass:t

   189         instanceVariableNames:f

   190         classVariableNames:d

   191         poolDictionaries:s

   192         category:cat

   193 

   194     "create a new class as a subclass of an existing class (the receiver) 

   195      in which the subclass has indexable byte-sized nonpointer variables"

   196 

   197     self isVariable ifTrue:[

   198         self isBytes ifFalse:[

   199             ^ self error:

   200                 'cannot make a variable byte subclass of a variable non-byte class'

   201         ].

   202     ].

   203 

   204     ^ self class

   205         name:t

   206         inEnvironment:Smalltalk

   207         subclassOf:self

   208         instanceVariableNames:f

   209         variable:true

   210         words:false

   211         pointers:false

   212         classVariableNames:d

   213         poolDictionaries:s

   214         category:cat

   215         comment:nil

   216         changed:false

   217 !

   218 

   219 variableWordSubclass:t

   220         instanceVariableNames:f

   221         classVariableNames:d

   222         poolDictionaries:s

   223         category:cat

   224 

   225     "create a new class as a subclass of an existing class (the receiver) 

   226      in which the subclass has indexable word-sized nonpointer variables"

   227 

   228     self isVariable ifTrue:[

   229         self isWords ifFalse:[

   230             ^ self error:

   231                 'cannot make a variable word subclass of a variable non-word class'

   232         ].

   233     ].

   234 

   235     ^ self class

   236         name:t

   237         inEnvironment:Smalltalk

   238         subclassOf:self

   239         instanceVariableNames:f

   240         variable:true

   241         words:true

   242         pointers:false

   243         classVariableNames:d

   244         poolDictionaries:s

   245         category:cat

   246         comment:nil

   247         changed:false

   248 !

   249 

   250 variableLongSubclass:t

   251         instanceVariableNames:f

   252         classVariableNames:d

   253         poolDictionaries:s

   254         category:cat

   255 

   256     "create a new class as a subclass of an existing class (the receiver) 

   257      in which the subclass has indexable long-sized nonpointer variables"

   258 

   259     self isVariable ifTrue:[

   260         self isLongs ifFalse:[

   261             ^ self error:

   262                 'cannot make a variable long subclass of a variable non-long class'

   263         ].

   264     ].

   265 

   266     ^ self class

   267         name:t

   268         inEnvironment:Smalltalk

   269         subclassOf:self

   270         instanceVariableNames:f

   271         variable:#long 

   272         words:false

   273         pointers:false

   274         classVariableNames:d

   275         poolDictionaries:s

   276         category:cat

   277         comment:nil

   278         changed:false

   279 !

   280 

   281 variableFloatSubclass:t

   282         instanceVariableNames:f

   283         classVariableNames:d

   284         poolDictionaries:s

   285         category:cat

   286 

   287     "create a new class as a subclass of an existing class (the receiver) 

   288      in which the subclass has indexable float-sized nonpointer variables"

   289 

   290     self isVariable ifTrue:[

   291         self isFloats ifFalse:[

   292             ^ self error:

   293                 'cannot make a variable float subclass of a variable non-float class'

   294         ].

   295     ].

   296 

   297     ^ self class

   298         name:t

   299         inEnvironment:Smalltalk

   300         subclassOf:self

   301         instanceVariableNames:f

   302         variable:#float 

   303         words:false

   304         pointers:false

   305         classVariableNames:d

   306         poolDictionaries:s

   307         category:cat

   308         comment:nil

   309         changed:false

   310 !

   311 

   312 variableDoubleSubclass:t

   313         instanceVariableNames:f

   314         classVariableNames:d

   315         poolDictionaries:s

   316         category:cat

   317 

   318     "create a new class as a subclass of an existing class (the receiver) 

   319      in which the subclass has indexable double-sized nonpointer variables"

   320 

   321     self isVariable ifTrue:[

   322         self isDoubles ifFalse:[

   323             ^ self error:

   324                 'cannot make a variable double subclass of a variable non-double class'

   325         ].

   326     ].

   327 

   328     ^ self class

   329         name:t

   330         inEnvironment:Smalltalk

   331         subclassOf:self

   332         instanceVariableNames:f

   333         variable:#double 

   334         words:false

   335         pointers:false

   336         classVariableNames:d

   337         poolDictionaries:s

   338         category:cat

   339         comment:nil

   340         changed:false

   341 ! !

   342 

   343 !Class methodsFor:'ST/V subclass creation'!

   344 

   345 subclass:t

   346         instanceVariableNames:f

   347         classVariableNames:d

   348         poolDictionaries:s

   349 

   350     "this methods allows fileIn of ST/V classes 

   351      (which seem to have no category)"

   352 

   353     ^ self subclass:t 

   354            instanceVariableNames:f

   355            classVariableNames:d

   356            poolDictionaries:s

   357            category:'ST/V classes'

   358 !

   359 

   360 variableByteSubclass:t

   361         classVariableNames:d

   362         poolDictionaries:s

   363 

   364     "this methods allows fileIn of ST/V variable byte classes 

   365      (which seem to have no category and no instvars)"

   366 

   367     ^ self variableByteSubclass:t 

   368            instanceVariableNames:''

   369            classVariableNames:d

   370            poolDictionaries:s

   371            category:'ST/V classes'

   372 !

   373 

   374 variableSubclass:t

   375         instanceVariableNames:f

   376         classVariableNames:d

   377         poolDictionaries:s

   378 

   379     "this methods allows fileIn of ST/V variable pointer classes 

   380      (which seem to have no category)"

   381 

   382     ^ self variableSubclass:t 

   383            instanceVariableNames:f

   384            classVariableNames:d

   385            poolDictionaries:s

   386            category:'ST/V classes'

   387 ! !

   388 

   389 !Class methodsFor:'accessing'!

   390 

   391 classVariableString

   392     "return a string of the class variables names "

   393 

   394     classvars isNil ifTrue:[^ ''].

   395     ^ classvars

   396 !

   397 

   398 classVarNames

   399     "return a collection of the class variable name-strings"

   400 

   401     ^ self addClassVarNamesTo:(OrderedCollection new)

   402 !

   403 

   404 allClassVarNames

   405     "return a collection of all the class variable name-strings

   406      this includes all superclass-class variables"

   407 

   408     ^ self addAllClassVarNamesTo:(OrderedCollection new)

   409 !

   410 

   411 instVarNames

   412     "return a collection of the instance variable name-strings"

   413 

   414     ^ self addInstVarNamesTo:(OrderedCollection new)

   415 !

   416 

   417 allInstVarNames

   418     "return a collection of all the instance variable name-strings

   419      this includes all superclass-instance variables"

   420 

   421     ^ self addAllInstVarNamesTo:(OrderedCollection new)

   422 !

   423 

   424 comment

   425     "return the comment (aString) of the class"

   426 

   427     ^ comment

   428 !

   429 

   430 setComment:aString

   431     "set the comment of the class to be the argument, aString;

   432      do NOT create a change record"

   433 

   434     comment := aString

   435 !

   436 

   437 comment:aString

   438     "set the comment of the class to be the argument, aString;

   439      create a change record"

   440 

   441     comment := aString.

   442     self addChangeRecordForClassComment:self

   443 !

   444 

   445 definition

   446     "return an expression-string to define myself"

   447 

   448     |s|

   449 

   450     s := WriteStream on:(String new).

   451     self fileOutDefinitionOn:s.

   452     ^ s contents

   453 

   454     "Object definition"

   455     "Point definition"

   456 !

   457 

   458 setComment:com category:categoryStringOrSymbol

   459     "set the comment and category of the class;

   460      do NOT create a change record"

   461 

   462     comment := com.

   463     category := categoryStringOrSymbol asSymbol

   464 !

   465 

   466 setName:aString

   467     "set the classes name"

   468 

   469     name := aString

   470 !

   471 

   472 setClassVariableString:aString

   473     "set the classes classvarnames string"

   474 

   475     classvars := aString

   476 !

   477 

   478 classVariableString:aString

   479     "set the classes classvarnames string;

   480      initialize new class variables with nil, clear and remove

   481      old ones"

   482 

   483     |prevVarNames varNames|

   484 

   485     "ignore for metaclasses except the one"

   486     (self isMeta "isKindOf:Metaclass") ifTrue:[

   487         (self == Metaclass) ifFalse:[

   488             ^ self

   489         ]

   490     ].

   491     (classvars = aString) ifFalse:[

   492         prevVarNames := self classVarNames.

   493         classvars := aString.

   494         varNames := self classVarNames.

   495 

   496         "new ones get initialized to nil;

   497          - old ones are nilled and removed from Smalltalk"

   498 

   499         varNames do:[:aName |

   500             (prevVarNames includes:aName) ifFalse:[

   501                 "a new one"

   502                 Smalltalk at:(self name , ':' , aName) asSymbol put:nil.

   503             ] ifTrue:[

   504                 prevVarNames remove:aName

   505             ]

   506         ].

   507         "left overs are gone"

   508         prevVarNames do:[:aName |

   509             Smalltalk at:(self name , ':' , aName) asSymbol put:nil.

   510             Smalltalk removeKey:(self name , ':' , aName) asSymbol

   511         ].

   512         Smalltalk changed

   513     ]

   514 !

   515 

   516 addClassVarName:aString

   517     "add a class variable"

   518 

   519     (self classVarNames includes:aString) ifFalse:[

   520         self classVariableString:(self classVariableString , ' ' , aString)

   521     ]

   522 ! !

   523 

   524 !Class methodsFor:'adding/removing'!

   525 

   526 addSelector:newSelector withMethod:newMethod

   527     "add the method given by 2nd argument under the selector given by

   528      1st argument to the methodDictionary"

   529 

   530     |index oldSelectorArray oldMethodArray

   531      newSelectorArray newMethodArray nargs|

   532 

   533     (newSelector isMemberOf:Symbol) ifFalse:[^ self error:'invalid selector'].

   534     newMethod isNil ifTrue:[^ self error:'invalid method'].

   535 

   536     index := selectors identityIndexOf:newSelector startingAt:1.

   537     (index == 0) ifTrue:[

   538         newSelectorArray := selectors copyWith:newSelector.

   539         newMethodArray := methods copyWith:newMethod.

   540         "keep a reference so they wont go away ..."

   541         oldSelectorArray := selectors.

   542         oldMethodArray := methods.

   543         selectors := newSelectorArray.

   544         methods := newMethodArray

   545     ] ifFalse:[

   546         methods at:index put:newMethod

   547     ].

   548 

   549     nargs := newSelector nArgsIfSelector.

   550 

   551     "actually, we would do better with less flushing ..."

   552     ObjectMemory flushMethodCache.

   553     ObjectMemory flushInlineCachesWithArgs:nargs.

   554 

   555     self addChangeRecordForMethod:newMethod

   556 !

   557 

   558 removeSelector:aSelector

   559     "remove the selector, aSelector and its associated method 

   560      from the methodDictionary"

   561 

   562     |index oldSelectorArray oldMethodArray 

   563      newSelectorArray newMethodArray nargs|

   564 

   565     index := selectors identityIndexOf:aSelector startingAt:1.

   566     (index ~~ 0) ifTrue:[

   567         newSelectorArray := selectors copyWithoutIndex:index.

   568         newMethodArray := methods copyWithoutIndex:index.

   569         oldSelectorArray := selectors.

   570         oldMethodArray := methods.

   571         selectors := newSelectorArray.

   572         methods := newMethodArray.

   573 "

   574         nargs := aSelector nArgsIfSelector.

   575         ObjectMemory flushMethodCacheFor:self.

   576         ObjectMemory flushInlineCachesWithArgs:nargs.

   577 "

   578         "actually, we would do better with less flushing ..."

   579         ObjectMemory flushCaches.

   580 

   581         self addChangeRecordForRemoveSelector:aSelector

   582     ]

   583 ! !

   584 

   585 !Class methodsFor:'changes management'!

   586 

   587 updateChanges:aBoolean

   588     "turn on/off changes management"

   589 

   590     |prev|

   591 

   592     prev := updatingChanges.

   593     updatingChanges := aBoolean.

   594     ^ prev

   595 !

   596 

   597 changesStream

   598     "return a Stream for the changes file"

   599 

   600     |aStream|

   601 

   602     updatingChanges ifTrue:[

   603         aStream := FileStream oldFileNamed:'changes'.

   604         aStream isNil ifTrue:[

   605             aStream := FileStream newFileNamed:'changes'.

   606             aStream isNil ifTrue:[

   607                 self error:'cannot update changes file'

   608             ]

   609         ] ifFalse:[

   610             aStream setToEnd

   611         ]

   612     ].

   613     ^ aStream

   614 !

   615 

   616 addChangeRecordForMethod:aMethod

   617     "add a method-change-record to the changes file"

   618 

   619     |aStream p|

   620 

   621     aStream := self changesStream.

   622     aStream notNil ifTrue:[

   623         p := aStream position.

   624         self fileOutMethod:aMethod on:aStream.

   625         aStream cr.

   626         aStream close.

   627         Project current notNil ifTrue:[

   628             Project current changeSet addMethodChange:aMethod in:self

   629         ]

   630     ]

   631 !

   632 

   633 addChangeRecordForRemoveSelector:aSelector

   634     "add a method-remove-record to the changes file"

   635 

   636     |aStream|

   637 

   638     aStream := self changesStream.

   639     aStream notNil ifTrue:[

   640         self printClassNameOn:aStream.

   641         aStream nextPutAll:(' removeSelector:#' , aSelector).

   642         aStream nextPut:(aStream class chunkSeparator).

   643         aStream cr.

   644         aStream close

   645     ]

   646 !

   647 

   648 addChangeRecordForClass:aClass

   649     "add a class-definition-record to the changes file"

   650 

   651     |aStream|

   652 

   653     aStream := self changesStream.

   654     aStream notNil ifTrue:[

   655         aClass fileOutDefinitionOn:aStream.

   656         aStream nextPut:(aStream class chunkSeparator).

   657         aStream cr.

   658         aStream close

   659     ]

   660 !

   661 

   662 addChangeRecordForClassComment:aClass

   663     "add a class-comment-record to the changes file"

   664 

   665     |aStream|

   666 

   667     aStream := self changesStream.

   668     aStream notNil ifTrue:[

   669         aClass fileOutCommentOn:aStream.

   670         aStream nextPut:$!!.

   671         aStream cr.

   672         aStream close

   673     ]

   674 !

   675 

   676 addChangeRecordForSnapshot

   677     "add a snapshot-record to the changes file"

   678 

   679     |aStream|

   680 

   681     aStream := self changesStream.

   682     aStream notNil ifTrue:[

   683         aStream nextPutAll:('''---- snapshot ' ,

   684                             Date today printString , ' ' ,

   685                             Time now printString ,

   686                             ' ----''!').

   687         aStream cr.

   688         aStream close

   689     ]

   690 ! !

   691 

   692 !Class methodsFor:'compiling'!

   693 

   694 compile:code

   695     "compile code, aString for this class; if sucessful update method

   696      dictionary."

   697 

   698     (Smalltalk at:#Compiler) compile:code forClass:self

   699 !

   700 

   701 compile:code notifying:requestor

   702     "compile code, aString for this class; on any error, notify

   703      requestor, anObject with the error reason"

   704 

   705     (Smalltalk at:#Compiler) compile:code forClass:self notifying:requestor

   706 !

   707 

   708 recompile:aSelector

   709     "recompile the method associated with the argument, aSelector;

   710      used when a superclass changes instances and we have to recompile

   711      subclasses"

   712 

   713     |cat code|

   714 

   715     cat := (self compiledMethodAt:aSelector) category.

   716     code := self sourceCodeAt:aSelector.

   717     (Smalltalk at:#Compiler) compile:code forClass:self inCategory:cat

   718 !

   719 

   720 recompile

   721     "recompile all methods

   722      used when a class changes instances and therefore all methods

   723      have to be recompiled"

   724 

   725     self selectors do:[:aSelector |

   726         self recompile:aSelector

   727     ]

   728 !

   729 

   730 recompileAll

   731     "recompile this class and all subclasses"

   732 

   733     |subclasses|

   734 

   735     subclasses := self subclasses.

   736     self recompile.

   737     subclasses do:[:aClass |

   738         aClass recompileAll

   739     ]

   740 ! !

   741 

   742 !Class methodsFor:'queries'!

   743 

   744 selectorIndex:aSelector

   745     "return the index in the arrays for given selector aSelector"

   746 

   747     ^ selectors identityIndexOf:aSelector startingAt:1

   748 !

   749 

   750 compiledMethodAt:aSelector

   751     "return the method for given selector aSelector"

   752 

   753     |index|

   754 

   755     index := selectors identityIndexOf:aSelector startingAt:1.

   756     (index == 0) ifTrue:[^ nil].

   757     ^ methods at:index

   758 !

   759 

   760 sourceCodeAt:aSelector

   761     "return the methods source for given selector aSelector"

   762 

   763     |index|

   764 

   765     index := selectors identityIndexOf:aSelector startingAt:1.

   766     (index == 0) ifTrue:[^ nil].

   767     ^ (methods at:index) source

   768 !

   769 

   770 hasMethods

   771     "return true, if there are any (local) methods in this class"

   772 

   773     methods isNil ifTrue:[^ false].

   774     ^ (methods size ~~ 0)

   775 !

   776 

   777 implements:aSelector

   778     "Return true, if I implement selector"

   779 

   780     ^ (selectors identityIndexOf:aSelector startingAt:1) ~~ 0

   781 !

   782 

   783 canUnderstand:aSelector

   784     "Return true, if I or one of my superclasses implements selector"

   785 

   786     |classToLookAt|

   787 

   788     classToLookAt := self.

   789     [classToLookAt notNil] whileTrue:[

   790         (classToLookAt implements:aSelector) ifTrue:[^ true].

   791         classToLookAt := classToLookAt superclass

   792     ].

   793     ^ false

   794 !

   795 

   796 whichClassImplements:aSelector

   797     "Return the class (the receiver or a class in the superclass-chain) 

   798      which implements given selector aSelector, if none, return nil"

   799 

   800     |classToLookAt|

   801 

   802     classToLookAt := self.

   803     [classToLookAt notNil] whileTrue:[

   804         (classToLookAt implements:aSelector) ifTrue:[^ classToLookAt].

   805         classToLookAt := classToLookAt superclass

   806     ].

   807     ^ nil

   808 !

   809 

   810 selectorForMethod:aMethod

   811     "Return the selector for given method aMethod"

   812 

   813     |index|

   814 

   815     index := methods identityIndexOf:aMethod startingAt:1.

   816     (index == 0) ifTrue:[^ nil].

   817     ^ selectors at:index

   818 !

   819 

   820 containsMethod:aMethod

   821     "Return true, if aMethod is a method of myself"

   822 

   823     ^ (methods identityIndexOf:aMethod startingAt:1) ~~ 0

   824 !

   825 

   826 categories

   827     "Return a Collection of all method-category strings known in class"

   828 

   829     |newList cat|

   830 

   831     newList := OrderedCollection new.

   832     methods do:[:aMethod |

   833         cat := aMethod category.

   834         newList indexOf:cat ifAbsent:[newList add:cat]

   835     ].

   836     ^ newList

   837 !

   838 

   839 allCategories

   840     "Return a Collection of all method-category strings known in class

   841      and all superclasses"

   842 

   843     ^ self addAllCategoriesTo:(OrderedCollection new)

   844 ! !

   845 

   846 !Class methodsFor:'private'!

   847 

   848 addFromString:aString to:aCollection

   849     "helper - take individual words from the first argument, aString

   850      and add them as strings to the 2nd argument, aCollection.

   851      return aCollection"

   852 

   853     |start stop strLen|

   854 

   855     aString isNil ifFalse:[

   856         start := 1.

   857         strLen := aString size.

   858         [start <= strLen] whileTrue:[

   859             (aString at:start) isSeparator ifTrue:[

   860                 start := start + 1

   861             ] ifFalse:[

   862                 stop := aString indexOfSeparatorStartingAt:start.

   863                 stop == 0 ifTrue:[

   864                     stop := strLen + 1

   865                 ].

   866                 aCollection add:(aString copyFrom:start to:(stop - 1)).

   867                 start := stop

   868             ]

   869         ]

   870     ].

   871     ^ aCollection

   872 !

   873 

   874 addInstVarNamesTo:aCollection

   875     "add the name-strings of the instance variables

   876      to the argument, aCollection. Return aCollection"

   877 

   878     ^ self addFromString:instvars to:aCollection

   879 !

   880 

   881 addClassVarNamesTo:aCollection

   882     "add the name-strings of the class varvariables

   883      to the argument, aCollection. Return aCollection"

   884 

   885     ^ self addFromString:classvars to:aCollection

   886 !

   887 

   888 addAllInstVarNamesTo:aCollection

   889     "add the name-strings of the instance variables and of the inst-vars

   890      of all superclasses to the argument, aCollection. Return aCollection"

   891 

   892     (superclass notNil) ifTrue:[

   893         superclass addAllInstVarNamesTo:aCollection

   894     ].

   895     ^ self addInstVarNamesTo:aCollection

   896 !

   897 

   898 addAllClassVarNamesTo:aCollection

   899     "add the name-strings of the class variables and of the class-vars

   900      of all superclasses to the argument, aCollection. Return aCollection"

   901 

   902     (superclass notNil) ifTrue:[

   903         superclass addAllClassVarNamesTo:aCollection

   904     ].

   905     ^ self addClassVarNamesTo:aCollection

   906 !

   907 

   908 addCategoriesTo:aCollection

   909     "helper - add categories to the argument, aCollection"

   910 

   911     |cat|

   912 

   913     methods do:[:aMethod |

   914         cat := aMethod category.

   915         (aCollection detect:[:element | cat = element]

   916                      ifNone:[nil])

   917             isNil ifTrue:[

   918                 aCollection add:cat

   919         ]

   920     ].

   921     ^ aCollection

   922 !

   923 

   924 addAllCategoriesTo:aCollection

   925     "helper - add categories and all superclasses categories

   926      to the argument, aCollection"

   927 

   928     (superclass notNil) ifTrue:[

   929         superclass addAllCategoriesTo:aCollection

   930     ].

   931     ^ self addCategoriesTo:aCollection

   932 ! !

   933 

   934 !Class methodsFor:'fileIn interface'!

   935 

   936 methodsFor:aCategory

   937     "return a ClassCategoryReader to read in and compile methods for me"

   938 

   939     ^ ClassCategoryReader class:self category:aCategory

   940 !

   941 

   942 publicMethodsFor:aCategory

   943     "this method allows fileIn of ENVY methods - currently we do not support method visibility.

   944      return a ClassCategoryReader to read in and compile methods for me."

   945 

   946     ^ self methodsFor:aCategory

   947 !

   948 

   949 privateMethodsFor:aCategory

   950     "this method allows fileIn of ENVY methods - currently we do not support method visibility.

   951      return a ClassCategoryReader to read in and compile methods for me."

   952 

   953     ^ self methodsFor:aCategory

   954 !

   955 

   956 binaryMethods

   957     "return a ClassCategoryReader to read in binary methods for me"

   958 

   959     ^ BinaryClassCategoryReader class:self category:'binary'

   960 !

   961 

   962 methods

   963     "this method allows fileIn of ST/V methods -

   964      return a ClassCategoryReader to read in and compile methods for me."

   965 

   966     ^ ClassCategoryReader class:self category:'ST/V methods'

   967 ! !

   968 

   969 !Class methodsFor:'fileOut'!

   970 

   971 printClassNameOn:aStream

   972     "helper for fileOut - print my name if I am not a Metaclass;

   973      otherwise my name without -class followed by space-class"

   974 

   975     (self isMeta "isMemberOf:Metaclass") ifTrue:[

   976         aStream nextPutAll:(name copyFrom:1 to:(name size - 5)).

   977         aStream nextPutAll:' class'

   978     ] ifFalse:[

   979         name printOn:aStream

   980     ]

   981 !

   982 

   983 printNameArray:anArray on:aStream indent:indent

   984     "print an array of strings separated by spaces; when the stream

   985      defines a lineLength, break when this limit is reached; indent

   986      every line; used to printOut instanve variable names"

   987 

   988     |thisName nextName arraySize lenMax pos mustBreak line spaces|

   989 

   990     arraySize := 0.

   991     anArray notNil ifTrue:[

   992         arraySize := anArray size

   993     ].

   994     arraySize ~~ 0 ifTrue:[

   995         pos := indent.

   996         lenMax := aStream lineLength.

   997         thisName := anArray at:1.

   998         line := ''.

   999         1 to:arraySize do:[:index |

  1000             line := line , thisName.

  1001             pos := pos + thisName size.

  1002             (index == arraySize) ifFalse:[

  1003                 nextName := anArray at:(index + 1).

  1004                 mustBreak := false.

  1005                 (lenMax > 0) ifTrue:[

  1006                     ((pos + nextName size) > lenMax) ifTrue:[

  1007                         mustBreak := true

  1008                     ]

  1009                 ].

  1010                 mustBreak ifTrue:[

  1011                     aStream nextPutAll:line.

  1012                     aStream cr.

  1013                     spaces isNil ifTrue:[

  1014                         spaces := String new:indent

  1015                     ].

  1016                     line := spaces.

  1017                     pos := indent

  1018                 ] ifFalse:[

  1019                     line := line , ' '.

  1020                     pos := pos + 1

  1021                 ].

  1022                 thisName := nextName

  1023             ]

  1024         ].

  1025         aStream nextPutAll:line

  1026     ]

  1027 !

  1028 

  1029 printClassVarNamesOn:aStream indent:indent

  1030     "print the class variable names indented and breaking at line end"

  1031 

  1032     self printNameArray:(self classVarNames) on:aStream indent:indent

  1033 !

  1034 

  1035 printInstVarNamesOn:aStream indent:indent

  1036     "print the instance variable names indented and breaking at line end"

  1037 

  1038     self printNameArray:(self instVarNames) on:aStream indent:indent

  1039 !

  1040 

  1041 printHierarchyOn:aStream

  1042     "print my class hierarchy on aStream"

  1043 

  1044     self printHierarchyAnswerIndentOn:aStream

  1045 !

  1046 

  1047 printHierarchyAnswerIndentOn:aStream

  1048     "print my class hierarchy on aStream - return indent

  1049      recursively calls itself to print superclass and use returned indent

  1050      for my description - used in the browser"

  1051 

  1052     |indent|

  1053 

  1054     indent := 0.

  1055     (superclass notNil) ifTrue:[

  1056         indent := (superclass printHierarchyAnswerIndentOn:aStream) + 2

  1057     ].

  1058     aStream nextPutAll:(String new:indent).

  1059     aStream nextPutAll:name.

  1060     aStream nextPutAll:' ('.

  1061     self printInstVarNamesOn:aStream indent:(indent + name size + 2).

  1062     aStream nextPutAll:')'.

  1063     aStream cr.

  1064     ^ indent

  1065 !

  1066     

  1067 printFullHierarchyOn:aStream indent:indent

  1068     "print myself and all subclasses on aStream.

  1069      recursively calls itself to print subclasses. 

  1070      Can be used to print hierarchy on the printer."

  1071 

  1072     aStream nextPutAll:(String new:indent).

  1073     aStream bold.

  1074     aStream nextPutAll:name.

  1075     aStream normal.

  1076     aStream nextPutAll:' ('.

  1077     self printInstVarNamesOn:aStream indent:(indent + name size + 2).

  1078     aStream nextPutAll:')'.

  1079     aStream cr.

  1080 

  1081     (self subclasses sort:[:a :b | a name < b name]) do:[:aSubclass |

  1082         aSubclass printFullHierarchyOn:aStream indent:(indent + 2)

  1083     ]

  1084 

  1085     "|printStream|

  1086      printStream := Printer new.

  1087      Object printFullHierarchyOn:printStream indent:0.

  1088      printStream close"

  1089 !

  1090 

  1091 fileOutCommentOn:aStream

  1092     "print an expression on aStream to define my comment"

  1093 

  1094     aStream nextPutAll:name.

  1095     aStream nextPutAll:' comment:'.

  1096     comment isNil ifTrue:[

  1097         aStream nextPutAll:''''''

  1098     ] ifFalse:[

  1099         aStream nextPutAll:(comment storeString)

  1100     ].

  1101     aStream cr

  1102 !

  1103 

  1104 fileOutDefinitionOn:aStream

  1105     "print an expression to define myself on aStream"

  1106 

  1107     |isVar line|

  1108 

  1109     superclass isNil ifTrue:[

  1110         line := 'Object'

  1111     ] ifFalse:[

  1112         line := (superclass name)

  1113     ].

  1114     superclass isNil ifTrue:[

  1115         isVar := self isVariable

  1116     ] ifFalse:[

  1117         "I cant remember what this is for ?"

  1118         isVar := (self isVariable and:[superclass isVariable not])

  1119     ].

  1120     isVar ifTrue:[

  1121         self isPointers ifTrue:[

  1122             line := line , ' variableSubclass:#'

  1123         ] ifFalse:[

  1124             self isBytes ifTrue:[

  1125                 line := line , ' variableByteSubclass:#'

  1126             ] ifFalse:[

  1127                 self isWords ifTrue:[

  1128                     line := line , ' variableWordSubclass:#'

  1129                 ] ifFalse:[

  1130                     self isLongs ifTrue:[

  1131                         line := line , ' variableLongSubclass:#'

  1132                     ] ifFalse:[

  1133                         self isFloats ifTrue:[

  1134                             line := line , ' variableFloatSubclass:#'

  1135                         ] ifFalse:[