SnapShotImageMemory.st
author Claus Gittinger <cg@exept.de>
Wed, 29 Jul 2009 20:02:02 +0200
changeset 2570 4e663bc64364
parent 2164 3c5fe1d92046
child 3088 5a5e9b9b5138
permissions -rw-r--r--
changed #requestPackage
     1 "{ Package: 'stx:libtool2' }"
     2 
     3 Object subclass:#SnapShotImageMemory
     4 	instanceVariableNames:'image stream msb ptrSize intSize intTag spaceInfos symbolEntries
     5 		globalEntries addrToObjectMapping'
     6 	classVariableNames:''
     7 	poolDictionaries:''
     8 	category:'System-Support'
     9 !
    10 
    11 Object subclass:#ImageHeader
    12 	instanceVariableNames:'memory address classRef bits byteSize'
    13 	classVariableNames:''
    14 	poolDictionaries:''
    15 	privateIn:SnapShotImageMemory
    16 !
    17 
    18 SnapShotImageMemory::ImageHeader variableSubclass:#ImageObject
    19 	instanceVariableNames:'cachedContents'
    20 	classVariableNames:''
    21 	poolDictionaries:''
    22 	privateIn:SnapShotImageMemory
    23 !
    24 
    25 SnapShotImageMemory::ImageHeader variableByteSubclass:#ImageByteObject
    26 	instanceVariableNames:''
    27 	classVariableNames:''
    28 	poolDictionaries:''
    29 	privateIn:SnapShotImageMemory
    30 !
    31 
    32 SnapShotImageMemory::ImageObject variableSubclass:#ImageMethodObject
    33 	instanceVariableNames:'cachedPackage cachedMClass cachedSelector'
    34 	classVariableNames:''
    35 	poolDictionaries:''
    36 	privateIn:SnapShotImageMemory
    37 !
    38 
    39 SnapShotImageMemory::ImageObject variableSubclass:#ImageClassObject
    40 	instanceVariableNames:'cachedCategory cachedFlags cachedName'
    41 	classVariableNames:''
    42 	poolDictionaries:''
    43 	privateIn:SnapShotImageMemory
    44 !
    45 
    46 Object subclass:#SpaceInfo
    47 	instanceVariableNames:'start end size flags imageBase'
    48 	classVariableNames:''
    49 	poolDictionaries:''
    50 	privateIn:SnapShotImageMemory
    51 !
    52 
    53 !SnapShotImageMemory class methodsFor:'documentation'!
    54 
    55 documentation
    56 "
    57     I represent the memory as contained in a snapshot image.
    58 
    59     I am not used directly; instead, via the SystemBrowsers entry:
    60         SystemBrowser openOnSnapShotImage:'/export/home/cg/work/stx/projects/smalltalk/st.img'
    61         SystemBrowser openOnSnapShotImage:'crash.img'
    62 
    63     [author:]
    64         Claus Gittinger
    65 
    66 "
    67 ! !
    68 
    69 !SnapShotImageMemory class methodsFor:'instance creation'!
    70 
    71 for:aFilename
    72     ^ self new for:aFilename
    73 ! !
    74 
    75 !SnapShotImageMemory class methodsFor:'private'!
    76 
    77 isNilOOP:anOOP
    78     ^ anOOP == 0
    79 !
    80 
    81 isPointerOOP:anOOP
    82     ^ (anOOP bitTest:1) not
    83 !
    84 
    85 isSmallIntegerOOP:anOOP
    86     ^ anOOP bitTest:1
    87 ! !
    88 
    89 !SnapShotImageMemory methodsFor:'accessing'!
    90 
    91 globalEntries
    92     "return the value of the instance variable 'globalEntries' (automatically generated)"
    93 
    94     ^ globalEntries
    95 !
    96 
    97 globalEntries:something
    98     "set the value of the instance variable 'globalEntries' (automatically generated)"
    99 
   100     globalEntries := something.
   101 !
   102 
   103 image
   104 
   105     ^ image
   106 !
   107 
   108 image:something
   109 
   110     image := something.
   111 !
   112 
   113 ptrSize
   114     "return the value of the instance variable 'ptrSize' (automatically generated)"
   115 
   116     ^ ptrSize
   117 !
   118 
   119 ptrSize:something
   120     "set the value of the instance variable 'ptrSize' (automatically generated)"
   121 
   122     ptrSize := something.
   123 ! !
   124 
   125 !SnapShotImageMemory methodsFor:'object access'!
   126 
   127 fetchByteAt:addr
   128     |byte imgAddr|
   129 
   130     imgAddr := self imageAddressOf:addr.
   131     stream position:imgAddr.
   132     byte := stream next.
   133     ^ byte
   134 !
   135 
   136 fetchClassObjectAt:baseAddr
   137     |addr classPtr size bits o classRef nInsts|
   138 
   139     (baseAddr bitAnd:3) ~~ 0 ifTrue:[self halt].
   140 
   141     o := addrToObjectMapping at:(baseAddr bitShift:-2) ifAbsent:nil.
   142     o notNil ifTrue:[^ o].
   143 
   144     addr := baseAddr.
   145     classPtr := self fetchPointerAt:addr.
   146     addr := addr + ptrSize.
   147     size := self fetchUnboxedIntegerAt:addr.
   148     addr := addr + ptrSize.
   149     bits := self fetchUnboxedIntegerAt:addr.
   150     addr := addr + ptrSize.
   151 
   152     nInsts := (size - (intSize * 3 "headerSize")) // intSize.
   153     o := ImageClassObject new:nInsts.
   154     o memory:self.
   155     o address:baseAddr.
   156     addrToObjectMapping at:(baseAddr bitShift:-2) put:o.
   157 
   158     (self class isPointerOOP:classPtr) ifFalse:[
   159         self halt
   160     ].
   161 
   162 size > 8000 ifTrue:[self halt].
   163     o byteSize:size.
   164     o bits:bits.
   165 
   166     1 to:nInsts do:[:idx |
   167         o at:idx put:(self fetchUnboxedIntegerAt:addr).
   168 "/        o at:idx put:(self fetchObjectAt:(self fetchUnboxedIntegerAt:addr)).
   169         addr := addr + ptrSize.
   170     ].
   171 
   172     classRef := self fetchClassObjectAt:classPtr.
   173     o classRef:classRef.
   174 
   175     ^ o
   176 !
   177 
   178 fetchObjectAt:baseAddr
   179     |addr classPtr classRef size bits o nBytes nInsts flags indexTypeFlags imgAddr
   180      |
   181 
   182     baseAddr == 0 ifTrue:[^ nil].
   183     (baseAddr bitAnd:1) == 1 ifTrue:[
   184         (baseAddr bitTest:16r80000000) ifTrue:[
   185             ^ (baseAddr - 16r100000000) bitShift32:-1
   186         ] ifFalse:[   
   187             ^ baseAddr bitShift32:-1
   188         ]
   189     ].
   190     (baseAddr bitAnd:3) ~~ 0 ifTrue:[self halt].
   191 
   192     o := addrToObjectMapping at:(baseAddr bitShift:-2) ifAbsent:nil.
   193     o notNil ifTrue:[^ o].
   194 
   195     addr := baseAddr.
   196     classPtr := self fetchPointerAt:addr.
   197     addr := addr + ptrSize.
   198     size := self fetchUnboxedIntegerAt:addr.
   199     addr := addr + ptrSize.
   200     bits := self fetchUnboxedIntegerAt:addr.
   201     addr := addr + ptrSize.
   202 
   203     (self class isPointerOOP:classPtr) ifFalse:[
   204         self halt
   205     ].
   206 
   207     classRef := self fetchClassObjectAt:classPtr.
   208 
   209     flags := classRef flags.
   210     indexTypeFlags := flags bitAnd:Behavior maskIndexType.
   211     (indexTypeFlags = Behavior flagBytes) ifTrue:[ 
   212         nBytes := (size - (intSize * 3)).
   213         o := ImageByteObject new:nBytes.
   214         o memory:self.
   215         o address:baseAddr.
   216         o classRef:classRef.
   217 "/ size > 8000 ifTrue:[self halt].
   218         o byteSize:size.
   219         o bits:bits.
   220         addrToObjectMapping at:(baseAddr bitShift:-2) put:o.
   221 
   222         imgAddr := self imageAddressOf:addr.
   223         stream position:imgAddr.
   224 
   225         1 to:nBytes do:[:idx |
   226             o at:idx put:(stream next).
   227             addr := addr + 1.
   228         ].
   229 
   230 "/Transcript show:'#'.
   231 "/Transcript show:((ByteArray new:nBytes-1) replaceFrom:1 to:nBytes-1 with:o startingAt:1) asString.
   232 "/Transcript cr.
   233 
   234     ] ifFalse:[
   235         (indexTypeFlags = Behavior flagNotIndexed) ifFalse:[ 
   236             (indexTypeFlags ~= Behavior flagPointers) ifTrue:[
   237                 (indexTypeFlags ~= Behavior flagWeakPointers) ifTrue:[
   238                     self halt 
   239                 ]
   240             ].
   241         ].
   242 
   243         nInsts := (size - (intSize * 3)) // intSize.
   244         (flags bitTest:Behavior flagBehavior)
   245         "/ classRef isImageBehavior 
   246         ifTrue:[
   247             o := ImageClassObject new:nInsts.
   248         ] ifFalse:[
   249             (flags bitTest:Behavior flagMethod) ifTrue:[
   250                 o := ImageMethodObject new:nInsts.
   251             ] ifFalse:[
   252                 o := ImageObject new:nInsts.
   253             ]
   254         ].
   255         o memory:self.
   256         o address:baseAddr.
   257         o classRef:classRef.
   258 size > 8000 ifTrue:[self halt].
   259         o byteSize:size.
   260         o bits:bits.
   261         addrToObjectMapping at:(baseAddr bitShift:-2) put:o.
   262 
   263         1 to:nInsts do:[:idx |
   264             o at:idx put:(self fetchUnboxedIntegerAt:addr).
   265 "/            o at:idx put:(self fetchObjectAt:(self fetchUnboxedIntegerAt:addr)).
   266             addr := addr + ptrSize.
   267         ]
   268     ].
   269     ^ o
   270 !
   271 
   272 fetchPointerAt:addr
   273     ^ self fetchUnboxedIntegerAt:addr
   274 !
   275 
   276 fetchUnboxedIntegerAt:addr
   277     |ptr imgAddr|
   278 
   279     (addr bitAnd:3) ~~ 0 ifTrue:[self halt].
   280 
   281     imgAddr := self imageAddressOf:addr.
   282     stream position:imgAddr.
   283     ptr := stream nextUnsignedLongMSB:msb.
   284     ^ ptr
   285 !
   286 
   287 imageAddressOf:addr
   288     spaceInfos do:[:eachSpace |
   289         |byte imgAddr|
   290 
   291         addr >= eachSpace start ifTrue:[
   292             addr <= eachSpace end ifTrue:[
   293                 imgAddr := eachSpace imageBase + (addr - eachSpace start).
   294                 ^ imgAddr
   295             ]
   296         ].
   297     ].
   298     self halt:'image address error'.
   299 ! !
   300 
   301 !SnapShotImageMemory methodsFor:'private'!
   302 
   303 allClassesDo:aBlock
   304     globalEntries do:[:eachGlobal |
   305         |val|
   306 
   307         val := eachGlobal value.
   308         (val notNil     
   309         and:[(val isKindOf:ImageHeader)
   310         and:[val isImageBehavior]]) ifTrue:[
   311             aBlock value:val
   312         ].
   313     ].
   314 !
   315 
   316 fetchByteArrayFor:aByteArrayRef
   317     |nBytes|
   318 
   319     (aByteArrayRef isImageBytes) ifFalse:[self halt].
   320 
   321     nBytes := aByteArrayRef byteSize - (intSize * 3).
   322     ^ ((ByteArray new:nBytes) replaceFrom:1 to:nBytes-1 with:aByteArrayRef startingAt:1).
   323 !
   324 
   325 fetchStringFor:aStringRef
   326     |nBytes|
   327 
   328     (aStringRef isImageBytes) ifFalse:[self halt].
   329 
   330     nBytes := aStringRef byteSize - (intSize * 3).
   331     ^ ((ByteArray new:nBytes-1) replaceFrom:1 to:nBytes-1 with:aStringRef startingAt:1) asString.
   332 !
   333 
   334 for:aFilename
   335     stream := aFilename asFilename readStream binary.
   336     addrToObjectMapping := IdentityDictionary new.
   337 
   338     addrToObjectMapping at:((ObjectMemory addressOf:false) bitShift:-2) put:false.
   339     addrToObjectMapping at:((ObjectMemory addressOf:true) bitShift:-2)  put:true.
   340 !
   341 
   342 printStringOfClass:aClassRef
   343     |nameSlot|
   344 
   345     (aClassRef isImageBehavior) ifFalse:[self halt].
   346     ((aClassRef byteSize // intSize) - 3) < Class instSize ifTrue:[self halt.].
   347 
   348     nameSlot := aClassRef nameSlot.
   349     nameSlot isInteger ifTrue:[
   350         nameSlot := self fetchObjectAt:nameSlot
   351     ].
   352     nameSlot isImageSymbol ifFalse:[self halt].
   353     ^ 'Class: ' , (self printStringOfSymbol:nameSlot)
   354 !
   355 
   356 printStringOfObject:anObjectRef
   357     |s nBytes|
   358 
   359     anObjectRef isNil ifTrue:[^ 'nil'].
   360     (anObjectRef isInteger) ifTrue:[^ anObjectRef printString].
   361     (anObjectRef == true ) ifTrue:[^ anObjectRef printString].
   362     (anObjectRef == false) ifTrue:[^ anObjectRef printString].
   363 
   364     (anObjectRef isImageSymbol) ifTrue:[^ self printStringOfSymbol:anObjectRef].
   365     (anObjectRef isImageBehavior) ifTrue:[^ self printStringOfClass:anObjectRef].
   366 
   367     ^ 'obj(' , anObjectRef printString , ')'
   368 !
   369 
   370 printStringOfString:aStringRef
   371     |nBytes|
   372 
   373     (aStringRef isString) ifFalse:[self halt].
   374     ^ self fetchStringFor:aStringRef.
   375 !
   376 
   377 printStringOfSymbol:aSymbolRef
   378     |nBytes|
   379 
   380     (aSymbolRef isImageSymbol) ifFalse:[self halt].
   381     ^ self fetchStringFor:aSymbolRef.
   382 "/    nBytes := aSymbolRef size - (intSize * 3).
   383 "/    ^ ((ByteArray new:nBytes-1) replaceFrom:1 to:nBytes-1 with:aSymbolRef startingAt:1) asString.
   384 !
   385 
   386 readGlobalEntries
   387         |refPointer theSymbolPtr theSymbolRef theValuePtr theValueRef pos|
   388 
   389         globalEntries := OrderedCollection new.
   390         [
   391             refPointer := stream nextUnsignedLongMSB:msb.
   392             theSymbolPtr := stream nextUnsignedLongMSB:msb.
   393             theValuePtr := stream nextUnsignedLongMSB:msb.
   394             theSymbolPtr ~~ 0
   395         ] whileTrue:[
   396             globalEntries add:(theSymbolPtr -> theValuePtr).
   397         ].
   398         globalEntries := globalEntries asArray.
   399 
   400 "/ globalEntries inspect.
   401         pos := stream position.
   402         globalEntries do:[:item |
   403             theSymbolPtr := item key.
   404             theValuePtr := item value.
   405             theSymbolRef := self fetchObjectAt:theSymbolPtr.
   406 
   407 "/            Transcript show:(self printStringOfSymbol:theSymbolRef).
   408 "/            Transcript show:'->'.
   409 
   410             theValueRef := self fetchObjectAt:theValuePtr.
   411 "/            Transcript show:(self printStringOfObject:theValueRef).
   412 "/            Transcript cr.
   413 
   414             item key:theSymbolRef.
   415             item value:theValueRef.
   416         ].
   417         stream position:pos.
   418 !
   419 
   420 readHeader
   421         "
   422          (self for:'stmeas.img') readHeader
   423          (self for:'crash.img') readHeader
   424         "
   425 
   426         |order magic version timeStamp snapID last_util_addr hiText_addr flags 
   427          lowData hiData charSlots charTableSlots fixMemStart fixMemEnd 
   428          symMemStart symMemEnd vmDataAddr sharedMethodCode sharedBlockCode 
   429          nContexts contextSpace nRegistered symbolsSeqNr nSpaces 
   430          classNameSize spaceSize numCharSlots|
   431 
   432         stream next:256.        "/ skip execCmd
   433 
   434         msb := false.
   435         order := stream nextUnsignedLongMSB:msb.        
   436         order = 16r076543210 ifTrue:[
   437         ] ifFalse:[
   438             order = 16r10325476 ifTrue:[
   439                 msb := true.
   440             ] ifFalse:[
   441                 self error:'unhandled byteorder'
   442             ].
   443         ].
   444         magic := (stream next:8) asString.
   445         magic ~= 'ST/X-IMG' ifTrue:[
   446             self error:'not an st/x image'
   447         ].
   448         version := stream nextUnsignedLongMSB:msb.        
   449         timeStamp := stream nextUnsignedLongMSB:msb.        
   450         ptrSize := stream nextByte.        
   451         ptrSize ~~ 4 ifTrue:[
   452             self error:'unhandled ptr format'
   453         ].
   454         stream next:7.    "/ filler    
   455         intSize := stream nextUnsignedLongMSB:msb.        
   456         intSize == 9 ifTrue:[
   457             intSize := 4.
   458             intTag := 1.
   459         ] ifFalse:[
   460             self error:'unhandled int format'
   461         ].
   462         
   463         snapID := stream nextUnsignedLongMSB:msb.        
   464         last_util_addr := stream next:intSize.        
   465         hiText_addr := stream next:intSize.        
   466         flags := stream next:intSize.        
   467         stream next:8.    "/ info, debug & filler    
   468 
   469         lowData := stream nextUnsignedLongMSB:msb.
   470         hiData := stream nextUnsignedLongMSB:msb.
   471 
   472         charSlots := stream nextUnsignedLongMSB:msb.
   473         charTableSlots := stream nextUnsignedLongMSB:msb.
   474 
   475         version >= 8 ifTrue:[
   476             fixMemStart := stream nextUnsignedLongMSB:msb.
   477             fixMemEnd := stream nextUnsignedLongMSB:msb.
   478             symMemStart := stream nextUnsignedLongMSB:msb.
   479             symMemEnd := stream nextUnsignedLongMSB:msb.
   480             vmDataAddr := stream nextUnsignedLongMSB:msb.
   481         ].
   482         stream next:(128 * intSize).    "/ skip sharedMethodCode ptrs
   483         stream next:(128 * intSize).    "/ skip sharedBlockCode ptrs
   484 
   485         nContexts := stream nextUnsignedLongMSB:msb.
   486         contextSpace := stream nextUnsignedLongMSB:msb.
   487         nRegistered := stream nextUnsignedLongMSB:msb.
   488 
   489         version >= 8 ifTrue:[
   490             version >= 9 ifTrue:[
   491                 symbolsSeqNr := stream nextUnsignedLongMSB:msb.
   492                 version >= 10 ifTrue:[
   493                     numCharSlots := stream nextUnsignedLongMSB:msb.
   494                     stream next:(intSize * 30).
   495                 ] ifFalse:[
   496                     stream next:(intSize * 31).
   497                 ].
   498             ] ifFalse:[
   499                 stream next:(intSize * 32).
   500             ]
   501         ].
   502 
   503         nSpaces := stream nextUnsignedLongMSB:msb.
   504         spaceInfos := (1 to:nSpaces) collect:[:idx | SpaceInfo new].
   505         
   506         1 to:nSpaces do:[:i |
   507             (spaceInfos at:i) flags:(stream nextUnsignedLongMSB:msb).
   508         ].
   509         nSpaces+1 to:32 do:[:i | stream nextUnsignedLongMSB:msb].
   510 
   511         1 to:nSpaces do:[:i |
   512             (spaceInfos at:i) start:(stream nextUnsignedLongMSB:msb).
   513         ].
   514         nSpaces+1 to:32 do:[:i | stream nextUnsignedLongMSB:msb].
   515 
   516         1 to:nSpaces do:[:i |
   517             (spaceInfos at:i) size:(stream nextUnsignedLongMSB:msb).
   518         ].
   519         nSpaces+1 to:32 do:[:i | stream nextUnsignedLongMSB:msb].
   520         version >= 8 ifTrue:[
   521             stream reset.
   522             stream skip:4096.
   523         ].
   524 
   525         1 to:nSpaces do:[:i |
   526             (spaceInfos at:i) end:((spaceInfos at:i) start + (spaceInfos at:i) size - 1).
   527         ].
   528         1 to:nSpaces do:[:i |
   529             (spaceInfos at:i) imageBase:(stream position).
   530             spaceSize := (spaceInfos at:i) size.
   531             stream skip:spaceSize.
   532         ].
   533 
   534         "/ registration
   535 
   536         self readRegistrationEntries.
   537         Transcript showCR:'reading symbols...'.
   538         self readSymbolEntries.
   539         self readUGlobalEntries.
   540         Transcript showCR:'reading globals...'.
   541         self readGlobalEntries.
   542 
   543 
   544 "/struct basicImageHeader {
   545 "/        char            h_execCmd[256];
   546 "/
   547 "/        int             h_orderWord;
   548 "/        char            h_magic[8];
   549 "/        int             h_version;
   550 "/        int             h_timeStamp;
   551 "/        char            h_ptrSize;
   552 "/        char            h_filler1[7];
   553 "/        int             h_intSize;
   554 "/        int             h_snapID;
   555 "/        INT             h_last_util_addr;
   556 "/        INT             h_hiText_addr;
   557 "/        INT             h_flags;
   558 "/        char            h_infoPrinting;
   559 "/        char            h_debugPrinting;
   560 "/        char            h_filler2[6];
   561 "/
   562 "/        /*
   563 "/         * these are to verify compatibility of the image with
   564 "/         * myself ...
   565 "/         * this is now obsolete.
   566 "/         */
   567 "/        INT             h_lowData, h_hiData;
   568 "/
   569 "/        /*
   570 "/         * base address of character- and characterTable slots
   571 "/         */
   572 "/        INT             h_charSlots;
   573 "/        INT             h_charTableSlots;
   574 "/
   575 "/#if HEADER_VERSION >= 8
   576 "/        /*
   577 "/         * the fixBase (VMDATA address)
   578 "/         */
   579 "/        INT             h_fixMemStart;
   580 "/        INT             h_fixMemEnd;
   581 "/        INT             h_symMemStart;
   582 "/        INT             h_symMemEnd;
   583 "/
   584 "/        INT             h_vmDataAddr;
   585 "/#endif
   586 "/
   587 "/        INT             h_sharedMethodCode[128];
   588 "/        INT             h_sharedBlockCode[128];
   589 "/
   590 "/        /*      
   591 "/         * space needed to restore contexts
   592 "/         */
   593 "/        INT             h_nContexts;
   594 "/        INT             h_contextSpace;
   595 "/
   596 "/        /*
   597 "/         * number of class registration info records
   598 "/         */
   599 "/        INT             h_nRegistered;
   600 "/
   601 "/#if HEADER_VERSION >= 8
   602 "/        /*
   603 "/         * reserved slots, for future versions
   604 "/         * (can add additional info, without affecting position of following stuff)
   605 "/         * If you add slots, you MUST DECREMENT the fillcount.
   606 "/         */
   607 "/# if HEADER_VERSION >= 9
   608 "/        INT             h_symbolsSeqNr;
   609 "/        INT             h_reserved[31];
   610 "/# else
   611 "/        INT             h_reserved[32];
   612 "/# endif
   613 "/#endif
   614 "/
   615 "/        /*
   616 "/         * number of spaces, base and size of each
   617 "/         */
   618 "/        INT             h_nSpaces;
   619 "/        INT             h_spaceFlags[MAXSPACES];
   620 "/        INT             h_spaceBase[MAXSPACES];
   621 "/        INT             h_spaceSize[MAXSPACES];
   622 "/
   623 "/        /*
   624 "/         * here come nSpaces object spaces
   625 "/         */
   626 "/
   627 "/        /*
   628 "/         * here comes registration info
   629 "/         */
   630 "/
   631 "/        /*
   632 "/         * here come nSymbols symbolEntries
   633 "/         * followed by a zero/zero entry
   634 "/         */
   635 "/
   636 "/        /*
   637 "/         * here come nGlobal globalEntries
   638 "/         * followed by a zero/zero entry
   639 "/         */
   640 "/
   641 "/        /*
   642 "/         * here come nUnnamedGlobal globalEntries
   643 "/         * followed by a zero/zero entry
   644 "/         */
   645 "/
   646 "/        /*
   647 "/         * here come stack contexts
   648 "/         */
   649 "/};      
   650 !
   651 
   652 readRegistrationEntries
   653         |classNameSize|
   654 
   655         [
   656             classNameSize := stream nextUnsignedLongMSB:msb.
   657             classNameSize ~~ 0
   658         ] whileTrue:[
   659             |className flags moduleTimestamp signature nMethods nBlocks oldLitRefs nLitRefs
   660              oldConstTable nConsts|
   661 
   662             className := (stream next:classNameSize) asString.
   663             stream next. "/ 0-byte
   664             flags := stream nextUnsignedLongMSB:msb.
   665             moduleTimestamp := stream nextUnsignedLongMSB:msb.   
   666             signature := stream nextUnsignedLongMSB:msb.   
   667             nMethods := stream nextUnsignedLongMSB:msb.   
   668             nMethods timesRepeat:[ stream nextUnsignedLongMSB:msb ].
   669             nBlocks := stream nextUnsignedLongMSB:msb.   
   670             nBlocks timesRepeat:[ stream nextUnsignedLongMSB:msb ].
   671             oldLitRefs := stream nextUnsignedLongMSB:msb.  
   672             nLitRefs := stream nextUnsignedLongMSB:msb.
   673             nLitRefs timesRepeat:[ stream nextUnsignedLongMSB:msb ].
   674             stream nextUnsignedLongMSB:msb. "/ 0-litRef
   675             oldConstTable := stream nextUnsignedLongMSB:msb.  
   676             nConsts := stream nextLongMSB:msb.
   677             nConsts > 0 ifTrue:[
   678                 nConsts timesRepeat:[ stream nextUnsignedLongMSB:msb ].
   679             ]
   680             "/ Transcript showCR:className.
   681         ].
   682 !
   683 
   684 readSymbolEntries
   685         |refPointer theSymbolPtr theSymbolRef pos|
   686 
   687         symbolEntries := OrderedCollection new.
   688 
   689         [
   690             refPointer := stream nextUnsignedLongMSB:msb.
   691             theSymbolPtr := stream nextUnsignedLongMSB:msb.
   692             theSymbolPtr ~~ 0
   693         ] whileTrue:[
   694             symbolEntries add:theSymbolPtr.
   695         ].
   696         symbolEntries := symbolEntries asArray.
   697 
   698         pos := stream position.
   699         symbolEntries := symbolEntries collect:[:theSymbolPtr |
   700             theSymbolRef := self fetchObjectAt:theSymbolPtr.
   701             theSymbolRef isImageSymbol ifFalse:[
   702                 self halt
   703             ].
   704         ].        
   705         stream position:pos
   706 !
   707 
   708 readUGlobalEntries
   709         |refPointer theValue|
   710 
   711         [
   712             refPointer := stream nextUnsignedLongMSB:msb.
   713             theValue := stream nextUnsignedLongMSB:msb.
   714             refPointer ~~ 0
   715         ] whileTrue
   716 ! !
   717 
   718 !SnapShotImageMemory::ImageHeader methodsFor:'accessing'!
   719 
   720 address:something
   721     address := something.
   722 !
   723 
   724 bits
   725     "return the value of the instance variable 'bits' (automatically generated)"
   726 
   727     ^ bits
   728 !
   729 
   730 bits:something
   731     "set the value of the instance variable 'bits' (automatically generated)"
   732 
   733     bits := something.
   734 !
   735 
   736 byteSize
   737     "return the value of the instance variable 'size' (automatically generated)"
   738 
   739     ^ byteSize
   740 !
   741 
   742 byteSize:something
   743     "set the value of the instance variable 'size' (automatically generated)"
   744 
   745 "/ something > 8000 ifTrue:[self halt].
   746     byteSize := something.
   747 !
   748 
   749 classRef
   750     "return the value of the instance variable 'classRef' (automatically generated)"
   751 
   752     ^ classRef
   753 !
   754 
   755 classRef:something
   756     "set the value of the instance variable 'classRef' (automatically generated)"
   757 
   758     classRef := something.
   759 !
   760 
   761 memory
   762     "return the value of the instance variable 'memory' (automatically generated)"
   763 
   764     ^ memory
   765 !
   766 
   767 memory:something
   768     "set the value of the instance variable 'memory' (automatically generated)"
   769 
   770     memory := something.
   771 ! !
   772 
   773 !SnapShotImageMemory::ImageHeader methodsFor:'queries'!
   774 
   775 category
   776     |categoryPtr categoryRef category categorySlotOffset|
   777 
   778     self isMethodOrLazyMethod ifTrue:[
   779         categorySlotOffset := Method instVarOffsetOf:'category'.
   780         "/ categorySlotOffset := 6.
   781         categoryPtr := self at:categorySlotOffset.
   782         categoryRef := memory fetchObjectAt:categoryPtr.
   783         category := memory fetchStringFor:categoryRef.
   784         ^ category
   785     ].
   786 self halt.
   787 !
   788 
   789 isBehavior
   790     ^ self isImageBehavior
   791 !
   792 
   793 isImageBehavior
   794     |flags|
   795 
   796     flags := classRef flags.
   797     ^ flags bitTest:Behavior flagBehavior  
   798 !
   799 
   800 isImageBytes
   801     |flags|
   802 
   803     flags := classRef flags bitAnd:Behavior maskIndexType.
   804     ^ flags = Behavior flagBytes 
   805 !
   806 
   807 isImageMethod
   808     |flags|
   809 
   810     flags := classRef flags.
   811     ^ flags bitTest:Behavior flagMethod 
   812 !
   813 
   814 isImageSymbol
   815     |flags|
   816 
   817     flags := classRef flags.
   818     ^ flags bitTest:Behavior flagSymbol 
   819 !
   820 
   821 isJavaMethod    
   822     |nm|
   823 
   824     nm := classRef name.
   825     ^ (nm = 'JavaMethod'
   826       or:[ nm = 'JavaMethodWithException' 
   827       or:[ nm = 'JavaMethodWithHandler' 
   828       or:[ nm = 'JavaNativeMethod' ]]])
   829 !
   830 
   831 isLazyMethod                               
   832     ^ classRef name = 'LazyMethod'
   833 !
   834 
   835 isMeta
   836     ^ false
   837 !
   838 
   839 isMethod                               
   840     |cls|
   841 
   842     cls := classRef.
   843     [cls notNil] whileTrue:[
   844         cls name = 'Method' ifTrue:[^ true].
   845         cls := cls superclass
   846     ].
   847     ^ false.
   848 !
   849 
   850 isMethodDictionary
   851     ^ classRef name = 'MethodDictionary'
   852 !
   853 
   854 isMethodOrLazyMethod                 
   855     classRef name = 'LazyMethod' ifTrue:[^ true].
   856     ^ self isMethod
   857 !
   858 
   859 isString                               
   860     ^ classRef name = 'String'
   861 ! !
   862 
   863 !SnapShotImageMemory::ImageObject methodsFor:'method protocol'!
   864 
   865 byteCode
   866     |byteCodeSlotOffset byteCodePtr byteCodeRef byteCode|
   867 
   868     self isMethod ifTrue:[
   869         byteCodeSlotOffset := Method instVarOffsetOf:'byteCode'.
   870     ].
   871     byteCodeSlotOffset notNil ifTrue:[
   872         byteCodePtr := self at:byteCodeSlotOffset.
   873         byteCodeRef := memory fetchObjectAt:byteCodePtr.
   874         byteCodeRef isNil ifTrue:[^ nil].
   875 
   876         byteCode := memory fetchByteArrayFor:byteCodeRef.
   877         ^ byteCode
   878     ].
   879 
   880     self halt.
   881 !
   882 
   883 comment
   884     |src comment comments parser|
   885 
   886     self isMethod ifTrue:[
   887         src := self source.
   888         src isNil ifTrue:[^ nil].
   889 
   890         parser := Parser for:src in:nil.
   891         parser ignoreErrors; ignoreWarnings; saveComments:true.
   892         parser parseMethodSpec.
   893         comments := parser comments.
   894         comments size ~~ 0 ifTrue:[
   895             comment := comments first string.
   896             (comment withoutSpaces endsWith:'}') ifTrue:[
   897                 "if first comment is a pragma, take next comment"
   898                 comment := comments at:2 ifAbsent:nil.
   899                 comment notNil ifTrue:[
   900                     comment := comment string.
   901                 ].
   902             ].
   903         ].
   904         ^ comment.
   905     ].
   906     self isLazyMethod ifTrue:[
   907         ^ ''
   908     ].
   909 
   910     self halt.
   911 !
   912 
   913 containingClass
   914     self isMethodOrLazyMethod ifTrue:[
   915         ^ self mclass
   916     ].
   917     self halt.
   918 !
   919 
   920 flags
   921     |flagsSlotOffset flagsPtr flags|
   922 
   923     self isMethod ifTrue:[
   924         flagsSlotOffset := Method instVarOffsetOf:'flags'.
   925     ].
   926     flagsSlotOffset notNil ifTrue:[
   927         flagsPtr := self at:flagsSlotOffset.
   928         flags := memory fetchObjectAt:flagsPtr.
   929         ^ flags
   930     ].
   931 
   932     self halt.
   933 !
   934 
   935 hasCode
   936     ^ false
   937 !
   938 
   939 isBreakpointed
   940     ^ false
   941 !
   942 
   943 isCounting
   944     ^ false
   945 !
   946 
   947 isCountingMemoryUsage
   948     ^ false
   949 !
   950 
   951 isDynamic
   952     ^ false
   953 !
   954 
   955 isExecutable
   956     self isMethod ifTrue:[
   957         ^ false
   958     ].
   959     self halt.
   960 !
   961 
   962 isIgnored
   963     ^ false
   964 !
   965 
   966 isObsolete
   967     ^ false
   968 !
   969 
   970 isPrivate
   971     ^ false
   972 !
   973 
   974 isProtected
   975     ^ false
   976 !
   977 
   978 isPublic
   979     ^ true
   980 !
   981 
   982 isTimed
   983     ^ false
   984 !
   985 
   986 isTraced
   987     ^ false
   988 !
   989 
   990 isWrapped
   991     ^ false
   992 !
   993 
   994 mclass
   995     |mclassSlotOffset mclassPtr mclass|
   996 
   997     self isMethod ifTrue:[
   998         mclassSlotOffset := Method instVarOffsetOf:'mclass'.
   999     ] ifFalse:[
  1000         self isJavaMethod ifTrue:[
  1001             mclassSlotOffset := JavaMethod instVarOffsetOf:'javaClass'.
  1002         ]
  1003     ].
  1004 
  1005     mclassSlotOffset notNil ifTrue:[
  1006         mclassPtr := self at:mclassSlotOffset.
  1007         mclassPtr ~~ 0 ifTrue:[
  1008             mclassPtr isInteger ifTrue:[
  1009                 mclass := memory fetchObjectAt:mclassPtr.
  1010                 self at:mclassSlotOffset put:mclass.    
  1011             ] ifFalse:[
  1012                 mclass := mclassPtr.
  1013             ].
  1014             mclass isImageBehavior ifFalse:[
  1015                 self halt
  1016             ].
  1017             ^ mclass
  1018         ].
  1019 
  1020         "/ search my class ...
  1021         memory image allClassesDo:[:eachClass |
  1022             eachClass theNonMetaclass methodDictionary keysAndValuesDo:[:sel :mthdRef |
  1023                 mthdRef == self ifTrue:[
  1024                     self at:mclassSlotOffset put:eachClass theNonMetaclass.    
  1025                     ^ eachClass theNonMetaclass
  1026                 ].
  1027             ].
  1028             eachClass theMetaclass methodDictionary keysAndValuesDo:[:sel :mthdRef |
  1029                 mthdRef == self ifTrue:[
  1030                     self at:mclassSlotOffset put:eachClass theMetaclass.    
  1031                     ^ eachClass theMetaclass
  1032                 ].
  1033             ]
  1034         ].
  1035         self halt.
  1036         ^ nil.
  1037     ].
  1038     ^ nil.
  1039     self halt.
  1040 !
  1041 
  1042 numArgs
  1043     |flags|
  1044 
  1045     flags := self flags.
  1046     ^ (flags bitAnd:(Method numArgsMaskInFlags)) bitShift:(Method numArgsShiftInFlags negated)   
  1047 !
  1048 
  1049 package
  1050     |packageSlotOffset packagePtr packageRef package|
  1051 
  1052     self isImageBehavior ifTrue:[
  1053         self isMeta ifTrue:[
  1054             ^ self theNonMetaclass package
  1055         ].
  1056         packageSlotOffset := Class instVarOffsetOf:'package'.
  1057     ] ifFalse:[
  1058         self isMethod ifTrue:[
  1059             packageSlotOffset := Method instVarOffsetOf:'package'.
  1060         ] ifFalse:[
  1061             self isLazyMethod ifTrue:[
  1062                 packageSlotOffset := Method instVarOffsetOf:'package'.
  1063             ].
  1064         ].
  1065     ].
  1066     packageSlotOffset notNil ifTrue:[
  1067         packagePtr := self at:packageSlotOffset.
  1068         packageRef := memory fetchObjectAt:packagePtr.
  1069         packageRef isNil ifTrue:[^ nil].
  1070 
  1071         packageRef isImageSymbol ifFalse:[
  1072             packageRef isImageBytes ifFalse:[
  1073                 self halt.
  1074             ].
  1075             "/ mhmh - can be a string sometimes ...
  1076         ].
  1077         package := memory fetchStringFor:packageRef.
  1078         ^ package asSymbol
  1079     ].
  1080     self isMeta ifTrue:[
  1081         self halt
  1082     ].
  1083 
  1084     ^ nil
  1085 !
  1086 
  1087 previousVersion
  1088     ^ nil
  1089 !
  1090 
  1091 printStringForBrowserWithSelector:selector
  1092     ^ selector
  1093 !
  1094 
  1095 printStringForBrowserWithSelector:selector inClass:aClass
  1096     ^ selector
  1097 !
  1098 
  1099 privacy
  1100     ^ #public
  1101 !
  1102 
  1103 resources
  1104     ^ nil
  1105 !
  1106 
  1107 source
  1108     self halt:'unimplemented'.
  1109 !
  1110 
  1111 sourceFilename
  1112     "return the sourcefilename if source is extern; nil otherwise"
  1113 
  1114     |sourcePtr sourceRef source|
  1115 
  1116     self isMethodOrLazyMethod ifTrue:[
  1117         self sourcePosition notNil ifTrue:[
  1118             sourcePtr := self at:(Method instVarOffsetOf:'source').
  1119             sourceRef := memory fetchObjectAt:sourcePtr.
  1120             sourceRef isString ifFalse:[
  1121                 self halt.
  1122             ].
  1123             source := memory printStringOfString:sourceRef.
  1124             ^ source.
  1125         ].
  1126         ^ nil
  1127     ].
  1128     self halt.
  1129 !
  1130 
  1131 sourceLineNumber
  1132     self isMethodOrLazyMethod ifTrue:[
  1133         ^ 1
  1134     ].
  1135     self halt.
  1136 !
  1137 
  1138 sourcePosition
  1139     |sourcePosition|
  1140 
  1141     self isMethodOrLazyMethod ifTrue:[
  1142         sourcePosition := self sourcePositionValue.
  1143         sourcePosition isNil ifTrue:[^ sourcePosition].
  1144         ^ sourcePosition abs
  1145     ].
  1146     self halt.
  1147 !
  1148 
  1149 sourcePositionValue
  1150     |sourcePosition sourcePositionPtr|
  1151 
  1152     self isMethodOrLazyMethod ifTrue:[
  1153         sourcePositionPtr := self at:(Method instVarOffsetOf:'sourcePosition').
  1154         sourcePosition := memory fetchObjectAt:sourcePositionPtr.
  1155         ^ sourcePosition 
  1156     ].
  1157     self halt.
  1158 !
  1159 
  1160 sourceStream
  1161     |sourcePosition source aStream fileName junk who 
  1162      myClass mgr className sep dir mod package|
  1163 
  1164     self isMethod ifTrue:[
  1165         sourcePosition := self at:(Method instVarOffsetOf:'sourcePosition').
  1166         source := self at:(Method instVarOffsetOf:'source').
  1167         source := memory fetchObjectAt:source.
  1168         source isString ifTrue:[
  1169             source := memory printStringOfString:source.
  1170         ].
  1171         sourcePosition notNil ifTrue:[
  1172             sourcePosition := memory fetchObjectAt:sourcePosition.
  1173         ].
  1174 
  1175         source isNil ifTrue:[^ nil].
  1176         sourcePosition isNil ifTrue:[^ source readStream].
  1177 
  1178         sourcePosition < 0 ifTrue:[
  1179             aStream := source asFilename readStream.
  1180             aStream notNil ifTrue:[
  1181                 ^ aStream
  1182             ].
  1183 
  1184             fileName := Smalltalk getSourceFileName:source.
  1185             fileName notNil ifTrue:[
  1186                 aStream := fileName asFilename readStream.
  1187                 aStream notNil ifTrue:[
  1188                     ^ aStream
  1189                 ].
  1190             ].
  1191         ].
  1192 
  1193         "/
  1194         "/ if there is no SourceManager, look in local standard places first
  1195         "/
  1196         (mgr := Smalltalk at:#SourceCodeManager) isNil ifTrue:[
  1197             aStream := self localSourceStream.
  1198             aStream notNil ifTrue:[
  1199                 ^ aStream
  1200             ].
  1201         ].
  1202 
  1203         "/
  1204         "/ nope - ask my class for the source (this also invokes the SCMgr)
  1205         "/
  1206         myClass := self mclass.
  1207 
  1208         package := self package.
  1209         (package notNil and:[package ~= myClass package]) ifTrue:[
  1210             mgr notNil ifTrue:[
  1211                 "/ try to get the source using my package information ...
  1212                 sep := package indexOfAny:'/\:'.
  1213                 sep ~~ 0 ifTrue:[
  1214                     mod := package copyTo:sep - 1.
  1215                     dir := package copyFrom:sep + 1.
  1216                     aStream := mgr streamForClass:nil fileName:source revision:nil directory:dir module:mod cache:true.
  1217                     aStream notNil ifTrue:[
  1218                         ^ aStream
  1219                     ].
  1220                 ].
  1221             ].
  1222         ].
  1223 
  1224         aStream := myClass sourceStreamFor:source.
  1225         aStream notNil ifTrue:[
  1226             ^ aStream
  1227         ].
  1228 
  1229         "/
  1230         "/ nope - look in standard places 
  1231         "/ (if there is a source-code manager - otherwise, we already did that)
  1232         "/
  1233         mgr notNil ifTrue:[
  1234             aStream := self localSourceStream.
  1235             aStream notNil ifTrue:[
  1236                 ^ aStream
  1237             ].
  1238         ].
  1239 
  1240         "/
  1241         "/ final chance: try current directory
  1242         "/
  1243         aStream isNil ifTrue:[
  1244             aStream := source asFilename readStream.
  1245             aStream notNil ifTrue:[
  1246                 ^ aStream
  1247             ].
  1248         ].
  1249 
  1250         (who isNil and:[source notNil]) ifTrue:[
  1251             "/
  1252             "/ mhmh - seems to be a method which used to be in some
  1253             "/ class, but has been overwritten by another or removed.
  1254             "/ (i.e. it has no containing class anyMore)
  1255             "/ try to guess the class from the sourceFileName.
  1256             "/ and retry.
  1257             "/
  1258             className := Smalltalk classNameForFile:source.
  1259             className knownAsSymbol ifTrue:[
  1260                 myClass := Smalltalk at:className asSymbol ifAbsent:nil.
  1261                 myClass notNil ifTrue:[
  1262                     aStream := myClass sourceStreamFor:source.
  1263                     aStream notNil ifTrue:[
  1264                         ^ aStream
  1265                     ].
  1266                 ]
  1267             ]
  1268         ].                
  1269 
  1270         ^ nil
  1271     ].
  1272     self halt.
  1273 ! !
  1274 
  1275 !SnapShotImageMemory::ImageObject methodsFor:'methodDictionary protocol'!
  1276 
  1277 at:aSelector ifAbsent:exceptionValue
  1278     self isMethodDictionary ifTrue:[
  1279         cachedContents isNil ifTrue:[
  1280             self cacheMethodDictionary.
  1281         ].
  1282         ^ cachedContents at:aSelector ifAbsent:exceptionValue
  1283     ].
  1284     self halt.
  1285 !
  1286 
  1287 cacheMethodDictionary
  1288     |symPtr symRef mthdPtr mthdRef s|
  1289 
  1290     cachedContents isNil ifTrue:[
  1291         cachedContents := IdentityDictionary new.
  1292 
  1293         1 to:self size by:2 do:[:idx |
  1294             symPtr := self at:idx.
  1295             symRef := memory fetchObjectAt:symPtr.
  1296             symRef isImageSymbol ifFalse:[self halt].
  1297             s := memory fetchStringFor:symRef.
  1298             mthdPtr := self at:idx + 1.
  1299             mthdRef := memory fetchObjectAt:mthdPtr.
  1300             cachedContents at:s asSymbol put:mthdRef.
  1301         ].
  1302     ].
  1303 !
  1304 
  1305 do:aBlock
  1306     self isMethodDictionary ifTrue:[
  1307         cachedContents isNil ifTrue:[
  1308             self cacheMethodDictionary.
  1309         ].
  1310         cachedContents do:aBlock.
  1311         ^ self.
  1312     ].
  1313     self halt.
  1314 !
  1315 
  1316 includesKey:aSelector
  1317     self isMethodDictionary ifTrue:[
  1318         cachedContents isNil ifTrue:[
  1319             self cacheMethodDictionary.
  1320         ].
  1321         ^ cachedContents includesKey:aSelector
  1322     ].
  1323     self halt.
  1324 !
  1325 
  1326 keyAtValue:aMethod ifAbsent:exceptionValue
  1327     self isMethodDictionary ifTrue:[
  1328         cachedContents isNil ifTrue:[
  1329             self cacheMethodDictionary.
  1330         ].
  1331         ^ cachedContents keyAtValue:aMethod ifAbsent:exceptionValue
  1332     ].
  1333     self halt.
  1334 !
  1335 
  1336 keysAndValuesDo:aBlock
  1337     self isMethodDictionary ifTrue:[
  1338         cachedContents isNil ifTrue:[
  1339             self cacheMethodDictionary.
  1340         ].
  1341 
  1342         cachedContents keysAndValuesDo:[:sel :mthdRef |
  1343             aBlock value:sel value:mthdRef.
  1344         ].
  1345         ^ self
  1346     ].
  1347     self halt.
  1348 ! !
  1349 
  1350 !SnapShotImageMemory::ImageByteObject methodsFor:'queries'!
  1351 
  1352 size
  1353     ^ byteSize
  1354 ! !
  1355 
  1356 !SnapShotImageMemory::ImageMethodObject methodsFor:'method protocol'!
  1357 
  1358 localSourceStream
  1359     "try to open a stream from a local source file,
  1360      searching in standard places."
  1361 
  1362     |fileName aStream package source|
  1363 
  1364     package := self package.
  1365     source := self sourceFilename.
  1366     package notNil ifTrue:[
  1367         fileName := Smalltalk getSourceFileName:(package copyReplaceAll:$: with:$/) , '/' , source.
  1368         fileName notNil ifTrue:[
  1369             aStream := fileName asFilename readStream.
  1370             aStream notNil ifTrue:[^ aStream].
  1371         ].
  1372     ].
  1373     fileName := Smalltalk getSourceFileName:source.
  1374     fileName notNil ifTrue:[
  1375         aStream := fileName asFilename readStream.
  1376         aStream notNil ifTrue:[^ aStream].
  1377     ].
  1378     ^ nil
  1379 !
  1380 
  1381 mclass
  1382     cachedMClass isNil ifTrue:[
  1383         cachedMClass := super mclass.
  1384     ].
  1385     ^ cachedMClass
  1386 !
  1387 
  1388 package
  1389     |packageSlotOffset packagePtr packageRef package|
  1390 
  1391     cachedPackage isNil ifTrue:[
  1392         packageSlotOffset := Method instVarOffsetOf:'package'.
  1393 
  1394         packagePtr := self at:packageSlotOffset.
  1395         packageRef := memory fetchObjectAt:packagePtr.
  1396         packageRef isNil ifTrue:[^ nil].
  1397 
  1398         packageRef isImageSymbol ifFalse:[
  1399             packageRef isImageBytes ifFalse:[
  1400                 self halt.
  1401             ].
  1402             "/ mhmh - can be a string sometimes ...
  1403         ].
  1404         package := memory fetchStringFor:packageRef.
  1405         cachedPackage := package asSymbol
  1406     ].
  1407     ^ cachedPackage
  1408 !
  1409 
  1410 selector
  1411     cachedSelector isNil ifTrue:[
  1412         self mclass methodDictionary keysAndValuesDo:[:sel :mthd | mthd == self ifTrue:[cachedSelector := sel]].
  1413     ].
  1414     ^ cachedSelector
  1415 !
  1416 
  1417 source
  1418     |sourcePosition sourcePositionPtr sourcePtr sourceRef source aStream junk|
  1419 
  1420     sourcePositionPtr := self at:(Method instVarOffsetOf:'sourcePosition').
  1421     sourcePtr := self at:(Method instVarOffsetOf:'source').
  1422     sourceRef := memory fetchObjectAt:sourcePtr.
  1423     sourceRef isString ifFalse:[
  1424         self halt.
  1425     ].
  1426     source := memory printStringOfString:sourceRef.
  1427     sourcePosition := memory fetchObjectAt:sourcePositionPtr.
  1428     sourcePosition isNil ifTrue:[
  1429         ^ source
  1430     ].
  1431 
  1432     aStream := self sourceStream.
  1433     aStream notNil ifTrue:[
  1434         Stream positionErrorSignal handle:[:ex |
  1435             ^ nil
  1436         ] do:[
  1437             aStream position:sourcePosition abs.
  1438         ].
  1439         junk := aStream nextChunk.
  1440 
  1441         aStream close.
  1442         ^ junk
  1443     ].
  1444     self halt.
  1445 !
  1446 
  1447 syntaxHighlighterClass
  1448     ^ #askClass
  1449 ! !
  1450 
  1451 !SnapShotImageMemory::ImageMethodObject methodsFor:'queries'!
  1452 
  1453 isMethod
  1454     ^ true
  1455 !
  1456 
  1457 previousVersionCode
  1458     "return the receivers previous versions source code"
  1459 
  1460     "there is no previous version"
  1461     ^ nil
  1462 !
  1463 
  1464 sends:aSelectorSymbol
  1465     "return true, if this method contains a message-send
  1466      with aSelectorSymbol as selector."
  1467 
  1468 "/    (self referencesLiteral:aSelectorSymbol) ifTrue:[
  1469 "/        ^ self messagesSent includesIdentical:aSelectorSymbol
  1470 "/    ].
  1471     ^ false
  1472 ! !
  1473 
  1474 !SnapShotImageMemory::ImageClassObject methodsFor:'accessing - slots'!
  1475 
  1476 category
  1477     |categoryRef|
  1478 
  1479     cachedCategory isNil ifTrue:[
  1480         categoryRef := self categorySlot.
  1481         categoryRef isInteger ifTrue:[
  1482             categoryRef := memory fetchObjectAt:categoryRef.
  1483         ].
  1484         categoryRef notNil ifTrue:[
  1485             cachedCategory := memory fetchStringFor:categoryRef.
  1486         ].
  1487     ].
  1488     ^ cachedCategory
  1489 !
  1490 
  1491 categorySlot
  1492     ^ self at:(Class instVarOffsetOf:'category')
  1493 !
  1494 
  1495 classBaseFilename
  1496     ^ self classFilename asFilename baseName
  1497 
  1498     "Created: / 19-10-2006 / 01:10:17 / cg"
  1499 !
  1500 
  1501 classFilename
  1502     |classFilenameRef classFilename|
  1503 
  1504     classFilenameRef := self classFilenameSlot.
  1505     classFilenameRef isInteger ifTrue:[
  1506         classFilenameRef := memory fetchObjectAt:classFilenameRef.
  1507     ].
  1508     classFilenameRef notNil ifTrue:[
  1509         classFilename := memory fetchStringFor:classFilenameRef.
  1510     ].
  1511     ^ classFilename
  1512 !
  1513 
  1514 classFilenameSlot
  1515     ^ self at:(Class instVarOffsetOf:'classFilename')
  1516 !
  1517 
  1518 classVarNames
  1519     |classVarNamesRef classVarNames s|
  1520 
  1521     classVarNamesRef := self classVarsSlot.
  1522     classVarNamesRef isInteger ifTrue:[
  1523         classVarNamesRef := memory fetchObjectAt:classVarNamesRef.
  1524     ].
  1525     classVarNamesRef notNil ifTrue:[
  1526         classVarNamesRef isImageBytes ifTrue:[
  1527             "/ a string
  1528             classVarNames := memory fetchStringFor:classVarNamesRef.
  1529             classVarNames := classVarNames asCollectionOfWords.
  1530         ] ifFalse:[
  1531             classVarNames := Array new:(classVarNamesRef size).
  1532             1 to:classVarNames size do:[:idx |
  1533                 s := classVarNamesRef at:idx.
  1534                 s := memory fetchObjectAt:s.
  1535                 s isImageBytes ifFalse:[self halt].
  1536                 s := memory fetchStringFor:s.
  1537                 classVarNames at:idx put:s.
  1538             ].
  1539         ].
  1540     ].
  1541     ^ classVarNames ? #()
  1542 !
  1543 
  1544 classVariableString
  1545     |classVarsPtr classVarsRef classVars|
  1546 
  1547     (classVarsPtr := self classVarsSlot) == 0 ifTrue:[^ ''].
  1548     classVarsRef := memory fetchObjectAt:classVarsPtr.
  1549     classVarsRef isImageBytes ifTrue:[
  1550         "/ a string
  1551         classVars := memory fetchStringFor:classVarsRef.
  1552         ^ classVars
  1553     ].
  1554     ^ self classVarNames asStringWith:(Character space)
  1555 !
  1556 
  1557 classVarsSlot
  1558     ^ self at:(Class instVarOffsetOf:'classvars')
  1559 !
  1560 
  1561 comment
  1562     |commentRef comment|
  1563 
  1564     commentRef := self commentSlot.
  1565     commentRef isInteger ifTrue:[
  1566         commentRef := memory fetchObjectAt:commentRef.
  1567     ].
  1568     commentRef notNil ifTrue:[
  1569         comment := memory fetchStringFor:commentRef.
  1570     ].
  1571     ^ comment
  1572 !
  1573 
  1574 commentSlot
  1575     ^ self at:(Class instVarOffsetOf:'comment')
  1576 !
  1577 
  1578 flags
  1579     |flags amount|
  1580 
  1581     cachedFlags isNil ifTrue:[
  1582         flags := self flagsSlot.
  1583 
  1584         (SnapShotImageMemory isSmallIntegerOOP:flags) ifFalse:[
  1585             self halt
  1586         ].
  1587         amount := -1.
  1588         cachedFlags := flags bitShift:amount.
  1589     ].
  1590     ^ cachedFlags
  1591 !
  1592 
  1593 flagsSlot
  1594     ^ self at:(Class instVarOffsetOf:'flags')
  1595 !
  1596 
  1597 instSize
  1598     |instSizeRef|
  1599 
  1600     instSizeRef := self instSizeSlot.
  1601     ^ memory fetchObjectAt:instSizeRef.
  1602 !
  1603 
  1604 instSizeSlot
  1605     ^ self at:(Class instVarOffsetOf:'instSize')
  1606 !
  1607 
  1608 instVarNames
  1609     |instVarNamesRef instVarNames s|
  1610 
  1611     instVarNamesRef := self instVarsSlot.
  1612     instVarNamesRef isInteger ifTrue:[
  1613         instVarNamesRef := memory fetchObjectAt:instVarNamesRef.
  1614     ].
  1615     instVarNamesRef notNil ifTrue:[
  1616         instVarNamesRef isImageBytes ifTrue:[
  1617             "/ a string
  1618             instVarNames := memory fetchStringFor:instVarNamesRef.
  1619             instVarNames := instVarNames asCollectionOfWords.
  1620         ] ifFalse:[
  1621             instVarNames := Array new:(instVarNamesRef size).
  1622             1 to:instVarNames size do:[:idx |
  1623                 s := instVarNamesRef at:idx.
  1624                 s := memory fetchObjectAt:s.
  1625                 s isImageBytes ifFalse:[self halt].
  1626                 s := memory fetchStringFor:s.
  1627                 instVarNames at:idx put:s.
  1628             ].
  1629         ].
  1630     ].
  1631     ^ instVarNames ? #()
  1632 !
  1633 
  1634 instVarsSlot
  1635     ^ self at:(Class instVarOffsetOf:'instvars')
  1636 !
  1637 
  1638 methodDictionary
  1639     |methodDictionaryRef methodDictionary|
  1640 
  1641     methodDictionaryRef := self methodDictionarySlot.
  1642     methodDictionaryRef isInteger ifTrue:[
  1643         methodDictionaryRef == 0 ifTrue:[^ nil].
  1644         methodDictionary := memory fetchObjectAt:methodDictionaryRef.
  1645     ].
  1646     ^ methodDictionary
  1647 !
  1648 
  1649 methodDictionarySlot
  1650     ^ self at:(Class instVarOffsetOf:'methodDictionary')
  1651 !
  1652 
  1653 name
  1654     |nameRef|
  1655 
  1656     cachedName isNil ifTrue:[
  1657         self isMeta ifTrue:[
  1658             cachedName := self theNonMetaclass name , ' class'
  1659         ] ifFalse:[
  1660             self isPrivateMeta ifTrue:[
  1661 self halt.
  1662             ].
  1663 
  1664             nameRef := self nameSlot.
  1665             nameRef isInteger ifTrue:[
  1666                 nameRef := memory fetchObjectAt:nameRef.
  1667             ].
  1668             nameRef notNil ifTrue:[
  1669                 cachedName := memory fetchStringFor:nameRef.
  1670                 cachedName := cachedName asSymbol
  1671             ].
  1672         ].
  1673     ].
  1674     ^ cachedName
  1675 !
  1676 
  1677 nameSlot
  1678     ^ self at:(Class instVarOffsetOf:'name')
  1679 !
  1680 
  1681 packageSlot
  1682     ^ self at:(Class instVarOffsetOf:'package')
  1683 !
  1684 
  1685 primitiveSpec
  1686     |primitiveSpecRef primitiveSpec|
  1687 
  1688     primitiveSpecRef := self primitiveSpecSlot.
  1689     primitiveSpecRef isInteger ifTrue:[
  1690         primitiveSpecRef := memory fetchObjectAt:primitiveSpecRef.
  1691     ].
  1692     primitiveSpecRef notNil ifTrue:[
  1693         primitiveSpec := memory fetchStringFor:primitiveSpecRef.
  1694     ].
  1695     ^ primitiveSpec
  1696 !
  1697 
  1698 primitiveSpecSlot
  1699     (Class instVarOffsetOf:'primitiveSpec') isNil ifTrue:[
  1700         ^ self at:(Class instVarOffsetOf:'attributes')
  1701     ].
  1702     ^ self at:(Class instVarOffsetOf:'primitiveSpec')
  1703 !
  1704 
  1705 revision
  1706     |revisionRef revision|
  1707 
  1708     revisionRef := self revisionSlot.
  1709     revisionRef isInteger ifTrue:[
  1710         revisionRef := memory fetchObjectAt:revisionRef.
  1711     ].
  1712     revisionRef notNil ifTrue:[
  1713         revision := memory fetchStringFor:revisionRef.
  1714     ].
  1715     ^ revision
  1716 !
  1717 
  1718 revisionSlot
  1719     ^ self at:(Class instVarOffsetOf:'revision')
  1720 !
  1721 
  1722 superclass
  1723     |superClassRef superClass|
  1724 
  1725     superClassRef := self superclassSlot.
  1726     superClassRef isInteger ifTrue:[
  1727         superClass := memory fetchObjectAt:superClassRef.
  1728     ].
  1729     ^ superClass
  1730 !
  1731 
  1732 superclassSlot
  1733     ^ self at:(Class instVarOffsetOf:'superclass')
  1734 ! !
  1735 
  1736 !SnapShotImageMemory::ImageClassObject methodsFor:'class protocol'!
  1737 
  1738 addAllClassVarNamesTo:aCollection
  1739     "helper - add the name-strings of the class variables and of the class-vars
  1740      of all superclasses to the argument, aCollection. Return aCollection"
  1741 
  1742     |classvars superclass|
  1743 
  1744     (superclass := self superclass) notNil ifTrue:[
  1745         superclass addAllClassVarNamesTo:aCollection
  1746     ].
  1747     (classvars := self classVariableString) notNil ifTrue:[
  1748         aCollection addAll:(classvars asCollectionOfWords).
  1749     ].
  1750     ^ aCollection
  1751 !
  1752 
  1753 addAllInstVarNamesTo:aCollection
  1754     |superInsts instvars superclass|
  1755 
  1756     (superclass := self superclass) notNil ifTrue:[
  1757         self superclass addAllInstVarNamesTo:aCollection
  1758     ].
  1759     aCollection addAll:self instVarNames.
  1760     ^ aCollection
  1761 !
  1762 
  1763 addChangeRecordForClassFileOut:aClass
  1764 !
  1765 
  1766 allClassVarNames
  1767     "return a collection of all the class variable name-strings
  1768      this includes all superclass-class variables"
  1769 
  1770     ^ self addAllClassVarNamesTo:(OrderedCollection new)
  1771 !
  1772 
  1773 allInstVarNames
  1774     self superclass isNil ifTrue:[^ self instVarNames].
  1775     ^ self addAllInstVarNamesTo:(OrderedCollection new)
  1776 !
  1777 
  1778 allSubclassesDo:aBlock
  1779     "evaluate aBlock for all of my subclasses.
  1780      There is no specific order, in which the entries are enumerated.
  1781      Warning:
  1782         This will only enumerate globally known classes - for anonymous
  1783         behaviors, you have to walk over all instances of Behavior."
  1784 
  1785     self isMeta ifTrue:[
  1786         "/ metaclasses are not found via Smalltalk allClassesDo:
  1787         "/ here, walk over classes and enumerate corresponding metas.
  1788         self soleInstance allSubclassesDo:[:aSubClass |
  1789             aBlock value:(aSubClass theMetaclass)
  1790         ].
  1791     ] ifFalse:[
  1792         Smalltalk allClassesDo:[:aClass |
  1793             (aClass isSubclassOf:self) ifTrue:[
  1794                 aBlock value:aClass
  1795             ]
  1796         ]
  1797     ]
  1798 
  1799     "
  1800      Collection allSubclassesDo:[:c | Transcript showCR:(c name)]
  1801      Collection class allSubclassesDo:[:c | Transcript showCR:(c name)]
  1802     "
  1803 
  1804     "Modified: / 25.10.1997 / 21:17:13 / cg"
  1805 !
  1806 
  1807 allSuperclasses
  1808     "return a collection of the receivers accumulated superclasses"
  1809 
  1810     |aCollection theSuperClass|
  1811 
  1812     theSuperClass := self superclass.
  1813     theSuperClass isNil ifTrue:[
  1814         ^ #()
  1815     ].
  1816     aCollection := OrderedCollection new.
  1817     [theSuperClass notNil] whileTrue:[
  1818         aCollection add:theSuperClass.
  1819         theSuperClass := theSuperClass superclass
  1820     ].
  1821     ^ aCollection
  1822 
  1823     "
  1824      String allSuperclasses 
  1825     "
  1826 !
  1827 
  1828 allSuperclassesDo:aBlock
  1829     "evaluate aBlock for all of my superclasses"
  1830 
  1831     |theClass|
  1832 
  1833     theClass := self superclass.
  1834     [theClass notNil] whileTrue:[
  1835         aBlock value:theClass.
  1836         theClass := theClass superclass
  1837     ]
  1838 
  1839     "
  1840      String allSuperclassesDo:[:c | Transcript showCR:(c name)]
  1841     "
  1842 !
  1843 
  1844 basicFileOutDefinitionOn:aStream withNameSpace:forceNameSpace
  1845     "append an expression on aStream, which defines myself."
  1846 
  1847     self
  1848         basicFileOutDefinitionOn:aStream 
  1849         withNameSpace:forceNameSpace 
  1850         withPackage:true
  1851 !
  1852 
  1853 basicFileOutDefinitionOn:aStream withNameSpace:forceNameSpace withPackage:showPackage
  1854     "append an expression on aStream, which defines myself."
  1855 
  1856     |s owner ns nsName fullName superName cls topOwner
  1857      syntaxHilighting superclass category|
  1858 
  1859     UserPreferences isNil ifTrue:[
  1860         syntaxHilighting := false
  1861     ] ifFalse:[
  1862         syntaxHilighting := UserPreferences current syntaxColoring.
  1863     ].
  1864 
  1865     owner := self owningClass.
  1866 
  1867     owner isNil ifTrue:[
  1868         ns := self nameSpace.
  1869     ] ifFalse:[
  1870         ns := self topOwningClass nameSpace
  1871     ].
  1872     fullName := Class fileOutNameSpaceQuerySignal query == true.
  1873 
  1874     (showPackage and:[owner isNil]) ifTrue:[
  1875         aStream nextPutAll:'"{ Package: '''.
  1876         aStream nextPutAll:self package asString.
  1877         aStream nextPutAll:''' }"'; cr; cr.
  1878     ].
  1879 
  1880     ((owner isNil and:[fullName not])
  1881     or:[owner notNil and:[forceNameSpace and:[fullName not]]]) ifTrue:[
  1882         (ns notNil and:[ns ~~ Smalltalk]) ifTrue:[
  1883             nsName := ns name.
  1884             (nsName includes:$:) ifTrue:[
  1885                 nsName := '''' , nsName , ''''
  1886             ].
  1887 "/            aStream nextPutLine:'"{ NameSpace: ' , nsName , ' }"'; cr.
  1888             aStream nextPutAll:'"{ NameSpace: '.
  1889             syntaxHilighting ifTrue:[aStream bold].
  1890             aStream nextPutAll:nsName.
  1891             syntaxHilighting ifTrue:[aStream normal].
  1892             aStream nextPutAll:' }"'; cr; cr.
  1893         ]
  1894     ].
  1895 
  1896     superclass := self superclass.
  1897     category := self category.
  1898 
  1899     "take care of nil-superclass"
  1900     superclass isNil ifTrue:[
  1901         s := 'nil'
  1902     ] ifFalse:[
  1903         fullName ifTrue:[
  1904             superclass == owner ifTrue:[
  1905                 s := superclass nameWithoutNameSpacePrefix
  1906             ] ifFalse:[
  1907                 s := superclass name
  1908             ]
  1909         ] ifFalse:[
  1910             (ns == superclass nameSpace 
  1911             and:[superclass owningClass isNil]) ifTrue:[
  1912                 "/ superclass is in the same namespace;
  1913                 "/ still prepend namespace prefix, to avoid
  1914                 "/ confusing stc, which needs that information ...
  1915                 s := superclass nameWithoutPrefix
  1916             ] ifFalse:[
  1917                 "/ a very special (rare) situation:
  1918                 "/ my superclass resides in another nameSpace,
  1919                 "/ but there is something else named like this
  1920                 "/ to be found in my nameSpace (or a private class)
  1921 
  1922                 superName := superclass nameWithoutNameSpacePrefix asSymbol.
  1923                 cls := self privateClassesAt:superName.
  1924                 cls isNil ifTrue:[
  1925                     (topOwner := self topOwningClass) isNil ifTrue:[
  1926                         ns := self nameSpace.
  1927                         ns notNil ifTrue:[
  1928                             cls := ns privateClassesAt:superName
  1929                         ] ifFalse:[
  1930                             "/ self error:'unexpected nil namespace'
  1931                         ]
  1932                     ] ifFalse:[
  1933                         cls := topOwner nameSpace at:superName.
  1934                     ]
  1935                 ].
  1936                 (cls notNil and:[cls ~~ superclass]) ifTrue:[
  1937                     s := superclass nameSpace name , '::' , superName
  1938                 ] ifFalse:[
  1939                     "/ no class with that name found in my namespace ...
  1940                     "/ if the superclass resides in Smalltalk,
  1941                     "/ suppress prefix; otherwise, use full prefix.
  1942                     (superclass nameSpace notNil 
  1943                     and:[superclass nameSpace ~~ Smalltalk]) ifTrue:[
  1944                         (owner notNil 
  1945                         and:[owner nameSpace == superclass owningClass nameSpace])
  1946                         ifTrue:[
  1947                             s := superclass nameWithoutNameSpacePrefix
  1948                         ] ifFalse:[
  1949                             s := superclass name
  1950                         ]
  1951                     ] ifFalse:[
  1952                         s := superName
  1953                     ]
  1954                 ]
  1955             ]
  1956         ]
  1957     ].
  1958 
  1959     syntaxHilighting ifTrue:[aStream bold].
  1960     aStream nextPutAll:s.   "/ superclass
  1961     syntaxHilighting ifTrue:[aStream normal].
  1962     aStream space.
  1963     self basicFileOutInstvarTypeKeywordOn:aStream.
  1964 
  1965     (fullName and:[owner isNil]) ifTrue:[
  1966         aStream nextPutAll:'#'''.
  1967         syntaxHilighting ifTrue:[aStream bold].
  1968         aStream nextPutAll:(self name).
  1969         syntaxHilighting ifTrue:[aStream normal].
  1970         aStream nextPutAll:''''.
  1971     ] ifFalse:[
  1972         aStream nextPut:$#.
  1973         syntaxHilighting ifTrue:[aStream bold].
  1974         aStream nextPutAll:(self nameWithoutPrefix).
  1975         syntaxHilighting ifTrue:[aStream normal].
  1976     ].
  1977 
  1978     aStream crtab. 
  1979     aStream nextPutAll:'instanceVariableNames:'''.
  1980     syntaxHilighting ifTrue:[aStream bold].
  1981     self printInstVarNamesOn:aStream indent:16.
  1982     syntaxHilighting ifTrue:[aStream normal].
  1983     aStream nextPutAll:''''.
  1984 
  1985     aStream crtab.
  1986     aStream nextPutAll:'classVariableNames:'''.
  1987     syntaxHilighting ifTrue:[aStream bold].
  1988     self printClassVarNamesOn:aStream indent:16.
  1989     syntaxHilighting ifTrue:[aStream normal].
  1990     aStream nextPutAll:''''.
  1991 
  1992     aStream crtab.
  1993     aStream nextPutAll:'poolDictionaries:'''''.
  1994 
  1995     aStream crtab.
  1996     owner isNil ifTrue:[
  1997         "/ a public class
  1998         aStream nextPutAll:'category:'.
  1999         category isNil ifTrue:[
  2000             s := ''''''
  2001         ] ifFalse:[
  2002             s := category asString storeString
  2003         ].
  2004         aStream nextPutAll:s.
  2005     ] ifFalse:[
  2006         "/ a private class
  2007         aStream nextPutAll:'privateIn:'.
  2008         syntaxHilighting ifTrue:[aStream bold].
  2009 "/        fullName ifTrue:[
  2010 "/            s := owner name.
  2011 "/        ] ifFalse:[
  2012 "/            s := owner nameWithoutNameSpacePrefix.
  2013 "/        ].
  2014         s := owner nameWithoutNameSpacePrefix.
  2015         aStream nextPutAll:s.
  2016         syntaxHilighting ifTrue:[aStream normal].
  2017     ].
  2018     aStream cr
  2019 
  2020     "Created: / 4.1.1997 / 20:38:16 / cg"
  2021     "Modified: / 8.8.1997 / 10:59:50 / cg"
  2022     "Modified: / 18.3.1999 / 18:15:46 / stefan"
  2023 !
  2024 
  2025 basicFileOutInstvarTypeKeywordOn:aStream
  2026     "a helper for fileOutDefinition"
  2027 
  2028     |isVar s superclass|
  2029 
  2030     superclass := self superclass.
  2031     superclass isNil ifTrue:[
  2032         isVar := self isVariable
  2033     ] ifFalse:[
  2034         "I cant remember what this is for ?"
  2035         isVar := (self isVariable and:[superclass isVariable not])
  2036     ].
  2037 
  2038     aStream nextPutAll:(self firstDefinitionSelectorPart).
  2039 
  2040     "Created: 11.10.1996 / 18:57:29 / cg"
  2041 !
  2042 
  2043 binaryRevision
  2044     "return the revision-ID from which the class was stc-compiled;
  2045      nil if its an autoloaded or filedIn class.
  2046      If a classes binary is up-to-date w.r.t. the source repository,
  2047      the returned string is the same as the one returned by #revision."
  2048 
  2049     |owner info c revision|
  2050 
  2051     revision := self revision.
  2052 
  2053     (owner := self owningClass) notNil ifTrue:[^ owner binaryRevision].
  2054     revision notNil ifTrue:[
  2055         c := revision first.
  2056         c == $$ ifTrue:[
  2057             info := Class revisionInfoFromString:revision.
  2058             info isNil ifTrue:[^ '0'].
  2059             ^ info at:#revision ifAbsent:'0'.
  2060         ].
  2061         c isDigit ifFalse:[
  2062             ^ '0'
  2063         ].
  2064     ].
  2065 
  2066     ^ revision
  2067 
  2068     "
  2069      Object binaryRevision
  2070      Object class binaryRevision
  2071     "
  2072 
  2073     "
  2074      to find all classes which are not up-to-date:
  2075 
  2076      |classes|
  2077 
  2078      classes := Smalltalk allClasses 
  2079                     select:[:cls | cls binaryRevision notNil and:[cls binaryRevision ~= cls revision]].
  2080      SystemBrowser browseClasses:classes title:'classes which are not up-to-date'
  2081     "
  2082 
  2083     "Created: 7.12.1995 / 10:58:47 / cg"
  2084     "Modified: 1.4.1997 / 23:33:01 / stefan"
  2085     "Modified: 9.9.1997 / 12:05:41 / cg"
  2086 !
  2087 
  2088 compiledMethodAt:aSelector
  2089 
  2090     ^ self compiledMethodAt:aSelector ifAbsent:nil
  2091 !
  2092 
  2093 compiledMethodAt:aSelector ifAbsent:exceptionValue
  2094     |dict|
  2095 
  2096     dict := self methodDictionary.
  2097     dict isNil ifTrue:[
  2098         ('Behavior [warning]: nil methodDictionary in ' , self name printString) errorPrintCR.
  2099         ^ exceptionValue value
  2100     ].
  2101 
  2102     ^ dict at:aSelector ifAbsent:exceptionValue
  2103 !
  2104 
  2105 evaluatorClass
  2106     ^ Object evaluatorClass
  2107 !
  2108 
  2109 fileOut
  2110     |baseName dirName nm fileName|
  2111 
  2112     baseName := (Smalltalk fileNameForClass:self name).
  2113     nm := baseName asFilename withSuffix:'st'.
  2114 
  2115     "
  2116      this test allows a smalltalk to be built without Projects/ChangeSets
  2117     "
  2118     Project notNil ifTrue:[
  2119         dirName := Project currentProjectDirectory
  2120     ] ifFalse:[
  2121         dirName := Filename currentDirectory
  2122     ].
  2123     fileName := (dirName asFilename construct:nm).
  2124     fileName makeLegalFilename.
  2125 
  2126     self fileOutAs:fileName name.
  2127 
  2128 "/    "
  2129 "/     add a change record; that way, administration is much easier,
  2130 "/     since we can see in that changeBrowser, which changes have 
  2131 "/     already found their way into a sourceFile and which must be
  2132 "/     applied again
  2133 "/    "
  2134 "/    self addChangeRecordForClassFileOut:self
  2135 
  2136     "Modified: / 7.6.1996 / 09:14:43 / stefan"
  2137     "Modified: / 27.8.1998 / 02:02:57 / cg"
  2138 !
  2139 
  2140 fileOutAllDefinitionsOn:aStream
  2141     "append expressions on aStream, which defines myself and all of my private classes."
  2142 
  2143     self fileOutDefinitionOn:aStream.
  2144     aStream nextPutChunkSeparator. 
  2145     aStream cr; cr.
  2146 
  2147     "/
  2148     "/ optional classInstanceVariables
  2149     "/
  2150     self classRef instanceVariableString isBlank ifFalse:[
  2151         self fileOutClassInstVarDefinitionOn:aStream.
  2152         aStream nextPutChunkSeparator. 
  2153         aStream cr; cr
  2154     ].
  2155 
  2156     "/ here, the full nameSpace prefixes are output,
  2157     "/ to avoid confusing stc 
  2158     "/ (which otherwise could not find the correct superclass)
  2159     "/
  2160     Class fileOutNameSpaceQuerySignal answer:true do:[
  2161         self privateClassesSorted do:[:aClass |
  2162             aClass fileOutAllDefinitionsOn:aStream
  2163         ]
  2164     ].
  2165 
  2166     "Created: 15.10.1996 / 11:15:19 / cg"
  2167     "Modified: 22.3.1997 / 16:11:56 / cg"
  2168 !
  2169 
  2170 fileOutAllMethodsOn:aStream methodFilter:methodFilter
  2171     |collectionOfCategories|
  2172 
  2173     collectionOfCategories := self theMetaclass categories asSortedCollection.
  2174     collectionOfCategories notNil ifTrue:[
  2175         collectionOfCategories do:[:aCategory |
  2176             self theMetaclass fileOutCategory:aCategory methodFilter:methodFilter on:aStream.
  2177             aStream cr
  2178         ]
  2179     ].
  2180     collectionOfCategories := self categories asSortedCollection.
  2181     collectionOfCategories notNil ifTrue:[
  2182         collectionOfCategories do:[:aCategory |
  2183             self fileOutCategory:aCategory methodFilter:methodFilter on:aStream.
  2184             aStream cr
  2185         ]
  2186     ].
  2187 
  2188     self privateClassesSorted do:[:aClass |
  2189         aClass fileOutAllMethodsOn:aStream methodFilter:methodFilter
  2190     ].
  2191 !
  2192 
  2193 fileOutAs:fileNameString
  2194     "create a file consisting of all methods in myself in
  2195      sourceForm, from which the class can be reconstructed (by filing in).
  2196      The given fileName should be a full path, including suffix.
  2197      Care is taken, to not clobber any existing file in
  2198      case of errors (for example: disk full). 
  2199      Also, since the classes methods need a valid sourcefile, the current 
  2200      sourceFile may not be rewritten."
  2201 
  2202     |aStream fileName newFileName savFilename needRename
  2203      mySourceFileName sameFile s mySourceFileID anySourceRef|
  2204 
  2205     self isLoaded ifFalse:[
  2206         ^ Class fileOutErrorSignal 
  2207             raiseRequestWith:self
  2208                  errorString:'will not fileOut unloaded classes'
  2209     ].
  2210 
  2211     fileName := fileNameString asFilename.
  2212 
  2213     "
  2214      if file exists, copy the existing to a .sav-file,
  2215      create the new file as XXX.new-file,
  2216      and, if that worked rename afterwards ...
  2217     "
  2218     (fileName exists) ifTrue:[
  2219         sameFile := false.
  2220 
  2221         "/ check carefully - maybe, my source does not really come from that
  2222         "/ file (i.e. all of my methods have their source as string)
  2223 
  2224         anySourceRef := false.
  2225         self methodDictionary do:[:m|
  2226             m sourcePosition notNil ifTrue:[
  2227                 anySourceRef := true
  2228             ]
  2229         ].
  2230         self classRef methodDictionary do:[:m|
  2231             m sourcePosition notNil ifTrue:[
  2232                 anySourceRef := true
  2233             ]
  2234         ].
  2235 
  2236         anySourceRef ifTrue:[
  2237             s := self sourceStream.
  2238             s notNil ifTrue:[
  2239                 mySourceFileID := s pathName asFilename info id.
  2240                 sameFile := (fileName info id) == mySourceFileID.
  2241                 s close.
  2242             ] ifFalse:[
  2243                 self classFilename notNil ifTrue:[
  2244                     "
  2245                      check for overwriting my current source file
  2246                      this is not allowed, since it would clobber my methods source
  2247                      file ... you have to save it to some other place.
  2248                      This happens if you ask for a fileOut into the source-directory
  2249                      (from which my methods get their source)
  2250                     "
  2251                     mySourceFileName := Smalltalk getSourceFileName:self classFilename. 
  2252                     sameFile := (fileNameString = mySourceFileName).
  2253                     sameFile ifFalse:[
  2254                         mySourceFileName notNil ifTrue:[
  2255                             sameFile := (fileName info id) == (mySourceFileName asFilename info id)
  2256                         ]
  2257                     ].
  2258                 ]
  2259             ].
  2260         ].
  2261 
  2262         sameFile ifTrue:[
  2263             ^ Class fileOutErrorSignal 
  2264                 raiseRequestWith:fileNameString
  2265                 errorString:('may not overwrite sourcefile:', fileNameString)
  2266         ].
  2267 
  2268         savFilename := Filename newTemporary.
  2269         fileName copyTo:savFilename.
  2270         newFileName := fileName withSuffix:'new'.
  2271         needRename := true
  2272     ] ifFalse:[
  2273         "/ another possible trap: if my sourceFileName is
  2274         "/ the same as the written one AND the new files directory
  2275         "/ is along the sourcePath, we also need a temporary file
  2276         "/ first, to avoid accessing the newly written file.
  2277 
  2278         anySourceRef := false.
  2279         self methodDictionary do:[:m|
  2280             |mSrc|
  2281 
  2282             (mSrc := m sourceFilename) notNil ifTrue:[
  2283                 mSrc asFilename baseName = fileName baseName ifTrue:[
  2284                     anySourceRef := true
  2285                 ]
  2286             ]
  2287         ].
  2288         self classRef methodDictionary do:[:m|
  2289             |mSrc|
  2290 
  2291             (mSrc := m sourceFilename) notNil ifTrue:[
  2292                 mSrc asFilename baseName = fileName baseName ifTrue:[
  2293                     anySourceRef := true
  2294                 ]
  2295             ]
  2296         ].
  2297         anySourceRef ifTrue:[
  2298             newFileName := fileName withSuffix:'new'.
  2299             needRename := true
  2300         ] ifFalse:[
  2301             newFileName := fileName.
  2302             needRename := false
  2303         ]
  2304     ].
  2305 
  2306     aStream := newFileName writeStream.
  2307     aStream isNil ifTrue:[
  2308         savFilename notNil ifTrue:[
  2309             savFilename delete
  2310         ].
  2311         ^ Class fileOutErrorSignal 
  2312                 raiseRequestWith:newFileName
  2313                 errorString:('cannot create file:', newFileName name)
  2314     ].
  2315     self fileOutOn:aStream.
  2316     aStream close.
  2317 
  2318     "
  2319      finally, replace the old-file
  2320      be careful, if the old one is a symbolic link; in this case,
  2321      we have to do a copy ...
  2322     "
  2323     needRename ifTrue:[
  2324         newFileName copyTo:fileName.
  2325         newFileName delete
  2326     ].
  2327     savFilename notNil ifTrue:[
  2328         savFilename delete
  2329     ].
  2330 
  2331     "
  2332      add a change record; that way, administration is much easier,
  2333      since we can see in that changeBrowser, which changes have 
  2334      already found their way into a sourceFile and which must be
  2335      applied again
  2336     "
  2337     self addChangeRecordForClassFileOut:self
  2338 
  2339     "Modified: / 7.6.1996 / 09:14:43 / stefan"
  2340     "Created: / 16.4.1997 / 20:44:05 / cg"
  2341     "Modified: / 12.8.1998 / 11:14:56 / cg"
  2342 !
  2343 
  2344 fileOutCategory:aCategory
  2345     "create a file 'class-category.st' consisting of all methods in aCategory.
  2346      If the current project is not nil, create the file in the projects
  2347      directory."
  2348 
  2349     |aStream fileName|
  2350 
  2351     fileName := (self name , '-' , aCategory , '.st') asFilename.
  2352     fileName makeLegalFilename.
  2353 
  2354     "/
  2355     "/ this test allows a smalltalk to be built without Projects/ChangeSets
  2356     "/
  2357     Project notNil ifTrue:[
  2358         fileName := Project currentProjectDirectory asFilename construct:(fileName name).
  2359     ].
  2360 
  2361     "/
  2362     "/ if the file exists, save original in a .sav file
  2363     "/
  2364     fileName exists ifTrue:[
  2365         fileName copyTo:(fileName withSuffix:'sav')
  2366     ].
  2367     aStream := FileStream newFileNamed:fileName.
  2368     aStream isNil ifTrue:[
  2369         ^ Class fileOutErrorSignal 
  2370                 raiseRequestWith:fileName
  2371                 errorString:('cannot create file:', fileName pathName)
  2372     ].
  2373 
  2374     self fileOutCategory:aCategory on:aStream.
  2375     aStream close
  2376 
  2377     "Modified: / 1.4.1997 / 16:00:24 / stefan"
  2378     "Created: / 1.4.1997 / 16:04:18 / stefan"
  2379     "Modified: / 28.10.1997 / 14:40:28 / cg"
  2380 !
  2381 
  2382 fileOutCategory:aCategory except:skippedMethods only:savedMethods methodFilter:methodFilter on:aStream
  2383     |dict source sortedSelectors first privacy interestingMethods cat|
  2384 
  2385     dict := self methodDictionary.
  2386     dict notNil ifTrue:[
  2387         interestingMethods := OrderedCollection new.
  2388         dict do:[:aMethod |
  2389             |wanted|
  2390 
  2391             (methodFilter isNil
  2392             or:[methodFilter value:aMethod]) ifTrue:[
  2393                 (aCategory = aMethod category) ifTrue:[
  2394                     skippedMethods notNil ifTrue:[
  2395                         wanted := (skippedMethods includesIdentical:aMethod) not
  2396                     ] ifFalse:[
  2397                         savedMethods notNil ifTrue:[
  2398                             wanted := (savedMethods includesIdentical:aMethod).
  2399                         ] ifFalse:[
  2400                             wanted := true
  2401                         ]
  2402                     ].
  2403                     wanted ifTrue:[interestingMethods add:aMethod].
  2404                 ]
  2405             ]
  2406         ].
  2407         interestingMethods notEmpty ifTrue:[
  2408             first := true.
  2409             privacy := nil.
  2410 
  2411             "/
  2412             "/ sort by selector
  2413             "/
  2414             sortedSelectors := interestingMethods collect:[:m | self selectorAtMethod:m].
  2415             sortedSelectors sortWith:interestingMethods.
  2416 
  2417             interestingMethods do:[:aMethod |
  2418                 first ifFalse:[
  2419                     privacy ~~ aMethod privacy ifTrue:[
  2420                         first := true.
  2421                         aStream space.
  2422                         aStream nextPutChunkSeparator.
  2423                     ].
  2424                     aStream cr; cr
  2425                 ].
  2426 
  2427                 privacy := aMethod privacy.
  2428 
  2429                 first ifTrue:[
  2430                     aStream nextPutChunkSeparator.
  2431                     self printClassNameOn:aStream.
  2432                     privacy ~~ #public ifTrue:[
  2433                         aStream space; nextPutAll:privacy; nextPutAll:'MethodsFor:'.
  2434                     ] ifFalse:[
  2435                         aStream nextPutAll:' methodsFor:'.
  2436                     ].
  2437                     cat := aCategory.
  2438                     cat isNil ifTrue:[ cat := '' ].
  2439                     aStream nextPutAll:aCategory asString storeString.
  2440                     aStream nextPutChunkSeparator; cr; cr.
  2441                     first := false.
  2442                 ].
  2443                 source := aMethod source.
  2444                 source isNil ifTrue:[
  2445                     Class fileOutErrorSignal 
  2446                         raiseRequestWith:self
  2447                         errorString:'no source for method: ', (aMethod displayString)
  2448                 ] ifFalse:[
  2449                     aStream nextChunkPut:source.
  2450                 ].
  2451             ].
  2452             aStream space.
  2453             aStream nextPutChunkSeparator.
  2454             aStream cr
  2455         ]
  2456     ]
  2457 
  2458     "Modified: 28.8.1995 / 14:30:41 / claus"
  2459     "Modified: 12.6.1996 / 11:37:33 / stefan"
  2460     "Modified: 15.11.1996 / 11:32:21 / cg"
  2461     "Created: 1.4.1997 / 16:04:33 / stefan"
  2462 !
  2463 
  2464 fileOutCategory:aCategory methodFilter:methodFilter on:aStream
  2465     "file out all methods belonging to aCategory, aString onto aStream"
  2466 
  2467     self fileOutCategory:aCategory except:nil only:nil methodFilter:methodFilter on:aStream
  2468 !
  2469 
  2470 fileOutCategory:aCategory on:aStream
  2471     Class fileOutNameSpaceQuerySignal answer:true do:[
  2472         self fileOutCategory:aCategory except:nil only:nil methodFilter:nil on:aStream
  2473     ]
  2474 !
  2475 
  2476 fileOutClassInstVarDefinitionOn:aStream withNameSpace:withNameSpace
  2477     "append an expression to define my classInstanceVariables on aStream"
  2478 
  2479     |anySuperClassInstVar|
  2480 
  2481     self isLoaded ifFalse:[
  2482         ^ self basicFileOutDefinitionOn:aStream withNameSpace:withNameSpace
  2483     ].
  2484 
  2485     withNameSpace ifTrue:[
  2486         self name printOn:aStream.
  2487     ] ifFalse:[
  2488         self printClassNameOn:aStream.
  2489     ].
  2490     aStream nextPutAll:' class instanceVariableNames:'''.
  2491     self theMetaclass printInstVarNamesOn:aStream indent:8.
  2492     aStream nextPutAll:''''.
  2493 
  2494     "mhmh - good idea; saw this in SmallDraw sourcecode ..."
  2495 
  2496     anySuperClassInstVar := false.
  2497     self allSuperclassesDo:[:aSuperClass |
  2498         aSuperClass theMetaclass instVarNames do:[:ignored | anySuperClassInstVar := true].
  2499     ].
  2500 
  2501     aStream cr; cr; nextPut:(Character doubleQuote); cr; space.
  2502     anySuperClassInstVar ifFalse:[
  2503         aStream  
  2504             nextPutLine:'No other class instance variables are inherited by this class.'.
  2505     ] ifTrue:[
  2506         aStream  
  2507             nextPutLine:'The following class instance variables are inherited by this class:'.
  2508         aStream cr.
  2509         self allSuperclassesDo:[:aSuperClass |
  2510             aStream tab; nextPutAll:aSuperClass name; nextPutAll:' - '.
  2511             aStream nextPutLine:(aSuperClass theMetaclass instanceVariableString).
  2512         ].
  2513 
  2514     ].
  2515     aStream nextPut:(Character doubleQuote); cr.
  2516 
  2517     "Created: / 10.12.1995 / 16:31:25 / cg"
  2518     "Modified: / 1.4.1997 / 16:00:33 / stefan"
  2519     "Modified: / 3.2.2000 / 23:05:28 / cg"
  2520 !
  2521 
  2522 fileOutCommentOn:aStream
  2523     "append an expression on aStream, which defines my comment"
  2524 
  2525     |comment s|
  2526 
  2527     self printClassNameOn:aStream.
  2528     aStream nextPutAll:' comment:'.
  2529     (comment := self comment) isNil ifTrue:[
  2530         s := ''''''
  2531     ] ifFalse:[
  2532         s := comment storeString
  2533     ].
  2534     aStream nextPutAllAsChunk:s.
  2535     aStream nextPutChunkSeparator.
  2536     aStream cr
  2537 !
  2538 
  2539 fileOutDefinitionOn:aStream
  2540     "append an expression on aStream, which defines myself."
  2541 
  2542     ^ self basicFileOutDefinitionOn:aStream withNameSpace:false
  2543 !
  2544 
  2545 fileOutMethod:aMethod
  2546     |aStream fileName selector|
  2547 
  2548     selector := self selectorAtMethod:aMethod.
  2549     selector notNil ifTrue:[
  2550         fileName := (self name , '-' , selector, '.st') asFilename.
  2551         fileName makeLegalFilename.
  2552 
  2553         "
  2554          this test allows a smalltalk to be built without Projects/ChangeSets
  2555         "
  2556         Project notNil ifTrue:[
  2557             fileName := Project currentProjectDirectory asFilename construct:fileName name.
  2558         ].
  2559 
  2560         "
  2561          if file exists, save original in a .sav file
  2562         "
  2563         fileName exists ifTrue:[
  2564             fileName copyTo:(fileName withSuffix: 'sav')
  2565         ].
  2566 
  2567         fileName := fileName name.
  2568 
  2569         aStream := FileStream newFileNamed:fileName.
  2570         aStream isNil ifTrue:[
  2571             ^ Class fileOutErrorSignal 
  2572                 raiseRequestWith:fileName
  2573                 errorString:('cannot create file:', fileName)
  2574         ].
  2575         self fileOutMethod:aMethod on:aStream.
  2576         aStream close
  2577     ]
  2578 
  2579     "Modified: / 1.4.1997 / 16:00:57 / stefan"
  2580     "Created: / 2.4.1997 / 00:24:28 / stefan"
  2581     "Modified: / 28.10.1997 / 14:40:34 / cg"
  2582 !
  2583 
  2584 fileOutMethod:aMethod on:aStream
  2585     |dict cat source privacy|
  2586 
  2587     dict := self methodDictionary.
  2588     dict notNil ifTrue:[
  2589         aStream nextPutChunkSeparator.
  2590         self name printOn:aStream.
  2591 "/        self printClassNameOn:aStream.
  2592 
  2593         (privacy := aMethod privacy) ~~ #public ifTrue:[
  2594             aStream space; nextPutAll:privacy; nextPutAll:'MethodsFor:'.
  2595         ] ifFalse:[
  2596             aStream nextPutAll:' methodsFor:'.
  2597         ].
  2598         cat := aMethod category.
  2599         cat isNil ifTrue:[
  2600             cat := ''
  2601         ].
  2602         aStream nextPutAll:cat asString storeString.
  2603         aStream nextPutChunkSeparator; cr; cr.
  2604         source := aMethod source.
  2605         source isNil ifTrue:[
  2606             Class fileOutErrorSignal 
  2607                 raiseRequestWith:self
  2608                 errorString:('no source for method: ' ,
  2609                              self name , '>>' ,
  2610                              (self selectorAtMethod:aMethod))
  2611         ] ifFalse:[
  2612             aStream nextChunkPut:source.
  2613         ].
  2614         aStream space.
  2615         aStream nextPutChunkSeparator.
  2616         aStream cr
  2617     ]
  2618 
  2619     "Modified: 27.8.1995 / 01:23:19 / claus"
  2620     "Modified: 12.6.1996 / 11:44:41 / stefan"
  2621     "Modified: 15.11.1996 / 11:32:43 / cg"
  2622     "Created: 2.4.1997 / 00:24:33 / stefan"
  2623 !
  2624 
  2625 fileOutOn:aStream
  2626 
  2627     ^ self fileOutOn:aStream withTimeStamp:true
  2628 !
  2629 
  2630 fileOutOn:aStream withTimeStamp:stampIt
  2631     "file out my definition and all methods onto aStream.
  2632      If stampIt is true, a timeStamp comment is prepended."
  2633 
  2634     self fileOutOn:aStream withTimeStamp:stampIt withInitialize:true
  2635 !
  2636 
  2637 fileOutOn:aStream withTimeStamp:stampIt withInitialize:initIt
  2638     "file out my definition and all methods onto aStream.
  2639      If stampIt is true, a timeStamp comment is prepended.
  2640      If initIt is true, and the class implements a class-initialize method,
  2641      append a corresponding doIt expression for initialization."
  2642 
  2643     self 
  2644         fileOutOn:aStream 
  2645         withTimeStamp:stampIt 
  2646         withInitialize:initIt 
  2647         withDefinition:true
  2648         methodFilter:nil
  2649 !
  2650 
  2651 fileOutOn:aStream withTimeStamp:stampIt withInitialize:initIt withDefinition:withDefinition methodFilter:methodFilter
  2652     "file out my definition and all methods onto aStream.
  2653      If stampIt is true, a timeStamp comment is prepended.
  2654      If initIt is true, and the class implements a class-initialize method,
  2655      append a corresponding doIt expression for initialization.
  2656      The order by which the fileOut is done is used to put the version string at the end.
  2657      Thus, if the version string is expanded (by CVS), the characterPositions of methods should not move"
  2658 
  2659     |collectionOfCategories copyrightMethod copyrightText comment versionMethod skippedMethods
  2660      meta|
  2661 
  2662     self isLoaded ifFalse:[
  2663         ^ Class fileOutErrorSignal 
  2664             raiseRequestWith:self
  2665                  errorString:'will not fileOut unloaded classes'
  2666     ].
  2667 
  2668     meta := self classRef.
  2669 
  2670     "
  2671      if there is a copyright method, add a copyright comment
  2672      at the beginning, taking the string from the copyright method.
  2673      We cannot do this unconditionally - that would lead to my copyrights
  2674      being put on your code ;-).
  2675      On the other hand: I want every file created by myself to have the
  2676      copyright string at the beginning be preserved .... even if the
  2677      code was edited in the browser and filedOut.
  2678     "
  2679     (copyrightMethod := meta compiledMethodAt:#copyright) notNil ifTrue:[
  2680         "
  2681          get the copyright methods source,
  2682          and insert at beginning.
  2683         "
  2684         copyrightText := copyrightMethod source.
  2685         copyrightText isNil ifTrue:[
  2686             "
  2687              no source available - trigger an error
  2688             "
  2689             Class fileOutErrorSignal
  2690                 raiseRequestWith:'no source for class ' , self name , ' available. Cannot fileOut'.
  2691             ^ self
  2692         ].
  2693         "
  2694          strip off the selector-line
  2695         "
  2696         copyrightText := copyrightText asCollectionOfLines asStringCollection.
  2697         copyrightText := copyrightText copyFrom:2 to:(copyrightText size).
  2698 "/        copyrightText do:[:line | aStream nextPutAll:line. aStream cr.].
  2699         copyrightText := copyrightText asString.
  2700         aStream nextPutAllAsChunk:copyrightText.
  2701     ].
  2702 
  2703     stampIt ifTrue:[
  2704         "/
  2705         "/ first, a timestamp
  2706         "/
  2707         aStream nextPutAll:(Smalltalk timeStamp).
  2708         aStream nextPutChunkSeparator. 
  2709         aStream cr; cr.
  2710     ].
  2711 
  2712     withDefinition ifTrue:[
  2713         "/
  2714         "/ then the definition
  2715         "/
  2716         self fileOutAllDefinitionsOn:aStream.
  2717         "/
  2718         "/ a comment - if any
  2719         "/
  2720         (comment := self comment) notNil ifTrue:[
  2721             self fileOutCommentOn:aStream.
  2722             aStream cr.
  2723         ].
  2724         "/
  2725         "/ primitive definitions - if any
  2726         "/
  2727         self fileOutPrimitiveSpecsOn:aStream.
  2728     ].
  2729 
  2730     "/
  2731     "/ methods from all categories in metaclass (i.e. class methods)
  2732     "/ EXCEPT: the version method is placed at the very end, to
  2733     "/         avoid sourcePosition-shifts when checked out later.
  2734     "/         (RCS expands this string, so its size is not constant)
  2735     "/
  2736     collectionOfCategories := meta categories asSortedCollection.
  2737     collectionOfCategories notNil ifTrue:[
  2738         "/
  2739         "/ documentation first (if any), but not the version method
  2740         "/
  2741         (collectionOfCategories includes:'documentation') ifTrue:[
  2742             versionMethod := meta compiledMethodAt:#version.
  2743             versionMethod notNil ifTrue:[
  2744                 skippedMethods := Array with:versionMethod
  2745             ].
  2746             meta fileOutCategory:'documentation' except:skippedMethods only:nil methodFilter:methodFilter on:aStream.
  2747             aStream cr.
  2748         ].
  2749 
  2750         "/
  2751         "/ initialization next (if any)
  2752         "/
  2753         (collectionOfCategories includes:'initialization') ifTrue:[
  2754             meta fileOutCategory:'initialization' methodFilter:methodFilter on:aStream.
  2755             aStream cr.
  2756         ].
  2757 
  2758         "/
  2759         "/ instance creation next (if any)
  2760         "/
  2761         (collectionOfCategories includes:'instance creation') ifTrue:[
  2762             meta fileOutCategory:'instance creation' methodFilter:methodFilter on:aStream.
  2763             aStream cr.
  2764         ].
  2765         collectionOfCategories do:[:aCategory |
  2766             ((aCategory ~= 'documentation')
  2767             and:[(aCategory ~= 'initialization')
  2768             and:[aCategory ~= 'instance creation']]) ifTrue:[
  2769                 meta fileOutCategory:aCategory methodFilter:methodFilter on:aStream.
  2770                 aStream cr
  2771             ]
  2772         ]
  2773     ].
  2774 
  2775     "/
  2776     "/ methods from all categories in myself
  2777     "/
  2778     collectionOfCategories := self categories asSortedCollection.
  2779     collectionOfCategories notNil ifTrue:[
  2780         collectionOfCategories do:[:aCategory |
  2781             self fileOutCategory:aCategory methodFilter:methodFilter on:aStream.
  2782             aStream cr
  2783         ]
  2784     ].
  2785 
  2786     "/
  2787     "/ any private classes' methods
  2788     "/
  2789     self privateClassesSorted do:[:aClass |
  2790         aClass fileOutAllMethodsOn:aStream methodFilter:methodFilter
  2791     ].
  2792 
  2793 
  2794     "/
  2795     "/ finally, the previously skipped version method
  2796     "/
  2797     versionMethod notNil ifTrue:[
  2798         meta fileOutCategory:'documentation' except:nil only:skippedMethods methodFilter:methodFilter on:aStream.
  2799     ].
  2800 
  2801     initIt ifTrue:[
  2802         "/
  2803         "/ optionally an initialize message
  2804         "/
  2805         (meta implements:#initialize) ifTrue:[
  2806             self printClassNameOn:aStream. aStream nextPutAll:' initialize'.
  2807             aStream nextPutChunkSeparator.
  2808             aStream cr
  2809         ]
  2810     ]
  2811 
  2812     "Created: / 15.11.1995 / 12:53:06 / cg"
  2813     "Modified: / 1.4.1997 / 16:01:05 / stefan"
  2814     "Modified: / 13.3.1998 / 12:23:59 / cg"
  2815 !
  2816 
  2817 fileOutPrimitiveDefinitionsOn:aStream
  2818     "append primitive defs (if any) to aStream."
  2819 
  2820     |s|
  2821 
  2822     "
  2823      primitive definitions - if any
  2824     "
  2825     (s := self primitiveDefinitionsString) notNil ifTrue:[
  2826         aStream nextPutChunkSeparator.
  2827         self printClassNameOn:aStream.
  2828         aStream nextPutAll:' primitiveDefinitions';
  2829                 nextPutChunkSeparator;
  2830                 cr.
  2831         aStream nextPutAll:s.
  2832         aStream nextPutChunkSeparator; space; nextPutChunkSeparator; cr; cr
  2833     ].
  2834     (s := self primitiveVariablesString) notNil ifTrue:[
  2835         aStream nextPutChunkSeparator.
  2836         self printClassNameOn:aStream.
  2837         aStream nextPutAll:' primitiveVariables';
  2838                 nextPutChunkSeparator;
  2839                 cr.
  2840         aStream nextPutAll:s.
  2841         aStream nextPutChunkSeparator; space; nextPutChunkSeparator; cr; cr
  2842     ].
  2843 
  2844     "Modified: 8.1.1997 / 17:45:40 / cg"
  2845 !
  2846 
  2847 fileOutPrimitiveSpecsOn:aStream
  2848     "append primitive defs (if any) to aStream."
  2849 
  2850     |s|
  2851 
  2852     "
  2853      primitive definitions - if any
  2854     "
  2855     self fileOutPrimitiveDefinitionsOn:aStream.
  2856     "
  2857      primitive functions - if any
  2858     "
  2859     (s := self primitiveFunctionsString) notNil ifTrue:[
  2860         aStream nextPutChunkSeparator.
  2861         self printClassNameOn:aStream.
  2862         aStream nextPutAll:' primitiveFunctions';
  2863                 nextPutChunkSeparator;
  2864                 cr.
  2865         aStream nextPutAll:s.
  2866         aStream nextPutChunkSeparator; space; nextPutChunkSeparator; cr; cr
  2867     ].
  2868 
  2869     "Modified: 8.1.1997 / 17:45:51 / cg"
  2870 !
  2871 
  2872 firstDefinitionSelectorPart
  2873     "return the first part of the selector with which I was (can be) defined in my superclass"
  2874 
  2875     self isVariable ifFalse:[
  2876         ^ #'subclass:'
  2877     ].
  2878     self isBytes ifTrue:[
  2879         ^ #'variableByteSubclass:'
  2880     ].
  2881     self isLongs ifTrue:[
  2882         ^ #'variableLongSubclass:'
  2883     ].
  2884     self isFloats ifTrue:[
  2885         ^ #'variableFloatSubclass:'
  2886     ].
  2887     self isDoubles ifTrue:[
  2888         ^ #'variableDoubleSubclass:'
  2889     ].
  2890     self isWords ifTrue:[
  2891         ^ #'variableWordSubclass:'
  2892     ].
  2893     self isSignedWords ifTrue:[
  2894         ^ #'variableSignedWordSubclass:'
  2895     ].
  2896     self isSignedLongs ifTrue:[
  2897         ^ #'variableSignedLongSubclass:'
  2898     ].
  2899     self isSignedLongLongs ifTrue:[
  2900         ^ #'variableSignedLongLongSubclass:'
  2901     ].
  2902     self isLongLongs ifTrue:[
  2903         ^ #'variableLongLongSubclass:'
  2904     ].
  2905     ^ #'variableSubclass:'
  2906 !
  2907 
  2908 getPrimitiveSpecsAt:index
  2909     "{ Pragma: +optSpace }"
  2910 
  2911     "return a primitiveSpecification component as string or nil"
  2912 
  2913     |owner pos stream string primitiveSpec classFilename|
  2914 
  2915     (owner := self owningClass) notNil ifTrue:[^ owner getPrimitiveSpecsAt:index].
  2916 
  2917     primitiveSpec := self primitiveSpec.
  2918 
  2919     primitiveSpec isNil ifTrue:[^ nil].
  2920     pos := primitiveSpec at:index.
  2921     pos isNil ifTrue:[^ nil].
  2922 
  2923     "the primitiveSpec is either a string, or an integer specifying the
  2924      position within the classes sourcefile ...
  2925     "
  2926     pos isNumber ifTrue:[
  2927         classFilename := self classFilename.
  2928         classFilename notNil ifTrue:[
  2929             stream := self sourceStream. 
  2930             stream notNil ifTrue:[
  2931                 stream position:pos+1.
  2932                 string := stream nextChunk.
  2933                 stream close.
  2934                 ^ string
  2935             ]
  2936         ].
  2937         ^ nil
  2938     ].
  2939     ^ pos
  2940 
  2941     "Modified: 15.1.1997 / 15:29:30 / stefan"
  2942 !
  2943 
  2944 hasMethods
  2945     "return true, if there are any (local) methods in this class"
  2946 
  2947     ^ (self methodDictionary size ~~ 0)
  2948 !
  2949 
  2950 implements:aSelector
  2951     ^ self includesSelector:aSelector
  2952 !
  2953 
  2954 includesSelector:aSelector
  2955     ^ self methodDictionary includesKey:aSelector
  2956 !
  2957 
  2958 instanceVariableString
  2959     "return a string of the instance variable names"
  2960 
  2961     |instvars|
  2962 
  2963     instvars := self instVarNames.
  2964     instvars isNil ifTrue:[^ ''].
  2965     instvars isString ifTrue:[
  2966         ^ instvars
  2967     ].
  2968 
  2969     ^ instvars asStringWith:(Character space)
  2970 
  2971     "
  2972      Point instanceVariableString   
  2973     "
  2974 
  2975     "Modified: 22.8.1997 / 14:59:14 / cg"
  2976 !
  2977 
  2978 isObsolete 
  2979     "return true, if the receiver is obsolete 
  2980      (i.e. has been replaced by a different class or was removed, 
  2981       but is still referenced by instanced)"
  2982 
  2983     |cat|
  2984 
  2985     cat := self category.
  2986 
  2987     ^ cat = 'obsolete' 
  2988       or:[cat = 'removed'
  2989       or:[cat = '* removed *'
  2990       or:[cat = '* obsolete *']]]
  2991 !
  2992 
  2993 isSubclassOf:aClass
  2994     "return true, if I am a subclass of the argument, aClass"
  2995 
  2996     |theClass|
  2997 
  2998     theClass := self superclass.
  2999     [theClass notNil] whileTrue:[
  3000         (theClass == aClass) ifTrue:[^ true].
  3001         theClass := theClass superclass.
  3002     ].
  3003     ^ false
  3004 !
  3005 
  3006 localSourceStreamFor:sourceFile
  3007     "return an open stream on a local sourcefile, nil if that is not available"
  3008 
  3009     |fileName info module dir fn package packageDir zar entry|
  3010 
  3011     "/
  3012     "/ old: look in 'source/<filename>'
  3013     "/ this is still kept in order to find user-private
  3014     "/ classes in her currentDirectory.
  3015     "/
  3016     fileName := Smalltalk getSourceFileName:sourceFile.
  3017     fileName notNil ifTrue:[
  3018         ^ fileName asFilename readStream.
  3019     ].
  3020 
  3021     (package := self package) notNil ifTrue:[
  3022         "/ newest sceme ...
  3023         packageDir := package copyReplaceAll:$: with:$/.
  3024         packageDir := Smalltalk getPackageFileName:packageDir.
  3025         packageDir notNil ifTrue:[
  3026             "/ present there ?
  3027             packageDir := packageDir asFilename.
  3028             (fn := packageDir construct:sourceFile) exists ifTrue:[
  3029                 ^ fn readStream.
  3030             ].
  3031 
  3032             "/ a source subdirectory ?
  3033             fn := (packageDir construct:'source') construct:sourceFile.
  3034             fn exists ifTrue:[
  3035                 ^ fn readStream.
  3036             ].
  3037 
  3038             "/ a zip-file ?
  3039             fn := (packageDir construct:'source.zip').
  3040             fn exists ifTrue:[
  3041                 zar := ZipArchive oldFileNamed:fn.
  3042                 zar notNil ifTrue:[
  3043                     entry := zar extract:sourceFile.
  3044                     entry notNil ifTrue:[
  3045                         ^ entry asString readStream
  3046                     ]
  3047                 ]
  3048             ]
  3049         ].
  3050 
  3051         "/ will vanish ...
  3052         (package includes:$:) ifTrue:[
  3053             package := package asString copyReplaceAll:$: with:$/
  3054         ] ifFalse:[
  3055             package := 'stx/' , package
  3056         ].
  3057         fileName := Smalltalk getSourceFileName:(package , '/' , sourceFile).
  3058         fileName notNil ifTrue:[
  3059             ^ fileName asFilename readStream.
  3060         ].
  3061         (package startsWith:'stx/') ifTrue:[
  3062             fileName := Smalltalk getSourceFileName:((package copyFrom:5) , '/' , sourceFile).
  3063             fileName notNil ifTrue:[
  3064                 ^ fileName asFilename readStream.
  3065             ]
  3066         ]
  3067     ].
  3068 
  3069     "/
  3070     "/ new: look in 'source/<module>/<package>/<filename>
  3071     "/ this makes the symbolic links to (or copy of) the source files
  3072     "/ obsolete.
  3073     info := self packageSourceCodeInfo.
  3074     info notNil ifTrue:[
  3075         module := info at:#module ifAbsent:nil.
  3076         module notNil ifTrue:[
  3077             dir := info at:#directory ifAbsent:nil.
  3078             dir notNil ifTrue:[
  3079                 fn := (module asFilename construct:dir) construct:sourceFile.
  3080                 fileName := Smalltalk getSourceFileName:(fn name).
  3081                 fileName notNil ifTrue:[
  3082                     ^ fileName asFilename readStream.
  3083                 ].
  3084 
  3085                 "/ brand new: look for source/<module>/package.zip
  3086                 "/ containing an entry for <filename>
  3087 
  3088                 fn := (module asFilename construct:dir) withSuffix:'zip'.
  3089                 fileName := Smalltalk getSourceFileName:(fn name).
  3090                 fileName notNil ifTrue:[
  3091                     zar := ZipArchive oldFileNamed:fileName.
  3092                     zar notNil ifTrue:[
  3093                         entry := zar extract:sourceFile.
  3094                         entry notNil ifTrue:[
  3095                             ^ entry asString readStream
  3096                         ]
  3097                     ]
  3098                 ].
  3099 
  3100                 "/ and also in source/source.zip ...
  3101 
  3102                 fileName := Smalltalk getSourceFileName:'source.zip'.
  3103                 fileName notNil ifTrue:[
  3104                     zar := ZipArchive oldFileNamed:fileName.
  3105                     zar notNil ifTrue:[
  3106                         entry := zar extract:sourceFile.
  3107                         entry notNil ifTrue:[
  3108                             ^ entry asString readStream
  3109                         ]
  3110                     ]
  3111                 ].
  3112             ]
  3113         ]
  3114     ].
  3115     ^ nil
  3116 
  3117     "Modified: / 18.7.1998 / 22:53:19 / cg"
  3118 !
  3119 
  3120 lookupMethodFor:aSelector
  3121     "return the method, which would be executed if aSelector was sent to
  3122      an instance of the receiver. I.e. the selector arrays of the receiver
  3123      and all of its superclasses are searched for aSelector.
  3124      Return the method, or nil if instances do not understand aSelector.
  3125      EXPERIMENTAL: take care of multiple superclasses."
  3126 
  3127     |m cls|
  3128 
  3129     cls := self.
  3130     [cls notNil] whileTrue:[
  3131         m := cls compiledMethodAt:aSelector.
  3132         m notNil ifTrue:[^ m].
  3133         cls := cls superclass
  3134     ].
  3135     ^ nil
  3136 !
  3137 
  3138 nameWithoutNameSpacePrefix
  3139     |nm owner|
  3140 
  3141     nm := self nameWithoutPrefix.
  3142     (owner := self owningClass) isNil ifTrue:[
  3143         ^ nm
  3144     ].
  3145 
  3146     ^ (owner nameWithoutNameSpacePrefix , '::' , nm)
  3147 !
  3148 
  3149 nameWithoutPrefix
  3150     |nm idx|
  3151 
  3152     nm := self name.
  3153     idx := nm lastIndexOf:$:.
  3154     idx == 0 ifTrue:[
  3155         ^ nm
  3156     ].
  3157     ^ nm copyFrom:idx+1.
  3158 !
  3159 
  3160 packageSourceCodeInfo
  3161     "{ Pragma: +optSpace }"
  3162 
  3163     "return the sourceCodeInfo, which defines the module and the subdirectory
  3164      in which the receiver class was built. 
  3165      This info is extracted from the package id (which is added to stc-compiled classes).
  3166      This method is to be obsoleted soon, since the same info is now found
  3167      in the versionString.
  3168 
  3169      The info returned consists of a dictionary
  3170      filled with (at least) values at: #module, #directory and #library.
  3171      If no such info is present in the class, nil is returned.
  3172      (this happens with autoloaded and filed-in classes)
  3173      Auotloaded classes set their package from the revisionInfo, if present.
  3174 
  3175      By convention, this info is encoded in the classes package
  3176      string (which is given as argument to stc) as the last word in parenthesis. 
  3177      The info consists of 1 to 3 subcomponents, separated by colons.
  3178      The first defines the classes module (i.e. some application identifier), 
  3179      the second defines the subdirectory within that module, the third
  3180      defines the name of the class library. 
  3181      If left blank, the module info defaults to 'stx',
  3182      the directory info defaults to library name.
  3183      The library name may not be left blank.
  3184      (this is done for backward compatibility,)
  3185 
  3186      For example: 
  3187         '....(libbasic)'                         -> module: stx directory: libbasic library: libbasic
  3188         '....(stx:libbasic)'                     -> module: stx directory: libbasic library: libbasic
  3189         '....(stx:foo:libbfoo)'                  -> module: stx directory: foo library: libfoo
  3190         '....(aeg:libIECInterface)'              -> module: aeg directory: libIECInterface library:libIECInterface
  3191         '....(stx:goodies/persistency:libdbase)' -> module: stx directory: goodies/persistency library:libdbase 
  3192 
  3193      The way how the sourceCodeManager uses this to find the source location
  3194      depends on the scheme used. For CVS, the module is taken as the -d arg,
  3195      while the directory is prepended to the file name.
  3196      Other schemes may do things differently - these are not yet specified.
  3197 
  3198      Caveat:
  3199         Encoding this info in the package string seems somewhat kludgy.
  3200     "
  3201 
  3202     |owner sourceInfo packageString idx1 idx2 
  3203      moduleString directoryString libraryString components component1 component2 dirComponents mgr
  3204      package|
  3205 
  3206     (owner := self owningClass) notNil ifTrue:[^ owner packageSourceCodeInfo].
  3207 
  3208     package := self package.
  3209     package isNil ifTrue:[^ nil].
  3210 
  3211     packageString := package asString.
  3212     idx1 := packageString lastIndexOf:$(.
  3213     idx1 ~~ 0 ifTrue:[
  3214         idx2 := packageString indexOf:$) startingAt:idx1+1.
  3215         idx2 ~~ 0 ifTrue:[
  3216             sourceInfo := packageString copyFrom:idx1 + 1 to:idx2 - 1
  3217         ]
  3218     ] ifFalse:[
  3219         sourceInfo := packageString
  3220     ].
  3221 
  3222     sourceInfo isNil ifTrue:[^ nil].
  3223     components := sourceInfo asCollectionOfSubstringsSeparatedBy:$:.
  3224     components size == 0 ifTrue:[
  3225 "/        moduleString := 'stx'.
  3226 "/        directoryString := libraryString := ''.
  3227         ^ nil
  3228     ].
  3229 
  3230     component1 := components at:1.
  3231     components size == 1 ifTrue:[
  3232         "/ a single name given - the module becomes 'stx' or
  3233         "/ the very first directory component (if such a module exists).
  3234         "/ If the component includes slashes, its the directory
  3235         "/ otherwise the library.
  3236         "/ 
  3237         dirComponents := Filename concreteClass components:component1.     
  3238         (dirComponents size > 1
  3239         and:[(mgr := self sourceCodeManager) notNil
  3240         and:[mgr checkForExistingModule:dirComponents first]]) ifTrue:[
  3241             moduleString := dirComponents first.
  3242             directoryString := libraryString := (Filename fromComponents:(dirComponents copyFrom:2)) asString.
  3243         ] ifFalse:[
  3244             "/ non-existing; assume directory under the stx package.
  3245             moduleString := 'stx'.
  3246             (component1 startsWith:'stx/') ifTrue:[
  3247                 component1 := component1 copyFrom:5
  3248             ].
  3249             directoryString := libraryString := component1.
  3250         ].
  3251 
  3252         (libraryString includes:$/) ifTrue:[
  3253             libraryString := libraryString asFilename baseName
  3254         ]
  3255     ] ifFalse:[
  3256         component2 := components at:2.
  3257         components size == 2 ifTrue:[
  3258             "/ two components - assume its the module and the directory; 
  3259             "/ the library is assumed to be named after the directory
  3260             "/ except, if slashes are in the name; then the libraryname
  3261             "/ is the last component.
  3262             "/
  3263             moduleString := component1.
  3264             directoryString := libraryString := component2.
  3265             (libraryString includes:$/) ifTrue:[
  3266                 libraryString := libraryString asFilename baseName
  3267             ]
  3268         ] ifFalse:[
  3269             "/ all components given
  3270             moduleString := component1.
  3271             directoryString := component2.
  3272             libraryString := components at:3.
  3273         ]
  3274     ].
  3275 
  3276     libraryString isEmpty ifTrue:[
  3277         directoryString notEmpty ifTrue:[
  3278             libraryString := directoryString asFilename baseName
  3279         ].
  3280         libraryString isEmpty ifTrue:[
  3281             "/ lets extract the library from the liblist file ...
  3282             libraryString := Smalltalk libraryFileNameOfClass:self.
  3283             libraryString isNil ifTrue:[^ nil].
  3284         ]
  3285     ].
  3286 
  3287     moduleString isEmpty ifTrue:[
  3288         moduleString := 'stx'.
  3289     ].
  3290     directoryString isEmpty ifTrue:[
  3291         directoryString := libraryString.
  3292     ].
  3293 
  3294     ^ IdentityDictionary
  3295         with:(#module->moduleString)
  3296         with:(#directory->directoryString)
  3297         with:(#library->libraryString)
  3298 
  3299     "
  3300      Object packageSourceCodeInfo     
  3301      View packageSourceCodeInfo    
  3302      Model packageSourceCodeInfo  
  3303      BinaryObjectStorage packageSourceCodeInfo  
  3304      MemoryMonitor packageSourceCodeInfo  
  3305      ClockView packageSourceCodeInfo  
  3306     "
  3307 
  3308     "Created: 4.11.1995 / 20:36:53 / cg"
  3309     "Modified: 19.9.1997 / 10:42:25 / cg"
  3310 !
  3311 
  3312 primitiveDefinitionsString
  3313     "{ Pragma: +optSpace }"
  3314 
  3315     "return the primitiveDefinition string or nil"
  3316 
  3317     ^ self getPrimitiveSpecsAt:1
  3318 
  3319     "
  3320      Object primitiveDefinitionsString 
  3321      String primitiveDefinitionsString
  3322     "
  3323 !
  3324 
  3325 primitiveFunctionsString
  3326     "{ Pragma: +optSpace }"
  3327 
  3328     "return the primitiveFunctions string or nil"
  3329 
  3330     ^ self getPrimitiveSpecsAt:3
  3331 !
  3332 
  3333 primitiveVariablesString
  3334     "{ Pragma: +optSpace }"
  3335 
  3336     "return the primitiveVariables string or nil"
  3337 
  3338     ^ self getPrimitiveSpecsAt:2
  3339 !
  3340 
  3341 printClassNameOn:aStream
  3342     |nm|
  3343 
  3344     Class fileOutNameSpaceQuerySignal query == false ifTrue:[
  3345         nm := self nameWithoutNameSpacePrefix
  3346     ] ifFalse:[
  3347         nm := self name.
  3348     ].
  3349 
  3350     aStream nextPutAll:nm.
  3351 !
  3352 
  3353 printClassVarNamesOn:aStream indent:indent
  3354     "print the class variable names indented and breaking at line end"
  3355 
  3356     self printNameArray:(self classVarNames) on:aStream indent:indent
  3357 !
  3358 
  3359 printHierarchyAnswerIndentOn:aStream
  3360     "print my class hierarchy on aStream - return indent
  3361      recursively calls itself to print superclass and use returned indent
  3362      for my description - used in the browser"
  3363 
  3364     |indent nm superclass|
  3365 
  3366     superclass := self superclass.
  3367     indent := 0.
  3368     (superclass notNil) ifTrue:[
  3369         indent := (superclass printHierarchyAnswerIndentOn:aStream) + 2
  3370     ].
  3371     aStream spaces:indent.
  3372     nm := self printNameInHierarchy.
  3373     aStream nextPutAll:nm; nextPutAll:' ('.
  3374     self printInstVarNamesOn:aStream indent:(indent + nm size + 2).
  3375     aStream nextPutLine:')'.
  3376     ^ indent
  3377 !
  3378 
  3379 printHierarchyOn:aStream
  3380     self printHierarchyAnswerIndentOn:aStream
  3381 !
  3382 
  3383 printInstVarNamesOn:aStream indent:indent
  3384     "print the instance variable names indented and breaking at line end"
  3385 
  3386     self printNameArray:(self instVarNames) on:aStream indent:indent
  3387 
  3388     "Created: 22.3.1997 / 14:12:00 / cg"
  3389 !
  3390 
  3391 printNameArray:anArray on:aStream indent:indent
  3392     "print an array of strings separated by spaces; when the stream
  3393      defines a lineLength, break when this limit is reached; indent
  3394      every line; used to printOut instance variable names"
  3395 
  3396     |thisName nextName arraySize lenMax pos mustBreak line spaces|
  3397 
  3398     arraySize := anArray size.
  3399     arraySize ~~ 0 ifTrue:[
  3400         pos := indent.
  3401         lenMax := aStream lineLength.
  3402         thisName := anArray at:1.
  3403         line := ''.
  3404         1 to:arraySize do:[:index |
  3405             line := line , thisName.
  3406             pos := pos + thisName size.
  3407             (index == arraySize) ifFalse:[
  3408                 nextName := anArray at:(index + 1).
  3409                 mustBreak := false.
  3410                 (lenMax > 0) ifTrue:[
  3411                     ((pos + nextName size) > lenMax) ifTrue:[
  3412                         mustBreak := true
  3413                     ]
  3414                 ].
  3415                 mustBreak ifTrue:[
  3416                     aStream nextPutLine:line withTabs.
  3417                     spaces isNil ifTrue:[
  3418                         spaces := String new:indent
  3419                     ].
  3420                     line := spaces.
  3421                     pos := indent
  3422                 ] ifFalse:[
  3423                     line := line , ' '.
  3424                     pos := pos + 1
  3425                 ].
  3426                 thisName := nextName
  3427             ]
  3428         ].
  3429         aStream nextPutAll:line withTabs
  3430     ]
  3431 
  3432     "Modified: 9.11.1996 / 00:12:06 / cg"
  3433     "Created: 22.3.1997 / 14:12:12 / cg"
  3434 !
  3435 
  3436 printNameInHierarchy
  3437     ^ self name
  3438 !
  3439 
  3440 privateClasses
  3441     "{ Pragma: +optSpace }"
  3442 
  3443     "return a collection of my private classes (if any).
  3444      The classes are in any order."
  3445 
  3446     ^ self privateClassesOrAll:false
  3447 !
  3448 
  3449 privateClassesAt:aClassNameStringOrSymbol
  3450     |nmSym|
  3451 
  3452     nmSym := (self name , '::' , aClassNameStringOrSymbol) asSymbolIfInterned.
  3453     nmSym isNil ifTrue:[
  3454         "/ no such symbol - there cannot be a corresponding private class
  3455         ^ nil
  3456     ].
  3457 
  3458     ^ memory image at:nmSym.
  3459 !
  3460 
  3461 privateClassesOrAll:allOfThem
  3462     "{ Pragma: +optSpace }"
  3463 
  3464     "return a collection of my direct private classes (if any)
  3465      or direct plus indirect private classes (if allOfThem).
  3466      An empty collection if there are none.
  3467      The classes are in any order."
  3468 
  3469     |classes myName myNamePrefix myNamePrefixLen|
  3470 
  3471     myName := self name.
  3472     myNamePrefix := myName , '::'.
  3473     myNamePrefixLen := myNamePrefix size.
  3474 
  3475     memory image keysDo:[:nm |
  3476         |cls|
  3477 
  3478         (nm startsWith:myNamePrefix) ifTrue:[
  3479             (allOfThem
  3480             or:[(nm indexOf:$: startingAt:myNamePrefixLen + 1) == 0]) ifTrue:[
  3481                 cls := memory image at:nm.
  3482 
  3483                 (cls isBehavior and:[cls isMeta not]) ifTrue:[
  3484                     classes isNil ifTrue:[
  3485                         classes := IdentitySet new:10.
  3486                     ].
  3487                     classes add:cls.
  3488                 ]
  3489             ]
  3490         ]
  3491     ].
  3492 
  3493     ^ classes ? #()
  3494 
  3495     "
  3496      UILayoutTool privateClassesOrAll:true 
  3497      UILayoutTool privateClassesOrAll:false 
  3498     "
  3499 
  3500     "Modified: / 29.5.1998 / 23:23:18 / cg"
  3501 !
  3502 
  3503 privateClassesSorted
  3504     "{ Pragma: +optSpace }"
  3505 
  3506     "return a collection of my private classes (if any).
  3507      The classes are sorted by inheritance."
  3508 
  3509     |classes|
  3510 
  3511     classes := self privateClasses.
  3512     (classes size > 0) ifTrue:[
  3513         classes := classes asOrderedCollection topologicalSort:[:a :b | b isSubclassOf:a].
  3514     ].
  3515     ^ classes.
  3516 
  3517     "
  3518      Object privateClassesSorted
  3519     "
  3520 
  3521     "Created: 22.3.1997 / 16:10:42 / cg"
  3522     "Modified: 22.3.1997 / 16:11:20 / cg"
  3523 !
  3524 
  3525 revisionInfo
  3526     "return a dictionary filled with revision info.
  3527      This extracts the relevant info from the revisionString.
  3528      The revisionInfo contains all or a subset of:
  3529         #binaryRevision - the revision upon which the binary of this class is based
  3530         #revision       - the revision upon which the class is based logically
  3531                           (different, if a changed class was checked in, but not yet recompiled)
  3532         #user           - the user who checked in the logical revision
  3533         #date           - the date when the logical revision was checked in
  3534         #time           - the time when the logical revision was checked in
  3535         #fileName       - the classes source file name
  3536         #repositoryPath - the classes source container
  3537     "
  3538 
  3539     |vsnString info mgr|
  3540 
  3541     vsnString := self revisionString.
  3542     vsnString notNil ifTrue:[
  3543         mgr := self sourceCodeManager.
  3544         mgr notNil ifTrue:[
  3545             info := mgr revisionInfoFromString:vsnString
  3546         ] ifFalse:[
  3547             info := Class revisionInfoFromString:vsnString.
  3548         ].
  3549         info notNil ifTrue:[
  3550             info at:#binaryRevision put:self binaryRevision.
  3551         ]
  3552     ].
  3553     ^ info
  3554 !
  3555 
  3556 revisionString
  3557     "{ Pragma: +optSpace }"
  3558 
  3559     "return my revision string; that one is extracted from the
  3560      classes #version method. Either this is a method returning that string,
  3561      or its a comment-only method and the comment defines the version.
  3562      If the source is not accessable or no such method exists,
  3563      nil is returned."
  3564 
  3565     |owner cls meta m src val|
  3566 
  3567     (owner := self owningClass) notNil ifTrue:[^ owner revisionString].
  3568 
  3569     thisContext isRecursive ifTrue:[^ nil ].
  3570 
  3571     self isMeta ifTrue:[
  3572         meta := self. cls := self soleInstance
  3573     ] ifFalse:[
  3574         cls := self. meta := self classRef
  3575     ].
  3576 
  3577     m := meta compiledMethodAt:#version.
  3578     m isNil ifTrue:[
  3579         m := cls compiledMethodAt:#version.
  3580         m isNil ifTrue:[^ nil].
  3581     ].
  3582 
  3583     m isExecutable ifTrue:[
  3584         "/
  3585         "/ if its a method returning the string,
  3586         "/ thats the returned value
  3587         "/
  3588         val := cls version.
  3589         val isString ifTrue:[^ val].
  3590     ].
  3591 
  3592     "/
  3593     "/ if its a method consisting of a comment only
  3594     "/ extract it - this may lead to a recursive call
  3595     "/ to myself (thats what the #isRecursive is for)
  3596     "/ in case we need to access the source code manager
  3597     "/ for the source ...
  3598     "/
  3599     src := m source.
  3600     src isNil ifTrue:[^ nil].
  3601     ^ Class revisionStringFromSource:src 
  3602 
  3603     "
  3604      Smalltalk allClassesDo:[:cls |
  3605         Transcript showCR:cls revisionString
  3606      ].
  3607 
  3608      Number revisionString  
  3609      FileDirectory revisionString
  3610      Metaclass revisionString
  3611     "
  3612 
  3613     "Created: 29.10.1995 / 19:28:03 / cg"
  3614     "Modified: 23.10.1996 / 18:23:56 / cg"
  3615     "Modified: 1.4.1997 / 23:37:25 / stefan"
  3616 !
  3617 
  3618 selectorAtMethod:aMethod
  3619     ^ self selectorAtMethod:aMethod ifAbsent:[nil]
  3620 !
  3621 
  3622 selectorAtMethod:aMethod ifAbsent:failBlock
  3623     |md|
  3624 
  3625     md := self methodDictionary.
  3626     md isNil ifTrue:[
  3627         'OOPS - nil methodDictionary' errorPrintCR.
  3628         ^ nil
  3629     ].
  3630     ^ md keyAtValue:aMethod ifAbsent:failBlock.
  3631 !
  3632 
  3633 soleInstance
  3634     self isMeta ifFalse:[self halt].
  3635     ^ self theNonMetaclass.
  3636 !
  3637 
  3638 sourceCodeManager
  3639     ^ SourceCodeManager
  3640 !
  3641 
  3642 sourceStreamFor:source
  3643     "return an open stream on a sourcefile, nil if that is not available"
  3644 
  3645     |owner fileName aStream mgr validated guessedFileName sep mod dir classFilename package name|
  3646 
  3647     self isMeta ifTrue:[
  3648         ^ self theNonMetaclass sourceStreamFor:source
  3649     ].
  3650 
  3651     (owner := self owningClass) notNil ifTrue:[^ owner sourceStreamFor:source].
  3652     validated := false.
  3653 
  3654     classFilename := self classFilename.
  3655     package := self package.
  3656     name := self name.
  3657 
  3658     "/
  3659     "/ if there is no SourceCodeManager, 
  3660     "/ or TryLocalSourceFirst is true,
  3661     "/ look in standard places first
  3662     "/
  3663     ((mgr := self sourceCodeManager) isNil 
  3664     or:[Class tryLocalSourceFirst == true]) ifTrue:[
  3665         aStream := self localSourceStreamFor:source.
  3666     ].
  3667 
  3668     aStream isNil ifTrue:[
  3669         "/ mhmh - still no source file.
  3670         "/ If there is a SourceCodeManager, ask it to aquire the
  3671         "/ the source for my class, and return an open stream on it. 
  3672         "/ if that one does not know about the source, look in
  3673         "/ standard places
  3674 
  3675         mgr notNil ifTrue:[
  3676             self classFilename ~= source ifTrue:[
  3677                 sep := self package indexOfAny:'/\:'.
  3678                 sep ~~ 0 ifTrue:[
  3679                     mod := package copyTo:sep - 1.
  3680                     dir := package copyFrom:sep + 1.
  3681                     aStream := mgr streamForClass:nil fileName:source revision:nil directory:dir module:mod cache:true.
  3682                 ].
  3683             ].
  3684             aStream isNil ifTrue:[
  3685                 classFilename isNil ifTrue:[
  3686                     classFilename := guessedFileName := (Smalltalk fileNameForClass:self) , '.st'.
  3687                 ].
  3688                 source asFilename baseName = classFilename asFilename baseName ifTrue:[
  3689                     aStream := mgr getSourceStreamFor:self.
  3690                 ]
  3691             ].
  3692             aStream notNil ifTrue:[
  3693                 (self validateSourceStream:aStream) ifFalse:[
  3694                     ('Class [info]: repositories source for `' 
  3695                      , (self isMeta ifTrue:[self soleInstance name]
  3696                                     ifFalse:[name])
  3697                      , ''' is invalid.') infoPrintCR.
  3698                     aStream close.
  3699                     aStream := nil
  3700                 ] ifTrue:[
  3701                     validated := true.
  3702                 ].
  3703             ].
  3704         ]
  3705     ].
  3706 
  3707     aStream isNil ifTrue:[
  3708         "/      
  3709         "/ hard case - there is no source file for this class
  3710         "/ (in the source-dir-path).
  3711         "/      
  3712 
  3713         "/      
  3714         "/ look if my binary is from a dynamically loaded module,
  3715         "/ and, if so, look in the modules directory for the
  3716         "/ source file.
  3717         "/      
  3718         ObjectFileLoader notNil ifTrue:[
  3719             ObjectFileLoader loadedObjectHandlesDo:[:h |
  3720                 |f classes|
  3721 
  3722                 aStream isNil ifTrue:[
  3723                     (classes := h classes) size > 0 ifTrue:[
  3724                         (classes includes:self) ifTrue:[
  3725                             f := h pathName.
  3726                             f := f asFilename directory.
  3727                             f := f construct:source.
  3728                             f exists ifTrue:[
  3729                                 aStream := f readStream.
  3730                             ].
  3731                         ].
  3732                     ].
  3733                 ]
  3734             ].
  3735         ].
  3736     ].
  3737 
  3738     "/
  3739     "/ try along sourcePath
  3740     "/
  3741     aStream isNil ifTrue:[
  3742         aStream := self localSourceStreamFor:source.
  3743     ].
  3744 
  3745     "/
  3746     "/ final chance: try current directory
  3747     "/
  3748     aStream isNil ifTrue:[
  3749         aStream := source asFilename readStream.
  3750     ].
  3751 
  3752     (aStream notNil and:[validated not]) ifTrue:[
  3753         (self validateSourceStream:aStream) ifFalse:[
  3754             (Smalltalk releaseIdentification = 'ST/X_free_demo_vsn') ifTrue:[
  3755 "/                ('Class [info]: source for ''' , self name , ''' is not available in the demo version.') infoPrintCR
  3756             ] ifFalse:[
  3757                 ('Class [warning]: source for ''' , self name , ''' is invalid or stripped. Take care.') errorPrintCR
  3758             ]
  3759         ].
  3760     ].
  3761     (aStream notNil and:[aStream isFileStream]) ifTrue:[
  3762         guessedFileName notNil ifTrue:[
  3763             classFilename := aStream pathName asFilename baseName.
  3764         ]
  3765     ].
  3766     ^ aStream
  3767 
  3768     "
  3769      Object sourceStream
  3770      Clock sourceStream
  3771      Autoload sourceStream
  3772     "
  3773 
  3774     "Created: / 10.11.1995 / 21:05:13 / cg"
  3775     "Modified: / 22.4.1998 / 19:20:50 / ca"
  3776     "Modified: / 23.4.1998 / 15:53:54 / cg"
  3777 !
  3778 
  3779 subclasses
  3780     "return a collection of the direct subclasses of the receiver"
  3781 
  3782     |newColl|
  3783 
  3784 "/    "/ use cached information (avoid class hierarchy search)
  3785 "/    "/ if possible
  3786 "/
  3787 "/    SubclassInfo notNil ifTrue:[
  3788 "/        newColl := SubclassInfo at:self ifAbsent:nil.
  3789 "/        newColl notNil ifTrue:[^ newColl asOrderedCollection]
  3790 "/    ].
  3791 
  3792     newColl := OrderedCollection new.
  3793     self subclassesDo:[:aClass |
  3794         newColl add:aClass
  3795     ].
  3796 "/    SubclassInfo notNil ifTrue:[
  3797 "/        SubclassInfo at:self put:newColl.
  3798 "/    ].
  3799     ^ newColl
  3800 !
  3801 
  3802 subclassesDo:aBlock
  3803     "evaluate the argument, aBlock for all immediate subclasses.
  3804      This will only enumerate globally known classes - for anonymous
  3805      behaviors, you have to walk over all instances of Behavior."
  3806 
  3807     |coll|
  3808 
  3809     self isMeta ifTrue:[
  3810         self halt.
  3811         "/ metaclasses are not found via Smalltalk allClassesDo:
  3812         "/ here, walk over classes and enumerate corresponding metas.
  3813         self soleInstance subclassesDo:[:aSubClass |
  3814             aBlock value:(aSubClass theMetaclass)
  3815         ].
  3816         ^ self
  3817     ].
  3818 
  3819     "/ use cached information (avoid class hierarchy search)
  3820     "/ if possible
  3821 
  3822 "/    SubclassInfo isNil ifTrue:[
  3823 "/        Behavior subclassInfo
  3824 "/    ].
  3825 "/    SubclassInfo notNil ifTrue:[
  3826 "/        coll := SubclassInfo at:self ifAbsent:nil.
  3827 "/        coll notNil ifTrue:[
  3828 "/            coll do:aBlock.
  3829 "/        ].
  3830 "/        ^ self
  3831 "/    ].
  3832 
  3833     Smalltalk allClassesDo:[:aClass |
  3834         (aClass superclass == self) ifTrue:[
  3835             aBlock value:aClass
  3836         ]
  3837     ]
  3838 
  3839     "
  3840      Collection subclassesDo:[:c | Transcript showCR:(c name)]
  3841     "
  3842 
  3843     "Modified: 22.1.1997 / 18:44:01 / cg"
  3844 !
  3845 
  3846 syntaxHighlighterClass
  3847     ^ Object syntaxHighlighterClass
  3848 !
  3849 
  3850 theMetaclass
  3851     self isMeta ifTrue:[^ self].
  3852     ^ self classRef.
  3853 !
  3854 
  3855 theNonMetaclass
  3856     |instSlotOffs clsPtr|
  3857 
  3858     self isMeta ifFalse:[^ self].
  3859     instSlotOffs := Metaclass instVarOffsetOf:'myClass'.
  3860     clsPtr := self at:instSlotOffs.
  3861     ^ memory fetchObjectAt:clsPtr.
  3862 !
  3863 
  3864 validateSourceStream:aStream
  3865     "check if aStream really contains my source.
  3866      This is done by checking the version methods return value
  3867      against the version string as contained in the version method"
  3868 
  3869     ^ true
  3870 !
  3871 
  3872 whichClassDefinesClassVar:aVariableName
  3873     "return the class which defines the class variable
  3874      named aVariableName. This method should not be used for
  3875      repeated searches (i.e. in the compiler/parser), since it creates
  3876      many throw away intermediate objects."
  3877 
  3878     |cls|
  3879 
  3880     cls := self.
  3881     [cls notNil] whileTrue:[
  3882         (cls classVarNames includes:aVariableName) ifTrue:[ ^ cls].
  3883         cls := cls superclass
  3884     ].
  3885     ^ nil
  3886 !
  3887 
  3888 whichClassIncludesSelector:aSelector
  3889     "return the class in the inheritance chain, which implements the method
  3890      for aSelector; return nil if none."
  3891 
  3892     |cls|
  3893 
  3894     cls := self.
  3895     [cls notNil] whileTrue:[
  3896         (cls includesSelector:aSelector) ifTrue:[^ cls].
  3897         cls := cls superclass
  3898     ].
  3899     ^ nil
  3900 !
  3901 
  3902 withAllSuperclasses
  3903     "return a collection containing the receiver and all
  3904      of the receivers accumulated superclasses"
  3905 
  3906     |aCollection theSuperClass|
  3907 
  3908     aCollection := OrderedCollection with:self.
  3909     theSuperClass := self superclass.
  3910     [theSuperClass notNil] whileTrue:[
  3911         aCollection add:theSuperClass.
  3912         theSuperClass := theSuperClass superclass
  3913     ].
  3914     ^ aCollection
  3915 !
  3916 
  3917 withAllSuperclassesDo:aBlock
  3918     |sc|
  3919 
  3920     aBlock value:self.
  3921     sc := self superclass.
  3922     sc notNil ifTrue:[
  3923         sc withAllSuperclassesDo:aBlock.
  3924     ]
  3925 ! !
  3926 
  3927 !SnapShotImageMemory::ImageClassObject methodsFor:'namespace protocol'!
  3928 
  3929 allClasses
  3930     |classes|
  3931 
  3932     classes := IdentitySet new.
  3933     self allClassesDo:[:aClass | classes add:aClass].
  3934     ^ classes
  3935 !
  3936 
  3937 allClassesDo:aBlock
  3938     |prefix|
  3939 
  3940     self isNameSpace ifFalse:[ self error ].
  3941     prefix := self name , '::'.
  3942 
  3943     memory image allClassesDo:[:cls |
  3944         (cls name startsWith:prefix) ifTrue:[
  3945             aBlock value:cls
  3946         ]
  3947     ]
  3948 !
  3949 
  3950 at:aKey
  3951     |fullName|
  3952 
  3953     aKey isString ifFalse:[
  3954         ^ super at:aKey
  3955     ].
  3956 
  3957     self isNameSpace ifFalse:[ self error:'namespace expected' ].
  3958     fullName := self name , '::' , aKey.
  3959     ^ memory image at:fullName asSymbol
  3960 ! !
  3961 
  3962 !SnapShotImageMemory::ImageClassObject methodsFor:'printing'!
  3963 
  3964 printOn:aStream
  3965     aStream nextPutAll:'img-'.
  3966     aStream nextPutAll:self name.
  3967 ! !
  3968 
  3969 !SnapShotImageMemory::ImageClassObject methodsFor:'queries'!
  3970 
  3971 categories
  3972     |newList|
  3973 
  3974     newList := Set new.
  3975     self methodDictionary do:[:aMethod |
  3976         |cat|
  3977 
  3978         cat := aMethod category.
  3979         cat isNil ifTrue:[
  3980             cat := '* no category *'
  3981         ].
  3982         newList add:cat
  3983     ].
  3984     ^ newList
  3985 !
  3986 
  3987 isBytes
  3988     ^ (self flags bitAnd:Behavior maskIndexType) == Behavior flagBytes.
  3989 !
  3990 
  3991 isDoubles
  3992     ^ (self flags bitAnd:Behavior maskIndexType) == Behavior flagDoubles.
  3993 !
  3994 
  3995 isFloats
  3996     ^ (self flags bitAnd:Behavior maskIndexType) == Behavior flagFloats.
  3997 !
  3998 
  3999 isImageBehavior
  4000     ^ true
  4001 !
  4002 
  4003 isLoaded
  4004     |superclass|
  4005 
  4006     superclass := self superclass.
  4007     superclass isNil ifTrue:[^ true].
  4008     ^ self superclass name ~= 'Autoload'
  4009 !
  4010 
  4011 isLongLongs
  4012     ^ (self flags bitAnd:Behavior maskIndexType) == Behavior flagLongLongs.
  4013 !
  4014 
  4015 isLongs
  4016     ^ (self flags bitAnd:Behavior maskIndexType) == Behavior flagLongs.
  4017 !
  4018 
  4019 isMeta
  4020     |clsName|
  4021 
  4022     thisContext isRecursive ifTrue:[^ false].
  4023     byteSize = (Metaclass instSize * 4 + 12) ifFalse:[^ false].
  4024 
  4025     clsName := classRef name.
  4026     ^ clsName = 'Metaclass' or:[clsName = 'PrivateMetaclass'].
  4027 
  4028 "/self halt.
  4029 "/    ^ self size == (Metaclass instSize).
  4030 !
  4031 
  4032 isNameSpace
  4033     "return true, if this is a nameSpace."
  4034 
  4035     |superclass|
  4036 
  4037     superclass := self superclass.
  4038     ^ superclass notNil
  4039       and:[ superclass name = 'NameSpace' ].
  4040 !
  4041 
  4042 isPrivate
  4043     ^ classRef isPrivateMeta 
  4044 !
  4045 
  4046 isPrivateMeta
  4047     thisContext isRecursive ifTrue:[^ false].
  4048     byteSize = (PrivateMetaclass instSize * 4 + 12) ifFalse:[^ false].
  4049     ^ classRef name = 'PrivateMetaclass'
  4050 !
  4051 
  4052 isSignedLongLongs
  4053     ^ (self flags bitAnd:Behavior maskIndexType) == Behavior flagSignedLongLongs.
  4054 !
  4055 
  4056 isSignedLongs
  4057     ^ (self flags bitAnd:Behavior maskIndexType) == Behavior flagSignedLongs.
  4058 !
  4059 
  4060 isSignedWords
  4061     ^ (self flags bitAnd:Behavior maskIndexType) == Behavior flagSignedWords.
  4062 !
  4063 
  4064 isTopLevelNameSpace
  4065     "return true, if this is a top level nameSpace."
  4066 
  4067     ^ self isNameSpace and:[(self name includes:$:) not]
  4068 !
  4069 
  4070 isVariable
  4071     ^ (self flags bitAnd:Behavior maskIndexType) ~= 0.
  4072 !
  4073 
  4074 isVisualStartable
  4075     ^ false
  4076 !
  4077 
  4078 isWords
  4079     ^ (self flags bitAnd:Behavior maskIndexType) == Behavior flagWords.
  4080 !
  4081 
  4082 nameSpace
  4083     |env name idx nsName|
  4084 
  4085 "/    (env := self environment) notNil ifTrue:[^ env].
  4086     env := memory image at:#Smalltalk. "/ default
  4087     name := self name.
  4088     idx := name lastIndexOf:$:.
  4089     idx ~~ 0 ifTrue:[
  4090         (name at:idx-1) == $: ifTrue:[
  4091             nsName := name copyTo:(idx - 2).
  4092             env := memory image at:nsName asSymbol.
  4093         ]
  4094     ].
  4095     ^ env
  4096 !
  4097 
  4098 owningClass
  4099     |ownerPtr owner|
  4100 
  4101     classRef isPrivateMeta ifFalse:[^ nil].
  4102     ownerPtr := classRef at:(PrivateMetaclass instVarOffsetOf:'owningClass').
  4103     owner := memory fetchClassObjectAt:ownerPtr.
  4104     ^ owner
  4105 !
  4106 
  4107 owningClassOrYourself
  4108     self owningClass notNil ifTrue:[^ self topOwningClass].
  4109     ^ self
  4110 !
  4111 
  4112 supportsMethodCategories
  4113     ^ true
  4114 !
  4115 
  4116 topNameSpace
  4117     "return the nameSpace of my topOwningClass (if private) or my own nameSpace."
  4118 
  4119     self isPrivate ifTrue:[^ self topOwningClass topNameSpace].
  4120     ^ self nameSpace
  4121 !
  4122 
  4123 topOwningClass
  4124     |owner|
  4125 
  4126     classRef isPrivateMeta ifTrue:[
  4127         owner := self owningClass.
  4128         [owner classRef isPrivateMeta] whileTrue:[
  4129             owner := owner owningClass
  4130         ].
  4131         ^ owner
  4132     ] ifFalse:[
  4133         ^ nil
  4134     ].
  4135     ^ self halt.
  4136 !
  4137 
  4138 wasAutoloaded
  4139     ^ false 
  4140 ! !
  4141 
  4142 !SnapShotImageMemory::SpaceInfo methodsFor:'accessing'!
  4143 
  4144 end
  4145     "return the value of the instance variable 'end' (automatically generated)"
  4146 
  4147     ^ end
  4148 !
  4149 
  4150 end:something
  4151     "set the value of the instance variable 'end' (automatically generated)"
  4152 
  4153     end := something.
  4154 !
  4155 
  4156 flags
  4157     "return the value of the instance variable 'flags' (automatically generated)"
  4158 
  4159     ^ flags
  4160 !
  4161 
  4162 flags:something
  4163     "set the value of the instance variable 'flags' (automatically generated)"
  4164 
  4165     flags := something.
  4166 !
  4167 
  4168 imageBase
  4169     "return the value of the instance variable 'imageBase' (automatically generated)"
  4170 
  4171     ^ imageBase
  4172 !
  4173 
  4174 imageBase:something
  4175     "set the value of the instance variable 'imageBase' (automatically generated)"
  4176 
  4177     imageBase := something.
  4178 !
  4179 
  4180 size
  4181     "return the value of the instance variable 'size' (automatically generated)"
  4182 
  4183     ^ size
  4184 !
  4185 
  4186 size:something
  4187     "set the value of the instance variable 'size' (automatically generated)"
  4188 
  4189     size := something.
  4190 !
  4191 
  4192 start
  4193     "return the value of the instance variable 'start' (automatically generated)"
  4194 
  4195     ^ start
  4196 !
  4197 
  4198 start:something
  4199     "set the value of the instance variable 'start' (automatically generated)"
  4200 
  4201     start := something.
  4202 ! !
  4203 
  4204 !SnapShotImageMemory class methodsFor:'documentation'!
  4205 
  4206 version
  4207     ^ '$Header$'
  4208 ! !