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