# HG changeset patch # User Merge Script # Date 1432528659 -7200 # Node ID 9a3fc7cc71270d6847d0de5445087b63b5389fc8 # Parent 20527009f3522864fabfc969becf7fbb8f38fad8# Parent b702d11f9a324fdfbd88c4038a4f21ce7e18d5fc Merge diff -r 20527009f352 -r 9a3fc7cc7127 Behavior.st --- a/Behavior.st Mon May 25 02:51:46 2015 +0100 +++ b/Behavior.st Mon May 25 06:37:39 2015 +0200 @@ -1587,11 +1587,11 @@ "/ CG: why this? "/ the VM ONLY looks at the lookupObject slot and does not walk the hierarchy; "/ (which it should never !!!!!!) - "/ It is the responsibility of the IDE (or whoever uses lookupObjects), + "/ It is the responsibility of the IDE (or whoever uses lookupObjects), "/ to make sure that subclasses get a lookupObject, if they need it. - "/ Also: it does not really make sense to redefine the behavior here + "/ Also: it does not really make sense to redefine the behavior here "/ (for inheritance of lookup), - "/ differently to what the VM does; + "/ differently to what the VM does; "/ remember: this is also called for canUnderstand, respondsTo etc. "/ and no one expects these to return different results than what the VM does. @@ -1615,25 +1615,25 @@ lookupObject == anObject ifTrue:[^ self ]. anObject notNil ifTrue:[ - "/ check if it is valid; the reason is that the VM gets into bad trouble, - "/ if some invalid thingy is set as lookup object - (anObject respondsTo: #lookupMethodForSelector:directedTo:for:withArguments:from:ilc:) - ifFalse:[ - self error:'Lookup object does not respond to #lookupMethodForSelector:directedTo:for:withArguments:from:ilc:' - ]. - - "/ CG: huh - what is this - it is nowhere implemented. - (anObject respondsTo:#superLookupObject:) - ifTrue:[ - anObject superLookupObject: self lookupObject - ]. + "/ check if it is valid; the reason is that the VM gets into bad trouble, + "/ if some invalid thingy is set as lookup object + (anObject respondsTo: #lookupMethodForSelector:directedTo:for:withArguments:from:ilc:) + ifFalse:[ + self error:'Lookup object does not respond to #lookupMethodForSelector:directedTo:for:withArguments:from:ilc:' + ]. + + "/ CG: huh - what is this - it is nowhere implemented. + (anObject respondsTo:#superLookupObject:) + ifTrue:[ + anObject superLookupObject: self lookupObject + ]. ]. "/ the builtin has the same behavior as the VM's default; "/ so let it do it - it's faster anObject == BuiltinLookup instance ifTrue:[ - self setLookupObject: nil. + self setLookupObject: nil. ] ifFalse:[ - self setLookupObject: anObject. + self setLookupObject: anObject. ]. "Created: / 26-04-2010 / 13:35:19 / Jan Vrany " @@ -2683,7 +2683,7 @@ memset4(__InstPtr(newobj)->i_instvars, 0, n4); } # else -# if defined(FAST_ARRAY_MEMSET) +# if 1 /* defined(FAST_ARRAY_MEMSET) */ /* * knowing that nil is 0 */ @@ -3446,8 +3446,8 @@ has to provide a method object for message sends." lookupObject ~~ aLookupObjectOrNil ifTrue:[ - lookupObject := aLookupObjectOrNil. - self withAllSubclassesDo:[:cls | ObjectMemory flushCachesFor: cls] + lookupObject := aLookupObjectOrNil. + self withAllSubclassesDo:[:cls | ObjectMemory flushCachesFor: cls] ] "Modified: / 22-07-2010 / 18:10:30 / Jan Vrany " @@ -5328,10 +5328,9 @@ !Behavior class methodsFor:'documentation'! version - ^ '$Header: /cvs/stx/stx/libbasic/Behavior.st,v 1.378 2015-05-18 15:20:47 cg Exp $' + ^ '$Header: /cvs/stx/stx/libbasic/Behavior.st,v 1.379 2015-05-24 12:53:14 cg Exp $' ! version_CVS - ^ '$Header: /cvs/stx/stx/libbasic/Behavior.st,v 1.378 2015-05-18 15:20:47 cg Exp $' + ^ '$Header: /cvs/stx/stx/libbasic/Behavior.st,v 1.379 2015-05-24 12:53:14 cg Exp $' ! ! - diff -r 20527009f352 -r 9a3fc7cc7127 NonPositionableExternalStream.st --- a/NonPositionableExternalStream.st Mon May 25 02:51:46 2015 +0100 +++ b/NonPositionableExternalStream.st Mon May 25 06:37:39 2015 +0200 @@ -498,6 +498,18 @@ !NonPositionableExternalStream methodsFor:'reading'! +readWait + "cannot do a readWait (which means possible suspend), + if the processor is not yet initialized; i.e. if a read is attempted + during early startup. + This may happen, for example, if a MiniDebugger is entered, before + process scheduling has been setup. + In this case, all I/O operations here will be blocking." + + Smalltalk isInitialized ifFalse:[ ^ false ]. + ^ super readWait +! + next "return the next element, if available. If nothing is available, this does never raise a read-beyond end signal. @@ -595,10 +607,10 @@ !NonPositionableExternalStream class methodsFor:'documentation'! version - ^ '$Header: /cvs/stx/stx/libbasic/NonPositionableExternalStream.st,v 1.74 2015-05-03 12:39:22 cg Exp $' + ^ '$Header: /cvs/stx/stx/libbasic/NonPositionableExternalStream.st,v 1.75 2015-05-24 12:51:37 cg Exp $' ! version_CVS - ^ '$Header: /cvs/stx/stx/libbasic/NonPositionableExternalStream.st,v 1.74 2015-05-03 12:39:22 cg Exp $' + ^ '$Header: /cvs/stx/stx/libbasic/NonPositionableExternalStream.st,v 1.75 2015-05-24 12:51:37 cg Exp $' ! ! diff -r 20527009f352 -r 9a3fc7cc7127 ObjectMemory.st --- a/ObjectMemory.st Mon May 25 02:51:46 2015 +0100 +++ b/ObjectMemory.st Mon May 25 06:37:39 2015 +0200 @@ -673,32 +673,32 @@ "/ protect against double initialization AllocationFailureSignal isNil ifTrue:[ - AllocationFailureSignal := AllocationFailure. - AllocationFailureSignal notifierString:'allocation failure'. - - MallocFailureSignal := MallocFailure. - MallocFailureSignal notifierString:'(malloc) allocation failure'. - - LowSpaceSemaphore := Semaphore new name:'LowSpaceSemaphore'. - - DisposeInterruptHandler := self. - - "/ BackgroundCollectMaximumInterval := 3600. "/ run it at least once an hour - BackgroundCollectMaximumInterval := nil. "/ only run when space situation makes it feasable - IncrementalGCLimit := 500000. "/ run it whenever 500k have been allocated - FreeSpaceGCLimit := FreeSpaceGCAmount := nil. "/ no minumum-freeSpace trigger. - MemoryInterruptHandler := self. - ExceptionInterruptHandler := self. - - VMSelectors := #( #noByteCode #invalidCodeObject #invalidByteCode #invalidInstruction - #tooManyArguments #badLiteralTable #receiverNotBoolean: #typeCheckError - #integerCheckError #wrongNumberOfArguments: #privateMethodCalled - #doesNotUnderstand: #invalidReturn: #invalidReturnOrRestart: - #userInterrupt #internalError: #spyInterrupt #timerInterrupt #stepInterrupt - #errorInterrupt:with: #disposeInterrupt #recursionInterrupt - #memoryInterrupt #fpExceptionInterrupt #signalInterrupt: #childSignalInterrupt - #ioInterrupt #customInterrupt #schedulerInterrupt #contextInterrupt - #interruptLatency:receiver:class:selector:vmActivity:id:). + AllocationFailureSignal := AllocationFailure. + AllocationFailureSignal notifierString:'allocation failure'. + + MallocFailureSignal := MallocFailure. + MallocFailureSignal notifierString:'(malloc) allocation failure'. + + LowSpaceSemaphore := Semaphore new name:'LowSpaceSemaphore'. + + DisposeInterruptHandler := self. + + "/ BackgroundCollectMaximumInterval := 3600. "/ run it at least once an hour + BackgroundCollectMaximumInterval := nil. "/ only run when space situation makes it feasable + IncrementalGCLimit := 500000. "/ run it whenever 500k have been allocated + FreeSpaceGCLimit := FreeSpaceGCAmount := nil. "/ no minumum-freeSpace trigger. + MemoryInterruptHandler := self. + ExceptionInterruptHandler := self. + + VMSelectors := #( #noByteCode #invalidCodeObject #invalidByteCode #invalidInstruction + #tooManyArguments #badLiteralTable #receiverNotBoolean: #typeCheckError + #integerCheckError #wrongNumberOfArguments: #privateMethodCalled + #doesNotUnderstand: #invalidReturn: #invalidReturnOrRestart: + #userInterrupt #internalError: #spyInterrupt #timerInterrupt #stepInterrupt + #errorInterrupt:with: #disposeInterrupt #recursionInterrupt + #memoryInterrupt #fpExceptionInterrupt #signalInterrupt: #childSignalInterrupt + #ioInterrupt #customInterrupt #schedulerInterrupt #contextInterrupt + #interruptLatency:receiver:class:selector:vmActivity:id:). ] "Modified: / 5.8.1998 / 15:30:12 / cg" @@ -724,7 +724,11 @@ takes" %{ /* NOCONTEXT */ +#ifdef __SCHTEAM__ + return __c__._RETURN(8); // not really true +#else RETURN(__mkSmallInteger(sizeof(OBJ))); +#endif %} " @@ -737,7 +741,11 @@ i.e. the number of bytes in every objects header." %{ /* NOCONTEXT */ +#ifdef __SCHTEAM__ + return __c__._RETURN(0); // not really true +#else RETURN(__mkSmallInteger(OHDR_SIZE)); +#endif %} " @@ -856,9 +864,13 @@ are turned on, false of off." %{ /* NOCONTEXT */ +#ifdef __SCHTEAM__ + return __c__._RETURN( STMain.DebugPrinting ? STObject.True : STObject.False); +#else extern int __getDebugPrinting(); RETURN (__getDebugPrinting() ? true : false); +#endif %}. " ObjectMemory debugPrinting @@ -874,9 +886,19 @@ Returns the previous setting." %{ /* NOCONTEXT */ +#ifdef __SCHTEAM__ + { + boolean prev = STMain.DebugPrinting; + + STMain.DebugPrinting = (aBoolean == STObject.True); + return __c__._RETURN( prev ? STObject.True : STObject.False); + } + /* NOTREACHED */ +#else extern int __setDebugPrinting(); RETURN ( __setDebugPrinting( (aBoolean == true) ) ? true : false); +#endif %} ! @@ -885,9 +907,13 @@ are turned on, false of off." %{ /* NOCONTEXT */ +#ifdef __SCHTEAM__ + return __c__._RETURN( STMain.InfoPrinting ? STObject.True : STObject.False); +#else extern int __getInfoPrinting(); RETURN (__getInfoPrinting() ? true : false); +#endif %} " ObjectMemory infoPrinting @@ -902,9 +928,19 @@ Returns the previous setting." %{ /* NOCONTEXT */ +#ifdef __SCHTEAM__ + { + boolean prev = STMain.InfoPrinting; + + STMain.InfoPrinting = (aBoolean == STObject.True); + return __c__._RETURN( prev ? STObject.True : STObject.False); + } + /* NOTREACHED */ +#else extern int __setInfoPrinting(); RETURN ( __setInfoPrinting( (aBoolean == true) ) ? true : false); +#endif %} ! @@ -914,9 +950,13 @@ Returns the previous setting." %{ /* NOCONTEXT */ +#ifdef __SCHTEAM__ + return __c__._RETURN_false(); +#else extern int __setInitTrace(); RETURN ( __setInitTrace( (aBoolean == true) ) ? true : false); +#endif %} ! ! @@ -975,9 +1015,13 @@ versions, if it turns out to be not useful." %{ /* NOCONTEXT */ +#ifdef __SCHTEAM__ + return __c__._RETURN_false(); +#else extern int __setPrivacyChecks__(); RETURN ( __setPrivacyChecks__( (aBoolean == true) ) ? true : false); +#endif %} ! @@ -988,7 +1032,11 @@ (true of trap was installed ok, false if failed) should be checked." %{ /* NOCONTEXT */ +#ifdef __SCHTEAM__ + return __c__._RETURN_false(); +#else RETURN (__addTrapOnAccess(anObject, 2) ? true : false); +#endif %} ! @@ -999,7 +1047,11 @@ (true of trap was installed ok, false if failed) should be checked." %{ /* NOCONTEXT */ +#ifdef __SCHTEAM__ + return __c__._RETURN_false(); +#else RETURN (__addTrapOnAccess(anObject, 0) ? true : false); +#endif %} ! @@ -1010,7 +1062,11 @@ (true of trap was installed ok, false if failed) should be checked." %{ /* NOCONTEXT */ +#ifdef __SCHTEAM__ + return __c__._RETURN_false(); +#else RETURN (__addTrapOnAccess(anObject, 1) ? true : false); +#endif %} ! @@ -1036,12 +1092,11 @@ %{ #ifndef WIN32 - /*extern void __debugBreakPoint3__();*/ - __debugBreakPoint3__(); + /*extern void __debugBreakPoint3__();*/ + __debugBreakPoint3__(); #endif %}. - ^ 0 - + ^ 0 ! flushCaches @@ -1145,27 +1200,29 @@ ! ilcMisses: newValue - - newValue class == SmallInteger ifFalse:[^self error:'Not an integer value']. + newValue class == SmallInteger ifFalse:[ + ^ self error:'Not an integer value' + ]. + %{ /* NOCONTEXT */ - /*extern int __ilcMisses(int);*/ + /*extern int __ilcMisses(int);*/ #ifdef ILC_PROFILING - RETURN ( __MKSMALLINT ( __ilcMisses ( __intVal ( newValue ) ) ) ); + RETURN ( __MKSMALLINT ( __ilcMisses ( __intVal ( newValue ) ) ) ); #endif %}. - ^ -1 + ^ -1 ! ilcMissesTrace: bool %{ - /*extern int __ilcMissesTrace(int);*/ + /*extern int __ilcMissesTrace(int);*/ #ifdef ILC_PROFILING - RETURN ( __ilcMissesTrace ( bool == true ) ? true : false ); + RETURN ( __ilcMissesTrace ( bool == true ) ? true : false ); #endif %}. - ^ 0 + ^ 0 ! @@ -1185,7 +1242,11 @@ caches which are stored with the image" %{ /* NOCONTEXT */ +#ifdef __SCHTEAM__ + return __c__._RETURN(0); +#else RETURN ( __mkSmallInteger( __snapshotID() )); +#endif %} " ObjectMemory snapshotID @@ -1203,12 +1264,15 @@ |oldTrap| %{ - if (__setTrapRestrictedMethods(trap == true)) - oldTrap = true; - else - oldTrap = false; +#ifdef __SCHTEAM__ + return __c__._RETURN_false(); +#else + if (__setTrapRestrictedMethods(trap == true)) + oldTrap = true; + else + oldTrap = false; +#endif %}. - (trap and:[oldTrap not]) ifTrue:[ self flushCaches ]. @@ -1230,7 +1294,9 @@ it will be removed without notice" %{ /* NOCONTEXT */ - +#ifdef __SCHTEAM__ + return __c__._RETURN(0); +#else if (anObject != nil) { if (! __isNonNilObject(anObject)) { RETURN ( nil ); @@ -1240,6 +1306,7 @@ RETURN ( __mkSmallInteger((INT)anObject) ); } RETURN ( __MKUINT((INT)anObject) ); +#endif %} " |p| @@ -1258,11 +1325,14 @@ it will be removed without notice" %{ /* NOCONTEXT */ - +#ifdef __SCHTEAM__ + return __c__._RETURN(0); +#else if (! __isNonNilObject(anObject)) { RETURN ( 0 ); } RETURN ( __mkSmallInteger( _GET_AGE(anObject) ) ); +#endif %} " |p| @@ -1347,29 +1417,29 @@ lbl origin:(0.0@0.0) corner:(1.0@0.0). h := lbl preferredHeight. lbl - topInset:5; - bottomInset:(h+5) negated; - leftInset:5; - rightInset:5. + topInset:5; + bottomInset:(h+5) negated; + leftInset:5; + rightInset:5. progress := ProgressIndicator in:top. progress origin:(0.0@45) corner:(1.0@45). progress level:-1. h := progress preferredHeight. progress - topInset:(h // 2) negated; - bottomInset:(h // 2) negated; - leftInset:5; - rightInset:5. + topInset:(h // 2) negated; + bottomInset:(h // 2) negated; + leftInset:5; + rightInset:5. progress beInvisible. listV := HVScrollableView for:SelectionInListView in:top. listV origin:(0.0@55) corner:(1.0@1.0). listV - topInset:(h // 2); - bottomInset:40; - leftInset:5; - rightInset:5. + topInset:(h // 2); + bottomInset:40; + leftInset:5; + rightInset:5. listV beInvisible. panel := HorizontalPanelView in:top. @@ -1408,246 +1478,246 @@ firstRound := true. [done] whileFalse:[ - anyShown := false. - - progress percentage:0. - firstRound ifTrue:[ - firstRound := false. - ] ifFalse:[ - lbl label:'compressing garbage ...'. - self garbageCollect. - ]. - - lbl label:('searching level ' - , levels size printString - , ' (' , objects size printString , ' refs) ...'). - nAll := objects size. - nDone := 0. - - objectArray := objects asArray. - - owners := "Weak"IdentitySet new. - - numObjectsDone := 0. - found := false. - - AbortOperationRequest catch:[ - self allObjectsIncludingContextsDo:[:o | - |inPrevLevel isOwner| - - stop ifTrue:[AbortOperationRequest raise]. - stop ifFalse:[ - isOwner := false. - (o referencesAny:objectArray) ifTrue:[ - o isBehavior ifTrue:[ - o == Smalltalk ifTrue:[ - found := true. - ] ifFalse:[ - "/ only add it if it has classInstVars - o instSize ~~ Class instSize ifTrue:[ - isOwner := true. - ] - ] - ] ifFalse:[ - o class ~~ WeakArray ifTrue:[ - isOwner := true. - ] - ]. - ]. - - isOwner ifTrue:[ - (objects includesIdentical:o) ifFalse:[ - inPrevLevel := false. - levels do:[:lColl | - lColl == o ifTrue:[ - inPrevLevel := true - ] ifFalse:[ - (lColl includesIdentical:o) ifTrue:[inPrevLevel := true]. - ] - ]. - inPrevLevel ifFalse:[ - owners add:o. - (limitOrNil notNil and:[owners size >= limitOrNil]) ifTrue:[ - AbortOperationRequest raise - ]. - ] - ] - ]. - - numObjectsDone := numObjectsDone + 1. - numObjects notNil ifTrue:[ - numObjectsDone \\ 1000 == 0 ifTrue:[ - progress percentage:(numObjectsDone / numObjects * 100). - Processor yield. - ] - ] - ] - ]. - ]. - progress percentage:100. - - numObjects isNil ifTrue:[ - numObjects := numObjectsDone. - ]. - - owners remove:aCollection ifAbsent:nil. - owners remove:thisContext ifAbsent:nil. - owners remove:objectArray ifAbsent:nil. - owners remove:objects keyArray ifAbsent:nil. - owners remove:owners keyArray ifAbsent:nil. + anyShown := false. + + progress percentage:0. + firstRound ifTrue:[ + firstRound := false. + ] ifFalse:[ + lbl label:'compressing garbage ...'. + self garbageCollect. + ]. + + lbl label:('searching level ' + , levels size printString + , ' (' , objects size printString , ' refs) ...'). + nAll := objects size. + nDone := 0. + + objectArray := objects asArray. + + owners := "Weak"IdentitySet new. + + numObjectsDone := 0. + found := false. + + AbortOperationRequest catch:[ + self allObjectsIncludingContextsDo:[:o | + |inPrevLevel isOwner| + + stop ifTrue:[AbortOperationRequest raise]. + stop ifFalse:[ + isOwner := false. + (o referencesAny:objectArray) ifTrue:[ + o isBehavior ifTrue:[ + o == Smalltalk ifTrue:[ + found := true. + ] ifFalse:[ + "/ only add it if it has classInstVars + o instSize ~~ Class instSize ifTrue:[ + isOwner := true. + ] + ] + ] ifFalse:[ + o class ~~ WeakArray ifTrue:[ + isOwner := true. + ] + ]. + ]. + + isOwner ifTrue:[ + (objects includesIdentical:o) ifFalse:[ + inPrevLevel := false. + levels do:[:lColl | + lColl == o ifTrue:[ + inPrevLevel := true + ] ifFalse:[ + (lColl includesIdentical:o) ifTrue:[inPrevLevel := true]. + ] + ]. + inPrevLevel ifFalse:[ + owners add:o. + (limitOrNil notNil and:[owners size >= limitOrNil]) ifTrue:[ + AbortOperationRequest raise + ]. + ] + ] + ]. + + numObjectsDone := numObjectsDone + 1. + numObjects notNil ifTrue:[ + numObjectsDone \\ 1000 == 0 ifTrue:[ + progress percentage:(numObjectsDone / numObjects * 100). + Processor yield. + ] + ] + ] + ]. + ]. + progress percentage:100. + + numObjects isNil ifTrue:[ + numObjects := numObjectsDone. + ]. + + owners remove:aCollection ifAbsent:nil. + owners remove:thisContext ifAbsent:nil. + owners remove:objectArray ifAbsent:nil. + owners remove:objects keyArray ifAbsent:nil. + owners remove:owners keyArray ifAbsent:nil. "/ 'done with level: ' print. levels size print. ' found ' print. owners size print. ' refs' printCR. - owners isEmpty ifTrue:[ - found ifFalse:[ - stop := true. - ] - ]. - - stop ifFalse:[ - done := found or:[(owners includesIdentical:Smalltalk)]. - done ifTrue:[ - moreChainsOnThisLevel := true. - temporaryRemoved := IdentitySet new. - - levels size > 0 ifTrue:[ - "/ show what we found so far. - levels last add:Smalltalk. - levels reverse. - ]. - - chains := OrderedCollection new. - - tLevels := levels collect:[:lColl | lColl copy]. - - lbl label:('building refchains ...'). - - nAll := aCollection size. - nDone := 0. - aCollection do:[:anObject | |theseChains| - stop ifFalse:[ - theseChains := self - refChainsFrom:Smalltalk - to:anObject - inRefSets:tLevels - startingAt:1. - - theseChains size > 0 ifTrue:[ - chains addAll:theseChains - ]. - nDone := nDone + 1. - progress percentage:(nDone / nAll * 100). - ] - ]. - - tLevels := nil. - - levels size > 0 ifTrue:[ - levels reverse. - levels last remove:Smalltalk. - ]. - - [stop not - and:[chains size > 0]] whileTrue:[ - chain := chains first. - chains removeFirst. - - lbl label:('found a reference chain.'). - progress beInvisible. - - chain addFirst:Smalltalk. - list := OrderedCollection newWithSize:chain size. - 1 to:chain size-1 do:[:i | - list - at:i - put:(self refNameFor:(chain at:i+1) in:(chain at:i)) - ]. - list at:list size put:(chain last classNameWithArticle). - - "/ hide the VMProcesses stuff from the user ... - (list at:1) string = 'Smalltalk:__VMProcesses__' ifTrue:[ - list at:1 put:'__VMProcesses__ (a hidden VM reference)'. - list removeIndex:2. - chain at:1 put:nil. - chain removeIndex:2. - ]. - - listV list:list. - - listV beVisible. - listV doubleClickAction:[:idx | |o| - (o := chain at:idx) notNil ifTrue:[ - o inspect. - ] - ]. - moreButton beVisible. - anyShown := anyShownInAnyLevel := true. - showMore := false. - - "/ kludge - wait for some user action - - [showMore or:[stop or:[top realized not]]] whileFalse:[ - Delay waitForSeconds:0.1 - ]. - - chain := nil. - - top realized ifFalse:[ - stop := true - ] ifTrue:[ - listV doubleClickAction:nil. - showMore ifFalse:[ - stop := true. - ]. - ]. - done := false. - - stop ifFalse:[ - progress beVisible. - listV beInvisible. - moreButton beInvisible. - - chain := nil. - ] - ]. - levels size > 0 ifTrue:[ - levels last addAll:temporaryRemoved. - ] - ]. - ]. - - owners remove:Smalltalk ifAbsent:nil. - owners remove:(owners keyArray) ifAbsent:nil. - owners remove:objectArray ifAbsent:nil. - levels do:[:lColl | - owners remove:lColl ifAbsent:nil - ]. - - levels add:owners. - - objects := owners. - - objects size == 0 ifTrue:[ - stop := true - ]. - - stop ifTrue:[ - Smalltalk at:#'__VMProcesses__' put:nil. - top destroy. - anyShown ifFalse:[ - userStop ifFalse:[ - self information:(anyShownInAnyLevel ifTrue:['no more references'] ifFalse:['no references']). - ] - ]. - ^ self. - ]. + owners isEmpty ifTrue:[ + found ifFalse:[ + stop := true. + ] + ]. + + stop ifFalse:[ + done := found or:[(owners includesIdentical:Smalltalk)]. + done ifTrue:[ + moreChainsOnThisLevel := true. + temporaryRemoved := IdentitySet new. + + levels size > 0 ifTrue:[ + "/ show what we found so far. + levels last add:Smalltalk. + levels reverse. + ]. + + chains := OrderedCollection new. + + tLevels := levels collect:[:lColl | lColl copy]. + + lbl label:('building refchains ...'). + + nAll := aCollection size. + nDone := 0. + aCollection do:[:anObject | |theseChains| + stop ifFalse:[ + theseChains := self + refChainsFrom:Smalltalk + to:anObject + inRefSets:tLevels + startingAt:1. + + theseChains size > 0 ifTrue:[ + chains addAll:theseChains + ]. + nDone := nDone + 1. + progress percentage:(nDone / nAll * 100). + ] + ]. + + tLevels := nil. + + levels size > 0 ifTrue:[ + levels reverse. + levels last remove:Smalltalk. + ]. + + [stop not + and:[chains size > 0]] whileTrue:[ + chain := chains first. + chains removeFirst. + + lbl label:('found a reference chain.'). + progress beInvisible. + + chain addFirst:Smalltalk. + list := OrderedCollection newWithSize:chain size. + 1 to:chain size-1 do:[:i | + list + at:i + put:(self refNameFor:(chain at:i+1) in:(chain at:i)) + ]. + list at:list size put:(chain last classNameWithArticle). + + "/ hide the VMProcesses stuff from the user ... + (list at:1) string = 'Smalltalk:__VMProcesses__' ifTrue:[ + list at:1 put:'__VMProcesses__ (a hidden VM reference)'. + list removeIndex:2. + chain at:1 put:nil. + chain removeIndex:2. + ]. + + listV list:list. + + listV beVisible. + listV doubleClickAction:[:idx | |o| + (o := chain at:idx) notNil ifTrue:[ + o inspect. + ] + ]. + moreButton beVisible. + anyShown := anyShownInAnyLevel := true. + showMore := false. + + "/ kludge - wait for some user action + + [showMore or:[stop or:[top realized not]]] whileFalse:[ + Delay waitForSeconds:0.1 + ]. + + chain := nil. + + top realized ifFalse:[ + stop := true + ] ifTrue:[ + listV doubleClickAction:nil. + showMore ifFalse:[ + stop := true. + ]. + ]. + done := false. + + stop ifFalse:[ + progress beVisible. + listV beInvisible. + moreButton beInvisible. + + chain := nil. + ] + ]. + levels size > 0 ifTrue:[ + levels last addAll:temporaryRemoved. + ] + ]. + ]. + + owners remove:Smalltalk ifAbsent:nil. + owners remove:(owners keyArray) ifAbsent:nil. + owners remove:objectArray ifAbsent:nil. + levels do:[:lColl | + owners remove:lColl ifAbsent:nil + ]. + + levels add:owners. + + objects := owners. + + objects size == 0 ifTrue:[ + stop := true + ]. + + stop ifTrue:[ + Smalltalk at:#'__VMProcesses__' put:nil. + top destroy. + anyShown ifFalse:[ + userStop ifFalse:[ + self information:(anyShownInAnyLevel ifTrue:['no more references'] ifFalse:['no references']). + ] + ]. + ^ self. + ]. ]. anyShown ifTrue:[ - userStop ifFalse:[ - self information:'no more references'. - ] + userStop ifFalse:[ + self information:'no more references'. + ] ]. Smalltalk at:#'__VMProcesses__' put:nil. ^ self @@ -1704,7 +1774,11 @@ it may be removed (or replaced by a noop) without notice" %{ +#ifdef __SCHTEAM__ + someObject.dumpObject(); +#else __dumpObject__(someObject, __LINE__); +#endif %} " ObjectMemory dumpObject:true @@ -1717,8 +1791,12 @@ "dump my senders context" %{ +#ifdef __SCHTEAM__ + __c__.currentContinuation.dumpObject(); +#else __PATCHUPCONTEXT(__thisContext); __dumpContext__(__ContextInstPtr(__thisContext)->c_sender); +#endif %} " ObjectMemory dumpSender @@ -1731,11 +1809,14 @@ it will be removed without notice" %{ /* NOCONTEXT */ - +#ifdef __SCHTEAM__ + return __c__._RETURN(0); +#else if (! __isNonNilObject(anObject)) { RETURN ( nil ); } RETURN ( __mkSmallInteger( anObject->o_flags ) ); +#endif %} " F_ISREMEMBERED 1 /* a new-space thing being refd by some oldSpace thing */ @@ -1768,8 +1849,8 @@ if (addr) { RETURN ((OBJ)(addr)); } - RETURN (nil); -%} +%}. + ^ nil ! printReferences:anObject @@ -1930,8 +2011,11 @@ it will be removed without notice" %{ /* NOCONTEXT */ - +#ifdef __SCHTEAM__ + return __c__._RETURN(0); +#else RETURN ( __isNonNilObject(anObject) ? __mkSmallInteger(__qSize(anObject)) : __mkSmallInteger(0) ) +#endif %} " |hist big nw| @@ -1959,11 +2043,14 @@ it will be removed without notice" %{ /* NOCONTEXT */ - +#ifdef __SCHTEAM__ + return __c__._RETURN(0); +#else if (! __isNonNilObject(anObject)) { RETURN ( nil ); } RETURN ( __mkSmallInteger( __qSpace(anObject) ) ); +#endif %} ! ! @@ -2012,7 +2099,11 @@ it will be removed without notice" %{ +#ifdef __SCHTEAM__ + __c__.printWalkback( STObject.StandardErrorStream ); +#else __printStack(__context); +#endif %} " @@ -2208,7 +2299,9 @@ extern OBJ __processesKnownInVM(); RETURN (__processesKnownInVM()); -%} +%}. + ^ #() + " ObjectMemory processesKnownInVM " @@ -2283,8 +2376,8 @@ __markAndSweep(); RETURN (false); } - RETURN (true); -%} +%}. + ^ true " ObjectMemory compressingGarbageCollect @@ -2330,6 +2423,8 @@ |done limit| + self isSchteamEngine ifTrue:[^ false ]. + AbortOperationRequest handle:[:ex | "/ in case of abort (from the debugger), "/ disable gcSteps. @@ -2391,6 +2486,8 @@ |delay| + self isSchteamEngine ifTrue:[^ self]. + Processor activeProcess priority > Processor userBackgroundPriority ifTrue:[ delay := Delay forMilliseconds:1 ]. @@ -2501,6 +2598,8 @@ |p| + self isSchteamEngine ifTrue:[^ self]. + "/ "/ its not useful, to run it more than once "/ @@ -2881,9 +2980,13 @@ |result| %{ +#ifdef __SCHTEAM__ + return __c__._RETURN_false(); +#else extern int __fastMoreOldSpaceAllocation(); result = __fastMoreOldSpaceAllocation(aBoolean == true ? 1 : 0) ? true : false; +#endif %}. self saveGarbageCollectorSetting:#fastMoreOldSpaceAllocation: value:aBoolean. @@ -3058,7 +3161,11 @@ |result| %{ +#ifdef __SCHTEAM__ + return __c__._RETURN_false(); +#else result = __incrementalSweep((aBoolean == true) ? 1 : 0) ? true : false; +#endif %}. self saveGarbageCollectorSetting:#incrementalSweep: value:aBoolean. @@ -3092,10 +3199,14 @@ " %{ +#ifdef __SCHTEAM__ + return __c__._RETURN_false(); +#else if (flag == true) { __tenure(__context); } __lockTenure(flag == true ? 1 : 0); +#endif %}. self saveGarbageCollectorSetting:#lockTenure: value:flag. @@ -3173,10 +3284,14 @@ Notice: this is a nonstandard interface - use only in special situations." %{ +#ifdef __SCHTEAM__ + return __c__._RETURN_true(); +#else if (__isSmallInteger(howMuch)) { RETURN( __moreOldSpace(__context, __intVal(howMuch)) ? true : false ); } RETURN (false); +#endif %} " ObjectMemory moreOldSpace:1000000 @@ -3229,11 +3344,15 @@ |result| %{ +#ifdef __SCHTEAM__ + return __c__._RETURN_false(); +#else extern int __setNewSpaceSize(); if (__isSmallInteger(newSize)) { result = __setNewSpaceSize(__intVal(newSize)) ? true : false; } +#endif %}. result isNil ifTrue:[ self primitiveFailed. @@ -3710,6 +3829,7 @@ : -1); RETURN (__mkSmallInteger(prev)); %}. + ^ 0 " ObjectMemory byteCodeSizeLimitForDynamicCompilation:nil @@ -3737,6 +3857,7 @@ RETURN (__codeForCPU(aCPUSymbol)); %}. + ^ nil " ObjectMemory codeForCPU:nil @@ -3762,6 +3883,7 @@ : -1); RETURN (__mkSmallInteger(prev)); %}. + ^ 0 " ObjectMemory codeSizeLimitForDynamicCompilation:nil @@ -3780,7 +3902,9 @@ nBytes = __compiledCodeCounter(); RETURN (__mkSmallInteger(nBytes)); -%} +%}. + ^ 0 + " ObjectMemory compiledCodeCounter " @@ -3796,7 +3920,9 @@ nBytes = __compiledCodeSpaceUsed(); RETURN (__mkSmallInteger(nBytes)); -%} +%}. + ^ 0 + " ObjectMemory compiledCodeSpaceUsed " @@ -3806,9 +3932,13 @@ "return the setting of the full single step support flag" %{ /* NOCONTEXT */ +#ifdef __SCHTEAM__ + return __c__._RETURN_false(); +#else extern int __fullSingleStep(); RETURN (__fullSingleStep(-1) ? true : false); +#endif %} " ObjectMemory fullSingleStepSupport @@ -3824,6 +3954,9 @@ Execution is a bit slower if enabled." %{ /* NOCONTEXT */ +#ifdef __SCHTEAM__ + return __c__._RETURN_false(); +#else extern int __fullSingleStep(); int prev; @@ -3833,6 +3966,7 @@ ? 0 : -1); RETURN (prev ? true : false); +#endif %} " ObjectMemory fullSingleStepSupport:true @@ -3852,8 +3986,8 @@ if (limit) { RETURN (__mkSmallInteger(limit)); } - RETURN (nil); -%} +%}. + ^ nil ! insnSizeLimitForDynamicCompilation:aNumber @@ -3875,6 +4009,7 @@ : -1); RETURN (__mkSmallInteger(prev)); %}. + ^ 0 " ObjectMemory insnSizeLimitForDynamicCompilation:nil @@ -3889,7 +4024,9 @@ extern int __javaJustInTimeCompilation(); RETURN (__javaJustInTimeCompilation(-1) ? true : false); -%} +%}. + ^ false + " ObjectMemory javaJustInTimeCompilation " @@ -3990,6 +4127,8 @@ : -1); RETURN (prev ? true : false); %}. + ^ false + " ObjectMemory justInTimeCompilation:true ObjectMemory justInTimeCompilation:false @@ -4003,7 +4142,9 @@ extern int __optimizeContexts(); RETURN (__optimizeContexts(-1) ? true : false); -%} +%}. + ^ false + " ObjectMemory optimizeContexts " @@ -4024,7 +4165,9 @@ ? 0 : -1); RETURN (prev ? true : false); -%} +%}. + ^ false + " ObjectMemory optimizeContexts:true ObjectMemory optimizeContexts:false @@ -4088,7 +4231,9 @@ extern int __canDoJustInTimeCompilation(); RETURN (__canDoJustInTimeCompilation() ? true : false); -%} +%}. + ^ false + " ObjectMemory supportsJustInTimeCompilation " @@ -4365,7 +4510,9 @@ extern unsigned int __newSpaceUsed(); RETURN ( __MKUINT(__oldSpaceUsed() + (INT)__newSpaceUsed() - __freeListSpace()) ); -%} +%}. + ^ 0 + " ObjectMemory bytesUsed " @@ -4397,7 +4544,8 @@ #else RETURN(__mkSmallInteger(0)); #endif -%} +%}. + ^ 0 " self collectedOldSpaceAddress @@ -4411,7 +4559,9 @@ extern unsigned __fixSpaceSize(); RETURN ( __MKUINT(__fixSpaceSize()) ); -%} +%}. + ^ 0 + " ObjectMemory fixSpaceSize " @@ -4424,7 +4574,9 @@ extern unsigned __fixSpaceUsed(); RETURN ( __MKUINT(__fixSpaceUsed()) ); -%} +%}. + ^ 0 + " ObjectMemory fixSpaceUsed " @@ -4438,7 +4590,9 @@ extern unsigned INT __freeListSpace(); RETURN ( __MKUINT(__freeListSpace()) ); -%} +%}. + ^ 0 + " ObjectMemory freeListSpace " @@ -4452,7 +4606,9 @@ extern unsigned INT __oldSpaceSize(), __oldSpaceUsed(); RETURN ( __MKUINT(__oldSpaceSize() - __oldSpaceUsed()) ); -%} +%}. + ^ 0 + " ObjectMemory freeSpace " @@ -4465,7 +4621,9 @@ extern int __garbageCollectCount(); RETURN (__mkSmallInteger(__garbageCollectCount())); -%} +%}. + ^ 0 + " ObjectMemory garbageCollectCount " @@ -4478,7 +4636,9 @@ extern int __incrementalGCCount(); RETURN (__mkSmallInteger(__incrementalGCCount())); -%} +%}. + ^ 0 + " ObjectMemory incrementalGCCount " @@ -4499,7 +4659,8 @@ extern int __incrGCphase(); RETURN (__mkSmallInteger(__incrGCphase())); -%} +%}. + ^ 2 ! incrementalGCPhaseSymbolic @@ -4524,6 +4685,16 @@ "Created: / 10.8.1998 / 15:02:52 / cg" ! +isSchteamEngine + "is this Smalltalk/X system running under the new Schteam engine?" +%{ +#ifdef __SCHTEAM__ + return __c__._RETURN_true(); +#endif +%}. + ^ false +! + lastScavengeReclamation "returns the number of bytes replacimed by the last scavenge. For statistic only - this may vanish." @@ -4532,7 +4703,9 @@ extern int __newSpaceReclaimed(); RETURN ( __mkSmallInteger(__newSpaceReclaimed()) ); -%} +%}. + ^ 0 + "percentage of reclaimed objects is returned by: ((ObjectMemory lastScavengeReclamation) @@ -4548,7 +4721,9 @@ extern OBJ __lifoRememberedSet(); RETURN ( __lifoRememberedSet() ); -%} +%}. + ^ nil + " ObjectMemory lifoRememberedSet " @@ -4562,7 +4737,9 @@ extern int __lifoRememberedSetSize(); RETURN (__mkSmallInteger(__lifoRememberedSetSize())); -%} +%}. + ^ 0 + " ObjectMemory lifoRememberedSetSize " @@ -4581,7 +4758,9 @@ RETURN(__mkSmallInteger(0)); } RETURN ( __MKUINT(statsArray[0])); -%} +%}. + ^ 0 + " ObjectMemory mallocAllocated " @@ -4609,7 +4788,9 @@ } RETURN ( allStats ); -%} +%}. + ^ #() + " ObjectMemory mallocStatsArray " @@ -4628,7 +4809,9 @@ RETURN(__mkSmallInteger(0)); } RETURN ( __MKUINT(statsArray[1])); -%} +%}. + ^ 0 + " ObjectMemory mallocTotal " @@ -4641,7 +4824,9 @@ extern int __markAndSweepCount(); RETURN (__mkSmallInteger(__markAndSweepCount())); -%} +%}. + ^ 0 + " ObjectMemory markAndSweepCount " @@ -4655,21 +4840,25 @@ %{ /* NOCONTEXT */ RETURN ( __mkSmallInteger( __MAX_HASH__ << __HASH_SHIFT__) ); -%} +%}. + ^ 8191 + " ObjectMemory maximumIdentityHashValue " ! minScavengeReclamation - "returns the number of bytes replacimed by the least effective scavenge. + "returns the number of bytes replaimed by the least effective scavenge. For statistic only - this may vanish." %{ /* NOCONTEXT */ extern int __newSpaceReclaimedMin(); RETURN ( __mkSmallInteger(__newSpaceReclaimedMin()) ); -%} +%}. + ^ 0 + " ObjectMemory minScavengeReclamation " @@ -4682,7 +4871,9 @@ extern unsigned __newSpaceSize(); RETURN ( __MKUINT(__newSpaceSize()) ); -%} +%}. + ^ 0 + " ObjectMemory newSpaceSize " @@ -4697,7 +4888,9 @@ extern unsigned int __newSpaceUsed(); RETURN ( __MKUINT(__newSpaceUsed()) ); -%} +%}. + ^ 0 + " ObjectMemory newSpaceUsed " @@ -4724,7 +4917,9 @@ extern int __weakListSize(); RETURN ( __mkSmallInteger(__weakListSize()) ); -%} +%}. + ^ 0 + " ObjectMemory numberOfWeakObjects " @@ -4737,7 +4932,8 @@ #else RETURN(__mkSmallInteger(0)); #endif -%} +%}. + ^ 0 " self oldSpaceAddress @@ -4754,7 +4950,9 @@ extern unsigned INT __oldSpaceAllocatedSinceLastGC(); RETURN ( __MKUINT(__oldSpaceAllocatedSinceLastGC()) ); -%} +%}. + ^ 0 + " ObjectMemory oldSpaceAllocatedSinceLastGC " @@ -4767,7 +4965,9 @@ extern unsigned INT __oldSpaceSize(); RETURN ( __MKUINT(__oldSpaceSize()) ); -%} +%}. + ^ 0 + " ObjectMemory oldSpaceSize " @@ -4781,7 +4981,9 @@ extern unsigned INT __oldSpaceUsed(); RETURN ( __MKUINT(__oldSpaceUsed()) ); -%} +%}. + ^ 0 + " ObjectMemory oldSpaceUsed " @@ -4795,7 +4997,9 @@ extern unsigned int __rememberedSetSize(); RETURN (__mkSmallInteger(__rememberedSetSize())); -%} +%}. + ^ 0 + " ObjectMemory rememberedSetSize " @@ -4811,6 +5015,7 @@ __resetNewSpaceReclaimedMin(); %}. ^ self + " ObjectMemory resetMinScavengeReclamation. ObjectMemory minScavengeReclamation @@ -4834,7 +5039,9 @@ extern int __runsSingleOldSpace(); RETURN ( (__runsSingleOldSpace() ? true : false) ); -%} +%}. + ^ true + " ObjectMemory runsSingleOldSpace " @@ -4847,7 +5054,9 @@ extern int __scavengeCount(); RETURN (__mkSmallInteger(__scavengeCount())); -%} +%}. + ^ 0 + " ObjectMemory scavengeCount " @@ -4860,7 +5069,9 @@ extern unsigned __symSpaceSize(); RETURN ( __mkSmallInteger(__symSpaceSize()) ); -%} +%}. + ^ 0 + " ObjectMemory symSpaceSize " @@ -4873,7 +5084,9 @@ extern unsigned __symSpaceUsed(); RETURN ( __mkSmallInteger(__symSpaceUsed()) ); -%} +%}. + ^ 0 + " ObjectMemory symSpaceUsed " @@ -4888,7 +5101,8 @@ extern unsigned __tenureAge(); RETURN ( __mkSmallInteger(__tenureAge()) ); -%} +%}. + ^ 0 ! vmSymbols @@ -5056,66 +5270,66 @@ modules := IdentityDictionary new. self allBinaryModulesDo:[:idArg :nameArg :flagsArg :libName :timeStamp | - |type subModuleName module dynamic infoRec handle pathName - typeName name nameString| - - nameArg isString ifFalse:[ - 'Error in binaryModuleInfo - skip entry' errorPrintCR. - ] ifTrue:[ - name := nameArg. - subModuleName := name asSymbol. - - idArg > 0 ifTrue:[ - dynamic := true. - typeName := 'dynamic '. - handle := ObjectFileLoader handleFromID:idArg. - (handle isNil or:[(pathName := handle pathName) isNil]) ifTrue:[ - name := '?' - ] ifFalse:[ - name := pathName asFilename baseName - ] - ] ifFalse:[ - dynamic := false. - typeName := 'builtIn '. - pathName := nil. - libName isNil ifTrue:[ - name := subModuleName - ] ifFalse:[ - name := libName - ]. - ]. - nameString := typeName. - libName isNil ifTrue:[ - nameString := nameString, 'module ' - ] ifFalse:[ - nameString := nameString, 'classLib ' - ]. - nameString := nameString , name. - - libName isNil ifTrue:[ - type := #classObject - ] ifFalse:[ - type := #classLibrary - ]. - - infoRec := modules at:idArg ifAbsent:nil. - infoRec notNil ifTrue:[ - infoRec classNames add:subModuleName. - ] ifFalse:[ - infoRec := BinaryModuleDescriptor - name:nameString - type:type - id:idArg - dynamic:dynamic - classNames:( (OrderedSet ? Set) with:subModuleName) - handle:handle - pathName:pathName - libraryName:libName - timeStamp:nil. - - modules at:idArg put:infoRec. - ]. - ]. + |type subModuleName module dynamic infoRec handle pathName + typeName name nameString| + + nameArg isString ifFalse:[ + 'Error in binaryModuleInfo - skip entry' errorPrintCR. + ] ifTrue:[ + name := nameArg. + subModuleName := name asSymbol. + + idArg > 0 ifTrue:[ + dynamic := true. + typeName := 'dynamic '. + handle := ObjectFileLoader handleFromID:idArg. + (handle isNil or:[(pathName := handle pathName) isNil]) ifTrue:[ + name := '?' + ] ifFalse:[ + name := pathName asFilename baseName + ] + ] ifFalse:[ + dynamic := false. + typeName := 'builtIn '. + pathName := nil. + libName isNil ifTrue:[ + name := subModuleName + ] ifFalse:[ + name := libName + ]. + ]. + nameString := typeName. + libName isNil ifTrue:[ + nameString := nameString, 'module ' + ] ifFalse:[ + nameString := nameString, 'classLib ' + ]. + nameString := nameString , name. + + libName isNil ifTrue:[ + type := #classObject + ] ifFalse:[ + type := #classLibrary + ]. + + infoRec := modules at:idArg ifAbsent:nil. + infoRec notNil ifTrue:[ + infoRec classNames add:subModuleName. + ] ifFalse:[ + infoRec := BinaryModuleDescriptor + name:nameString + type:type + id:idArg + dynamic:dynamic + classNames:( (OrderedSet ? Set) with:subModuleName) + handle:handle + pathName:pathName + libraryName:libName + timeStamp:nil. + + modules at:idArg put:infoRec. + ]. + ]. ]. ^ modules @@ -5137,7 +5351,9 @@ extern OBJ __getVMReleaseStrings(); RETURN (__getVMReleaseStrings()); -%} +%}. + ^ #() + " ObjectMemory getVMIdentificationStrings " @@ -5153,14 +5369,14 @@ "/ the current directory is not a good idea, if stx is started via a desktop manager "/ or in osx, by clicking on stx.app. dir isRootDirectory ifTrue:[ - exeDir := OperatingSystem nameOfSTXExecutable asFilename directory. - dir ~= exeDir ifTrue:[ - "/ Change it to ~/.smalltalk or is executable directory better? - - "/ use executable dir, as otherwise I'd have to change the VM to include an image path... - "/ dir := Filename usersPrivateSmalltalkDirectory. - dir := exeDir. - ]. + exeDir := OperatingSystem nameOfSTXExecutable asFilename directory. + dir ~= exeDir ifTrue:[ + "/ Change it to ~/.smalltalk or is executable directory better? + + "/ use executable dir, as otherwise I'd have to change the VM to include an image path... + "/ dir := Filename usersPrivateSmalltalkDirectory. + dir := exeDir. + ]. ]. ^ dir @@ -5216,8 +5432,8 @@ "/ make the changeFilePath an absolute one, "/ in case some stupid windows fileDialog changes the current directory... self - nameForChanges:(self directoryForImageAndChangeFile / ObjectMemory nameForChangesLocal) - asAbsoluteFilename pathName + nameForChanges:(self directoryForImageAndChangeFile / ObjectMemory nameForChangesLocal) + asAbsoluteFilename pathName " self initChangeFilename @@ -5320,6 +5536,7 @@ ImageName := filenameString. ImageSaveTime := Timestamp now. + ok := false. %{ /* CALLSSTACK:32000 */ @@ -5393,7 +5610,7 @@ ST-80 compatibility; send #preSnapshot to all classes " Smalltalk allClassesDo:[:aClass | - aClass preSnapshot + aClass preSnapshot ]. " @@ -5403,58 +5620,58 @@ " snapshotFilename := aFileName asFilename. snapshotFilename isAbsolute ifFalse:[ - snapshotFilename := self directoryForImageAndChangeFile - / snapshotFilename name. + snapshotFilename := self directoryForImageAndChangeFile + / snapshotFilename name. ]. tempFilename := (FileStream newTemporaryIn:snapshotFilename directory) - close; - fileName. + close; + fileName. ok := self primSnapShotOn:tempFilename. ok ifTrue:[ - "keep history of one snapshot file" - snapshotFilename exists ifTrue:[ - tempFilename symbolicAccessRights:snapshotFilename symbolicAccessRights. - snapshotFilename renameTo:(snapshotFilename withSuffix:'sav'). - ] ifFalse:[ - "image file hat stx as interpreter and can be executed" - tempFilename makeExecutable. - ]. - tempFilename renameTo:snapshotFilename. - - Class addChangeRecordForSnapshot:aFileName. - - setImageName ifTrue:[ - oldChangeFile := self nameForChanges. - ImageName := snapshotFilename asAbsoluteFilename asString. - self refreshChangesFrom:oldChangeFile. - ]. + "keep history of one snapshot file" + snapshotFilename exists ifTrue:[ + tempFilename symbolicAccessRights:snapshotFilename symbolicAccessRights. + snapshotFilename renameTo:(snapshotFilename withSuffix:'sav'). + ] ifFalse:[ + "image file hat stx as interpreter and can be executed" + tempFilename makeExecutable. + ]. + tempFilename renameTo:snapshotFilename. + + Class addChangeRecordForSnapshot:aFileName. + + setImageName ifTrue:[ + oldChangeFile := self nameForChanges. + ImageName := snapshotFilename asAbsoluteFilename asString. + self refreshChangesFrom:oldChangeFile. + ]. ] ifFalse:[ - tempFilename remove. + tempFilename remove. ]. " ST-80 compatibility; send #postSnapshot to all classes " Smalltalk allClassesDo:[:aClass | - aClass postSnapshot + aClass postSnapshot ]. self changed:#finishedSnapshot. "/ ST-80 compatibility ok ifFalse:[ - SnapshotError raise. - "not reached" + SnapshotError raise. + "not reached" ]. Transcript - show:'Snapshot '; - show:snapshotFilename baseName allBold; - show:' saved '; - show:Timestamp now; - show:' in '; - show:snapshotFilename asAbsoluteFilename directoryName; - showCR:'.'. + show:'Snapshot '; + show:snapshotFilename baseName allBold; + show:' saved '; + show:Timestamp now; + show:' in '; + show:snapshotFilename asAbsoluteFilename directoryName; + showCR:'.'. ^ ok @@ -5617,11 +5834,11 @@ !ObjectMemory class methodsFor:'documentation'! version - ^ '$Header: /cvs/stx/stx/libbasic/ObjectMemory.st,v 1.286 2015-02-20 22:45:22 cg Exp $' + ^ '$Header: /cvs/stx/stx/libbasic/ObjectMemory.st,v 1.287 2015-05-24 12:52:28 cg Exp $' ! version_CVS - ^ '$Header: /cvs/stx/stx/libbasic/ObjectMemory.st,v 1.286 2015-02-20 22:45:22 cg Exp $' + ^ '$Header: /cvs/stx/stx/libbasic/ObjectMemory.st,v 1.287 2015-05-24 12:52:28 cg Exp $' ! version_SVN diff -r 20527009f352 -r 9a3fc7cc7127 SmallInteger.st --- a/SmallInteger.st Mon May 25 02:51:46 2015 +0100 +++ b/SmallInteger.st Mon May 25 06:37:39 2015 +0200 @@ -3936,7 +3936,61 @@ |s| %{ -#ifndef __SCHTEAM__ +#ifdef __SCHTEAM__ + int __base = base.intValue(); + long myValue = self.longValue(); + java.lang.String __s; + + switch (__base) { + case 2: + __s = java.lang.Long.toBinaryString(myValue); + break; + + case 8: + __s = java.lang.Long.toOctalString(myValue); + break; + + case 10: + __s = java.lang.Long.toString(myValue); + break; + + case 16: + __s = java.lang.Long.toHexString(myValue); + break; + + default: + { + boolean negative = false; + __s = ""; + + if ((__base > 36) || (__base < 2)) { + throw new SmalltalkError("invalid base: ", base); + } + if (myValue < 0) { + negative = true; + myValue = -myValue; + } + while (myValue != 0) { + int digit; + char ch; + + digit = (int)(myValue % __base); + if (digit <= 9) { + ch = (char)('0' + digit); + } else { + ch = (char)('A' + digit - 10); + } + __s = ch + __s; + myValue = myValue / __base; + } + if (negative) { + __s = "-" + __s; + } + break; + } + } + return context._RETURN( new STString( __s )); +#else char buffer[64+3]; /* for 64bit machines, base 2, plus sign, plus 0-byte */ char *cp; OBJ newString; @@ -4887,11 +4941,11 @@ !SmallInteger class methodsFor:'documentation'! version - ^ '$Header: /cvs/stx/stx/libbasic/SmallInteger.st,v 1.237 2015-05-23 14:09:31 cg Exp $' + ^ '$Header: /cvs/stx/stx/libbasic/SmallInteger.st,v 1.238 2015-05-24 12:52:47 cg Exp $' ! version_CVS - ^ '$Header: /cvs/stx/stx/libbasic/SmallInteger.st,v 1.237 2015-05-23 14:09:31 cg Exp $' + ^ '$Header: /cvs/stx/stx/libbasic/SmallInteger.st,v 1.238 2015-05-24 12:52:47 cg Exp $' ! ! diff -r 20527009f352 -r 9a3fc7cc7127 UnixOperatingSystem.st --- a/UnixOperatingSystem.st Mon May 25 02:51:46 2015 +0100 +++ b/UnixOperatingSystem.st Mon May 25 06:37:39 2015 +0200 @@ -10863,10 +10863,17 @@ This depends on a working select or FIONREAD to be provided by the OS." %{ +#ifdef __SCHTEAM__ + { + int avail = fd.streamAvailable(); + return __c__._RETURN (avail > 0 ? STObject.True : STObject.False); + } + /* NOTREACHED */ +#else /* * if available, try FIONREAD first, which is usually done faster. */ -#if 0 && defined(FIONREAD) +# if 0 && defined(FIONREAD) if (__isSmallInteger(fd)) { int result = 0; @@ -10874,7 +10881,8 @@ RETURN(result > 0 ? true : false); } } -#endif /* FIONREAD */ +# endif /* FIONREAD */ +#endif %}. ^ super readCheck:fd @@ -14421,11 +14429,11 @@ !UnixOperatingSystem class methodsFor:'documentation'! version - ^ '$Header: /cvs/stx/stx/libbasic/UnixOperatingSystem.st,v 1.440 2015-05-19 13:41:07 cg Exp $' + ^ '$Header: /cvs/stx/stx/libbasic/UnixOperatingSystem.st,v 1.441 2015-05-24 12:52:03 cg Exp $' ! version_CVS - ^ '$Header: /cvs/stx/stx/libbasic/UnixOperatingSystem.st,v 1.440 2015-05-19 13:41:07 cg Exp $' + ^ '$Header: /cvs/stx/stx/libbasic/UnixOperatingSystem.st,v 1.441 2015-05-24 12:52:03 cg Exp $' ! !