.
--- a/Behavior.st Sat Aug 05 16:05:36 1995 +0200
+++ b/Behavior.st Tue Aug 08 02:49:43 1995 +0200
@@ -22,7 +22,7 @@
COPYRIGHT (c) 1988 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Behavior.st,v 1.44 1995-07-28 02:35:49 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Behavior.st,v 1.45 1995-08-08 00:45:54 claus Exp $
'!
!Behavior class methodsFor:'documentation'!
@@ -43,7 +43,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Behavior.st,v 1.44 1995-07-28 02:35:49 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Behavior.st,v 1.45 1995-08-08 00:45:54 claus Exp $
"
!
@@ -1982,7 +1982,14 @@
theClass := superclass.
[theClass notNil] whileTrue:[
(theClass == aClass) ifTrue:[^ true].
- theClass := theClass superclass
+%{
+ if (__isBehaviorLike(theClass)) {
+ theClass = __ClassInstPtr(theClass)->c_superclass;
+ } else {
+ theClass = nil;
+ }
+%}.
+"/ theClass := theClass superclass.
].
^ false
--- a/Context.st Sat Aug 05 16:05:36 1995 +0200
+++ b/Context.st Tue Aug 08 02:49:43 1995 +0200
@@ -22,7 +22,7 @@
COPYRIGHT (c) 1988 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Context.st,v 1.34 1995-07-02 01:06:16 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Context.st,v 1.35 1995-08-08 00:46:14 claus Exp $
'!
!Context class methodsFor:'documentation'!
@@ -43,7 +43,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Context.st,v 1.34 1995-07-02 01:06:16 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Context.st,v 1.35 1995-08-08 00:46:14 claus Exp $
"
!
@@ -430,9 +430,15 @@
^ lineNr bitAnd:16rFFFF
!
+setLineNumber:aNumber
+ "private entry for uncompiledCodeObject ..."
+
+ lineNr := aNumber
+!
+
canReturn
"return true, if the receiver allows returning through it.
- For normal method contexts, this normally returns true;
+ For normal method contexts, this returns true;
for blocks, it (currently) always returns false.
However, the system can be compiled (for production code), to create
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/HRegistry.st Tue Aug 08 02:49:43 1995 +0200
@@ -0,0 +1,77 @@
+"
+ COPYRIGHT (c) 1995 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+Registry subclass:#HandleRegistry
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'System-Support'
+!
+
+HandleRegistry comment:'
+COPYRIGHT (c) 1993 by Claus Gittinger
+ All Rights Reserved
+
+$Header: /cvs/stx/stx/libbasic/Attic/HRegistry.st,v 1.1 1995-08-08 00:46:33 claus Exp $
+'!
+
+!HandleRegistry class methodsFor:'documentation'!
+
+copyright
+"
+ COPYRIGHT (c) 1995 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+!
+
+version
+"
+$Header: /cvs/stx/stx/libbasic/Attic/HRegistry.st,v 1.1 1995-08-08 00:46:33 claus Exp $
+"
+!
+
+documentation
+"
+ HandleRegistries are like Registries, in that they watch for the death of
+ a registered object. However, they send a self-change notification, passing the registered
+ handle as argument, instead of creating a shallow copy and letting it do the finalization.
+ Use Registry for objects which know themself how to clean up;
+ use HandleRegistry, if someone else does the cleanup.
+"
+! !
+
+!HandleRegistry methodsFor:'dispose handling'!
+
+informDispose:someHandle
+ self changed:#finalize with:someHandle from:self
+! !
+
+!HandleRegistry methodsFor:'redefined to block'!
+
+registerChange:anObject
+ "not useful for HandleRegistry"
+
+ self shouldNotImplement
+!
+
+register:anObject
+ "not useful for HandleRegistry - use #register:as:"
+
+ self shouldNotImplement
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/HandleRegistry.st Tue Aug 08 02:49:43 1995 +0200
@@ -0,0 +1,77 @@
+"
+ COPYRIGHT (c) 1995 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+Registry subclass:#HandleRegistry
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'System-Support'
+!
+
+HandleRegistry comment:'
+COPYRIGHT (c) 1993 by Claus Gittinger
+ All Rights Reserved
+
+$Header: /cvs/stx/stx/libbasic/HandleRegistry.st,v 1.1 1995-08-08 00:46:33 claus Exp $
+'!
+
+!HandleRegistry class methodsFor:'documentation'!
+
+copyright
+"
+ COPYRIGHT (c) 1995 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+!
+
+version
+"
+$Header: /cvs/stx/stx/libbasic/HandleRegistry.st,v 1.1 1995-08-08 00:46:33 claus Exp $
+"
+!
+
+documentation
+"
+ HandleRegistries are like Registries, in that they watch for the death of
+ a registered object. However, they send a self-change notification, passing the registered
+ handle as argument, instead of creating a shallow copy and letting it do the finalization.
+ Use Registry for objects which know themself how to clean up;
+ use HandleRegistry, if someone else does the cleanup.
+"
+! !
+
+!HandleRegistry methodsFor:'dispose handling'!
+
+informDispose:someHandle
+ self changed:#finalize with:someHandle from:self
+! !
+
+!HandleRegistry methodsFor:'redefined to block'!
+
+registerChange:anObject
+ "not useful for HandleRegistry"
+
+ self shouldNotImplement
+!
+
+register:anObject
+ "not useful for HandleRegistry - use #register:as:"
+
+ self shouldNotImplement
+! !
--- a/IdDict.st Sat Aug 05 16:05:36 1995 +0200
+++ b/IdDict.st Tue Aug 08 02:49:43 1995 +0200
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1992 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Attic/IdDict.st,v 1.12 1995-07-22 19:22:47 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/IdDict.st,v 1.13 1995-08-08 00:47:13 claus Exp $
'!
!IdentityDictionary class methodsFor:'documentation'!
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Attic/IdDict.st,v 1.12 1995-07-22 19:22:47 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/IdDict.st,v 1.13 1995-08-08 00:47:13 claus Exp $
"
!
@@ -91,7 +91,8 @@
if key was not found, and no unused slots where present"
|index "{ Class:SmallInteger }"
- length startIndex probe |
+ length "{ Class:SmallInteger }"
+ startIndex probe |
length := keyArray basicSize.
index := key identityHash.
@@ -120,7 +121,7 @@
key is not already in the receiver - used only while growing/rehashing"
|index "{ Class:SmallInteger }"
- length|
+ length "{ Class:SmallInteger }"|
length := keyArray basicSize.
index := key identityHash.
--- a/IdentityDictionary.st Sat Aug 05 16:05:36 1995 +0200
+++ b/IdentityDictionary.st Tue Aug 08 02:49:43 1995 +0200
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1992 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/IdentityDictionary.st,v 1.12 1995-07-22 19:22:47 claus Exp $
+$Header: /cvs/stx/stx/libbasic/IdentityDictionary.st,v 1.13 1995-08-08 00:47:13 claus Exp $
'!
!IdentityDictionary class methodsFor:'documentation'!
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/IdentityDictionary.st,v 1.12 1995-07-22 19:22:47 claus Exp $
+$Header: /cvs/stx/stx/libbasic/IdentityDictionary.st,v 1.13 1995-08-08 00:47:13 claus Exp $
"
!
@@ -91,7 +91,8 @@
if key was not found, and no unused slots where present"
|index "{ Class:SmallInteger }"
- length startIndex probe |
+ length "{ Class:SmallInteger }"
+ startIndex probe |
length := keyArray basicSize.
index := key identityHash.
@@ -120,7 +121,7 @@
key is not already in the receiver - used only while growing/rehashing"
|index "{ Class:SmallInteger }"
- length|
+ length "{ Class:SmallInteger }"|
length := keyArray basicSize.
index := key identityHash.
--- a/Make.proto Sat Aug 05 16:05:36 1995 +0200
+++ b/Make.proto Tue Aug 08 02:49:43 1995 +0200
@@ -1,4 +1,4 @@
-# $Header: /cvs/stx/stx/libbasic/Make.proto,v 1.33 1995-07-22 19:25:26 claus Exp $
+# $Header: /cvs/stx/stx/libbasic/Make.proto,v 1.34 1995-08-08 00:49:43 claus Exp $
#
# -------------- no need to change anything below ----------
@@ -91,6 +91,7 @@
Geometric.$(O) \
Rectangle.$(O) \
Registry.$(O) \
+ HRegistry.$(O) \
Signal.$(O) \
Smalltalk.$(O) \
Stream.$(O) \
@@ -239,6 +240,7 @@
STRING=$(I)/String.H $(CHARARRAY)
Registry.$(O): Registry.st $(OBJECT)
+HRegistry.$(O): HRegistry.st $(I)/Registry.H $(OBJECT)
Coll.$(O): Coll.st $(OBJECT)
FileDir.$(O): FileDir.st $(COLL)
SeqColl.$(O): SeqColl.st $(COLL)
--- a/Metaclass.st Sat Aug 05 16:05:36 1995 +0200
+++ b/Metaclass.st Tue Aug 08 02:49:43 1995 +0200
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1988 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Metaclass.st,v 1.27 1995-07-22 19:23:05 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Metaclass.st,v 1.28 1995-08-08 00:47:25 claus Exp $
'!
!Metaclass class methodsFor:'documentation'!
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Metaclass.st,v 1.27 1995-07-22 19:23:05 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Metaclass.st,v 1.28 1995-08-08 00:47:25 claus Exp $
"
!
@@ -751,7 +751,7 @@
oldNames newNames addedNames
oldOffsets newOffsets offset changeSet delta
oldToNew newSubMeta newSub oldSubMeta oldSuper
- commonClassInstVars|
+ commonClassInstVars currentProject|
"
cleanup needed here: extract common things with name:inEnvironment:...
@@ -846,6 +846,16 @@
newClass category:(oldClass category).
newClass primitiveSpec:(oldClass primitiveSpec).
+ "/ set the new classes package
+
+ Project notNil ifTrue:[
+ currentProject := Project current.
+ currentProject notNil ifTrue:[
+ newMetaclass package:(currentProject packageName).
+ newClass package:(currentProject packageName).
+ ]
+ ].
+
changeSet := Set new.
((oldNames size == 0)
or:[newNames startsWith:oldNames]) ifTrue:[
--- a/Method.st Sat Aug 05 16:05:36 1995 +0200
+++ b/Method.st Tue Aug 08 02:49:43 1995 +0200
@@ -23,7 +23,7 @@
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Method.st,v 1.39 1995-07-22 19:23:12 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Method.st,v 1.40 1995-08-08 00:47:31 claus Exp $
'!
!Method class methodsFor:'documentation'!
@@ -44,7 +44,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Method.st,v 1.39 1995-07-22 19:23:12 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Method.st,v 1.40 1995-08-08 00:47:31 claus Exp $
"
!
@@ -877,6 +877,10 @@
(self code notNil and:[self code = m code]) ifTrue:[^ true].
(byteCode notNil and:[byteCode == m byteCode]) ifTrue:[^ true].
+ m := Method compiledMethodAt:#uncompiledCodeObject.
+ (self code notNil and:[self code = m code]) ifTrue:[^ true].
+ (byteCode notNil and:[byteCode == m byteCode]) ifTrue:[^ true].
+
m := Metaclass compiledMethodAt:#invalidCodeObject.
(self code notNil and:[self code = m code]) ifTrue:[^ true].
(byteCode notNil and:[byteCode == m byteCode]) ifTrue:[^ true].
@@ -905,6 +909,21 @@
errorString:'invalid method - not executable'.
!
+uncompiledCodeObject
+ "this method is invoked by methods which contain primitive code,
+ but have not been compiled to machine code (either due to an error
+ when compiling, or simply because no stc is available.
+ For those methods, the compiler generated a method object consisting
+ of the original source code, but with this methods machine/byte code.
+ Therefore, we patch (kludge) the lineNumber information, to show the
+ first line (instead of the real line below)"
+
+ thisContext setLineNumber:1.
+ ^ InvalidCodeSignal
+ raiseRequestWith:self
+ errorString:'invalid method - not compiled'.
+!
+
wrongNumberOfArguments:numberGiven
"this error is triggered, if a method is called with a wrong number
of arguments. This only applies to #valueWithReceiverXXX - sends.
--- a/MiniDebug.st Sat Aug 05 16:05:36 1995 +0200
+++ b/MiniDebug.st Tue Aug 08 02:49:43 1995 +0200
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1988 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Attic/MiniDebug.st,v 1.13 1995-07-02 01:07:16 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/MiniDebug.st,v 1.14 1995-08-08 00:47:37 claus Exp $
'!
!MiniDebugger class methodsFor: 'documentation'!
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Attic/MiniDebug.st,v 1.13 1995-07-02 01:07:16 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/MiniDebug.st,v 1.14 1995-08-08 00:47:37 claus Exp $
"
!
@@ -288,7 +288,7 @@
Process allInstancesDo:[:p |
'proc id=' print. p id print. ' name=' print. p name print. ' state=' print.
- p state printNewline.
+ p state print. ' prio=' print. p priority printNL.
]
!
--- a/MiniDebugger.st Sat Aug 05 16:05:36 1995 +0200
+++ b/MiniDebugger.st Tue Aug 08 02:49:43 1995 +0200
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1988 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/MiniDebugger.st,v 1.13 1995-07-02 01:07:16 claus Exp $
+$Header: /cvs/stx/stx/libbasic/MiniDebugger.st,v 1.14 1995-08-08 00:47:37 claus Exp $
'!
!MiniDebugger class methodsFor: 'documentation'!
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/MiniDebugger.st,v 1.13 1995-07-02 01:07:16 claus Exp $
+$Header: /cvs/stx/stx/libbasic/MiniDebugger.st,v 1.14 1995-08-08 00:47:37 claus Exp $
"
!
@@ -288,7 +288,7 @@
Process allInstancesDo:[:p |
'proc id=' print. p id print. ' name=' print. p name print. ' state=' print.
- p state printNewline.
+ p state print. ' prio=' print. p priority printNL.
]
!
--- a/ObjMem.st Sat Aug 05 16:05:36 1995 +0200
+++ b/ObjMem.st Tue Aug 08 02:49:43 1995 +0200
@@ -34,7 +34,7 @@
COPYRIGHT (c) 1992 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Attic/ObjMem.st,v 1.48 1995-08-03 01:15:54 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/ObjMem.st,v 1.49 1995-08-08 00:47:48 claus Exp $
'!
!ObjectMemory class methodsFor:'documentation'!
@@ -55,7 +55,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Attic/ObjMem.st,v 1.48 1995-08-03 01:15:54 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/ObjMem.st,v 1.49 1995-08-08 00:47:48 claus Exp $
"
!
@@ -457,6 +457,59 @@
^ LowSpaceSemaphore
! !
+!ObjectMemory class methodsFor:'VM messages'!
+
+infoPrinting:aBoolean
+ "turn on/off various informational printouts in the VM.
+ For example, the GC activity messages are controlled by
+ this flags setting.
+ The default is true, since (currently) those messages
+ are useful for ST/X developers."
+
+%{ /* NOCONTEXT */
+ extern int __infoPrinting;
+
+ __infoPrinting = (aBoolean == true);
+%}
+!
+
+infoPrinting
+ "return true, if various informational printouts in the VM
+ are turned on, false of off."
+
+%{ /* NOCONTEXT */
+ extern int __infoPrinting;
+
+ RETURN (__infoPrinting ? true : false);
+%}
+!
+
+debugPrinting:aBoolean
+ "turn on/off various debug printouts in the VM
+ in case of an error. For example, a double-notUnderstood
+ leads to a VM context dump if debugPrinting is on.
+ If off, those messages are suppressed.
+ The default is on, since these messages are only printed for
+ severe errors."
+
+%{ /* NOCONTEXT */
+ extern int __debugPrinting;
+
+ __debugPrinting = (aBoolean == true);
+%}
+!
+
+debugPrinting
+ "return true, if various debug printouts in the VM
+ are turned on, false of off."
+
+%{ /* NOCONTEXT */
+ extern int __debugPrinting;
+
+ RETURN (__debugPrinting ? true : false);
+%}
+! !
+
!ObjectMemory class methodsFor:'dependents access'!
dependents
@@ -1459,6 +1512,21 @@
!
garbageCollect
+ "search for and free garbage in the oldSpace.
+ This can take a long time - especially, if paging is involved."
+
+ "/ used to be
+ "/ self compressingGarbageCollect
+ "/ here; changed to default to markAndSweep
+
+ self markAndSweep
+
+ "
+ ObjectMemory garbageCollect
+ "
+!
+
+compressingGarbageCollect
"search for and free garbage in the oldSpace (newSpace is cleaned automatically)
performing a COMPRESSING garbage collect.
This can take a long time - especially, if paging is involved
@@ -1472,21 +1540,7 @@
%}
"
- ObjectMemory garbageCollect
- "
-!
-
-reclaimSymbols
- "reclaim unused symbols;
- Unused symbols are (currently) not reclaimed automatically,
- but only upon request with this method.
- It takes some time to do this ... and it is NOT interruptable.
- Future versions may do this automatically, while garbage collecting."
-%{
- __reclaimSymbols(__context);
-%}
- "
- ObjectMemory reclaimSymbols
+ ObjectMemory compressingGarbageCollect
"
!
@@ -1505,6 +1559,20 @@
"
!
+reclaimSymbols
+ "reclaim unused symbols;
+ Unused symbols are (currently) not reclaimed automatically,
+ but only upon request with this method.
+ It takes some time to do this ... and it is NOT interruptable.
+ Future versions may do this automatically, while garbage collecting."
+%{
+ __reclaimSymbols(__context);
+%}
+ "
+ ObjectMemory reclaimSymbols
+ "
+!
+
gcStep
"one incremental garbage collect step.
Mark or sweep some small number of objects. This
@@ -1571,13 +1639,13 @@
!
verboseGarbageCollect
- "perform a compessing garbage collect and show some informational
+ "perform a compressing garbage collect and show some informational
output on the Transcript"
|nBytesBefore nReclaimed value unit|
nBytesBefore := self oldSpaceUsed.
- self garbageCollect.
+ self compressingGarbageCollect.
nReclaimed := nBytesBefore - self oldSpaceUsed.
nReclaimed > 0 ifTrue:[
nReclaimed > 1024 ifTrue:[
@@ -2651,4 +2719,3 @@
compactingGC
self garbageCollect
! !
-
--- a/Object.st Sat Aug 05 16:05:36 1995 +0200
+++ b/Object.st Tue Aug 08 02:49:43 1995 +0200
@@ -30,7 +30,7 @@
COPYRIGHT (c) 1988 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Object.st,v 1.55 1995-08-03 01:16:04 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Object.st,v 1.56 1995-08-08 00:47:59 claus Exp $
'!
!Object class methodsFor:'documentation'!
@@ -51,7 +51,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Object.st,v 1.55 1995-08-03 01:16:04 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Object.st,v 1.56 1995-08-08 00:47:59 claus Exp $
"
!
@@ -296,6 +296,12 @@
messages. The default is true."
InfoPrinting := aBoolean
+!
+
+infoPrinting
+ "return the flag which controls information messages."
+
+ ^ InfoPrinting
! !
!Object class methodsFor:'queries'!
@@ -1261,8 +1267,8 @@
REGISTER unsigned h;
if (__isNonNilObject(self) && __isNonNilObject(anObject)) {
- h = _GET_HASH(anObject);
- _SET_HASH(self, h);
+ h = __GET_HASH(anObject);
+ __SET_HASH(self, h);
RETURN (self);
}
%}
@@ -1343,15 +1349,15 @@
OBJ cls;
if (__isNonNilObject(self)) {
- hash = _GET_HASH(self);
+ hash = __GET_HASH(self);
if (hash == 0) {
hash = nextHash++;
- _SET_HASH(self, hash);
- hash = _GET_HASH(self);
+ __SET_HASH(self, hash);
+ hash = __GET_HASH(self);
if (hash == 0) {
hash = nextHash++;
- _SET_HASH(self, hash);
- hash = _GET_HASH(self);
+ __SET_HASH(self, hash);
+ hash = __GET_HASH(self);
}
}
@@ -1411,13 +1417,15 @@
self error:'timer Interrupt - but no handler'
!
-errorInterrupt:errorID
- "subsystem error. The argument errorID is the parameter passed
- to the 'errorInterruptWithID(id)' function, which can be called from
- c subsystems to raise an error exception.
+errorInterrupt:errorID with:aParameter
+ "subsystem error. The arguments errorID and aParameter are the values passed
+ to the 'errorInterruptWithIDAndParameter(id, param)' function,
+ which can be called from C subsystems to raise an (asynchronous)
+ error exception.
Currently, this is used to map XErrors to smalltalk errors, but can be
- used from other c subsystems too, to upcast errors.
+ used from other C subsystems too, to upcast errors.
+ Especially, for subsystems which call errorHandler functions asynchronously.
IDs (currently) used:
#DisplayError ..... x-error interrupt
#XtError ..... xt-error interrupt (Xt interface is not yet published)
@@ -1427,11 +1435,16 @@
handler := ObjectMemory registeredErrorInterruptHandlers at:errorID ifAbsent:nil.
handler notNil ifTrue:[
- handler errorInterrupt:errorID.
+ "/
+ "/ handler found; let it do whatever it wants ...
+ "/
+ handler errorInterrupt:errorID with:aParameter.
^ self
].
- "no handler - raise errorSignal"
+ "/
+ "/ no handler - raise errorSignal passing the errorId as parameter
+ "/
^ ErrorSignal
raiseRequestWith:errorID
errorString:('Subsystem error. ErrorID = ' , errorID printString)
--- a/ObjectMemory.st Sat Aug 05 16:05:36 1995 +0200
+++ b/ObjectMemory.st Tue Aug 08 02:49:43 1995 +0200
@@ -34,7 +34,7 @@
COPYRIGHT (c) 1992 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/ObjectMemory.st,v 1.48 1995-08-03 01:15:54 claus Exp $
+$Header: /cvs/stx/stx/libbasic/ObjectMemory.st,v 1.49 1995-08-08 00:47:48 claus Exp $
'!
!ObjectMemory class methodsFor:'documentation'!
@@ -55,7 +55,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/ObjectMemory.st,v 1.48 1995-08-03 01:15:54 claus Exp $
+$Header: /cvs/stx/stx/libbasic/ObjectMemory.st,v 1.49 1995-08-08 00:47:48 claus Exp $
"
!
@@ -457,6 +457,59 @@
^ LowSpaceSemaphore
! !
+!ObjectMemory class methodsFor:'VM messages'!
+
+infoPrinting:aBoolean
+ "turn on/off various informational printouts in the VM.
+ For example, the GC activity messages are controlled by
+ this flags setting.
+ The default is true, since (currently) those messages
+ are useful for ST/X developers."
+
+%{ /* NOCONTEXT */
+ extern int __infoPrinting;
+
+ __infoPrinting = (aBoolean == true);
+%}
+!
+
+infoPrinting
+ "return true, if various informational printouts in the VM
+ are turned on, false of off."
+
+%{ /* NOCONTEXT */
+ extern int __infoPrinting;
+
+ RETURN (__infoPrinting ? true : false);
+%}
+!
+
+debugPrinting:aBoolean
+ "turn on/off various debug printouts in the VM
+ in case of an error. For example, a double-notUnderstood
+ leads to a VM context dump if debugPrinting is on.
+ If off, those messages are suppressed.
+ The default is on, since these messages are only printed for
+ severe errors."
+
+%{ /* NOCONTEXT */
+ extern int __debugPrinting;
+
+ __debugPrinting = (aBoolean == true);
+%}
+!
+
+debugPrinting
+ "return true, if various debug printouts in the VM
+ are turned on, false of off."
+
+%{ /* NOCONTEXT */
+ extern int __debugPrinting;
+
+ RETURN (__debugPrinting ? true : false);
+%}
+! !
+
!ObjectMemory class methodsFor:'dependents access'!
dependents
@@ -1459,6 +1512,21 @@
!
garbageCollect
+ "search for and free garbage in the oldSpace.
+ This can take a long time - especially, if paging is involved."
+
+ "/ used to be
+ "/ self compressingGarbageCollect
+ "/ here; changed to default to markAndSweep
+
+ self markAndSweep
+
+ "
+ ObjectMemory garbageCollect
+ "
+!
+
+compressingGarbageCollect
"search for and free garbage in the oldSpace (newSpace is cleaned automatically)
performing a COMPRESSING garbage collect.
This can take a long time - especially, if paging is involved
@@ -1472,21 +1540,7 @@
%}
"
- ObjectMemory garbageCollect
- "
-!
-
-reclaimSymbols
- "reclaim unused symbols;
- Unused symbols are (currently) not reclaimed automatically,
- but only upon request with this method.
- It takes some time to do this ... and it is NOT interruptable.
- Future versions may do this automatically, while garbage collecting."
-%{
- __reclaimSymbols(__context);
-%}
- "
- ObjectMemory reclaimSymbols
+ ObjectMemory compressingGarbageCollect
"
!
@@ -1505,6 +1559,20 @@
"
!
+reclaimSymbols
+ "reclaim unused symbols;
+ Unused symbols are (currently) not reclaimed automatically,
+ but only upon request with this method.
+ It takes some time to do this ... and it is NOT interruptable.
+ Future versions may do this automatically, while garbage collecting."
+%{
+ __reclaimSymbols(__context);
+%}
+ "
+ ObjectMemory reclaimSymbols
+ "
+!
+
gcStep
"one incremental garbage collect step.
Mark or sweep some small number of objects. This
@@ -1571,13 +1639,13 @@
!
verboseGarbageCollect
- "perform a compessing garbage collect and show some informational
+ "perform a compressing garbage collect and show some informational
output on the Transcript"
|nBytesBefore nReclaimed value unit|
nBytesBefore := self oldSpaceUsed.
- self garbageCollect.
+ self compressingGarbageCollect.
nReclaimed := nBytesBefore - self oldSpaceUsed.
nReclaimed > 0 ifTrue:[
nReclaimed > 1024 ifTrue:[
@@ -2651,4 +2719,3 @@
compactingGC
self garbageCollect
! !
-
--- a/OrdColl.st Sat Aug 05 16:05:36 1995 +0200
+++ b/OrdColl.st Tue Aug 08 02:49:43 1995 +0200
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Attic/OrdColl.st,v 1.28 1995-08-03 01:16:13 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/OrdColl.st,v 1.29 1995-08-08 00:48:10 claus Exp $
'!
!OrderedCollection class methodsFor:'documentation'!
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Attic/OrdColl.st,v 1.28 1995-08-03 01:16:13 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/OrdColl.st,v 1.29 1995-08-08 00:48:10 claus Exp $
"
!
@@ -588,7 +588,7 @@
].
newContents := Array basicNew:newSize.
- newContents replaceFrom:1 to:(lastIndex - firstIndex + 1) with:contentsArray.
+ newContents replaceFrom:1 to:oldSize with:contentsArray startingAt:firstIndex.
contentsArray := newContents.
firstIndex := 1.
lastIndex := newSize
@@ -796,6 +796,9 @@
"
oldSize > (sz * 2) ifTrue:[
startIndex := firstIndex // 4.
+ startIndex == 0 ifTrue:[
+ startIndex := 1
+ ].
contentsArray
replaceFrom:startIndex
to:startIndex + sz - 1
@@ -845,6 +848,9 @@
"
oldSize > (sz * 2) ifTrue:[
startIndex := oldSize // 4.
+ startIndex == 0 ifTrue:[
+ startIndex := 1
+ ].
contentsArray
replaceFrom:startIndex
to:startIndex + sz - 1
--- a/OrderedCollection.st Sat Aug 05 16:05:36 1995 +0200
+++ b/OrderedCollection.st Tue Aug 08 02:49:43 1995 +0200
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/OrderedCollection.st,v 1.28 1995-08-03 01:16:13 claus Exp $
+$Header: /cvs/stx/stx/libbasic/OrderedCollection.st,v 1.29 1995-08-08 00:48:10 claus Exp $
'!
!OrderedCollection class methodsFor:'documentation'!
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/OrderedCollection.st,v 1.28 1995-08-03 01:16:13 claus Exp $
+$Header: /cvs/stx/stx/libbasic/OrderedCollection.st,v 1.29 1995-08-08 00:48:10 claus Exp $
"
!
@@ -588,7 +588,7 @@
].
newContents := Array basicNew:newSize.
- newContents replaceFrom:1 to:(lastIndex - firstIndex + 1) with:contentsArray.
+ newContents replaceFrom:1 to:oldSize with:contentsArray startingAt:firstIndex.
contentsArray := newContents.
firstIndex := 1.
lastIndex := newSize
@@ -796,6 +796,9 @@
"
oldSize > (sz * 2) ifTrue:[
startIndex := firstIndex // 4.
+ startIndex == 0 ifTrue:[
+ startIndex := 1
+ ].
contentsArray
replaceFrom:startIndex
to:startIndex + sz - 1
@@ -845,6 +848,9 @@
"
oldSize > (sz * 2) ifTrue:[
startIndex := oldSize // 4.
+ startIndex == 0 ifTrue:[
+ startIndex := 1
+ ].
contentsArray
replaceFrom:startIndex
to:startIndex + sz - 1
--- a/ProcSched.st Sat Aug 05 16:05:36 1995 +0200
+++ b/ProcSched.st Tue Aug 08 02:49:43 1995 +0200
@@ -35,7 +35,7 @@
COPYRIGHT (c) 1993 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Attic/ProcSched.st,v 1.44 1995-08-05 14:05:36 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/ProcSched.st,v 1.45 1995-08-08 00:48:18 claus Exp $
'!
Smalltalk at:#Processor put:nil!
@@ -58,7 +58,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Attic/ProcSched.st,v 1.44 1995-08-05 14:05:36 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/ProcSched.st,v 1.45 1995-08-08 00:48:18 claus Exp $
"
!
@@ -495,7 +495,8 @@
initialize
"initialize the one-and-only ProcessorScheduler"
- |nPrios l p|
+ |nPrios "{ Class: SmallInteger }"
+ l p|
KnownProcesses isNil ifTrue:[
KnownProcesses := WeakArray new:10.
@@ -508,6 +509,9 @@
"
nPrios := SchedulingPriority.
quiescentProcessLists := Array new:nPrios.
+ 1 to:nPrios do:[:pri |
+ quiescentProcessLists at:pri put:(LinkedList new)
+ ].
readFdArray := Array with:nil.
readCheckArray := Array with:nil.
@@ -534,11 +538,9 @@
p setPriority:currentPriority.
p name:'scheduler'.
- l := LinkedList new.
- l add:p.
scheduler := activeProcess := p.
- quiescentProcessLists at:currentPriority put:l.
+ (quiescentProcessLists at:currentPriority) add:p.
"
let me handle IO and timer interrupts
@@ -715,11 +717,6 @@
"
debugging consistency checks - will be removed later
"
- l isNil ifTrue:[
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
- 'oops - nil runnable list' errorPrintNL.
- ^ self
- ].
l isEmpty ifTrue:[
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
'oops - empty runnable list' errorPrintNL.
@@ -773,18 +770,6 @@
pri := aProcess priority.
l := quiescentProcessLists at:pri.
- "
- debugging consisteny checks - will be removed later
- "
- l isNil ifTrue:[
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
-
- 'bad suspend: empty run list' errorPrintNL.
- "/ MiniDebugger enterWithMessage:'bad suspend: empty run list'.
- self threadSwitch:scheduler.
- ^ self
- ].
-
"notice: this is slightly faster than putting the if-code into
the ifAbsent block, because [] is a shared cheap block
"
@@ -796,10 +781,6 @@
^ self
].
- l isEmpty ifTrue:[
- quiescentProcessLists at:pri put:nil.
- l := nil
- ].
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
"
@@ -812,7 +793,7 @@
(aProcess == activeProcess) ifTrue:[
"we can immediately switch sometimes"
- l notNil ifTrue:[
+ l notEmpty ifTrue:[
p := l first
] ifFalse:[
p := scheduler
@@ -837,15 +818,10 @@
pri := aProcess priority.
l := quiescentProcessLists at:pri.
- l isNil ifTrue:[
- l := LinkedList new.
- quiescentProcessLists at:pri put:l
- ] ifFalse:[
- "if already running, ignore"
- (l identityIndexOf:aProcess) ~~ 0 ifTrue:[
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
- ^ self
- ]
+ "if already running, ignore"
+ (l identityIndexOf:aProcess) ~~ 0 ifTrue:[
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+ ^ self
].
l addLast:aProcess.
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
@@ -896,9 +872,8 @@
pri := aProcess priority.
l := quiescentProcessLists at:pri.
- (l notNil and:[(l identityIndexOf:aProcess) ~~ 0]) ifTrue:[
+ (l identityIndexOf:aProcess) ~~ 0 ifTrue:[
l remove:aProcess.
- l isEmpty ifTrue:[quiescentProcessLists at:pri put:nil].
].
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
@@ -986,19 +961,14 @@
aProcess setPriority:newPrio.
oldList := quiescentProcessLists at:oldPrio.
- (oldList isNil or:[(oldList identityIndexOf:aProcess) ==0]) ifTrue:[
+ (oldList identityIndexOf:aProcess) == 0 ifTrue:[
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
^ self
].
oldList remove:aProcess.
- oldList isEmpty ifTrue:[quiescentProcessLists at:oldPrio put:nil].
newList := quiescentProcessLists at:newPrio.
- newList isNil ifTrue:[
- newList := LinkedList new.
- quiescentProcessLists at:newPrio put:newList
- ].
newList addLast:aProcess.
"if its the current process lowering its prio
@@ -1059,24 +1029,17 @@
listArray := quiescentProcessLists.
[prio >= 1] whileTrue:[
l := listArray at:prio.
- l notNil ifTrue:[
- l isEmpty ifTrue:[
- "
- on the fly clear out empty lists
- "
- listArray at:prio put:nil
- ] ifFalse:[
- p := l first.
- "
- if it got corrupted somehow ...
- "
- p id isNil ifTrue:[
- 'process with nil id removed' errorPrintNL.
- l removeFirst.
- ^ nil.
- ].
- ^ p
+ l notEmpty ifTrue:[
+ p := l first.
+ "
+ if it got corrupted somehow ...
+ "
+ p id isNil ifTrue:[
+ 'process with nil id removed' errorPrintNL.
+ l removeFirst.
+ ^ nil.
].
+ ^ p
].
prio := prio - 1
].
--- a/Process.st Sat Aug 05 16:05:36 1995 +0200
+++ b/Process.st Tue Aug 08 02:49:43 1995 +0200
@@ -13,7 +13,7 @@
Link subclass:#Process
instanceVariableNames:'id prio state startBlock name
restartable interruptActions
- exitAction exitSemaphore suspendSemaphore
+ exitActions suspendSemaphore
singleStepping emergencySignalHandler'
classVariableNames:'TerminateSignal CoughtSignals'
poolDictionaries:''
@@ -24,7 +24,7 @@
COPYRIGHT (c) 1992 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Process.st,v 1.29 1995-06-27 02:14:01 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Process.st,v 1.30 1995-08-08 00:48:25 claus Exp $
'!
!Process class methodsFor:'documentation'!
@@ -45,7 +45,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Process.st,v 1.29 1995-06-27 02:14:01 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Process.st,v 1.30 1995-08-08 00:48:25 claus Exp $
"
!
@@ -90,7 +90,7 @@
in Smalltalk/X, processes are gone, when an image is restarted;
this means, that you have to take care of process re-creation yourself.
Usually, this is done by depending on ObjectMemory, recreating the
- process(s) when the #returnFromSnapshot-change notifiction arrives.
+ process(es) when the #returnFromSnapshot-change notifiction arrives.
All views (actually windowGroups) recreate their window process
on image-restart. You have to do so manually for your own processes.
@@ -100,17 +100,22 @@
will be recreated to restart from the beginning. It will not be possible to
automatically continue a processes execution where it left off.
This is a consequence of the portable implementation of ST/X, since in order to
- implement process cintinuation, the machines stack had to be preserved and
- recreated.
- Although this is possible theoretically, this has not been implemented, since
- the machines stack layout is highly machine/compiler dependent, thus leading
- to much bigger porting effort of ST/X.
-
+ implement process continuation, the machines stack had to be preserved and
+ recreated. Although this is possible to do (and actually not too complicated),
+ this has not been implemented, since the machines stack layout is highly machine/compiler
+ dependent, thus leading to much bigger porting effort of ST/X (which conflicts
+ with ST/X's design goal of being highly portable).
Process synchronization:
- any other process can wait for a process to suspend or terminate. This
- is implemented by using suspendSemaphore and exitSemaphore, which are
- signalled when these events occur (see waitUntilSuspended/waitUntilTerminated).
+ Synchronization with cooperating processes is supported as usual,
+ via Semaphores (see Semaphore, Delay, SharedQueue etc.)
+
+ With uncooperative processes, only synchronization on suspend
+ and termination is possible:
+ any other process can wait for a process to suspend or terminate.
+ This waiting is implemented by using suspendSemaphore and exitBlocks
+ (where an exitSemaphore is signalled).
+ See waitUntilSuspended / waitUntilTerminated.
Instance variables:
@@ -128,15 +133,14 @@
suspendSemaphore <Semaphore> triggered when suspend (if nonNil)
- exitSemaphore <Semaphore> triggered when terminated (if nonNil)
-
restartable <Boolean> is restartable (not yet implemented)
interruptActions <Collection> interrupt actions as defined by interruptWith:,
performed at interrupt time
- exitAction <Block> additional cleanup action to perform
- on termination (if nonNil)
+ exitActions <Collection of Block>
+ additional cleanup actions to perform
+ on termination (if nonEmpty)
emergencySignalHandler <Block> can be used for per-process
emergency signal handling
@@ -374,17 +378,14 @@
^ id printString
!
-exitAction
- "return the processes exit action"
-
- ^ exitAction
-!
-
exitAction:aBlock
- "set the processes exit action to aBlock.
+ "add aBlock to the processes exit actions.
This will be evaluated right before the process dies."
- exitAction := aBlock
+ exitActions isNil ifTrue:[
+ exitActions := OrderedCollection new
+ ].
+ exitActions add:aBlock
!
suspendedContext
@@ -440,6 +441,20 @@
!Process methodsFor:'monitoring'!
+vmTrace:aBoolean
+ "turn on/off VM message tracing for the receiver.
+ This is meant for ST/X debugging, and may valish.
+ Expect lots of output, once this is turned on."
+
+%{ /* NOCONTEXT */
+ OBJ i;
+
+ if (__isSmallInteger(i = _INST(id))) {
+ __threadTracing(_intVal(i), aBoolean);
+ }
+%}.
+!
+
usedStackSize
"Return the processes current stack size.
This method is for monitoring purposes only - it may vanish."
@@ -494,9 +509,9 @@
OBJ i;
if (__isSmallInteger(i = _INST(id))) {
- n = __threadNumberOfStackBoundaryHits(_intVal(i));
+ n = __threadNumberOfStackBoundaryHits(_intVal(i));
n &= 0x3FFFFFFF;
- RETURN( _MKSMALLINT(n) );
+ RETURN( _MKSMALLINT(n) );
}
%}.
^ nil
@@ -554,13 +569,7 @@
ex return
] do:block.
- (block := exitAction) notNil ifTrue:[
- exitAction := nil.
- block value.
- ].
- suspendSemaphore notNil ifTrue:[suspendSemaphore signalForAll].
- exitSemaphore notNil ifTrue:[exitSemaphore signalForAll].
- Processor terminateActiveNoSignal
+ self terminateNoSignal.
] ifFalse:[
"is this artificial restriction useful ?"
self error:'a process cannot be started twice'
@@ -615,7 +624,9 @@
!
terminate
- "terminate the receiver process. All unwind actions and the exit-action (if any)
+ "terminate the receiver process. Termination is done by raising
+ the terminateSignal in the receiver process, which can be cought.
+ All unwind actions and the exit-actions (if any)
will be performed before the process is really terminated."
Processor activeProcess == self ifTrue:[
@@ -624,19 +635,26 @@
] do:[
TerminateSignal raise.
].
- suspendSemaphore notNil ifTrue:[suspendSemaphore signalForAll].
- exitSemaphore notNil ifTrue:[exitSemaphore signalForAll].
- Processor terminateNoSignal:self
+ self terminateNoSignal.
] ifFalse:[
self interruptWith:[self terminate]
]
!
terminateNoSignal
- "terminate the receiver process without performing any unwind- or exit-actions"
+ "terminate the receiver process without sending a terminateSignal
+ or performing any unwind-handling.
+ However, exit-actions are performed."
+
+ |block|
+ exitActions notNil ifTrue:[
+ [exitActions notEmpty] whileTrue:[
+ block := exitActions removeFirst.
+ block value.
+ ]
+ ].
suspendSemaphore notNil ifTrue:[suspendSemaphore signalForAll].
- exitSemaphore notNil ifTrue:[exitSemaphore signalForAll].
Processor terminateNoSignal:self
! !
@@ -729,11 +747,12 @@
"wait until the receiver is terminated.
This method allows another process to wait till the receiver finishes."
- |wasBlocked|
+ |wasBlocked sema|
wasBlocked := OperatingSystem blockInterrupts.
- exitSemaphore isNil ifTrue:[exitSemaphore := Semaphore new].
- exitSemaphore wait.
+ sema := Semaphore new.
+ self exitAction:[sema signal].
+ sema wait.
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
!
--- a/ProcessorScheduler.st Sat Aug 05 16:05:36 1995 +0200
+++ b/ProcessorScheduler.st Tue Aug 08 02:49:43 1995 +0200
@@ -35,7 +35,7 @@
COPYRIGHT (c) 1993 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/ProcessorScheduler.st,v 1.44 1995-08-05 14:05:36 claus Exp $
+$Header: /cvs/stx/stx/libbasic/ProcessorScheduler.st,v 1.45 1995-08-08 00:48:18 claus Exp $
'!
Smalltalk at:#Processor put:nil!
@@ -58,7 +58,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/ProcessorScheduler.st,v 1.44 1995-08-05 14:05:36 claus Exp $
+$Header: /cvs/stx/stx/libbasic/ProcessorScheduler.st,v 1.45 1995-08-08 00:48:18 claus Exp $
"
!
@@ -495,7 +495,8 @@
initialize
"initialize the one-and-only ProcessorScheduler"
- |nPrios l p|
+ |nPrios "{ Class: SmallInteger }"
+ l p|
KnownProcesses isNil ifTrue:[
KnownProcesses := WeakArray new:10.
@@ -508,6 +509,9 @@
"
nPrios := SchedulingPriority.
quiescentProcessLists := Array new:nPrios.
+ 1 to:nPrios do:[:pri |
+ quiescentProcessLists at:pri put:(LinkedList new)
+ ].
readFdArray := Array with:nil.
readCheckArray := Array with:nil.
@@ -534,11 +538,9 @@
p setPriority:currentPriority.
p name:'scheduler'.
- l := LinkedList new.
- l add:p.
scheduler := activeProcess := p.
- quiescentProcessLists at:currentPriority put:l.
+ (quiescentProcessLists at:currentPriority) add:p.
"
let me handle IO and timer interrupts
@@ -715,11 +717,6 @@
"
debugging consistency checks - will be removed later
"
- l isNil ifTrue:[
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
- 'oops - nil runnable list' errorPrintNL.
- ^ self
- ].
l isEmpty ifTrue:[
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
'oops - empty runnable list' errorPrintNL.
@@ -773,18 +770,6 @@
pri := aProcess priority.
l := quiescentProcessLists at:pri.
- "
- debugging consisteny checks - will be removed later
- "
- l isNil ifTrue:[
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
-
- 'bad suspend: empty run list' errorPrintNL.
- "/ MiniDebugger enterWithMessage:'bad suspend: empty run list'.
- self threadSwitch:scheduler.
- ^ self
- ].
-
"notice: this is slightly faster than putting the if-code into
the ifAbsent block, because [] is a shared cheap block
"
@@ -796,10 +781,6 @@
^ self
].
- l isEmpty ifTrue:[
- quiescentProcessLists at:pri put:nil.
- l := nil
- ].
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
"
@@ -812,7 +793,7 @@
(aProcess == activeProcess) ifTrue:[
"we can immediately switch sometimes"
- l notNil ifTrue:[
+ l notEmpty ifTrue:[
p := l first
] ifFalse:[
p := scheduler
@@ -837,15 +818,10 @@
pri := aProcess priority.
l := quiescentProcessLists at:pri.
- l isNil ifTrue:[
- l := LinkedList new.
- quiescentProcessLists at:pri put:l
- ] ifFalse:[
- "if already running, ignore"
- (l identityIndexOf:aProcess) ~~ 0 ifTrue:[
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
- ^ self
- ]
+ "if already running, ignore"
+ (l identityIndexOf:aProcess) ~~ 0 ifTrue:[
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+ ^ self
].
l addLast:aProcess.
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
@@ -896,9 +872,8 @@
pri := aProcess priority.
l := quiescentProcessLists at:pri.
- (l notNil and:[(l identityIndexOf:aProcess) ~~ 0]) ifTrue:[
+ (l identityIndexOf:aProcess) ~~ 0 ifTrue:[
l remove:aProcess.
- l isEmpty ifTrue:[quiescentProcessLists at:pri put:nil].
].
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
@@ -986,19 +961,14 @@
aProcess setPriority:newPrio.
oldList := quiescentProcessLists at:oldPrio.
- (oldList isNil or:[(oldList identityIndexOf:aProcess) ==0]) ifTrue:[
+ (oldList identityIndexOf:aProcess) == 0 ifTrue:[
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
^ self
].
oldList remove:aProcess.
- oldList isEmpty ifTrue:[quiescentProcessLists at:oldPrio put:nil].
newList := quiescentProcessLists at:newPrio.
- newList isNil ifTrue:[
- newList := LinkedList new.
- quiescentProcessLists at:newPrio put:newList
- ].
newList addLast:aProcess.
"if its the current process lowering its prio
@@ -1059,24 +1029,17 @@
listArray := quiescentProcessLists.
[prio >= 1] whileTrue:[
l := listArray at:prio.
- l notNil ifTrue:[
- l isEmpty ifTrue:[
- "
- on the fly clear out empty lists
- "
- listArray at:prio put:nil
- ] ifFalse:[
- p := l first.
- "
- if it got corrupted somehow ...
- "
- p id isNil ifTrue:[
- 'process with nil id removed' errorPrintNL.
- l removeFirst.
- ^ nil.
- ].
- ^ p
+ l notEmpty ifTrue:[
+ p := l first.
+ "
+ if it got corrupted somehow ...
+ "
+ p id isNil ifTrue:[
+ 'process with nil id removed' errorPrintNL.
+ l removeFirst.
+ ^ nil.
].
+ ^ p
].
prio := prio - 1
].
--- a/Project.st Sat Aug 05 16:05:36 1995 +0200
+++ b/Project.st Tue Aug 08 02:49:43 1995 +0200
@@ -23,7 +23,7 @@
COPYRIGHT (c) 1993 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Project.st,v 1.23 1995-08-03 01:16:24 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Project.st,v 1.24 1995-08-08 00:48:30 claus Exp $
'!
!Project class methodsFor:'documentation'!
@@ -44,7 +44,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Project.st,v 1.23 1995-08-03 01:16:24 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Project.st,v 1.24 1995-08-08 00:48:30 claus Exp $
"
!
@@ -249,7 +249,12 @@
|classes methods|
- classes := self classes asIdentitySet.
+ classes := self classes.
+ classes notNil ifTrue:[
+ classes := classes asIdentitySet.
+ ] ifFalse:[
+ classes := #()
+ ].
methods := IdentitySet new.
Smalltalk allBehaviorsDo:[:cls |
--- a/Registry.st Sat Aug 05 16:05:36 1995 +0200
+++ b/Registry.st Tue Aug 08 02:49:43 1995 +0200
@@ -11,7 +11,7 @@
"
Object subclass:#Registry
- instanceVariableNames:'registeredObjects phantomArray cleanState'
+ instanceVariableNames:'registeredObjects handleArray cleanState'
classVariableNames:''
poolDictionaries:''
category:'System-Support'
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1993 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Registry.st,v 1.15 1995-06-27 02:14:12 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Registry.st,v 1.16 1995-08-08 00:48:37 claus Exp $
'!
!Registry class methodsFor:'documentation'!
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Registry.st,v 1.15 1995-06-27 02:14:12 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Registry.st,v 1.16 1995-08-08 00:48:37 claus Exp $
"
!
@@ -77,6 +77,10 @@
!Registry methodsFor:'dispose handling'!
+informDispose:someHandle
+ someHandle disposed
+!
+
informDispose
"an instance has been destroyed - look which one it was"
@@ -84,13 +88,13 @@
sz "{ Class: SmallInteger }"|
cleanState ifTrue:[
- sz := phantomArray size.
+ sz := handleArray size.
1 to:sz do:[:index |
(registeredObjects at:index) isNil ifTrue:[
- phantom := phantomArray at:index.
+ phantom := handleArray at:index.
phantom notNil ifTrue:[
- phantomArray at:index put:nil.
- phantom disposed
+ handleArray at:index put:nil.
+ self informDispose:phantom
]
]
]
@@ -115,14 +119,14 @@
^ registeredObjects
!
-changed:anObject
+registerChange:anObject
"a registered object has changed, create a new phantom"
|index|
index := registeredObjects identityIndexOf:anObject ifAbsent:[0].
index ~~ 0 ifTrue:[
- phantomArray at:index put:anObject shallowCopyForFinalization.
+ handleArray at:index put:anObject shallowCopyForFinalization.
]
!
@@ -130,19 +134,24 @@
"register anObject, so that a copy of it gets the disposed message
when anObject dies (some time in the future)"
- |phantom newColl newPhantoms
+ ^ self register:anObject as:(anObject shallowCopyForFinalization)
+!
+
+register:anObject as:aHandle
+ "register anObject, so that I later receive informDispose: with aHandle
+ (some time in the future)"
+
+ |newColl newPhantoms
size "{ Class: SmallInteger }"
index "{ Class: SmallInteger }"
p|
- phantom := anObject shallowCopyForFinalization.
-
registeredObjects isNil ifTrue:[
registeredObjects := WeakArray new:10.
registeredObjects watcher:self.
- phantomArray := Array basicNew:10.
+ handleArray := Array basicNew:10.
registeredObjects at:1 put:anObject.
- phantomArray at:1 put:phantom.
+ handleArray at:1 put:aHandle.
cleanState := true.
ObjectMemory addDependent:self.
^ self
@@ -151,7 +160,7 @@
index := registeredObjects identityIndexOf:anObject ifAbsent:[0].
index ~~ 0 ifTrue:[
"already registered"
- phantomArray at:index put:phantom.
+ handleArray at:index put:aHandle.
self error:'object is already registered'.
^ self
].
@@ -160,15 +169,15 @@
index := registeredObjects identityIndexOf:nil startingAt:1.
index ~~ 0 ifTrue:[
"is there a leftover ?"
- p := phantomArray at:index.
+ p := handleArray at:index.
p notNil ifTrue:[
"tell the phantom"
- phantomArray at:index put:nil.
- p disposed.
+ handleArray at:index put:nil.
+ self informDispose:p.
p := nil.
].
registeredObjects at:index put:anObject.
- phantomArray at:index put:phantom.
+ handleArray at:index put:aHandle.
^ self
].
@@ -183,9 +192,9 @@
registeredObjects at:index put:anObject.
newPhantoms := Array basicNew:(size * 2).
- newPhantoms replaceFrom:1 to:size with:phantomArray.
- phantomArray := newPhantoms.
- phantomArray at:index put:phantom.
+ newPhantoms replaceFrom:1 to:size with:handleArray.
+ handleArray := newPhantoms.
+ handleArray at:index put:aHandle.
!
unregister:anObject
@@ -197,7 +206,7 @@
index := registeredObjects identityIndexOf:anObject ifAbsent:[0].
index ~~ 0 ifTrue:[
- phantomArray at:index put:nil.
+ handleArray at:index put:nil.
registeredObjects at:index put:nil
]
! !
@@ -206,8 +215,8 @@
update:aParameter
aParameter == #earlyRestart ifTrue:[
- phantomArray notNil ifTrue:[
- phantomArray atAllPut:nil
+ handleArray notNil ifTrue:[
+ handleArray atAllPut:nil
]
].
aParameter == #returnFromSnapshot ifTrue:[
--- a/Semaphore.st Sat Aug 05 16:05:36 1995 +0200
+++ b/Semaphore.st Tue Aug 08 02:49:43 1995 +0200
@@ -10,9 +10,8 @@
hereby transferred.
"
-LinkedList subclass:#Semaphore
+Object subclass:#Semaphore
instanceVariableNames:'count waitingProcesses'
-"/ instanceVariableNames:'count'
classVariableNames:''
poolDictionaries:''
category:'Kernel-Processes'!
@@ -21,7 +20,7 @@
COPYRIGHT (c) 1993 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Semaphore.st,v 1.18 1995-07-22 19:24:21 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Semaphore.st,v 1.19 1995-08-08 00:48:42 claus Exp $
'!
!Semaphore class methodsFor:'documentation'!
@@ -42,7 +41,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Semaphore.st,v 1.18 1995-07-22 19:24:21 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Semaphore.st,v 1.19 1995-08-08 00:48:42 claus Exp $
"
!
@@ -92,6 +91,7 @@
!Semaphore methodsFor:'private accessing'!
setCount:n
+ waitingProcesses := OrderedCollection new:3.
count := n
! !
@@ -138,12 +138,7 @@
suspend.
"
[count == 0] whileTrue:[
- waitingProcesses isNil ifTrue:[
- waitingProcesses := OrderedCollection with:current
- ] ifFalse:[
- waitingProcesses add:current
- ].
-"/ self add:current.
+ waitingProcesses add:current.
"
for some more descriptive info in processMonitor ...
(notice that state could already be #ioWait, #timeWait or anything else)
@@ -181,12 +176,7 @@
suspend.
"
[count == 0] whileTrue:[
- waitingProcesses isNil ifTrue:[
- waitingProcesses := OrderedCollection with:current
- ] ifFalse:[
- waitingProcesses add:current
- ].
-"/ self add:current.
+ waitingProcesses add:current.
"
for some more descriptive info in processMonitor ...
(notice that state could already be #ioWait, #timeWait or anything else)
@@ -243,12 +233,7 @@
suspend.
"
[count == 0] whileTrue:[
- waitingProcesses isNil ifTrue:[
- waitingProcesses := OrderedCollection with:current
- ] ifFalse:[
- waitingProcesses add:current
- ].
-"/ self add:current.
+ waitingProcesses add:current.
"
for some more descriptive info in processMonitor ...
@@ -294,10 +279,8 @@
wasBlocked := OperatingSystem blockInterrupts.
count := count + 1.
- (waitingProcesses notNil and:[waitingProcesses notEmpty]) ifTrue:[
+ waitingProcesses notEmpty ifTrue:[
p := waitingProcesses removeFirst.
-"/ self isEmpty ifFalse:[
-"/ p := self removeFirst.
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
p resume.
@@ -313,9 +296,9 @@
|wasBlocked|
- (waitingProcesses notNil and:[waitingProcesses notEmpty]) ifTrue:[
+ waitingProcesses notEmpty ifTrue:[
wasBlocked := OperatingSystem blockInterrupts.
- (waitingProcesses notNil and:[waitingProcesses notEmpty]) ifTrue:[
+ waitingProcesses notEmpty ifTrue:[
self signal
].
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
@@ -329,9 +312,9 @@
|wasBlocked|
- [waitingProcesses notNil and:[waitingProcesses notEmpty]] whileTrue:[
+ [waitingProcesses notEmpty] whileTrue:[
wasBlocked := OperatingSystem blockInterrupts.
- (waitingProcesses notNil and:[waitingProcesses notEmpty]) ifTrue:[
+ waitingProcesses notEmpty ifTrue:[
self signal
].
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
--- a/SeqColl.st Sat Aug 05 16:05:36 1995 +0200
+++ b/SeqColl.st Tue Aug 08 02:49:43 1995 +0200
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Attic/SeqColl.st,v 1.33 1995-07-27 04:12:12 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/SeqColl.st,v 1.34 1995-08-08 00:48:47 claus Exp $
'!
!SequenceableCollection class methodsFor:'documentation'!
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Attic/SeqColl.st,v 1.33 1995-07-27 04:12:12 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/SeqColl.st,v 1.34 1995-08-08 00:48:47 claus Exp $
"
!
@@ -407,7 +407,7 @@
time can become much bigger than the time lost in added probing.
Time will show ..."
- ^ (self at:1 ifAbsent:[0]) hash * self size
+ ^ ((self at:1 ifAbsent:[0]) hash * self size) bitAnd:16r3FFFFFFF
"
#(1 2 3 4 5) hash
--- a/SequenceableCollection.st Sat Aug 05 16:05:36 1995 +0200
+++ b/SequenceableCollection.st Tue Aug 08 02:49:43 1995 +0200
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/SequenceableCollection.st,v 1.33 1995-07-27 04:12:12 claus Exp $
+$Header: /cvs/stx/stx/libbasic/SequenceableCollection.st,v 1.34 1995-08-08 00:48:47 claus Exp $
'!
!SequenceableCollection class methodsFor:'documentation'!
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/SequenceableCollection.st,v 1.33 1995-07-27 04:12:12 claus Exp $
+$Header: /cvs/stx/stx/libbasic/SequenceableCollection.st,v 1.34 1995-08-08 00:48:47 claus Exp $
"
!
@@ -407,7 +407,7 @@
time can become much bigger than the time lost in added probing.
Time will show ..."
- ^ (self at:1 ifAbsent:[0]) hash * self size
+ ^ ((self at:1 ifAbsent:[0]) hash * self size) bitAnd:16r3FFFFFFF
"
#(1 2 3 4 5) hash
--- a/Set.st Sat Aug 05 16:05:36 1995 +0200
+++ b/Set.st Tue Aug 08 02:49:43 1995 +0200
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1991 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Set.st,v 1.19 1995-07-22 19:24:33 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Set.st,v 1.20 1995-08-08 00:48:53 claus Exp $
'!
!Set class methodsFor:'documentation'!
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Set.st,v 1.19 1995-07-22 19:24:33 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Set.st,v 1.20 1995-08-08 00:48:53 claus Exp $
"
!
@@ -203,7 +203,7 @@
to redefine it. (which may be a bad design decision, but slightly
improves performance, by avoiding an extra message send ...)"
- ^ hashKey \\ length + 1.
+ ^ (hashKey \\ length) + 1.
!
setTally:count
--- a/Smalltalk.st Sat Aug 05 16:05:36 1995 +0200
+++ b/Smalltalk.st Tue Aug 08 02:49:43 1995 +0200
@@ -27,7 +27,7 @@
COPYRIGHT (c) 1988 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Smalltalk.st,v 1.55 1995-07-23 11:54:53 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Smalltalk.st,v 1.56 1995-08-08 00:49:01 claus Exp $
'!
"
@@ -56,7 +56,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Smalltalk.st,v 1.55 1995-07-23 11:54:53 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Smalltalk.st,v 1.56 1995-08-08 00:49:01 claus Exp $
"
!
@@ -1020,44 +1020,14 @@
%}
!
-infoPrinting:aBoolean
- "turn on/off various informational printouts in the VM.
- For example, the GC activity messages are controlled by
- this flags setting.
- The default is true, since (currently) those messages
- are useful for ST/X developers."
-
-%{ /* NOCONTEXT */
- extern int __infoPrinting;
-
- __infoPrinting = (aBoolean == true);
-%}
-!
-
-debugPrinting:aBoolean
- "turn on/off various debug printouts in the VM
- in case of an error. For example, a double-notUnderstood
- leads to a VM context dump if debugPrinting is on.
- If off, those messages are suppressed.
- The default is on, since these messages are only printed for
- severe errors."
-
-%{ /* NOCONTEXT */
- extern int __debugPrinting;
-
- __debugPrinting = (aBoolean == true);
-%}
-!
-
debugOn
"turns some tracing on.
WARNING: this method is for debugging only
it may be removed without notice"
"LookupTrace := true. "
- MessageTrace := true.
"AllocTrace := true. "
- ObjectMemory flushInlineCaches
+ ObjectMemory flushCaches
!
debugOff
@@ -1066,7 +1036,6 @@
it may be removed without notice"
LookupTrace := nil.
- MessageTrace := nil
". AllocTrace := nil "
!
@@ -2043,7 +2012,7 @@
aStream := self fileInFileStreamFor:(aFileName copyFrom:8)
] ifFalse:[
aStream := self systemFileStreamFor:aFileName.
- (aFileName includes:$/) ifTrue:[
+ (aStream notNil and:[aFileName includes:$/]) ifTrue:[
"/ temporarily prepend the files directory
"/ to the searchPath.
"/ This allows fileIn-driver files to refer to local
--- a/String.st Sat Aug 05 16:05:36 1995 +0200
+++ b/String.st Tue Aug 08 02:49:43 1995 +0200
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1988 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/String.st,v 1.40 1995-08-03 01:16:53 claus Exp $
+$Header: /cvs/stx/stx/libbasic/String.st,v 1.41 1995-08-08 00:49:12 claus Exp $
'!
!String class methodsFor:'documentation'!
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/String.st,v 1.40 1995-08-03 01:16:53 claus Exp $
+$Header: /cvs/stx/stx/libbasic/String.st,v 1.41 1995-08-08 00:49:12 claus Exp $
"
!
@@ -1121,97 +1121,82 @@
startsWith:aString
"return true, if the receiver starts with something, aString."
- aString isString ifFalse: [
- (aString isMemberOf:Character) ifTrue:[
- self isEmpty ifTrue:[^ false].
- ^ (self at:1) == aString
- ].
- ^ super startsWith:aString
- ].
-%{
+%{ /* NOCONTEXT */
+
int len1, len2;
REGISTER unsigned char *src1, *src2;
- REGISTER OBJ s = aString;
- OBJ cls;
char c;
- len1 = __qSize(self);
- src1 = _stringVal(self);
- if ((cls = __qClass(self)) != String) {
- int n = __OBJS2BYTES__(_intVal(_ClassInstPtr(cls)->c_ninstvars));
- len1 -= n;
- src1 += n;
+ if ((__isString(self) || __isSymbol(self))
+ && (__isString(aString) || __isSymbol(aString))) {
+ len1 = __qSize(self);
+ len2 = __qSize(aString);
+ if (len1 < len2) {
+ RETURN ( false );
+ }
+
+ src1 = _stringVal(self);
+ src2 = _stringVal(aString);
+ while (c = *src2++) {
+ if (c != *src1++) {
+ RETURN ( false );
+ }
+ }
+ RETURN (true);
}
- len2 = __qSize(s);
- src2 = _stringVal(s);
- if ((cls = __qClass(s)) != String) {
- int n = __OBJS2BYTES__(_intVal(_ClassInstPtr(cls)->c_ninstvars));
- len2 -= n;
- src2 += n;
- }
- if (len1 < len2) {
- RETURN ( false );
- }
- while (c = *src2++)
- if (c != *src1++) {
- RETURN ( false );
- }
-%}
-.
- ^ true
+%}.
+ (aString isMemberOf:Character) ifTrue:[
+ self size == 0 ifTrue:[^ false].
+ ^ (self at:1) == aString
+ ].
+ ^ super startsWith:aString
"
'hello world' startsWith:'hello'
'hello world' startsWith:'hi'
+ 'hello world' startsWith:$h
+ 'hello world' startsWith:#($h $e $l)
"
!
endsWith:aString
"return true, if the receiver end with something, aString."
- aString isString ifFalse: [
- (aString isMemberOf:Character) ifTrue:[
- self isEmpty ifTrue:[^ false].
- ^ (self at:(self size)) == aString
- ].
- ^ super endsWith:aString
- ].
-%{
+%{ /* NOCONTEXT */
+
int len1, len2;
REGISTER unsigned char *src1, *src2;
- REGISTER OBJ s = aString;
- OBJ cls;
char c;
- len1 = __qSize(self);
- src1 = _stringVal(self);
- if ((cls = __qClass(self)) != String) {
- int n = __OBJS2BYTES__(_intVal(_ClassInstPtr(cls)->c_ninstvars));
- len1 -= n;
- src1 += n;
+ if ((__isString(self) || __isSymbol(self))
+ && (__isString(aString) || __isSymbol(aString))) {
+ len1 = __qSize(self);
+ len2 = __qSize(aString);
+ if (len1 < len2) {
+ RETURN ( false );
+ }
+
+ src1 = _stringVal(self) + len1 - len2;
+ src2 = _stringVal(aString);
+ while (c = *src2++) {
+ if (c != *src1++) {
+ RETURN ( false );
+ }
+ }
+ RETURN (true);
}
- len2 = __qSize(s);
- src2 = _stringVal(s);
- if ((cls = __qClass(s)) != String) {
- int n = __OBJS2BYTES__(_intVal(_ClassInstPtr(cls)->c_ninstvars));
- len2 -= n;
- src2 += n;
- }
- if (len1 < len2) {
- RETURN ( false );
- }
- src1 = _stringVal(self) + len1 - len2;
- src2 = _stringVal(aString);
- while (c = *src2++)
- if (c != *src1++) {
- RETURN ( false );
- }
%}.
- ^ true
+ (aString isMemberOf:Character) ifTrue:[
+ self size == 0 ifTrue:[^ false].
+ ^ (self at:(self size)) == aString
+ ].
+ ^ super endsWith:aString
"
'hello world' endsWith:'world'
'hello world' endsWith:'earth'
+ 'hello world' endsWith:$d
+ 'hello world' endsWith:#($r $l $d)
"
! !
@@ -1695,6 +1680,19 @@
}
}
}
+ /*
+ * allow empty copy
+ */
+ if (index1 > index2) {
+ PROTECT_CONTEXT
+ _qNew(newString, OHDR_SIZE+1, SENDER);
+ UNPROTECT_CONTEXT
+ if (newString != nil) {
+ _InstPtr(newString)->o_class = String;
+ __stringVal(newString)[0] = '\0';
+ RETURN ( newString );
+ }
+ }
}
%}.
"fall back in case of non-integer index or out-of-bound index;
--- a/Symbol.st Sat Aug 05 16:05:36 1995 +0200
+++ b/Symbol.st Tue Aug 08 02:49:43 1995 +0200
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1988 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Symbol.st,v 1.25 1995-08-03 01:17:01 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Symbol.st,v 1.26 1995-08-08 00:49:18 claus Exp $
'!
!Symbol class methodsFor:'documentation'!
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Symbol.st,v 1.25 1995-08-03 01:17:01 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Symbol.st,v 1.26 1995-08-08 00:49:18 claus Exp $
"
!
@@ -297,10 +297,12 @@
int l;
if (__Class(self) == Symbol) {
- val = _GET_HASH(self);
+ val = __GET_HASH(self);
/*
* only do it, if I have no standard hash key
- * assigned.
+ * assigned (which can only happen due to a #become:,
+ * or by creating a symbol uninterned, and interning it
+ * after it got a hashKey assigned.
*/
if (val == 0) {
cp = _stringVal(self);
@@ -329,9 +331,10 @@
l |= 1;
val = (val * l) & 0x3FFFFFFF;
}
-
- RETURN ( _MKSMALLINT(val) );
+ } else {
+ val <<= __HASH_SHIFT__;
}
+ RETURN ( _MKSMALLINT(val) );
}
%}.
^ super identityHash
--- a/Unix.st Sat Aug 05 16:05:36 1995 +0200
+++ b/Unix.st Tue Aug 08 02:49:43 1995 +0200
@@ -22,7 +22,7 @@
COPYRIGHT (c) 1988 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Attic/Unix.st,v 1.44 1995-08-03 03:26:11 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/Unix.st,v 1.45 1995-08-08 00:49:29 claus Exp $
'!
!OperatingSystem primitiveDefinitions!
@@ -160,7 +160,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Attic/Unix.st,v 1.44 1995-08-03 03:26:11 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/Unix.st,v 1.45 1995-08-08 00:49:29 claus Exp $
"
!
@@ -3048,7 +3048,7 @@
id := OperatingSystem fork.
id == 0 ifTrue:[
"I am the child"
- OperatingSystem exec:'/bin/sh' withArguments:'sh -c ls -l'.
+ OperatingSystem exec:'/bin/ls' withArguments:#('ls' '/tmp').
"not reached"
]
"