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