forked from dolphinsmalltalk/Dolphin
-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathPreBoot.st
341 lines (249 loc) · 10.6 KB
/
PreBoot.st
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
"This file contains patches to base system classes that are required in order to be able to reload the base class library, but which are not yet consolidated into the boot image. Note that the BCL is reloaded anyway (see Boot.st), so most BCL changes do not require pre-patching; try without first"!
VMLibrary default primRegistryAt: 71 put: #~~; primRegistryAt: 72 put: #not!
AttributeDescriptorFlags keysAndValuesDo: [:k :v | AttributeDescriptor addClassConstant: k value: v].
AttributeDescriptor addClassConstant: 'NonBrowsableMask' value: 128!
#(#AttributeDescriptorFlags #STBPrefixConstants) do: [:each | Package manager systemPackage removeGlobalNamed: each. Smalltalk removeKey: each ifAbsent: []]!
ClassLocator.ImportedClasses := nil!
!ClassLocator class methodsFor!
isImportedClass: aClass
^ImportedClasses notNil and: [ImportedClasses identityIncludes: aClass]! !
!ClassLocator class categoriesFor: #isImportedClass:!public!testing! !
!Package methodsFor!
isImportedClass: aClass
"Private - Answer true if aClass is an imported binary class"
^ClassLocator isImportedClass: aClass! !
!Package categoriesFor: #isImportedClass:!private!testing! !
"Switch to new identity hash - which is tricky"!
!Object methodsFor!
basicIdentityHash
<primitive: 75>
^self primitiveFailed! !
!SmallInteger methodsFor!
basicIdentityHash
^self! !
!MethodDictionary methodsFor!
hash: anObject max: anInteger
"Implementation Note: This must match the selector hashing implementation used by the VM."
^(anObject basicIdentityHash bitAnd: anInteger - 1) + 1! !
!IdentitySet methodsFor!
hash: anObject max: anInteger
^anObject identityHash \\ anInteger + 1! !
!SharedIdentitySet methodsFor!
hash: anObject max: anInteger
^anObject identityHash \\ anInteger + 1! !
!IdentityDictionary methodsFor!
hash: anObject max: anInteger
^anObject identityHash \\ anInteger + 1! !
!SharedIdentityDictionary methodsFor!
hash: anObject max: anInteger
^anObject identityHash \\ anInteger + 1! !
!WeakIdentityDictionary methodsFor!
hash: anObject max: anInteger
^anObject identityHash \\ anInteger + 1! !
!IdentitySearchPolicy methodsFor!
hash: operand max: maximum
^operand identityHash \\ maximum + 1! !
!Object methodsFor!
identityHash
^self basicIdentityHash bitShift: 14!
hash
^self identityHash! !
| m st |
st := Smalltalk.
m := Symbol basicCompile: 'hash ^self identityHash'.
"As soon as we replace Symbol>>hash, the Smalltalk dictionary is invalidated"
st rehash!
Set allSubinstances do: [:each | each size > 0 ifTrue: [each rehash]]!
"Behavior.methodDictionary can now be nil"
Behavior addClassConstant: '_NullMethodDictionary'
value: ((MethodDictionary new)
isImmutable: true;
yourself)!
!Behavior methodsFor!
addSelector: aSymbol withMethod: aCompiledMethod
| selector |
selector := aSymbol asSymbol.
aCompiledMethod
methodClass: self;
selector: selector.
(methodDictionary ifNil: [methodDictionary := MethodDictionary new]) at: selector
put: aCompiledMethod.
self flushMethodCache!
basicCompile: aString flags: anInteger
| error result stubMethod |
result := error := stubMethod := nil.
[result := self compilerClass
compile: aString
in: self
flags: anInteger]
on: self compilerClass errorClass
do:
[:n |
error := n.
stubMethod := (MethodCompileFailed with: n) signal: n description.
n pass].
error notNil ifTrue: [result := stubMethod].
result notNil
ifTrue:
[| selector method |
method := result method.
selector := method selector asSymbol.
methodDictionary
ifNotNil:
[| oldMethod |
oldMethod := methodDictionary at: selector ifAbsent: [].
result oldMethod: oldMethod.
oldMethod ifNotNil: [method isPrivate: oldMethod isPrivate]].
self addSelector: selector withMethod: method.
method
storeSourceString: aString asString;
isImmutable: true].
^result! !
(Array with: ExternalCallback with: ExternalDescriptor) do: [:each | each class removeSelector: #initialize]!
ExternalDescriptor addClassConstant: 'RetTypeMask' value: 63!
#(always caseInsensitive equality identity never uninitialize) do: [:each | SearchPolicy class removeSelector: each]!
#(current uninitialize) do: [:each | SymbolStringSearchPolicy class removeSelector: each. AssociationSearchPolicy class removeSelector: each]!
BYTE subclass: #BOOLEAN
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
classInstanceVariableNames: ''!
!BOOLEAN class methodsFor!
fileOutStem
^super fileOutStem, '_struct'! !
NTLibrary addClassVariable: 'IsWine' value: false!
(Array with: ArrayField with: ArrayPointerField) do: [:each | each withAllSubclassesDo: [:f | (f whichSelectorsAccess: 'length') do: [:s | f removeSelector: s]]]!
(Array with: CPINFO with: TIME_ZONE_INFORMATION) do: [:each | each resetTemplate]!
ByteCodeDispatcher.RunStarts at: #shortSpecialSendEx: put: 200!
!Dictionary methodsFor!
lookup: keyObject
^self at: keyObject ifAbsent: []! !
!LookupTable methodsFor!
lookup: keyObject
^self at: keyObject ifAbsent: []! !
!PoolDictionary methodsFor!
lookup: keyObject
^super lookup: keyObject asString! !
!SystemDictionary methodsFor!
lookup: keyObject
^super lookup: keyObject asSymbol! !
!CRTLibrary methodsFor!
_splitpath_s: path drive: drive driveLen: driveInteger dir: dir dirLen: dirInteger fname: fname fnameLen: nameInteger ext: ext extLen: extInteger
<cdecl: sdword _splitpath_s char* char* sdword char* sdword char* sdword char* sdword>
^self invalidCall!
strcat_s: strDestination bufferSize: anInteger strSource: strSource
<cdecl: sdword strcat_s lpstr sdword lpstr>
^self invalidCall!
_makepath_s: path bufferSize: sizeInBytes drive: drive dir: dir fname: fname ext: ext
<cdecl: sdword _makepath_s char* intptr char* char* char* char*>
^self invalidCall! !
Object subclass: #InputState
instanceVariableNames: 'inputSemaphore idler idleTimer main windows deferredActions lastWindow wakeupEvent msgWindow queueStatusMask'
classVariableNames: 'EnumHandlesDescriptor SamplingInterval UserInterruptSignal'
poolDictionaries: 'Win32Constants'
classInstanceVariableNames: 'maxIdleSleep'!
SessionManager inputState instVarAt: 10 put: 16rFF!
!StackFrame methodsFor!
callstackDo: aMonadicValuable depth: anInteger
| frame i |
frame := self.
i := anInteger.
[i ~~ 0 and: [frame notNil and: [frame method selector notNil]]] whileTrue:
[aMonadicValuable value: frame.
frame := frame sender.
i := i - 1]!
printStackOn: aPuttableStream depth: anInteger
self callstackDo:
[:frame |
aPuttableStream
display: frame;
cr]
depth: anInteger! !
!KernelLibrary methodsFor!
getFileSizeEx: hfile lpFileSize: lpFileSize
<stdcall: bool GetFileSizeEx handle sqword*>
^self invalidCall!
setFilePointerEx: hfile liDistanceToMove: liDistanceToMove lpNewFilePointer: lpNewFilePointer dwMoveMethod: dwMoveMethod
<stdcall: bool SetFilePointerEx handle sqword sqword* dword>
^self invalidCall! !
Object subclass: #File
instanceVariableNames: 'handle spec flags shareFlags intBuffer'
classVariableNames: 'AccessFlagsMask CheckModes NoCheckModes OpenFlagsMask ShareModes'
poolDictionaries: 'CRTConstants Win32Constants Win32Errors'
classInstanceVariableNames: ''!
!File methodsFor!
seek: offsetInteger sense: senseFlag
intBuffer:= ByteArray newFixed: 8.
^(KernelLibrary default
setFilePointerEx: handle
liDistanceToMove: offsetInteger
lpNewFilePointer: intBuffer
dwMoveMethod: senseFlag) ifTrue: [
intBuffer sqwordAtOffset: 0] ifFalse: [self signalOsError: false]! !
File class removeSelector: #initialize!
FileStream class removeSelector: #initialize!
!FileStream methodsFor!
beDirty
flags := flags bitOr: 3!
nextPut: anIntegerOrCharacter
self primitiveNextPut: anIntegerOrCharacter.
flags := flags bitOr: 3.
^anIntegerOrCharacter!
updateLimits
(flags anyMask: 1)
ifTrue:
[| absolute |
flags := flags bitAnd: 1 bitInvert.
readLimit < position ifTrue: [readLimit := position].
logicalFileSize < (absolute := self position) ifTrue: [logicalFileSize := absolute]]! !
(FileStream compiledMethodAt: #beDirty) loseSource!
SequencedStream subclass: #StdioFileStream
instanceVariableNames: 'stream flags name oldFd fd crtlib'
classVariableNames: 'DeviceMask ReadOnlyMask TextMask'
poolDictionaries: 'CRTConstants'
classInstanceVariableNames: ''!
!StdioFileStream methodsFor!
setStream: anExternalHandle flags: anInteger name: aString
stream := anExternalHandle.
flags := anInteger.
crtlib := CRTLibrary default.
fd := crtlib _fileno: stream.
name := aString! !
SessionManager current stdioStreams do: [:each | each setStream: each asParameter flags: 16r80 name: nil]!
!Process methodsFor!
at: anInteger
<primitive: 60>
^self errorAt: anInteger! !
Process instanceVariableString: 'suspendedFrame priority myList callbackDepth primitiveFailureCode primitiveFailureData fpControl threadSync thread exceptionEnvironment _alreadyPrinted _reserved1 debugger name reserved2'!
CRTConstants at: '_EM_INEXACT' put: 1!
!Magnitude methodsFor!
isNaN
^false! !
(Array with: Process class with: Process) do: [:each | each removeSelector: #initialize]!
Process addClassConstant: 'DefaultFPEMask' value: CRTConstants._EM_DENORMAL | CRTConstants._EM_INEXACT | CRTConstants._EM_UNDERFLOW!
Processor activeProcess fpeMask: Process.DefaultFPEMask | CRTConstants._EM_OVERFLOW | CRTConstants._EM_INVALID!
#(#fpeMask #fpeMask:) do: [:each | Process removeSelector: each]!
#(#absPrintExactlyOn:base:decimalPlaces:showTrailingFractionalZeros: #absPrintExactlyOn:base:) do: [:each | Float removeSelector: each]!
Float class removeSelector: #fminDenormalized!
| infinity |
infinity := Float fmax * 2.
Float addClassConstant: 'Infinity' value: infinity.
Float addClassConstant: 'NegativeInfinity' value: infinity negated.
Float addClassConstant: 'NaN' value: infinity - infinity!
#(#decimalSeparator #synchronizeLocale) do: [:each | CRTLibrary removeSelector: each]!
Behavior addClassConstant: '_BasicSpecMask' value: 32767!
Behavior addClassConstant: '_BytesSubMask' value: 18432!
Behavior addClassConstant: '_FundamentalShapeMask' value: 12543!
Behavior addClassConstant: '_IndirectMask' value: 2048!
Behavior addClassConstant: '_MournerMask' value: 1024!
Behavior addClassConstant: '_NonInstantiableMask' value: 512!
Behavior addClassConstant: '_NullTermMask' value: 16384!
Behavior addClassConstant: '_PointersMask' value: 8192!
Behavior addClassConstant: '_ShapeMask' value: 28927!
Behavior addClassConstant: '_SizeMask' value: 255!
Behavior addClassConstant: '_VariableMask' value: 4096!
ClassBuilder setSharedPoolNames: (ClassBuilder sharedPoolNames copyWithout: #_BehaviorMasks)!
!Class methodsFor!
isAbstract: aBoolean
self setShapeFlags: _NonInstantiableMask to: aBoolean! !
Behavior owningPackage removeGlobalNamed: #_BehaviorMasks!