SnapShotImageMemory.st
author Patrik Svestka <patrik.svestka@gmail.com>
Wed, 14 Nov 2018 12:07:51 +0100
branchjv
changeset 3630 5e718e0a754e
parent 3326 4ecde59f7563
permissions -rw-r--r--
Issue #239: Fix all Smalltak/X source files to be in unicode (UTF8 without BOM) and prefixed by "{ Encoding: utf8 }" when any unicode character is present

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