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

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