SnapShotImageMemory.st
author Claus Gittinger <cg@exept.de>
Wed, 29 Jul 2009 20:02:02 +0200
changeset 2570 4e663bc64364
parent 2164 3c5fe1d92046
child 3088 5a5e9b9b5138
permissions -rw-r--r--
changed #requestPackage
ps@1423
     1
"{ Package: 'stx:libtool2' }"
cg@1416
     2
cg@1416
     3
Object subclass:#SnapShotImageMemory
cg@1417
     4
	instanceVariableNames:'image stream msb ptrSize intSize intTag spaceInfos symbolEntries
cg@1416
     5
		globalEntries addrToObjectMapping'
cg@1416
     6
	classVariableNames:''
cg@1416
     7
	poolDictionaries:''
cg@1416
     8
	category:'System-Support'
cg@1416
     9
!
cg@1416
    10
cg@1417
    11
Object subclass:#ImageHeader
cg@1864
    12
	instanceVariableNames:'memory address classRef bits byteSize'
cg@1417
    13
	classVariableNames:''
cg@1417
    14
	poolDictionaries:''
cg@1417
    15
	privateIn:SnapShotImageMemory
cg@1417
    16
!
cg@1417
    17
cg@1440
    18
SnapShotImageMemory::ImageHeader variableSubclass:#ImageObject
cg@1440
    19
	instanceVariableNames:'cachedContents'
cg@1440
    20
	classVariableNames:''
cg@1440
    21
	poolDictionaries:''
cg@1440
    22
	privateIn:SnapShotImageMemory
cg@1440
    23
!
cg@1440
    24
cg@1448
    25
SnapShotImageMemory::ImageHeader variableByteSubclass:#ImageByteObject
cg@1448
    26
	instanceVariableNames:''
cg@1448
    27
	classVariableNames:''
cg@1448
    28
	poolDictionaries:''
cg@1448
    29
	privateIn:SnapShotImageMemory
cg@1448
    30
!
cg@1448
    31
cg@1482
    32
SnapShotImageMemory::ImageObject variableSubclass:#ImageMethodObject
cg@1552
    33
	instanceVariableNames:'cachedPackage cachedMClass cachedSelector'
cg@1482
    34
	classVariableNames:''
cg@1482
    35
	poolDictionaries:''
cg@1482
    36
	privateIn:SnapShotImageMemory
cg@1482
    37
!
cg@1482
    38
cg@1440
    39
SnapShotImageMemory::ImageObject variableSubclass:#ImageClassObject
cg@1482
    40
	instanceVariableNames:'cachedCategory cachedFlags cachedName'
cg@1440
    41
	classVariableNames:''
cg@1440
    42
	poolDictionaries:''
cg@1440
    43
	privateIn:SnapShotImageMemory
cg@1440
    44
!
cg@1440
    45
ps@1423
    46
Object subclass:#SpaceInfo
ps@1423
    47
	instanceVariableNames:'start end size flags imageBase'
cg@1419
    48
	classVariableNames:''
cg@1419
    49
	poolDictionaries:''
cg@1419
    50
	privateIn:SnapShotImageMemory
cg@1419
    51
!
cg@1419
    52
cg@1448
    53
!SnapShotImageMemory class methodsFor:'documentation'!
cg@1448
    54
cg@1448
    55
documentation
cg@1448
    56
"
cg@1448
    57
    I represent the memory as contained in a snapshot image.
cg@1448
    58
cg@1448
    59
    I am not used directly; instead, via the SystemBrowsers entry:
cg@1448
    60
        SystemBrowser openOnSnapShotImage:'/export/home/cg/work/stx/projects/smalltalk/st.img'
cg@1864
    61
        SystemBrowser openOnSnapShotImage:'crash.img'
cg@1448
    62
cg@1448
    63
    [author:]
cg@1448
    64
        Claus Gittinger
cg@1448
    65
cg@1448
    66
"
cg@1448
    67
! !
cg@1416
    68
cg@1416
    69
!SnapShotImageMemory class methodsFor:'instance creation'!
cg@1416
    70
cg@1416
    71
for:aFilename
cg@1416
    72
    ^ self new for:aFilename
cg@1416
    73
! !
cg@1416
    74
cg@1416
    75
!SnapShotImageMemory class methodsFor:'private'!
cg@1416
    76
cg@1416
    77
isNilOOP:anOOP
cg@1416
    78
    ^ anOOP == 0
cg@1416
    79
!
cg@1416
    80
cg@1416
    81
isPointerOOP:anOOP
cg@1416
    82
    ^ (anOOP bitTest:1) not
cg@1416
    83
!
cg@1416
    84
cg@1416
    85
isSmallIntegerOOP:anOOP
cg@1416
    86
    ^ anOOP bitTest:1
cg@1416
    87
! !
cg@1416
    88
cg@1416
    89
!SnapShotImageMemory methodsFor:'accessing'!
cg@1416
    90
cg@1416
    91
globalEntries
cg@1416
    92
    "return the value of the instance variable 'globalEntries' (automatically generated)"
cg@1416
    93
cg@1440
    94
    ^ globalEntries
cg@1440
    95
!
cg@1416
    96
cg@1416
    97
globalEntries:something
cg@1416
    98
    "set the value of the instance variable 'globalEntries' (automatically generated)"
cg@1416
    99
cg@1440
   100
    globalEntries := something.
cg@1440
   101
!
cg@1417
   102
cg@1417
   103
image
cg@1417
   104
cg@1417
   105
    ^ image
cg@1417
   106
!
cg@1417
   107
cg@1417
   108
image:something
cg@1417
   109
cg@1417
   110
    image := something.
cg@1417
   111
!
cg@1417
   112
cg@1417
   113
ptrSize
cg@1417
   114
    "return the value of the instance variable 'ptrSize' (automatically generated)"
cg@1417
   115
cg@1440
   116
    ^ ptrSize
cg@1440
   117
!
cg@1417
   118
cg@1417
   119
ptrSize:something
cg@1417
   120
    "set the value of the instance variable 'ptrSize' (automatically generated)"
cg@1417
   121
cg@1440
   122
    ptrSize := something.
cg@1440
   123
! !
cg@1416
   124
cg@1416
   125
!SnapShotImageMemory methodsFor:'object access'!
cg@1416
   126
cg@1417
   127
fetchByteAt:addr
cg@1417
   128
    |byte imgAddr|
cg@1417
   129
cg@1417
   130
    imgAddr := self imageAddressOf:addr.
cg@1417
   131
    stream position:imgAddr.
cg@1417
   132
    byte := stream next.
cg@1417
   133
    ^ byte
cg@1417
   134
!
cg@1417
   135
cg@1416
   136
fetchClassObjectAt:baseAddr
cg@1417
   137
    |addr classPtr size bits o classRef nInsts|
cg@1417
   138
cg@1417
   139
    (baseAddr bitAnd:3) ~~ 0 ifTrue:[self halt].
cg@1416
   140
cg@1864
   141
    o := addrToObjectMapping at:(baseAddr bitShift:-2) ifAbsent:nil.
cg@1416
   142
    o notNil ifTrue:[^ o].
cg@1416
   143
cg@1416
   144
    addr := baseAddr.
cg@1416
   145
    classPtr := self fetchPointerAt:addr.
cg@1416
   146
    addr := addr + ptrSize.
cg@1416
   147
    size := self fetchUnboxedIntegerAt:addr.
cg@1416
   148
    addr := addr + ptrSize.
cg@1416
   149
    bits := self fetchUnboxedIntegerAt:addr.
cg@1416
   150
    addr := addr + ptrSize.
cg@1416
   151
cg@1864
   152
    nInsts := (size - (intSize * 3 "headerSize")) // intSize.
cg@1417
   153
    o := ImageClassObject new:nInsts.
cg@1864
   154
    o memory:self.
cg@1864
   155
    o address:baseAddr.
cg@1864
   156
    addrToObjectMapping at:(baseAddr bitShift:-2) put:o.
cg@1417
   157
cg@1417
   158
    (self class isPointerOOP:classPtr) ifFalse:[
cg@1417
   159
        self halt
cg@1417
   160
    ].
cg@1417
   161
cg@1417
   162
size > 8000 ifTrue:[self halt].
cg@1417
   163
    o byteSize:size.
cg@1416
   164
    o bits:bits.
cg@1416
   165
cg@1417
   166
    1 to:nInsts do:[:idx |
cg@1416
   167
        o at:idx put:(self fetchUnboxedIntegerAt:addr).
cg@1417
   168
"/        o at:idx put:(self fetchObjectAt:(self fetchUnboxedIntegerAt:addr)).
cg@1417
   169
        addr := addr + ptrSize.
cg@1416
   170
    ].
cg@1864
   171
cg@1864
   172
    classRef := self fetchClassObjectAt:classPtr.
cg@1864
   173
    o classRef:classRef.
cg@1864
   174
cg@1416
   175
    ^ o
cg@1416
   176
!
cg@1416
   177
cg@1416
   178
fetchObjectAt:baseAddr
cg@1482
   179
    |addr classPtr classRef size bits o nBytes nInsts flags indexTypeFlags imgAddr
cg@1482
   180
     |
cg@1417
   181
cg@1417
   182
    baseAddr == 0 ifTrue:[^ nil].
cg@1864
   183
    (baseAddr bitAnd:1) == 1 ifTrue:[
cg@1864
   184
        (baseAddr bitTest:16r80000000) ifTrue:[
cg@1864
   185
            ^ (baseAddr - 16r100000000) bitShift32:-1
cg@1864
   186
        ] ifFalse:[   
cg@1864
   187
            ^ baseAddr bitShift32:-1
cg@1864
   188
        ]
cg@1864
   189
    ].
cg@1417
   190
    (baseAddr bitAnd:3) ~~ 0 ifTrue:[self halt].
cg@1416
   191
cg@1864
   192
    o := addrToObjectMapping at:(baseAddr bitShift:-2) ifAbsent:nil.
cg@1416
   193
    o notNil ifTrue:[^ o].
cg@1416
   194
cg@1416
   195
    addr := baseAddr.
cg@1416
   196
    classPtr := self fetchPointerAt:addr.
cg@1416
   197
    addr := addr + ptrSize.
cg@1416
   198
    size := self fetchUnboxedIntegerAt:addr.
cg@1416
   199
    addr := addr + ptrSize.
cg@1416
   200
    bits := self fetchUnboxedIntegerAt:addr.
cg@1416
   201
    addr := addr + ptrSize.
cg@1416
   202
cg@1416
   203
    (self class isPointerOOP:classPtr) ifFalse:[
cg@1416
   204
        self halt
cg@1416
   205
    ].
cg@1416
   206
cg@1416
   207
    classRef := self fetchClassObjectAt:classPtr.
cg@1417
   208
cg@1482
   209
    flags := classRef flags.
cg@1482
   210
    indexTypeFlags := flags bitAnd:Behavior maskIndexType.
cg@1482
   211
    (indexTypeFlags = Behavior flagBytes) ifTrue:[ 
cg@1417
   212
        nBytes := (size - (intSize * 3)).
cg@1417
   213
        o := ImageByteObject new:nBytes.
cg@1864
   214
        o memory:self.
cg@1864
   215
        o address:baseAddr.
cg@1417
   216
        o classRef:classRef.
cg@1791
   217
"/ size > 8000 ifTrue:[self halt].
cg@1417
   218
        o byteSize:size.
cg@1417
   219
        o bits:bits.
cg@1864
   220
        addrToObjectMapping at:(baseAddr bitShift:-2) put:o.
cg@1417
   221
cg@1417
   222
        imgAddr := self imageAddressOf:addr.
cg@1417
   223
        stream position:imgAddr.
cg@1417
   224
cg@1417
   225
        1 to:nBytes do:[:idx |
cg@1417
   226
            o at:idx put:(stream next).
cg@1417
   227
            addr := addr + 1.
cg@1417
   228
        ].
cg@1417
   229
cg@1417
   230
"/Transcript show:'#'.
cg@1417
   231
"/Transcript show:((ByteArray new:nBytes-1) replaceFrom:1 to:nBytes-1 with:o startingAt:1) asString.
cg@1417
   232
"/Transcript cr.
cg@1417
   233
cg@1417
   234
    ] ifFalse:[
cg@1482
   235
        (indexTypeFlags = Behavior flagNotIndexed) ifFalse:[ 
cg@1482
   236
            (indexTypeFlags ~= Behavior flagPointers) ifTrue:[
cg@1482
   237
                (indexTypeFlags ~= Behavior flagWeakPointers) ifTrue:[
cg@1417
   238
                    self halt 
cg@1417
   239
                ]
cg@1417
   240
            ].
cg@1417
   241
        ].
cg@1417
   242
cg@1417
   243
        nInsts := (size - (intSize * 3)) // intSize.
cg@1482
   244
        (flags bitTest:Behavior flagBehavior)
cg@1417
   245
        "/ classRef isImageBehavior 
cg@1417
   246
        ifTrue:[
cg@1417
   247
            o := ImageClassObject new:nInsts.
cg@1417
   248
        ] ifFalse:[
cg@1482
   249
            (flags bitTest:Behavior flagMethod) ifTrue:[
cg@1482
   250
                o := ImageMethodObject new:nInsts.
cg@1482
   251
            ] ifFalse:[
cg@1482
   252
                o := ImageObject new:nInsts.
cg@1482
   253
            ]
cg@1417
   254
        ].
cg@1864
   255
        o memory:self.
cg@1864
   256
        o address:baseAddr.
cg@1417
   257
        o classRef:classRef.
cg@1417
   258
size > 8000 ifTrue:[self halt].
cg@1417
   259
        o byteSize:size.
cg@1417
   260
        o bits:bits.
cg@1864
   261
        addrToObjectMapping at:(baseAddr bitShift:-2) put:o.
cg@1417
   262
cg@1417
   263
        1 to:nInsts do:[:idx |
cg@1417
   264
            o at:idx put:(self fetchUnboxedIntegerAt:addr).
cg@1417
   265
"/            o at:idx put:(self fetchObjectAt:(self fetchUnboxedIntegerAt:addr)).
cg@1417
   266
            addr := addr + ptrSize.
cg@1417
   267
        ]
cg@1416
   268
    ].
cg@1417
   269
    ^ o
cg@1416
   270
!
cg@1416
   271
cg@1416
   272
fetchPointerAt:addr
cg@1416
   273
    ^ self fetchUnboxedIntegerAt:addr
cg@1416
   274
!
cg@1416
   275
cg@1416
   276
fetchUnboxedIntegerAt:addr
cg@1417
   277
    |ptr imgAddr|
cg@1417
   278
cg@1417
   279
    (addr bitAnd:3) ~~ 0 ifTrue:[self halt].
cg@1417
   280
cg@1417
   281
    imgAddr := self imageAddressOf:addr.
cg@1417
   282
    stream position:imgAddr.
cg@1417
   283
    ptr := stream nextUnsignedLongMSB:msb.
cg@1417
   284
    ^ ptr
cg@1417
   285
!
cg@1417
   286
cg@1417
   287
imageAddressOf:addr
cg@1416
   288
    spaceInfos do:[:eachSpace |
cg@1417
   289
        |byte imgAddr|
cg@1416
   290
cg@1416
   291
        addr >= eachSpace start ifTrue:[
cg@1416
   292
            addr <= eachSpace end ifTrue:[
cg@1416
   293
                imgAddr := eachSpace imageBase + (addr - eachSpace start).
cg@1417
   294
                ^ imgAddr
cg@1416
   295
            ]
cg@1416
   296
        ].
cg@1416
   297
    ].
cg@1417
   298
    self halt:'image address error'.
cg@1416
   299
! !
cg@1416
   300
cg@1416
   301
!SnapShotImageMemory methodsFor:'private'!
cg@1416
   302
cg@1416
   303
allClassesDo:aBlock
cg@1551
   304
    globalEntries do:[:eachGlobal |
cg@1416
   305
        |val|
cg@1416
   306
cg@1551
   307
        val := eachGlobal value.
cg@1551
   308
        (val notNil     
cg@1551
   309
        and:[(val isKindOf:ImageHeader)
cg@1551
   310
        and:[val isImageBehavior]]) ifTrue:[
cg@1416
   311
            aBlock value:val
cg@1417
   312
        ].
cg@1416
   313
    ].
cg@1416
   314
!
cg@1416
   315
cg@1419
   316
fetchByteArrayFor:aByteArrayRef
cg@1419
   317
    |nBytes|
cg@1419
   318
cg@1419
   319
    (aByteArrayRef isImageBytes) ifFalse:[self halt].
cg@1419
   320
cg@1419
   321
    nBytes := aByteArrayRef byteSize - (intSize * 3).
cg@1440
   322
    ^ ((ByteArray new:nBytes) replaceFrom:1 to:nBytes-1 with:aByteArrayRef startingAt:1).
cg@1440
   323
!
cg@1419
   324
cg@1417
   325
fetchStringFor:aStringRef
cg@1417
   326
    |nBytes|
cg@1417
   327
cg@1417
   328
    (aStringRef isImageBytes) ifFalse:[self halt].
cg@1417
   329
cg@1417
   330
    nBytes := aStringRef byteSize - (intSize * 3).
cg@1417
   331
    ^ ((ByteArray new:nBytes-1) replaceFrom:1 to:nBytes-1 with:aStringRef startingAt:1) asString.
cg@1417
   332
!
cg@1417
   333
cg@1416
   334
for:aFilename
cg@1416
   335
    stream := aFilename asFilename readStream binary.
cg@1416
   336
    addrToObjectMapping := IdentityDictionary new.
cg@1417
   337
cg@1864
   338
    addrToObjectMapping at:((ObjectMemory addressOf:false) bitShift:-2) put:false.
cg@1864
   339
    addrToObjectMapping at:((ObjectMemory addressOf:true) bitShift:-2)  put:true.
cg@1417
   340
!
cg@1417
   341
cg@1417
   342
printStringOfClass:aClassRef
cg@1417
   343
    |nameSlot|
cg@1417
   344
cg@1417
   345
    (aClassRef isImageBehavior) ifFalse:[self halt].
cg@1417
   346
    ((aClassRef byteSize // intSize) - 3) < Class instSize ifTrue:[self halt.].
cg@1417
   347
cg@1791
   348
    nameSlot := aClassRef nameSlot.
cg@1417
   349
    nameSlot isInteger ifTrue:[
cg@1417
   350
        nameSlot := self fetchObjectAt:nameSlot
cg@1417
   351
    ].
cg@1417
   352
    nameSlot isImageSymbol ifFalse:[self halt].
cg@1417
   353
    ^ 'Class: ' , (self printStringOfSymbol:nameSlot)
cg@1417
   354
!
cg@1417
   355
cg@1417
   356
printStringOfObject:anObjectRef
cg@1417
   357
    |s nBytes|
cg@1417
   358
cg@1417
   359
    anObjectRef isNil ifTrue:[^ 'nil'].
cg@1417
   360
    (anObjectRef isInteger) ifTrue:[^ anObjectRef printString].
cg@1417
   361
    (anObjectRef == true ) ifTrue:[^ anObjectRef printString].
cg@1417
   362
    (anObjectRef == false) ifTrue:[^ anObjectRef printString].
cg@1417
   363
cg@1417
   364
    (anObjectRef isImageSymbol) ifTrue:[^ self printStringOfSymbol:anObjectRef].
cg@1417
   365
    (anObjectRef isImageBehavior) ifTrue:[^ self printStringOfClass:anObjectRef].
cg@1417
   366
cg@1417
   367
    ^ 'obj(' , anObjectRef printString , ')'
cg@1417
   368
!
cg@1417
   369
cg@1417
   370
printStringOfString:aStringRef
cg@1417
   371
    |nBytes|
cg@1417
   372
cg@1417
   373
    (aStringRef isString) ifFalse:[self halt].
cg@1417
   374
    ^ self fetchStringFor:aStringRef.
cg@1417
   375
!
cg@1417
   376
cg@1417
   377
printStringOfSymbol:aSymbolRef
cg@1417
   378
    |nBytes|
cg@1417
   379
cg@1417
   380
    (aSymbolRef isImageSymbol) ifFalse:[self halt].
cg@1420
   381
    ^ self fetchStringFor:aSymbolRef.
cg@1417
   382
"/    nBytes := aSymbolRef size - (intSize * 3).
cg@1417
   383
"/    ^ ((ByteArray new:nBytes-1) replaceFrom:1 to:nBytes-1 with:aSymbolRef startingAt:1) asString.
cg@1416
   384
!
cg@1416
   385
cg@1416
   386
readGlobalEntries
cg@1417
   387
        |refPointer theSymbolPtr theSymbolRef theValuePtr theValueRef pos|
cg@1416
   388
cg@1416
   389
        globalEntries := OrderedCollection new.
cg@1416
   390
        [
cg@1416
   391
            refPointer := stream nextUnsignedLongMSB:msb.
cg@1417
   392
            theSymbolPtr := stream nextUnsignedLongMSB:msb.
cg@1417
   393
            theValuePtr := stream nextUnsignedLongMSB:msb.
cg@1417
   394
            theSymbolPtr ~~ 0
cg@1416
   395
        ] whileTrue:[
cg@1417
   396
            globalEntries add:(theSymbolPtr -> theValuePtr).
cg@1416
   397
        ].
cg@1417
   398
        globalEntries := globalEntries asArray.
cg@1417
   399
cg@1417
   400
"/ globalEntries inspect.
cg@1417
   401
        pos := stream position.
cg@1417
   402
        globalEntries do:[:item |
cg@1417
   403
            theSymbolPtr := item key.
cg@1417
   404
            theValuePtr := item value.
cg@1417
   405
            theSymbolRef := self fetchObjectAt:theSymbolPtr.
cg@1417
   406
cg@1417
   407
"/            Transcript show:(self printStringOfSymbol:theSymbolRef).
cg@1417
   408
"/            Transcript show:'->'.
cg@1417
   409
cg@1417
   410
            theValueRef := self fetchObjectAt:theValuePtr.
cg@1417
   411
"/            Transcript show:(self printStringOfObject:theValueRef).
cg@1417
   412
"/            Transcript cr.
cg@1417
   413
cg@1417
   414
            item key:theSymbolRef.
cg@1417
   415
            item value:theValueRef.
cg@1417
   416
        ].
cg@1417
   417
        stream position:pos.
cg@1416
   418
!
cg@1416
   419
cg@1416
   420
readHeader
cg@1416
   421
        "
cg@1416
   422
         (self for:'stmeas.img') readHeader
cg@1864
   423
         (self for:'crash.img') readHeader
cg@1416
   424
        "
cg@1416
   425
cg@1416
   426
        |order magic version timeStamp snapID last_util_addr hiText_addr flags 
cg@1416
   427
         lowData hiData charSlots charTableSlots fixMemStart fixMemEnd 
cg@1416
   428
         symMemStart symMemEnd vmDataAddr sharedMethodCode sharedBlockCode 
cg@1416
   429
         nContexts contextSpace nRegistered symbolsSeqNr nSpaces 
cg@1864
   430
         classNameSize spaceSize numCharSlots|
cg@1416
   431
cg@1416
   432
        stream next:256.        "/ skip execCmd
cg@1416
   433
cg@1416
   434
        msb := false.
cg@1416
   435
        order := stream nextUnsignedLongMSB:msb.        
cg@1416
   436
        order = 16r076543210 ifTrue:[
cg@1416
   437
        ] ifFalse:[
ps@1423
   438
            order = 16r10325476 ifTrue:[
cg@1416
   439
                msb := true.
cg@1416
   440
            ] ifFalse:[
cg@1416
   441
                self error:'unhandled byteorder'
cg@1416
   442
            ].
cg@1416
   443
        ].
cg@1416
   444
        magic := (stream next:8) asString.
cg@1416
   445
        magic ~= 'ST/X-IMG' ifTrue:[
cg@1416
   446
            self error:'not an st/x image'
cg@1416
   447
        ].
cg@1416
   448
        version := stream nextUnsignedLongMSB:msb.        
cg@1416
   449
        timeStamp := stream nextUnsignedLongMSB:msb.        
cg@1416
   450
        ptrSize := stream nextByte.        
cg@1416
   451
        ptrSize ~~ 4 ifTrue:[
cg@1416
   452
            self error:'unhandled ptr format'
cg@1416
   453
        ].
cg@1416
   454
        stream next:7.    "/ filler    
cg@1416
   455
        intSize := stream nextUnsignedLongMSB:msb.        
cg@1416
   456
        intSize == 9 ifTrue:[
cg@1416
   457
            intSize := 4.
cg@1416
   458
            intTag := 1.
cg@1416
   459
        ] ifFalse:[
cg@1416
   460
            self error:'unhandled int format'
cg@1416
   461
        ].
cg@1416
   462
        
cg@1416
   463
        snapID := stream nextUnsignedLongMSB:msb.        
cg@1416
   464
        last_util_addr := stream next:intSize.        
cg@1416
   465
        hiText_addr := stream next:intSize.        
cg@1416
   466
        flags := stream next:intSize.        
cg@1416
   467
        stream next:8.    "/ info, debug & filler    
cg@1416
   468
cg@1416
   469
        lowData := stream nextUnsignedLongMSB:msb.
cg@1416
   470
        hiData := stream nextUnsignedLongMSB:msb.
cg@1416
   471
cg@1416
   472
        charSlots := stream nextUnsignedLongMSB:msb.
cg@1416
   473
        charTableSlots := stream nextUnsignedLongMSB:msb.
cg@1416
   474
cg@1416
   475
        version >= 8 ifTrue:[
cg@1416
   476
            fixMemStart := stream nextUnsignedLongMSB:msb.
cg@1416
   477
            fixMemEnd := stream nextUnsignedLongMSB:msb.
cg@1416
   478
            symMemStart := stream nextUnsignedLongMSB:msb.
cg@1416
   479
            symMemEnd := stream nextUnsignedLongMSB:msb.
cg@1416
   480
            vmDataAddr := stream nextUnsignedLongMSB:msb.
cg@1416
   481
        ].
cg@1416
   482
        stream next:(128 * intSize).    "/ skip sharedMethodCode ptrs
cg@1416
   483
        stream next:(128 * intSize).    "/ skip sharedBlockCode ptrs
cg@1416
   484
cg@1416
   485
        nContexts := stream nextUnsignedLongMSB:msb.
cg@1416
   486
        contextSpace := stream nextUnsignedLongMSB:msb.
cg@1416
   487
        nRegistered := stream nextUnsignedLongMSB:msb.
cg@1416
   488
cg@1416
   489
        version >= 8 ifTrue:[
cg@1416
   490
            version >= 9 ifTrue:[
cg@1416
   491
                symbolsSeqNr := stream nextUnsignedLongMSB:msb.
cg@1864
   492
                version >= 10 ifTrue:[
cg@1864
   493
                    numCharSlots := stream nextUnsignedLongMSB:msb.
cg@1864
   494
                    stream next:(intSize * 30).
cg@1864
   495
                ] ifFalse:[
cg@1864
   496
                    stream next:(intSize * 31).
cg@1864
   497
                ].
cg@1416
   498
            ] ifFalse:[
cg@1416
   499
                stream next:(intSize * 32).
cg@1416
   500
            ]
cg@1416
   501
        ].
cg@1416
   502
cg@1416
   503
        nSpaces := stream nextUnsignedLongMSB:msb.
cg@1416
   504
        spaceInfos := (1 to:nSpaces) collect:[:idx | SpaceInfo new].
cg@1416
   505
        
cg@1416
   506
        1 to:nSpaces do:[:i |
cg@1416
   507
            (spaceInfos at:i) flags:(stream nextUnsignedLongMSB:msb).
cg@1416
   508
        ].
cg@1416
   509
        nSpaces+1 to:32 do:[:i | stream nextUnsignedLongMSB:msb].
cg@1416
   510
cg@1416
   511
        1 to:nSpaces do:[:i |
cg@1416
   512
            (spaceInfos at:i) start:(stream nextUnsignedLongMSB:msb).
cg@1416
   513
        ].
cg@1416
   514
        nSpaces+1 to:32 do:[:i | stream nextUnsignedLongMSB:msb].
cg@1416
   515
cg@1416
   516
        1 to:nSpaces do:[:i |
cg@1416
   517
            (spaceInfos at:i) size:(stream nextUnsignedLongMSB:msb).
cg@1416
   518
        ].
cg@1416
   519
        nSpaces+1 to:32 do:[:i | stream nextUnsignedLongMSB:msb].
cg@1416
   520
        version >= 8 ifTrue:[
cg@1864
   521
            stream reset.
cg@1417
   522
            stream skip:4096.
cg@1416
   523
        ].
cg@1416
   524
cg@1416
   525
        1 to:nSpaces do:[:i |
cg@1416
   526
            (spaceInfos at:i) end:((spaceInfos at:i) start + (spaceInfos at:i) size - 1).
cg@1416
   527
        ].
cg@1416
   528
        1 to:nSpaces do:[:i |
cg@1416
   529
            (spaceInfos at:i) imageBase:(stream position).
cg@1417
   530
            spaceSize := (spaceInfos at:i) size.
cg@1417
   531
            stream skip:spaceSize.
cg@1416
   532
        ].
cg@1416
   533
cg@1416
   534
        "/ registration
cg@1416
   535
cg@1416
   536
        self readRegistrationEntries.
cg@1417
   537
        Transcript showCR:'reading symbols...'.
cg@1416
   538
        self readSymbolEntries.
cg@1417
   539
        self readUGlobalEntries.
cg@1417
   540
        Transcript showCR:'reading globals...'.
cg@1416
   541
        self readGlobalEntries.
cg@1416
   542
cg@1416
   543
cg@1416
   544
"/struct basicImageHeader {
cg@1416
   545
"/        char            h_execCmd[256];
cg@1416
   546
"/
cg@1416
   547
"/        int             h_orderWord;
cg@1416
   548
"/        char            h_magic[8];
cg@1416
   549
"/        int             h_version;
cg@1416
   550
"/        int             h_timeStamp;
cg@1416
   551
"/        char            h_ptrSize;
cg@1416
   552
"/        char            h_filler1[7];
cg@1416
   553
"/        int             h_intSize;
cg@1416
   554
"/        int             h_snapID;
cg@1416
   555
"/        INT             h_last_util_addr;
cg@1416
   556
"/        INT             h_hiText_addr;
cg@1416
   557
"/        INT             h_flags;
cg@1416
   558
"/        char            h_infoPrinting;
cg@1416
   559
"/        char            h_debugPrinting;
cg@1416
   560
"/        char            h_filler2[6];
cg@1416
   561
"/
cg@1416
   562
"/        /*
cg@1416
   563
"/         * these are to verify compatibility of the image with
cg@1416
   564
"/         * myself ...
cg@1416
   565
"/         * this is now obsolete.
cg@1416
   566
"/         */
cg@1416
   567
"/        INT             h_lowData, h_hiData;
cg@1416
   568
"/
cg@1416
   569
"/        /*
cg@1416
   570
"/         * base address of character- and characterTable slots
cg@1416
   571
"/         */
cg@1416
   572
"/        INT             h_charSlots;
cg@1416
   573
"/        INT             h_charTableSlots;
cg@1416
   574
"/
cg@1416
   575
"/#if HEADER_VERSION >= 8
cg@1416
   576
"/        /*
cg@1416
   577
"/         * the fixBase (VMDATA address)
cg@1416
   578
"/         */
cg@1416
   579
"/        INT             h_fixMemStart;
cg@1416
   580
"/        INT             h_fixMemEnd;
cg@1416
   581
"/        INT             h_symMemStart;
cg@1416
   582
"/        INT             h_symMemEnd;
cg@1416
   583
"/
cg@1416
   584
"/        INT             h_vmDataAddr;
cg@1416
   585
"/#endif
cg@1416
   586
"/
cg@1416
   587
"/        INT             h_sharedMethodCode[128];
cg@1416
   588
"/        INT             h_sharedBlockCode[128];
cg@1416
   589
"/
cg@1416
   590
"/        /*      
cg@1416
   591
"/         * space needed to restore contexts
cg@1416
   592
"/         */
cg@1416
   593
"/        INT             h_nContexts;
cg@1416
   594
"/        INT             h_contextSpace;
cg@1416
   595
"/
cg@1416
   596
"/        /*
cg@1416
   597
"/         * number of class registration info records
cg@1416
   598
"/         */
cg@1416
   599
"/        INT             h_nRegistered;
cg@1416
   600
"/
cg@1416
   601
"/#if HEADER_VERSION >= 8
cg@1416
   602
"/        /*
cg@1416
   603
"/         * reserved slots, for future versions
cg@1416
   604
"/         * (can add additional info, without affecting position of following stuff)
cg@1416
   605
"/         * If you add slots, you MUST DECREMENT the fillcount.
cg@1416
   606
"/         */
cg@1416
   607
"/# if HEADER_VERSION >= 9
cg@1416
   608
"/        INT             h_symbolsSeqNr;
cg@1416
   609
"/        INT             h_reserved[31];
cg@1416
   610
"/# else
cg@1416
   611
"/        INT             h_reserved[32];
cg@1416
   612
"/# endif
cg@1416
   613
"/#endif
cg@1416
   614
"/
cg@1416
   615
"/        /*
cg@1416
   616
"/         * number of spaces, base and size of each
cg@1416
   617
"/         */
cg@1416
   618
"/        INT             h_nSpaces;
cg@1416
   619
"/        INT             h_spaceFlags[MAXSPACES];
cg@1416
   620
"/        INT             h_spaceBase[MAXSPACES];
cg@1416
   621
"/        INT             h_spaceSize[MAXSPACES];
cg@1416
   622
"/
cg@1416
   623
"/        /*
cg@1416
   624
"/         * here come nSpaces object spaces
cg@1416
   625
"/         */
cg@1416
   626
"/
cg@1416
   627
"/        /*
cg@1416
   628
"/         * here comes registration info
cg@1416
   629
"/         */
cg@1416
   630
"/
cg@1416
   631
"/        /*
cg@1416
   632
"/         * here come nSymbols symbolEntries
cg@1416
   633
"/         * followed by a zero/zero entry
cg@1416
   634
"/         */
cg@1416
   635
"/
cg@1416
   636
"/        /*
cg@1416
   637
"/         * here come nGlobal globalEntries
cg@1416
   638
"/         * followed by a zero/zero entry
cg@1416
   639
"/         */
cg@1416
   640
"/
cg@1416
   641
"/        /*
cg@1416
   642
"/         * here come nUnnamedGlobal globalEntries
cg@1416
   643
"/         * followed by a zero/zero entry
cg@1416
   644
"/         */
cg@1416
   645
"/
cg@1416
   646
"/        /*
cg@1416
   647
"/         * here come stack contexts
cg@1416
   648
"/         */
cg@1416
   649
"/};      
cg@1416
   650
!
cg@1416
   651
cg@1416
   652
readRegistrationEntries
cg@1416
   653
        |classNameSize|
cg@1416
   654
cg@1416
   655
        [
cg@1416
   656
            classNameSize := stream nextUnsignedLongMSB:msb.
cg@1416
   657
            classNameSize ~~ 0
cg@1416
   658
        ] whileTrue:[
cg@1416
   659
            |className flags moduleTimestamp signature nMethods nBlocks oldLitRefs nLitRefs
cg@1416
   660
             oldConstTable nConsts|
cg@1416
   661
cg@1416
   662
            className := (stream next:classNameSize) asString.
cg@1416
   663
            stream next. "/ 0-byte
cg@1416
   664
            flags := stream nextUnsignedLongMSB:msb.
cg@1416
   665
            moduleTimestamp := stream nextUnsignedLongMSB:msb.   
cg@1416
   666
            signature := stream nextUnsignedLongMSB:msb.   
cg@1416
   667
            nMethods := stream nextUnsignedLongMSB:msb.   
cg@1416
   668
            nMethods timesRepeat:[ stream nextUnsignedLongMSB:msb ].
cg@1416
   669
            nBlocks := stream nextUnsignedLongMSB:msb.   
cg@1416
   670
            nBlocks timesRepeat:[ stream nextUnsignedLongMSB:msb ].
cg@1416
   671
            oldLitRefs := stream nextUnsignedLongMSB:msb.  
cg@1416
   672
            nLitRefs := stream nextUnsignedLongMSB:msb.
cg@1416
   673
            nLitRefs timesRepeat:[ stream nextUnsignedLongMSB:msb ].
cg@1416
   674
            stream nextUnsignedLongMSB:msb. "/ 0-litRef
cg@1416
   675
            oldConstTable := stream nextUnsignedLongMSB:msb.  
cg@1550
   676
            nConsts := stream nextLongMSB:msb.
cg@1550
   677
            nConsts > 0 ifTrue:[
cg@1550
   678
                nConsts timesRepeat:[ stream nextUnsignedLongMSB:msb ].
cg@1550
   679
            ]
cg@1420
   680
            "/ Transcript showCR:className.
cg@1416
   681
        ].
cg@1416
   682
!
cg@1416
   683
cg@1416
   684
readSymbolEntries
cg@1417
   685
        |refPointer theSymbolPtr theSymbolRef pos|
cg@1416
   686
cg@1416
   687
        symbolEntries := OrderedCollection new.
cg@1416
   688
cg@1416
   689
        [
cg@1416
   690
            refPointer := stream nextUnsignedLongMSB:msb.
cg@1417
   691
            theSymbolPtr := stream nextUnsignedLongMSB:msb.
cg@1417
   692
            theSymbolPtr ~~ 0
cg@1416
   693
        ] whileTrue:[
cg@1417
   694
            symbolEntries add:theSymbolPtr.
cg@1416
   695
        ].
cg@1417
   696
        symbolEntries := symbolEntries asArray.
cg@1417
   697
cg@1417
   698
        pos := stream position.
cg@1417
   699
        symbolEntries := symbolEntries collect:[:theSymbolPtr |
cg@1417
   700
            theSymbolRef := self fetchObjectAt:theSymbolPtr.
cg@1417
   701
            theSymbolRef isImageSymbol ifFalse:[
cg@1417
   702
                self halt
cg@1417
   703
            ].
cg@1417
   704
        ].        
cg@1417
   705
        stream position:pos
cg@1416
   706
!
cg@1416
   707
cg@1416
   708
readUGlobalEntries
cg@1416
   709
        |refPointer theValue|
cg@1416
   710
cg@1416
   711
        [
cg@1416
   712
            refPointer := stream nextUnsignedLongMSB:msb.
cg@1416
   713
            theValue := stream nextUnsignedLongMSB:msb.
cg@1416
   714
            refPointer ~~ 0
cg@1416
   715
        ] whileTrue
cg@1416
   716
! !
cg@1416
   717
cg@1417
   718
!SnapShotImageMemory::ImageHeader methodsFor:'accessing'!
cg@1417
   719
cg@1864
   720
address:something
cg@1864
   721
    address := something.
cg@1864
   722
!
cg@1864
   723
cg@1417
   724
bits
cg@1417
   725
    "return the value of the instance variable 'bits' (automatically generated)"
cg@1417
   726
cg@1440
   727
    ^ bits
cg@1440
   728
!
cg@1417
   729
cg@1417
   730
bits:something
cg@1417
   731
    "set the value of the instance variable 'bits' (automatically generated)"
cg@1417
   732
cg@1440
   733
    bits := something.
cg@1440
   734
!
cg@1417
   735
cg@1417
   736
byteSize
cg@1417
   737
    "return the value of the instance variable 'size' (automatically generated)"
cg@1417
   738
cg@1417
   739
    ^ byteSize
cg@1417
   740
!
cg@1417
   741
cg@1417
   742
byteSize:something
cg@1417
   743
    "set the value of the instance variable 'size' (automatically generated)"
cg@1417
   744
cg@1791
   745
"/ something > 8000 ifTrue:[self halt].
cg@1417
   746
    byteSize := something.
cg@1417
   747
!
cg@1417
   748
cg@1417
   749
classRef
cg@1417
   750
    "return the value of the instance variable 'classRef' (automatically generated)"
cg@1417
   751
cg@1440
   752
    ^ classRef
cg@1440
   753
!
cg@1417
   754
cg@1417
   755
classRef:something
cg@1417
   756
    "set the value of the instance variable 'classRef' (automatically generated)"
cg@1417
   757
cg@1440
   758
    classRef := something.
cg@1440
   759
!
cg@1417
   760
cg@1417
   761
memory
cg@1417
   762
    "return the value of the instance variable 'memory' (automatically generated)"
cg@1417
   763
cg@1440
   764
    ^ memory
cg@1440
   765
!
cg@1417
   766
cg@1417
   767
memory:something
cg@1417
   768
    "set the value of the instance variable 'memory' (automatically generated)"
cg@1417
   769
cg@1440
   770
    memory := something.
cg@1440
   771
! !
cg@1417
   772
cg@1417
   773
!SnapShotImageMemory::ImageHeader methodsFor:'queries'!
cg@1417
   774
cg@1417
   775
category
cg@1791
   776
    |categoryPtr categoryRef category categorySlotOffset|
cg@1417
   777
cg@1417
   778
    self isMethodOrLazyMethod ifTrue:[
cg@1791
   779
        categorySlotOffset := Method instVarOffsetOf:'category'.
cg@1791
   780
        "/ categorySlotOffset := 6.
cg@1791
   781
        categoryPtr := self at:categorySlotOffset.
cg@1417
   782
        categoryRef := memory fetchObjectAt:categoryPtr.
cg@1417
   783
        category := memory fetchStringFor:categoryRef.
cg@1417
   784
        ^ category
cg@1417
   785
    ].
cg@1417
   786
self halt.
cg@1417
   787
!
cg@1417
   788
cg@1419
   789
isBehavior
cg@1440
   790
    ^ self isImageBehavior
cg@1440
   791
!
cg@1419
   792
cg@1417
   793
isImageBehavior
cg@1417
   794
    |flags|
cg@1417
   795
cg@1417
   796
    flags := classRef flags.
cg@1417
   797
    ^ flags bitTest:Behavior flagBehavior  
cg@1417
   798
!
cg@1417
   799
cg@1417
   800
isImageBytes
cg@1417
   801
    |flags|
cg@1417
   802
cg@1417
   803
    flags := classRef flags bitAnd:Behavior maskIndexType.
cg@1417
   804
    ^ flags = Behavior flagBytes 
cg@1417
   805
!
cg@1417
   806
cg@1417
   807
isImageMethod
cg@1417
   808
    |flags|
cg@1417
   809
cg@1417
   810
    flags := classRef flags.
cg@1417
   811
    ^ flags bitTest:Behavior flagMethod 
cg@1417
   812
!
cg@1417
   813
cg@1417
   814
isImageSymbol
cg@1417
   815
    |flags|
cg@1417
   816
cg@1417
   817
    flags := classRef flags.
cg@1417
   818
    ^ flags bitTest:Behavior flagSymbol 
cg@1417
   819
!
cg@1417
   820
cg@1420
   821
isJavaMethod    
cg@1420
   822
    |nm|
cg@1420
   823
cg@1420
   824
    nm := classRef name.
cg@1420
   825
    ^ (nm = 'JavaMethod'
cg@1420
   826
      or:[ nm = 'JavaMethodWithException' 
cg@1420
   827
      or:[ nm = 'JavaMethodWithHandler' 
cg@1420
   828
      or:[ nm = 'JavaNativeMethod' ]]])
cg@1420
   829
!
cg@1420
   830
cg@1419
   831
isLazyMethod                               
cg@1440
   832
    ^ classRef name = 'LazyMethod'
cg@1440
   833
!
cg@1419
   834
cg@1417
   835
isMeta
cg@1417
   836
    ^ false
cg@1417
   837
!
cg@1417
   838
cg@1417
   839
isMethod                               
cg@1420
   840
    |cls|
cg@1420
   841
cg@1420
   842
    cls := classRef.
cg@1420
   843
    [cls notNil] whileTrue:[
cg@1420
   844
        cls name = 'Method' ifTrue:[^ true].
cg@1420
   845
        cls := cls superclass
cg@1420
   846
    ].
cg@1420
   847
    ^ false.
cg@1417
   848
!
cg@1417
   849
cg@1417
   850
isMethodDictionary
cg@1417
   851
    ^ classRef name = 'MethodDictionary'
cg@1417
   852
!
cg@1417
   853
cg@1417
   854
isMethodOrLazyMethod                 
cg@1417
   855
    classRef name = 'LazyMethod' ifTrue:[^ true].
cg@1420
   856
    ^ self isMethod
cg@1417
   857
!
cg@1417
   858
cg@1417
   859
isString                               
cg@1417
   860
    ^ classRef name = 'String'
cg@1417
   861
! !
cg@1417
   862
cg@1419
   863
!SnapShotImageMemory::ImageObject methodsFor:'method protocol'!
cg@1419
   864
cg@1419
   865
byteCode
cg@1419
   866
    |byteCodeSlotOffset byteCodePtr byteCodeRef byteCode|
cg@1419
   867
cg@1419
   868
    self isMethod ifTrue:[
cg@1419
   869
        byteCodeSlotOffset := Method instVarOffsetOf:'byteCode'.
cg@1419
   870
    ].
cg@1419
   871
    byteCodeSlotOffset notNil ifTrue:[
cg@1419
   872
        byteCodePtr := self at:byteCodeSlotOffset.
cg@1419
   873
        byteCodeRef := memory fetchObjectAt:byteCodePtr.
cg@1419
   874
        byteCodeRef isNil ifTrue:[^ nil].
cg@1419
   875
cg@1419
   876
        byteCode := memory fetchByteArrayFor:byteCodeRef.
cg@1419
   877
        ^ byteCode
cg@1419
   878
    ].
cg@1419
   879
cg@1419
   880
    self halt.
cg@1419
   881
!
cg@1419
   882
cg@1419
   883
comment
cg@1419
   884
    |src comment comments parser|
cg@1419
   885
cg@1419
   886
    self isMethod ifTrue:[
cg@1419
   887
        src := self source.
cg@1419
   888
        src isNil ifTrue:[^ nil].
cg@1419
   889
cg@1419
   890
        parser := Parser for:src in:nil.
cg@1419
   891
        parser ignoreErrors; ignoreWarnings; saveComments:true.
cg@1419
   892
        parser parseMethodSpec.
cg@1419
   893
        comments := parser comments.
cg@1419
   894
        comments size ~~ 0 ifTrue:[
cg@1419
   895
            comment := comments first string.
cg@1419
   896
            (comment withoutSpaces endsWith:'}') ifTrue:[
cg@1419
   897
                "if first comment is a pragma, take next comment"
cg@1419
   898
                comment := comments at:2 ifAbsent:nil.
cg@1419
   899
                comment notNil ifTrue:[
cg@1419
   900
                    comment := comment string.
cg@1419
   901
                ].
cg@1419
   902
            ].
cg@1417
   903
        ].
cg@1419
   904
        ^ comment.
cg@1416
   905
    ].
cg@1419
   906
    self isLazyMethod ifTrue:[
cg@1419
   907
        ^ ''
cg@1419
   908
    ].
cg@1419
   909
cg@1419
   910
    self halt.
cg@1416
   911
!
cg@1416
   912
cg@1419
   913
containingClass
cg@1419
   914
    self isMethodOrLazyMethod ifTrue:[
cg@1419
   915
        ^ self mclass
cg@1417
   916
    ].
cg@1440
   917
    self halt.
cg@1440
   918
!
cg@1419
   919
cg@1469
   920
flags
cg@1469
   921
    |flagsSlotOffset flagsPtr flags|
cg@1469
   922
cg@1469
   923
    self isMethod ifTrue:[
cg@1469
   924
        flagsSlotOffset := Method instVarOffsetOf:'flags'.
cg@1469
   925
    ].
cg@1469
   926
    flagsSlotOffset notNil ifTrue:[
cg@1469
   927
        flagsPtr := self at:flagsSlotOffset.
cg@1469
   928
        flags := memory fetchObjectAt:flagsPtr.
cg@1469
   929
        ^ flags
cg@1469
   930
    ].
cg@1469
   931
cg@1469
   932
    self halt.
cg@1469
   933
!
cg@1469
   934
cg@1419
   935
hasCode
cg@1440
   936
    ^ false
cg@1440
   937
!
cg@1419
   938
cg@1419
   939
isBreakpointed
cg@1440
   940
    ^ false
cg@1440
   941
!
cg@1419
   942
cg@1419
   943
isCounting
cg@1440
   944
    ^ false
cg@1440
   945
!
cg@1419
   946
cg@1419
   947
isCountingMemoryUsage
cg@1440
   948
    ^ false
cg@1440
   949
!
cg@1419
   950
cg@1419
   951
isDynamic
cg@1440
   952
    ^ false
cg@1440
   953
!
cg@1419
   954
cg@1419
   955
isExecutable
cg@1419
   956
    self isMethod ifTrue:[
cg@1419
   957
        ^ false
cg@1419
   958
    ].
cg@1440
   959
    self halt.
cg@1440
   960
!
cg@1419
   961
cg@1419
   962
isIgnored
cg@1440
   963
    ^ false
cg@1440
   964
!
cg@1419
   965
cg@1482
   966
isObsolete
cg@1482
   967
    ^ false
cg@1482
   968
!
cg@1482
   969
cg@1419
   970
isPrivate
cg@1440
   971
    ^ false
cg@1440
   972
!
cg@1419
   973
cg@1419
   974
isProtected
cg@1440
   975
    ^ false
cg@1440
   976
!
cg@1419
   977
cg@1419
   978
isPublic
cg@1440
   979
    ^ true
cg@1440
   980
!
cg@1419
   981
cg@1419
   982
isTimed
cg@1440
   983
    ^ false
cg@1440
   984
!
cg@1419
   985
cg@1419
   986
isTraced
cg@1440
   987
    ^ false
cg@1440
   988
!
cg@1417
   989
cg@1417
   990
isWrapped
cg@1417
   991
    ^ false
cg@1417
   992
!
cg@1417
   993
cg@1419
   994
mclass
cg@1419
   995
    |mclassSlotOffset mclassPtr mclass|
cg@1419
   996
cg@1419
   997
    self isMethod ifTrue:[
cg@1419
   998
        mclassSlotOffset := Method instVarOffsetOf:'mclass'.
cg@1420
   999
    ] ifFalse:[
cg@1420
  1000
        self isJavaMethod ifTrue:[
cg@1420
  1001
            mclassSlotOffset := JavaMethod instVarOffsetOf:'javaClass'.
cg@1420
  1002
        ]
cg@1420
  1003
    ].
cg@1420
  1004
cg@1420
  1005
    mclassSlotOffset notNil ifTrue:[
cg@1419
  1006
        mclassPtr := self at:mclassSlotOffset.
cg@1419
  1007
        mclassPtr ~~ 0 ifTrue:[
cg@1420
  1008
            mclassPtr isInteger ifTrue:[
cg@1420
  1009
                mclass := memory fetchObjectAt:mclassPtr.
cg@1420
  1010
                self at:mclassSlotOffset put:mclass.    
cg@1420
  1011
            ] ifFalse:[
cg@1420
  1012
                mclass := mclassPtr.
cg@1420
  1013
            ].
cg@1419
  1014
            mclass isImageBehavior ifFalse:[
cg@1419
  1015
                self halt
cg@1419
  1016
            ].
cg@1419
  1017
            ^ mclass
cg@1417
  1018
        ].
cg@1419
  1019
cg@1419
  1020
        "/ search my class ...
cg@1419
  1021
        memory image allClassesDo:[:eachClass |
cg@1419
  1022
            eachClass theNonMetaclass methodDictionary keysAndValuesDo:[:sel :mthdRef |
cg@1419
  1023
                mthdRef == self ifTrue:[
cg@1419
  1024
                    self at:mclassSlotOffset put:eachClass theNonMetaclass.    
cg@1419
  1025
                    ^ eachClass theNonMetaclass
cg@1419
  1026
                ].
cg@1419
  1027
            ].
cg@1419
  1028
            eachClass theMetaclass methodDictionary keysAndValuesDo:[:sel :mthdRef |
cg@1419
  1029
                mthdRef == self ifTrue:[
cg@1419
  1030
                    self at:mclassSlotOffset put:eachClass theMetaclass.    
cg@1419
  1031
                    ^ eachClass theMetaclass
cg@1419
  1032
                ].
cg@1419
  1033
            ]
cg@1419
  1034
        ].
cg@1419
  1035
        self halt.
cg@1420
  1036
        ^ nil.
cg@1417
  1037
    ].
cg@1420
  1038
    ^ nil.
cg@1419
  1039
    self halt.
cg@1417
  1040
!
cg@1417
  1041
cg@1419
  1042
numArgs
cg@1469
  1043
    |flags|
cg@1469
  1044
cg@1469
  1045
    flags := self flags.
cg@1469
  1046
    ^ (flags bitAnd:(Method numArgsMaskInFlags)) bitShift:(Method numArgsShiftInFlags negated)   
cg@1419
  1047
!
cg@1419
  1048
cg@1419
  1049
package
cg@1419
  1050
    |packageSlotOffset packagePtr packageRef package|
cg@1419
  1051
cg@1419
  1052
    self isImageBehavior ifTrue:[
cg@1419
  1053
        self isMeta ifTrue:[
cg@1419
  1054
            ^ self theNonMetaclass package
cg@1419
  1055
        ].
cg@1419
  1056
        packageSlotOffset := Class instVarOffsetOf:'package'.
cg@1420
  1057
    ] ifFalse:[
cg@1420
  1058
        self isMethod ifTrue:[
cg@1420
  1059
            packageSlotOffset := Method instVarOffsetOf:'package'.
cg@1420
  1060
        ] ifFalse:[
cg@1420
  1061
            self isLazyMethod ifTrue:[
cg@1420
  1062
                packageSlotOffset := Method instVarOffsetOf:'package'.
cg@1420
  1063
            ].
cg@1420
  1064
        ].
cg@1419
  1065
    ].
cg@1419
  1066
    packageSlotOffset notNil ifTrue:[
cg@1419
  1067
        packagePtr := self at:packageSlotOffset.
cg@1419
  1068
        packageRef := memory fetchObjectAt:packagePtr.
cg@1419
  1069
        packageRef isNil ifTrue:[^ nil].
cg@1419
  1070
cg@1419
  1071
        packageRef isImageSymbol ifFalse:[
cg@1420
  1072
            packageRef isImageBytes ifFalse:[
cg@1420
  1073
                self halt.
cg@1420
  1074
            ].
cg@1420
  1075
            "/ mhmh - can be a string sometimes ...
cg@1419
  1076
        ].
cg@1419
  1077
        package := memory fetchStringFor:packageRef.
cg@1419
  1078
        ^ package asSymbol
cg@1419
  1079
    ].
cg@1419
  1080
    self isMeta ifTrue:[
cg@1419
  1081
        self halt
cg@1419
  1082
    ].
cg@1419
  1083
cg@1420
  1084
    ^ nil
cg@1419
  1085
!
cg@1419
  1086
cg@1419
  1087
previousVersion
cg@1440
  1088
    ^ nil
cg@1440
  1089
!
cg@1419
  1090
cg@1417
  1091
printStringForBrowserWithSelector:selector
cg@1417
  1092
    ^ selector
cg@1417
  1093
!
cg@1417
  1094
sr@2164
  1095
printStringForBrowserWithSelector:selector inClass:aClass
sr@2164
  1096
    ^ selector
sr@2164
  1097
!
sr@2164
  1098
cg@1419
  1099
privacy
cg@1440
  1100
    ^ #public
cg@1440
  1101
!
cg@1419
  1102
cg@1417
  1103
resources
cg@1417
  1104
    ^ nil
cg@1417
  1105
!
cg@1417
  1106
cg@1417
  1107
source
cg@1482
  1108
    self halt:'unimplemented'.
cg@1416
  1109
!
cg@1416
  1110
cg@1419
  1111
sourceFilename
cg@1419
  1112
    "return the sourcefilename if source is extern; nil otherwise"
cg@1419
  1113
cg@1486
  1114
    |sourcePtr sourceRef source|
cg@1485
  1115
cg@1419
  1116
    self isMethodOrLazyMethod ifTrue:[
cg@1484
  1117
        self sourcePosition notNil ifTrue:[
cg@1486
  1118
            sourcePtr := self at:(Method instVarOffsetOf:'source').
cg@1486
  1119
            sourceRef := memory fetchObjectAt:sourcePtr.
cg@1486
  1120
            sourceRef isString ifFalse:[
cg@1486
  1121
                self halt.
cg@1485
  1122
            ].
cg@1486
  1123
            source := memory printStringOfString:sourceRef.
cg@1485
  1124
            ^ source.
cg@1484
  1125
        ].
cg@1419
  1126
        ^ nil
cg@1419
  1127
    ].
cg@1440
  1128
    self halt.
cg@1440
  1129
!
cg@1419
  1130
cg@1419
  1131
sourceLineNumber
cg@1419
  1132
    self isMethodOrLazyMethod ifTrue:[
cg@1419
  1133
        ^ 1
cg@1419
  1134
    ].
cg@1419
  1135
    self halt.
cg@1419
  1136
!
cg@1419
  1137
cg@1419
  1138
sourcePosition
cg@1419
  1139
    |sourcePosition|
cg@1419
  1140
cg@1419
  1141
    self isMethodOrLazyMethod ifTrue:[
cg@1419
  1142
        sourcePosition := self sourcePositionValue.
cg@1419
  1143
        sourcePosition isNil ifTrue:[^ sourcePosition].
cg@1419
  1144
        ^ sourcePosition abs
cg@1419
  1145
    ].
cg@1440
  1146
    self halt.
cg@1440
  1147
!
cg@1419
  1148
cg@1419
  1149
sourcePositionValue
cg@1419
  1150
    |sourcePosition sourcePositionPtr|
cg@1419
  1151
cg@1419
  1152
    self isMethodOrLazyMethod ifTrue:[
cg@1419
  1153
        sourcePositionPtr := self at:(Method instVarOffsetOf:'sourcePosition').
cg@1419
  1154
        sourcePosition := memory fetchObjectAt:sourcePositionPtr.
cg@1419
  1155
        ^ sourcePosition 
cg@1419
  1156
    ].
cg@1440
  1157
    self halt.
cg@1440
  1158
!
cg@1419
  1159
cg@1417
  1160
sourceStream
cg@1417
  1161
    |sourcePosition source aStream fileName junk who 
cg@1417
  1162
     myClass mgr className sep dir mod package|
cg@1416
  1163
cg@1417
  1164
    self isMethod ifTrue:[
cg@1417
  1165
        sourcePosition := self at:(Method instVarOffsetOf:'sourcePosition').
cg@1417
  1166
        source := self at:(Method instVarOffsetOf:'source').
cg@1417
  1167
        source := memory fetchObjectAt:source.
cg@1417
  1168
        source isString ifTrue:[
cg@1417
  1169
            source := memory printStringOfString:source.
cg@1417
  1170
        ].
cg@1417
  1171
        sourcePosition notNil ifTrue:[
cg@1417
  1172
            sourcePosition := memory fetchObjectAt:sourcePosition.
cg@1417
  1173
        ].
cg@1417
  1174
cg@1417
  1175
        source isNil ifTrue:[^ nil].
cg@1417
  1176
        sourcePosition isNil ifTrue:[^ source readStream].
cg@1417
  1177
cg@1417
  1178
        sourcePosition < 0 ifTrue:[
cg@1417
  1179
            aStream := source asFilename readStream.
cg@1417
  1180
            aStream notNil ifTrue:[
cg@1417
  1181
                ^ aStream
cg@1417
  1182
            ].
cg@1417
  1183
cg@1417
  1184
            fileName := Smalltalk getSourceFileName:source.
cg@1417
  1185
            fileName notNil ifTrue:[
cg@1417
  1186
                aStream := fileName asFilename readStream.
cg@1417
  1187
                aStream notNil ifTrue:[
cg@1417
  1188
                    ^ aStream
cg@1417
  1189
                ].
cg@1417
  1190
            ].
cg@1417
  1191
        ].
cg@1417
  1192
cg@1417
  1193
        "/
cg@1417
  1194
        "/ if there is no SourceManager, look in local standard places first
cg@1417
  1195
        "/
cg@1417
  1196
        (mgr := Smalltalk at:#SourceCodeManager) isNil ifTrue:[
cg@1417
  1197
            aStream := self localSourceStream.
cg@1417
  1198
            aStream notNil ifTrue:[
cg@1417
  1199
                ^ aStream
cg@1417
  1200
            ].
cg@1417
  1201
        ].
cg@1417
  1202
cg@1417
  1203
        "/
cg@1417
  1204
        "/ nope - ask my class for the source (this also invokes the SCMgr)
cg@1417
  1205
        "/
cg@1417
  1206
        myClass := self mclass.
cg@1417
  1207
cg@1417
  1208
        package := self package.
cg@1417
  1209
        (package notNil and:[package ~= myClass package]) ifTrue:[
cg@1417
  1210
            mgr notNil ifTrue:[
cg@1417
  1211
                "/ try to get the source using my package information ...
cg@1417
  1212
                sep := package indexOfAny:'/\:'.
cg@1417
  1213
                sep ~~ 0 ifTrue:[
cg@1417
  1214
                    mod := package copyTo:sep - 1.
cg@1417
  1215
                    dir := package copyFrom:sep + 1.
cg@1417
  1216
                    aStream := mgr streamForClass:nil fileName:source revision:nil directory:dir module:mod cache:true.
cg@1417
  1217
                    aStream notNil ifTrue:[
cg@1417
  1218
                        ^ aStream
cg@1417
  1219
                    ].
cg@1417
  1220
                ].
cg@1417
  1221
            ].
cg@1417
  1222
        ].
cg@1417
  1223
cg@1417
  1224
        aStream := myClass sourceStreamFor:source.
cg@1417
  1225
        aStream notNil ifTrue:[
cg@1417
  1226
            ^ aStream
cg@1417
  1227
        ].
cg@1417
  1228
cg@1417
  1229
        "/
cg@1417
  1230
        "/ nope - look in standard places 
cg@1417
  1231
        "/ (if there is a source-code manager - otherwise, we already did that)
cg@1417
  1232
        "/
cg@1417
  1233
        mgr notNil ifTrue:[
cg@1417
  1234
            aStream := self localSourceStream.
cg@1417
  1235
            aStream notNil ifTrue:[
cg@1417
  1236
                ^ aStream
cg@1417
  1237
            ].
cg@1417
  1238
        ].
cg@1417
  1239
cg@1417
  1240
        "/
cg@1417
  1241
        "/ final chance: try current directory
cg@1417
  1242
        "/
cg@1417
  1243
        aStream isNil ifTrue:[
cg@1417
  1244
            aStream := source asFilename readStream.
cg@1417
  1245
            aStream notNil ifTrue:[
cg@1417
  1246
                ^ aStream
cg@1417
  1247
            ].
cg@1417
  1248
        ].
cg@1417
  1249
cg@1417
  1250
        (who isNil and:[source notNil]) ifTrue:[
cg@1417
  1251
            "/
cg@1417
  1252
            "/ mhmh - seems to be a method which used to be in some
cg@1417
  1253
            "/ class, but has been overwritten by another or removed.
cg@1417
  1254
            "/ (i.e. it has no containing class anyMore)
cg@1417
  1255
            "/ try to guess the class from the sourceFileName.
cg@1417
  1256
            "/ and retry.
cg@1417
  1257
            "/
cg@1417
  1258
            className := Smalltalk classNameForFile:source.
cg@1417
  1259
            className knownAsSymbol ifTrue:[
cg@1417
  1260
                myClass := Smalltalk at:className asSymbol ifAbsent:nil.
cg@1417
  1261
                myClass notNil ifTrue:[
cg@1417
  1262
                    aStream := myClass sourceStreamFor:source.
cg@1417
  1263
                    aStream notNil ifTrue:[
cg@1417
  1264
                        ^ aStream
cg@1417
  1265
                    ].
cg@1417
  1266
                ]
cg@1417
  1267
            ]
cg@1417
  1268
        ].                
cg@1417
  1269
cg@1417
  1270
        ^ nil
cg@1417
  1271
    ].
cg@1416
  1272
    self halt.
cg@1416
  1273
! !
cg@1416
  1274
cg@1419
  1275
!SnapShotImageMemory::ImageObject methodsFor:'methodDictionary protocol'!
cg@1419
  1276
cg@1419
  1277
at:aSelector ifAbsent:exceptionValue
cg@1419
  1278
    self isMethodDictionary ifTrue:[
cg@1419
  1279
        cachedContents isNil ifTrue:[
cg@1419
  1280
            self cacheMethodDictionary.
cg@1419
  1281
        ].
cg@1419
  1282
        ^ cachedContents at:aSelector ifAbsent:exceptionValue
cg@1419
  1283
    ].
cg@1440
  1284
    self halt.
cg@1440
  1285
!
cg@1419
  1286
cg@1419
  1287
cacheMethodDictionary
cg@1419
  1288
    |symPtr symRef mthdPtr mthdRef s|
cg@1419
  1289
cg@1419
  1290
    cachedContents isNil ifTrue:[
cg@1419
  1291
        cachedContents := IdentityDictionary new.
cg@1419
  1292
cg@1419
  1293
        1 to:self size by:2 do:[:idx |
cg@1419
  1294
            symPtr := self at:idx.
cg@1419
  1295
            symRef := memory fetchObjectAt:symPtr.
cg@1419
  1296
            symRef isImageSymbol ifFalse:[self halt].
cg@1419
  1297
            s := memory fetchStringFor:symRef.
cg@1419
  1298
            mthdPtr := self at:idx + 1.
cg@1419
  1299
            mthdRef := memory fetchObjectAt:mthdPtr.
cg@1419
  1300
            cachedContents at:s asSymbol put:mthdRef.
cg@1419
  1301
        ].
cg@1440
  1302
    ].
cg@1440
  1303
!
cg@1419
  1304
cg@1419
  1305
do:aBlock
cg@1419
  1306
    self isMethodDictionary ifTrue:[
cg@1419
  1307
        cachedContents isNil ifTrue:[
cg@1419
  1308
            self cacheMethodDictionary.
cg@1419
  1309
        ].
cg@1419
  1310
        cachedContents do:aBlock.
cg@1419
  1311
        ^ self.
cg@1419
  1312
    ].
cg@1419
  1313
    self halt.
cg@1419
  1314
!
cg@1419
  1315
cg@1419
  1316
includesKey:aSelector
cg@1419
  1317
    self isMethodDictionary ifTrue:[
cg@1419
  1318
        cachedContents isNil ifTrue:[
cg@1419
  1319
            self cacheMethodDictionary.
cg@1419
  1320
        ].
cg@1419
  1321
        ^ cachedContents includesKey:aSelector
cg@1419
  1322
    ].
cg@1440
  1323
    self halt.
cg@1440
  1324
!
cg@1419
  1325
cg@1419
  1326
keyAtValue:aMethod ifAbsent:exceptionValue
cg@1419
  1327
    self isMethodDictionary ifTrue:[
cg@1419
  1328
        cachedContents isNil ifTrue:[
cg@1419
  1329
            self cacheMethodDictionary.
cg@1419
  1330
        ].
cg@1419
  1331
        ^ cachedContents keyAtValue:aMethod ifAbsent:exceptionValue
cg@1419
  1332
    ].
cg@1440
  1333
    self halt.
cg@1440
  1334
!
cg@1419
  1335
cg@1419
  1336
keysAndValuesDo:aBlock
cg@1419
  1337
    self isMethodDictionary ifTrue:[
cg@1419
  1338
        cachedContents isNil ifTrue:[
cg@1419
  1339
            self cacheMethodDictionary.
cg@1419
  1340
        ].
cg@1419
  1341
cg@1419
  1342
        cachedContents keysAndValuesDo:[:sel :mthdRef |
cg@1419
  1343
            aBlock value:sel value:mthdRef.
cg@1419
  1344
        ].
cg@1419
  1345
        ^ self
cg@1419
  1346
    ].
cg@1419
  1347
    self halt.
cg@1419
  1348
! !
cg@1419
  1349
cg@1448
  1350
!SnapShotImageMemory::ImageByteObject methodsFor:'queries'!
cg@1448
  1351
cg@1448
  1352
size
cg@1448
  1353
    ^ byteSize
cg@1448
  1354
! !
cg@1448
  1355
cg@1482
  1356
!SnapShotImageMemory::ImageMethodObject methodsFor:'method protocol'!
cg@1482
  1357
cg@1484
  1358
localSourceStream
cg@1484
  1359
    "try to open a stream from a local source file,
cg@1484
  1360
     searching in standard places."
cg@1484
  1361
cg@1484
  1362
    |fileName aStream package source|
cg@1484
  1363
cg@1484
  1364
    package := self package.
cg@1485
  1365
    source := self sourceFilename.
cg@1484
  1366
    package notNil ifTrue:[
cg@1484
  1367
        fileName := Smalltalk getSourceFileName:(package copyReplaceAll:$: with:$/) , '/' , source.
cg@1484
  1368
        fileName notNil ifTrue:[
cg@1484
  1369
            aStream := fileName asFilename readStream.
cg@1484
  1370
            aStream notNil ifTrue:[^ aStream].
cg@1484
  1371
        ].
cg@1484
  1372
    ].
cg@1484
  1373
    fileName := Smalltalk getSourceFileName:source.
cg@1484
  1374
    fileName notNil ifTrue:[
cg@1484
  1375
        aStream := fileName asFilename readStream.
cg@1484
  1376
        aStream notNil ifTrue:[^ aStream].
cg@1484
  1377
    ].
cg@1484
  1378
    ^ nil
cg@1484
  1379
!
cg@1484
  1380
cg@1552
  1381
mclass
cg@1552
  1382
    cachedMClass isNil ifTrue:[
cg@1552
  1383
        cachedMClass := super mclass.
cg@1552
  1384
    ].
cg@1552
  1385
    ^ cachedMClass
cg@1552
  1386
!
cg@1552
  1387
cg@1482
  1388
package
cg@1482
  1389
    |packageSlotOffset packagePtr packageRef package|
cg@1482
  1390
cg@1482
  1391
    cachedPackage isNil ifTrue:[
cg@1482
  1392
        packageSlotOffset := Method instVarOffsetOf:'package'.
cg@1482
  1393
cg@1482
  1394
        packagePtr := self at:packageSlotOffset.
cg@1482
  1395
        packageRef := memory fetchObjectAt:packagePtr.
cg@1482
  1396
        packageRef isNil ifTrue:[^ nil].
cg@1482
  1397
cg@1482
  1398
        packageRef isImageSymbol ifFalse:[
cg@1482
  1399
            packageRef isImageBytes ifFalse:[
cg@1482
  1400
                self halt.
cg@1482
  1401
            ].
cg@1482
  1402
            "/ mhmh - can be a string sometimes ...
cg@1482
  1403
        ].
cg@1482
  1404
        package := memory fetchStringFor:packageRef.
cg@1482
  1405
        cachedPackage := package asSymbol
cg@1482
  1406
    ].
cg@1482
  1407
    ^ cachedPackage
cg@1482
  1408
!
cg@1482
  1409
cg@1552
  1410
selector
cg@1552
  1411
    cachedSelector isNil ifTrue:[
cg@1552
  1412
        self mclass methodDictionary keysAndValuesDo:[:sel :mthd | mthd == self ifTrue:[cachedSelector := sel]].
cg@1552
  1413
    ].
cg@1552
  1414
    ^ cachedSelector
cg@1552
  1415
!
cg@1552
  1416
cg@1482
  1417
source
cg@1482
  1418
    |sourcePosition sourcePositionPtr sourcePtr sourceRef source aStream junk|
cg@1482
  1419
cg@1482
  1420
    sourcePositionPtr := self at:(Method instVarOffsetOf:'sourcePosition').
cg@1482
  1421
    sourcePtr := self at:(Method instVarOffsetOf:'source').
cg@1482
  1422
    sourceRef := memory fetchObjectAt:sourcePtr.
cg@1482
  1423
    sourceRef isString ifFalse:[
cg@1482
  1424
        self halt.
cg@1482
  1425
    ].
cg@1482
  1426
    source := memory printStringOfString:sourceRef.
cg@1482
  1427
    sourcePosition := memory fetchObjectAt:sourcePositionPtr.
cg@1482
  1428
    sourcePosition isNil ifTrue:[
cg@1482
  1429
        ^ source
cg@1482
  1430
    ].
cg@1482
  1431
cg@1482
  1432
    aStream := self sourceStream.
cg@1482
  1433
    aStream notNil ifTrue:[
cg@1482
  1434
        Stream positionErrorSignal handle:[:ex |
cg@1482
  1435
            ^ nil
cg@1482
  1436
        ] do:[
cg@1482
  1437
            aStream position:sourcePosition abs.
cg@1482
  1438
        ].
cg@1482
  1439
        junk := aStream nextChunk.
cg@1482
  1440
cg@1482
  1441
        aStream close.
cg@1482
  1442
        ^ junk
cg@1482
  1443
    ].
cg@1482
  1444
    self halt.
cg@1584
  1445
!
cg@1584
  1446
cg@1584
  1447
syntaxHighlighterClass
cg@1584
  1448
    ^ #askClass
cg@1482
  1449
! !
cg@1482
  1450
cg@1482
  1451
!SnapShotImageMemory::ImageMethodObject methodsFor:'queries'!
cg@1482
  1452
cg@1482
  1453
isMethod
cg@1482
  1454
    ^ true
sv@1865
  1455
!
sv@1865
  1456
sv@1865
  1457
previousVersionCode
sv@1865
  1458
    "return the receivers previous versions source code"
sv@1865
  1459
sv@1865
  1460
    "there is no previous version"
sv@1865
  1461
    ^ nil
sv@1866
  1462
!
sv@1866
  1463
sv@1866
  1464
sends:aSelectorSymbol
sv@1866
  1465
    "return true, if this method contains a message-send
sv@1866
  1466
     with aSelectorSymbol as selector."
sv@1866
  1467
sv@1866
  1468
"/    (self referencesLiteral:aSelectorSymbol) ifTrue:[
sv@1866
  1469
"/        ^ self messagesSent includesIdentical:aSelectorSymbol
sv@1866
  1470
"/    ].
sv@1866
  1471
    ^ false
cg@1482
  1472
! !
cg@1482
  1473
cg@1416
  1474
!SnapShotImageMemory::ImageClassObject methodsFor:'accessing - slots'!
cg@1416
  1475
cg@1417
  1476
category
cg@1482
  1477
    |categoryRef|
cg@1482
  1478
cg@1482
  1479
    cachedCategory isNil ifTrue:[
cg@1482
  1480
        categoryRef := self categorySlot.
cg@1482
  1481
        categoryRef isInteger ifTrue:[
cg@1482
  1482
            categoryRef := memory fetchObjectAt:categoryRef.
cg@1482
  1483
        ].
cg@1482
  1484
        categoryRef notNil ifTrue:[
cg@1482
  1485
            cachedCategory := memory fetchStringFor:categoryRef.
cg@1482
  1486
        ].
cg@1417
  1487
    ].
cg@1482
  1488
    ^ cachedCategory
cg@1417
  1489
!
cg@1417
  1490
cg@1416
  1491
categorySlot
cg@1440
  1492
    ^ self at:(Class instVarOffsetOf:'category')
cg@1440
  1493
!
cg@1419
  1494
cg@2130
  1495
classBaseFilename
cg@2130
  1496
    ^ self classFilename asFilename baseName
cg@2130
  1497
cg@2130
  1498
    "Created: / 19-10-2006 / 01:10:17 / cg"
cg@2130
  1499
!
cg@2130
  1500
cg@1419
  1501
classFilename
cg@1419
  1502
    |classFilenameRef classFilename|
cg@1419
  1503
cg@1419
  1504
    classFilenameRef := self classFilenameSlot.
cg@1419
  1505
    classFilenameRef isInteger ifTrue:[
cg@1419
  1506
        classFilenameRef := memory fetchObjectAt:classFilenameRef.
cg@1419
  1507
    ].
cg@1419
  1508
    classFilenameRef notNil ifTrue:[
cg@1419
  1509
        classFilename := memory fetchStringFor:classFilenameRef.
cg@1419
  1510
    ].
cg@1440
  1511
    ^ classFilename
cg@1440
  1512
!
cg@1416
  1513
cg@1416
  1514
classFilenameSlot
cg@1440
  1515
    ^ self at:(Class instVarOffsetOf:'classFilename')
cg@1440
  1516
!
cg@1416
  1517
cg@1417
  1518
classVarNames
cg@1417
  1519
    |classVarNamesRef classVarNames s|
cg@1417
  1520
cg@1417
  1521
    classVarNamesRef := self classVarsSlot.
cg@1417
  1522
    classVarNamesRef isInteger ifTrue:[
cg@1417
  1523
        classVarNamesRef := memory fetchObjectAt:classVarNamesRef.
cg@1417
  1524
    ].
cg@1417
  1525
    classVarNamesRef notNil ifTrue:[
cg@1417
  1526
        classVarNamesRef isImageBytes ifTrue:[
cg@1417
  1527
            "/ a string
cg@1417
  1528
            classVarNames := memory fetchStringFor:classVarNamesRef.
cg@1417
  1529
            classVarNames := classVarNames asCollectionOfWords.
cg@1417
  1530
        ] ifFalse:[
cg@1417
  1531
            classVarNames := Array new:(classVarNamesRef size).
cg@1417
  1532
            1 to:classVarNames size do:[:idx |
cg@1417
  1533
                s := classVarNamesRef at:idx.
cg@1417
  1534
                s := memory fetchObjectAt:s.
cg@1417
  1535
                s isImageBytes ifFalse:[self halt].
cg@1417
  1536
                s := memory fetchStringFor:s.
cg@1417
  1537
                classVarNames at:idx put:s.
cg@1417
  1538
            ].
cg@1417
  1539
        ].
cg@1417
  1540
    ].
cg@1482
  1541
    ^ classVarNames ? #()
cg@1417
  1542
!
cg@1417
  1543
cg@1419
  1544
classVariableString
cg@1419
  1545
    |classVarsPtr classVarsRef classVars|
cg@1419
  1546
cg@1419
  1547
    (classVarsPtr := self classVarsSlot) == 0 ifTrue:[^ ''].
cg@1419
  1548
    classVarsRef := memory fetchObjectAt:classVarsPtr.
cg@1419
  1549
    classVarsRef isImageBytes ifTrue:[
cg@1419
  1550
        "/ a string
cg@1419
  1551
        classVars := memory fetchStringFor:classVarsRef.
cg@1419
  1552
        ^ classVars
cg@1419
  1553
    ].
cg@1419
  1554
    ^ self classVarNames asStringWith:(Character space)
cg@1419
  1555
!
cg@1419
  1556
cg@1416
  1557
classVarsSlot
cg@1791
  1558
    ^ self at:(Class instVarOffsetOf:'classvars')
cg@1416
  1559
!
cg@1416
  1560
cg@1417
  1561
comment
cg@1417
  1562
    |commentRef comment|
cg@1417
  1563
cg@1417
  1564
    commentRef := self commentSlot.
cg@1417
  1565
    commentRef isInteger ifTrue:[
cg@1417
  1566
        commentRef := memory fetchObjectAt:commentRef.
cg@1417
  1567
    ].
cg@1417
  1568
    commentRef notNil ifTrue:[
cg@1417
  1569
        comment := memory fetchStringFor:commentRef.
cg@1417
  1570
    ].
cg@1417
  1571
    ^ comment
cg@1417
  1572
!
cg@1417
  1573
cg@1416
  1574
commentSlot
cg@1440
  1575
    ^ self at:(Class instVarOffsetOf:'comment')
cg@1440
  1576
!
cg@1416
  1577
cg@1417
  1578
flags
ps@1423
  1579
    |flags amount|
cg@1416
  1580
cg@1482
  1581
    cachedFlags isNil ifTrue:[
cg@1482
  1582
        flags := self flagsSlot.
cg@1482
  1583
cg@1482
  1584
        (SnapShotImageMemory isSmallIntegerOOP:flags) ifFalse:[
cg@1482
  1585
            self halt
cg@1482
  1586
        ].
cg@1482
  1587
        amount := -1.
cg@1482
  1588
        cachedFlags := flags bitShift:amount.
cg@1416
  1589
    ].
cg@1482
  1590
    ^ cachedFlags
cg@1416
  1591
!
cg@1416
  1592
cg@1417
  1593
flagsSlot
cg@1440
  1594
    ^ self at:(Class instVarOffsetOf:'flags')
cg@1440
  1595
!
cg@1419
  1596
cg@1419
  1597
instSize
cg@1419
  1598
    |instSizeRef|
cg@1419
  1599
cg@1419
  1600
    instSizeRef := self instSizeSlot.
cg@1440
  1601
    ^ memory fetchObjectAt:instSizeRef.
cg@1440
  1602
!
cg@1417
  1603
cg@1416
  1604
instSizeSlot
cg@1440
  1605
    ^ self at:(Class instVarOffsetOf:'instSize')
cg@1440
  1606
!
cg@1416
  1607
cg@1417
  1608
instVarNames
cg@1417
  1609
    |instVarNamesRef instVarNames s|
cg@1417
  1610
cg@1417
  1611
    instVarNamesRef := self instVarsSlot.
cg@1417
  1612
    instVarNamesRef isInteger ifTrue:[
cg@1417
  1613
        instVarNamesRef := memory fetchObjectAt:instVarNamesRef.
cg@1417
  1614
    ].
cg@1417
  1615
    instVarNamesRef notNil ifTrue:[
cg@1417
  1616
        instVarNamesRef isImageBytes ifTrue:[
cg@1417
  1617
            "/ a string
cg@1417
  1618
            instVarNames := memory fetchStringFor:instVarNamesRef.
cg@1417
  1619
            instVarNames := instVarNames asCollectionOfWords.
cg@1417
  1620
        ] ifFalse:[
cg@1417
  1621
            instVarNames := Array new:(instVarNamesRef size).
cg@1417
  1622
            1 to:instVarNames size do:[:idx |
cg@1417
  1623
                s := instVarNamesRef at:idx.
cg@1417
  1624
                s := memory fetchObjectAt:s.
cg@1417
  1625
                s isImageBytes ifFalse:[self halt].
cg@1417
  1626
                s := memory fetchStringFor:s.
cg@1417
  1627
                instVarNames at:idx put:s.
cg@1417
  1628
            ].
cg@1417
  1629
        ].
cg@1417
  1630
    ].
cg@1440
  1631
    ^ instVarNames ? #()
cg@1440
  1632
!
cg@1417
  1633
cg@1416
  1634
instVarsSlot
cg@1791
  1635
    ^ self at:(Class instVarOffsetOf:'instvars')
cg@1416
  1636
!
cg@1416
  1637
cg@1417
  1638
methodDictionary
cg@1417
  1639
    |methodDictionaryRef methodDictionary|
cg@1417
  1640
cg@1417
  1641
    methodDictionaryRef := self methodDictionarySlot.
cg@1417
  1642
    methodDictionaryRef isInteger ifTrue:[
cg@1417
  1643
        methodDictionaryRef == 0 ifTrue:[^ nil].
cg@1417
  1644
        methodDictionary := memory fetchObjectAt:methodDictionaryRef.
cg@1417
  1645
    ].
cg@1417
  1646
    ^ methodDictionary
cg@1417
  1647
!
cg@1417
  1648
cg@1416
  1649
methodDictionarySlot
cg@1440
  1650
    ^ self at:(Class instVarOffsetOf:'methodDictionary')
cg@1440
  1651
!
cg@1416
  1652
cg@1417
  1653
name
cg@1482
  1654
    |nameRef|
cg@1482
  1655
cg@1482
  1656
    cachedName isNil ifTrue:[
cg@1482
  1657
        self isMeta ifTrue:[
cg@1482
  1658
            cachedName := self theNonMetaclass name , ' class'
cg@1482
  1659
        ] ifFalse:[
cg@1792
  1660
            self isPrivateMeta ifTrue:[
cg@1792
  1661
self halt.
cg@1792
  1662
            ].
cg@1792
  1663
cg@1482
  1664
            nameRef := self nameSlot.
cg@1482
  1665
            nameRef isInteger ifTrue:[
cg@1482
  1666
                nameRef := memory fetchObjectAt:nameRef.
cg@1482
  1667
            ].
cg@1482
  1668
            nameRef notNil ifTrue:[
cg@1482
  1669
                cachedName := memory fetchStringFor:nameRef.
cg@1482
  1670
                cachedName := cachedName asSymbol
cg@1482
  1671
            ].
cg@1482
  1672
        ].
cg@1419
  1673
    ].
cg@1482
  1674
    ^ cachedName
cg@1417
  1675
!
cg@1417
  1676
cg@1416
  1677
nameSlot
cg@1440
  1678
    ^ self at:(Class instVarOffsetOf:'name')
cg@1440
  1679
!
cg@1419
  1680
cg@1419
  1681
packageSlot
cg@1440
  1682
    ^ self at:(Class instVarOffsetOf:'package')
cg@1440
  1683
!
cg@1419
  1684
cg@1419
  1685
primitiveSpec
cg@1419
  1686
    |primitiveSpecRef primitiveSpec|
cg@1419
  1687
cg@1419
  1688
    primitiveSpecRef := self primitiveSpecSlot.
cg@1419
  1689
    primitiveSpecRef isInteger ifTrue:[
cg@1419
  1690
        primitiveSpecRef := memory fetchObjectAt:primitiveSpecRef.
cg@1419
  1691
    ].
cg@1419
  1692
    primitiveSpecRef notNil ifTrue:[
cg@1419
  1693
        primitiveSpec := memory fetchStringFor:primitiveSpecRef.
cg@1419
  1694
    ].
cg@1419
  1695
    ^ primitiveSpec
cg@1416
  1696
!
cg@1416
  1697
cg@1419
  1698
primitiveSpecSlot
cg@1791
  1699
    (Class instVarOffsetOf:'primitiveSpec') isNil ifTrue:[
cg@1791
  1700
        ^ self at:(Class instVarOffsetOf:'attributes')
cg@1791
  1701
    ].
cg@1440
  1702
    ^ self at:(Class instVarOffsetOf:'primitiveSpec')
cg@1440
  1703
!
cg@1419
  1704
cg@1419
  1705
revision
cg@1419
  1706
    |revisionRef revision|
cg@1419
  1707
cg@1419
  1708
    revisionRef := self revisionSlot.
cg@1419
  1709
    revisionRef isInteger ifTrue:[
cg@1419
  1710
        revisionRef := memory fetchObjectAt:revisionRef.
cg@1419
  1711
    ].
cg@1419
  1712
    revisionRef notNil ifTrue:[
cg@1419
  1713
        revision := memory fetchStringFor:revisionRef.
cg@1419
  1714
    ].
cg@1440
  1715
    ^ revision
cg@1440
  1716
!
cg@1416
  1717
cg@1416
  1718
revisionSlot
cg@1791
  1719
    ^ self at:(Class instVarOffsetOf:'revision')
cg@1416
  1720
!
cg@1416
  1721
cg@1417
  1722
superclass
cg@1417
  1723
    |superClassRef superClass|
cg@1417
  1724
cg@1417
  1725
    superClassRef := self superclassSlot.
cg@1417
  1726
    superClassRef isInteger ifTrue:[
cg@1417
  1727
        superClass := memory fetchObjectAt:superClassRef.
cg@1417
  1728
    ].
cg@1417
  1729
    ^ superClass
cg@1417
  1730
!
cg@1417
  1731
cg@1417
  1732
superclassSlot
cg@1791
  1733
    ^ self at:(Class instVarOffsetOf:'superclass')
cg@1416
  1734
! !
cg@1416
  1735
cg@1417
  1736
!SnapShotImageMemory::ImageClassObject methodsFor:'class protocol'!
cg@1417
  1737
cg@1419
  1738
addAllClassVarNamesTo:aCollection
cg@1419
  1739
    "helper - add the name-strings of the class variables and of the class-vars
cg@1419
  1740
     of all superclasses to the argument, aCollection. Return aCollection"
cg@1419
  1741
cg@1419
  1742
    |classvars superclass|
cg@1419
  1743
cg@1419
  1744
    (superclass := self superclass) notNil ifTrue:[
cg@1419
  1745
        superclass addAllClassVarNamesTo:aCollection
cg@1419
  1746
    ].
cg@1419
  1747
    (classvars := self classVariableString) notNil ifTrue:[
cg@1419
  1748
        aCollection addAll:(classvars asCollectionOfWords).
cg@1419
  1749
    ].
cg@1440
  1750
    ^ aCollection
cg@1440
  1751
!
cg@1419
  1752
cg@1419
  1753
addAllInstVarNamesTo:aCollection
cg@1419
  1754
    |superInsts instvars superclass|
cg@1419
  1755
cg@1419
  1756
    (superclass := self superclass) notNil ifTrue:[
cg@1419
  1757
        self superclass addAllInstVarNamesTo:aCollection
cg@1419
  1758
    ].
cg@1419
  1759
    aCollection addAll:self instVarNames.
cg@1440
  1760
    ^ aCollection
cg@1440
  1761
!
cg@1440
  1762
cg@1440
  1763
addChangeRecordForClassFileOut:aClass
cg@1440
  1764
!
cg@1419
  1765
cg@1419
  1766
allClassVarNames
cg@1419
  1767
    "return a collection of all the class variable name-strings
cg@1419
  1768
     this includes all superclass-class variables"
cg@1419
  1769
cg@1440
  1770
    ^ self addAllClassVarNamesTo:(OrderedCollection new)
cg@1440
  1771
!
cg@1419
  1772
cg@1419
  1773
allInstVarNames
cg@1419
  1774
    self superclass isNil ifTrue:[^ self instVarNames].
cg@1440
  1775
    ^ self addAllInstVarNamesTo:(OrderedCollection new)
cg@1440
  1776
!
cg@1419
  1777
cg@1419
  1778
allSubclassesDo:aBlock
cg@1419
  1779
    "evaluate aBlock for all of my subclasses.
cg@1419
  1780
     There is no specific order, in which the entries are enumerated.
cg@1419
  1781
     Warning:
cg@1419
  1782
        This will only enumerate globally known classes - for anonymous
cg@1419
  1783
        behaviors, you have to walk over all instances of Behavior."
cg@1419
  1784
cg@1419
  1785
    self isMeta ifTrue:[
cg@1419
  1786
        "/ metaclasses are not found via Smalltalk allClassesDo:
cg@1419
  1787
        "/ here, walk over classes and enumerate corresponding metas.
cg@1419
  1788
        self soleInstance allSubclassesDo:[:aSubClass |
cg@1482
  1789
            aBlock value:(aSubClass theMetaclass)
cg@1419
  1790
        ].
cg@1419
  1791
    ] ifFalse:[
cg@1419
  1792
        Smalltalk allClassesDo:[:aClass |
cg@1419
  1793
            (aClass isSubclassOf:self) ifTrue:[
cg@1419
  1794
                aBlock value:aClass
cg@1419
  1795
            ]
cg@1419
  1796
        ]
cg@1419
  1797
    ]
cg@1419
  1798
cg@1419
  1799
    "
cg@1419
  1800
     Collection allSubclassesDo:[:c | Transcript showCR:(c name)]
cg@1419
  1801
     Collection class allSubclassesDo:[:c | Transcript showCR:(c name)]
cg@1419
  1802
    "
cg@1419
  1803
cg@1419
  1804
    "Modified: / 25.10.1997 / 21:17:13 / cg"
cg@1419
  1805
!
cg@1419
  1806
cg@1419
  1807
allSuperclasses
cg@1419
  1808
    "return a collection of the receivers accumulated superclasses"
cg@1419
  1809
cg@1419
  1810
    |aCollection theSuperClass|
cg@1419
  1811
cg@1419
  1812
    theSuperClass := self superclass.
cg@1419
  1813
    theSuperClass isNil ifTrue:[
cg@1419
  1814
        ^ #()
cg@1419
  1815
    ].
cg@1419
  1816
    aCollection := OrderedCollection new.
cg@1419
  1817
    [theSuperClass notNil] whileTrue:[
cg@1419
  1818
        aCollection add:theSuperClass.
cg@1419
  1819
        theSuperClass := theSuperClass superclass
cg@1419
  1820
    ].
cg@1419
  1821
    ^ aCollection
cg@1419
  1822
cg@1419
  1823
    "
cg@1419
  1824
     String allSuperclasses 
cg@1440
  1825
    "
cg@1440
  1826
!
cg@1419
  1827
cg@1419
  1828
allSuperclassesDo:aBlock
cg@1419
  1829
    "evaluate aBlock for all of my superclasses"
cg@1419
  1830
cg@1419
  1831
    |theClass|
cg@1419
  1832
cg@1419
  1833
    theClass := self superclass.
cg@1419
  1834
    [theClass notNil] whileTrue:[
cg@1419
  1835
        aBlock value:theClass.
cg@1419
  1836
        theClass := theClass superclass
cg@1419
  1837
    ]
cg@1419
  1838
cg@1419
  1839
    "
cg@1419
  1840
     String allSuperclassesDo:[:c | Transcript showCR:(c name)]
cg@1419
  1841
    "
cg@1419
  1842
!
cg@1419
  1843
cg@1419
  1844
basicFileOutDefinitionOn:aStream withNameSpace:forceNameSpace
cg@1419
  1845
    "append an expression on aStream, which defines myself."
cg@1419
  1846
cg@1419
  1847
    self
cg@1419
  1848
        basicFileOutDefinitionOn:aStream 
cg@1419
  1849
        withNameSpace:forceNameSpace 
cg@1440
  1850
        withPackage:true
cg@1440
  1851
!
cg@1419
  1852
cg@1417
  1853
basicFileOutDefinitionOn:aStream withNameSpace:forceNameSpace withPackage:showPackage
cg@1417
  1854
    "append an expression on aStream, which defines myself."
cg@1417
  1855
cg@1417
  1856
    |s owner ns nsName fullName superName cls topOwner
cg@1417
  1857
     syntaxHilighting superclass category|
cg@1417
  1858
cg@1417
  1859
    UserPreferences isNil ifTrue:[
cg@1417
  1860
        syntaxHilighting := false
cg@1417
  1861
    ] ifFalse:[
cg@1417
  1862
        syntaxHilighting := UserPreferences current syntaxColoring.
cg@1417
  1863
    ].
cg@1417
  1864
cg@1417
  1865
    owner := self owningClass.
cg@1417
  1866
cg@1417
  1867
    owner isNil ifTrue:[
cg@1417
  1868
        ns := self nameSpace.
cg@1417
  1869
    ] ifFalse:[
cg@1417
  1870
        ns := self topOwningClass nameSpace
cg@1417
  1871
    ].
cg@1417
  1872
    fullName := Class fileOutNameSpaceQuerySignal query == true.
cg@1417
  1873
cg@1417
  1874
    (showPackage and:[owner isNil]) ifTrue:[
cg@1417
  1875
        aStream nextPutAll:'"{ Package: '''.
cg@1417
  1876
        aStream nextPutAll:self package asString.
cg@1417
  1877
        aStream nextPutAll:''' }"'; cr; cr.
cg@1417
  1878
    ].
cg@1417
  1879
cg@1417
  1880
    ((owner isNil and:[fullName not])
cg@1417
  1881
    or:[owner notNil and:[forceNameSpace and:[fullName not]]]) ifTrue:[
cg@1417
  1882
        (ns notNil and:[ns ~~ Smalltalk]) ifTrue:[
cg@1417
  1883
            nsName := ns name.
cg@1417
  1884
            (nsName includes:$:) ifTrue:[
cg@1417
  1885
                nsName := '''' , nsName , ''''
cg@1417
  1886
            ].
cg@1417
  1887
"/            aStream nextPutLine:'"{ NameSpace: ' , nsName , ' }"'; cr.
cg@1417
  1888
            aStream nextPutAll:'"{ NameSpace: '.
cg@1417
  1889
            syntaxHilighting ifTrue:[aStream bold].
cg@1417
  1890
            aStream nextPutAll:nsName.
cg@1417
  1891
            syntaxHilighting ifTrue:[aStream normal].
cg@1417
  1892
            aStream nextPutAll:' }"'; cr; cr.
cg@1417
  1893
        ]
cg@1417
  1894
    ].
cg@1417
  1895
cg@1419
  1896
    superclass := self superclass.
cg@1419
  1897
    category := self category.
cg@1419
  1898
cg@1417
  1899
    "take care of nil-superclass"
cg@1417
  1900
    superclass isNil ifTrue:[
cg@1417
  1901
        s := 'nil'
cg@1417
  1902
    ] ifFalse:[
cg@1417
  1903
        fullName ifTrue:[
cg@1417
  1904
            superclass == owner ifTrue:[
cg@1417
  1905
                s := superclass nameWithoutNameSpacePrefix
cg@1417
  1906
            ] ifFalse:[
cg@1417
  1907
                s := superclass name
cg@1417
  1908
            ]
cg@1417
  1909
        ] ifFalse:[
cg@1417
  1910
            (ns == superclass nameSpace 
cg@1417
  1911
            and:[superclass owningClass isNil]) ifTrue:[
cg@1417
  1912
                "/ superclass is in the same namespace;
cg@1417
  1913
                "/ still prepend namespace prefix, to avoid
cg@1417
  1914
                "/ confusing stc, which needs that information ...
cg@1417
  1915
                s := superclass nameWithoutPrefix
cg@1417
  1916
            ] ifFalse:[
cg@1417
  1917
                "/ a very special (rare) situation:
cg@1417
  1918
                "/ my superclass resides in another nameSpace,
cg@1417
  1919
                "/ but there is something else named like this
cg@1417
  1920
                "/ to be found in my nameSpace (or a private class)
cg@1417
  1921
cg@1417
  1922
                superName := superclass nameWithoutNameSpacePrefix asSymbol.
cg@1417
  1923
                cls := self privateClassesAt:superName.
cg@1417
  1924
                cls isNil ifTrue:[
cg@1417
  1925
                    (topOwner := self topOwningClass) isNil ifTrue:[
cg@1417
  1926
                        ns := self nameSpace.
cg@1417
  1927
                        ns notNil ifTrue:[
cg@1417
  1928
                            cls := ns privateClassesAt:superName
cg@1417
  1929
                        ] ifFalse:[
cg@1417
  1930
                            "/ self error:'unexpected nil namespace'
cg@1417
  1931
                        ]
cg@1417
  1932
                    ] ifFalse:[
cg@1417
  1933
                        cls := topOwner nameSpace at:superName.
cg@1417
  1934
                    ]
cg@1417
  1935
                ].
cg@1417
  1936
                (cls notNil and:[cls ~~ superclass]) ifTrue:[
cg@1417
  1937
                    s := superclass nameSpace name , '::' , superName
cg@1417
  1938
                ] ifFalse:[
cg@1417
  1939
                    "/ no class with that name found in my namespace ...
cg@1417
  1940
                    "/ if the superclass resides in Smalltalk,
cg@1417
  1941
                    "/ suppress prefix; otherwise, use full prefix.
cg@1417
  1942
                    (superclass nameSpace notNil 
cg@1417
  1943
                    and:[superclass nameSpace ~~ Smalltalk]) ifTrue:[
cg@1417
  1944
                        (owner notNil 
cg@1417
  1945
                        and:[owner nameSpace == superclass owningClass nameSpace])
cg@1417
  1946
                        ifTrue:[
cg@1417
  1947
                            s := superclass nameWithoutNameSpacePrefix
cg@1417
  1948
                        ] ifFalse:[
cg@1417
  1949
                            s := superclass name
cg@1417
  1950
                        ]
cg@1417
  1951
                    ] ifFalse:[
cg@1417
  1952
                        s := superName
cg@1417
  1953
                    ]
cg@1417
  1954
                ]
cg@1417
  1955
            ]
cg@1417
  1956
        ]
cg@1417
  1957
    ].
cg@1417
  1958
cg@1417
  1959
    syntaxHilighting ifTrue:[aStream bold].
cg@1417
  1960
    aStream nextPutAll:s.   "/ superclass
cg@1417
  1961
    syntaxHilighting ifTrue:[aStream normal].
cg@1417
  1962
    aStream space.
cg@1417
  1963
    self basicFileOutInstvarTypeKeywordOn:aStream.
cg@1417
  1964
cg@1417
  1965
    (fullName and:[owner isNil]) ifTrue:[
cg@1417
  1966
        aStream nextPutAll:'#'''.
cg@1417
  1967
        syntaxHilighting ifTrue:[aStream bold].
cg@1417
  1968
        aStream nextPutAll:(self name).
cg@1417
  1969
        syntaxHilighting ifTrue:[aStream normal].
cg@1417
  1970
        aStream nextPutAll:''''.
cg@1417
  1971
    ] ifFalse:[
cg@1417
  1972
        aStream nextPut:$#.
cg@1417
  1973
        syntaxHilighting ifTrue:[aStream bold].
cg@1417
  1974
        aStream nextPutAll:(self nameWithoutPrefix).
cg@1417
  1975
        syntaxHilighting ifTrue:[aStream normal].
cg@1417
  1976
    ].
cg@1417
  1977
cg@1417
  1978
    aStream crtab. 
cg@1417
  1979
    aStream nextPutAll:'instanceVariableNames:'''.
cg@1417
  1980
    syntaxHilighting ifTrue:[aStream bold].
cg@1417
  1981
    self printInstVarNamesOn:aStream indent:16.
cg@1417
  1982
    syntaxHilighting ifTrue:[aStream normal].
cg@1417
  1983
    aStream nextPutAll:''''.
cg@1417
  1984
cg@1417
  1985
    aStream crtab.
cg@1417
  1986
    aStream nextPutAll:'classVariableNames:'''.
cg@1417
  1987
    syntaxHilighting ifTrue:[aStream bold].
cg@1417
  1988
    self printClassVarNamesOn:aStream indent:16.
cg@1417
  1989
    syntaxHilighting ifTrue:[aStream normal].
cg@1417
  1990
    aStream nextPutAll:''''.
cg@1417
  1991
cg@1417
  1992
    aStream crtab.
cg@1417
  1993
    aStream nextPutAll:'poolDictionaries:'''''.
cg@1417
  1994
cg@1417
  1995
    aStream crtab.
cg@1417
  1996
    owner isNil ifTrue:[
cg@1417
  1997
        "/ a public class
cg@1417
  1998
        aStream nextPutAll:'category:'.
cg@1417
  1999
        category isNil ifTrue:[
cg@1417
  2000
            s := ''''''
cg@1417
  2001
        ] ifFalse:[
cg@1417
  2002
            s := category asString storeString
cg@1417
  2003
        ].
cg@1417
  2004
        aStream nextPutAll:s.
cg@1417
  2005
    ] ifFalse:[
cg@1417
  2006
        "/ a private class
cg@1417
  2007
        aStream nextPutAll:'privateIn:'.
cg@1417
  2008
        syntaxHilighting ifTrue:[aStream bold].
cg@1417
  2009
"/        fullName ifTrue:[
cg@1417
  2010
"/            s := owner name.
cg@1417
  2011
"/        ] ifFalse:[
cg@1417
  2012
"/            s := owner nameWithoutNameSpacePrefix.
cg@1417
  2013
"/        ].
cg@1417
  2014
        s := owner nameWithoutNameSpacePrefix.
cg@1417
  2015
        aStream nextPutAll:s.
cg@1417
  2016
        syntaxHilighting ifTrue:[aStream normal].
cg@1417
  2017
    ].
cg@1417
  2018
    aStream cr
cg@1417
  2019
cg@1417
  2020
    "Created: / 4.1.1997 / 20:38:16 / cg"
cg@1417
  2021
    "Modified: / 8.8.1997 / 10:59:50 / cg"
cg@1440
  2022
    "Modified: / 18.3.1999 / 18:15:46 / stefan"
cg@1440
  2023
!
cg@1417
  2024
cg@1417
  2025
basicFileOutInstvarTypeKeywordOn:aStream
cg@1417
  2026
    "a helper for fileOutDefinition"
cg@1417
  2027
cg@1417
  2028
    |isVar s superclass|
cg@1417
  2029
cg@1417
  2030
    superclass := self superclass.
cg@1417
  2031
    superclass isNil ifTrue:[
cg@1417
  2032
        isVar := self isVariable
cg@1417
  2033
    ] ifFalse:[
cg@1417
  2034
        "I cant remember what this is for ?"
cg@1417
  2035
        isVar := (self isVariable and:[superclass isVariable not])
cg@1417
  2036
    ].
cg@1417
  2037
cg@1417
  2038
    aStream nextPutAll:(self firstDefinitionSelectorPart).
cg@1417
  2039
cg@1417
  2040
    "Created: 11.10.1996 / 18:57:29 / cg"
cg@1417
  2041
!
cg@1417
  2042
cg@1419
  2043
binaryRevision
cg@1419
  2044
    "return the revision-ID from which the class was stc-compiled;
cg@1419
  2045
     nil if its an autoloaded or filedIn class.
cg@1419
  2046
     If a classes binary is up-to-date w.r.t. the source repository,
cg@1419
  2047
     the returned string is the same as the one returned by #revision."
cg@1419
  2048
cg@1419
  2049
    |owner info c revision|
cg@1419
  2050
cg@1419
  2051
    revision := self revision.
cg@1419
  2052
cg@1419
  2053
    (owner := self owningClass) notNil ifTrue:[^ owner binaryRevision].
cg@1419
  2054
    revision notNil ifTrue:[
cg@1419
  2055
        c := revision first.
cg@1419
  2056
        c == $$ ifTrue:[
cg@1419
  2057
            info := Class revisionInfoFromString:revision.
cg@1419
  2058
            info isNil ifTrue:[^ '0'].
cg@1419
  2059
            ^ info at:#revision ifAbsent:'0'.
cg@1419
  2060
        ].
cg@1419
  2061
        c isDigit ifFalse:[
cg@1419
  2062
            ^ '0'
cg@1419
  2063
        ].
cg@1419
  2064
    ].
cg@1419
  2065
cg@1419
  2066
    ^ revision
cg@1419
  2067
cg@1419
  2068
    "
cg@1419
  2069
     Object binaryRevision
cg@1419
  2070
     Object class binaryRevision
cg@1419
  2071
    "
cg@1419
  2072
cg@1419
  2073
    "
cg@1419
  2074
     to find all classes which are not up-to-date:
cg@1419
  2075
cg@1419
  2076
     |classes|
cg@1419
  2077
cg@1419
  2078
     classes := Smalltalk allClasses 
cg@1419
  2079
                    select:[:cls | cls binaryRevision notNil and:[cls binaryRevision ~= cls revision]].
cg@1419
  2080
     SystemBrowser browseClasses:classes title:'classes which are not up-to-date'
cg@1419
  2081
    "
cg@1419
  2082
cg@1419
  2083
    "Created: 7.12.1995 / 10:58:47 / cg"
cg@1419
  2084
    "Modified: 1.4.1997 / 23:33:01 / stefan"
cg@1440
  2085
    "Modified: 9.9.1997 / 12:05:41 / cg"
cg@1440
  2086
!
cg@1419
  2087
cg@1417
  2088
compiledMethodAt:aSelector
cg@1417
  2089
cg@1417
  2090
    ^ self compiledMethodAt:aSelector ifAbsent:nil
cg@1417
  2091
!
cg@1417
  2092
cg@1417
  2093
compiledMethodAt:aSelector ifAbsent:exceptionValue
cg@1417
  2094
    |dict|
cg@1417
  2095
cg@1417
  2096
    dict := self methodDictionary.
cg@1417
  2097
    dict isNil ifTrue:[
cg@1417
  2098
        ('Behavior [warning]: nil methodDictionary in ' , self name printString) errorPrintCR.
cg@1417
  2099
        ^ exceptionValue value
cg@1417
  2100
    ].
cg@1417
  2101
cg@1417
  2102
    ^ dict at:aSelector ifAbsent:exceptionValue
cg@1417
  2103
!
cg@1417
  2104
cg@1417
  2105
evaluatorClass
cg@1417
  2106
    ^ Object evaluatorClass
cg@1417
  2107
!
cg@1417
  2108
cg@1419
  2109
fileOut
cg@1419
  2110
    |baseName dirName nm fileName|
cg@1419
  2111
cg@1419
  2112
    baseName := (Smalltalk fileNameForClass:self name).
cg@1419
  2113
    nm := baseName asFilename withSuffix:'st'.
cg@1419
  2114
cg@1419
  2115
    "
cg@1419
  2116
     this test allows a smalltalk to be built without Projects/ChangeSets
cg@1419
  2117
    "
cg@1419
  2118
    Project notNil ifTrue:[
cg@1419
  2119
        dirName := Project currentProjectDirectory
cg@1419
  2120
    ] ifFalse:[
cg@1419
  2121
        dirName := Filename currentDirectory
cg@1419
  2122
    ].
cg@1419
  2123
    fileName := (dirName asFilename construct:nm).
cg@1419
  2124
    fileName makeLegalFilename.
cg@1419
  2125
cg@1419
  2126
    self fileOutAs:fileName name.
cg@1419
  2127
cg@1419
  2128
"/    "
cg@1419
  2129
"/     add a change record; that way, administration is much easier,
cg@1419
  2130
"/     since we can see in that changeBrowser, which changes have 
cg@1419
  2131
"/     already found their way into a sourceFile and which must be
cg@1419
  2132
"/     applied again
cg@1419
  2133
"/    "
cg@1419
  2134
"/    self addChangeRecordForClassFileOut:self
cg@1419
  2135
cg@1419
  2136
    "Modified: / 7.6.1996 / 09:14:43 / stefan"
cg@1440
  2137
    "Modified: / 27.8.1998 / 02:02:57 / cg"
cg@1440
  2138
!
cg@1419
  2139
cg@1419
  2140
fileOutAllDefinitionsOn:aStream
cg@1419
  2141
    "append expressions on aStream, which defines myself and all of my private classes."
cg@1419
  2142
cg@1419
  2143
    self fileOutDefinitionOn:aStream.
cg@1419
  2144
    aStream nextPutChunkSeparator. 
cg@1419
  2145
    aStream cr; cr.
cg@1419
  2146
cg@1419
  2147
    "/
cg@1419
  2148
    "/ optional classInstanceVariables
cg@1419
  2149
    "/
cg@1419
  2150
    self classRef instanceVariableString isBlank ifFalse:[
cg@1419
  2151
        self fileOutClassInstVarDefinitionOn:aStream.
cg@1419
  2152
        aStream nextPutChunkSeparator. 
cg@1419
  2153
        aStream cr; cr
cg@1419
  2154
    ].
cg@1419
  2155
cg@1419
  2156
    "/ here, the full nameSpace prefixes are output,
cg@1419
  2157
    "/ to avoid confusing stc 
cg@1419
  2158
    "/ (which otherwise could not find the correct superclass)
cg@1419
  2159
    "/
cg@1419
  2160
    Class fileOutNameSpaceQuerySignal answer:true do:[
cg@1419
  2161
        self privateClassesSorted do:[:aClass |
cg@1419
  2162
            aClass fileOutAllDefinitionsOn:aStream
cg@1419
  2163
        ]
cg@1419
  2164
    ].
cg@1419
  2165
cg@1419
  2166
    "Created: 15.10.1996 / 11:15:19 / cg"
cg@1440
  2167
    "Modified: 22.3.1997 / 16:11:56 / cg"
cg@1440
  2168
!
cg@1419
  2169
cg@1791
  2170
fileOutAllMethodsOn:aStream methodFilter:methodFilter
cg@1791
  2171
    |collectionOfCategories|
cg@1791
  2172
cg@1792
  2173
    collectionOfCategories := self theMetaclass categories asSortedCollection.
cg@1791
  2174
    collectionOfCategories notNil ifTrue:[
cg@1791
  2175
        collectionOfCategories do:[:aCategory |
cg@1792
  2176
            self theMetaclass fileOutCategory:aCategory methodFilter:methodFilter on:aStream.
cg@1791
  2177
            aStream cr
cg@1791
  2178
        ]
cg@1791
  2179
    ].
cg@1791
  2180
    collectionOfCategories := self categories asSortedCollection.
cg@1791
  2181
    collectionOfCategories notNil ifTrue:[
cg@1791
  2182
        collectionOfCategories do:[:aCategory |
cg@1791
  2183
            self fileOutCategory:aCategory methodFilter:methodFilter on:aStream.
cg@1791
  2184
            aStream cr
cg@1791
  2185
        ]
cg@1791
  2186
    ].
cg@1791
  2187
cg@1791
  2188
    self privateClassesSorted do:[:aClass |
cg@1791
  2189
        aClass fileOutAllMethodsOn:aStream methodFilter:methodFilter
cg@1791
  2190
    ].
cg@1791
  2191
!
cg@1791
  2192
cg@1419
  2193
fileOutAs:fileNameString
cg@1419
  2194
    "create a file consisting of all methods in myself in
cg@1419
  2195
     sourceForm, from which the class can be reconstructed (by filing in).
cg@1419
  2196
     The given fileName should be a full path, including suffix.
cg@1419
  2197
     Care is taken, to not clobber any existing file in
cg@1419
  2198
     case of errors (for example: disk full). 
cg@1419
  2199
     Also, since the classes methods need a valid sourcefile, the current 
cg@1419
  2200
     sourceFile may not be rewritten."
cg@1419
  2201
cg@1419
  2202
    |aStream fileName newFileName savFilename needRename
cg@1419
  2203
     mySourceFileName sameFile s mySourceFileID anySourceRef|
cg@1419
  2204
cg@1419
  2205
    self isLoaded ifFalse:[
cg@1419
  2206
        ^ Class fileOutErrorSignal 
cg@1419
  2207
            raiseRequestWith:self
cg@1419
  2208
                 errorString:'will not fileOut unloaded classes'
cg@1419
  2209
    ].
cg@1419
  2210
cg@1419
  2211
    fileName := fileNameString asFilename.
cg@1419
  2212
cg@1419
  2213
    "
cg@1419
  2214
     if file exists, copy the existing to a .sav-file,
cg@1419
  2215
     create the new file as XXX.new-file,
cg@1419
  2216
     and, if that worked rename afterwards ...
cg@1419
  2217
    "
cg@1419
  2218
    (fileName exists) ifTrue:[
cg@1419
  2219
        sameFile := false.
cg@1419
  2220
cg@1419
  2221
        "/ check carefully - maybe, my source does not really come from that
cg@1419
  2222
        "/ file (i.e. all of my methods have their source as string)
cg@1419
  2223
cg@1419
  2224
        anySourceRef := false.
cg@1419
  2225
        self methodDictionary do:[:m|
cg@1419
  2226
            m sourcePosition notNil ifTrue:[
cg@1419
  2227
                anySourceRef := true
cg@1419
  2228
            ]
cg@1419
  2229
        ].
cg@1419
  2230
        self classRef methodDictionary do:[:m|
cg@1419
  2231
            m sourcePosition notNil ifTrue:[
cg@1419
  2232
                anySourceRef := true
cg@1419
  2233
            ]
cg@1419
  2234
        ].
cg@1419
  2235
cg@1419
  2236
        anySourceRef ifTrue:[
cg@1419
  2237
            s := self sourceStream.
cg@1419
  2238
            s notNil ifTrue:[
cg@1419
  2239
                mySourceFileID := s pathName asFilename info id.
cg@1419
  2240
                sameFile := (fileName info id) == mySourceFileID.
cg@1419
  2241
                s close.
cg@1419
  2242
            ] ifFalse:[
cg@1419
  2243
                self classFilename notNil ifTrue:[
cg@1419
  2244
                    "
cg@1419
  2245
                     check for overwriting my current source file
cg@1419
  2246
                     this is not allowed, since it would clobber my methods source
cg@1419
  2247
                     file ... you have to save it to some other place.
cg@1419
  2248
                     This happens if you ask for a fileOut into the source-directory
cg@1419
  2249
                     (from which my methods get their source)
cg@1419
  2250
                    "
cg@1419
  2251
                    mySourceFileName := Smalltalk getSourceFileName:self classFilename. 
cg@1419
  2252
                    sameFile := (fileNameString = mySourceFileName).
cg@1419
  2253
                    sameFile ifFalse:[
cg@1419
  2254
                        mySourceFileName notNil ifTrue:[
cg@1419
  2255
                            sameFile := (fileName info id) == (mySourceFileName asFilename info id)
cg@1419
  2256
                        ]
cg@1419
  2257
                    ].
cg@1419
  2258
                ]
cg@1419
  2259
            ].
cg@1419
  2260
        ].
cg@1419
  2261
cg@1419
  2262
        sameFile ifTrue:[
cg@1419
  2263
            ^ Class fileOutErrorSignal 
cg@1419
  2264
                raiseRequestWith:fileNameString
cg@1419
  2265
                errorString:('may not overwrite sourcefile:', fileNameString)
cg@1419
  2266
        ].
cg@1419
  2267
cg@1419
  2268
        savFilename := Filename newTemporary.
cg@1419
  2269
        fileName copyTo:savFilename.
cg@1419
  2270
        newFileName := fileName withSuffix:'new'.
cg@1419
  2271
        needRename := true
cg@1419
  2272
    ] ifFalse:[
cg@1419
  2273
        "/ another possible trap: if my sourceFileName is
cg@1419
  2274
        "/ the same as the written one AND the new files directory
cg@1419
  2275
        "/ is along the sourcePath, we also need a temporary file
cg@1419
  2276
        "/ first, to avoid accessing the newly written file.
cg@1419
  2277
cg@1419
  2278
        anySourceRef := false.
cg@1419
  2279
        self methodDictionary do:[:m|
cg@1419
  2280
            |mSrc|
cg@1419
  2281
cg@1419
  2282
            (mSrc := m sourceFilename) notNil ifTrue:[
cg@1419
  2283
                mSrc asFilename baseName = fileName baseName ifTrue:[
cg@1419
  2284
                    anySourceRef := true
cg@1419
  2285
                ]
cg@1419
  2286
            ]
cg@1419
  2287
        ].
cg@1419
  2288
        self classRef methodDictionary do:[:m|
cg@1419
  2289
            |mSrc|
cg@1419
  2290
cg@1419
  2291
            (mSrc := m sourceFilename) notNil ifTrue:[
cg@1419
  2292
                mSrc asFilename baseName = fileName baseName ifTrue:[
cg@1419
  2293
                    anySourceRef := true
cg@1419
  2294
                ]
cg@1419
  2295
            ]
cg@1419
  2296
        ].
cg@1419
  2297
        anySourceRef ifTrue:[
cg@1419
  2298
            newFileName := fileName withSuffix:'new'.
cg@1419
  2299
            needRename := true
cg@1419
  2300
        ] ifFalse:[
cg@1419
  2301
            newFileName := fileName.
cg@1419
  2302
            needRename := false
cg@1419
  2303
        ]
cg@1419
  2304
    ].
cg@1419
  2305
cg@1419
  2306
    aStream := newFileName writeStream.
cg@1419
  2307
    aStream isNil ifTrue:[
cg@1419
  2308
        savFilename notNil ifTrue:[
cg@1419
  2309
            savFilename delete
cg@1419
  2310
        ].
cg@1419
  2311
        ^ Class fileOutErrorSignal 
cg@1419
  2312
                raiseRequestWith:newFileName
cg@1419
  2313
                errorString:('cannot create file:', newFileName name)
cg@1419
  2314
    ].
cg@1419
  2315
    self fileOutOn:aStream.
cg@1419
  2316
    aStream close.
cg@1419
  2317
cg@1419
  2318
    "
cg@1419
  2319
     finally, replace the old-file
cg@1419
  2320
     be careful, if the old one is a symbolic link; in this case,
cg@1419
  2321
     we have to do a copy ...
cg@1419
  2322
    "
cg@1419
  2323
    needRename ifTrue:[
cg@1419
  2324
        newFileName copyTo:fileName.
cg@1419
  2325
        newFileName delete
cg@1419
  2326
    ].
cg@1419
  2327
    savFilename notNil ifTrue:[
cg@1419
  2328
        savFilename delete
cg@1419
  2329
    ].
cg@1419
  2330
cg@1419
  2331
    "
cg@1419
  2332
     add a change record; that way, administration is much easier,
cg@1419
  2333
     since we can see in that changeBrowser, which changes have 
cg@1419
  2334
     already found their way into a sourceFile and which must be
cg@1419
  2335
     applied again
cg@1419
  2336
    "
cg@1419
  2337
    self addChangeRecordForClassFileOut:self
cg@1419
  2338
cg@1419
  2339
    "Modified: / 7.6.1996 / 09:14:43 / stefan"
cg@1419
  2340
    "Created: / 16.4.1997 / 20:44:05 / cg"
cg@1440
  2341
    "Modified: / 12.8.1998 / 11:14:56 / cg"
cg@1440
  2342
!
cg@1419
  2343
cg@1419
  2344
fileOutCategory:aCategory
cg@1419
  2345
    "create a file 'class-category.st' consisting of all methods in aCategory.
cg@1419
  2346
     If the current project is not nil, create the file in the projects
cg@1419
  2347
     directory."
cg@1419
  2348
cg@1419
  2349
    |aStream fileName|
cg@1419
  2350
cg@1419
  2351
    fileName := (self name , '-' , aCategory , '.st') asFilename.
cg@1419
  2352
    fileName makeLegalFilename.
cg@1419
  2353
cg@1419
  2354
    "/
cg@1419
  2355
    "/ this test allows a smalltalk to be built without Projects/ChangeSets
cg@1419
  2356
    "/
cg@1419
  2357
    Project notNil ifTrue:[
cg@1419
  2358
        fileName := Project currentProjectDirectory asFilename construct:(fileName name).
cg@1419
  2359
    ].
cg@1419
  2360
cg@1419
  2361
    "/
cg@1419
  2362
    "/ if the file exists, save original in a .sav file
cg@1419
  2363
    "/
cg@1419
  2364
    fileName exists ifTrue:[
cg@1419
  2365
        fileName copyTo:(fileName withSuffix:'sav')
cg@1419
  2366
    ].
cg@1419
  2367
    aStream := FileStream newFileNamed:fileName.
cg@1419
  2368
    aStream isNil ifTrue:[
cg@1419
  2369
        ^ Class fileOutErrorSignal 
cg@1419
  2370
                raiseRequestWith:fileName
cg@1419
  2371
                errorString:('cannot create file:', fileName pathName)
cg@1419
  2372
    ].
cg@1419
  2373
cg@1419
  2374
    self fileOutCategory:aCategory on:aStream.
cg@1419
  2375
    aStream close
cg@1419
  2376
cg@1419
  2377
    "Modified: / 1.4.1997 / 16:00:24 / stefan"
cg@1419
  2378
    "Created: / 1.4.1997 / 16:04:18 / stefan"
cg@1440
  2379
    "Modified: / 28.10.1997 / 14:40:28 / cg"
cg@1440
  2380
!
cg@1419
  2381
cg@1419
  2382
fileOutCategory:aCategory except:skippedMethods only:savedMethods methodFilter:methodFilter on:aStream
cg@1419
  2383
    |dict source sortedSelectors first privacy interestingMethods cat|
cg@1419
  2384
cg@1419
  2385
    dict := self methodDictionary.
cg@1419
  2386
    dict notNil ifTrue:[
cg@1419
  2387
        interestingMethods := OrderedCollection new.
cg@1419
  2388
        dict do:[:aMethod |
cg@1419
  2389
            |wanted|
cg@1419
  2390
cg@1419
  2391
            (methodFilter isNil
cg@1419
  2392
            or:[methodFilter value:aMethod]) ifTrue:[
cg@1419
  2393
                (aCategory = aMethod category) ifTrue:[
cg@1419
  2394
                    skippedMethods notNil ifTrue:[
cg@1419
  2395
                        wanted := (skippedMethods includesIdentical:aMethod) not
cg@1419
  2396
                    ] ifFalse:[
cg@1419
  2397
                        savedMethods notNil ifTrue:[
cg@1419
  2398
                            wanted := (savedMethods includesIdentical:aMethod).
cg@1419
  2399
                        ] ifFalse:[
cg@1419
  2400
                            wanted := true
cg@1419
  2401
                        ]
cg@1419
  2402
                    ].
cg@1419
  2403
                    wanted ifTrue:[interestingMethods add:aMethod].
cg@1419
  2404
                ]
cg@1419
  2405
            ]
cg@1419
  2406
        ].
cg@1419
  2407
        interestingMethods notEmpty ifTrue:[
cg@1419
  2408
            first := true.
cg@1419
  2409
            privacy := nil.
cg@1419
  2410
cg@1419
  2411
            "/
cg@1419
  2412
            "/ sort by selector
cg@1419
  2413
            "/
cg@1419
  2414
            sortedSelectors := interestingMethods collect:[:m | self selectorAtMethod:m].
cg@1419
  2415
            sortedSelectors sortWith:interestingMethods.
cg@1419
  2416
cg@1419
  2417
            interestingMethods do:[:aMethod |
cg@1419
  2418
                first ifFalse:[
cg@1419
  2419
                    privacy ~~ aMethod privacy ifTrue:[
cg@1419
  2420
                        first := true.
cg@1419
  2421
                        aStream space.
cg@1419
  2422
                        aStream nextPutChunkSeparator.
cg@1419
  2423
                    ].
cg@1419
  2424
                    aStream cr; cr
cg@1419
  2425
                ].
cg@1419
  2426
cg@1419
  2427
                privacy := aMethod privacy.
cg@1419
  2428
cg@1419
  2429
                first ifTrue:[
cg@1419
  2430
                    aStream nextPutChunkSeparator.
cg@1419
  2431
                    self printClassNameOn:aStream.
cg@1419
  2432
                    privacy ~~ #public ifTrue:[
cg@1419
  2433
                        aStream space; nextPutAll:privacy; nextPutAll:'MethodsFor:'.
cg@1419
  2434
                    ] ifFalse:[
cg@1419
  2435
                        aStream nextPutAll:' methodsFor:'.
cg@1419
  2436
                    ].
cg@1419
  2437
                    cat := aCategory.
cg@1419
  2438
                    cat isNil ifTrue:[ cat := '' ].
cg@1419
  2439
                    aStream nextPutAll:aCategory asString storeString.
cg@1419
  2440
                    aStream nextPutChunkSeparator; cr; cr.
cg@1419
  2441
                    first := false.
cg@1419
  2442
                ].
cg@1419
  2443
                source := aMethod source.
cg@1419
  2444
                source isNil ifTrue:[
cg@1419
  2445
                    Class fileOutErrorSignal 
cg@1419
  2446
                        raiseRequestWith:self
cg@1419
  2447
                        errorString:'no source for method: ', (aMethod displayString)
cg@1419
  2448
                ] ifFalse:[
cg@1419
  2449
                    aStream nextChunkPut:source.
cg@1419
  2450
                ].
cg@1419
  2451
            ].
cg@1419
  2452
            aStream space.
cg@1419
  2453
            aStream nextPutChunkSeparator.
cg@1419
  2454
            aStream cr
cg@1419
  2455
        ]
cg@1419
  2456
    ]
cg@1419
  2457
cg@1419
  2458
    "Modified: 28.8.1995 / 14:30:41 / claus"
cg@1419
  2459
    "Modified: 12.6.1996 / 11:37:33 / stefan"
cg@1419
  2460
    "Modified: 15.11.1996 / 11:32:21 / cg"
cg@1440
  2461
    "Created: 1.4.1997 / 16:04:33 / stefan"
cg@1440
  2462
!
cg@1419
  2463
cg@1419
  2464
fileOutCategory:aCategory methodFilter:methodFilter on:aStream
cg@1419
  2465
    "file out all methods belonging to aCategory, aString onto aStream"
cg@1419
  2466
cg@1440
  2467
    self fileOutCategory:aCategory except:nil only:nil methodFilter:methodFilter on:aStream
cg@1440
  2468
!
cg@1419
  2469
cg@1419
  2470
fileOutCategory:aCategory on:aStream
cg@1419
  2471
    Class fileOutNameSpaceQuerySignal answer:true do:[
cg@1419
  2472
        self fileOutCategory:aCategory except:nil only:nil methodFilter:nil on:aStream
cg@1440
  2473
    ]
cg@1440
  2474
!
cg@1419
  2475
cg@1419
  2476
fileOutClassInstVarDefinitionOn:aStream withNameSpace:withNameSpace
cg@1419
  2477
    "append an expression to define my classInstanceVariables on aStream"
cg@1419
  2478
cg@1419
  2479
    |anySuperClassInstVar|
cg@1419
  2480
cg@1419
  2481
    self isLoaded ifFalse:[
cg@1419
  2482
        ^ self basicFileOutDefinitionOn:aStream withNameSpace:withNameSpace
cg@1419
  2483
    ].
cg@1419
  2484
cg@1419
  2485
    withNameSpace ifTrue:[
cg@1419
  2486
        self name printOn:aStream.
cg@1419
  2487
    ] ifFalse:[
cg@1419
  2488
        self printClassNameOn:aStream.
cg@1419
  2489
    ].
cg@1419
  2490
    aStream nextPutAll:' class instanceVariableNames:'''.
cg@1482
  2491
    self theMetaclass printInstVarNamesOn:aStream indent:8.
cg@1419
  2492
    aStream nextPutAll:''''.
cg@1419
  2493
cg@1419
  2494
    "mhmh - good idea; saw this in SmallDraw sourcecode ..."
cg@1419
  2495
cg@1419
  2496
    anySuperClassInstVar := false.
cg@1419
  2497
    self allSuperclassesDo:[:aSuperClass |
cg@1482
  2498
        aSuperClass theMetaclass instVarNames do:[:ignored | anySuperClassInstVar := true].
cg@1419
  2499
    ].
cg@1419
  2500
cg@1419
  2501
    aStream cr; cr; nextPut:(Character doubleQuote); cr; space.
cg@1419
  2502
    anySuperClassInstVar ifFalse:[
cg@1419
  2503
        aStream  
cg@1419
  2504
            nextPutLine:'No other class instance variables are inherited by this class.'.
cg@1419
  2505
    ] ifTrue:[
cg@1419
  2506
        aStream  
cg@1419
  2507
            nextPutLine:'The following class instance variables are inherited by this class:'.
cg@1419
  2508
        aStream cr.
cg@1419
  2509
        self allSuperclassesDo:[:aSuperClass |
cg@1419
  2510
            aStream tab; nextPutAll:aSuperClass name; nextPutAll:' - '.
cg@1482
  2511
            aStream nextPutLine:(aSuperClass theMetaclass instanceVariableString).
cg@1419
  2512
        ].
cg@1419
  2513
cg@1419
  2514
    ].
cg@1419
  2515
    aStream nextPut:(Character doubleQuote); cr.
cg@1419
  2516
cg@1419
  2517
    "Created: / 10.12.1995 / 16:31:25 / cg"
cg@1419
  2518
    "Modified: / 1.4.1997 / 16:00:33 / stefan"
cg@1419
  2519
    "Modified: / 3.2.2000 / 23:05:28 / cg"
cg@1419
  2520
!
cg@1419
  2521
cg@1864
  2522
fileOutCommentOn:aStream
cg@1864
  2523
    "append an expression on aStream, which defines my comment"
cg@1864
  2524
cg@1864
  2525
    |comment s|
cg@1864
  2526
cg@1864
  2527
    self printClassNameOn:aStream.
cg@1864
  2528
    aStream nextPutAll:' comment:'.
cg@1864
  2529
    (comment := self comment) isNil ifTrue:[
cg@1864
  2530
        s := ''''''
cg@1864
  2531
    ] ifFalse:[
cg@1864
  2532
        s := comment storeString
cg@1864
  2533
    ].
cg@1864
  2534
    aStream nextPutAllAsChunk:s.
cg@1864
  2535
    aStream nextPutChunkSeparator.
cg@1864
  2536
    aStream cr
cg@1864
  2537
!
cg@1864
  2538
cg@1419
  2539
fileOutDefinitionOn:aStream
cg@1419
  2540
    "append an expression on aStream, which defines myself."
cg@1419
  2541
cg@1440
  2542
    ^ self basicFileOutDefinitionOn:aStream withNameSpace:false
cg@1440
  2543
!
cg@1419
  2544
cg@1419
  2545
fileOutMethod:aMethod
cg@1419
  2546
    |aStream fileName selector|
cg@1419
  2547
cg@1419
  2548
    selector := self selectorAtMethod:aMethod.
cg@1419
  2549
    selector notNil ifTrue:[
cg@1419
  2550
        fileName := (self name , '-' , selector, '.st') asFilename.
cg@1419
  2551
        fileName makeLegalFilename.
cg@1419
  2552
cg@1419
  2553
        "
cg@1419
  2554
         this test allows a smalltalk to be built without Projects/ChangeSets
cg@1419
  2555
        "
cg@1419
  2556
        Project notNil ifTrue:[
cg@1419
  2557
            fileName := Project currentProjectDirectory asFilename construct:fileName name.
cg@1419
  2558
        ].
cg@1419
  2559
cg@1419
  2560
        "
cg@1419
  2561
         if file exists, save original in a .sav file
cg@1419
  2562
        "
cg@1419
  2563
        fileName exists ifTrue:[
cg@1419
  2564
            fileName copyTo:(fileName withSuffix: 'sav')
cg@1419
  2565
        ].
cg@1419
  2566
cg@1419
  2567
        fileName := fileName name.
cg@1419
  2568
cg@1419
  2569
        aStream := FileStream newFileNamed:fileName.
cg@1419
  2570
        aStream isNil ifTrue:[
cg@1419
  2571
            ^ Class fileOutErrorSignal 
cg@1419
  2572
                raiseRequestWith:fileName
cg@1419
  2573
                errorString:('cannot create file:', fileName)
cg@1419
  2574
        ].
cg@1419
  2575
        self fileOutMethod:aMethod on:aStream.
cg@1419
  2576
        aStream close
cg@1419
  2577
    ]
cg@1419
  2578
cg@1419
  2579
    "Modified: / 1.4.1997 / 16:00:57 / stefan"
cg@1419
  2580
    "Created: / 2.4.1997 / 00:24:28 / stefan"
cg@1440
  2581
    "Modified: / 28.10.1997 / 14:40:34 / cg"
cg@1440
  2582
!
cg@1419
  2583
cg@1419
  2584
fileOutMethod:aMethod on:aStream
cg@1419
  2585
    |dict cat source privacy|
cg@1419
  2586
cg@1419
  2587
    dict := self methodDictionary.
cg@1419
  2588
    dict notNil ifTrue:[
cg@1419
  2589
        aStream nextPutChunkSeparator.
cg@1419
  2590
        self name printOn:aStream.
cg@1419
  2591
"/        self printClassNameOn:aStream.
cg@1419
  2592
cg@1419
  2593
        (privacy := aMethod privacy) ~~ #public ifTrue:[
cg@1419
  2594
            aStream space; nextPutAll:privacy; nextPutAll:'MethodsFor:'.
cg@1419
  2595
        ] ifFalse:[
cg@1419
  2596
            aStream nextPutAll:' methodsFor:'.
cg@1419
  2597
        ].
cg@1419
  2598
        cat := aMethod category.
cg@1419
  2599
        cat isNil ifTrue:[
cg@1419
  2600
            cat := ''
cg@1419
  2601
        ].
cg@1419
  2602
        aStream nextPutAll:cat asString storeString.
cg@1419
  2603
        aStream nextPutChunkSeparator; cr; cr.
cg@1419
  2604
        source := aMethod source.
cg@1419
  2605
        source isNil ifTrue:[
cg@1419
  2606
            Class fileOutErrorSignal 
cg@1419
  2607
                raiseRequestWith:self
cg@1419
  2608
                errorString:('no source for method: ' ,
cg@1419
  2609
                             self name , '>>' ,
cg@1419
  2610
                             (self selectorAtMethod:aMethod))
cg@1419
  2611
        ] ifFalse:[
cg@1419
  2612
            aStream nextChunkPut:source.
cg@1419
  2613
        ].
cg@1419
  2614
        aStream space.
cg@1419
  2615
        aStream nextPutChunkSeparator.
cg@1419
  2616
        aStream cr
cg@1419
  2617
    ]
cg@1419
  2618
cg@1419
  2619
    "Modified: 27.8.1995 / 01:23:19 / claus"
cg@1419
  2620
    "Modified: 12.6.1996 / 11:44:41 / stefan"
cg@1419
  2621
    "Modified: 15.11.1996 / 11:32:43 / cg"
cg@1440
  2622
    "Created: 2.4.1997 / 00:24:33 / stefan"
cg@1440
  2623
!
cg@1419
  2624
cg@1419
  2625
fileOutOn:aStream
cg@1419
  2626
cg@1440
  2627
    ^ self fileOutOn:aStream withTimeStamp:true
cg@1440
  2628
!
cg@1419
  2629
cg@1419
  2630
fileOutOn:aStream withTimeStamp:stampIt
cg@1419
  2631
    "file out my definition and all methods onto aStream.
cg@1419
  2632
     If stampIt is true, a timeStamp comment is prepended."
cg@1419
  2633
cg@1440
  2634
    self fileOutOn:aStream withTimeStamp:stampIt withInitialize:true
cg@1440
  2635
!
cg@1419
  2636
cg@1419
  2637
fileOutOn:aStream withTimeStamp:stampIt withInitialize:initIt
cg@1419
  2638
    "file out my definition and all methods onto aStream.
cg@1419
  2639
     If stampIt is true, a timeStamp comment is prepended.
cg@1419
  2640
     If initIt is true, and the class implements a class-initialize method,
cg@1419
  2641
     append a corresponding doIt expression for initialization."
cg@1419
  2642
cg@1419
  2643
    self 
cg@1419
  2644
        fileOutOn:aStream 
cg@1419
  2645
        withTimeStamp:stampIt 
cg@1419
  2646
        withInitialize:initIt 
cg@1419
  2647
        withDefinition:true
cg@1440
  2648
        methodFilter:nil
cg@1440
  2649
!
cg@1419
  2650
cg@1419
  2651
fileOutOn:aStream withTimeStamp:stampIt withInitialize:initIt withDefinition:withDefinition methodFilter:methodFilter
cg@1419
  2652
    "file out my definition and all methods onto aStream.
cg@1419
  2653
     If stampIt is true, a timeStamp comment is prepended.
cg@1419
  2654
     If initIt is true, and the class implements a class-initialize method,
cg@1419
  2655
     append a corresponding doIt expression for initialization.
cg@1419
  2656
     The order by which the fileOut is done is used to put the version string at the end.
cg@1419
  2657
     Thus, if the version string is expanded (by CVS), the characterPositions of methods should not move"
cg@1419
  2658
cg@1419
  2659
    |collectionOfCategories copyrightMethod copyrightText comment versionMethod skippedMethods
cg@1419
  2660
     meta|
cg@1419
  2661
cg@1419
  2662
    self isLoaded ifFalse:[
cg@1419
  2663
        ^ Class fileOutErrorSignal 
cg@1419
  2664
            raiseRequestWith:self
cg@1419
  2665
                 errorString:'will not fileOut unloaded classes'
cg@1419
  2666
    ].
cg@1419
  2667
cg@1419
  2668
    meta := self classRef.
cg@1419
  2669
cg@1419
  2670
    "
cg@1419
  2671
     if there is a copyright method, add a copyright comment
cg@1419
  2672
     at the beginning, taking the string from the copyright method.
cg@1419
  2673
     We cannot do this unconditionally - that would lead to my copyrights
cg@1419
  2674
     being put on your code ;-).
cg@1419
  2675
     On the other hand: I want every file created by myself to have the
cg@1419
  2676
     copyright string at the beginning be preserved .... even if the
cg@1419
  2677
     code was edited in the browser and filedOut.
cg@1419
  2678
    "
cg@1419
  2679
    (copyrightMethod := meta compiledMethodAt:#copyright) notNil ifTrue:[
cg@1419
  2680
        "
cg@1419
  2681
         get the copyright methods source,
cg@1419
  2682
         and insert at beginning.
cg@1419
  2683
        "
cg@1419
  2684
        copyrightText := copyrightMethod source.
cg@1419
  2685
        copyrightText isNil ifTrue:[
cg@1419
  2686
            "
cg@1419
  2687
             no source available - trigger an error
cg@1419
  2688
            "
cg@1419
  2689
            Class fileOutErrorSignal
cg@1419
  2690
                raiseRequestWith:'no source for class ' , self name , ' available. Cannot fileOut'.
cg@1419
  2691
            ^ self
cg@1419
  2692
        ].
cg@1419
  2693
        "
cg@1419
  2694
         strip off the selector-line
cg@1419
  2695
        "
cg@1419
  2696
        copyrightText := copyrightText asCollectionOfLines asStringCollection.
cg@1419
  2697
        copyrightText := copyrightText copyFrom:2 to:(copyrightText size).
cg@1419
  2698
"/        copyrightText do:[:line | aStream nextPutAll:line. aStream cr.].
cg@1419
  2699
        copyrightText := copyrightText asString.
cg@1419
  2700
        aStream nextPutAllAsChunk:copyrightText.
cg@1419
  2701
    ].
cg@1419
  2702
cg@1419
  2703
    stampIt ifTrue:[
cg@1419
  2704
        "/
cg@1419
  2705
        "/ first, a timestamp
cg@1419
  2706
        "/
cg@1419
  2707
        aStream nextPutAll:(Smalltalk timeStamp).
cg@1419
  2708
        aStream nextPutChunkSeparator. 
cg@1419
  2709
        aStream cr; cr.
cg@1419
  2710
    ].
cg@1419
  2711
cg@1419
  2712
    withDefinition ifTrue:[
cg@1419
  2713
        "/
cg@1419
  2714
        "/ then the definition
cg@1419
  2715
        "/
cg@1419
  2716
        self fileOutAllDefinitionsOn:aStream.
cg@1419
  2717
        "/
cg@1419
  2718
        "/ a comment - if any
cg@1419
  2719
        "/
cg@1419
  2720
        (comment := self comment) notNil ifTrue:[
cg@1419
  2721
            self fileOutCommentOn:aStream.
cg@1419
  2722
            aStream cr.
cg@1419
  2723
        ].
cg@1419
  2724
        "/
cg@1419
  2725
        "/ primitive definitions - if any
cg@1419
  2726
        "/
cg@1419
  2727
        self fileOutPrimitiveSpecsOn:aStream.
cg@1419
  2728
    ].
cg@1419
  2729
cg@1419
  2730
    "/
cg@1419
  2731
    "/ methods from all categories in metaclass (i.e. class methods)
cg@1419
  2732
    "/ EXCEPT: the version method is placed at the very end, to
cg@1419
  2733
    "/         avoid sourcePosition-shifts when checked out later.
cg@1419
  2734
    "/         (RCS expands this string, so its size is not constant)
cg@1419
  2735
    "/
cg@1419
  2736
    collectionOfCategories := meta categories asSortedCollection.
cg@1419
  2737
    collectionOfCategories notNil ifTrue:[
cg@1419
  2738
        "/
cg@1419
  2739
        "/ documentation first (if any), but not the version method
cg@1419
  2740
        "/
cg@1419
  2741
        (collectionOfCategories includes:'documentation') ifTrue:[
cg@1419
  2742
            versionMethod := meta compiledMethodAt:#version.
cg@1419
  2743
            versionMethod notNil ifTrue:[
cg@1419
  2744
                skippedMethods := Array with:versionMethod
cg@1419
  2745
            ].
cg@1419
  2746
            meta fileOutCategory:'documentation' except:skippedMethods only:nil methodFilter:methodFilter on:aStream.
cg@1419
  2747
            aStream cr.
cg@1419
  2748
        ].
cg@1419
  2749
cg@1419
  2750
        "/
cg@1419
  2751
        "/ initialization next (if any)
cg@1419
  2752
        "/
cg@1419
  2753
        (collectionOfCategories includes:'initialization') ifTrue:[
cg@1419
  2754
            meta fileOutCategory:'initialization' methodFilter:methodFilter on:aStream.
cg@1419
  2755
            aStream cr.
cg@1419
  2756
        ].
cg@1419
  2757
cg@1419
  2758
        "/
cg@1419
  2759
        "/ instance creation next (if any)
cg@1419
  2760
        "/
cg@1419
  2761
        (collectionOfCategories includes:'instance creation') ifTrue:[
cg@1419
  2762
            meta fileOutCategory:'instance creation' methodFilter:methodFilter on:aStream.
cg@1419
  2763
            aStream cr.
cg@1419
  2764
        ].
cg@1419
  2765
        collectionOfCategories do:[:aCategory |
cg@1419
  2766
            ((aCategory ~= 'documentation')
cg@1419
  2767
            and:[(aCategory ~= 'initialization')
cg@1419
  2768
            and:[aCategory ~= 'instance creation']]) ifTrue:[
cg@1419
  2769
                meta fileOutCategory:aCategory methodFilter:methodFilter on:aStream.
cg@1419
  2770
                aStream cr
cg@1419
  2771
            ]
cg@1419
  2772
        ]
cg@1419
  2773
    ].
cg@1419
  2774
cg@1419
  2775
    "/
cg@1419
  2776
    "/ methods from all categories in myself
cg@1419
  2777
    "/
cg@1419
  2778
    collectionOfCategories := self categories asSortedCollection.
cg@1419
  2779
    collectionOfCategories notNil ifTrue:[
cg@1419
  2780
        collectionOfCategories do:[:aCategory |
cg@1419
  2781
            self fileOutCategory:aCategory methodFilter:methodFilter on:aStream.
cg@1419
  2782
            aStream cr
cg@1419
  2783
        ]
cg@1419
  2784
    ].
cg@1419
  2785
cg@1419
  2786
    "/
cg@1419
  2787
    "/ any private classes' methods
cg@1419
  2788
    "/
cg@1419
  2789
    self privateClassesSorted do:[:aClass |
cg@1419
  2790
        aClass fileOutAllMethodsOn:aStream methodFilter:methodFilter
cg@1419
  2791
    ].
cg@1419
  2792
cg@1419
  2793
cg@1419
  2794
    "/
cg@1419
  2795
    "/ finally, the previously skipped version method
cg@1419
  2796
    "/
cg@1419
  2797
    versionMethod notNil ifTrue:[
cg@1419
  2798
        meta fileOutCategory:'documentation' except:nil only:skippedMethods methodFilter:methodFilter on:aStream.
cg@1419
  2799
    ].
cg@1419
  2800
cg@1419
  2801
    initIt ifTrue:[
cg@1419
  2802
        "/
cg@1419
  2803
        "/ optionally an initialize message
cg@1419
  2804
        "/
cg@1419
  2805
        (meta implements:#initialize) ifTrue:[
cg@1419
  2806
            self printClassNameOn:aStream. aStream nextPutAll:' initialize'.
cg@1419
  2807
            aStream nextPutChunkSeparator.
cg@1419
  2808
            aStream cr
cg@1419
  2809
        ]
cg@1419
  2810
    ]
cg@1419
  2811
cg@1419
  2812
    "Created: / 15.11.1995 / 12:53:06 / cg"
cg@1419
  2813
    "Modified: / 1.4.1997 / 16:01:05 / stefan"
cg@1440
  2814
    "Modified: / 13.3.1998 / 12:23:59 / cg"
cg@1440
  2815
!