--- a/AbsTime.st Thu Dec 07 22:24:46 1995 +0100
+++ b/AbsTime.st Thu Dec 07 22:32:39 1995 +0100
@@ -10,8 +10,6 @@
hereby transferred.
"
-'From Smalltalk/X, Version:2.10.4 on 8-feb-1995 at 12:46:45 pm'!
-
AbstractTime subclass:#AbsoluteTime
instanceVariableNames:'osTime'
classVariableNames:''
@@ -35,10 +33,6 @@
"
!
-version
- ^ '$Header: /cvs/stx/stx/libbasic/Attic/AbsTime.st,v 1.17 1995-11-16 23:27:50 cg Exp $'
-!
-
documentation
"
This class represents time values in seconds from 1st. Jan 1970, as
@@ -148,44 +142,6 @@
"Modified: 16.11.1995 / 22:49:39 / cg"
! !
-!AbsoluteTime methodsFor:'private'!
-
-secondsLow
- "strictly private: return the low part of the seconds"
-
- ^ osTime at:1
-!
-
-secondsHi
- "strictly private: return the hi part of the seconds"
-
- ^ osTime at:2
-!
-
-setSecondsLow:secsLow and:secsHi
- "strictly private: set the seconds (since whatever)"
-
- osTime := Array with:secsLow with:secsHi
-!
-
-setSeconds:secs
- "strictly private: set the seconds (since whatever)"
-
- osTime := Array with:(secs // 16r10000) with:(secs \\ 16r10000)
-!
-
-getSeconds
- "strictly private: return the seconds (since whatever)"
-
- ^ ((osTime at:2) * 16r10000) + (osTime at:1)
-!
-
-fromOSTimeLow:secsLow and:secsHi
- "strictly private: set the seconds from an OS time (since whatever)"
-
- osTime := Array with:secsLow with:secsHi
-! !
-
!AbsoluteTime methodsFor:'accessing'!
day
@@ -204,38 +160,6 @@
"
!
-month
- "return the month of the receiver (1..12).
- For compatibility, use instances of Date for this."
-
- |m|
-
- OperatingSystem computeDatePartsOf:osTime for:[ :year :month :day |
- m := month
- ].
- ^ m
-
- "
- AbsoluteTime now month
- "
-!
-
-year
- "return the year of the receiver i.e. 1992.
- For compatibility, use instances of Date for this."
-
- |y|
-
- OperatingSystem computeDatePartsOf:osTime for:[:year :month :day |
- y := year
- ].
- ^ y
-
- "
- AbsoluteTime now year
- "
-!
-
hours
"return the hours (0..23)"
@@ -268,6 +192,22 @@
!
+month
+ "return the month of the receiver (1..12).
+ For compatibility, use instances of Date for this."
+
+ |m|
+
+ OperatingSystem computeDatePartsOf:osTime for:[ :year :month :day |
+ m := month
+ ].
+ ^ m
+
+ "
+ AbsoluteTime now month
+ "
+!
+
seconds
"return the seconds (0..59)"
@@ -282,99 +222,22 @@
AbsoluteTime now seconds
"
-! !
-
-!AbsoluteTime methodsFor:'comparing'!
-
-> aTime
- "return true if the argument, aTime is after the receiver"
-
- |myHi otherHi|
-
- myHi := self secondsHi.
- otherHi := aTime secondsHi.
- myHi > otherHi ifTrue:[^ true].
- myHi < otherHi ifTrue:[^ false].
- ^ self secondsLow > aTime secondsLow
-!
-
-< aTime
- "return true if the argument, aTime is before the receiver"
-
- |myHi otherHi|
-
- myHi := self secondsHi.
- otherHi := aTime secondsHi.
- myHi < otherHi ifTrue:[^ true].
- myHi > otherHi ifTrue:[^ false].
- ^ self secondsLow < aTime secondsLow
-!
-
-= aTime
- "return true if the argument, aTime represents the same time"
-
- (aTime species == self species) ifFalse:[^ false].
- ^ (self secondsLow == aTime secondsLow) and:[self secondsHi == aTime secondsHi]
!
-hash
- "return an integer useful for hashing on times"
-
- ^ self getSeconds
-! !
-
-!AbsoluteTime methodsFor:'converting'!
+year
+ "return the year of the receiver i.e. 1992.
+ For compatibility, use instances of Date for this."
-asSeconds
- "return the number of seconds elapsed since whatever time the
- OperatingSystem bases its time upon. Since this is totally
- OS-dependent, do not interpret the value returned by this method.
- You can use it to add/subtract seconds or get time deltas, though."
+ |y|
- ^ self getSeconds
+ OperatingSystem computeDatePartsOf:osTime for:[:year :month :day |
+ y := year
+ ].
+ ^ y
"
- AbsoluteTime now asSeconds
- AbsoluteTime fromSeconds:(AbsoluteTime now asSeconds + 3600)
- Time hour:23 minutes:33 seconds:0
- Time fromSeconds:((Time hour:23 minutes:33 seconds:0) asSeconds + 3600)
- "
-!
-
-asDate
- "return a Date object from the receiver.
- The returned date will only represent the day - not the timeOfDay."
-
- ^ Date fromOSTime:osTime
-
- "
- AbsoluteTime now
- AbsoluteTime now asDate
- (AbsoluteTime now addTime:3600) asDate
- (AbsoluteTime now addTime:3600) asTime
- AbsoluteTime fromSeconds:(AbsoluteTime now asSeconds + 3600)
- (AbsoluteTime fromSeconds:(AbsoluteTime now asSeconds + 3600)) asDate
+ AbsoluteTime now year
"
-
-!
-
-asTime
- "return a Time object from the receiver.
- The returned time will only represent the timeOfDay - not the day."
-
- ^ Time fromOSTime:osTime
-
- "
- AbsoluteTime now
- AbsoluteTime now asTime
- (AbsoluteTime now addTime:3600) asTime
- "
-!
-
-asAbsoluteTime
- "return an AbsoluteTime object from the receiver - thats the receiver."
-
- ^ self
! !
!AbsoluteTime methodsFor:'arithmetic'!
@@ -413,6 +276,99 @@
"
! !
+!AbsoluteTime methodsFor:'comparing'!
+
+< aTime
+ "return true if the argument, aTime is before the receiver"
+
+ |myHi otherHi|
+
+ myHi := self secondsHi.
+ otherHi := aTime secondsHi.
+ myHi < otherHi ifTrue:[^ true].
+ myHi > otherHi ifTrue:[^ false].
+ ^ self secondsLow < aTime secondsLow
+!
+
+= aTime
+ "return true if the argument, aTime represents the same time"
+
+ (aTime species == self species) ifFalse:[^ false].
+ ^ (self secondsLow == aTime secondsLow) and:[self secondsHi == aTime secondsHi]
+!
+
+> aTime
+ "return true if the argument, aTime is after the receiver"
+
+ |myHi otherHi|
+
+ myHi := self secondsHi.
+ otherHi := aTime secondsHi.
+ myHi > otherHi ifTrue:[^ true].
+ myHi < otherHi ifTrue:[^ false].
+ ^ self secondsLow > aTime secondsLow
+!
+
+hash
+ "return an integer useful for hashing on times"
+
+ ^ self getSeconds
+! !
+
+!AbsoluteTime methodsFor:'converting'!
+
+asAbsoluteTime
+ "return an AbsoluteTime object from the receiver - thats the receiver."
+
+ ^ self
+!
+
+asDate
+ "return a Date object from the receiver.
+ The returned date will only represent the day - not the timeOfDay."
+
+ ^ Date fromOSTime:osTime
+
+ "
+ AbsoluteTime now
+ AbsoluteTime now asDate
+ (AbsoluteTime now addTime:3600) asDate
+ (AbsoluteTime now addTime:3600) asTime
+ AbsoluteTime fromSeconds:(AbsoluteTime now asSeconds + 3600)
+ (AbsoluteTime fromSeconds:(AbsoluteTime now asSeconds + 3600)) asDate
+ "
+
+!
+
+asSeconds
+ "return the number of seconds elapsed since whatever time the
+ OperatingSystem bases its time upon. Since this is totally
+ OS-dependent, do not interpret the value returned by this method.
+ You can use it to add/subtract seconds or get time deltas, though."
+
+ ^ self getSeconds
+
+ "
+ AbsoluteTime now asSeconds
+ AbsoluteTime fromSeconds:(AbsoluteTime now asSeconds + 3600)
+ Time hour:23 minutes:33 seconds:0
+ Time fromSeconds:((Time hour:23 minutes:33 seconds:0) asSeconds + 3600)
+ "
+!
+
+asTime
+ "return a Time object from the receiver.
+ The returned time will only represent the timeOfDay - not the day."
+
+ ^ Time fromOSTime:osTime
+
+ "
+ AbsoluteTime now
+ AbsoluteTime now asTime
+ (AbsoluteTime now addTime:3600) asTime
+ "
+! !
+
!AbsoluteTime methodsFor:'printing & storing'!
printOn:aStream
@@ -463,3 +419,47 @@
AbsoluteTime readFrom:(AbsoluteTime now storeString) readStream
"
! !
+
+!AbsoluteTime methodsFor:'private'!
+
+fromOSTimeLow:secsLow and:secsHi
+ "strictly private: set the seconds from an OS time (since whatever)"
+
+ osTime := Array with:secsLow with:secsHi
+!
+
+getSeconds
+ "strictly private: return the seconds (since whatever)"
+
+ ^ ((osTime at:2) * 16r10000) + (osTime at:1)
+!
+
+secondsHi
+ "strictly private: return the hi part of the seconds"
+
+ ^ osTime at:2
+!
+
+secondsLow
+ "strictly private: return the low part of the seconds"
+
+ ^ osTime at:1
+!
+
+setSeconds:secs
+ "strictly private: set the seconds (since whatever)"
+
+ osTime := Array with:(secs // 16r10000) with:(secs \\ 16r10000)
+!
+
+setSecondsLow:secsLow and:secsHi
+ "strictly private: set the seconds (since whatever)"
+
+ osTime := Array with:secsLow with:secsHi
+! !
+
+!AbsoluteTime class methodsFor:'documentation'!
+
+version
+ ^ '$Header: /cvs/stx/stx/libbasic/Attic/AbsTime.st,v 1.18 1995-12-07 21:31:29 cg Exp $'
+! !
--- a/AbsoluteTime.st Thu Dec 07 22:24:46 1995 +0100
+++ b/AbsoluteTime.st Thu Dec 07 22:32:39 1995 +0100
@@ -10,8 +10,6 @@
hereby transferred.
"
-'From Smalltalk/X, Version:2.10.4 on 8-feb-1995 at 12:46:45 pm'!
-
AbstractTime subclass:#AbsoluteTime
instanceVariableNames:'osTime'
classVariableNames:''
@@ -35,10 +33,6 @@
"
!
-version
- ^ '$Header: /cvs/stx/stx/libbasic/Attic/AbsoluteTime.st,v 1.17 1995-11-16 23:27:50 cg Exp $'
-!
-
documentation
"
This class represents time values in seconds from 1st. Jan 1970, as
@@ -148,44 +142,6 @@
"Modified: 16.11.1995 / 22:49:39 / cg"
! !
-!AbsoluteTime methodsFor:'private'!
-
-secondsLow
- "strictly private: return the low part of the seconds"
-
- ^ osTime at:1
-!
-
-secondsHi
- "strictly private: return the hi part of the seconds"
-
- ^ osTime at:2
-!
-
-setSecondsLow:secsLow and:secsHi
- "strictly private: set the seconds (since whatever)"
-
- osTime := Array with:secsLow with:secsHi
-!
-
-setSeconds:secs
- "strictly private: set the seconds (since whatever)"
-
- osTime := Array with:(secs // 16r10000) with:(secs \\ 16r10000)
-!
-
-getSeconds
- "strictly private: return the seconds (since whatever)"
-
- ^ ((osTime at:2) * 16r10000) + (osTime at:1)
-!
-
-fromOSTimeLow:secsLow and:secsHi
- "strictly private: set the seconds from an OS time (since whatever)"
-
- osTime := Array with:secsLow with:secsHi
-! !
-
!AbsoluteTime methodsFor:'accessing'!
day
@@ -204,38 +160,6 @@
"
!
-month
- "return the month of the receiver (1..12).
- For compatibility, use instances of Date for this."
-
- |m|
-
- OperatingSystem computeDatePartsOf:osTime for:[ :year :month :day |
- m := month
- ].
- ^ m
-
- "
- AbsoluteTime now month
- "
-!
-
-year
- "return the year of the receiver i.e. 1992.
- For compatibility, use instances of Date for this."
-
- |y|
-
- OperatingSystem computeDatePartsOf:osTime for:[:year :month :day |
- y := year
- ].
- ^ y
-
- "
- AbsoluteTime now year
- "
-!
-
hours
"return the hours (0..23)"
@@ -268,6 +192,22 @@
!
+month
+ "return the month of the receiver (1..12).
+ For compatibility, use instances of Date for this."
+
+ |m|
+
+ OperatingSystem computeDatePartsOf:osTime for:[ :year :month :day |
+ m := month
+ ].
+ ^ m
+
+ "
+ AbsoluteTime now month
+ "
+!
+
seconds
"return the seconds (0..59)"
@@ -282,99 +222,22 @@
AbsoluteTime now seconds
"
-! !
-
-!AbsoluteTime methodsFor:'comparing'!
-
-> aTime
- "return true if the argument, aTime is after the receiver"
-
- |myHi otherHi|
-
- myHi := self secondsHi.
- otherHi := aTime secondsHi.
- myHi > otherHi ifTrue:[^ true].
- myHi < otherHi ifTrue:[^ false].
- ^ self secondsLow > aTime secondsLow
-!
-
-< aTime
- "return true if the argument, aTime is before the receiver"
-
- |myHi otherHi|
-
- myHi := self secondsHi.
- otherHi := aTime secondsHi.
- myHi < otherHi ifTrue:[^ true].
- myHi > otherHi ifTrue:[^ false].
- ^ self secondsLow < aTime secondsLow
-!
-
-= aTime
- "return true if the argument, aTime represents the same time"
-
- (aTime species == self species) ifFalse:[^ false].
- ^ (self secondsLow == aTime secondsLow) and:[self secondsHi == aTime secondsHi]
!
-hash
- "return an integer useful for hashing on times"
-
- ^ self getSeconds
-! !
-
-!AbsoluteTime methodsFor:'converting'!
+year
+ "return the year of the receiver i.e. 1992.
+ For compatibility, use instances of Date for this."
-asSeconds
- "return the number of seconds elapsed since whatever time the
- OperatingSystem bases its time upon. Since this is totally
- OS-dependent, do not interpret the value returned by this method.
- You can use it to add/subtract seconds or get time deltas, though."
+ |y|
- ^ self getSeconds
+ OperatingSystem computeDatePartsOf:osTime for:[:year :month :day |
+ y := year
+ ].
+ ^ y
"
- AbsoluteTime now asSeconds
- AbsoluteTime fromSeconds:(AbsoluteTime now asSeconds + 3600)
- Time hour:23 minutes:33 seconds:0
- Time fromSeconds:((Time hour:23 minutes:33 seconds:0) asSeconds + 3600)
- "
-!
-
-asDate
- "return a Date object from the receiver.
- The returned date will only represent the day - not the timeOfDay."
-
- ^ Date fromOSTime:osTime
-
- "
- AbsoluteTime now
- AbsoluteTime now asDate
- (AbsoluteTime now addTime:3600) asDate
- (AbsoluteTime now addTime:3600) asTime
- AbsoluteTime fromSeconds:(AbsoluteTime now asSeconds + 3600)
- (AbsoluteTime fromSeconds:(AbsoluteTime now asSeconds + 3600)) asDate
+ AbsoluteTime now year
"
-
-!
-
-asTime
- "return a Time object from the receiver.
- The returned time will only represent the timeOfDay - not the day."
-
- ^ Time fromOSTime:osTime
-
- "
- AbsoluteTime now
- AbsoluteTime now asTime
- (AbsoluteTime now addTime:3600) asTime
- "
-!
-
-asAbsoluteTime
- "return an AbsoluteTime object from the receiver - thats the receiver."
-
- ^ self
! !
!AbsoluteTime methodsFor:'arithmetic'!
@@ -413,6 +276,99 @@
"
! !
+!AbsoluteTime methodsFor:'comparing'!
+
+< aTime
+ "return true if the argument, aTime is before the receiver"
+
+ |myHi otherHi|
+
+ myHi := self secondsHi.
+ otherHi := aTime secondsHi.
+ myHi < otherHi ifTrue:[^ true].
+ myHi > otherHi ifTrue:[^ false].
+ ^ self secondsLow < aTime secondsLow
+!
+
+= aTime
+ "return true if the argument, aTime represents the same time"
+
+ (aTime species == self species) ifFalse:[^ false].
+ ^ (self secondsLow == aTime secondsLow) and:[self secondsHi == aTime secondsHi]
+!
+
+> aTime
+ "return true if the argument, aTime is after the receiver"
+
+ |myHi otherHi|
+
+ myHi := self secondsHi.
+ otherHi := aTime secondsHi.
+ myHi > otherHi ifTrue:[^ true].
+ myHi < otherHi ifTrue:[^ false].
+ ^ self secondsLow > aTime secondsLow
+!
+
+hash
+ "return an integer useful for hashing on times"
+
+ ^ self getSeconds
+! !
+
+!AbsoluteTime methodsFor:'converting'!
+
+asAbsoluteTime
+ "return an AbsoluteTime object from the receiver - thats the receiver."
+
+ ^ self
+!
+
+asDate
+ "return a Date object from the receiver.
+ The returned date will only represent the day - not the timeOfDay."
+
+ ^ Date fromOSTime:osTime
+
+ "
+ AbsoluteTime now
+ AbsoluteTime now asDate
+ (AbsoluteTime now addTime:3600) asDate
+ (AbsoluteTime now addTime:3600) asTime
+ AbsoluteTime fromSeconds:(AbsoluteTime now asSeconds + 3600)
+ (AbsoluteTime fromSeconds:(AbsoluteTime now asSeconds + 3600)) asDate
+ "
+
+!
+
+asSeconds
+ "return the number of seconds elapsed since whatever time the
+ OperatingSystem bases its time upon. Since this is totally
+ OS-dependent, do not interpret the value returned by this method.
+ You can use it to add/subtract seconds or get time deltas, though."
+
+ ^ self getSeconds
+
+ "
+ AbsoluteTime now asSeconds
+ AbsoluteTime fromSeconds:(AbsoluteTime now asSeconds + 3600)
+ Time hour:23 minutes:33 seconds:0
+ Time fromSeconds:((Time hour:23 minutes:33 seconds:0) asSeconds + 3600)
+ "
+!
+
+asTime
+ "return a Time object from the receiver.
+ The returned time will only represent the timeOfDay - not the day."
+
+ ^ Time fromOSTime:osTime
+
+ "
+ AbsoluteTime now
+ AbsoluteTime now asTime
+ (AbsoluteTime now addTime:3600) asTime
+ "
+! !
+
!AbsoluteTime methodsFor:'printing & storing'!
printOn:aStream
@@ -463,3 +419,47 @@
AbsoluteTime readFrom:(AbsoluteTime now storeString) readStream
"
! !
+
+!AbsoluteTime methodsFor:'private'!
+
+fromOSTimeLow:secsLow and:secsHi
+ "strictly private: set the seconds from an OS time (since whatever)"
+
+ osTime := Array with:secsLow with:secsHi
+!
+
+getSeconds
+ "strictly private: return the seconds (since whatever)"
+
+ ^ ((osTime at:2) * 16r10000) + (osTime at:1)
+!
+
+secondsHi
+ "strictly private: return the hi part of the seconds"
+
+ ^ osTime at:2
+!
+
+secondsLow
+ "strictly private: return the low part of the seconds"
+
+ ^ osTime at:1
+!
+
+setSeconds:secs
+ "strictly private: set the seconds (since whatever)"
+
+ osTime := Array with:(secs // 16r10000) with:(secs \\ 16r10000)
+!
+
+setSecondsLow:secsLow and:secsHi
+ "strictly private: set the seconds (since whatever)"
+
+ osTime := Array with:secsLow with:secsHi
+! !
+
+!AbsoluteTime class methodsFor:'documentation'!
+
+version
+ ^ '$Header: /cvs/stx/stx/libbasic/Attic/AbsoluteTime.st,v 1.18 1995-12-07 21:31:29 cg Exp $'
+! !
--- a/AbstrTime.st Thu Dec 07 22:24:46 1995 +0100
+++ b/AbstrTime.st Thu Dec 07 22:32:39 1995 +0100
@@ -10,8 +10,6 @@
hereby transferred.
"
-'From Smalltalk/X, Version:2.10.4 on 7-feb-1995 at 11:53:03 pm'!
-
Magnitude subclass:#AbstractTime
instanceVariableNames:''
classVariableNames:''
@@ -40,37 +38,17 @@
This is an abstract class; there are no instances in the system.
It is meant as a home for methods common to time handling classes.
"
-!
-
-version
- ^ '$Header: /cvs/stx/stx/libbasic/Attic/AbstrTime.st,v 1.7 1995-11-11 14:26:24 cg Exp $'
! !
!AbstractTime class methodsFor:'instance creation'!
-now
- "return an instance of myself representing this moment"
+dateAndTimeNow
+ "return an array filled with date and time"
- ^ self basicNew fromOSTime:(OperatingSystem getTimeParts)
+ ^ Array with:(Date today) with:(Time now)
"
- AbsoluteTime now
- Time now
- "
-!
-
-fromSeconds:seconds
- "return an instance that is constructed from seconds.
- This method is only allowed for second values as returned by
- getSeconds, possibly adding/subtracting to that. Never
- depend on any specific interpretation of the seconds."
-
- ^ self basicNew setSeconds:seconds
-
- "
- Time fromSeconds:0 should return midnight
- AbsoluteTime fromSeconds:0 on UNIX: returns 1st. Jan 1970
- on others: dont know
+ Time dateAndTimeNow
"
!
@@ -100,14 +78,40 @@
^ self basicNew fromOSTimeLow:osTimeLow and:osTimeHigh
!
-dateAndTimeNow
- "return an array filled with date and time"
+fromSeconds:seconds
+ "return an instance that is constructed from seconds.
+ This method is only allowed for second values as returned by
+ getSeconds, possibly adding/subtracting to that. Never
+ depend on any specific interpretation of the seconds."
- ^ Array with:(Date today) with:(Time now)
+ ^ self basicNew setSeconds:seconds
"
- Time dateAndTimeNow
+ Time fromSeconds:0 should return midnight
+ AbsoluteTime fromSeconds:0 on UNIX: returns 1st. Jan 1970
+ on others: dont know
+ "
+!
+
+now
+ "return an instance of myself representing this moment"
+
+ ^ self basicNew fromOSTime:(OperatingSystem getTimeParts)
+
"
+ AbsoluteTime now
+ Time now
+ "
+! !
+
+!AbstractTime class methodsFor:'ST-80 compatibility'!
+
+totalSeconds
+ "returns an internal second clock. Dont interpret the returned
+ value - if at all, use it to compute time deltas, by subtracting
+ returned values."
+
+ ^ self secondClock
! !
!AbstractTime class methodsFor:'obsolete'!
@@ -119,36 +123,60 @@
^ self fromOSTimeLow:low and:hi
! !
-!AbstractTime methodsFor:'private'!
+!AbstractTime class methodsFor:'queries'!
-fromOSTime:timeParts
- "set my time, from operatingSystems time parts"
+millisecondClockValue
+ "return the millisecond clock - since this one overruns
+ regularly, use the value only for short timing deltas.
+ Also remember that it wraps when compares these values."
- ^ self fromOSTimeLow:(timeParts at:1) and:(timeParts at:2)
+ ^ OperatingSystem getMillisecondTime.
+
+ "
+ Time millisecondClockValue
+ "
!
-fromOSTimeTimeLow:lowTime and:hiTime
- "set my time, from operatingSystems time parts.
- Since I am abstract (not knowing how the time is actually
- represented), this must be done by a concrete class."
+secondClock
+ "return seconds of now - for GNU-ST compatibility"
+
+ ^ OperatingSystem getTime
+
+ "
+ AbstractTime secondClock
+ "
+! !
+
+!AbstractTime class methodsFor:'timing evaluations'!
- ^ self subclassResponsibility
+millisecondsToRun:aBlock
+ "evaluate the argument, aBlock; return the number of milliseconds it took"
+
+ |startTime endTime|
+
+ startTime := self millisecondClockValue.
+ aBlock value.
+ endTime := self millisecondClockValue.
+ ^ endTime - startTime
+
+ "
+ Time millisecondsToRun:[100 factorial]
+ "
!
-setSeconds:secs
- "set the seconds.
- Since I am abstract (not knowing how the time is actually
- represented), this must be done by a concrete class."
+secondsToRun:aBlock
+ "evaluate the argument, aBlock; return the number of seconds it took"
+
+ |startTime endTime|
- ^ self subclassResponsibility
-!
+ startTime := self secondClock.
+ aBlock value.
+ endTime := self secondClock.
+ ^ endTime - startTime
-getSeconds
- "get the seconds.
- Since I am abstract (not knowing how the time is actually
- represented), this must be done by a concrete class."
-
- ^ self subclassResponsibility
+ "
+ Time secondsToRun:[1000 factorial]
+ "
! !
!AbstractTime methodsFor:'accessing'!
@@ -203,17 +231,17 @@
"
!
-addSeconds:numberOfSeconds
- "return a new instance of myself, numberOfSeconds afterwards."
+addHours:numberOfHours
+ "return a new instance of myself, numberOfHours afterwards."
- ^ self species basicNew setSeconds:(self getSeconds + numberOfSeconds)
+ ^ self addSeconds:(numberOfHours * (60 * 60))
"
|t|
- t := AbsoluteTime now. t printNL. (t addSeconds:50) printNL.
-
- t := Time now. t printNL. (t addSeconds:50) printNL
+ t := AbsoluteTime now.
+ t printNL.
+ (t addHours:50) printNL
"
!
@@ -231,31 +259,39 @@
"
!
-addHours:numberOfHours
- "return a new instance of myself, numberOfHours afterwards."
+addSeconds:numberOfSeconds
+ "return a new instance of myself, numberOfSeconds afterwards."
+
+ ^ self species basicNew setSeconds:(self getSeconds + numberOfSeconds)
+
+ "
+ |t|
+
+ t := AbsoluteTime now. t printNL. (t addSeconds:50) printNL.
- ^ self addSeconds:(numberOfHours * (60 * 60))
+ t := Time now. t printNL. (t addSeconds:50) printNL
+ "
+!
+
+addTime:timeAmount
+ "return a new instance of myself, timeAmount seconds afterwards.
+ AddTime is a bad name - it does not add a time, but expects
+ a number. Use any of addSeconds/addHours etc."
+
+ ^ self species basicNew setSeconds:(self getSeconds + timeAmount)
+!
+
+subtractHours:numberOfHours
+ "return a new instance of myself, numberOfHours before."
+
+ ^ self subtractSeconds:(numberOfHours * (60 * 60))
"
|t|
t := AbsoluteTime now.
t printNL.
- (t addHours:50) printNL
- "
-!
-
-subtractSeconds:numberOfSeconds
- "return a new instance of myself, numberOfSeconds before."
-
- ^ self species basicNew setSeconds:(self getSeconds - numberOfSeconds)
-
- "
- |t|
-
- t := AbsoluteTime now.
- t printNL.
- (t subtractSeconds:50) printNL
+ (t subtractHours:50) printNL
"
!
@@ -273,28 +309,20 @@
"
!
-subtractHours:numberOfHours
- "return a new instance of myself, numberOfHours before."
+subtractSeconds:numberOfSeconds
+ "return a new instance of myself, numberOfSeconds before."
- ^ self subtractSeconds:(numberOfHours * (60 * 60))
+ ^ self species basicNew setSeconds:(self getSeconds - numberOfSeconds)
"
|t|
t := AbsoluteTime now.
t printNL.
- (t subtractHours:50) printNL
+ (t subtractSeconds:50) printNL
"
!
-addTime:timeAmount
- "return a new instance of myself, timeAmount seconds afterwards.
- AddTime is a bad name - it does not add a time, but expects
- a number. Use any of addSeconds/addHours etc."
-
- ^ self species basicNew setSeconds:(self getSeconds + timeAmount)
-!
-
subtractTime:timeAmount
"return a new instance opf myself, timeAmount seconds before myself.
SubtractTime is a bad name - it does not subtract a time, but expects
@@ -303,69 +331,40 @@
^ self species basicNew setSeconds:(self getSeconds - timeAmount)
! !
-!AbstractTime class methodsFor:'queries'!
-
-secondClock
- "return seconds of now - for GNU-ST compatibility"
+!AbstractTime methodsFor:'private'!
- ^ OperatingSystem getTime
+fromOSTime:timeParts
+ "set my time, from operatingSystems time parts"
- "
- AbstractTime secondClock
- "
+ ^ self fromOSTimeLow:(timeParts at:1) and:(timeParts at:2)
!
-millisecondClockValue
- "return the millisecond clock - since this one overruns
- regularly, use the value only for short timing deltas.
- Also remember that it wraps when compares these values."
+fromOSTimeTimeLow:lowTime and:hiTime
+ "set my time, from operatingSystems time parts.
+ Since I am abstract (not knowing how the time is actually
+ represented), this must be done by a concrete class."
+
+ ^ self subclassResponsibility
+!
- ^ OperatingSystem getMillisecondTime.
+getSeconds
+ "get the seconds.
+ Since I am abstract (not knowing how the time is actually
+ represented), this must be done by a concrete class."
- "
- Time millisecondClockValue
- "
+ ^ self subclassResponsibility
+!
+
+setSeconds:secs
+ "set the seconds.
+ Since I am abstract (not knowing how the time is actually
+ represented), this must be done by a concrete class."
+
+ ^ self subclassResponsibility
! !
-!AbstractTime class methodsFor:'timing evaluations'!
-
-secondsToRun:aBlock
- "evaluate the argument, aBlock; return the number of seconds it took"
-
- |startTime endTime|
-
- startTime := self secondClock.
- aBlock value.
- endTime := self secondClock.
- ^ endTime - startTime
-
- "
- Time secondsToRun:[1000 factorial]
- "
-!
-
-millisecondsToRun:aBlock
- "evaluate the argument, aBlock; return the number of milliseconds it took"
+!AbstractTime class methodsFor:'documentation'!
- |startTime endTime|
-
- startTime := self millisecondClockValue.
- aBlock value.
- endTime := self millisecondClockValue.
- ^ endTime - startTime
-
- "
- Time millisecondsToRun:[100 factorial]
- "
+version
+ ^ '$Header: /cvs/stx/stx/libbasic/Attic/AbstrTime.st,v 1.8 1995-12-07 21:31:40 cg Exp $'
! !
-
-!AbstractTime class methodsFor:'ST-80 compatibility'!
-
-totalSeconds
- "returns an internal second clock. Dont interpret the returned
- value - if at all, use it to compute time deltas, by subtracting
- returned values."
-
- ^ self secondClock
-! !
-
--- a/AbstractTime.st Thu Dec 07 22:24:46 1995 +0100
+++ b/AbstractTime.st Thu Dec 07 22:32:39 1995 +0100
@@ -10,8 +10,6 @@
hereby transferred.
"
-'From Smalltalk/X, Version:2.10.4 on 7-feb-1995 at 11:53:03 pm'!
-
Magnitude subclass:#AbstractTime
instanceVariableNames:''
classVariableNames:''
@@ -40,37 +38,17 @@
This is an abstract class; there are no instances in the system.
It is meant as a home for methods common to time handling classes.
"
-!
-
-version
- ^ '$Header: /cvs/stx/stx/libbasic/AbstractTime.st,v 1.7 1995-11-11 14:26:24 cg Exp $'
! !
!AbstractTime class methodsFor:'instance creation'!
-now
- "return an instance of myself representing this moment"
+dateAndTimeNow
+ "return an array filled with date and time"
- ^ self basicNew fromOSTime:(OperatingSystem getTimeParts)
+ ^ Array with:(Date today) with:(Time now)
"
- AbsoluteTime now
- Time now
- "
-!
-
-fromSeconds:seconds
- "return an instance that is constructed from seconds.
- This method is only allowed for second values as returned by
- getSeconds, possibly adding/subtracting to that. Never
- depend on any specific interpretation of the seconds."
-
- ^ self basicNew setSeconds:seconds
-
- "
- Time fromSeconds:0 should return midnight
- AbsoluteTime fromSeconds:0 on UNIX: returns 1st. Jan 1970
- on others: dont know
+ Time dateAndTimeNow
"
!
@@ -100,14 +78,40 @@
^ self basicNew fromOSTimeLow:osTimeLow and:osTimeHigh
!
-dateAndTimeNow
- "return an array filled with date and time"
+fromSeconds:seconds
+ "return an instance that is constructed from seconds.
+ This method is only allowed for second values as returned by
+ getSeconds, possibly adding/subtracting to that. Never
+ depend on any specific interpretation of the seconds."
- ^ Array with:(Date today) with:(Time now)
+ ^ self basicNew setSeconds:seconds
"
- Time dateAndTimeNow
+ Time fromSeconds:0 should return midnight
+ AbsoluteTime fromSeconds:0 on UNIX: returns 1st. Jan 1970
+ on others: dont know
+ "
+!
+
+now
+ "return an instance of myself representing this moment"
+
+ ^ self basicNew fromOSTime:(OperatingSystem getTimeParts)
+
"
+ AbsoluteTime now
+ Time now
+ "
+! !
+
+!AbstractTime class methodsFor:'ST-80 compatibility'!
+
+totalSeconds
+ "returns an internal second clock. Dont interpret the returned
+ value - if at all, use it to compute time deltas, by subtracting
+ returned values."
+
+ ^ self secondClock
! !
!AbstractTime class methodsFor:'obsolete'!
@@ -119,36 +123,60 @@
^ self fromOSTimeLow:low and:hi
! !
-!AbstractTime methodsFor:'private'!
+!AbstractTime class methodsFor:'queries'!
-fromOSTime:timeParts
- "set my time, from operatingSystems time parts"
+millisecondClockValue
+ "return the millisecond clock - since this one overruns
+ regularly, use the value only for short timing deltas.
+ Also remember that it wraps when compares these values."
- ^ self fromOSTimeLow:(timeParts at:1) and:(timeParts at:2)
+ ^ OperatingSystem getMillisecondTime.
+
+ "
+ Time millisecondClockValue
+ "
!
-fromOSTimeTimeLow:lowTime and:hiTime
- "set my time, from operatingSystems time parts.
- Since I am abstract (not knowing how the time is actually
- represented), this must be done by a concrete class."
+secondClock
+ "return seconds of now - for GNU-ST compatibility"
+
+ ^ OperatingSystem getTime
+
+ "
+ AbstractTime secondClock
+ "
+! !
+
+!AbstractTime class methodsFor:'timing evaluations'!
- ^ self subclassResponsibility
+millisecondsToRun:aBlock
+ "evaluate the argument, aBlock; return the number of milliseconds it took"
+
+ |startTime endTime|
+
+ startTime := self millisecondClockValue.
+ aBlock value.
+ endTime := self millisecondClockValue.
+ ^ endTime - startTime
+
+ "
+ Time millisecondsToRun:[100 factorial]
+ "
!
-setSeconds:secs
- "set the seconds.
- Since I am abstract (not knowing how the time is actually
- represented), this must be done by a concrete class."
+secondsToRun:aBlock
+ "evaluate the argument, aBlock; return the number of seconds it took"
+
+ |startTime endTime|
- ^ self subclassResponsibility
-!
+ startTime := self secondClock.
+ aBlock value.
+ endTime := self secondClock.
+ ^ endTime - startTime
-getSeconds
- "get the seconds.
- Since I am abstract (not knowing how the time is actually
- represented), this must be done by a concrete class."
-
- ^ self subclassResponsibility
+ "
+ Time secondsToRun:[1000 factorial]
+ "
! !
!AbstractTime methodsFor:'accessing'!
@@ -203,17 +231,17 @@
"
!
-addSeconds:numberOfSeconds
- "return a new instance of myself, numberOfSeconds afterwards."
+addHours:numberOfHours
+ "return a new instance of myself, numberOfHours afterwards."
- ^ self species basicNew setSeconds:(self getSeconds + numberOfSeconds)
+ ^ self addSeconds:(numberOfHours * (60 * 60))
"
|t|
- t := AbsoluteTime now. t printNL. (t addSeconds:50) printNL.
-
- t := Time now. t printNL. (t addSeconds:50) printNL
+ t := AbsoluteTime now.
+ t printNL.
+ (t addHours:50) printNL
"
!
@@ -231,31 +259,39 @@
"
!
-addHours:numberOfHours
- "return a new instance of myself, numberOfHours afterwards."
+addSeconds:numberOfSeconds
+ "return a new instance of myself, numberOfSeconds afterwards."
+
+ ^ self species basicNew setSeconds:(self getSeconds + numberOfSeconds)
+
+ "
+ |t|
+
+ t := AbsoluteTime now. t printNL. (t addSeconds:50) printNL.
- ^ self addSeconds:(numberOfHours * (60 * 60))
+ t := Time now. t printNL. (t addSeconds:50) printNL
+ "
+!
+
+addTime:timeAmount
+ "return a new instance of myself, timeAmount seconds afterwards.
+ AddTime is a bad name - it does not add a time, but expects
+ a number. Use any of addSeconds/addHours etc."
+
+ ^ self species basicNew setSeconds:(self getSeconds + timeAmount)
+!
+
+subtractHours:numberOfHours
+ "return a new instance of myself, numberOfHours before."
+
+ ^ self subtractSeconds:(numberOfHours * (60 * 60))
"
|t|
t := AbsoluteTime now.
t printNL.
- (t addHours:50) printNL
- "
-!
-
-subtractSeconds:numberOfSeconds
- "return a new instance of myself, numberOfSeconds before."
-
- ^ self species basicNew setSeconds:(self getSeconds - numberOfSeconds)
-
- "
- |t|
-
- t := AbsoluteTime now.
- t printNL.
- (t subtractSeconds:50) printNL
+ (t subtractHours:50) printNL
"
!
@@ -273,28 +309,20 @@
"
!
-subtractHours:numberOfHours
- "return a new instance of myself, numberOfHours before."
+subtractSeconds:numberOfSeconds
+ "return a new instance of myself, numberOfSeconds before."
- ^ self subtractSeconds:(numberOfHours * (60 * 60))
+ ^ self species basicNew setSeconds:(self getSeconds - numberOfSeconds)
"
|t|
t := AbsoluteTime now.
t printNL.
- (t subtractHours:50) printNL
+ (t subtractSeconds:50) printNL
"
!
-addTime:timeAmount
- "return a new instance of myself, timeAmount seconds afterwards.
- AddTime is a bad name - it does not add a time, but expects
- a number. Use any of addSeconds/addHours etc."
-
- ^ self species basicNew setSeconds:(self getSeconds + timeAmount)
-!
-
subtractTime:timeAmount
"return a new instance opf myself, timeAmount seconds before myself.
SubtractTime is a bad name - it does not subtract a time, but expects
@@ -303,69 +331,40 @@
^ self species basicNew setSeconds:(self getSeconds - timeAmount)
! !
-!AbstractTime class methodsFor:'queries'!
-
-secondClock
- "return seconds of now - for GNU-ST compatibility"
+!AbstractTime methodsFor:'private'!
- ^ OperatingSystem getTime
+fromOSTime:timeParts
+ "set my time, from operatingSystems time parts"
- "
- AbstractTime secondClock
- "
+ ^ self fromOSTimeLow:(timeParts at:1) and:(timeParts at:2)
!
-millisecondClockValue
- "return the millisecond clock - since this one overruns
- regularly, use the value only for short timing deltas.
- Also remember that it wraps when compares these values."
+fromOSTimeTimeLow:lowTime and:hiTime
+ "set my time, from operatingSystems time parts.
+ Since I am abstract (not knowing how the time is actually
+ represented), this must be done by a concrete class."
+
+ ^ self subclassResponsibility
+!
- ^ OperatingSystem getMillisecondTime.
+getSeconds
+ "get the seconds.
+ Since I am abstract (not knowing how the time is actually
+ represented), this must be done by a concrete class."
- "
- Time millisecondClockValue
- "
+ ^ self subclassResponsibility
+!
+
+setSeconds:secs
+ "set the seconds.
+ Since I am abstract (not knowing how the time is actually
+ represented), this must be done by a concrete class."
+
+ ^ self subclassResponsibility
! !
-!AbstractTime class methodsFor:'timing evaluations'!
-
-secondsToRun:aBlock
- "evaluate the argument, aBlock; return the number of seconds it took"
-
- |startTime endTime|
-
- startTime := self secondClock.
- aBlock value.
- endTime := self secondClock.
- ^ endTime - startTime
-
- "
- Time secondsToRun:[1000 factorial]
- "
-!
-
-millisecondsToRun:aBlock
- "evaluate the argument, aBlock; return the number of milliseconds it took"
+!AbstractTime class methodsFor:'documentation'!
- |startTime endTime|
-
- startTime := self millisecondClockValue.
- aBlock value.
- endTime := self millisecondClockValue.
- ^ endTime - startTime
-
- "
- Time millisecondsToRun:[100 factorial]
- "
+version
+ ^ '$Header: /cvs/stx/stx/libbasic/AbstractTime.st,v 1.8 1995-12-07 21:31:40 cg Exp $'
! !
-
-!AbstractTime class methodsFor:'ST-80 compatibility'!
-
-totalSeconds
- "returns an internal second clock. Dont interpret the returned
- value - if at all, use it to compute time deltas, by subtracting
- returned values."
-
- ^ self secondClock
-! !
-
--- a/CCReader.st Thu Dec 07 22:24:46 1995 +0100
+++ b/CCReader.st Thu Dec 07 22:32:39 1995 +0100
@@ -11,10 +11,10 @@
"
Object subclass:#ClassCategoryReader
- instanceVariableNames:'myClass myCategory privacy ignore primSpec'
- classVariableNames:'KeepSource'
- poolDictionaries:''
- category:'Kernel-Support'
+ instanceVariableNames:'myClass myCategory privacy ignore primSpec'
+ classVariableNames:'KeepSource'
+ poolDictionaries:''
+ category:'Kernel-Support'
!
!ClassCategoryReader class methodsFor:'documentation'!
@@ -33,10 +33,6 @@
"
!
-version
- ^ '$Header: /cvs/stx/stx/libbasic/Attic/CCReader.st,v 1.22 1995-11-11 14:27:31 cg Exp $'
-!
-
documentation
"
a helper class for fileIn - keeps track of class and category to filein for.
@@ -51,20 +47,6 @@
KeepSource := true
! !
-!ClassCategoryReader class methodsFor:'defaults'!
-
-keepSource:aBoolean
- KeepSource := aBoolean
-
- "Created: 9.9.1995 / 15:22:26 / claus"
-!
-
-keepSource
- ^ KeepSource
-
- "Created: 9.9.1995 / 15:22:27 / claus"
-! !
-
!ClassCategoryReader class methodsFor:'instance creation'!
class:aClass category:aCategory
@@ -86,40 +68,29 @@
^ self new ignoreMethods
! !
-!ClassCategoryReader methodsFor:'private'!
+!ClassCategoryReader class methodsFor:'defaults'!
-class:aClass category:aCategory
- "set the instance variables"
+keepSource
+ ^ KeepSource
- myClass := aClass.
- myCategory := aCategory.
- ignore := false
+ "Created: 9.9.1995 / 15:22:27 / claus"
!
-class:aClass primitiveSpec:which
- "set the instance variables"
-
- myClass := aClass.
- primSpec := which.
- ignore := false
-! !
-
-!ClassCategoryReader methodsFor:'special'!
+keepSource:aBoolean
+ KeepSource := aBoolean
-privateProtocol
- privacy := #private
-!
-
-protectedProtocol
- privacy := #protected
-!
-
-ignoreMethods
- ignore := true
+ "Created: 9.9.1995 / 15:22:26 / claus"
! !
!ClassCategoryReader methodsFor:'fileIn'!
+fileInFrom:aStream
+ "read method-chunks from the input stream, aStream; compile them
+ and add the methods to the class defined by the class-instance var"
+
+ self fileInFrom:aStream notifying:nil passChunk:false
+!
+
fileInFrom:aStream notifying:requestor passChunk:passChunk
"read method-chunks from the input stream, aStream; compile them
and add the methods to the class defined by the class-instance var;
@@ -216,11 +187,43 @@
]
"Modified: 9.9.1995 / 15:29:08 / claus"
+! !
+
+!ClassCategoryReader methodsFor:'private'!
+
+class:aClass category:aCategory
+ "set the instance variables"
+
+ myClass := aClass.
+ myCategory := aCategory.
+ ignore := false
!
-fileInFrom:aStream
- "read method-chunks from the input stream, aStream; compile them
- and add the methods to the class defined by the class-instance var"
+class:aClass primitiveSpec:which
+ "set the instance variables"
+
+ myClass := aClass.
+ primSpec := which.
+ ignore := false
+! !
+
+!ClassCategoryReader methodsFor:'special'!
+
+ignoreMethods
+ ignore := true
+!
- self fileInFrom:aStream notifying:nil passChunk:false
+privateProtocol
+ privacy := #private
+!
+
+protectedProtocol
+ privacy := #protected
! !
+
+!ClassCategoryReader class methodsFor:'documentation'!
+
+version
+ ^ '$Header: /cvs/stx/stx/libbasic/Attic/CCReader.st,v 1.23 1995-12-07 21:31:11 cg Exp $'
+! !
+ClassCategoryReader initialize!
--- a/Character.st Thu Dec 07 22:24:46 1995 +0100
+++ b/Character.st Thu Dec 07 22:32:39 1995 +0100
@@ -11,10 +11,10 @@
"
Magnitude subclass:#Character
- instanceVariableNames:'asciivalue'
- classVariableNames:''
- poolDictionaries:''
- category:'Magnitude-General'
+ instanceVariableNames:'asciivalue'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Magnitude-General'
!
!Character class methodsFor:'documentation'!
@@ -33,10 +33,6 @@
"
!
-version
- ^' $Header: /cvs/stx/stx/libbasic/Character.st,v 1.26 1995-11-14 19:01:21 cg Exp $'
-!
-
documentation
"
Single byte Characters are unique; this means that for every asciiValue (0..255) there
@@ -72,6 +68,22 @@
^ self error:'Characters cannot be created with new'
!
+digitValue:anInteger
+ "return a character that corresponds to anInteger.
+ 0-9 map to $0-$9, 10-35 map to $A-$Z"
+
+ |val "{ Class: SmallInteger }" |
+
+ val := anInteger.
+ (val between:0 and:9) ifTrue:[
+ ^ Character value:(val + ($0 asciiValue))
+ ].
+ (val between:10 and:35) ifTrue:[
+ ^ Character value:(val + ($A asciiValue - 10))
+ ].
+ ^self error:'value not in range 0 to 35'
+!
+
value:anInteger
"return a character with asciivalue anInteger"
@@ -97,22 +109,105 @@
(i.e. only single-byte and twoByte characters are allowed.)
"
self error:'invalid ascii code for character'
+! !
+
+!Character class methodsFor:'constants'!
+
+backspace
+ "return the backspace character"
+
+ ^ Character value:8
+!
+
+bell
+ "return the bell character"
+
+ ^ Character value:7
+!
+
+cr
+ "return the lineEnd character
+ - actually (in unix) this is a newline character"
+
+ ^ Character value:10
+!
+
+del
+ "return the delete character"
+
+ ^ Character value:16r7F
+!
+
+doubleQuote
+ "return the double-quote character"
+
+ ^ Character value:34
+!
+
+esc
+ "return the escape character"
+
+ ^ Character value:27
+!
+
+excla
+ "return the exclamation-mark character"
+ ^ $!!
!
-digitValue:anInteger
- "return a character that corresponds to anInteger.
- 0-9 map to $0-$9, 10-35 map to $A-$Z"
+ff
+ "return the form-feed character"
+
+ ^ Character value:12
+!
+
+lf
+ "return the newline/linefeed character"
+
+ ^ Character value:10
+!
- |val "{ Class: SmallInteger }" |
+maxValue
+ "return the maximum asciiValue a character can have"
+
+ ^ 16rFFFF
+!
+
+newPage
+ "return the form-feed character"
+
+ ^ Character value:12
+!
+
+nl
+ "return the newline character"
- val := anInteger.
- (val between:0 and:9) ifTrue:[
- ^ Character value:(val + ($0 asciiValue))
- ].
- (val between:10 and:35) ifTrue:[
- ^ Character value:(val + ($A asciiValue - 10))
- ].
- ^self error:'value not in range 0 to 35'
+ ^ Character value:10
+!
+
+quote
+ "return the single-quote character"
+
+ ^ Character value:39
+!
+
+return
+ "return the return character.
+ In ST/X, this is different from cr - for Unix reasons."
+
+ ^ Character value:13
+!
+
+space
+ "return the blank character"
+
+ ^ Character value:32
+!
+
+tab
+ "return the tabulator character"
+
+ ^ Character value:9
! !
!Character class methodsFor:'primitive input'!
@@ -141,153 +236,6 @@
^ self == Character
! !
-!Character class methodsFor:'constants'!
-
-bell
- "return the bell character"
-
- ^ Character value:7
-!
-
-backspace
- "return the backspace character"
-
- ^ Character value:8
-!
-
-del
- "return the delete character"
-
- ^ Character value:16r7F
-!
-
-nl
- "return the newline character"
-
- ^ Character value:10
-!
-
-lf
- "return the newline/linefeed character"
-
- ^ Character value:10
-!
-
-cr
- "return the lineEnd character
- - actually (in unix) this is a newline character"
-
- ^ Character value:10
-!
-
-return
- "return the return character.
- In ST/X, this is different from cr - for Unix reasons."
-
- ^ Character value:13
-!
-
-tab
- "return the tabulator character"
-
- ^ Character value:9
-!
-
-newPage
- "return the form-feed character"
-
- ^ Character value:12
-!
-
-ff
- "return the form-feed character"
-
- ^ Character value:12
-!
-
-space
- "return the blank character"
-
- ^ Character value:32
-!
-
-esc
- "return the escape character"
-
- ^ Character value:27
-!
-
-quote
- "return the single-quote character"
-
- ^ Character value:39
-!
-
-doubleQuote
- "return the double-quote character"
-
- ^ Character value:34
-!
-
-excla
- "return the exclamation-mark character"
- ^ $!!
-!
-
-maxValue
- "return the maximum asciiValue a character can have"
-
- ^ 16rFFFF
-! !
-
-!Character methodsFor:'copying'!
-
-copy
- "return a copy of myself
- reimplemented since characters are unique"
-
- ^ self
-!
-
-shallowCopy
- "return a shallow copy of myself
- reimplemented since characters are unique"
-
- ^ self
-!
-
-deepCopy
- "return a deep copy of myself
- reimplemented since characters are unique"
-
- ^ self
-!
-
-simpleDeepCopy
- "return a deep copy of myself
- reimplemented since characters are unique"
-
- ^ self
-!
-
-deepCopyUsing:aDictionary
- "return a deep copy of myself
- reimplemented since characters are unique"
-
- ^ self
-! !
-
-!Character methodsFor:'private accessing'!
-
-setAsciiValue:anInteger
- "very private - set the ascii value.
- - use this only for characters with codes > 16rFF.
- DANGER alert: funny things happen, if this is applied to
- one of the fixed-characters 0..255."
-
- asciivalue := anInteger
-! !
-
!Character methodsFor:'accessing'!
asciiValue
@@ -304,68 +252,7 @@
self error:'Characters may not be modified'
! !
-!Character methodsFor:'comparing'!
-
-= aCharacter
- "return true, if the argument, aCharacter is the same character
- Redefined to take care of 16bit characters."
-
- self == aCharacter ifTrue:[^ true].
- aCharacter isCharacter ifFalse:[^ false].
- ^ (asciivalue = aCharacter asciiValue)
-!
-
-~= aCharacter
- "return true, if the argument, aCharacter is not the same character
- Redefined to take care of 16bit characters."
-
- self == aCharacter ifTrue:[^ false].
- aCharacter isCharacter ifFalse:[^ true].
- ^ (asciivalue ~~ aCharacter asciiValue)
-!
-
-sameAs:aCharacter
- "return true, if the argument, aCharacter is the same character,
- ignoring case differences."
-
- self == aCharacter ifTrue:[^ true].
- ^ self asLowercase = aCharacter asLowercase
-!
-
-> aCharacter
- "return true, if the arguments asciiValue is less than mine"
-
- ^ (asciivalue > aCharacter asciiValue)
-!
-
-< aCharacter
- "return true, if the arguments asciiValue is greater than mine"
-
- ^ (asciivalue < aCharacter asciiValue)
-!
-
-<= aCharacter
- "return true, if the arguments asciiValue is greater or equal to mine"
-
- ^ (asciivalue <= aCharacter asciiValue)
-!
-
->= aCharacter
- "return true, if the arguments asciiValue is less or equal to mine"
-
- ^ (asciivalue >= aCharacter asciiValue)
-!
-
-identityHash
- "return an integer useful for hashing on identity"
-
- asciivalue <= 255 ifTrue:[
- ^ 4096 + asciivalue
- ].
- ^ super identityHash
-! !
-
-!Character methodsFor: 'arithmetic'!
+!Character methodsFor:'arithmetic'!
+ aMagnitude
"Return the Character that is <aMagnitude> higher than the receiver.
@@ -405,8 +292,362 @@
^ Character value:(asciivalue \\ aMagnitude asInteger \\ 256)
! !
+!Character methodsFor:'binary storage'!
+
+hasSpecialBinaryRepresentation
+ "return true, if the receiver has a special binary representation"
+
+ ^ true
+!
+
+storeBinaryOn:stream manager:manager
+ "store a binary representation of the receiver on stream;
+ redefined, since single-byte characters are stored more compact
+ with a special type-code followed by the asciiValue."
+
+ (asciivalue < 256) ifTrue:[
+ stream nextPut:manager codeForCharacter.
+ stream nextPut:asciivalue
+ ] ifFalse:[
+ stream nextPut:manager codeForTwoByteCharacter.
+ stream nextPutShort:asciivalue MSB:true
+ ]
+! !
+
+!Character methodsFor:'comparing'!
+
+< aCharacter
+ "return true, if the arguments asciiValue is greater than mine"
+
+ ^ (asciivalue < aCharacter asciiValue)
+!
+
+<= aCharacter
+ "return true, if the arguments asciiValue is greater or equal to mine"
+
+ ^ (asciivalue <= aCharacter asciiValue)
+!
+
+= aCharacter
+ "return true, if the argument, aCharacter is the same character
+ Redefined to take care of 16bit characters."
+
+ self == aCharacter ifTrue:[^ true].
+ aCharacter isCharacter ifFalse:[^ false].
+ ^ (asciivalue = aCharacter asciiValue)
+!
+
+> aCharacter
+ "return true, if the arguments asciiValue is less than mine"
+
+ ^ (asciivalue > aCharacter asciiValue)
+!
+
+>= aCharacter
+ "return true, if the arguments asciiValue is less or equal to mine"
+
+ ^ (asciivalue >= aCharacter asciiValue)
+!
+
+identityHash
+ "return an integer useful for hashing on identity"
+
+ asciivalue <= 255 ifTrue:[
+ ^ 4096 + asciivalue
+ ].
+ ^ super identityHash
+!
+
+sameAs:aCharacter
+ "return true, if the argument, aCharacter is the same character,
+ ignoring case differences."
+
+ self == aCharacter ifTrue:[^ true].
+ ^ self asLowercase = aCharacter asLowercase
+!
+
+~= aCharacter
+ "return true, if the argument, aCharacter is not the same character
+ Redefined to take care of 16bit characters."
+
+ self == aCharacter ifTrue:[^ false].
+ aCharacter isCharacter ifFalse:[^ true].
+ ^ (asciivalue ~~ aCharacter asciiValue)
+! !
+
+!Character methodsFor:'converting'!
+
+asCharacter
+ "usually sent to integers, but redefined here to allow integers
+ and characters to be used commonly without a need for a test."
+
+ ^ self
+
+ "
+ 32 asCharacter
+ "
+!
+
+asInteger
+ "return an Integer with my ascii-value.
+ OWST4.2 compatibility (sigh)"
+
+ ^ asciivalue
+!
+
+asLowercase
+ "return a character with same letter as the receiver,
+ but lowercase (the receiver if its lowercase or nonLetter)"
+
+ self isUppercase ifFalse:[^ self].
+ ^ Character value:(asciivalue + 32)
+!
+
+asString
+ "return a string of len 1 with myself as contents"
+
+"/
+"/ |newString|
+"/
+"/ newString := String new:1.
+"/ newString at:1 put:self.
+"/ ^ newString
+"/
+
+%{ /* NOCONTEXT */
+ char buffer[2];
+ OBJ s;
+ OBJ __MKSTRING_L();
+
+ buffer[0] = (char) _intVal(_characterVal(self));
+ buffer[1] = '\0';
+ s = __MKSTRING_L(buffer, 1 COMMA_SND);
+ if (s != nil) {
+ RETURN (s);
+ }
+%}.
+ "
+ memory allocation (for the new string) failed.
+ When we arrive here, there was no memory, even after a garbage collect.
+ This means, that the VM wanted to get some more memory from the
+ OS, which was not kind enough to give it.
+ Bad luck - you should increase the swap space on your machine.
+ "
+ ^ ObjectMemory allocationFailureSignal raise.
+!
+
+asSymbol
+ "return a unique symbol which prints like I print"
+
+ ^ Symbol internCharacter:self
+!
+
+asUppercase
+ "return a character with same letter as the receiver,
+ but uppercase (the receiver if its uppercase or nonLetter)"
+
+ self isLowercase ifFalse:[^ self].
+ ^ Character value:(asciivalue - 32)
+!
+
+digitValue
+ "return my digitValue for any base"
+
+ |ascii "{ Class: SmallInteger }" |
+
+ ascii := asciivalue.
+ (ascii between:($0 asciiValue) and:($9 asciiValue)) ifTrue:[
+ ^ ascii - $0 asciiValue
+ ].
+ (ascii between:($a asciiValue) and:($z asciiValue)) ifTrue:[
+ ^ ascii + (10 - $a asciiValue)
+ ].
+ (ascii between:($A asciiValue) and:($Z asciiValue)) ifTrue:[
+ ^ ascii + (10 - $A asciiValue)
+ ].
+
+"remove error below for X3J20 conformance ... "
+ self error:'bad character'.
+" "
+ ^ -1
+!
+
+to:aMagnitude
+ "Return an Interval over the characters from the receiver to <aMagnitude>.
+ Wrap <aMagnitude> if it is not a legal Character value. (JS)"
+
+ ^ Interval from:self to:(aMagnitude \\ 256)
+! !
+
+!Character methodsFor:'copying'!
+
+copy
+ "return a copy of myself
+ reimplemented since characters are unique"
+
+ ^ self
+!
+
+deepCopy
+ "return a deep copy of myself
+ reimplemented since characters are unique"
+
+ ^ self
+!
+
+deepCopyUsing:aDictionary
+ "return a deep copy of myself
+ reimplemented since characters are unique"
+
+ ^ self
+!
+
+shallowCopy
+ "return a shallow copy of myself
+ reimplemented since characters are unique"
+
+ ^ self
+!
+
+simpleDeepCopy
+ "return a deep copy of myself
+ reimplemented since characters are unique"
+
+ ^ self
+! !
+
+!Character methodsFor:'enumerating'!
+
+to:stopCharacter do:aBlock
+ "evaluate aBlock for each character in self .. stopCharacter.
+ This is somewhat stupid, since it depends on the ascii encoding
+ (370-users watch out :-)"
+
+ |runChar|
+
+ runChar := self.
+ [runChar <= stopCharacter] whileTrue:[
+ aBlock value:runChar.
+ runChar := runChar + 1
+ ]
+
+ "
+ ($a to:$z) do:[:char | char printNL]
+ $a to:$z do:[:char | char printNL].
+ "
+! !
+
+!Character methodsFor:'national testing'!
+
+isNationalAlphaNumeric
+ "return true, if the receiver is a letter in the
+ current language (Language variable)"
+
+ "stupid - should be configurable from a table ...
+ ... good thing is, that iso8859 puts all national
+ characters above 16rC0"
+
+ self isLetterOrDigit ifTrue:[^ true].
+ ^ self asciiValue between:16rC0 and:16rFF
+!
+
+isNationalLetter
+ "return true, if the receiver is a letter in the
+ current language (Language variable)"
+
+ "stupid - should be configurable from a table ...
+ ... good thing is, that iso8859 puts all national
+ characters above 16rC0"
+
+ self isLetter ifTrue:[^ true].
+ ^ self asciiValue between:16rC0 and:16rFF
+! !
+
+!Character methodsFor:'printing & storing'!
+
+displayString
+ "return a string used when the receiver is to be displayed
+ in an inspector kind-of-thing"
+
+ ^ self storeString
+!
+
+isLiteral
+ "return true, if the receiver can be used as a literal
+ (i.e. can be used in constant arrays)"
+
+ ^ true
+!
+
+print
+ "print myself on stdout"
+
+%{ /* NOCONTEXT */
+
+ putchar(_intVal(_INST(asciivalue)));
+%}
+!
+
+printOn:aStream
+ "print myself on aStream"
+
+ aStream nextPut:self
+!
+
+printString
+ "return a string to print me"
+
+ ^ self asString
+!
+
+storeOn:aStream
+ "store myself on aStream"
+
+ |special|
+
+ (asciivalue between:33 and:127) ifFalse:[
+ (self == Character space) ifTrue:[
+ special := '(Character space)'
+ ] ifFalse:[
+ (self == Character cr) ifTrue:[
+ special := '(Character cr)'.
+ ] ifFalse:[
+ (self == Character tab) ifTrue:[
+ special := '(Character tab)'.
+ ]
+ ]
+ ].
+ special notNil ifTrue:[
+ aStream nextPutAll:special.
+ ^ self
+ ].
+ aStream nextPutAll:'(Character value:';
+ nextPutAll:(asciivalue printString); nextPutAll:')'
+ ] ifTrue:[
+ aStream nextPut:$$; nextPut:self
+ ]
+! !
+
+!Character methodsFor:'private accessing'!
+
+setAsciiValue:anInteger
+ "very private - set the ascii value.
+ - use this only for characters with codes > 16rFF.
+ DANGER alert: funny things happen, if this is applied to
+ one of the fixed-characters 0..255."
+
+ asciivalue := anInteger
+! !
+
!Character methodsFor:'testing'!
+isAlphaNumeric
+ "return true, if I am a letter or a digit
+ - same as isAlphaNumeric for compatibility reasons."
+
+ ^ self isLetterOrDigit
+!
+
isCharacter
"return true, if the receiver is some kind of character"
@@ -436,40 +677,22 @@
^ false
!
-isLowercase
- "return true, if I am a lower-case letter"
+isEndOfLineCharacter
+ "return true if I am a line delimitting character"
%{ /* NOCONTEXT */
REGISTER int val;
val = _intVal(_INST(asciivalue));
-#ifndef OLD
- /* iso8859 puts national lower case characters at e0 .. ff */
- if ((val >= 0xE0) && (val <= 0xFF)) {
- RETURN(true);
+ if ((val == '\n')
+ || (val == '\r')
+ || (val == '\f')) {
+ RETURN ( true );
}
-#endif
- RETURN ( ((val >= 'a') && (val <= 'z')) ? true : false );
%}
-!
-
-isUppercase
- "return true, if I am an upper-case letter"
-
-%{ /* NOCONTEXT */
-
- REGISTER int val;
-
- val = _intVal(_INST(asciivalue));
-#ifndef OLD
- /* iso8859 puts national upper case characters at c0 .. df */
- if ((val >= 0xC0) && (val <= 0xDF)) {
- RETURN(true);
- }
-#endif
- RETURN ( ((val >= 'A') && (val <= 'Z')) ? true : false );
-%}
+.
+ ^ false
!
isLetter
@@ -508,27 +731,33 @@
%}
!
-isAlphaNumeric
- "return true, if I am a letter or a digit
- - same as isAlphaNumeric for compatibility reasons."
+isLowercase
+ "return true, if I am a lower-case letter"
+
+%{ /* NOCONTEXT */
+
+ REGISTER int val;
- ^ self isLetterOrDigit
+ val = _intVal(_INST(asciivalue));
+#ifndef OLD
+ /* iso8859 puts national lower case characters at e0 .. ff */
+ if ((val >= 0xE0) && (val <= 0xFF)) {
+ RETURN(true);
+ }
+#endif
+ RETURN ( ((val >= 'a') && (val <= 'z')) ? true : false );
+%}
!
-isVowel
- "return true, if I am a vowel (lower- or uppercase)"
+isPrintable
+ "return true, if the receiver is a useful printable character
+ (see fileBrowsers showFile:-method on how it can be used)"
- (self == $a) ifTrue:[^ true].
- (self == $e) ifTrue:[^ true].
- (self == $i) ifTrue:[^ true].
- (self == $o) ifTrue:[^ true].
- (self == $u) ifTrue:[^ true].
- (self == $A) ifTrue:[^ true].
- (self == $E) ifTrue:[^ true].
- (self == $I) ifTrue:[^ true].
- (self == $O) ifTrue:[^ true].
- (self == $U) ifTrue:[^ true].
- ^ false
+ (asciivalue between:32 and:127) ifTrue:[^ true].
+ asciivalue == 13 ifTrue:[^ true].
+ asciivalue == 9 ifTrue:[^ true].
+ asciivalue == 10 ifTrue:[^ true].
+ ^ self isNationalLetter
!
isSeparator
@@ -554,269 +783,42 @@
^ false
!
-isEndOfLineCharacter
- "return true if I am a line delimitting character"
+isUppercase
+ "return true, if I am an upper-case letter"
%{ /* NOCONTEXT */
REGISTER int val;
val = _intVal(_INST(asciivalue));
- if ((val == '\n')
- || (val == '\r')
- || (val == '\f')) {
- RETURN ( true );
- }
-%}
-.
- ^ false
-!
-
-isPrintable
- "return true, if the receiver is a useful printable character
- (see fileBrowsers showFile:-method on how it can be used)"
-
- (asciivalue between:32 and:127) ifTrue:[^ true].
- asciivalue == 13 ifTrue:[^ true].
- asciivalue == 9 ifTrue:[^ true].
- asciivalue == 10 ifTrue:[^ true].
- ^ self isNationalLetter
-! !
-
-!Character methodsFor:'national testing'!
-
-isNationalLetter
- "return true, if the receiver is a letter in the
- current language (Language variable)"
-
- "stupid - should be configurable from a table ...
- ... good thing is, that iso8859 puts all national
- characters above 16rC0"
-
- self isLetter ifTrue:[^ true].
- ^ self asciiValue between:16rC0 and:16rFF
-!
-
-isNationalAlphaNumeric
- "return true, if the receiver is a letter in the
- current language (Language variable)"
-
- "stupid - should be configurable from a table ...
- ... good thing is, that iso8859 puts all national
- characters above 16rC0"
-
- self isLetterOrDigit ifTrue:[^ true].
- ^ self asciiValue between:16rC0 and:16rFF
-! !
-
-!Character methodsFor:'converting'!
-
-asLowercase
- "return a character with same letter as the receiver,
- but lowercase (the receiver if its lowercase or nonLetter)"
-
- self isUppercase ifFalse:[^ self].
- ^ Character value:(asciivalue + 32)
-!
-
-asUppercase
- "return a character with same letter as the receiver,
- but uppercase (the receiver if its uppercase or nonLetter)"
-
- self isLowercase ifFalse:[^ self].
- ^ Character value:(asciivalue - 32)
-!
-
-asCharacter
- "usually sent to integers, but redefined here to allow integers
- and characters to be used commonly without a need for a test."
-
- ^ self
-
- "
- 32 asCharacter
- "
-!
-
-asInteger
- "return an Integer with my ascii-value.
- OWST4.2 compatibility (sigh)"
-
- ^ asciivalue
-!
-
-asSymbol
- "return a unique symbol which prints like I print"
-
- ^ Symbol internCharacter:self
-!
-
-asString
- "return a string of len 1 with myself as contents"
-
-"/
-"/ |newString|
-"/
-"/ newString := String new:1.
-"/ newString at:1 put:self.
-"/ ^ newString
-"/
-
-%{ /* NOCONTEXT */
- char buffer[2];
- OBJ s;
- OBJ __MKSTRING_L();
-
- buffer[0] = (char) _intVal(_characterVal(self));
- buffer[1] = '\0';
- s = __MKSTRING_L(buffer, 1 COMMA_SND);
- if (s != nil) {
- RETURN (s);
+#ifndef OLD
+ /* iso8859 puts national upper case characters at c0 .. df */
+ if ((val >= 0xC0) && (val <= 0xDF)) {
+ RETURN(true);
}
-%}.
- "
- memory allocation (for the new string) failed.
- When we arrive here, there was no memory, even after a garbage collect.
- This means, that the VM wanted to get some more memory from the
- OS, which was not kind enough to give it.
- Bad luck - you should increase the swap space on your machine.
- "
- ^ ObjectMemory allocationFailureSignal raise.
-!
-
-digitValue
- "return my digitValue for any base"
-
- |ascii "{ Class: SmallInteger }" |
-
- ascii := asciivalue.
- (ascii between:($0 asciiValue) and:($9 asciiValue)) ifTrue:[
- ^ ascii - $0 asciiValue
- ].
- (ascii between:($a asciiValue) and:($z asciiValue)) ifTrue:[
- ^ ascii + (10 - $a asciiValue)
- ].
- (ascii between:($A asciiValue) and:($Z asciiValue)) ifTrue:[
- ^ ascii + (10 - $A asciiValue)
- ].
-
-"remove error below for X3J20 conformance ... "
- self error:'bad character'.
-" "
- ^ -1
-!
-
-to:aMagnitude
- "Return an Interval over the characters from the receiver to <aMagnitude>.
- Wrap <aMagnitude> if it is not a legal Character value. (JS)"
-
- ^ Interval from:self to:(aMagnitude \\ 256)
-! !
-
-!Character methodsFor:'enumerating'!
-
-to:stopCharacter do:aBlock
- "evaluate aBlock for each character in self .. stopCharacter.
- This is somewhat stupid, since it depends on the ascii encoding
- (370-users watch out :-)"
-
- |runChar|
-
- runChar := self.
- [runChar <= stopCharacter] whileTrue:[
- aBlock value:runChar.
- runChar := runChar + 1
- ]
-
- "
- ($a to:$z) do:[:char | char printNL]
- $a to:$z do:[:char | char printNL].
- "
-! !
-
-!Character methodsFor:'binary storage'!
-
-hasSpecialBinaryRepresentation
- "return true, if the receiver has a special binary representation"
-
- ^ true
-!
-
-storeBinaryOn:stream manager:manager
- "store a binary representation of the receiver on stream;
- redefined, since single-byte characters are stored more compact
- with a special type-code followed by the asciiValue."
-
- (asciivalue < 256) ifTrue:[
- stream nextPut:manager codeForCharacter.
- stream nextPut:asciivalue
- ] ifFalse:[
- stream nextPut:manager codeForTwoByteCharacter.
- stream nextPutShort:asciivalue MSB:true
- ]
-! !
-
-!Character methodsFor:'printing & storing'!
-
-isLiteral
- "return true, if the receiver can be used as a literal
- (i.e. can be used in constant arrays)"
-
- ^ true
-!
-
-printString
- "return a string to print me"
-
- ^ self asString
-!
-
-printOn:aStream
- "print myself on aStream"
-
- aStream nextPut:self
-!
-
-print
- "print myself on stdout"
-
-%{ /* NOCONTEXT */
-
- putchar(_intVal(_INST(asciivalue)));
+#endif
+ RETURN ( ((val >= 'A') && (val <= 'Z')) ? true : false );
%}
!
-displayString
- "return a string used when the receiver is to be displayed
- in an inspector kind-of-thing"
-
- ^ self storeString
-!
-
-storeOn:aStream
- "store myself on aStream"
-
- |special|
+isVowel
+ "return true, if I am a vowel (lower- or uppercase)"
- (asciivalue between:33 and:127) ifFalse:[
- (self == Character space) ifTrue:[
- special := '(Character space)'
- ] ifFalse:[
- (self == Character cr) ifTrue:[
- special := '(Character cr)'.
- ] ifFalse:[
- (self == Character tab) ifTrue:[
- special := '(Character tab)'.
- ]
- ]
- ].
- special notNil ifTrue:[
- aStream nextPutAll:special.
- ^ self
- ].
- aStream nextPutAll:'(Character value:';
- nextPutAll:(asciivalue printString); nextPutAll:')'
- ] ifTrue:[
- aStream nextPut:$$; nextPut:self
- ]
+ (self == $a) ifTrue:[^ true].
+ (self == $e) ifTrue:[^ true].
+ (self == $i) ifTrue:[^ true].
+ (self == $o) ifTrue:[^ true].
+ (self == $u) ifTrue:[^ true].
+ (self == $A) ifTrue:[^ true].
+ (self == $E) ifTrue:[^ true].
+ (self == $I) ifTrue:[^ true].
+ (self == $O) ifTrue:[^ true].
+ (self == $U) ifTrue:[^ true].
+ ^ false
! !
+
+!Character class methodsFor:'documentation'!
+
+version
+ ^' $Header: /cvs/stx/stx/libbasic/Character.st,v 1.27 1995-12-07 21:31:57 cg Exp $'
+! !
--- a/ClassCategoryReader.st Thu Dec 07 22:24:46 1995 +0100
+++ b/ClassCategoryReader.st Thu Dec 07 22:32:39 1995 +0100
@@ -11,10 +11,10 @@
"
Object subclass:#ClassCategoryReader
- instanceVariableNames:'myClass myCategory privacy ignore primSpec'
- classVariableNames:'KeepSource'
- poolDictionaries:''
- category:'Kernel-Support'
+ instanceVariableNames:'myClass myCategory privacy ignore primSpec'
+ classVariableNames:'KeepSource'
+ poolDictionaries:''
+ category:'Kernel-Support'
!
!ClassCategoryReader class methodsFor:'documentation'!
@@ -33,10 +33,6 @@
"
!
-version
- ^ '$Header: /cvs/stx/stx/libbasic/ClassCategoryReader.st,v 1.22 1995-11-11 14:27:31 cg Exp $'
-!
-
documentation
"
a helper class for fileIn - keeps track of class and category to filein for.
@@ -51,20 +47,6 @@
KeepSource := true
! !
-!ClassCategoryReader class methodsFor:'defaults'!
-
-keepSource:aBoolean
- KeepSource := aBoolean
-
- "Created: 9.9.1995 / 15:22:26 / claus"
-!
-
-keepSource
- ^ KeepSource
-
- "Created: 9.9.1995 / 15:22:27 / claus"
-! !
-
!ClassCategoryReader class methodsFor:'instance creation'!
class:aClass category:aCategory
@@ -86,40 +68,29 @@
^ self new ignoreMethods
! !
-!ClassCategoryReader methodsFor:'private'!
+!ClassCategoryReader class methodsFor:'defaults'!
-class:aClass category:aCategory
- "set the instance variables"
+keepSource
+ ^ KeepSource
- myClass := aClass.
- myCategory := aCategory.
- ignore := false
+ "Created: 9.9.1995 / 15:22:27 / claus"
!
-class:aClass primitiveSpec:which
- "set the instance variables"
-
- myClass := aClass.
- primSpec := which.
- ignore := false
-! !
-
-!ClassCategoryReader methodsFor:'special'!
+keepSource:aBoolean
+ KeepSource := aBoolean
-privateProtocol
- privacy := #private
-!
-
-protectedProtocol
- privacy := #protected
-!
-
-ignoreMethods
- ignore := true
+ "Created: 9.9.1995 / 15:22:26 / claus"
! !
!ClassCategoryReader methodsFor:'fileIn'!
+fileInFrom:aStream
+ "read method-chunks from the input stream, aStream; compile them
+ and add the methods to the class defined by the class-instance var"
+
+ self fileInFrom:aStream notifying:nil passChunk:false
+!
+
fileInFrom:aStream notifying:requestor passChunk:passChunk
"read method-chunks from the input stream, aStream; compile them
and add the methods to the class defined by the class-instance var;
@@ -216,11 +187,43 @@
]
"Modified: 9.9.1995 / 15:29:08 / claus"
+! !
+
+!ClassCategoryReader methodsFor:'private'!
+
+class:aClass category:aCategory
+ "set the instance variables"
+
+ myClass := aClass.
+ myCategory := aCategory.
+ ignore := false
!
-fileInFrom:aStream
- "read method-chunks from the input stream, aStream; compile them
- and add the methods to the class defined by the class-instance var"
+class:aClass primitiveSpec:which
+ "set the instance variables"
+
+ myClass := aClass.
+ primSpec := which.
+ ignore := false
+! !
+
+!ClassCategoryReader methodsFor:'special'!
+
+ignoreMethods
+ ignore := true
+!
- self fileInFrom:aStream notifying:nil passChunk:false
+privateProtocol
+ privacy := #private
+!
+
+protectedProtocol
+ privacy := #protected
! !
+
+!ClassCategoryReader class methodsFor:'documentation'!
+
+version
+ ^ '$Header: /cvs/stx/stx/libbasic/ClassCategoryReader.st,v 1.23 1995-12-07 21:31:11 cg Exp $'
+! !
+ClassCategoryReader initialize!
--- a/Date.st Thu Dec 07 22:24:46 1995 +0100
+++ b/Date.st Thu Dec 07 22:32:39 1995 +0100
@@ -11,11 +11,10 @@
"
Magnitude subclass:#Date
- instanceVariableNames:'dateEncoding'
- classVariableNames:'DayNames MonthNames DayAbbrevs MonthAbbrevs
- EnvironmentChange'
- poolDictionaries:''
- category:'Magnitude-General'
+ instanceVariableNames:'dateEncoding'
+ classVariableNames:'DayNames MonthNames DayAbbrevs MonthAbbrevs EnvironmentChange'
+ poolDictionaries:''
+ category:'Magnitude-General'
!
!Date class methodsFor:'documentation'!
@@ -34,10 +33,6 @@
"
!
-version
- ^ '$Header: /cvs/stx/stx/libbasic/Date.st,v 1.28 1995-11-16 23:27:56 cg Exp $'
-!
-
documentation
"
Instances of Date represent dates as year, month and day encoded in the
@@ -71,8 +66,522 @@
"
! !
+!Date class methodsFor:'instance creation'!
+
+day:day month:month year:year
+ "return a new Date, given the day, month and year.
+ Obsolete:
+ use newDay:month:year: for ST-80 compatibility"
+
+ ^ self newDay:day month:month year:year
+!
+
+day:dayInYear year:year
+ "return a new Date, given the year and the day-in-year (starting at 1).
+ Obsolete:
+ use newDay:year: for ST-80 compatibility"
+
+ ^ self newDay:dayInYear year:year
+!
+
+fromDays:dayCount
+ "return a new Date, given the day-number starting with 0 at 1.Jan 1901;
+ (i.e. 'Date fromDays:0' returns 1st Jan. 1901).
+ Date asDays is the reverse operation.
+ for GNU/ST-80 compatibility"
+
+ |yr rest d|
+
+ "approx. year"
+ yr := (dayCount // 366) + 1901.
+ rest := dayCount - (self yearAsDays:yr) + 1. "+1 for ST-80 compatibility"
+ d := self daysInYear:yr.
+ (rest > d) ifTrue:[
+ "adjust"
+ yr := yr + 1.
+ rest := rest - d.
+ ].
+
+ ^ self day:rest year:yr
+
+ "
+ Date fromDays:0 -> 1 jan 1901
+ Date fromDays:365 -> 1 jan 1902
+ Date fromDays:730 -> 1 jan 1903
+ Date fromDays:1095 -> 1 jan 1903
+ Date fromDays:1460 ->31 dec 1904 since 1904 was a leap year
+ "
+!
+
+fromOSTime:osTime
+ "return a date, representing the date given by the operatingSystem time.
+ This somewhat clumsy implementation hides the OS's date representation
+ (i.e. makes this class independent of what the OS starts its time values with).
+ Dont use this method, the osTime representation is totally unportable."
+
+ ^ self basicNew fromOSTime:osTime
+
+ "
+ Date fromOSTime:#(0 0) -> on UNIX: this should return 1st Jan 1970
+ thats where Unix time starts
+ On other systems, it may be something different.
+
+ Date fromOSTime:#(86400 0) -> on UNIX: the day after
+ "
+!
+
+newDay:day month:month year:year
+ "return a new Date, given the day, month and year.
+ For your convenience, month may be either an integer
+ or the months name as a string.
+ Year may be the actual year (such as 1890, 2001) or the number
+ of years since 1900 (which is rubbish ST-80 compatibility:
+ it will be totally useless in a few years ...).
+ You better not use this short-year feature in your programs."
+
+ |monthIndex ok yr|
+
+ yr := year.
+ yr < 100 ifTrue:[
+ yr := yr + 1900.
+ ].
+
+ month isInteger ifTrue:[
+ monthIndex := month
+ ] ifFalse:[
+ monthIndex := self indexOfMonth:month
+ ].
+ (monthIndex == 2 and:[day == 29]) ifTrue:[
+ ok := self leapYear:yr
+ ] ifFalse:[
+ ok := day <= (self daysInMonth:month forYear:yr)
+ ].
+ ((day > 0) and:[ok]) ifTrue:[
+ ^ self basicNew dateEncoding:(((yr * 100) + monthIndex) * 100) + day
+ ].
+
+ "this error is triggered if you try to create a date from an
+ invalid year/month/day combination;
+ Such as 29-feb-year, where year is no leap year
+ "
+ self error:'invalid date'
+
+ "
+ Date newDay:8 month:'may' year:1993
+ Date newDay:8 month:5 year:1994
+ Date newDay:29 month:'feb' year:1994
+ Date newDay:29 month:'feb' year:1993
+ Date newDay:28 month:'feb' year:5
+ Date newDay:28 month:'feb' year:95
+ "
+!
+
+newDay:dayInYear year:year
+ "return a new Date, given the year and the day-in-year (starting at 1).
+ ST-80 compatibility"
+
+ |monthAndDay|
+
+ (dayInYear between:1 and:365) ifFalse:[
+ ((dayInYear == 366) and:[self leapYear:year]) ifFalse:[
+ "
+ this error is triggered, when you try to create a
+ day from an invalid day-in-year;
+ for example, 366 in a non-leap year.
+ I dont know, if ST-80 wraps to the next year(s) in this case.
+ "
+ ^ self error:'invalid date'
+ ]
+ ].
+ monthAndDay := self monthAndDayFromDayInYear:dayInYear forYear:year.
+ ^ self day:(monthAndDay at:2) month:(monthAndDay at:1) year:year
+
+ "
+ Date newDay:150 year:1994
+ Date newDay:1 year:1994
+ Date newDay:1 year:1901
+ Date newDay:1 year:1902
+ Date newDay:365 year:1992
+ Date newDay:366 year:1992
+ Date newDay:365 year:1994
+ Date newDay:366 year:1994
+ "
+!
+
+readFrom:aStringOrStream onError:exceptionBlock
+ "return a new Date, reading a printed representation from aStream.
+ Notice, that this is not the storeString format and
+ is different from the format expected by readFrom:.
+ BUG:
+ This method assumes american format (i.e. month-day-year) instead
+ of the german/french and other day-month-year.
+ There ought to be a nationalized variant of this."
+
+ |str month day year|
+
+ Object errorSignal handle:[:ex |
+ ^ exceptionBlock value
+ ] do:[
+ str := aStringOrStream readStream.
+
+ [str peek isLetterOrDigit] whileFalse:[str next].
+ (str peek isDigit) ifTrue:[
+ day := Integer readFrom:str onError:[^ exceptionBlock value]
+ ].
+ [str peek isLetterOrDigit] whileFalse:[str next].
+ (str peek isLetter) ifTrue:[
+ month := str nextAlphaNumericWord.
+ day isNil ifTrue:[
+ [str peek isLetterOrDigit] whileFalse:[str next].
+ day := Integer readFrom:str onError:[^ exceptionBlock value].
+ ]
+ ] ifFalse:[
+ month := self nameOfMonth:day.
+ day := Integer readFrom:str onError:[^ exceptionBlock value]
+ ].
+ [str peek isLetterOrDigit] whileFalse:[str next].
+ year := Integer readFrom:str onError:[^ exceptionBlock value].
+ ^ self newDay:day month:month year:year
+ ].
+
+ "
+ Date readFromString:'31 December 1992'
+ Date readFromString:'December, 5, 1992'
+ Date readFromString:'December, 5 1992'
+ Date readFromString:'3-jan-95'
+ Date readFromString:'12/31/1992'
+ Date readFromString:'15.4.1992' -> german; leads to an error
+ Date readFromString:'10.4.1992' -> german; leads to a wrong date
+ Date readFromString:'10.4.1992' onError:['wrong date']
+ "
+
+ "Created: 16.11.1995 / 22:50:17 / cg"
+!
+
+today
+ "return a date, representing today"
+
+ ^ self fromOSTime:OperatingSystem getTimeParts
+
+ "
+ Date today
+ "
+! !
+
+!Date class methodsFor:'general queries'!
+
+abbreviatedNameOfDay:dayIndex
+ "given a day index (1..7), return the abbreviated name
+ of the day"
+
+ EnvironmentChange ifTrue:[
+ self initNames
+ ].
+ ^ DayAbbrevs at:dayIndex
+
+ "
+ Date abbreviatedNameOfDay:4
+ "
+!
+
+abbreviatedNameOfMonth:monthIndex
+ "given a month index (1..12), return the abbreviated name
+ of the month"
+
+ EnvironmentChange ifTrue:[
+ self initNames
+ ].
+ ^ MonthAbbrevs at:monthIndex
+
+ "
+ Date abbreviatedNameOfMonth:11
+ Date abbreviatedNameOfMonth:12
+ "
+!
+
+dateAndTimeNow
+ "return an array containing the date and time of now"
+
+ ^ Time dateAndTimeNow
+
+ "
+ Date dateAndTimeNow
+ "
+!
+
+dayOfWeek:dayName
+ "given the name of a day (either string or symbol),
+ return the day-index (1 for monday; 7 for sunday).
+ Return 0 for invalid day name"
+
+ EnvironmentChange ifTrue:[
+ self initNames
+ ].
+ ^ DayNames indexOf:dayName
+
+ "
+ Date dayOfWeek:'wednesday'
+ "
+!
+
+daysInMonth:month forYear:yearInteger
+ "given the name of a month and a year, return the number
+ of days this month has (modified GNU).
+ return 0 if the month name was invalid.
+ For your convenience, month maybe an integer or name-string."
+
+ |monthIndex "{ Class: SmallInteger }"|
+
+ month isInteger ifTrue:[
+ monthIndex := month
+ ] ifFalse:[
+ monthIndex := self indexOfMonth:month
+ ].
+
+ ^ self daysInMonthIndex:monthIndex forYear:yearInteger
+
+ "
+ Date daysInMonth:2 forYear:1980
+ Date daysInMonth:2 forYear:1981
+ Date daysInMonth:'feb' forYear:1981
+ "
+!
+
+daysInYear:yearInteger
+ "return the number of days in a year"
+
+ (self leapYear:yearInteger) ifTrue:[^ 366].
+ ^ 365
+
+ "
+ Date daysInYear:1900
+ Date daysInYear:1901
+ Date daysInYear:1904
+ Date daysInYear:1980
+ Date daysInYear:1981
+ "
+!
+
+daysUntilMonth:month forYear:yearInteger
+ "given the name of a month and a year, return the number
+ of days from 1st january to last of prev month of that year.
+ Return 0 if the month name/index is invalid or is january.
+ For your convenience, month maybe an integer or name-string."
+
+ |monthIndex "{ Class: SmallInteger }"
+ sumDays "{ Class: SmallInteger }" |
+
+ month isInteger ifTrue:[
+ monthIndex := month
+ ] ifFalse:[
+ monthIndex := self indexOfMonth:month
+ ].
+ (monthIndex between:1 and:12) ifFalse:[^ 0].
+
+ sumDays := 0.
+ 1 to:monthIndex-1 do:[:m |
+ sumDays := sumDays + (self daysInMonthIndex:m forYear:yearInteger)
+ ].
+ ^ sumDays
+
+ "
+ Date daysUntilMonth:'feb' forYear:1993
+ Date daysUntilMonth:'jan' forYear:1993
+ "
+!
+
+indexOfMonth:aMonthString
+ "given the name of a month (either string or symbol),
+ return the month-index (1 for jan; 12 for december).
+ The given string may be a full or abbreviated name,
+ case is ignored.
+ Return 0 for invalid month name."
+
+ |idx name|
+
+ EnvironmentChange ifTrue:[
+ self initNames
+ ].
+ name := aMonthString asLowercase.
+ idx := MonthAbbrevs indexOf:name.
+ idx ~~ 0 ifTrue:[^ idx].
+ idx := MonthNames indexOf:name.
+ idx ~~ 0 ifTrue:[^ idx].
+
+ name at:1 put:(name at:1) asUppercase.
+ idx := MonthAbbrevs indexOf:name.
+ idx ~~ 0 ifTrue:[^ idx].
+ idx := MonthNames indexOf:name.
+ idx ~~ 0 ifTrue:[^ idx].
+
+ ^ idx
+
+ "
+ Date indexOfMonth:'jan'
+ Date indexOfMonth:'Jan'
+ Date indexOfMonth:'December'
+ "
+!
+
+isLeapYear:yearInteger
+ "Return true, if a year is a leap year.
+ Obsolete:
+ Please use the ST-80 compatible #leapYear for new programs,
+ since this method will vanish."
+
+ ^ self leapYear:yearInteger
+!
+
+leapYear:yearInteger
+ "return true, if yearInteger is a leap year."
+
+ |y "{ Class: SmallInteger }"|
+
+ y := yearInteger.
+ (y \\ 4 == 0) ifTrue:[
+ (y \\ 100 ~~ 0) ifTrue:[^ true].
+ (y \\ 400 == 0) ifTrue:[^ true]
+ ].
+ ^ false
+
+ "
+ Date leapYear:1992
+ Date leapYear:1994
+ Date leapYear:1900
+ Date leapYear:2000
+ "
+!
+
+monthAndDayFromDayInYear:aDayInYear forYear:yearInteger
+ "given a day-in-year (1..365) return an Array containing the
+ month index and the day-in-month. Return nil if the argument is invalid."
+
+ |restDays daysInMonth|
+
+ restDays := aDayInYear.
+ restDays < 1 ifTrue:[^ nil].
+
+ 1 to:12 do:[:m |
+ daysInMonth := self daysInMonthIndex:m forYear:yearInteger.
+ restDays <= daysInMonth ifTrue:[
+ ^ Array with:m with:restDays
+ ].
+ restDays := restDays - daysInMonth
+ ].
+ restDays > daysInMonth ifTrue:[^ nil].
+ ^ Array with:12 with:restDays
+
+ "
+ Date monthAndDayFromDayInYear:66 forYear:1980
+ Date monthAndDayFromDayInYear:66 forYear:1981
+ "
+!
+
+nameOfDay:dayIndex
+ "given a day index (1..7), return the name of the day"
+
+ EnvironmentChange ifTrue:[
+ self initNames
+ ].
+ ^ DayNames at:dayIndex
+
+ "
+ Date nameOfDay:4
+ "
+!
+
+nameOfMonth:monthIndex
+ "given a month index (1..12), return the name of the month"
+
+ EnvironmentChange ifTrue:[
+ self initNames
+ ].
+ ^ MonthNames at:monthIndex
+
+ "
+ Date nameOfMonth:11
+ Date nameOfMonth:12
+ Date nameOfMonth:4
+ "
+!
+
+yearAsDays: yearInteger
+ "Returns the number of days since Jan 1, 1901. (GNU)
+ to the first Jan of the year, yearInteger.
+ For 1901 this is zero, for 1902 its 365.
+ Defined for years >= 1901"
+
+ |y "{ Class: SmallInteger }"|
+
+ y := yearInteger - 1900.
+ y := y - 1.
+ ^ (y * 365)
+ + (y // 4)
+ - (y // 100)
+ + ((y + 300) // 400)
+
+ "
+ Date yearAsDays:1901
+ Date yearAsDays:1902
+ Date yearAsDays:1903
+ Date yearAsDays:1904
+ Date yearAsDays:1905
+ Date yearAsDays:1994
+ (Date yearAsDays:2001) - (Date yearAsDays:2000)
+ "
+! !
+
+!Date class methodsFor:'handling language changes'!
+
+initialize
+ "check for case where Resource-classes are absent"
+ ResourcePack isNil ifTrue:[
+ self initNames
+ ] ifFalse:[
+ Smalltalk addDependent:self.
+ EnvironmentChange := true
+ ]
+!
+
+update:something
+ ((something == #Language) or:[something == #LanguageTerritory]) ifTrue:[
+ "just remember change for next access"
+ EnvironmentChange := true
+ ]
+! !
+
!Date class methodsFor:'private'!
+daysInMonthIndex: monthIndex forYear: yearInteger
+ "return the number of days in month monthIndex of
+ year yearInteger (modified GNU).
+ Return 0 for invalid month index.
+ This is the internal version of daysInMonth:forYear:"
+
+ |days|
+
+ (monthIndex between:1 and:12) ifFalse:[^ 0].
+
+ days := #(31 28 31 "Jan Feb Mar"
+ 30 31 30 "Apr May Jun"
+ 31 31 30 "Jul Aug Sep"
+ 31 30 31 "Oct Nov Dec"
+ ) at: monthIndex.
+
+ (monthIndex == 2) ifTrue:[
+ (self leapYear:yearInteger) ifTrue:[
+ ^ days + 1
+ ]
+ ].
+ ^ days
+
+ "
+ Date daysInMonthIndex:2 forYear:1994
+ Date daysInMonthIndex:2 forYear:1980
+ Date daysInMonthIndex:2 forYear:1981
+ "
+!
+
initNames
"read the language specific names"
@@ -133,520 +642,6 @@
EnvironmentChange := false
"Date initNames"
-!
-
-daysInMonthIndex: monthIndex forYear: yearInteger
- "return the number of days in month monthIndex of
- year yearInteger (modified GNU).
- Return 0 for invalid month index.
- This is the internal version of daysInMonth:forYear:"
-
- |days|
-
- (monthIndex between:1 and:12) ifFalse:[^ 0].
-
- days := #(31 28 31 "Jan Feb Mar"
- 30 31 30 "Apr May Jun"
- 31 31 30 "Jul Aug Sep"
- 31 30 31 "Oct Nov Dec"
- ) at: monthIndex.
-
- (monthIndex == 2) ifTrue:[
- (self leapYear:yearInteger) ifTrue:[
- ^ days + 1
- ]
- ].
- ^ days
-
- "
- Date daysInMonthIndex:2 forYear:1994
- Date daysInMonthIndex:2 forYear:1980
- Date daysInMonthIndex:2 forYear:1981
- "
-! !
-
-!Date class methodsFor:'handling language changes'!
-
-initialize
- "check for case where Resource-classes are absent"
- ResourcePack isNil ifTrue:[
- self initNames
- ] ifFalse:[
- Smalltalk addDependent:self.
- EnvironmentChange := true
- ]
-!
-
-update:something
- ((something == #Language) or:[something == #LanguageTerritory]) ifTrue:[
- "just remember change for next access"
- EnvironmentChange := true
- ]
-! !
-
-!Date class methodsFor:'general queries'!
-
-dateAndTimeNow
- "return an array containing the date and time of now"
-
- ^ Time dateAndTimeNow
-
- "
- Date dateAndTimeNow
- "
-!
-
-dayOfWeek:dayName
- "given the name of a day (either string or symbol),
- return the day-index (1 for monday; 7 for sunday).
- Return 0 for invalid day name"
-
- EnvironmentChange ifTrue:[
- self initNames
- ].
- ^ DayNames indexOf:dayName
-
- "
- Date dayOfWeek:'wednesday'
- "
-!
-
-nameOfDay:dayIndex
- "given a day index (1..7), return the name of the day"
-
- EnvironmentChange ifTrue:[
- self initNames
- ].
- ^ DayNames at:dayIndex
-
- "
- Date nameOfDay:4
- "
-!
-
-abbreviatedNameOfDay:dayIndex
- "given a day index (1..7), return the abbreviated name
- of the day"
-
- EnvironmentChange ifTrue:[
- self initNames
- ].
- ^ DayAbbrevs at:dayIndex
-
- "
- Date abbreviatedNameOfDay:4
- "
-!
-
-indexOfMonth:aMonthString
- "given the name of a month (either string or symbol),
- return the month-index (1 for jan; 12 for december).
- The given string may be a full or abbreviated name,
- case is ignored.
- Return 0 for invalid month name."
-
- |idx name|
-
- EnvironmentChange ifTrue:[
- self initNames
- ].
- name := aMonthString asLowercase.
- idx := MonthAbbrevs indexOf:name.
- idx ~~ 0 ifTrue:[^ idx].
- idx := MonthNames indexOf:name.
- idx ~~ 0 ifTrue:[^ idx].
-
- name at:1 put:(name at:1) asUppercase.
- idx := MonthAbbrevs indexOf:name.
- idx ~~ 0 ifTrue:[^ idx].
- idx := MonthNames indexOf:name.
- idx ~~ 0 ifTrue:[^ idx].
-
- ^ idx
-
- "
- Date indexOfMonth:'jan'
- Date indexOfMonth:'Jan'
- Date indexOfMonth:'December'
- "
-!
-
-nameOfMonth:monthIndex
- "given a month index (1..12), return the name of the month"
-
- EnvironmentChange ifTrue:[
- self initNames
- ].
- ^ MonthNames at:monthIndex
-
- "
- Date nameOfMonth:11
- Date nameOfMonth:12
- Date nameOfMonth:4
- "
-!
-
-abbreviatedNameOfMonth:monthIndex
- "given a month index (1..12), return the abbreviated name
- of the month"
-
- EnvironmentChange ifTrue:[
- self initNames
- ].
- ^ MonthAbbrevs at:monthIndex
-
- "
- Date abbreviatedNameOfMonth:11
- Date abbreviatedNameOfMonth:12
- "
-!
-
-daysInMonth:month forYear:yearInteger
- "given the name of a month and a year, return the number
- of days this month has (modified GNU).
- return 0 if the month name was invalid.
- For your convenience, month maybe an integer or name-string."
-
- |monthIndex "{ Class: SmallInteger }"|
-
- month isInteger ifTrue:[
- monthIndex := month
- ] ifFalse:[
- monthIndex := self indexOfMonth:month
- ].
-
- ^ self daysInMonthIndex:monthIndex forYear:yearInteger
-
- "
- Date daysInMonth:2 forYear:1980
- Date daysInMonth:2 forYear:1981
- Date daysInMonth:'feb' forYear:1981
- "
-!
-
-daysUntilMonth:month forYear:yearInteger
- "given the name of a month and a year, return the number
- of days from 1st january to last of prev month of that year.
- Return 0 if the month name/index is invalid or is january.
- For your convenience, month maybe an integer or name-string."
-
- |monthIndex "{ Class: SmallInteger }"
- sumDays "{ Class: SmallInteger }" |
-
- month isInteger ifTrue:[
- monthIndex := month
- ] ifFalse:[
- monthIndex := self indexOfMonth:month
- ].
- (monthIndex between:1 and:12) ifFalse:[^ 0].
-
- sumDays := 0.
- 1 to:monthIndex-1 do:[:m |
- sumDays := sumDays + (self daysInMonthIndex:m forYear:yearInteger)
- ].
- ^ sumDays
-
- "
- Date daysUntilMonth:'feb' forYear:1993
- Date daysUntilMonth:'jan' forYear:1993
- "
-!
-
-monthAndDayFromDayInYear:aDayInYear forYear:yearInteger
- "given a day-in-year (1..365) return an Array containing the
- month index and the day-in-month. Return nil if the argument is invalid."
-
- |restDays daysInMonth|
-
- restDays := aDayInYear.
- restDays < 1 ifTrue:[^ nil].
-
- 1 to:12 do:[:m |
- daysInMonth := self daysInMonthIndex:m forYear:yearInteger.
- restDays <= daysInMonth ifTrue:[
- ^ Array with:m with:restDays
- ].
- restDays := restDays - daysInMonth
- ].
- restDays > daysInMonth ifTrue:[^ nil].
- ^ Array with:12 with:restDays
-
- "
- Date monthAndDayFromDayInYear:66 forYear:1980
- Date monthAndDayFromDayInYear:66 forYear:1981
- "
-!
-
-daysInYear:yearInteger
- "return the number of days in a year"
-
- (self leapYear:yearInteger) ifTrue:[^ 366].
- ^ 365
-
- "
- Date daysInYear:1900
- Date daysInYear:1901
- Date daysInYear:1904
- Date daysInYear:1980
- Date daysInYear:1981
- "
-!
-
-yearAsDays: yearInteger
- "Returns the number of days since Jan 1, 1901. (GNU)
- to the first Jan of the year, yearInteger.
- For 1901 this is zero, for 1902 its 365.
- Defined for years >= 1901"
-
- |y "{ Class: SmallInteger }"|
-
- y := yearInteger - 1900.
- y := y - 1.
- ^ (y * 365)
- + (y // 4)
- - (y // 100)
- + ((y + 300) // 400)
-
- "
- Date yearAsDays:1901
- Date yearAsDays:1902
- Date yearAsDays:1903
- Date yearAsDays:1904
- Date yearAsDays:1905
- Date yearAsDays:1994
- (Date yearAsDays:2001) - (Date yearAsDays:2000)
- "
-!
-
-leapYear:yearInteger
- "return true, if yearInteger is a leap year."
-
- |y "{ Class: SmallInteger }"|
-
- y := yearInteger.
- (y \\ 4 == 0) ifTrue:[
- (y \\ 100 ~~ 0) ifTrue:[^ true].
- (y \\ 400 == 0) ifTrue:[^ true]
- ].
- ^ false
-
- "
- Date leapYear:1992
- Date leapYear:1994
- Date leapYear:1900
- Date leapYear:2000
- "
-!
-
-isLeapYear:yearInteger
- "Return true, if a year is a leap year.
- Obsolete:
- Please use the ST-80 compatible #leapYear for new programs,
- since this method will vanish."
-
- ^ self leapYear:yearInteger
-! !
-
-!Date class methodsFor:'instance creation'!
-
-fromOSTime:osTime
- "return a date, representing the date given by the operatingSystem time.
- This somewhat clumsy implementation hides the OS's date representation
- (i.e. makes this class independent of what the OS starts its time values with).
- Dont use this method, the osTime representation is totally unportable."
-
- ^ self basicNew fromOSTime:osTime
-
- "
- Date fromOSTime:#(0 0) -> on UNIX: this should return 1st Jan 1970
- thats where Unix time starts
- On other systems, it may be something different.
-
- Date fromOSTime:#(86400 0) -> on UNIX: the day after
- "
-!
-
-today
- "return a date, representing today"
-
- ^ self fromOSTime:OperatingSystem getTimeParts
-
- "
- Date today
- "
-!
-
-fromDays:dayCount
- "return a new Date, given the day-number starting with 0 at 1.Jan 1901;
- (i.e. 'Date fromDays:0' returns 1st Jan. 1901).
- Date asDays is the reverse operation.
- for GNU/ST-80 compatibility"
-
- |yr rest d|
-
- "approx. year"
- yr := (dayCount // 366) + 1901.
- rest := dayCount - (self yearAsDays:yr) + 1. "+1 for ST-80 compatibility"
- d := self daysInYear:yr.
- (rest > d) ifTrue:[
- "adjust"
- yr := yr + 1.
- rest := rest - d.
- ].
-
- ^ self day:rest year:yr
-
- "
- Date fromDays:0 -> 1 jan 1901
- Date fromDays:365 -> 1 jan 1902
- Date fromDays:730 -> 1 jan 1903
- Date fromDays:1095 -> 1 jan 1903
- Date fromDays:1460 ->31 dec 1904 since 1904 was a leap year
- "
-!
-
-day:dayInYear year:year
- "return a new Date, given the year and the day-in-year (starting at 1).
- Obsolete:
- use newDay:year: for ST-80 compatibility"
-
- ^ self newDay:dayInYear year:year
-!
-
-newDay:dayInYear year:year
- "return a new Date, given the year and the day-in-year (starting at 1).
- ST-80 compatibility"
-
- |monthAndDay|
-
- (dayInYear between:1 and:365) ifFalse:[
- ((dayInYear == 366) and:[self leapYear:year]) ifFalse:[
- "
- this error is triggered, when you try to create a
- day from an invalid day-in-year;
- for example, 366 in a non-leap year.
- I dont know, if ST-80 wraps to the next year(s) in this case.
- "
- ^ self error:'invalid date'
- ]
- ].
- monthAndDay := self monthAndDayFromDayInYear:dayInYear forYear:year.
- ^ self day:(monthAndDay at:2) month:(monthAndDay at:1) year:year
-
- "
- Date newDay:150 year:1994
- Date newDay:1 year:1994
- Date newDay:1 year:1901
- Date newDay:1 year:1902
- Date newDay:365 year:1992
- Date newDay:366 year:1992
- Date newDay:365 year:1994
- Date newDay:366 year:1994
- "
-!
-
-day:day month:month year:year
- "return a new Date, given the day, month and year.
- Obsolete:
- use newDay:month:year: for ST-80 compatibility"
-
- ^ self newDay:day month:month year:year
-!
-
-newDay:day month:month year:year
- "return a new Date, given the day, month and year.
- For your convenience, month may be either an integer
- or the months name as a string.
- Year may be the actual year (such as 1890, 2001) or the number
- of years since 1900 (which is rubbish ST-80 compatibility:
- it will be totally useless in a few years ...).
- You better not use this short-year feature in your programs."
-
- |monthIndex ok yr|
-
- yr := year.
- yr < 100 ifTrue:[
- yr := yr + 1900.
- ].
-
- month isInteger ifTrue:[
- monthIndex := month
- ] ifFalse:[
- monthIndex := self indexOfMonth:month
- ].
- (monthIndex == 2 and:[day == 29]) ifTrue:[
- ok := self leapYear:yr
- ] ifFalse:[
- ok := day <= (self daysInMonth:month forYear:yr)
- ].
- ((day > 0) and:[ok]) ifTrue:[
- ^ self basicNew dateEncoding:(((yr * 100) + monthIndex) * 100) + day
- ].
-
- "this error is triggered if you try to create a date from an
- invalid year/month/day combination;
- Such as 29-feb-year, where year is no leap year
- "
- self error:'invalid date'
-
- "
- Date newDay:8 month:'may' year:1993
- Date newDay:8 month:5 year:1994
- Date newDay:29 month:'feb' year:1994
- Date newDay:29 month:'feb' year:1993
- Date newDay:28 month:'feb' year:5
- Date newDay:28 month:'feb' year:95
- "
-!
-
-readFrom:aStringOrStream onError:exceptionBlock
- "return a new Date, reading a printed representation from aStream.
- Notice, that this is not the storeString format and
- is different from the format expected by readFrom:.
- BUG:
- This method assumes american format (i.e. month-day-year) instead
- of the german/french and other day-month-year.
- There ought to be a nationalized variant of this."
-
- |str month day year|
-
- Object errorSignal handle:[:ex |
- ^ exceptionBlock value
- ] do:[
- str := aStringOrStream readStream.
-
- [str peek isLetterOrDigit] whileFalse:[str next].
- (str peek isDigit) ifTrue:[
- day := Integer readFrom:str onError:[^ exceptionBlock value]
- ].
- [str peek isLetterOrDigit] whileFalse:[str next].
- (str peek isLetter) ifTrue:[
- month := str nextAlphaNumericWord.
- day isNil ifTrue:[
- [str peek isLetterOrDigit] whileFalse:[str next].
- day := Integer readFrom:str onError:[^ exceptionBlock value].
- ]
- ] ifFalse:[
- month := self nameOfMonth:day.
- day := Integer readFrom:str onError:[^ exceptionBlock value]
- ].
- [str peek isLetterOrDigit] whileFalse:[str next].
- year := Integer readFrom:str onError:[^ exceptionBlock value].
- ^ self newDay:day month:month year:year
- ].
-
- "
- Date readFromString:'31 December 1992'
- Date readFromString:'December, 5, 1992'
- Date readFromString:'December, 5 1992'
- Date readFromString:'3-jan-95'
- Date readFromString:'12/31/1992'
- Date readFromString:'15.4.1992' -> german; leads to an error
- Date readFromString:'10.4.1992' -> german; leads to a wrong date
- Date readFromString:'10.4.1992' onError:['wrong date']
- "
-
- "Created: 16.11.1995 / 22:50:17 / cg"
! !
!Date class methodsFor:'private encoding'!
@@ -658,168 +653,31 @@
^ (((y * 100) + m) * 100) + d
! !
-!Date methodsFor:'private accessing'!
-
-dateEncoding
- "the internal encoding is stricktly private,
- and should not be used outside."
-
- ^ dateEncoding
-!
-
-dateEncoding:anInteger
- "the internal encoding is stricktly private,
- and should not be used outside."
-
- dateEncoding := anInteger
-!
-
-fromOSTime:osTime
- "set my dateEncoding from an OS time.
- This somewhat clumsy implementation hides the OS's date representation
- (i.e. makes this class independent of what the OS starts its time values with).
- Dont use this method, the osTime representation is totally unportable."
+!Date methodsFor:'accessing'!
- OperatingSystem computeDatePartsOf:osTime
- for:[:year :month :day |
- dateEncoding := (((year * 100) + month) * 100) + day
- ]
-! !
-
-!Date methodsFor:'arithmetic'!
+abbreviatedDayName
+ "return the short week-day of the receiver as a string.
+ The returned string depends on the language setting.
+ Expect things like 'mon', 'tue' ..."
-plusDays:days
- "return a new date representing 'days' after the receiver.
- The argument should be some kind of integer.
- Obsolete:
- Please dont use this method since it will vanish.
- Use #addDays: instead for ST-80 compatibility."
-
- ^ self addDays:days
-!
-
-addDays:days
- "return a new date representing 'days' after the receiver.
- The argument should be some kind of integer.
- For ST-80 compatibility."
-
- ^ self class fromDays:(self asDays + days)
+ ^ self class abbreviatedNameOfDay:(self dayInWeek)
"
- Date today addDays:7
- "
-!
-
-minusDays:days
- "return a new date representing 'days' before the receiver.
- The argument should be some kind of integer.
- Obsolete:
- Please dont use this method since it will vanish.
- Use #subtractDays: instead for ST-80 compatibility."
-
- ^ self subtractDays:days
-!
-
-subtractDays:days
- "return a new date representing 'days' before the receiver.
- The argument should be some kind of integer.
- For ST-80 compatibility"
-
- ^ self class fromDays:(self asDays - days)
-
- "
- Date today subtractDays:7
+ Date today abbreviatedDayName
+ (Date day:15 month:4 year:1959) abbreviatedDayName
"
!
-subtractDate:aDate
- "return the number of days between the receiver and aDate"
-
- ^ self asDays - aDate asDays
-
- "
- (Date day:1 month:1 year:1995) subtractDate:(Date day:24 month:12 year:1994)
- (Date day:1 month:3 year:1992) subtractDate:(Date day:1 month:2 year:1992)
- (Date day:1 month:3 year:1994) subtractDate:(Date day:1 month:2 year:1994)
- "
-!
-
-daysUntil:aDate
- "return the number of days between the receiver and the argument,
- aDate, whuch should be some kind of date"
-
- ^ aDate asDays - self asDays
+abbreviatedMonthName
+ "return the month of the receiver as a string.
+ The returned string depends on the language setting.
+ Expect things like 'jan', 'feb' ..."
- "
- (Date day:24 month:12 year:1994) daysUntil:(Date day:1 month:1 year:1995)
- (Date day:1 month:2 year:1992) daysUntil:(Date day:1 month:3 year:1992)
- (Date day:1 month:2 year:1994) daysUntil:(Date day:1 month:3 year:1994)
-
- |delta|
- delta := Date today
- daysUntil:(Date day:25 month:12 year:Date today year).
- Transcript show:'still ';
- show:delta ;
- showCr:' days till xmas'
- "
-! !
-
-!Date methodsFor:'accessing'!
-
-day
- "return the day (1..31) of the receiver"
-
- ^ dateEncoding \\ 100
+ ^ self class abbreviatedNameOfMonth:(self month)
"
- Date today day
- "
-!
-
-month
- "return the month (1..12) of the receiver"
-
- ^ (dateEncoding // 100) \\ 100
-
- "
- Date today month
- "
-!
-
-year
- "return the year (1..12) of the receiver"
-
- ^ dateEncoding // (100*100)
-
- "
- Date today year
- "
-!
-
-leap
- "return true, if the receivers year is a leap year"
-
- ^ Date leapYear:(self year)
-
- "
- Date today leap
- (Date day:1 month:1 year:1992) leap
- "
-!
-
-dayCount
- "return the number of days since 1st. Jan. 1901;
- starting with 0 for this date.
- Date>>fromDays: is the reverse operation.
- Obsolete:
- please use asDays for ST-80 compatibility"
-
- ^ self asDays.
-
- "
- (Date day:1 month:1 year:1901) dayCount
- Date fromDays:(Date day:1 month:1 year:1994) dayCount
- Date today dayCount
+ Date today abbreviatedMonthName
+ (Date day:15 month:4 year:1959) abbreviatedMonthName
"
!
@@ -857,7 +715,55 @@
(Date day: 1 month: 1 year: 1901) asSeconds
(Date today addDays:7) asSeconds - Date today asSeconds
"
-!
+!
+
+day
+ "return the day (1..31) of the receiver"
+
+ ^ dateEncoding \\ 100
+
+ "
+ Date today day
+ "
+!
+
+dayCount
+ "return the number of days since 1st. Jan. 1901;
+ starting with 0 for this date.
+ Date>>fromDays: is the reverse operation.
+ Obsolete:
+ please use asDays for ST-80 compatibility"
+
+ ^ self asDays.
+
+ "
+ (Date day:1 month:1 year:1901) dayCount
+ Date fromDays:(Date day:1 month:1 year:1994) dayCount
+ Date today dayCount
+ "
+!
+
+dayInWeek
+ "return the week-day of the receiver - 1 for monday, 7 for sunday"
+
+ ^ (1 "know, that 1st Jan 1901 was a tuesday"
+ + self asDays) \\ 7 + 1
+
+ "
+ Date today dayInWeek
+ (Date day:15 month:4 year:1959) dayInWeek
+ "
+!
+
+dayName
+ "return the week-day of the receiver as a string.
+ The returned string depends on the language setting.
+ Expect things like 'monday', 'tuesday' ...
+ Obsolete:
+ use #weekday for ST-80 compatibility"
+
+ ^ self weekday
+!
dayOfMonth
"Answer the day of the month represented by me.
@@ -900,52 +806,24 @@
"
!
-dayInWeek
- "return the week-day of the receiver - 1 for monday, 7 for sunday"
+leap
+ "return true, if the receivers year is a leap year"
- ^ (1 "know, that 1st Jan 1901 was a tuesday"
- + self asDays) \\ 7 + 1
+ ^ Date leapYear:(self year)
"
- Date today dayInWeek
- (Date day:15 month:4 year:1959) dayInWeek
+ Date today leap
+ (Date day:1 month:1 year:1992) leap
"
!
-dayName
- "return the week-day of the receiver as a string.
- The returned string depends on the language setting.
- Expect things like 'monday', 'tuesday' ...
- Obsolete:
- use #weekday for ST-80 compatibility"
+month
+ "return the month (1..12) of the receiver"
- ^ self weekday
-!
-
-weekday
- "return the week-day of the receiver as a string.
- The returned string depends on the language setting.
- Expect things like 'monday', 'tuesday' ...
- For ST-80 compatibility"
-
- ^ self class nameOfDay:(self dayInWeek)
+ ^ (dateEncoding // 100) \\ 100
"
- Date today weekday
- (Date day:15 month:4 year:1959) weekday
- "
-!
-
-abbreviatedDayName
- "return the short week-day of the receiver as a string.
- The returned string depends on the language setting.
- Expect things like 'mon', 'tue' ..."
-
- ^ self class abbreviatedNameOfDay:(self dayInWeek)
-
- "
- Date today abbreviatedDayName
- (Date day:15 month:4 year:1959) abbreviatedDayName
+ Date today month
"
!
@@ -969,16 +847,105 @@
"
!
-abbreviatedMonthName
- "return the month of the receiver as a string.
+weekday
+ "return the week-day of the receiver as a string.
The returned string depends on the language setting.
- Expect things like 'jan', 'feb' ..."
+ Expect things like 'monday', 'tuesday' ...
+ For ST-80 compatibility"
+
+ ^ self class nameOfDay:(self dayInWeek)
+
+ "
+ Date today weekday
+ (Date day:15 month:4 year:1959) weekday
+ "
+!
+
+year
+ "return the year (1..12) of the receiver"
+
+ ^ dateEncoding // (100*100)
- ^ self class abbreviatedNameOfMonth:(self month)
+ "
+ Date today year
+ "
+! !
+
+!Date methodsFor:'arithmetic'!
+
+addDays:days
+ "return a new date representing 'days' after the receiver.
+ The argument should be some kind of integer.
+ For ST-80 compatibility."
+
+ ^ self class fromDays:(self asDays + days)
+
+ "
+ Date today addDays:7
+ "
+!
+
+daysUntil:aDate
+ "return the number of days between the receiver and the argument,
+ aDate, whuch should be some kind of date"
+
+ ^ aDate asDays - self asDays
"
- Date today abbreviatedMonthName
- (Date day:15 month:4 year:1959) abbreviatedMonthName
+ (Date day:24 month:12 year:1994) daysUntil:(Date day:1 month:1 year:1995)
+ (Date day:1 month:2 year:1992) daysUntil:(Date day:1 month:3 year:1992)
+ (Date day:1 month:2 year:1994) daysUntil:(Date day:1 month:3 year:1994)
+
+ |delta|
+ delta := Date today
+ daysUntil:(Date day:25 month:12 year:Date today year).
+ Transcript show:'still ';
+ show:delta ;
+ showCr:' days till xmas'
+ "
+!
+
+minusDays:days
+ "return a new date representing 'days' before the receiver.
+ The argument should be some kind of integer.
+ Obsolete:
+ Please dont use this method since it will vanish.
+ Use #subtractDays: instead for ST-80 compatibility."
+
+ ^ self subtractDays:days
+!
+
+plusDays:days
+ "return a new date representing 'days' after the receiver.
+ The argument should be some kind of integer.
+ Obsolete:
+ Please dont use this method since it will vanish.
+ Use #addDays: instead for ST-80 compatibility."
+
+ ^ self addDays:days
+!
+
+subtractDate:aDate
+ "return the number of days between the receiver and aDate"
+
+ ^ self asDays - aDate asDays
+
+ "
+ (Date day:1 month:1 year:1995) subtractDate:(Date day:24 month:12 year:1994)
+ (Date day:1 month:3 year:1992) subtractDate:(Date day:1 month:2 year:1992)
+ (Date day:1 month:3 year:1994) subtractDate:(Date day:1 month:2 year:1994)
+ "
+!
+
+subtractDays:days
+ "return a new date representing 'days' before the receiver.
+ The argument should be some kind of integer.
+ For ST-80 compatibility"
+
+ ^ self class fromDays:(self asDays - days)
+
+ "
+ Date today subtractDays:7
"
! !
@@ -1003,25 +970,6 @@
"Date today < (Date day:24 month:12 year:1900)"
!
-> aDate
- "return true, if the date represented by the receiver
- is after the argument, aDate"
-
- (aDate isMemberOf:Date) ifTrue:[
- ^ dateEncoding > aDate dateEncoding
- ].
-
- "the argument must understand year, month and day to be
- comparable, whatever it is"
-
- ^ dateEncoding > (Date encodeYear:aDate year
- month:aDate month
- day:aDate day)
-
- "Date today > (Date day:24 month:12 year:2000)"
- "Date today > (Date day:24 month:12 year:1900)"
-!
-
= aDate
"return true, if the date represented by the receiver
is the same as the one represented by argument, aDate"
@@ -1041,6 +989,25 @@
"Date today = ((Date today plusDays:7) minusDays:7)"
!
+> aDate
+ "return true, if the date represented by the receiver
+ is after the argument, aDate"
+
+ (aDate isMemberOf:Date) ifTrue:[
+ ^ dateEncoding > aDate dateEncoding
+ ].
+
+ "the argument must understand year, month and day to be
+ comparable, whatever it is"
+
+ ^ dateEncoding > (Date encodeYear:aDate year
+ month:aDate month
+ day:aDate day)
+
+ "Date today > (Date day:24 month:12 year:2000)"
+ "Date today > (Date day:24 month:12 year:1900)"
+!
+
hash
"return an integer useful for hashing on dates"
@@ -1049,37 +1016,6 @@
!Date methodsFor:'printing & storing'!
-storeOn:aStream
- "append a representation to aStream, from which the receiver
- can be reconstructed"
-
- aStream nextPutAll:'('; nextPutAll:'Date day:'.
- self day printOn:aStream.
- aStream nextPutAll:' month:'.
- self month printOn:aStream.
- aStream nextPutAll:' year:'.
- self year printOn:aStream.
- aStream nextPutAll:')'
-
- "
- Date today storeOn:Transcript
- Date today storeString
- "
-!
-
-printOn:aStream
- "append a printed representation of the receiver to aStream"
-
- self printFormat:#(1 2 3 $- 2 1) on:aStream
-
- "
- Date today printOn:Transcript
- Date today printNL
- "
-
- "Modified: 27.8.1995 / 01:01:49 / claus"
-!
-
printFormat:aFormatArray
"return a string containing a printed representation of the receiver.
The formatArray argument consists of 6 or 7 integers which control
@@ -1199,4 +1135,70 @@
Date today printFormat:#(1 2 3 $- 2 1) on:Transcript. Transcript cr.
Date today printFormat:#(1 2 3 $- 4 1) on:Transcript. Transcript cr.
"
+!
+
+printOn:aStream
+ "append a printed representation of the receiver to aStream"
+
+ self printFormat:#(1 2 3 $- 2 1) on:aStream
+
+ "
+ Date today printOn:Transcript
+ Date today printNL
+ "
+
+ "Modified: 27.8.1995 / 01:01:49 / claus"
+!
+
+storeOn:aStream
+ "append a representation to aStream, from which the receiver
+ can be reconstructed"
+
+ aStream nextPutAll:'('; nextPutAll:'Date day:'.
+ self day printOn:aStream.
+ aStream nextPutAll:' month:'.
+ self month printOn:aStream.
+ aStream nextPutAll:' year:'.
+ self year printOn:aStream.
+ aStream nextPutAll:')'
+
+ "
+ Date today storeOn:Transcript
+ Date today storeString
+ "
! !
+
+!Date methodsFor:'private accessing'!
+
+dateEncoding
+ "the internal encoding is stricktly private,
+ and should not be used outside."
+
+ ^ dateEncoding
+!
+
+dateEncoding:anInteger
+ "the internal encoding is stricktly private,
+ and should not be used outside."
+
+ dateEncoding := anInteger
+!
+
+fromOSTime:osTime
+ "set my dateEncoding from an OS time.
+ This somewhat clumsy implementation hides the OS's date representation
+ (i.e. makes this class independent of what the OS starts its time values with).
+ Dont use this method, the osTime representation is totally unportable."
+
+ OperatingSystem computeDatePartsOf:osTime
+ for:[:year :month :day |
+ dateEncoding := (((year * 100) + month) * 100) + day
+ ]
+! !
+
+!Date class methodsFor:'documentation'!
+
+version
+ ^ '$Header: /cvs/stx/stx/libbasic/Date.st,v 1.29 1995-12-07 21:32:16 cg Exp $'
+! !
+Date initialize!
--- a/Magnitude.st Thu Dec 07 22:24:46 1995 +0100
+++ b/Magnitude.st Thu Dec 07 22:32:39 1995 +0100
@@ -11,10 +11,10 @@
"
Object subclass:#Magnitude
- instanceVariableNames:''
- classVariableNames:''
- poolDictionaries:''
- category:'Magnitude-General'
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Magnitude-General'
!
!Magnitude class methodsFor:'documentation'!
@@ -33,10 +33,6 @@
"
!
-version
- ^ '$Header: /cvs/stx/stx/libbasic/Magnitude.st,v 1.11 1995-11-11 15:23:55 cg Exp $'
-!
-
documentation
"
This is an abstract class definining common methods for
@@ -46,11 +42,18 @@
!Magnitude methodsFor:'comparing'!
-> aMagnitude
+< aMagnitude
"Compare the receiver with the argument and return true if the
- receiver is greater than the argument. Otherwise return false."
+ receiver is less than the argument. Otherwise return false."
+
+ ^ (aMagnitude > self)
+!
- ^ self subclassResponsibility
+<= aMagnitude
+ "Compare the receiver with the argument and return true if the
+ receiver is less than or equal to the argument. Otherwise return false."
+
+ ^ (self > aMagnitude) not
!
= aMagnitude
@@ -60,18 +63,11 @@
^ self subclassResponsibility
!
-<= aMagnitude
+> aMagnitude
"Compare the receiver with the argument and return true if the
- receiver is less than or equal to the argument. Otherwise return false."
+ receiver is greater than the argument. Otherwise return false."
- ^ (self > aMagnitude) not
-!
-
-< aMagnitude
- "Compare the receiver with the argument and return true if the
- receiver is less than the argument. Otherwise return false."
-
- ^ (aMagnitude > self)
+ ^ self subclassResponsibility
!
>= aMagnitude
@@ -82,6 +78,20 @@
^ (aMagnitude > self) not
!
+max:aMagnitude
+ "return the receiver or the argument, whichever has greater magnitude"
+
+ (self > aMagnitude) ifTrue:[^ self].
+ ^ aMagnitude
+
+ "
+ 1 max: 2
+ 1 max: 2.0
+ 2.0 max: 1.0
+ 2.0 max: 2
+ "
+!
+
min:aMagnitude
"return the receiver or the argument, whichever has lesser magnitude"
@@ -94,20 +104,6 @@
2.0 min: 1.0
2.0 min: 2
"
-!
-
-max:aMagnitude
- "return the receiver or the argument, whichever has greater magnitude"
-
- (self > aMagnitude) ifTrue:[^ self].
- ^ aMagnitude
-
- "
- 1 max: 2
- 1 max: 2.0
- 2.0 max: 1.0
- 2.0 max: 2
- "
! !
!Magnitude methodsFor:'testing'!
@@ -140,3 +136,9 @@
(3/2) in:(0 to: 1)
"
! !
+
+!Magnitude class methodsFor:'documentation'!
+
+version
+ ^ '$Header: /cvs/stx/stx/libbasic/Magnitude.st,v 1.12 1995-12-07 21:32:39 cg Exp $'
+! !
--- a/ProcSched.st Thu Dec 07 22:24:46 1995 +0100
+++ b/ProcSched.st Thu Dec 07 22:32:39 1995 +0100
@@ -11,28 +11,18 @@
"
Object subclass:#ProcessorScheduler
- instanceVariableNames:'quiescentProcessLists scheduler
- zombie
- activeProcess currentPriority
- readFdArray readSemaphoreArray readCheckArray
- writeFdArray writeSemaphoreArray
- timeoutArray timeoutActionArray timeoutProcessArray timeoutSemaphoreArray
- idleActions anyTimeouts dispatching interruptedProcess
- useIOInterrupts'
- classVariableNames:'KnownProcesses KnownProcessIds
- PureEventDriven
- UserSchedulingPriority
- UserInterruptPriority
- TimingPriority
- HighestPriority
- SchedulingPriority
- MaxNumberOfProcesses'
+ instanceVariableNames:'quiescentProcessLists scheduler zombie activeProcess
+ currentPriority readFdArray readSemaphoreArray readCheckArray
+ writeFdArray writeSemaphoreArray timeoutArray timeoutActionArray
+ timeoutProcessArray timeoutSemaphoreArray idleActions anyTimeouts
+ dispatching interruptedProcess useIOInterrupts'
+ classVariableNames:'KnownProcesses KnownProcessIds PureEventDriven
+ UserSchedulingPriority UserInterruptPriority TimingPriority
+ HighestPriority SchedulingPriority MaxNumberOfProcesses'
poolDictionaries:''
category:'Kernel-Processes'
!
-Smalltalk at:#Processor put:nil!
-
!ProcessorScheduler class methodsFor:'documentation'!
copyright
@@ -49,10 +39,6 @@
"
!
-version
- ^ '$Header: /cvs/stx/stx/libbasic/Attic/ProcSched.st,v 1.52 1995-11-24 19:19:45 cg Exp $'
-!
-
documentation
"
This class has only one instance, which is bound to the global
@@ -192,85 +178,8 @@
]
! !
-!ProcessorScheduler class methodsFor:'queries'!
-
-isPureEventDriven
- "this is temporary - (maybe not :-).
- you can run ST/X either with or without processes.
- Without, there is conceptionally a single process handling all
- outside events and timeouts. This has some negative implications
- (Debugger is ugly), but allows a fully portable ST/X without any
- assembler support - i.e. quick portability.
- The PureEvent flag will automatically be set if the runtime system
- does not support threads - otherwise, it can be set manually
- (from rc-file).
- "
-
- ^ PureEventDriven
-!
-
-pureEventDriven
- "turn on pure-event driven mode - no processes, single dispatch loop"
-
- PureEventDriven := true
-!
-
-processDriven
- "turn on process driven mode"
-
- PureEventDriven := false
-!
-
-knownProcesses
- "return a collection of all (living) processes in the system"
-
- ^ KnownProcesses select:[:p | p notNil]
-!
-
-maxNumberOfProcesses
- "return the limit on the number of processes;
- the default is nil (i.e. unlimited)."
-
- ^ MaxNumberOfProcesses
-!
-
-maxNumberOfProcesses:aNumber
- "set the limit on the number of processes.
- This helps if you have a program which (by error) creates countless
- subprocesses. Without this limit, you may have a hard time to find
- this error (and repairing it). If nil (the default), the number of
- processes is unlimited."
-
- MaxNumberOfProcesses := aNumber
-! !
-
!ProcessorScheduler class methodsFor:'primitive process primitives'!
-threadsAvailable
- "return true, if the runtime system supports threads (i.e. processes);
- false otherwise."
-
-%{ /* NOCONTEXT */
- extern OBJ __threadsAvailable();
-
- RETURN (__threadsAvailable());
-%}
-!
-
-threadInterrupt:id
- "make the process evaluate an interrupt. This sets a flag in the VMs
- threadSwitcher, to let the process perform a #interrupt when its set to
- run the next time. The process itself can decide how to react on this
- interrupt (currently, it looks for interruptBlocks to evaluate)."
-
-%{ /* NOCONTEXT */
-
- if (__isSmallInteger(id)) {
- __threadInterrupt(_intVal(id));
- }
-%}
-!
-
threadCreate:aProcess withId:id
"physical creation of a process.
(warning: low level entry, no administration done).
@@ -322,656 +231,123 @@
__threadDestroy(_intVal(id));
}
%}
+!
+
+threadInterrupt:id
+ "make the process evaluate an interrupt. This sets a flag in the VMs
+ threadSwitcher, to let the process perform a #interrupt when its set to
+ run the next time. The process itself can decide how to react on this
+ interrupt (currently, it looks for interruptBlocks to evaluate)."
+
+%{ /* NOCONTEXT */
+
+ if (__isSmallInteger(id)) {
+ __threadInterrupt(_intVal(id));
+ }
+%}
+!
+
+threadsAvailable
+ "return true, if the runtime system supports threads (i.e. processes);
+ false otherwise."
+
+%{ /* NOCONTEXT */
+ extern OBJ __threadsAvailable();
+
+ RETURN (__threadsAvailable());
+%}
! !
-!ProcessorScheduler methodsFor:'primitive process primitives'!
+!ProcessorScheduler class methodsFor:'queries'!
+
+isPureEventDriven
+ "this is temporary - (maybe not :-).
+ you can run ST/X either with or without processes.
+ Without, there is conceptionally a single process handling all
+ outside events and timeouts. This has some negative implications
+ (Debugger is ugly), but allows a fully portable ST/X without any
+ assembler support - i.e. quick portability.
+ The PureEvent flag will automatically be set if the runtime system
+ does not support threads - otherwise, it can be set manually
+ (from rc-file).
+ "
+
+ ^ PureEventDriven
+!
+
+knownProcesses
+ "return a collection of all (living) processes in the system"
+
+ ^ KnownProcesses select:[:p | p notNil]
+!
+
+maxNumberOfProcesses
+ "return the limit on the number of processes;
+ the default is nil (i.e. unlimited)."
+
+ ^ MaxNumberOfProcesses
+!
-threadSwitch:aProcess
- "continue execution in aProcess.
- (warning: low level entry, no administration is done here)"
+maxNumberOfProcesses:aNumber
+ "set the limit on the number of processes.
+ This helps if you have a program which (by error) creates countless
+ subprocesses. Without this limit, you may have a hard time to find
+ this error (and repairing it). If nil (the default), the number of
+ processes is unlimited."
+
+ MaxNumberOfProcesses := aNumber
+!
+
+processDriven
+ "turn on process driven mode"
- |id pri ok oldProcess oldPri p singleStep wasBlocked|
+ PureEventDriven := false
+!
+
+pureEventDriven
+ "turn on pure-event driven mode - no processes, single dispatch loop"
+
+ PureEventDriven := true
+! !
- (aProcess isNil or:[aProcess == activeProcess]) ifTrue:[^ self].
+!ProcessorScheduler methodsFor:'I/O event actions'!
+
+disableFd:aFileDescriptor
+ "disable block events on aFileDescriptor.
+ This is a leftover support for pure-event systems and may vanish."
+
+ |idx "{Class: SmallInteger }"
+ wasBlocked|
wasBlocked := OperatingSystem blockInterrupts.
-
- oldProcess := activeProcess.
- oldPri := currentPriority.
-
- id := aProcess id.
- pri := aProcess priority.
- singleStep := aProcess isSingleStepping.
- aProcess state:#active.
- oldProcess setStateTo:#run if:#active.
-
- "
- no interrupts now - activeProcess has already been changed
- (dont add any message sends here)
- "
- activeProcess := aProcess.
- currentPriority := pri.
-%{
- extern OBJ ___threadSwitch();
-
- if (__isSmallInteger(id)) {
- ok = ___threadSwitch(__context, _intVal(id), (singleStep == true) ? 1 : 0);
- } else {
- ok = false;
- }
-%}.
- "time passes spent in some other process ...
- ... here again"
-
- p := activeProcess.
- activeProcess := oldProcess.
- currentPriority := oldProcess priority.
-
- ok ifFalse:[
- "
- switch failed for some reason -
- destroy the bad process
- "
- p id ~~ 0 ifTrue:[
- 'SCHEDULER: problem with process ' errorPrint.
- p id errorPrint.
- p name notNil ifTrue:[
- ' (' errorPrint. p name errorPrint. ')' errorPrint.
- ].
- '; hard-terminate it.' errorPrintNL.
- p state:#suspended.
- self terminateNoSignal:p.
- ]
- ].
- zombie notNil ifTrue:[
- self class threadDestroy:zombie.
- zombie := nil
+ idx := readFdArray identityIndexOf:aFileDescriptor startingAt:1.
+ idx ~~ 0 ifTrue:[
+ readFdArray at:idx put:nil.
+ readCheckArray at:idx put:nil.
+ readSemaphoreArray at:idx put:nil
].
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
!
-scheduleForInterrupt:aProcess
- "make aProcess evaluate its pushed interrupt block(s)"
-
- |id|
-
- aProcess isNil ifTrue:[^ self].
- aProcess == activeProcess ifTrue:[^ self].
-
- id := aProcess id.
- self class threadInterrupt:id.
- "
- and, make the process runnable
- "
- aProcess state ~~ #stopped ifTrue:[
- "
- and, make the process runnable
- "
- aProcess resume
- ]
-! !
-
-!ProcessorScheduler methodsFor:'constants'!
-
-lowestPriority
- "return the lowest priority value"
-
- ^ 1 "do not change this - its not variable"
-!
-
-highestPriority
- "return the highest priority value (normal) processes can have."
-
- "must be below schedulingPriority -
- otherwise scheduler could be blocked ...
- "
- ^ HighestPriority
-!
-
-schedulingPriority
- "return the priority at which the scheduler runs."
-
- "must be above highestPriority -
- otherwise scheduler could be blocked ...
- "
- ^ SchedulingPriority
-!
-
-userInterruptPriority
- "return the priority, at which the event scheduler runs - i.e.
- all processes running at a lower priority are interruptable by Cntl-C
- or the timer. Processes running at higher prio will not be interrupted."
-
- ^ UserInterruptPriority
-!
-
-timingPriority
- "return the priority, at which all timing takes place (messageTally,
- delay etc.)"
-
- ^ TimingPriority
-!
-
-userSchedulingPriority
- "return the priority, at which all normal user (interactive) processing
- takes place"
-
- ^ UserSchedulingPriority
-!
-
-userBackgroundPriority
- "return the priority, at which background user (non-interactive) processing
- should take place.
- Not currently used - for ST80 compatibility only"
-
- ^ 6
-!
-
-systemBackgroundPriority
- "return the priority, at which background system processing
- should take place.
- Not currently used - for ST80 compatibility only"
-
- ^ 4
-!
-
-lowIOPriority
- "not currently used - for ST80 compatibility only"
-
- ^ 2 "claus: is this ok ?"
-! !
-
-!ProcessorScheduler methodsFor:'private initializing'!
-
-initialize
- "initialize the one-and-only ProcessorScheduler"
-
- |nPrios "{ Class: SmallInteger }"
- l p|
-
- KnownProcesses isNil ifTrue:[
- KnownProcesses := WeakArray new:10.
- KnownProcesses watcher:self class.
- KnownProcessIds := OrderedCollection new.
- ].
-
- "
- create a collection with process lists; accessed using the priority as key
- "
- nPrios := SchedulingPriority.
- quiescentProcessLists := Array new:nPrios.
- 1 to:nPrios do:[:pri |
- quiescentProcessLists at:pri put:(LinkedList new)
- ].
+enableIOAction:aBlock onInput:aFileDescriptor
+ "half-obsolete event support: arrange for aBlock to be
+ evaluated when input on aFileDescriptor arrives.
+ This is a leftover support for pure-event systems and may vanish."
- readFdArray := Array with:nil.
- readCheckArray := Array with:nil.
- readSemaphoreArray := Array with:nil.
- writeFdArray := Array with:nil.
- writeSemaphoreArray := Array with:nil.
- timeoutArray := Array with:nil.
- timeoutSemaphoreArray := Array with:nil.
- timeoutActionArray := Array with:nil.
- timeoutProcessArray := Array with:nil.
- anyTimeouts := false.
- dispatching := false.
- useIOInterrupts := OperatingSystem supportsIOInterrupts.
-
- "
- handcraft the first (dispatcher-) process - this one will never
- block, but go into a select if there is nothing to do.
- Also, it has a prio of max+1 - thus, it comes first when looking
- for a runnable process.
- "
- currentPriority := SchedulingPriority.
- p := Process new.
- p setId:0 state:#run.
- p setPriority:currentPriority.
- p name:'scheduler'.
-
- scheduler := activeProcess := p.
-
- (quiescentProcessLists at:currentPriority) add:p.
-
- "
- let me handle IO and timer interrupts
- "
- ObjectMemory ioInterruptHandler:self.
- ObjectMemory timerInterruptHandler:self.
-!
-
-reinitialize
- "all previous processes (except those marked as restartable) are made dead
- - each object should reinstall its process(s) upon restart;
- especially, windowgroups have to.
- In contrast to ST-80, restartable processes are restarted at the beginning
- NOT continued where left. This is a consequence of the portable implementation
- of ST/X, since in order to continue a process, we needed to know the
- internals of the machines (and C-compilers) stack layout.
- This was not done, favouring portability for process continuation.
- In praxis, this is not much of a problem, since in almost every case,
- the computation state can be saved in some object, and processing be
- restarted from scratch, reinitializing things from this saved state."
-
- |processesToRestart|
-
- "
- lay all processes to rest, collect restartable ones
- "
- processesToRestart := OrderedCollection new.
- KnownProcesses do:[:p |
- p notNil ifTrue:[
- "how, exactly should this be done ?"
-
- p isRestartable == true ifTrue:[
- p nextLink:nil.
- processesToRestart add:p
- ] ifFalse:[
- p setId:nil state:#dead
- ]
- ].
- ].
- scheduler setId:nil state:#dead.
-
- "
- now, start from scratch
- "
- KnownProcesses := nil.
- self initialize.
-
- "
- ... and restart those that can be.
- "
- processesToRestart do:[:p |
-"/ 'process restart not implemented' errorPrintNL.
- p restart
- ]
-! !
-
-!ProcessorScheduler methodsFor:'private'!
-
-remember:aProcess
- "remember aProcess for later disposal (where the underlying
- system resources have to be freed)."
-
- |newShadow oldId wasBlocked
- oldSize "{ Class: SmallInteger }"
- index "{ Class: SmallInteger }"
- sz "{ Class: SmallInteger }" |
-
- wasBlocked := OperatingSystem blockInterrupts.
- index := 1.
- sz := KnownProcessIds size.
- [index <= sz] whileTrue:[
- (KnownProcesses at:index) isNil ifTrue:[
- oldId := KnownProcessIds at:index.
- oldId notNil ifTrue:[
- self class threadDestroy:oldId.
- ].
- KnownProcesses at:index put:aProcess.
- KnownProcessIds at:index put:aProcess id.
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
- ^ self
- ].
- index := index + 1
- ].
-
- KnownProcessIds grow:index.
- KnownProcessIds at:index put:aProcess id.
-
- oldSize := KnownProcesses size.
- (index > oldSize) ifTrue:[
- newShadow := WeakArray new:(oldSize * 2).
- newShadow watcher:self class.
- newShadow replaceFrom:1 with:KnownProcesses.
- KnownProcesses := newShadow
- ].
- KnownProcesses at:index put:aProcess.
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
-!
-
-unRemember:aProcess
- "forget aProcess - dispose processing will not consider this one"
-
- |index wasBlocked|
+ |idx "{Class: SmallInteger }"
+ wasBlocked|
wasBlocked := OperatingSystem blockInterrupts.
- index := KnownProcesses identityIndexOf:aProcess.
- index ~~ 0 ifTrue:[
- KnownProcessIds at:index put:nil.
- KnownProcesses at:index put:nil.
- ].
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
-! !
-
-!ProcessorScheduler methodsFor:'process creation'!
-
-newProcessFor:aProcess withId:idWant
- "private entry for Process restart - do not use in your program"
-
- (self class threadCreate:aProcess withId:idWant) ~~ idWant ifTrue:[
- ^ false
- ].
-
- aProcess state:#light. "meaning: has no stack yet"
- self remember:aProcess.
- ^ true
-!
-
-newProcessFor:aProcess
- "create a physical (VM-) process for aProcess.
- Return true if ok, false if something went wrong.
- The process is not scheduled; to start it running,
- it needs a Process>>resume. Once resumed, the process will later
- get control in its #start method."
-
- |id|
-
- id := self class threadCreate:aProcess withId:nil.
- id isNil ifTrue:[^ false].
-
- aProcess setId:id state:#light. "meaning: has no stack yet"
- self remember:aProcess.
- ^ true
-! !
-
-!ProcessorScheduler methodsFor:'scheduling'!
-
-reschedule
- "switch to the highest prio runnable process.
- The scheduler itself is always runnable, so we can do an unconditional switch
- to that one. This method is a historical left-over and will vanish."
-
- ^ self threadSwitch:scheduler
-!
-
-yield
- "move the currently running process to the end of the currentList
- and reschedule to the first in the list, thus switching to the
- next same-prio-process."
-
- |l wasBlocked|
-
- wasBlocked := OperatingSystem blockInterrupts.
-
- "
- debugging consistency check - will be removed later
- "
- activeProcess priority ~~ currentPriority ifTrue:[
- 'oops process changed priority' errorPrintNL.
- currentPriority := activeProcess priority.
- ].
-
- l := quiescentProcessLists at:currentPriority.
-
- "
- debugging consistency checks - will be removed later
- "
- l isEmpty ifTrue:[
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
- 'oops - empty runnable list' errorPrintNL.
- ^ self
- ].
-
- "
- check if the running process is not the only one
- "
- l size ~~ 1 ifTrue:[
- "
- bring running process to the end
- "
- l removeFirst.
- l addLast:activeProcess.
-
- "
- and switch to first in the list
- "
- self threadSwitch:(l first).
- ].
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
-!
-
-suspend:aProcess
- "remove the argument, aProcess from the list of runnable processes.
- If the process is the current one, reschedule."
-
- |pri l p wasBlocked|
-
- "
- some debugging stuff
- "
- aProcess isNil ifTrue:[
- MiniDebugger enterWithMessage:'nil suspend'.
- ^ self
- ].
- aProcess id isNil ifTrue:[
- MiniDebugger enterWithMessage:'bad suspend: already dead'.
- self threadSwitch:scheduler.
- ^ self
- ].
- aProcess == scheduler ifTrue:[
- 'scheduler should never be suspended' errorPrintNL.
- MiniDebugger enterWithMessage:'scheduler should never be suspended'.
- ^ self
- ].
-
- wasBlocked := OperatingSystem blockInterrupts.
-
- pri := aProcess priority.
- l := quiescentProcessLists at:pri.
-
- "notice: this is slightly faster than putting the if-code into
- the ifAbsent block, because [] is a shared cheap block
- "
- (l remove:aProcess ifAbsent:[]) isNil ifTrue:[
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
- 'bad suspend: not on run list' errorPrintNL.
- "/ MiniDebugger enterWithMessage:'bad suspend: not on run list'.
- self threadSwitch:scheduler.
- ^ self
- ].
-
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
-
- "
- this is a bit of a kludge: allow someone else to
- set the state to something like #ioWait etc.
- In this case, do not set to #suspend.
- All of this to enhance the output of the process monitor ...
- "
- aProcess setStateTo:#suspended if:#active or:#run.
-
- (aProcess == activeProcess) ifTrue:[
- "we can immediately switch sometimes"
- l notEmpty ifTrue:[
- p := l first
+ (readFdArray identityIndexOf:aFileDescriptor startingAt:1) == 0 ifTrue:[
+ idx := readFdArray identityIndexOf:nil startingAt:1.
+ idx ~~ 0 ifTrue:[
+ readFdArray at:idx put:aFileDescriptor.
+ readCheckArray at:idx put:aBlock.
+ readSemaphoreArray at:idx put:nil
] ifFalse:[
- p := scheduler
- ].
- self threadSwitch:p
- ].
-!
-
-resume:aProcess
- "set aProcess runnable -
- if its prio is higher than the currently running prio, switch to it."
-
- |l pri wasBlocked|
-
- (aProcess isNil or:[aProcess == activeProcess]) ifTrue:[^ self].
-
- "ignore, if process is already dead"
- aProcess id isNil ifTrue:[^ self].
-
- wasBlocked := OperatingSystem blockInterrupts.
-
- pri := aProcess priority.
-
- l := quiescentProcessLists at:pri.
- "if already running, ignore"
- (l identityIndexOf:aProcess) ~~ 0 ifTrue:[
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
- ^ self
- ].
- l addLast:aProcess.
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
-
- (pri > currentPriority) ifTrue:[
- "
- its prio is higher; immediately transfer control to it
- "
- self threadSwitch:aProcess
- ] ifFalse:[
- "
- its prio is lower; it will have to wait for a while ...
- "
- aProcess state:#run
- ]
-!
-
-resumeForSingleSend:aProcess
- "like resume, but let the process execute a single send only.
- This will be used by the (new, not yet released) debugger
- for single stepping."
-
- (aProcess isNil or:[aProcess == activeProcess]) ifTrue:[^ self].
- aProcess singleStep:true.
- self resume:aProcess
-!
-
-terminateNoSignal:aProcess
- "hard terminate aProcess without sending the terminate signal, thus
- no unwind blocks or exitAction are performed in the process..
- If its not the current process, it is simply removed from its list
- and physically destroyed. Otherwise (since we can't take away the chair
- we are sitting on), a switch is forced and the process
- will be physically destroyed by the next running process.
- (see zombie handling)"
-
- |pri id l wasBlocked|
-
- aProcess isNil ifTrue:[^ self].
- id := aProcess id.
- id isNil ifTrue:[^ self]. "already dead"
-
- aProcess setId:nil state:#dead.
-
- wasBlocked := OperatingSystem blockInterrupts.
-
- "remove the process from the runnable list"
-
- pri := aProcess priority.
- l := quiescentProcessLists at:pri.
- (l identityIndexOf:aProcess) ~~ 0 ifTrue:[
- l remove:aProcess.
- ].
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
-
- aProcess == activeProcess ifTrue:[
- "
- hard case - its the currently running process
- we must have the next active process destroy this one
- (we cannot destroy the chair we are sitting on ... :-)
- "
- zombie := id.
- self unRemember:aProcess.
- self threadSwitch:scheduler.
- "not reached"
- ^ self
- ].
- self class threadDestroy:id.
- self unRemember:aProcess.
- ^ self
-!
-
-terminateActiveNoSignal
- "hard terminate the active process, without sending any
- terminate signal thus no unwind blocks are evaluated."
-
- self terminateNoSignal:activeProcess
-!
-
-processTermination
- "sent by VM if the current process finished its startup block
- without proper process termination. Lay him to rest now.
- This can only happen, if something went wrong in Block>>newProcess,
- since the block defined there always terminates itself."
-
- self terminateNoSignal:activeProcess.
- self threadSwitch:scheduler
-!
-
-terminate:aProcess
- "terminate aProcess. This is donen by sending aProcess the terminateSignal,
- which will evaluate any unwind blocks and finally do a hard terminate."
-
- aProcess terminate
-!
-
-terminateActive
- "terminate the current process (i.e. the running process kills itself).
- The active process is sent the terminateSignal so it will evaluate any
- unwind blocks and finally do a hard terminate.
- This is sent for regular termination and by the VM, if the hard-stack limit
- is reached. (i.e. a process did not repair things in a recursionInterrupt and
- continued to grow its stack)"
-
- activeProcess terminate
-!
-
-interruptActive
- "interrupt the current process"
-
- activeProcess interrupt
-!
-
-changePriority:prio for:aProcess
- "change the priority of aProcess"
-
- |oldList newList oldPrio newPrio wasBlocked|
-
- oldPrio := aProcess priority.
- oldPrio == prio ifTrue:[^ self].
-
- "
- check for valid argument
- "
- newPrio := prio.
- newPrio < 1 ifTrue:[
- newPrio := 1.
- ] ifFalse:[
- aProcess == scheduler ifTrue:[^ self].
- newPrio > HighestPriority ifTrue:[
- newPrio := HighestPriority
- ]
- ].
-
- wasBlocked := OperatingSystem blockInterrupts.
-
- aProcess setPriority:newPrio.
-
- oldList := quiescentProcessLists at:oldPrio.
- (oldList identityIndexOf:aProcess) == 0 ifTrue:[
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
- ^ self
- ].
-
- oldList remove:aProcess.
-
- newList := quiescentProcessLists at:newPrio.
- newList addLast:aProcess.
-
- "if its the current process lowering its prio
- or another one raising, we have to reschedule"
-
- aProcess == activeProcess ifTrue:[
- currentPriority := newPrio.
- newPrio < oldPrio ifTrue:[
- self threadSwitch:scheduler.
- ]
- ] ifFalse:[
- newPrio > currentPriority ifTrue:[
- self threadSwitch:aProcess.
+ readFdArray := readFdArray copyWith:aFileDescriptor.
+ readCheckArray := readCheckArray copyWith:aBlock.
+ readSemaphoreArray := readSemaphoreArray copyWith:nil.
]
].
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
@@ -979,14 +355,6 @@
!ProcessorScheduler methodsFor:'accessing'!
-currentPriority
- "return the priority of the currently running process"
-
- ^ currentPriority
-
- "Processor currentPriority"
-!
-
activePriority
"return the priority of the currently running process.
GNU-ST & ST-80 compatibility; this is the same as currentPriority"
@@ -1002,92 +370,127 @@
"Processor activeProcess"
!
+currentPriority
+ "return the priority of the currently running process"
+
+ ^ currentPriority
+
+ "Processor currentPriority"
+!
+
interruptedProcess
"returns the process which was interrupted by the active one"
^ interruptedProcess
! !
-!ProcessorScheduler methodsFor:'queries'!
+!ProcessorScheduler methodsFor:'background processing'!
-highestPriorityRunnableProcess
- "return the highest prio runnable process"
+addIdleBlock:aBlock
+ "add the argument, aBlock to the list of idle-actions.
+ Idle blocks are evaluated whenever no other process is runnable,
+ and no events are pending.
+ Use of idle blocks is not recommended, use a low priority processes
+ instead, which has the same effect. Idle blcoks are still included
+ to support background actions in pure-event systems, where no processes
+ are available.
+ Support for idle-blocks may vanish."
- |listArray l p prio "{ Class: SmallInteger }" |
+ |wasBlocked|
+
+ wasBlocked := OperatingSystem blockInterrupts.
+ idleActions isNil ifTrue:[
+ idleActions := OrderedCollection new
+ ].
+ idleActions add:aBlock.
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+!
- prio := HighestPriority.
- listArray := quiescentProcessLists.
- [prio >= 1] whileTrue:[
- l := listArray at:prio.
- 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
+removeIdleBlock:aBlock
+ "remove the argument, aBlock from the list of idle-blocks.
+ Support for idle-blocks may vanish - use low prio processes instead."
+
+ |wasBlocked|
+
+ wasBlocked := OperatingSystem blockInterrupts.
+ idleActions notNil ifTrue:[
+ idleActions remove:aBlock
].
- ^ nil
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+! !
+
+!ProcessorScheduler methodsFor:'constants'!
+
+highestPriority
+ "return the highest priority value (normal) processes can have."
+
+ "must be below schedulingPriority -
+ otherwise scheduler could be blocked ...
+ "
+ ^ HighestPriority
+!
+
+lowIOPriority
+ "not currently used - for ST80 compatibility only"
+
+ ^ 2 "claus: is this ok ?"
!
-isSystemProcess:aProcess
- "return true if aProcess is a system process,
- which should not be suspended/terminated etc.."
+lowestPriority
+ "return the lowest priority value"
+
+ ^ 1 "do not change this - its not variable"
+!
+
+schedulingPriority
+ "return the priority at which the scheduler runs."
- (self class isPureEventDriven
- or:[aProcess id == 0
- or:[(Display notNil and:[Display dispatchProcess == aProcess])
- " nameOrId endsWith:'dispatcher' "
- ]]) ifTrue:[
- ^ true
- ].
- ^ false
+ "must be above highestPriority -
+ otherwise scheduler could be blocked ...
+ "
+ ^ SchedulingPriority
+!
- "
- Processor activeProcessIsSystemProcess
- "
+systemBackgroundPriority
+ "return the priority, at which background system processing
+ should take place.
+ Not currently used - for ST80 compatibility only"
+
+ ^ 4
!
-activeProcessIsSystemProcess
- "return true if the active process is a system process,
- which should not be suspended."
+timingPriority
+ "return the priority, at which all timing takes place (messageTally,
+ delay etc.)"
+
+ ^ TimingPriority
+!
+
+userBackgroundPriority
+ "return the priority, at which background user (non-interactive) processing
+ should take place.
+ Not currently used - for ST80 compatibility only"
- ^ self isSystemProcess:activeProcess
+ ^ 6
+!
+
+userInterruptPriority
+ "return the priority, at which the event scheduler runs - i.e.
+ all processes running at a lower priority are interruptable by Cntl-C
+ or the timer. Processes running at higher prio will not be interrupted."
- "
- Processor activeProcessIsSystemProcess
- "
+ ^ UserInterruptPriority
+!
+
+userSchedulingPriority
+ "return the priority, at which all normal user (interactive) processing
+ takes place"
+
+ ^ UserSchedulingPriority
! !
!ProcessorScheduler methodsFor:'dispatching'!
-dispatchLoop
- "central dispatch loop; the scheduler process is always staying in
- this method, looping forever."
-
- "avoid confusion if entered twice"
-
- dispatching == true ifTrue:[^ self].
- dispatching := true.
-
- "I made this an extra call to dispatch; this allows recompilation
- of the dispatch-handling code in the running system.
- "
- [true] whileTrue:[
- AbortSignal handle:[:ex |
- ex return
- ] do:[
- self dispatch
- ]
- ]
-!
-
dispatch
"It handles timeouts and switches to the highest prio runnable process"
@@ -1211,10 +614,1027 @@
OperatingSystem disableTimer.
self checkForInputWithTimeout:0.
]
+!
+
+dispatchLoop
+ "central dispatch loop; the scheduler process is always staying in
+ this method, looping forever."
+
+ "avoid confusion if entered twice"
+
+ dispatching == true ifTrue:[^ self].
+ dispatching := true.
+
+ "I made this an extra call to dispatch; this allows recompilation
+ of the dispatch-handling code in the running system.
+ "
+ [true] whileTrue:[
+ AbortSignal handle:[:ex |
+ ex return
+ ] do:[
+ self dispatch
+ ]
+ ]
+! !
+
+!ProcessorScheduler methodsFor:'primitive process primitives'!
+
+scheduleForInterrupt:aProcess
+ "make aProcess evaluate its pushed interrupt block(s)"
+
+ |id|
+
+ aProcess isNil ifTrue:[^ self].
+ aProcess == activeProcess ifTrue:[^ self].
+
+ id := aProcess id.
+ self class threadInterrupt:id.
+ "
+ and, make the process runnable
+ "
+ aProcess state ~~ #stopped ifTrue:[
+ "
+ and, make the process runnable
+ "
+ aProcess resume
+ ]
+!
+
+threadSwitch:aProcess
+ "continue execution in aProcess.
+ (warning: low level entry, no administration is done here)"
+
+ |id pri ok oldProcess oldPri p singleStep wasBlocked|
+
+ (aProcess isNil or:[aProcess == activeProcess]) ifTrue:[^ self].
+
+ wasBlocked := OperatingSystem blockInterrupts.
+
+ oldProcess := activeProcess.
+ oldPri := currentPriority.
+
+ id := aProcess id.
+ pri := aProcess priority.
+ singleStep := aProcess isSingleStepping.
+ aProcess state:#active.
+ oldProcess setStateTo:#run if:#active.
+
+ "
+ no interrupts now - activeProcess has already been changed
+ (dont add any message sends here)
+ "
+ activeProcess := aProcess.
+ currentPriority := pri.
+%{
+ extern OBJ ___threadSwitch();
+
+ if (__isSmallInteger(id)) {
+ ok = ___threadSwitch(__context, _intVal(id), (singleStep == true) ? 1 : 0);
+ } else {
+ ok = false;
+ }
+%}.
+ "time passes spent in some other process ...
+ ... here again"
+
+ p := activeProcess.
+ activeProcess := oldProcess.
+ currentPriority := oldProcess priority.
+
+ ok ifFalse:[
+ "
+ switch failed for some reason -
+ destroy the bad process
+ "
+ p id ~~ 0 ifTrue:[
+ 'SCHEDULER: problem with process ' errorPrint.
+ p id errorPrint.
+ p name notNil ifTrue:[
+ ' (' errorPrint. p name errorPrint. ')' errorPrint.
+ ].
+ '; hard-terminate it.' errorPrintNL.
+ p state:#suspended.
+ self terminateNoSignal:p.
+ ]
+ ].
+ zombie notNil ifTrue:[
+ self class threadDestroy:zombie.
+ zombie := nil
+ ].
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+! !
+
+!ProcessorScheduler methodsFor:'private'!
+
+remember:aProcess
+ "remember aProcess for later disposal (where the underlying
+ system resources have to be freed)."
+
+ |newShadow oldId wasBlocked
+ oldSize "{ Class: SmallInteger }"
+ index "{ Class: SmallInteger }"
+ sz "{ Class: SmallInteger }" |
+
+ wasBlocked := OperatingSystem blockInterrupts.
+ index := 1.
+ sz := KnownProcessIds size.
+ [index <= sz] whileTrue:[
+ (KnownProcesses at:index) isNil ifTrue:[
+ oldId := KnownProcessIds at:index.
+ oldId notNil ifTrue:[
+ self class threadDestroy:oldId.
+ ].
+ KnownProcesses at:index put:aProcess.
+ KnownProcessIds at:index put:aProcess id.
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+ ^ self
+ ].
+ index := index + 1
+ ].
+
+ KnownProcessIds grow:index.
+ KnownProcessIds at:index put:aProcess id.
+
+ oldSize := KnownProcesses size.
+ (index > oldSize) ifTrue:[
+ newShadow := WeakArray new:(oldSize * 2).
+ newShadow watcher:self class.
+ newShadow replaceFrom:1 with:KnownProcesses.
+ KnownProcesses := newShadow
+ ].
+ KnownProcesses at:index put:aProcess.
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+!
+
+unRemember:aProcess
+ "forget aProcess - dispose processing will not consider this one"
+
+ |index wasBlocked|
+
+ wasBlocked := OperatingSystem blockInterrupts.
+ index := KnownProcesses identityIndexOf:aProcess.
+ index ~~ 0 ifTrue:[
+ KnownProcessIds at:index put:nil.
+ KnownProcesses at:index put:nil.
+ ].
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+! !
+
+!ProcessorScheduler methodsFor:'private initializing'!
+
+initialize
+ "initialize the one-and-only ProcessorScheduler"
+
+ |nPrios "{ Class: SmallInteger }"
+ l p|
+
+ KnownProcesses isNil ifTrue:[
+ KnownProcesses := WeakArray new:10.
+ KnownProcesses watcher:self class.
+ KnownProcessIds := OrderedCollection new.
+ ].
+
+ "
+ create a collection with process lists; accessed using the priority as key
+ "
+ 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.
+ readSemaphoreArray := Array with:nil.
+ writeFdArray := Array with:nil.
+ writeSemaphoreArray := Array with:nil.
+ timeoutArray := Array with:nil.
+ timeoutSemaphoreArray := Array with:nil.
+ timeoutActionArray := Array with:nil.
+ timeoutProcessArray := Array with:nil.
+ anyTimeouts := false.
+ dispatching := false.
+ useIOInterrupts := OperatingSystem supportsIOInterrupts.
+
+ "
+ handcraft the first (dispatcher-) process - this one will never
+ block, but go into a select if there is nothing to do.
+ Also, it has a prio of max+1 - thus, it comes first when looking
+ for a runnable process.
+ "
+ currentPriority := SchedulingPriority.
+ p := Process new.
+ p setId:0 state:#run.
+ p setPriority:currentPriority.
+ p name:'scheduler'.
+
+ scheduler := activeProcess := p.
+
+ (quiescentProcessLists at:currentPriority) add:p.
+
+ "
+ let me handle IO and timer interrupts
+ "
+ ObjectMemory ioInterruptHandler:self.
+ ObjectMemory timerInterruptHandler:self.
+!
+
+reinitialize
+ "all previous processes (except those marked as restartable) are made dead
+ - each object should reinstall its process(s) upon restart;
+ especially, windowgroups have to.
+ In contrast to ST-80, restartable processes are restarted at the beginning
+ NOT continued where left. This is a consequence of the portable implementation
+ of ST/X, since in order to continue a process, we needed to know the
+ internals of the machines (and C-compilers) stack layout.
+ This was not done, favouring portability for process continuation.
+ In praxis, this is not much of a problem, since in almost every case,
+ the computation state can be saved in some object, and processing be
+ restarted from scratch, reinitializing things from this saved state."
+
+ |processesToRestart|
+
+ "
+ lay all processes to rest, collect restartable ones
+ "
+ processesToRestart := OrderedCollection new.
+ KnownProcesses do:[:p |
+ p notNil ifTrue:[
+ "how, exactly should this be done ?"
+
+ p isRestartable == true ifTrue:[
+ p nextLink:nil.
+ processesToRestart add:p
+ ] ifFalse:[
+ p setId:nil state:#dead
+ ]
+ ].
+ ].
+ scheduler setId:nil state:#dead.
+
+ "
+ now, start from scratch
+ "
+ KnownProcesses := nil.
+ self initialize.
+
+ "
+ ... and restart those that can be.
+ "
+ processesToRestart do:[:p |
+"/ 'process restart not implemented' errorPrintNL.
+ p restart
+ ]
+! !
+
+!ProcessorScheduler methodsFor:'process creation'!
+
+newProcessFor:aProcess
+ "create a physical (VM-) process for aProcess.
+ Return true if ok, false if something went wrong.
+ The process is not scheduled; to start it running,
+ it needs a Process>>resume. Once resumed, the process will later
+ get control in its #start method."
+
+ |id|
+
+ id := self class threadCreate:aProcess withId:nil.
+ id isNil ifTrue:[^ false].
+
+ aProcess setId:id state:#light. "meaning: has no stack yet"
+ self remember:aProcess.
+ ^ true
+!
+
+newProcessFor:aProcess withId:idWant
+ "private entry for Process restart - do not use in your program"
+
+ (self class threadCreate:aProcess withId:idWant) ~~ idWant ifTrue:[
+ ^ false
+ ].
+
+ aProcess state:#light. "meaning: has no stack yet"
+ self remember:aProcess.
+ ^ true
+! !
+
+!ProcessorScheduler methodsFor:'queries'!
+
+activeProcessIsSystemProcess
+ "return true if the active process is a system process,
+ which should not be suspended."
+
+ ^ self isSystemProcess:activeProcess
+
+ "
+ Processor activeProcessIsSystemProcess
+ "
+!
+
+highestPriorityRunnableProcess
+ "return the highest prio runnable process"
+
+ |listArray l p prio "{ Class: SmallInteger }" |
+
+ prio := HighestPriority.
+ listArray := quiescentProcessLists.
+ [prio >= 1] whileTrue:[
+ l := listArray at:prio.
+ 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
+ ].
+ ^ nil
+!
+
+isSystemProcess:aProcess
+ "return true if aProcess is a system process,
+ which should not be suspended/terminated etc.."
+
+ (self class isPureEventDriven
+ or:[aProcess id == 0
+ or:[(Display notNil and:[Display dispatchProcess == aProcess])
+ " nameOrId endsWith:'dispatcher' "
+ ]]) ifTrue:[
+ ^ true
+ ].
+ ^ false
+
+ "
+ Processor activeProcessIsSystemProcess
+ "
+! !
+
+!ProcessorScheduler methodsFor:'scheduling'!
+
+changePriority:prio for:aProcess
+ "change the priority of aProcess"
+
+ |oldList newList oldPrio newPrio wasBlocked|
+
+ oldPrio := aProcess priority.
+ oldPrio == prio ifTrue:[^ self].
+
+ "
+ check for valid argument
+ "
+ newPrio := prio.
+ newPrio < 1 ifTrue:[
+ newPrio := 1.
+ ] ifFalse:[
+ aProcess == scheduler ifTrue:[^ self].
+ newPrio > HighestPriority ifTrue:[
+ newPrio := HighestPriority
+ ]
+ ].
+
+ wasBlocked := OperatingSystem blockInterrupts.
+
+ aProcess setPriority:newPrio.
+
+ oldList := quiescentProcessLists at:oldPrio.
+ (oldList identityIndexOf:aProcess) == 0 ifTrue:[
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+ ^ self
+ ].
+
+ oldList remove:aProcess.
+
+ newList := quiescentProcessLists at:newPrio.
+ newList addLast:aProcess.
+
+ "if its the current process lowering its prio
+ or another one raising, we have to reschedule"
+
+ aProcess == activeProcess ifTrue:[
+ currentPriority := newPrio.
+ newPrio < oldPrio ifTrue:[
+ self threadSwitch:scheduler.
+ ]
+ ] ifFalse:[
+ newPrio > currentPriority ifTrue:[
+ self threadSwitch:aProcess.
+ ]
+ ].
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+!
+
+interruptActive
+ "interrupt the current process"
+
+ activeProcess interrupt
+!
+
+processTermination
+ "sent by VM if the current process finished its startup block
+ without proper process termination. Lay him to rest now.
+ This can only happen, if something went wrong in Block>>newProcess,
+ since the block defined there always terminates itself."
+
+ self terminateNoSignal:activeProcess.
+ self threadSwitch:scheduler
+!
+
+reschedule
+ "switch to the highest prio runnable process.
+ The scheduler itself is always runnable, so we can do an unconditional switch
+ to that one. This method is a historical left-over and will vanish."
+
+ ^ self threadSwitch:scheduler
+!
+
+resume:aProcess
+ "set aProcess runnable -
+ if its prio is higher than the currently running prio, switch to it."
+
+ |l pri wasBlocked|
+
+ (aProcess isNil or:[aProcess == activeProcess]) ifTrue:[^ self].
+
+ "ignore, if process is already dead"
+ aProcess id isNil ifTrue:[^ self].
+
+ wasBlocked := OperatingSystem blockInterrupts.
+
+ pri := aProcess priority.
+
+ l := quiescentProcessLists at:pri.
+ "if already running, ignore"
+ (l identityIndexOf:aProcess) ~~ 0 ifTrue:[
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+ ^ self
+ ].
+ l addLast:aProcess.
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+
+ (pri > currentPriority) ifTrue:[
+ "
+ its prio is higher; immediately transfer control to it
+ "
+ self threadSwitch:aProcess
+ ] ifFalse:[
+ "
+ its prio is lower; it will have to wait for a while ...
+ "
+ aProcess state:#run
+ ]
+!
+
+resumeForSingleSend:aProcess
+ "like resume, but let the process execute a single send only.
+ This will be used by the (new, not yet released) debugger
+ for single stepping."
+
+ (aProcess isNil or:[aProcess == activeProcess]) ifTrue:[^ self].
+ aProcess singleStep:true.
+ self resume:aProcess
+!
+
+suspend:aProcess
+ "remove the argument, aProcess from the list of runnable processes.
+ If the process is the current one, reschedule."
+
+ |pri l p wasBlocked|
+
+ "
+ some debugging stuff
+ "
+ aProcess isNil ifTrue:[
+ MiniDebugger enterWithMessage:'nil suspend'.
+ ^ self
+ ].
+ aProcess id isNil ifTrue:[
+ MiniDebugger enterWithMessage:'bad suspend: already dead'.
+ self threadSwitch:scheduler.
+ ^ self
+ ].
+ aProcess == scheduler ifTrue:[
+ 'scheduler should never be suspended' errorPrintNL.
+ MiniDebugger enterWithMessage:'scheduler should never be suspended'.
+ ^ self
+ ].
+
+ wasBlocked := OperatingSystem blockInterrupts.
+
+ pri := aProcess priority.
+ l := quiescentProcessLists at:pri.
+
+ "notice: this is slightly faster than putting the if-code into
+ the ifAbsent block, because [] is a shared cheap block
+ "
+ (l remove:aProcess ifAbsent:[]) isNil ifTrue:[
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+ 'bad suspend: not on run list' errorPrintNL.
+ "/ MiniDebugger enterWithMessage:'bad suspend: not on run list'.
+ self threadSwitch:scheduler.
+ ^ self
+ ].
+
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+
+ "
+ this is a bit of a kludge: allow someone else to
+ set the state to something like #ioWait etc.
+ In this case, do not set to #suspend.
+ All of this to enhance the output of the process monitor ...
+ "
+ aProcess setStateTo:#suspended if:#active or:#run.
+
+ (aProcess == activeProcess) ifTrue:[
+ "we can immediately switch sometimes"
+ l notEmpty ifTrue:[
+ p := l first
+ ] ifFalse:[
+ p := scheduler
+ ].
+ self threadSwitch:p
+ ].
+!
+
+terminate:aProcess
+ "terminate aProcess. This is donen by sending aProcess the terminateSignal,
+ which will evaluate any unwind blocks and finally do a hard terminate."
+
+ aProcess terminate
+!
+
+terminateActive
+ "terminate the current process (i.e. the running process kills itself).
+ The active process is sent the terminateSignal so it will evaluate any
+ unwind blocks and finally do a hard terminate.
+ This is sent for regular termination and by the VM, if the hard-stack limit
+ is reached. (i.e. a process did not repair things in a recursionInterrupt and
+ continued to grow its stack)"
+
+ activeProcess terminate
+!
+
+terminateActiveNoSignal
+ "hard terminate the active process, without sending any
+ terminate signal thus no unwind blocks are evaluated."
+
+ self terminateNoSignal:activeProcess
+!
+
+terminateNoSignal:aProcess
+ "hard terminate aProcess without sending the terminate signal, thus
+ no unwind blocks or exitAction are performed in the process..
+ If its not the current process, it is simply removed from its list
+ and physically destroyed. Otherwise (since we can't take away the chair
+ we are sitting on), a switch is forced and the process
+ will be physically destroyed by the next running process.
+ (see zombie handling)"
+
+ |pri id l wasBlocked|
+
+ aProcess isNil ifTrue:[^ self].
+ id := aProcess id.
+ id isNil ifTrue:[^ self]. "already dead"
+
+ aProcess setId:nil state:#dead.
+
+ wasBlocked := OperatingSystem blockInterrupts.
+
+ "remove the process from the runnable list"
+
+ pri := aProcess priority.
+ l := quiescentProcessLists at:pri.
+ (l identityIndexOf:aProcess) ~~ 0 ifTrue:[
+ l remove:aProcess.
+ ].
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+
+ aProcess == activeProcess ifTrue:[
+ "
+ hard case - its the currently running process
+ we must have the next active process destroy this one
+ (we cannot destroy the chair we are sitting on ... :-)
+ "
+ zombie := id.
+ self unRemember:aProcess.
+ self threadSwitch:scheduler.
+ "not reached"
+ ^ self
+ ].
+ self class threadDestroy:id.
+ self unRemember:aProcess.
+ ^ self
+!
+
+yield
+ "move the currently running process to the end of the currentList
+ and reschedule to the first in the list, thus switching to the
+ next same-prio-process."
+
+ |l wasBlocked|
+
+ wasBlocked := OperatingSystem blockInterrupts.
+
+ "
+ debugging consistency check - will be removed later
+ "
+ activeProcess priority ~~ currentPriority ifTrue:[
+ 'oops process changed priority' errorPrintNL.
+ currentPriority := activeProcess priority.
+ ].
+
+ l := quiescentProcessLists at:currentPriority.
+
+ "
+ debugging consistency checks - will be removed later
+ "
+ l isEmpty ifTrue:[
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+ 'oops - empty runnable list' errorPrintNL.
+ ^ self
+ ].
+
+ "
+ check if the running process is not the only one
+ "
+ l size ~~ 1 ifTrue:[
+ "
+ bring running process to the end
+ "
+ l removeFirst.
+ l addLast:activeProcess.
+
+ "
+ and switch to first in the list
+ "
+ self threadSwitch:(l first).
+ ].
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+! !
+
+!ProcessorScheduler methodsFor:'semaphore signalling'!
+
+disableSemaphore:aSemaphore
+ "disable triggering of a semaphore"
+
+ |idx "{ Class: SmallInteger }"
+ wasBlocked|
+
+ wasBlocked := OperatingSystem blockInterrupts.
+ idx := readSemaphoreArray identityIndexOf:aSemaphore startingAt:1.
+ [idx ~~ 0] whileTrue:[
+ readFdArray at:idx put:nil.
+ readSemaphoreArray at:idx put:nil.
+ readCheckArray at:idx put:nil.
+ idx := readSemaphoreArray identityIndexOf:aSemaphore startingAt:idx.
+ ].
+ idx := writeSemaphoreArray identityIndexOf:aSemaphore startingAt:1.
+ [idx ~~ 0] whileTrue:[
+ writeFdArray at:idx put:nil.
+ writeSemaphoreArray at:idx put:nil.
+ idx := writeSemaphoreArray identityIndexOf:aSemaphore startingAt:idx.
+ ].
+ idx := timeoutSemaphoreArray identityIndexOf:aSemaphore startingAt:1.
+ [idx ~~ 0] whileTrue:[
+ timeoutArray at:idx put:nil.
+ timeoutSemaphoreArray at:idx put:nil.
+ timeoutActionArray at:idx put:nil.
+ timeoutProcessArray at:idx put:nil.
+ idx := timeoutSemaphoreArray identityIndexOf:aSemaphore startingAt:idx.
+ ].
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+!
+
+signal:aSemaphore afterMilliseconds:millis
+ "arrange for a semaphore to be triggered after some milliseconds"
+
+ |now then wasBlocked|
+
+ wasBlocked := OperatingSystem blockInterrupts.
+ now := OperatingSystem getMillisecondTime.
+ then := OperatingSystem millisecondTimeAdd:now and:millis rounded.
+ self signal:aSemaphore atMilliseconds:then.
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+!
+
+signal:aSemaphore afterSeconds:seconds
+ "arrange for a semaphore to be triggered after some seconds"
+
+ self signal:aSemaphore afterMilliseconds:(seconds * 1000)
+!
+
+signal:aSemaphore atMilliseconds:aMillisecondTime
+ "arrange for a semaphore to be triggered at a specific millisecond time.
+ If there is already a pending trigger time, the time is changed."
+
+ |index "{ Class: SmallInteger }"
+ wasBlocked|
+
+ wasBlocked := OperatingSystem blockInterrupts.
+ index := timeoutSemaphoreArray identityIndexOf:aSemaphore startingAt:1.
+ index ~~ 0 ifTrue:[
+ timeoutArray at:index put:aMillisecondTime
+ ] ifFalse:[
+ index := timeoutArray identityIndexOf:nil startingAt:1.
+ index ~~ 0 ifTrue:[
+ timeoutSemaphoreArray at:index put:aSemaphore.
+ timeoutArray at:index put:aMillisecondTime.
+ timeoutActionArray at:index put:nil.
+ timeoutProcessArray at:index put:nil
+ ] ifFalse:[
+ timeoutSemaphoreArray := timeoutSemaphoreArray copyWith:aSemaphore.
+ timeoutArray := timeoutArray copyWith:aMillisecondTime.
+ timeoutActionArray := timeoutActionArray copyWith:nil.
+ timeoutProcessArray := timeoutProcessArray copyWith:nil
+ ].
+ ].
+
+ anyTimeouts := true.
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+!
+
+signal:aSemaphore onInput:aFileDescriptor
+ "arrange for a semaphore to be triggered when input on aFileDescriptor
+ arrives."
+
+ self signal:aSemaphore onInput:aFileDescriptor orCheck:nil
+!
+
+signal:aSemaphore onInput:aFileDescriptor orCheck:aBlock
+ "arrange for a semaphore to be triggered when input on aFileDescriptor
+ arrives OR checkblock evaluates to true.
+ (checkBlock is used for buffered input, where a select may not detect
+ data already read into a buffer - as in Xlib)"
+
+ |idx "{ Class: SmallInteger }"
+ wasBlocked|
+
+ wasBlocked := OperatingSystem blockInterrupts.
+ (readFdArray identityIndexOf:aFileDescriptor startingAt:1) == 0 ifTrue:[
+ idx := readFdArray identityIndexOf:nil startingAt:1.
+ idx ~~ 0 ifTrue:[
+ readFdArray at:idx put:aFileDescriptor.
+ readSemaphoreArray at:idx put:aSemaphore.
+ readCheckArray at:idx put:aBlock
+ ] ifFalse:[
+ readFdArray := readFdArray copyWith:aFileDescriptor.
+ readSemaphoreArray := readSemaphoreArray copyWith:aSemaphore.
+ readCheckArray := readCheckArray copyWith:aBlock.
+ ]
+ ].
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+!
+
+signal:aSemaphore onOutput:aFileDescriptor
+ "arrange for a semaphore to be triggered when output on aFileDescriptor
+ is possible. (i.e. can be written without blocking)"
+
+ |idx "{ Class: SmallInteger }"
+ wasBlocked|
+
+ wasBlocked := OperatingSystem blockInterrupts.
+ (writeFdArray identityIndexOf:aFileDescriptor startingAt:1) == 0 ifTrue:[
+ idx := writeFdArray identityIndexOf:nil startingAt:1.
+ idx ~~ 0 ifTrue:[
+ writeFdArray at:idx put:aFileDescriptor.
+ writeSemaphoreArray at:idx put:aSemaphore.
+ ] ifFalse:[
+ writeFdArray := writeFdArray copyWith:aFileDescriptor.
+ writeSemaphoreArray := writeSemaphoreArray copyWith:aSemaphore.
+ ]
+ ].
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+! !
+
+!ProcessorScheduler methodsFor:'timeout handling'!
+
+addTimedBlock:aBlock afterMilliseconds:delta
+ "add the argument, aBlock to the list of time-scheduled-blocks; to be
+ evaluated after delta milliseconds. The process which installs this timed
+ block will be interrupted for execution of the block.
+ (if it is running, the interrupt will occur in whatever method it is
+ executing; if it is suspended, it will be resumed).
+ The block will be removed from the timed-block list after evaluation
+ (i.e. it will trigger only once)."
+
+ ^ self addTimedBlock:aBlock for:activeProcess afterMilliseconds:delta
+!
+
+addTimedBlock:aBlock afterSeconds:delta
+ "add the argument, aBlock to the list of time-scheduled-blocks.
+ to be evaluated after delta seconds. The process which installs this timed
+ block will be interrupted for execution of the block.
+ (if it is running, the interrupt will occur in whatever method it is
+ executing; if it is suspended, it will be resumed).
+ The block will be removed from the timed-block list after evaluation
+ (i.e. it will trigger only once)."
+
+ self addTimedBlock:aBlock for:activeProcess afterMilliseconds:(delta * 1000) rounded
+!
+
+addTimedBlock:aBlock atMilliseconds:aMillisecondTime
+ "add the argument, aBlock to the list of time-scheduled-blocks; to be
+ evaluated when the millisecondClock value passes aMillisecondTime.
+ The process which installs this timed block will be interrupted for
+ execution of the block.
+ (if it is running, the interrupt will occur in whatever method it is
+ executing; if it is suspended, it will be resumed).
+ The block will be removed from the timed-block list after evaluation
+ (i.e. it will trigger only once)."
+
+ self addTimedBlock:aBlock for:activeProcess atMilliseconds:aMillisecondTime
+!
+
+addTimedBlock:aBlock for:aProcess afterMilliseconds:delta
+ "add the argument, aBlock to the list of time-scheduled-blocks; to be
+ evaluated after delta milliseconds. The process specified by the argument,
+ aProcess will be interrupted for execution of the block.
+ (if it is running, the interrupt will occur in whatever method it is
+ executing; if it is suspended, it will be resumed).
+ If aProcess is nil, the block will be evaluated by the scheduler itself
+ (which is dangerous - the block should not raise any error conditions).
+ The block will be removed from the timed-block list after evaluation
+ (i.e. it will trigger only once)."
+
+ |now then wasBlocked|
+
+ wasBlocked := OperatingSystem blockInterrupts.
+ now := OperatingSystem getMillisecondTime.
+ then := OperatingSystem millisecondTimeAdd:now and:delta.
+ self addTimedBlock:aBlock for:aProcess atMilliseconds:then.
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+!
+
+addTimedBlock:aBlock for:aProcess afterSeconds:delta
+ "add the argument, aBlock to the list of time-scheduled-blocks.
+ to be evaluated after delta seconds. aProcess will be interrupted for
+ execution of the block.
+ (if it is running, the interrupt will occur in whatever method it is
+ executing; if it is suspended, it will be resumed).
+ If aProcess is nil, the block will be evaluated by the scheduler itself
+ (which is dangerous - the block should not raise any error conditions).
+ The block will be removed from the timed-block list after evaluation
+ (i.e. it will trigger only once)."
+
+ self addTimedBlock:aBlock for:aProcess afterMilliseconds:(delta * 1000) rounded
+!
+
+addTimedBlock:aBlock for:aProcess atMilliseconds:aMillisecondTime
+ "add the argument, aBlock to the list of time-scheduled-blocks; to be
+ evaluated by aProcess when the millisecondClock value passes
+ aMillisecondTime.
+ If that block is already in the timeout list,
+ its trigger-time is changed.
+ The process specified by the argument, aProcess will be interrupted
+ for execution of the block.
+ If aProcess is nil, the block will be evaluated by the scheduler itself
+ (which is dangerous - the block should not raise any error conditions).
+ If the process is active at trigger time, the interrupt will occur in
+ whatever method it is executing; if suspended at trigger time, it will be
+ resumed.
+ The block will be removed from the timed-block list after evaluation
+ (i.e. it will trigger only once)."
+
+ |index "{ Class: SmallInteger }"
+ wasBlocked|
+
+ wasBlocked := OperatingSystem blockInterrupts.
+ index := timeoutActionArray identityIndexOf:aBlock startingAt:1.
+ index ~~ 0 ifTrue:[
+ timeoutArray at:index put:aMillisecondTime
+ ] ifFalse:[
+ index := timeoutArray indexOf:nil.
+ index ~~ 0 ifTrue:[
+ timeoutArray at:index put:aMillisecondTime.
+ timeoutActionArray at:index put:aBlock.
+ timeoutSemaphoreArray at:index put:nil.
+ timeoutProcessArray at:index put:aProcess
+ ] ifFalse:[
+ timeoutArray := timeoutArray copyWith:aMillisecondTime.
+ timeoutActionArray := timeoutActionArray copyWith:aBlock.
+ timeoutSemaphoreArray := timeoutSemaphoreArray copyWith:nil.
+ timeoutProcessArray := timeoutProcessArray copyWith:aProcess.
+ ].
+ ].
+
+ anyTimeouts := true.
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+!
+
+evaluateTimeouts
+ "walk through timeouts and evaluate blocks or signal semas that need to be .."
+
+ |sema now aTime block blocksToEvaluate
+ processes n "{ Class: SmallInteger }"|
+
+ anyTimeouts ifFalse:[ ^ self].
+
+ "have to collect the blocks first, then evaluate them. This avoids
+ problems due to newly inserted blocks."
+
+ now := OperatingSystem getMillisecondTime.
+ blocksToEvaluate := nil.
+ n := timeoutArray size.
+ anyTimeouts := false.
+ 1 to:n do:[:index |
+ aTime := timeoutArray at:index.
+ aTime notNil ifTrue:[
+ (OperatingSystem millisecondTime:aTime isAfter:now) ifFalse:[
+ "this one should be triggered"
+
+ sema := timeoutSemaphoreArray at:index.
+ sema notNil ifTrue:[
+ sema signalOnce.
+ timeoutSemaphoreArray at:index put:nil
+ ] ifFalse:[
+ "to support pure-events"
+ block := timeoutActionArray at:index.
+ block notNil ifTrue:[
+ blocksToEvaluate isNil ifTrue:[
+ blocksToEvaluate := OrderedCollection new:10.
+ processes := OrderedCollection new:10.
+ ].
+ blocksToEvaluate add:block.
+ processes add:(timeoutProcessArray at:index).
+ timeoutActionArray at:index put:nil.
+ timeoutProcessArray at:index put:nil.
+ ]
+ ].
+ timeoutArray at:index put:nil.
+ ] ifTrue:[
+ anyTimeouts := true
+ ]
+ ]
+ ].
+
+ blocksToEvaluate notNil ifTrue:[
+ blocksToEvaluate keysAndValuesDo:[:index :block |
+ |p|
+
+ p := processes at:index.
+ (p isNil or:[p == scheduler or:[PureEventDriven]]) ifTrue:[
+ block value
+ ] ifFalse:[
+ p interruptWith:block
+ ]
+ ]
+ ]
+!
+
+removeTimedBlock:aBlock
+ "remove the argument, aBlock from the list of time-sceduled-blocks."
+
+ |index "{ Class: SmallInteger }"
+ wasBlocked|
+
+ wasBlocked := OperatingSystem blockInterrupts.
+ index := timeoutActionArray identityIndexOf:aBlock startingAt:1.
+ (index ~~ 0) ifTrue:[
+ timeoutArray at:index put:nil.
+ timeoutActionArray at:index put:nil.
+ timeoutSemaphoreArray at:index put:nil.
+ timeoutProcessArray at:index put:nil.
+ ].
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
! !
!ProcessorScheduler methodsFor:'waiting'!
+checkForInputWithTimeout:millis
+ "this is called, when there is absolutely nothing to do;
+ hard wait for either input to arrive or a timeout to occur."
+
+ |fd index sema action|
+
+ fd := OperatingSystem
+ selectOnAnyReadable:readFdArray
+ writable:writeFdArray
+ exception:nil
+ withTimeOut:millis.
+ fd notNil ifTrue:[
+ index := readFdArray indexOf:fd.
+ index ~~ 0 ifTrue:[
+ sema := readSemaphoreArray at:index.
+ sema notNil ifTrue:[
+ sema signalOnce.
+ ^ true
+ ] ifFalse:[
+ action := readCheckArray at:index.
+ action notNil ifTrue:[
+ action value.
+ ^ true
+ ]
+ ]
+ ]
+ ].
+ ^ false
+!
+
ioInterrupt
"data arrived while waiting - switch to scheduler process which will decide
what to do now."
@@ -1223,14 +1643,6 @@
self threadSwitch:scheduler
!
-timerInterrupt
- "timer expired while waiting - switch to scheduler process which will decide
- what to do now."
-
- interruptedProcess := activeProcess.
- self threadSwitch:scheduler
-!
-
timeToNextTimeout
"return the delta-T (in millis) to next timeout, or nil if
there is none"
@@ -1261,6 +1673,14 @@
^ minDelta
!
+timerInterrupt
+ "timer expired while waiting - switch to scheduler process which will decide
+ what to do now."
+
+ interruptedProcess := activeProcess.
+ self threadSwitch:scheduler
+!
+
waitForEventOrTimeout
"entered when no process is runnable - wait for either input on
any file descriptors to arrive or a timeout to happen.
@@ -1325,438 +1745,11 @@
millis := millis rounded
].
self checkForInputWithTimeout:millis
-!
-
-checkForInputWithTimeout:millis
- "this is called, when there is absolutely nothing to do;
- hard wait for either input to arrive or a timeout to occur."
-
- |fd index sema action|
-
- fd := OperatingSystem
- selectOnAnyReadable:readFdArray
- writable:writeFdArray
- exception:nil
- withTimeOut:millis.
- fd notNil ifTrue:[
- index := readFdArray indexOf:fd.
- index ~~ 0 ifTrue:[
- sema := readSemaphoreArray at:index.
- sema notNil ifTrue:[
- sema signalOnce.
- ^ true
- ] ifFalse:[
- action := readCheckArray at:index.
- action notNil ifTrue:[
- action value.
- ^ true
- ]
- ]
- ]
- ].
- ^ false
-! !
-
-!ProcessorScheduler methodsFor:'semaphore signalling'!
-
-signal:aSemaphore onInput:aFileDescriptor
- "arrange for a semaphore to be triggered when input on aFileDescriptor
- arrives."
-
- self signal:aSemaphore onInput:aFileDescriptor orCheck:nil
-!
-
-signal:aSemaphore onInput:aFileDescriptor orCheck:aBlock
- "arrange for a semaphore to be triggered when input on aFileDescriptor
- arrives OR checkblock evaluates to true.
- (checkBlock is used for buffered input, where a select may not detect
- data already read into a buffer - as in Xlib)"
-
- |idx "{ Class: SmallInteger }"
- wasBlocked|
-
- wasBlocked := OperatingSystem blockInterrupts.
- (readFdArray identityIndexOf:aFileDescriptor startingAt:1) == 0 ifTrue:[
- idx := readFdArray identityIndexOf:nil startingAt:1.
- idx ~~ 0 ifTrue:[
- readFdArray at:idx put:aFileDescriptor.
- readSemaphoreArray at:idx put:aSemaphore.
- readCheckArray at:idx put:aBlock
- ] ifFalse:[
- readFdArray := readFdArray copyWith:aFileDescriptor.
- readSemaphoreArray := readSemaphoreArray copyWith:aSemaphore.
- readCheckArray := readCheckArray copyWith:aBlock.
- ]
- ].
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
-!
-
-signal:aSemaphore onOutput:aFileDescriptor
- "arrange for a semaphore to be triggered when output on aFileDescriptor
- is possible. (i.e. can be written without blocking)"
-
- |idx "{ Class: SmallInteger }"
- wasBlocked|
-
- wasBlocked := OperatingSystem blockInterrupts.
- (writeFdArray identityIndexOf:aFileDescriptor startingAt:1) == 0 ifTrue:[
- idx := writeFdArray identityIndexOf:nil startingAt:1.
- idx ~~ 0 ifTrue:[
- writeFdArray at:idx put:aFileDescriptor.
- writeSemaphoreArray at:idx put:aSemaphore.
- ] ifFalse:[
- writeFdArray := writeFdArray copyWith:aFileDescriptor.
- writeSemaphoreArray := writeSemaphoreArray copyWith:aSemaphore.
- ]
- ].
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
-!
-
-signal:aSemaphore afterSeconds:seconds
- "arrange for a semaphore to be triggered after some seconds"
-
- self signal:aSemaphore afterMilliseconds:(seconds * 1000)
-!
-
-signal:aSemaphore afterMilliseconds:millis
- "arrange for a semaphore to be triggered after some milliseconds"
-
- |now then wasBlocked|
-
- wasBlocked := OperatingSystem blockInterrupts.
- now := OperatingSystem getMillisecondTime.
- then := OperatingSystem millisecondTimeAdd:now and:millis rounded.
- self signal:aSemaphore atMilliseconds:then.
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
-!
-
-signal:aSemaphore atMilliseconds:aMillisecondTime
- "arrange for a semaphore to be triggered at a specific millisecond time.
- If there is already a pending trigger time, the time is changed."
-
- |index "{ Class: SmallInteger }"
- wasBlocked|
-
- wasBlocked := OperatingSystem blockInterrupts.
- index := timeoutSemaphoreArray identityIndexOf:aSemaphore startingAt:1.
- index ~~ 0 ifTrue:[
- timeoutArray at:index put:aMillisecondTime
- ] ifFalse:[
- index := timeoutArray identityIndexOf:nil startingAt:1.
- index ~~ 0 ifTrue:[
- timeoutSemaphoreArray at:index put:aSemaphore.
- timeoutArray at:index put:aMillisecondTime.
- timeoutActionArray at:index put:nil.
- timeoutProcessArray at:index put:nil
- ] ifFalse:[
- timeoutSemaphoreArray := timeoutSemaphoreArray copyWith:aSemaphore.
- timeoutArray := timeoutArray copyWith:aMillisecondTime.
- timeoutActionArray := timeoutActionArray copyWith:nil.
- timeoutProcessArray := timeoutProcessArray copyWith:nil
- ].
- ].
-
- anyTimeouts := true.
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
-!
-
-disableSemaphore:aSemaphore
- "disable triggering of a semaphore"
-
- |idx "{ Class: SmallInteger }"
- wasBlocked|
-
- wasBlocked := OperatingSystem blockInterrupts.
- idx := readSemaphoreArray identityIndexOf:aSemaphore startingAt:1.
- [idx ~~ 0] whileTrue:[
- readFdArray at:idx put:nil.
- readSemaphoreArray at:idx put:nil.
- readCheckArray at:idx put:nil.
- idx := readSemaphoreArray identityIndexOf:aSemaphore startingAt:idx.
- ].
- idx := writeSemaphoreArray identityIndexOf:aSemaphore startingAt:1.
- [idx ~~ 0] whileTrue:[
- writeFdArray at:idx put:nil.
- writeSemaphoreArray at:idx put:nil.
- idx := writeSemaphoreArray identityIndexOf:aSemaphore startingAt:idx.
- ].
- idx := timeoutSemaphoreArray identityIndexOf:aSemaphore startingAt:1.
- [idx ~~ 0] whileTrue:[
- timeoutArray at:idx put:nil.
- timeoutSemaphoreArray at:idx put:nil.
- timeoutActionArray at:idx put:nil.
- timeoutProcessArray at:idx put:nil.
- idx := timeoutSemaphoreArray identityIndexOf:aSemaphore startingAt:idx.
- ].
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
-! !
-
-!ProcessorScheduler methodsFor:'background processing'!
-
-addIdleBlock:aBlock
- "add the argument, aBlock to the list of idle-actions.
- Idle blocks are evaluated whenever no other process is runnable,
- and no events are pending.
- Use of idle blocks is not recommended, use a low priority processes
- instead, which has the same effect. Idle blcoks are still included
- to support background actions in pure-event systems, where no processes
- are available.
- Support for idle-blocks may vanish."
-
- |wasBlocked|
-
- wasBlocked := OperatingSystem blockInterrupts.
- idleActions isNil ifTrue:[
- idleActions := OrderedCollection new
- ].
- idleActions add:aBlock.
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
-!
-
-removeIdleBlock:aBlock
- "remove the argument, aBlock from the list of idle-blocks.
- Support for idle-blocks may vanish - use low prio processes instead."
-
- |wasBlocked|
-
- wasBlocked := OperatingSystem blockInterrupts.
- idleActions notNil ifTrue:[
- idleActions remove:aBlock
- ].
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
! !
-!ProcessorScheduler methodsFor:'I/O event actions'!
-
-enableIOAction:aBlock onInput:aFileDescriptor
- "half-obsolete event support: arrange for aBlock to be
- evaluated when input on aFileDescriptor arrives.
- This is a leftover support for pure-event systems and may vanish."
-
- |idx "{Class: SmallInteger }"
- wasBlocked|
-
- wasBlocked := OperatingSystem blockInterrupts.
- (readFdArray identityIndexOf:aFileDescriptor startingAt:1) == 0 ifTrue:[
- idx := readFdArray identityIndexOf:nil startingAt:1.
- idx ~~ 0 ifTrue:[
- readFdArray at:idx put:aFileDescriptor.
- readCheckArray at:idx put:aBlock.
- readSemaphoreArray at:idx put:nil
- ] ifFalse:[
- readFdArray := readFdArray copyWith:aFileDescriptor.
- readCheckArray := readCheckArray copyWith:aBlock.
- readSemaphoreArray := readSemaphoreArray copyWith:nil.
- ]
- ].
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
-!
-
-disableFd:aFileDescriptor
- "disable block events on aFileDescriptor.
- This is a leftover support for pure-event systems and may vanish."
-
- |idx "{Class: SmallInteger }"
- wasBlocked|
-
- wasBlocked := OperatingSystem blockInterrupts.
- idx := readFdArray identityIndexOf:aFileDescriptor startingAt:1.
- idx ~~ 0 ifTrue:[
- readFdArray at:idx put:nil.
- readCheckArray at:idx put:nil.
- readSemaphoreArray at:idx put:nil
- ].
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
-! !
-
-!ProcessorScheduler methodsFor:'timeout handling'!
-
-addTimedBlock:aBlock afterSeconds:delta
- "add the argument, aBlock to the list of time-scheduled-blocks.
- to be evaluated after delta seconds. The process which installs this timed
- block will be interrupted for execution of the block.
- (if it is running, the interrupt will occur in whatever method it is
- executing; if it is suspended, it will be resumed).
- The block will be removed from the timed-block list after evaluation
- (i.e. it will trigger only once)."
-
- self addTimedBlock:aBlock for:activeProcess afterMilliseconds:(delta * 1000) rounded
-!
-
-addTimedBlock:aBlock for:aProcess afterSeconds:delta
- "add the argument, aBlock to the list of time-scheduled-blocks.
- to be evaluated after delta seconds. aProcess will be interrupted for
- execution of the block.
- (if it is running, the interrupt will occur in whatever method it is
- executing; if it is suspended, it will be resumed).
- If aProcess is nil, the block will be evaluated by the scheduler itself
- (which is dangerous - the block should not raise any error conditions).
- The block will be removed from the timed-block list after evaluation
- (i.e. it will trigger only once)."
-
- self addTimedBlock:aBlock for:aProcess afterMilliseconds:(delta * 1000) rounded
-!
-
-addTimedBlock:aBlock afterMilliseconds:delta
- "add the argument, aBlock to the list of time-scheduled-blocks; to be
- evaluated after delta milliseconds. The process which installs this timed
- block will be interrupted for execution of the block.
- (if it is running, the interrupt will occur in whatever method it is
- executing; if it is suspended, it will be resumed).
- The block will be removed from the timed-block list after evaluation
- (i.e. it will trigger only once)."
-
- ^ self addTimedBlock:aBlock for:activeProcess afterMilliseconds:delta
-!
-
-addTimedBlock:aBlock for:aProcess afterMilliseconds:delta
- "add the argument, aBlock to the list of time-scheduled-blocks; to be
- evaluated after delta milliseconds. The process specified by the argument,
- aProcess will be interrupted for execution of the block.
- (if it is running, the interrupt will occur in whatever method it is
- executing; if it is suspended, it will be resumed).
- If aProcess is nil, the block will be evaluated by the scheduler itself
- (which is dangerous - the block should not raise any error conditions).
- The block will be removed from the timed-block list after evaluation
- (i.e. it will trigger only once)."
-
- |now then wasBlocked|
-
- wasBlocked := OperatingSystem blockInterrupts.
- now := OperatingSystem getMillisecondTime.
- then := OperatingSystem millisecondTimeAdd:now and:delta.
- self addTimedBlock:aBlock for:aProcess atMilliseconds:then.
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
-!
-
-addTimedBlock:aBlock atMilliseconds:aMillisecondTime
- "add the argument, aBlock to the list of time-scheduled-blocks; to be
- evaluated when the millisecondClock value passes aMillisecondTime.
- The process which installs this timed block will be interrupted for
- execution of the block.
- (if it is running, the interrupt will occur in whatever method it is
- executing; if it is suspended, it will be resumed).
- The block will be removed from the timed-block list after evaluation
- (i.e. it will trigger only once)."
-
- self addTimedBlock:aBlock for:activeProcess atMilliseconds:aMillisecondTime
-!
+!ProcessorScheduler class methodsFor:'documentation'!
-addTimedBlock:aBlock for:aProcess atMilliseconds:aMillisecondTime
- "add the argument, aBlock to the list of time-scheduled-blocks; to be
- evaluated by aProcess when the millisecondClock value passes
- aMillisecondTime.
- If that block is already in the timeout list,
- its trigger-time is changed.
- The process specified by the argument, aProcess will be interrupted
- for execution of the block.
- If aProcess is nil, the block will be evaluated by the scheduler itself
- (which is dangerous - the block should not raise any error conditions).
- If the process is active at trigger time, the interrupt will occur in
- whatever method it is executing; if suspended at trigger time, it will be
- resumed.
- The block will be removed from the timed-block list after evaluation
- (i.e. it will trigger only once)."
-
- |index "{ Class: SmallInteger }"
- wasBlocked|
-
- wasBlocked := OperatingSystem blockInterrupts.
- index := timeoutActionArray identityIndexOf:aBlock startingAt:1.
- index ~~ 0 ifTrue:[
- timeoutArray at:index put:aMillisecondTime
- ] ifFalse:[
- index := timeoutArray indexOf:nil.
- index ~~ 0 ifTrue:[
- timeoutArray at:index put:aMillisecondTime.
- timeoutActionArray at:index put:aBlock.
- timeoutSemaphoreArray at:index put:nil.
- timeoutProcessArray at:index put:aProcess
- ] ifFalse:[
- timeoutArray := timeoutArray copyWith:aMillisecondTime.
- timeoutActionArray := timeoutActionArray copyWith:aBlock.
- timeoutSemaphoreArray := timeoutSemaphoreArray copyWith:nil.
- timeoutProcessArray := timeoutProcessArray copyWith:aProcess.
- ].
- ].
-
- anyTimeouts := true.
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
-!
-
-removeTimedBlock:aBlock
- "remove the argument, aBlock from the list of time-sceduled-blocks."
-
- |index "{ Class: SmallInteger }"
- wasBlocked|
-
- wasBlocked := OperatingSystem blockInterrupts.
- index := timeoutActionArray identityIndexOf:aBlock startingAt:1.
- (index ~~ 0) ifTrue:[
- timeoutArray at:index put:nil.
- timeoutActionArray at:index put:nil.
- timeoutSemaphoreArray at:index put:nil.
- timeoutProcessArray at:index put:nil.
- ].
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
-!
-
-evaluateTimeouts
- "walk through timeouts and evaluate blocks or signal semas that need to be .."
-
- |sema now aTime block blocksToEvaluate
- processes n "{ Class: SmallInteger }"|
-
- anyTimeouts ifFalse:[ ^ self].
-
- "have to collect the blocks first, then evaluate them. This avoids
- problems due to newly inserted blocks."
-
- now := OperatingSystem getMillisecondTime.
- blocksToEvaluate := nil.
- n := timeoutArray size.
- anyTimeouts := false.
- 1 to:n do:[:index |
- aTime := timeoutArray at:index.
- aTime notNil ifTrue:[
- (OperatingSystem millisecondTime:aTime isAfter:now) ifFalse:[
- "this one should be triggered"
-
- sema := timeoutSemaphoreArray at:index.
- sema notNil ifTrue:[
- sema signalOnce.
- timeoutSemaphoreArray at:index put:nil
- ] ifFalse:[
- "to support pure-events"
- block := timeoutActionArray at:index.
- block notNil ifTrue:[
- blocksToEvaluate isNil ifTrue:[
- blocksToEvaluate := OrderedCollection new:10.
- processes := OrderedCollection new:10.
- ].
- blocksToEvaluate add:block.
- processes add:(timeoutProcessArray at:index).
- timeoutActionArray at:index put:nil.
- timeoutProcessArray at:index put:nil.
- ]
- ].
- timeoutArray at:index put:nil.
- ] ifTrue:[
- anyTimeouts := true
- ]
- ]
- ].
-
- blocksToEvaluate notNil ifTrue:[
- blocksToEvaluate keysAndValuesDo:[:index :block |
- |p|
-
- p := processes at:index.
- (p isNil or:[p == scheduler or:[PureEventDriven]]) ifTrue:[
- block value
- ] ifFalse:[
- p interruptWith:block
- ]
- ]
- ]
+version
+ ^ '$Header: /cvs/stx/stx/libbasic/Attic/ProcSched.st,v 1.53 1995-12-07 21:29:55 cg Exp $'
! !
+ProcessorScheduler initialize!
--- a/Process.st Thu Dec 07 22:24:46 1995 +0100
+++ b/Process.st Thu Dec 07 22:32:39 1995 +0100
@@ -11,10 +11,9 @@
"
Link subclass:#Process
- instanceVariableNames:'id prio state startBlock name
- restartable interruptActions
- exitActions suspendSemaphore
- singleStepping emergencySignalHandler'
+ instanceVariableNames:'id prio state startBlock name restartable interruptActions
+ exitActions suspendSemaphore singleStepping
+ emergencySignalHandler'
classVariableNames:'TerminateSignal CoughtSignals'
poolDictionaries:''
category:'Kernel-Processes'
@@ -36,10 +35,6 @@
"
!
-version
- ^ '$Header: /cvs/stx/stx/libbasic/Process.st,v 1.35 1995-11-13 09:08:17 stefan Exp $'
-!
-
documentation
"
Instances of Process represent lightweight smalltalk processes
@@ -203,6 +198,16 @@
]
! !
+!Process class methodsFor:'instance creation'!
+
+for:aBlock priority:aPrio
+ "create a new (unscheduled) process which will execute aBlock at
+ a given priority, once scheduled. The process will start execution once
+ it gets a #resume-message."
+
+ ^ self new for:aBlock priority:aPrio
+! !
+
!Process class methodsFor:'Signal constants'!
terminateSignal
@@ -211,14 +216,302 @@
^ TerminateSignal
! !
-!Process class methodsFor:'instance creation'!
+!Process methodsFor:'accessing'!
+
+changePriority:aNumber
+ "same as priority:, but returns the old priority.
+ (cannot do this in priority: for ST-80 compatibility)"
+
+ |oldPrio|
+
+ oldPrio := prio.
+ Processor changePriority:aNumber for:self.
+ ^ oldPrio
+!
+
+emergencySignalHandler
+ "return the emergencySignalHandler block.
+ See Signal>>documentation for more info."
+
+ ^ emergencySignalHandler
+!
+
+emergencySignalHandler:aOneArgBlock
+ "set the emergencySignalHandler block.
+ See Signal>>documentation for more info."
+
+ emergencySignalHandler := aOneArgBlock
+!
+
+exitAction:aBlock
+ "add aBlock to the processes exit actions.
+ This will be evaluated right before the process dies."
+
+ exitActions isNil ifTrue:[
+ exitActions := OrderedCollection new
+ ].
+ exitActions add:aBlock
+!
+
+id
+ "return the processes id"
+
+ ^ id
+!
+
+isDead
+ "return true, if the receiver has already terminated"
+
+ ^ state == #dead
+!
+
+isRestartable
+ "return true, iff the receiver is restartable"
+
+ ^ restartable
+!
+
+isSingleStepping
+ ^ singleStepping
+!
+
+maximumStackSize
+ "returns the processes stack limit - i.e. the process will be
+ interrupted with a recursionSignal-raise, if it ever
+ needs more stack (in bytes) than this number"
+
+%{ /* NOCONTEXT */
+ extern int __threadMaxStackSize();
+ OBJ i;
+
+ if (__isSmallInteger(i = _INST(id))) {
+ RETURN( _MKSMALLINT(__threadMaxStackSize(_intVal(i))) );
+ }
+%}.
+ ^ nil
+!
+
+name
+ "return the processes name"
+
+ ^ name
+!
+
+name:aString
+ "set the processes name"
+
+ name := aString
+!
+
+nameOrId
+ "return a string to identify the process - either name or id"
+
+ name notNil ifTrue:[^ name].
+ ^ id printString
+!
+
+priority
+ "return the receivers priority"
+
+ ^ prio
+!
+
+priority:aNumber
+ "set my priority"
+
+ Processor changePriority:aNumber for:self.
+!
+
+restartable:aBoolean
+ "set/clear, the restartable flag.
+ Restartable processes will automatically be restarted by the
+ ProcessorScheduler upon image restart. Others have to be restarted
+ manually."
+
+ startBlock isNil ifTrue:[
+ self error:'cannot be made restartable when already started'.
+ ^ self
+ ].
+ restartable := aBoolean
+!
+
+setMaximumStackSize:limit
+ "sets the processes stack limit - i.e. the process will be
+ interrupted with a recursionSignal-raise, if it ever
+ needs more stack (in bytes) than this number.
+ Returns the old value."
+
+%{ /* NOCONTEXT */
+ extern int __threadSetMaxStackSize();
+ OBJ i;
+
+ if (__isSmallInteger(i = _INST(id))
+ && __isSmallInteger(limit) ) {
+ RETURN ( _MKSMALLINT(__threadSetMaxStackSize(_intVal(i), _intVal(limit))) );
+ }
+%}.
+ ^ nil
+!
+
+singleStep:aBoolean
+ singleStepping := aBoolean
+!
+
+startBlock
+ "return the processes startup-block"
+
+ ^ startBlock
+!
-for:aBlock priority:aPrio
- "create a new (unscheduled) process which will execute aBlock at
- a given priority, once scheduled. The process will start execution once
- it gets a #resume-message."
+state
+ "return a symbol describing the processes state"
+
+ ^ state
+!
+
+state:aSymbol
+ "set the state - only to be used from scheduler"
+
+ state := aSymbol
+!
+
+suspendedContext
+ "return the processes suspended context
+ - this is the context from which a process switch into the scheduler
+ or another process occured.
+ Typically, only the debugger is interrested in this one."
+
+%{ /* NOCONTEXT */
+ extern OBJ __threadContext();
+ OBJ i;
+
+ if (__isSmallInteger(i = _INST(id))) {
+ RETURN (__threadContext(_intVal(i)));
+ }
+%}.
+ ^ nil
+! !
+
+!Process methodsFor:'interrupts'!
+
+interrupt
+ "evaluate my interrupt-actions
+ the process will go back to where it got interrupted
+ after doing this.
+ "
+ |action|
+
+ [interruptActions notNil and:[interruptActions notEmpty]] whileTrue:[
+ action := interruptActions removeFirst.
+ action value
+ ].
+ interruptActions := nil
+!
+
+interruptWith:aBlock
+ "interrupt the receiver and make it evaluate aBlock.
+ If the receiver is currently suspended, the block will be remembered
+ to be evaluated once the receiver wakes up."
+
+ self uninterruptablyDo:[
+ interruptActions isNil ifTrue:[
+ interruptActions := OrderedCollection with:aBlock.
+ ] ifFalse:[
+ interruptActions addLast:aBlock.
+ ].
+ ].
+ Processor scheduleForInterrupt:self.
+! !
+
+!Process methodsFor:'monitoring'!
+
+numberOfStackBoundaryHits
+ "internal monitoring only - will vanish"
+
+%{ /* NOCONTEXT */
+ extern int __threadNumberOfStackBoundaryHits();
+ int n;
+ OBJ i;
- ^ self new for:aBlock priority:aPrio
+ if (__isSmallInteger(i = _INST(id))) {
+ n = __threadNumberOfStackBoundaryHits(_intVal(i));
+ n &= 0x3FFFFFFF;
+ RETURN( _MKSMALLINT(n) );
+ }
+%}.
+ ^ nil
+!
+
+numberOfStackSegments
+ "return the processes number of stack segments currently used.
+ This method is for monitoring purposes only - it may vanish."
+
+%{ /* NOCONTEXT */
+ extern int __threadTotalStackSize();
+ OBJ i;
+
+ if (__isSmallInteger(i = _INST(id))) {
+ RETURN( _MKSMALLINT(__threadStackSegments(_intVal(i))) );
+ }
+%}.
+ ^ nil
+!
+
+totalStackSize
+ "return the processes maximum used stack size.
+ This method is for monitoring purposes only - it may vanish."
+
+%{ /* NOCONTEXT */
+ extern int __threadTotalStackSize();
+ OBJ i;
+
+ if (__isSmallInteger(i = _INST(id))) {
+ RETURN( _MKSMALLINT(__threadTotalStackSize(_intVal(i))) );
+ }
+%}.
+ ^ nil
+!
+
+usedStackSize
+ "Return the processes current stack size.
+ This method is for monitoring purposes only - it may vanish."
+
+%{ /* NOCONTEXT */
+ extern int __threadUsedStackSize();
+ OBJ i;
+
+ if (__isSmallInteger(i = _INST(id))) {
+ RETURN( _MKSMALLINT(__threadUsedStackSize(_intVal(i))) );
+ }
+%}.
+ ^ nil
+!
+
+vmTrace:aBoolean
+ "turn on/off VM message tracing for the receiver.
+ This is meant for ST/X debugging, and may vanish.
+ Expect lots of output, once this is turned on."
+
+%{ /* NOCONTEXT */
+ OBJ i;
+
+ if (__isSmallInteger(i = _INST(id))) {
+ __threadTracing(_intVal(i), aBoolean);
+ }
+%}.
+! !
+
+!Process methodsFor:'printing & storing'!
+
+printOn:aStream
+ "a little more info in my printed representation"
+
+ aStream nextPutAll:state article;
+ space;
+ nextPutAll:state;
+ nextPutAll:' Process (';
+ nextPutAll:self nameOrId;
+ nextPutAll:')'
! !
!Process methodsFor:'private'!
@@ -254,262 +547,15 @@
]
! !
-!Process methodsFor:'accessing'!
-
-state
- "return a symbol describing the processes state"
-
- ^ state
-!
-
-state:aSymbol
- "set the state - only to be used from scheduler"
-
- state := aSymbol
-!
-
-isDead
- "return true, if the receiver has already terminated"
-
- ^ state == #dead
-!
-
-startBlock
- "return the processes startup-block"
-
- ^ startBlock
-!
-
-emergencySignalHandler:aOneArgBlock
- "set the emergencySignalHandler block.
- See Signal>>documentation for more info."
-
- emergencySignalHandler := aOneArgBlock
-!
-
-emergencySignalHandler
- "return the emergencySignalHandler block.
- See Signal>>documentation for more info."
-
- ^ emergencySignalHandler
-!
-
-priority
- "return the receivers priority"
-
- ^ prio
-!
-
-priority:aNumber
- "set my priority"
-
- Processor changePriority:aNumber for:self.
-!
-
-isRestartable
- "return true, iff the receiver is restartable"
-
- ^ restartable
-!
-
-restartable:aBoolean
- "set/clear, the restartable flag.
- Restartable processes will automatically be restarted by the
- ProcessorScheduler upon image restart. Others have to be restarted
- manually."
-
- startBlock isNil ifTrue:[
- self error:'cannot be made restartable when already started'.
- ^ self
- ].
- restartable := aBoolean
-!
-
-changePriority:aNumber
- "same as priority:, but returns the old priority.
- (cannot do this in priority: for ST-80 compatibility)"
-
- |oldPrio|
-
- oldPrio := prio.
- Processor changePriority:aNumber for:self.
- ^ oldPrio
-!
-
-isSingleStepping
- ^ singleStepping
-!
-
-singleStep:aBoolean
- singleStepping := aBoolean
-!
-
-id
- "return the processes id"
-
- ^ id
-!
-
-name
- "return the processes name"
-
- ^ name
-!
-
-name:aString
- "set the processes name"
-
- name := aString
-!
-
-nameOrId
- "return a string to identify the process - either name or id"
-
- name notNil ifTrue:[^ name].
- ^ id printString
-!
-
-exitAction:aBlock
- "add aBlock to the processes exit actions.
- This will be evaluated right before the process dies."
-
- exitActions isNil ifTrue:[
- exitActions := OrderedCollection new
- ].
- exitActions add:aBlock
-!
+!Process methodsFor:'private scheduler access'!
-suspendedContext
- "return the processes suspended context
- - this is the context from which a process switch into the scheduler
- or another process occured.
- Typically, only the debugger is interrested in this one."
-
-%{ /* NOCONTEXT */
- extern OBJ __threadContext();
- OBJ i;
-
- if (__isSmallInteger(i = _INST(id))) {
- RETURN (__threadContext(_intVal(i)));
- }
-%}.
- ^ nil
-!
-
-maximumStackSize
- "returns the processes stack limit - i.e. the process will be
- interrupted with a recursionSignal-raise, if it ever
- needs more stack (in bytes) than this number"
-
-%{ /* NOCONTEXT */
- extern int __threadMaxStackSize();
- OBJ i;
-
- if (__isSmallInteger(i = _INST(id))) {
- RETURN( _MKSMALLINT(__threadMaxStackSize(_intVal(i))) );
- }
-%}.
- ^ nil
-!
-
-setMaximumStackSize:limit
- "sets the processes stack limit - i.e. the process will be
- interrupted with a recursionSignal-raise, if it ever
- needs more stack (in bytes) than this number.
- Returns the old value."
-
-%{ /* NOCONTEXT */
- extern int __threadSetMaxStackSize();
- OBJ i;
-
- if (__isSmallInteger(i = _INST(id))
- && __isSmallInteger(limit) ) {
- RETURN ( _MKSMALLINT(__threadSetMaxStackSize(_intVal(i), _intVal(limit))) );
- }
-%}.
- ^ nil
-! !
-
-!Process methodsFor:'monitoring'!
-
-vmTrace:aBoolean
- "turn on/off VM message tracing for the receiver.
- This is meant for ST/X debugging, and may vanish.
- Expect lots of output, once this is turned on."
-
-%{ /* NOCONTEXT */
- OBJ i;
+setId:idNumber state:stateSymbol
+ "set id and state - not for public use"
- 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."
-
-%{ /* NOCONTEXT */
- extern int __threadUsedStackSize();
- OBJ i;
-
- if (__isSmallInteger(i = _INST(id))) {
- RETURN( _MKSMALLINT(__threadUsedStackSize(_intVal(i))) );
- }
-%}.
- ^ nil
-!
-
-totalStackSize
- "return the processes maximum used stack size.
- This method is for monitoring purposes only - it may vanish."
-
-%{ /* NOCONTEXT */
- extern int __threadTotalStackSize();
- OBJ i;
-
- if (__isSmallInteger(i = _INST(id))) {
- RETURN( _MKSMALLINT(__threadTotalStackSize(_intVal(i))) );
- }
-%}.
- ^ nil
+ id := idNumber.
+ state := stateSymbol.
!
-numberOfStackSegments
- "return the processes number of stack segments currently used.
- This method is for monitoring purposes only - it may vanish."
-
-%{ /* NOCONTEXT */
- extern int __threadTotalStackSize();
- OBJ i;
-
- if (__isSmallInteger(i = _INST(id))) {
- RETURN( _MKSMALLINT(__threadStackSegments(_intVal(i))) );
- }
-%}.
- ^ nil
-!
-
-numberOfStackBoundaryHits
- "internal monitoring only - will vanish"
-
-%{ /* NOCONTEXT */
- extern int __threadNumberOfStackBoundaryHits();
- int n;
- OBJ i;
-
- if (__isSmallInteger(i = _INST(id))) {
- n = __threadNumberOfStackBoundaryHits(_intVal(i));
- n &= 0x3FFFFFFF;
- RETURN( _MKSMALLINT(n) );
- }
-%}.
- ^ nil
-! !
-
-!Process methodsFor:'private scheduler access'!
-
setPriority:aNumber
"set priority without telling processor - not for public use"
@@ -528,17 +574,124 @@
setStateTo:newState if:oldState1 or:oldState2
(state == oldState1 or:[state == oldState2]) ifTrue:[state := newState]
+! !
+
+!Process methodsFor:'special'!
+
+trapRestrictedMethods:trap
+ "Allow/deny the execution of restricted methods.
+ Process specific method restriction is not implemented yet, so this call is
+ redirected to ObjectMemory and causes a system wide restriction.
+
+ Notice: method restriction is a nonstandard feature, not supported
+ by other smalltalk implementations and not specified in the ANSI spec.
+ This is EXPERIMENTAL - and being evaluated for usability.
+ It may change or even vanish (if it shows to be not useful)."
+
+ ^ObjectMemory trapRestrictedMethods:trap
+
+ "
+ Processor activeProcess trapRestrictedMethods:true
+ Processor activeProcess trapRestrictedMethods:false
+ "
+
+ "Created: 8.11.1995 / 19:45:04 / stefan"
+!
+
+uninterruptablyDo:aBlock
+ "execute aBlock with interrupts blocked.
+ This does not prevent preemption by a higher priority processes
+ if any becomes runnable due to the evaluation of aBlock
+ (i.e. if a semaphore is signalled there)."
+
+ |wasBlocked|
+
+ "we must keep track of blocking-state if this is called nested"
+
+ wasBlocked := OperatingSystem blockInterrupts.
+ ^ aBlock valueNowOrOnUnwindDo:[
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+ 0 "stc hint"
+ ]
!
-setId:idNumber state:stateSymbol
- "set id and state - not for public use"
+waitUntilSuspended
+ "wait until the receiver is suspended."
+
+ |wasBlocked|
+
+ wasBlocked := OperatingSystem blockInterrupts.
+ suspendSemaphore isNil ifTrue:[suspendSemaphore := Semaphore new].
+ suspendSemaphore wait
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+!
+
+waitUntilTerminated
+ "wait until the receiver is terminated.
+ This method allows another process to wait till the receiver finishes."
+
+ |wasBlocked sema|
+
+ wasBlocked := OperatingSystem blockInterrupts.
+ sema := Semaphore new.
+ self exitAction:[sema signal].
+ sema wait.
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+!
+
+withLowerPriorityDo:aBlock
+ "execute aBlock at a lower priority. This can be used to perform
+ time-consuming operations at a more user-friendly priority."
- id := idNumber.
- state := stateSymbol.
+ ^ self withPriority:(prio - 1) do:aBlock
+
+ "
+ Processor activeProcess withLowerPriorityDo:[3000 factorial]
+ "
+!
+
+withPriority:aPrio do:aBlock
+ "execute aBlock at another priority. This can be used to perform
+ time-consuming operations at a more user-friendly priority,
+ or some critical action at a higher priority. Do not use too high
+ of a priority to avoid locking up the system (event processing takes place
+ at 24)"
+
+ |oldprio|
+
+ oldprio := prio.
+ self priority:aPrio.
+
+ ^ aBlock valueNowOrOnUnwindDo:[
+ self priority:oldprio
+ ]
+
+ "
+ Processor activeProcess withPriority:7 do:[3000 factorial]
+ "
+ "be careful - even ^C wont work until done:
+ Processor activeProcess withPriority:25 do:[3000 factorial]
+ "
! !
!Process methodsFor:'startup '!
+restart
+ "restart the process from the beginning.
+ This is sent by the ProcessorScheduler to all restartable processes."
+
+"/ ('restart process ' , id printString) errorPrintNL.
+
+ (Processor newProcessFor:self withId:id) ifFalse:[
+ "for some reason, the Processor was unable to create
+ a VM process for me ...."
+
+ ('process ' , id printString , ' failed to restart.') errorPrintNL.
+ ^ nil
+ ].
+ self resume
+!
+
start
"start the process - this is sent by the VM to the process to get
the process up and running.
@@ -565,26 +718,22 @@
"is this artificial restriction useful ?"
self error:'a process cannot be started twice'
]
-!
-
-restart
- "restart the process from the beginning.
- This is sent by the ProcessorScheduler to all restartable processes."
-
-"/ ('restart process ' , id printString) errorPrintNL.
-
- (Processor newProcessFor:self withId:id) ifFalse:[
- "for some reason, the Processor was unable to create
- a VM process for me ...."
-
- ('process ' , id printString , ' failed to restart.') errorPrintNL.
- ^ nil
- ].
- self resume
! !
!Process methodsFor:'suspend / resume'!
+resume
+ "resume the receiver process"
+
+ Processor resume:self
+!
+
+resumeForSingleSend
+ "resume the receiver process, but only let it execute a single send."
+
+ Processor resumeForSingleSend:self
+!
+
stop
"suspend the receiver process - will continue to run when a resume is sent.
A stopped process will not be resumed for interrupt processing."
@@ -602,18 +751,6 @@
Processor suspend:self
!
-resume
- "resume the receiver process"
-
- Processor resume:self
-!
-
-resumeForSingleSend
- "resume the receiver process, but only let it execute a single send."
-
- Processor resumeForSingleSend:self
-!
-
terminate
"terminate the receiver process. Termination is done by raising
the terminateSignal in the receiver process, which can be cought.
@@ -649,144 +786,9 @@
Processor terminateNoSignal:self
! !
-!Process methodsFor:'interrupts'!
-
-interruptWith:aBlock
- "interrupt the receiver and make it evaluate aBlock.
- If the receiver is currently suspended, the block will be remembered
- to be evaluated once the receiver wakes up."
-
- self uninterruptablyDo:[
- interruptActions isNil ifTrue:[
- interruptActions := OrderedCollection with:aBlock.
- ] ifFalse:[
- interruptActions addLast:aBlock.
- ].
- ].
- Processor scheduleForInterrupt:self.
-!
-
-interrupt
- "evaluate my interrupt-actions
- the process will go back to where it got interrupted
- after doing this.
- "
- |action|
-
- [interruptActions notNil and:[interruptActions notEmpty]] whileTrue:[
- action := interruptActions removeFirst.
- action value
- ].
- interruptActions := nil
-! !
-
-!Process methodsFor:'special'!
-
-withPriority:aPrio do:aBlock
- "execute aBlock at another priority. This can be used to perform
- time-consuming operations at a more user-friendly priority,
- or some critical action at a higher priority. Do not use too high
- of a priority to avoid locking up the system (event processing takes place
- at 24)"
-
- |oldprio|
-
- oldprio := prio.
- self priority:aPrio.
-
- ^ aBlock valueNowOrOnUnwindDo:[
- self priority:oldprio
- ]
-
- "
- Processor activeProcess withPriority:7 do:[3000 factorial]
- "
- "be careful - even ^C wont work until done:
- Processor activeProcess withPriority:25 do:[3000 factorial]
- "
-!
-
-withLowerPriorityDo:aBlock
- "execute aBlock at a lower priority. This can be used to perform
- time-consuming operations at a more user-friendly priority."
-
- ^ self withPriority:(prio - 1) do:aBlock
-
- "
- Processor activeProcess withLowerPriorityDo:[3000 factorial]
- "
-!
+!Process class methodsFor:'documentation'!
-uninterruptablyDo:aBlock
- "execute aBlock with interrupts blocked.
- This does not prevent preemption by a higher priority processes
- if any becomes runnable due to the evaluation of aBlock
- (i.e. if a semaphore is signalled there)."
-
- |wasBlocked|
-
- "we must keep track of blocking-state if this is called nested"
-
- wasBlocked := OperatingSystem blockInterrupts.
- ^ aBlock valueNowOrOnUnwindDo:[
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
- 0 "stc hint"
- ]
-!
-
-waitUntilTerminated
- "wait until the receiver is terminated.
- This method allows another process to wait till the receiver finishes."
-
- |wasBlocked sema|
-
- wasBlocked := OperatingSystem blockInterrupts.
- sema := Semaphore new.
- self exitAction:[sema signal].
- sema wait.
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
-!
-
-waitUntilSuspended
- "wait until the receiver is suspended."
-
- |wasBlocked|
-
- wasBlocked := OperatingSystem blockInterrupts.
- suspendSemaphore isNil ifTrue:[suspendSemaphore := Semaphore new].
- suspendSemaphore wait
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
-!
-
-trapRestrictedMethods:trap
- "Allow/deny the execution of restricted methods.
- Process specific method restriction is not implemented yet, so this call is
- redirected to ObjectMemory and causes a system wide restriction.
-
- Notice: method restriction is a nonstandard feature, not supported
- by other smalltalk implementations and not specified in the ANSI spec.
- This is EXPERIMENTAL - and being evaluated for usability.
- It may change or even vanish (if it shows to be not useful)."
-
- ^ObjectMemory trapRestrictedMethods:trap
-
- "
- Processor activeProcess trapRestrictedMethods:true
- Processor activeProcess trapRestrictedMethods:false
- "
-
- "Created: 8.11.1995 / 19:45:04 / stefan"
+version
+ ^ '$Header: /cvs/stx/stx/libbasic/Process.st,v 1.36 1995-12-07 21:29:26 cg Exp $'
! !
-
-!Process methodsFor:'printing & storing'!
-
-printOn:aStream
- "a little more info in my printed representation"
-
- aStream nextPutAll:state article;
- space;
- nextPutAll:state;
- nextPutAll:' Process (';
- nextPutAll:self nameOrId;
- nextPutAll:')'
-! !
+Process initialize!
--- a/ProcessorScheduler.st Thu Dec 07 22:24:46 1995 +0100
+++ b/ProcessorScheduler.st Thu Dec 07 22:32:39 1995 +0100
@@ -11,28 +11,18 @@
"
Object subclass:#ProcessorScheduler
- instanceVariableNames:'quiescentProcessLists scheduler
- zombie
- activeProcess currentPriority
- readFdArray readSemaphoreArray readCheckArray
- writeFdArray writeSemaphoreArray
- timeoutArray timeoutActionArray timeoutProcessArray timeoutSemaphoreArray
- idleActions anyTimeouts dispatching interruptedProcess
- useIOInterrupts'
- classVariableNames:'KnownProcesses KnownProcessIds
- PureEventDriven
- UserSchedulingPriority
- UserInterruptPriority
- TimingPriority
- HighestPriority
- SchedulingPriority
- MaxNumberOfProcesses'
+ instanceVariableNames:'quiescentProcessLists scheduler zombie activeProcess
+ currentPriority readFdArray readSemaphoreArray readCheckArray
+ writeFdArray writeSemaphoreArray timeoutArray timeoutActionArray
+ timeoutProcessArray timeoutSemaphoreArray idleActions anyTimeouts
+ dispatching interruptedProcess useIOInterrupts'
+ classVariableNames:'KnownProcesses KnownProcessIds PureEventDriven
+ UserSchedulingPriority UserInterruptPriority TimingPriority
+ HighestPriority SchedulingPriority MaxNumberOfProcesses'
poolDictionaries:''
category:'Kernel-Processes'
!
-Smalltalk at:#Processor put:nil!
-
!ProcessorScheduler class methodsFor:'documentation'!
copyright
@@ -49,10 +39,6 @@
"
!
-version
- ^ '$Header: /cvs/stx/stx/libbasic/ProcessorScheduler.st,v 1.52 1995-11-24 19:19:45 cg Exp $'
-!
-
documentation
"
This class has only one instance, which is bound to the global
@@ -192,85 +178,8 @@
]
! !
-!ProcessorScheduler class methodsFor:'queries'!
-
-isPureEventDriven
- "this is temporary - (maybe not :-).
- you can run ST/X either with or without processes.
- Without, there is conceptionally a single process handling all
- outside events and timeouts. This has some negative implications
- (Debugger is ugly), but allows a fully portable ST/X without any
- assembler support - i.e. quick portability.
- The PureEvent flag will automatically be set if the runtime system
- does not support threads - otherwise, it can be set manually
- (from rc-file).
- "
-
- ^ PureEventDriven
-!
-
-pureEventDriven
- "turn on pure-event driven mode - no processes, single dispatch loop"
-
- PureEventDriven := true
-!
-
-processDriven
- "turn on process driven mode"
-
- PureEventDriven := false
-!
-
-knownProcesses
- "return a collection of all (living) processes in the system"
-
- ^ KnownProcesses select:[:p | p notNil]
-!
-
-maxNumberOfProcesses
- "return the limit on the number of processes;
- the default is nil (i.e. unlimited)."
-
- ^ MaxNumberOfProcesses
-!
-
-maxNumberOfProcesses:aNumber
- "set the limit on the number of processes.
- This helps if you have a program which (by error) creates countless
- subprocesses. Without this limit, you may have a hard time to find
- this error (and repairing it). If nil (the default), the number of
- processes is unlimited."
-
- MaxNumberOfProcesses := aNumber
-! !
-
!ProcessorScheduler class methodsFor:'primitive process primitives'!
-threadsAvailable
- "return true, if the runtime system supports threads (i.e. processes);
- false otherwise."
-
-%{ /* NOCONTEXT */
- extern OBJ __threadsAvailable();
-
- RETURN (__threadsAvailable());
-%}
-!
-
-threadInterrupt:id
- "make the process evaluate an interrupt. This sets a flag in the VMs
- threadSwitcher, to let the process perform a #interrupt when its set to
- run the next time. The process itself can decide how to react on this
- interrupt (currently, it looks for interruptBlocks to evaluate)."
-
-%{ /* NOCONTEXT */
-
- if (__isSmallInteger(id)) {
- __threadInterrupt(_intVal(id));
- }
-%}
-!
-
threadCreate:aProcess withId:id
"physical creation of a process.
(warning: low level entry, no administration done).
@@ -322,656 +231,123 @@
__threadDestroy(_intVal(id));
}
%}
+!
+
+threadInterrupt:id
+ "make the process evaluate an interrupt. This sets a flag in the VMs
+ threadSwitcher, to let the process perform a #interrupt when its set to
+ run the next time. The process itself can decide how to react on this
+ interrupt (currently, it looks for interruptBlocks to evaluate)."
+
+%{ /* NOCONTEXT */
+
+ if (__isSmallInteger(id)) {
+ __threadInterrupt(_intVal(id));
+ }
+%}
+!
+
+threadsAvailable
+ "return true, if the runtime system supports threads (i.e. processes);
+ false otherwise."
+
+%{ /* NOCONTEXT */
+ extern OBJ __threadsAvailable();
+
+ RETURN (__threadsAvailable());
+%}
! !
-!ProcessorScheduler methodsFor:'primitive process primitives'!
+!ProcessorScheduler class methodsFor:'queries'!
+
+isPureEventDriven
+ "this is temporary - (maybe not :-).
+ you can run ST/X either with or without processes.
+ Without, there is conceptionally a single process handling all
+ outside events and timeouts. This has some negative implications
+ (Debugger is ugly), but allows a fully portable ST/X without any
+ assembler support - i.e. quick portability.
+ The PureEvent flag will automatically be set if the runtime system
+ does not support threads - otherwise, it can be set manually
+ (from rc-file).
+ "
+
+ ^ PureEventDriven
+!
+
+knownProcesses
+ "return a collection of all (living) processes in the system"
+
+ ^ KnownProcesses select:[:p | p notNil]
+!
+
+maxNumberOfProcesses
+ "return the limit on the number of processes;
+ the default is nil (i.e. unlimited)."
+
+ ^ MaxNumberOfProcesses
+!
-threadSwitch:aProcess
- "continue execution in aProcess.
- (warning: low level entry, no administration is done here)"
+maxNumberOfProcesses:aNumber
+ "set the limit on the number of processes.
+ This helps if you have a program which (by error) creates countless
+ subprocesses. Without this limit, you may have a hard time to find
+ this error (and repairing it). If nil (the default), the number of
+ processes is unlimited."
+
+ MaxNumberOfProcesses := aNumber
+!
+
+processDriven
+ "turn on process driven mode"
- |id pri ok oldProcess oldPri p singleStep wasBlocked|
+ PureEventDriven := false
+!
+
+pureEventDriven
+ "turn on pure-event driven mode - no processes, single dispatch loop"
+
+ PureEventDriven := true
+! !
- (aProcess isNil or:[aProcess == activeProcess]) ifTrue:[^ self].
+!ProcessorScheduler methodsFor:'I/O event actions'!
+
+disableFd:aFileDescriptor
+ "disable block events on aFileDescriptor.
+ This is a leftover support for pure-event systems and may vanish."
+
+ |idx "{Class: SmallInteger }"
+ wasBlocked|
wasBlocked := OperatingSystem blockInterrupts.
-
- oldProcess := activeProcess.
- oldPri := currentPriority.
-
- id := aProcess id.
- pri := aProcess priority.
- singleStep := aProcess isSingleStepping.
- aProcess state:#active.
- oldProcess setStateTo:#run if:#active.
-
- "
- no interrupts now - activeProcess has already been changed
- (dont add any message sends here)
- "
- activeProcess := aProcess.
- currentPriority := pri.
-%{
- extern OBJ ___threadSwitch();
-
- if (__isSmallInteger(id)) {
- ok = ___threadSwitch(__context, _intVal(id), (singleStep == true) ? 1 : 0);
- } else {
- ok = false;
- }
-%}.
- "time passes spent in some other process ...
- ... here again"
-
- p := activeProcess.
- activeProcess := oldProcess.
- currentPriority := oldProcess priority.
-
- ok ifFalse:[
- "
- switch failed for some reason -
- destroy the bad process
- "
- p id ~~ 0 ifTrue:[
- 'SCHEDULER: problem with process ' errorPrint.
- p id errorPrint.
- p name notNil ifTrue:[
- ' (' errorPrint. p name errorPrint. ')' errorPrint.
- ].
- '; hard-terminate it.' errorPrintNL.
- p state:#suspended.
- self terminateNoSignal:p.
- ]
- ].
- zombie notNil ifTrue:[
- self class threadDestroy:zombie.
- zombie := nil
+ idx := readFdArray identityIndexOf:aFileDescriptor startingAt:1.
+ idx ~~ 0 ifTrue:[
+ readFdArray at:idx put:nil.
+ readCheckArray at:idx put:nil.
+ readSemaphoreArray at:idx put:nil
].
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
!
-scheduleForInterrupt:aProcess
- "make aProcess evaluate its pushed interrupt block(s)"
-
- |id|
-
- aProcess isNil ifTrue:[^ self].
- aProcess == activeProcess ifTrue:[^ self].
-
- id := aProcess id.
- self class threadInterrupt:id.
- "
- and, make the process runnable
- "
- aProcess state ~~ #stopped ifTrue:[
- "
- and, make the process runnable
- "
- aProcess resume
- ]
-! !
-
-!ProcessorScheduler methodsFor:'constants'!
-
-lowestPriority
- "return the lowest priority value"
-
- ^ 1 "do not change this - its not variable"
-!
-
-highestPriority
- "return the highest priority value (normal) processes can have."
-
- "must be below schedulingPriority -
- otherwise scheduler could be blocked ...
- "
- ^ HighestPriority
-!
-
-schedulingPriority
- "return the priority at which the scheduler runs."
-
- "must be above highestPriority -
- otherwise scheduler could be blocked ...
- "
- ^ SchedulingPriority
-!
-
-userInterruptPriority
- "return the priority, at which the event scheduler runs - i.e.
- all processes running at a lower priority are interruptable by Cntl-C
- or the timer. Processes running at higher prio will not be interrupted."
-
- ^ UserInterruptPriority
-!
-
-timingPriority
- "return the priority, at which all timing takes place (messageTally,
- delay etc.)"
-
- ^ TimingPriority
-!
-
-userSchedulingPriority
- "return the priority, at which all normal user (interactive) processing
- takes place"
-
- ^ UserSchedulingPriority
-!
-
-userBackgroundPriority
- "return the priority, at which background user (non-interactive) processing
- should take place.
- Not currently used - for ST80 compatibility only"
-
- ^ 6
-!
-
-systemBackgroundPriority
- "return the priority, at which background system processing
- should take place.
- Not currently used - for ST80 compatibility only"
-
- ^ 4
-!
-
-lowIOPriority
- "not currently used - for ST80 compatibility only"
-
- ^ 2 "claus: is this ok ?"
-! !
-
-!ProcessorScheduler methodsFor:'private initializing'!
-
-initialize
- "initialize the one-and-only ProcessorScheduler"
-
- |nPrios "{ Class: SmallInteger }"
- l p|
-
- KnownProcesses isNil ifTrue:[
- KnownProcesses := WeakArray new:10.
- KnownProcesses watcher:self class.
- KnownProcessIds := OrderedCollection new.
- ].
-
- "
- create a collection with process lists; accessed using the priority as key
- "
- nPrios := SchedulingPriority.
- quiescentProcessLists := Array new:nPrios.
- 1 to:nPrios do:[:pri |
- quiescentProcessLists at:pri put:(LinkedList new)
- ].
+enableIOAction:aBlock onInput:aFileDescriptor
+ "half-obsolete event support: arrange for aBlock to be
+ evaluated when input on aFileDescriptor arrives.
+ This is a leftover support for pure-event systems and may vanish."
- readFdArray := Array with:nil.
- readCheckArray := Array with:nil.
- readSemaphoreArray := Array with:nil.
- writeFdArray := Array with:nil.
- writeSemaphoreArray := Array with:nil.
- timeoutArray := Array with:nil.
- timeoutSemaphoreArray := Array with:nil.
- timeoutActionArray := Array with:nil.
- timeoutProcessArray := Array with:nil.
- anyTimeouts := false.
- dispatching := false.
- useIOInterrupts := OperatingSystem supportsIOInterrupts.
-
- "
- handcraft the first (dispatcher-) process - this one will never
- block, but go into a select if there is nothing to do.
- Also, it has a prio of max+1 - thus, it comes first when looking
- for a runnable process.
- "
- currentPriority := SchedulingPriority.
- p := Process new.
- p setId:0 state:#run.
- p setPriority:currentPriority.
- p name:'scheduler'.
-
- scheduler := activeProcess := p.
-
- (quiescentProcessLists at:currentPriority) add:p.
-
- "
- let me handle IO and timer interrupts
- "
- ObjectMemory ioInterruptHandler:self.
- ObjectMemory timerInterruptHandler:self.
-!
-
-reinitialize
- "all previous processes (except those marked as restartable) are made dead
- - each object should reinstall its process(s) upon restart;
- especially, windowgroups have to.
- In contrast to ST-80, restartable processes are restarted at the beginning
- NOT continued where left. This is a consequence of the portable implementation
- of ST/X, since in order to continue a process, we needed to know the
- internals of the machines (and C-compilers) stack layout.
- This was not done, favouring portability for process continuation.
- In praxis, this is not much of a problem, since in almost every case,
- the computation state can be saved in some object, and processing be
- restarted from scratch, reinitializing things from this saved state."
-
- |processesToRestart|
-
- "
- lay all processes to rest, collect restartable ones
- "
- processesToRestart := OrderedCollection new.
- KnownProcesses do:[:p |
- p notNil ifTrue:[
- "how, exactly should this be done ?"
-
- p isRestartable == true ifTrue:[
- p nextLink:nil.
- processesToRestart add:p
- ] ifFalse:[
- p setId:nil state:#dead
- ]
- ].
- ].
- scheduler setId:nil state:#dead.
-
- "
- now, start from scratch
- "
- KnownProcesses := nil.
- self initialize.
-
- "
- ... and restart those that can be.
- "
- processesToRestart do:[:p |
-"/ 'process restart not implemented' errorPrintNL.
- p restart
- ]
-! !
-
-!ProcessorScheduler methodsFor:'private'!
-
-remember:aProcess
- "remember aProcess for later disposal (where the underlying
- system resources have to be freed)."
-
- |newShadow oldId wasBlocked
- oldSize "{ Class: SmallInteger }"
- index "{ Class: SmallInteger }"
- sz "{ Class: SmallInteger }" |
-
- wasBlocked := OperatingSystem blockInterrupts.
- index := 1.
- sz := KnownProcessIds size.
- [index <= sz] whileTrue:[
- (KnownProcesses at:index) isNil ifTrue:[
- oldId := KnownProcessIds at:index.
- oldId notNil ifTrue:[
- self class threadDestroy:oldId.
- ].
- KnownProcesses at:index put:aProcess.
- KnownProcessIds at:index put:aProcess id.
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
- ^ self
- ].
- index := index + 1
- ].
-
- KnownProcessIds grow:index.
- KnownProcessIds at:index put:aProcess id.
-
- oldSize := KnownProcesses size.
- (index > oldSize) ifTrue:[
- newShadow := WeakArray new:(oldSize * 2).
- newShadow watcher:self class.
- newShadow replaceFrom:1 with:KnownProcesses.
- KnownProcesses := newShadow
- ].
- KnownProcesses at:index put:aProcess.
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
-!
-
-unRemember:aProcess
- "forget aProcess - dispose processing will not consider this one"
-
- |index wasBlocked|
+ |idx "{Class: SmallInteger }"
+ wasBlocked|
wasBlocked := OperatingSystem blockInterrupts.
- index := KnownProcesses identityIndexOf:aProcess.
- index ~~ 0 ifTrue:[
- KnownProcessIds at:index put:nil.
- KnownProcesses at:index put:nil.
- ].
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
-! !
-
-!ProcessorScheduler methodsFor:'process creation'!
-
-newProcessFor:aProcess withId:idWant
- "private entry for Process restart - do not use in your program"
-
- (self class threadCreate:aProcess withId:idWant) ~~ idWant ifTrue:[
- ^ false
- ].
-
- aProcess state:#light. "meaning: has no stack yet"
- self remember:aProcess.
- ^ true
-!
-
-newProcessFor:aProcess
- "create a physical (VM-) process for aProcess.
- Return true if ok, false if something went wrong.
- The process is not scheduled; to start it running,
- it needs a Process>>resume. Once resumed, the process will later
- get control in its #start method."
-
- |id|
-
- id := self class threadCreate:aProcess withId:nil.
- id isNil ifTrue:[^ false].
-
- aProcess setId:id state:#light. "meaning: has no stack yet"
- self remember:aProcess.
- ^ true
-! !
-
-!ProcessorScheduler methodsFor:'scheduling'!
-
-reschedule
- "switch to the highest prio runnable process.
- The scheduler itself is always runnable, so we can do an unconditional switch
- to that one. This method is a historical left-over and will vanish."
-
- ^ self threadSwitch:scheduler
-!
-
-yield
- "move the currently running process to the end of the currentList
- and reschedule to the first in the list, thus switching to the
- next same-prio-process."
-
- |l wasBlocked|
-
- wasBlocked := OperatingSystem blockInterrupts.
-
- "
- debugging consistency check - will be removed later
- "
- activeProcess priority ~~ currentPriority ifTrue:[
- 'oops process changed priority' errorPrintNL.
- currentPriority := activeProcess priority.
- ].
-
- l := quiescentProcessLists at:currentPriority.
-
- "
- debugging consistency checks - will be removed later
- "
- l isEmpty ifTrue:[
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
- 'oops - empty runnable list' errorPrintNL.
- ^ self
- ].
-
- "
- check if the running process is not the only one
- "
- l size ~~ 1 ifTrue:[
- "
- bring running process to the end
- "
- l removeFirst.
- l addLast:activeProcess.
-
- "
- and switch to first in the list
- "
- self threadSwitch:(l first).
- ].
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
-!
-
-suspend:aProcess
- "remove the argument, aProcess from the list of runnable processes.
- If the process is the current one, reschedule."
-
- |pri l p wasBlocked|
-
- "
- some debugging stuff
- "
- aProcess isNil ifTrue:[
- MiniDebugger enterWithMessage:'nil suspend'.
- ^ self
- ].
- aProcess id isNil ifTrue:[
- MiniDebugger enterWithMessage:'bad suspend: already dead'.
- self threadSwitch:scheduler.
- ^ self
- ].
- aProcess == scheduler ifTrue:[
- 'scheduler should never be suspended' errorPrintNL.
- MiniDebugger enterWithMessage:'scheduler should never be suspended'.
- ^ self
- ].
-
- wasBlocked := OperatingSystem blockInterrupts.
-
- pri := aProcess priority.
- l := quiescentProcessLists at:pri.
-
- "notice: this is slightly faster than putting the if-code into
- the ifAbsent block, because [] is a shared cheap block
- "
- (l remove:aProcess ifAbsent:[]) isNil ifTrue:[
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
- 'bad suspend: not on run list' errorPrintNL.
- "/ MiniDebugger enterWithMessage:'bad suspend: not on run list'.
- self threadSwitch:scheduler.
- ^ self
- ].
-
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
-
- "
- this is a bit of a kludge: allow someone else to
- set the state to something like #ioWait etc.
- In this case, do not set to #suspend.
- All of this to enhance the output of the process monitor ...
- "
- aProcess setStateTo:#suspended if:#active or:#run.
-
- (aProcess == activeProcess) ifTrue:[
- "we can immediately switch sometimes"
- l notEmpty ifTrue:[
- p := l first
+ (readFdArray identityIndexOf:aFileDescriptor startingAt:1) == 0 ifTrue:[
+ idx := readFdArray identityIndexOf:nil startingAt:1.
+ idx ~~ 0 ifTrue:[
+ readFdArray at:idx put:aFileDescriptor.
+ readCheckArray at:idx put:aBlock.
+ readSemaphoreArray at:idx put:nil
] ifFalse:[
- p := scheduler
- ].
- self threadSwitch:p
- ].
-!
-
-resume:aProcess
- "set aProcess runnable -
- if its prio is higher than the currently running prio, switch to it."
-
- |l pri wasBlocked|
-
- (aProcess isNil or:[aProcess == activeProcess]) ifTrue:[^ self].
-
- "ignore, if process is already dead"
- aProcess id isNil ifTrue:[^ self].
-
- wasBlocked := OperatingSystem blockInterrupts.
-
- pri := aProcess priority.
-
- l := quiescentProcessLists at:pri.
- "if already running, ignore"
- (l identityIndexOf:aProcess) ~~ 0 ifTrue:[
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
- ^ self
- ].
- l addLast:aProcess.
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
-
- (pri > currentPriority) ifTrue:[
- "
- its prio is higher; immediately transfer control to it
- "
- self threadSwitch:aProcess
- ] ifFalse:[
- "
- its prio is lower; it will have to wait for a while ...
- "
- aProcess state:#run
- ]
-!
-
-resumeForSingleSend:aProcess
- "like resume, but let the process execute a single send only.
- This will be used by the (new, not yet released) debugger
- for single stepping."
-
- (aProcess isNil or:[aProcess == activeProcess]) ifTrue:[^ self].
- aProcess singleStep:true.
- self resume:aProcess
-!
-
-terminateNoSignal:aProcess
- "hard terminate aProcess without sending the terminate signal, thus
- no unwind blocks or exitAction are performed in the process..
- If its not the current process, it is simply removed from its list
- and physically destroyed. Otherwise (since we can't take away the chair
- we are sitting on), a switch is forced and the process
- will be physically destroyed by the next running process.
- (see zombie handling)"
-
- |pri id l wasBlocked|
-
- aProcess isNil ifTrue:[^ self].
- id := aProcess id.
- id isNil ifTrue:[^ self]. "already dead"
-
- aProcess setId:nil state:#dead.
-
- wasBlocked := OperatingSystem blockInterrupts.
-
- "remove the process from the runnable list"
-
- pri := aProcess priority.
- l := quiescentProcessLists at:pri.
- (l identityIndexOf:aProcess) ~~ 0 ifTrue:[
- l remove:aProcess.
- ].
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
-
- aProcess == activeProcess ifTrue:[
- "
- hard case - its the currently running process
- we must have the next active process destroy this one
- (we cannot destroy the chair we are sitting on ... :-)
- "
- zombie := id.
- self unRemember:aProcess.
- self threadSwitch:scheduler.
- "not reached"
- ^ self
- ].
- self class threadDestroy:id.
- self unRemember:aProcess.
- ^ self
-!
-
-terminateActiveNoSignal
- "hard terminate the active process, without sending any
- terminate signal thus no unwind blocks are evaluated."
-
- self terminateNoSignal:activeProcess
-!
-
-processTermination
- "sent by VM if the current process finished its startup block
- without proper process termination. Lay him to rest now.
- This can only happen, if something went wrong in Block>>newProcess,
- since the block defined there always terminates itself."
-
- self terminateNoSignal:activeProcess.
- self threadSwitch:scheduler
-!
-
-terminate:aProcess
- "terminate aProcess. This is donen by sending aProcess the terminateSignal,
- which will evaluate any unwind blocks and finally do a hard terminate."
-
- aProcess terminate
-!
-
-terminateActive
- "terminate the current process (i.e. the running process kills itself).
- The active process is sent the terminateSignal so it will evaluate any
- unwind blocks and finally do a hard terminate.
- This is sent for regular termination and by the VM, if the hard-stack limit
- is reached. (i.e. a process did not repair things in a recursionInterrupt and
- continued to grow its stack)"
-
- activeProcess terminate
-!
-
-interruptActive
- "interrupt the current process"
-
- activeProcess interrupt
-!
-
-changePriority:prio for:aProcess
- "change the priority of aProcess"
-
- |oldList newList oldPrio newPrio wasBlocked|
-
- oldPrio := aProcess priority.
- oldPrio == prio ifTrue:[^ self].
-
- "
- check for valid argument
- "
- newPrio := prio.
- newPrio < 1 ifTrue:[
- newPrio := 1.
- ] ifFalse:[
- aProcess == scheduler ifTrue:[^ self].
- newPrio > HighestPriority ifTrue:[
- newPrio := HighestPriority
- ]
- ].
-
- wasBlocked := OperatingSystem blockInterrupts.
-
- aProcess setPriority:newPrio.
-
- oldList := quiescentProcessLists at:oldPrio.
- (oldList identityIndexOf:aProcess) == 0 ifTrue:[
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
- ^ self
- ].
-
- oldList remove:aProcess.
-
- newList := quiescentProcessLists at:newPrio.
- newList addLast:aProcess.
-
- "if its the current process lowering its prio
- or another one raising, we have to reschedule"
-
- aProcess == activeProcess ifTrue:[
- currentPriority := newPrio.
- newPrio < oldPrio ifTrue:[
- self threadSwitch:scheduler.
- ]
- ] ifFalse:[
- newPrio > currentPriority ifTrue:[
- self threadSwitch:aProcess.
+ readFdArray := readFdArray copyWith:aFileDescriptor.
+ readCheckArray := readCheckArray copyWith:aBlock.
+ readSemaphoreArray := readSemaphoreArray copyWith:nil.
]
].
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
@@ -979,14 +355,6 @@
!ProcessorScheduler methodsFor:'accessing'!
-currentPriority
- "return the priority of the currently running process"
-
- ^ currentPriority
-
- "Processor currentPriority"
-!
-
activePriority
"return the priority of the currently running process.
GNU-ST & ST-80 compatibility; this is the same as currentPriority"
@@ -1002,92 +370,127 @@
"Processor activeProcess"
!
+currentPriority
+ "return the priority of the currently running process"
+
+ ^ currentPriority
+
+ "Processor currentPriority"
+!
+
interruptedProcess
"returns the process which was interrupted by the active one"
^ interruptedProcess
! !
-!ProcessorScheduler methodsFor:'queries'!
+!ProcessorScheduler methodsFor:'background processing'!
-highestPriorityRunnableProcess
- "return the highest prio runnable process"
+addIdleBlock:aBlock
+ "add the argument, aBlock to the list of idle-actions.
+ Idle blocks are evaluated whenever no other process is runnable,
+ and no events are pending.
+ Use of idle blocks is not recommended, use a low priority processes
+ instead, which has the same effect. Idle blcoks are still included
+ to support background actions in pure-event systems, where no processes
+ are available.
+ Support for idle-blocks may vanish."
- |listArray l p prio "{ Class: SmallInteger }" |
+ |wasBlocked|
+
+ wasBlocked := OperatingSystem blockInterrupts.
+ idleActions isNil ifTrue:[
+ idleActions := OrderedCollection new
+ ].
+ idleActions add:aBlock.
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+!
- prio := HighestPriority.
- listArray := quiescentProcessLists.
- [prio >= 1] whileTrue:[
- l := listArray at:prio.
- 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
+removeIdleBlock:aBlock
+ "remove the argument, aBlock from the list of idle-blocks.
+ Support for idle-blocks may vanish - use low prio processes instead."
+
+ |wasBlocked|
+
+ wasBlocked := OperatingSystem blockInterrupts.
+ idleActions notNil ifTrue:[
+ idleActions remove:aBlock
].
- ^ nil
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+! !
+
+!ProcessorScheduler methodsFor:'constants'!
+
+highestPriority
+ "return the highest priority value (normal) processes can have."
+
+ "must be below schedulingPriority -
+ otherwise scheduler could be blocked ...
+ "
+ ^ HighestPriority
+!
+
+lowIOPriority
+ "not currently used - for ST80 compatibility only"
+
+ ^ 2 "claus: is this ok ?"
!
-isSystemProcess:aProcess
- "return true if aProcess is a system process,
- which should not be suspended/terminated etc.."
+lowestPriority
+ "return the lowest priority value"
+
+ ^ 1 "do not change this - its not variable"
+!
+
+schedulingPriority
+ "return the priority at which the scheduler runs."
- (self class isPureEventDriven
- or:[aProcess id == 0
- or:[(Display notNil and:[Display dispatchProcess == aProcess])
- " nameOrId endsWith:'dispatcher' "
- ]]) ifTrue:[
- ^ true
- ].
- ^ false
+ "must be above highestPriority -
+ otherwise scheduler could be blocked ...
+ "
+ ^ SchedulingPriority
+!
- "
- Processor activeProcessIsSystemProcess
- "
+systemBackgroundPriority
+ "return the priority, at which background system processing
+ should take place.
+ Not currently used - for ST80 compatibility only"
+
+ ^ 4
!
-activeProcessIsSystemProcess
- "return true if the active process is a system process,
- which should not be suspended."
+timingPriority
+ "return the priority, at which all timing takes place (messageTally,
+ delay etc.)"
+
+ ^ TimingPriority
+!
+
+userBackgroundPriority
+ "return the priority, at which background user (non-interactive) processing
+ should take place.
+ Not currently used - for ST80 compatibility only"
- ^ self isSystemProcess:activeProcess
+ ^ 6
+!
+
+userInterruptPriority
+ "return the priority, at which the event scheduler runs - i.e.
+ all processes running at a lower priority are interruptable by Cntl-C
+ or the timer. Processes running at higher prio will not be interrupted."
- "
- Processor activeProcessIsSystemProcess
- "
+ ^ UserInterruptPriority
+!
+
+userSchedulingPriority
+ "return the priority, at which all normal user (interactive) processing
+ takes place"
+
+ ^ UserSchedulingPriority
! !
!ProcessorScheduler methodsFor:'dispatching'!
-dispatchLoop
- "central dispatch loop; the scheduler process is always staying in
- this method, looping forever."
-
- "avoid confusion if entered twice"
-
- dispatching == true ifTrue:[^ self].
- dispatching := true.
-
- "I made this an extra call to dispatch; this allows recompilation
- of the dispatch-handling code in the running system.
- "
- [true] whileTrue:[
- AbortSignal handle:[:ex |
- ex return
- ] do:[
- self dispatch
- ]
- ]
-!
-
dispatch
"It handles timeouts and switches to the highest prio runnable process"
@@ -1211,10 +614,1027 @@
OperatingSystem disableTimer.
self checkForInputWithTimeout:0.
]
+!
+
+dispatchLoop
+ "central dispatch loop; the scheduler process is always staying in
+ this method, looping forever."
+
+ "avoid confusion if entered twice"
+
+ dispatching == true ifTrue:[^ self].
+ dispatching := true.
+
+ "I made this an extra call to dispatch; this allows recompilation
+ of the dispatch-handling code in the running system.
+ "
+ [true] whileTrue:[
+ AbortSignal handle:[:ex |
+ ex return
+ ] do:[
+ self dispatch
+ ]
+ ]
+! !
+
+!ProcessorScheduler methodsFor:'primitive process primitives'!
+
+scheduleForInterrupt:aProcess
+ "make aProcess evaluate its pushed interrupt block(s)"
+
+ |id|
+
+ aProcess isNil ifTrue:[^ self].
+ aProcess == activeProcess ifTrue:[^ self].
+
+ id := aProcess id.
+ self class threadInterrupt:id.
+ "
+ and, make the process runnable
+ "
+ aProcess state ~~ #stopped ifTrue:[
+ "
+ and, make the process runnable
+ "
+ aProcess resume
+ ]
+!
+
+threadSwitch:aProcess
+ "continue execution in aProcess.
+ (warning: low level entry, no administration is done here)"
+
+ |id pri ok oldProcess oldPri p singleStep wasBlocked|
+
+ (aProcess isNil or:[aProcess == activeProcess]) ifTrue:[^ self].
+
+ wasBlocked := OperatingSystem blockInterrupts.
+
+ oldProcess := activeProcess.
+ oldPri := currentPriority.
+
+ id := aProcess id.
+ pri := aProcess priority.
+ singleStep := aProcess isSingleStepping.
+ aProcess state:#active.
+ oldProcess setStateTo:#run if:#active.
+
+ "
+ no interrupts now - activeProcess has already been changed
+ (dont add any message sends here)
+ "
+ activeProcess := aProcess.
+ currentPriority := pri.
+%{
+ extern OBJ ___threadSwitch();
+
+ if (__isSmallInteger(id)) {
+ ok = ___threadSwitch(__context, _intVal(id), (singleStep == true) ? 1 : 0);
+ } else {
+ ok = false;
+ }
+%}.
+ "time passes spent in some other process ...
+ ... here again"
+
+ p := activeProcess.
+ activeProcess := oldProcess.
+ currentPriority := oldProcess priority.
+
+ ok ifFalse:[
+ "
+ switch failed for some reason -
+ destroy the bad process
+ "
+ p id ~~ 0 ifTrue:[
+ 'SCHEDULER: problem with process ' errorPrint.
+ p id errorPrint.
+ p name notNil ifTrue:[
+ ' (' errorPrint. p name errorPrint. ')' errorPrint.
+ ].
+ '; hard-terminate it.' errorPrintNL.
+ p state:#suspended.
+ self terminateNoSignal:p.
+ ]
+ ].
+ zombie notNil ifTrue:[
+ self class threadDestroy:zombie.
+ zombie := nil
+ ].
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+! !
+
+!ProcessorScheduler methodsFor:'private'!
+
+remember:aProcess
+ "remember aProcess for later disposal (where the underlying
+ system resources have to be freed)."
+
+ |newShadow oldId wasBlocked
+ oldSize "{ Class: SmallInteger }"
+ index "{ Class: SmallInteger }"
+ sz "{ Class: SmallInteger }" |
+
+ wasBlocked := OperatingSystem blockInterrupts.
+ index := 1.
+ sz := KnownProcessIds size.
+ [index <= sz] whileTrue:[
+ (KnownProcesses at:index) isNil ifTrue:[
+ oldId := KnownProcessIds at:index.
+ oldId notNil ifTrue:[
+ self class threadDestroy:oldId.
+ ].
+ KnownProcesses at:index put:aProcess.
+ KnownProcessIds at:index put:aProcess id.
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+ ^ self
+ ].
+ index := index + 1
+ ].
+
+ KnownProcessIds grow:index.
+ KnownProcessIds at:index put:aProcess id.
+
+ oldSize := KnownProcesses size.
+ (index > oldSize) ifTrue:[
+ newShadow := WeakArray new:(oldSize * 2).
+ newShadow watcher:self class.
+ newShadow replaceFrom:1 with:KnownProcesses.
+ KnownProcesses := newShadow
+ ].
+ KnownProcesses at:index put:aProcess.
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+!
+
+unRemember:aProcess
+ "forget aProcess - dispose processing will not consider this one"
+
+ |index wasBlocked|
+
+ wasBlocked := OperatingSystem blockInterrupts.
+ index := KnownProcesses identityIndexOf:aProcess.
+ index ~~ 0 ifTrue:[
+ KnownProcessIds at:index put:nil.
+ KnownProcesses at:index put:nil.
+ ].
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+! !
+
+!ProcessorScheduler methodsFor:'private initializing'!
+
+initialize
+ "initialize the one-and-only ProcessorScheduler"
+
+ |nPrios "{ Class: SmallInteger }"
+ l p|
+
+ KnownProcesses isNil ifTrue:[
+ KnownProcesses := WeakArray new:10.
+ KnownProcesses watcher:self class.
+ KnownProcessIds := OrderedCollection new.
+ ].
+
+ "
+ create a collection with process lists; accessed using the priority as key
+ "
+ 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.
+ readSemaphoreArray := Array with:nil.
+ writeFdArray := Array with:nil.
+ writeSemaphoreArray := Array with:nil.
+ timeoutArray := Array with:nil.
+ timeoutSemaphoreArray := Array with:nil.
+ timeoutActionArray := Array with:nil.
+ timeoutProcessArray := Array with:nil.
+ anyTimeouts := false.
+ dispatching := false.
+ useIOInterrupts := OperatingSystem supportsIOInterrupts.
+
+ "
+ handcraft the first (dispatcher-) process - this one will never
+ block, but go into a select if there is nothing to do.
+ Also, it has a prio of max+1 - thus, it comes first when looking
+ for a runnable process.
+ "
+ currentPriority := SchedulingPriority.
+ p := Process new.
+ p setId:0 state:#run.
+ p setPriority:currentPriority.
+ p name:'scheduler'.
+
+ scheduler := activeProcess := p.
+
+ (quiescentProcessLists at:currentPriority) add:p.
+
+ "
+ let me handle IO and timer interrupts
+ "
+ ObjectMemory ioInterruptHandler:self.
+ ObjectMemory timerInterruptHandler:self.
+!
+
+reinitialize
+ "all previous processes (except those marked as restartable) are made dead
+ - each object should reinstall its process(s) upon restart;
+ especially, windowgroups have to.
+ In contrast to ST-80, restartable processes are restarted at the beginning
+ NOT continued where left. This is a consequence of the portable implementation
+ of ST/X, since in order to continue a process, we needed to know the
+ internals of the machines (and C-compilers) stack layout.
+ This was not done, favouring portability for process continuation.
+ In praxis, this is not much of a problem, since in almost every case,
+ the computation state can be saved in some object, and processing be
+ restarted from scratch, reinitializing things from this saved state."
+
+ |processesToRestart|
+
+ "
+ lay all processes to rest, collect restartable ones
+ "
+ processesToRestart := OrderedCollection new.
+ KnownProcesses do:[:p |
+ p notNil ifTrue:[
+ "how, exactly should this be done ?"
+
+ p isRestartable == true ifTrue:[
+ p nextLink:nil.
+ processesToRestart add:p
+ ] ifFalse:[
+ p setId:nil state:#dead
+ ]
+ ].
+ ].
+ scheduler setId:nil state:#dead.
+
+ "
+ now, start from scratch
+ "
+ KnownProcesses := nil.
+ self initialize.
+
+ "
+ ... and restart those that can be.
+ "
+ processesToRestart do:[:p |
+"/ 'process restart not implemented' errorPrintNL.
+ p restart
+ ]
+! !
+
+!ProcessorScheduler methodsFor:'process creation'!
+
+newProcessFor:aProcess
+ "create a physical (VM-) process for aProcess.
+ Return true if ok, false if something went wrong.
+ The process is not scheduled; to start it running,
+ it needs a Process>>resume. Once resumed, the process will later
+ get control in its #start method."
+
+ |id|
+
+ id := self class threadCreate:aProcess withId:nil.
+ id isNil ifTrue:[^ false].
+
+ aProcess setId:id state:#light. "meaning: has no stack yet"
+ self remember:aProcess.
+ ^ true
+!
+
+newProcessFor:aProcess withId:idWant
+ "private entry for Process restart - do not use in your program"
+
+ (self class threadCreate:aProcess withId:idWant) ~~ idWant ifTrue:[
+ ^ false
+ ].
+
+ aProcess state:#light. "meaning: has no stack yet"
+ self remember:aProcess.
+ ^ true
+! !
+
+!ProcessorScheduler methodsFor:'queries'!
+
+activeProcessIsSystemProcess
+ "return true if the active process is a system process,
+ which should not be suspended."
+
+ ^ self isSystemProcess:activeProcess
+
+ "
+ Processor activeProcessIsSystemProcess
+ "
+!
+
+highestPriorityRunnableProcess
+ "return the highest prio runnable process"
+
+ |listArray l p prio "{ Class: SmallInteger }" |
+
+ prio := HighestPriority.
+ listArray := quiescentProcessLists.
+ [prio >= 1] whileTrue:[
+ l := listArray at:prio.
+ 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
+ ].
+ ^ nil
+!
+
+isSystemProcess:aProcess
+ "return true if aProcess is a system process,
+ which should not be suspended/terminated etc.."
+
+ (self class isPureEventDriven
+ or:[aProcess id == 0
+ or:[(Display notNil and:[Display dispatchProcess == aProcess])
+ " nameOrId endsWith:'dispatcher' "
+ ]]) ifTrue:[
+ ^ true
+ ].
+ ^ false
+
+ "
+ Processor activeProcessIsSystemProcess
+ "
+! !
+
+!ProcessorScheduler methodsFor:'scheduling'!
+
+changePriority:prio for:aProcess
+ "change the priority of aProcess"
+
+ |oldList newList oldPrio newPrio wasBlocked|
+
+ oldPrio := aProcess priority.
+ oldPrio == prio ifTrue:[^ self].
+
+ "
+ check for valid argument
+ "
+ newPrio := prio.
+ newPrio < 1 ifTrue:[
+ newPrio := 1.
+ ] ifFalse:[
+ aProcess == scheduler ifTrue:[^ self].
+ newPrio > HighestPriority ifTrue:[
+ newPrio := HighestPriority
+ ]
+ ].
+
+ wasBlocked := OperatingSystem blockInterrupts.
+
+ aProcess setPriority:newPrio.
+
+ oldList := quiescentProcessLists at:oldPrio.
+ (oldList identityIndexOf:aProcess) == 0 ifTrue:[
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+ ^ self
+ ].
+
+ oldList remove:aProcess.
+
+ newList := quiescentProcessLists at:newPrio.
+ newList addLast:aProcess.
+
+ "if its the current process lowering its prio
+ or another one raising, we have to reschedule"
+
+ aProcess == activeProcess ifTrue:[
+ currentPriority := newPrio.
+ newPrio < oldPrio ifTrue:[
+ self threadSwitch:scheduler.
+ ]
+ ] ifFalse:[
+ newPrio > currentPriority ifTrue:[
+ self threadSwitch:aProcess.
+ ]
+ ].
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+!
+
+interruptActive
+ "interrupt the current process"
+
+ activeProcess interrupt
+!
+
+processTermination
+ "sent by VM if the current process finished its startup block
+ without proper process termination. Lay him to rest now.
+ This can only happen, if something went wrong in Block>>newProcess,
+ since the block defined there always terminates itself."
+
+ self terminateNoSignal:activeProcess.
+ self threadSwitch:scheduler
+!
+
+reschedule
+ "switch to the highest prio runnable process.
+ The scheduler itself is always runnable, so we can do an unconditional switch
+ to that one. This method is a historical left-over and will vanish."
+
+ ^ self threadSwitch:scheduler
+!
+
+resume:aProcess
+ "set aProcess runnable -
+ if its prio is higher than the currently running prio, switch to it."
+
+ |l pri wasBlocked|
+
+ (aProcess isNil or:[aProcess == activeProcess]) ifTrue:[^ self].
+
+ "ignore, if process is already dead"
+ aProcess id isNil ifTrue:[^ self].
+
+ wasBlocked := OperatingSystem blockInterrupts.
+
+ pri := aProcess priority.
+
+ l := quiescentProcessLists at:pri.
+ "if already running, ignore"
+ (l identityIndexOf:aProcess) ~~ 0 ifTrue:[
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+ ^ self
+ ].
+ l addLast:aProcess.
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+
+ (pri > currentPriority) ifTrue:[
+ "
+ its prio is higher; immediately transfer control to it
+ "
+ self threadSwitch:aProcess
+ ] ifFalse:[
+ "
+ its prio is lower; it will have to wait for a while ...
+ "
+ aProcess state:#run
+ ]
+!
+
+resumeForSingleSend:aProcess
+ "like resume, but let the process execute a single send only.
+ This will be used by the (new, not yet released) debugger
+ for single stepping."
+
+ (aProcess isNil or:[aProcess == activeProcess]) ifTrue:[^ self].
+ aProcess singleStep:true.
+ self resume:aProcess
+!
+
+suspend:aProcess
+ "remove the argument, aProcess from the list of runnable processes.
+ If the process is the current one, reschedule."
+
+ |pri l p wasBlocked|
+
+ "
+ some debugging stuff
+ "
+ aProcess isNil ifTrue:[
+ MiniDebugger enterWithMessage:'nil suspend'.
+ ^ self
+ ].
+ aProcess id isNil ifTrue:[
+ MiniDebugger enterWithMessage:'bad suspend: already dead'.
+ self threadSwitch:scheduler.
+ ^ self
+ ].
+ aProcess == scheduler ifTrue:[
+ 'scheduler should never be suspended' errorPrintNL.
+ MiniDebugger enterWithMessage:'scheduler should never be suspended'.
+ ^ self
+ ].
+
+ wasBlocked := OperatingSystem blockInterrupts.
+
+ pri := aProcess priority.
+ l := quiescentProcessLists at:pri.
+
+ "notice: this is slightly faster than putting the if-code into
+ the ifAbsent block, because [] is a shared cheap block
+ "
+ (l remove:aProcess ifAbsent:[]) isNil ifTrue:[
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+ 'bad suspend: not on run list' errorPrintNL.
+ "/ MiniDebugger enterWithMessage:'bad suspend: not on run list'.
+ self threadSwitch:scheduler.
+ ^ self
+ ].
+
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+
+ "
+ this is a bit of a kludge: allow someone else to
+ set the state to something like #ioWait etc.
+ In this case, do not set to #suspend.
+ All of this to enhance the output of the process monitor ...
+ "
+ aProcess setStateTo:#suspended if:#active or:#run.
+
+ (aProcess == activeProcess) ifTrue:[
+ "we can immediately switch sometimes"
+ l notEmpty ifTrue:[
+ p := l first
+ ] ifFalse:[
+ p := scheduler
+ ].
+ self threadSwitch:p
+ ].
+!
+
+terminate:aProcess
+ "terminate aProcess. This is donen by sending aProcess the terminateSignal,
+ which will evaluate any unwind blocks and finally do a hard terminate."
+
+ aProcess terminate
+!
+
+terminateActive
+ "terminate the current process (i.e. the running process kills itself).
+ The active process is sent the terminateSignal so it will evaluate any
+ unwind blocks and finally do a hard terminate.
+ This is sent for regular termination and by the VM, if the hard-stack limit
+ is reached. (i.e. a process did not repair things in a recursionInterrupt and
+ continued to grow its stack)"
+
+ activeProcess terminate
+!
+
+terminateActiveNoSignal
+ "hard terminate the active process, without sending any
+ terminate signal thus no unwind blocks are evaluated."
+
+ self terminateNoSignal:activeProcess
+!
+
+terminateNoSignal:aProcess
+ "hard terminate aProcess without sending the terminate signal, thus
+ no unwind blocks or exitAction are performed in the process..
+ If its not the current process, it is simply removed from its list
+ and physically destroyed. Otherwise (since we can't take away the chair
+ we are sitting on), a switch is forced and the process
+ will be physically destroyed by the next running process.
+ (see zombie handling)"
+
+ |pri id l wasBlocked|
+
+ aProcess isNil ifTrue:[^ self].
+ id := aProcess id.
+ id isNil ifTrue:[^ self]. "already dead"
+
+ aProcess setId:nil state:#dead.
+
+ wasBlocked := OperatingSystem blockInterrupts.
+
+ "remove the process from the runnable list"
+
+ pri := aProcess priority.
+ l := quiescentProcessLists at:pri.
+ (l identityIndexOf:aProcess) ~~ 0 ifTrue:[
+ l remove:aProcess.
+ ].
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+
+ aProcess == activeProcess ifTrue:[
+ "
+ hard case - its the currently running process
+ we must have the next active process destroy this one
+ (we cannot destroy the chair we are sitting on ... :-)
+ "
+ zombie := id.
+ self unRemember:aProcess.
+ self threadSwitch:scheduler.
+ "not reached"
+ ^ self
+ ].
+ self class threadDestroy:id.
+ self unRemember:aProcess.
+ ^ self
+!
+
+yield
+ "move the currently running process to the end of the currentList
+ and reschedule to the first in the list, thus switching to the
+ next same-prio-process."
+
+ |l wasBlocked|
+
+ wasBlocked := OperatingSystem blockInterrupts.
+
+ "
+ debugging consistency check - will be removed later
+ "
+ activeProcess priority ~~ currentPriority ifTrue:[
+ 'oops process changed priority' errorPrintNL.
+ currentPriority := activeProcess priority.
+ ].
+
+ l := quiescentProcessLists at:currentPriority.
+
+ "
+ debugging consistency checks - will be removed later
+ "
+ l isEmpty ifTrue:[
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+ 'oops - empty runnable list' errorPrintNL.
+ ^ self
+ ].
+
+ "
+ check if the running process is not the only one
+ "
+ l size ~~ 1 ifTrue:[
+ "
+ bring running process to the end
+ "
+ l removeFirst.
+ l addLast:activeProcess.
+
+ "
+ and switch to first in the list
+ "
+ self threadSwitch:(l first).
+ ].
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+! !
+
+!ProcessorScheduler methodsFor:'semaphore signalling'!
+
+disableSemaphore:aSemaphore
+ "disable triggering of a semaphore"
+
+ |idx "{ Class: SmallInteger }"
+ wasBlocked|
+
+ wasBlocked := OperatingSystem blockInterrupts.
+ idx := readSemaphoreArray identityIndexOf:aSemaphore startingAt:1.
+ [idx ~~ 0] whileTrue:[
+ readFdArray at:idx put:nil.
+ readSemaphoreArray at:idx put:nil.
+ readCheckArray at:idx put:nil.
+ idx := readSemaphoreArray identityIndexOf:aSemaphore startingAt:idx.
+ ].
+ idx := writeSemaphoreArray identityIndexOf:aSemaphore startingAt:1.
+ [idx ~~ 0] whileTrue:[
+ writeFdArray at:idx put:nil.
+ writeSemaphoreArray at:idx put:nil.
+ idx := writeSemaphoreArray identityIndexOf:aSemaphore startingAt:idx.
+ ].
+ idx := timeoutSemaphoreArray identityIndexOf:aSemaphore startingAt:1.
+ [idx ~~ 0] whileTrue:[
+ timeoutArray at:idx put:nil.
+ timeoutSemaphoreArray at:idx put:nil.
+ timeoutActionArray at:idx put:nil.
+ timeoutProcessArray at:idx put:nil.
+ idx := timeoutSemaphoreArray identityIndexOf:aSemaphore startingAt:idx.
+ ].
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+!
+
+signal:aSemaphore afterMilliseconds:millis
+ "arrange for a semaphore to be triggered after some milliseconds"
+
+ |now then wasBlocked|
+
+ wasBlocked := OperatingSystem blockInterrupts.
+ now := OperatingSystem getMillisecondTime.
+ then := OperatingSystem millisecondTimeAdd:now and:millis rounded.
+ self signal:aSemaphore atMilliseconds:then.
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+!
+
+signal:aSemaphore afterSeconds:seconds
+ "arrange for a semaphore to be triggered after some seconds"
+
+ self signal:aSemaphore afterMilliseconds:(seconds * 1000)
+!
+
+signal:aSemaphore atMilliseconds:aMillisecondTime
+ "arrange for a semaphore to be triggered at a specific millisecond time.
+ If there is already a pending trigger time, the time is changed."
+
+ |index "{ Class: SmallInteger }"
+ wasBlocked|
+
+ wasBlocked := OperatingSystem blockInterrupts.
+ index := timeoutSemaphoreArray identityIndexOf:aSemaphore startingAt:1.
+ index ~~ 0 ifTrue:[
+ timeoutArray at:index put:aMillisecondTime
+ ] ifFalse:[
+ index := timeoutArray identityIndexOf:nil startingAt:1.
+ index ~~ 0 ifTrue:[
+ timeoutSemaphoreArray at:index put:aSemaphore.
+ timeoutArray at:index put:aMillisecondTime.
+ timeoutActionArray at:index put:nil.
+ timeoutProcessArray at:index put:nil
+ ] ifFalse:[
+ timeoutSemaphoreArray := timeoutSemaphoreArray copyWith:aSemaphore.
+ timeoutArray := timeoutArray copyWith:aMillisecondTime.
+ timeoutActionArray := timeoutActionArray copyWith:nil.
+ timeoutProcessArray := timeoutProcessArray copyWith:nil
+ ].
+ ].
+
+ anyTimeouts := true.
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+!
+
+signal:aSemaphore onInput:aFileDescriptor
+ "arrange for a semaphore to be triggered when input on aFileDescriptor
+ arrives."
+
+ self signal:aSemaphore onInput:aFileDescriptor orCheck:nil
+!
+
+signal:aSemaphore onInput:aFileDescriptor orCheck:aBlock
+ "arrange for a semaphore to be triggered when input on aFileDescriptor
+ arrives OR checkblock evaluates to true.
+ (checkBlock is used for buffered input, where a select may not detect
+ data already read into a buffer - as in Xlib)"
+
+ |idx "{ Class: SmallInteger }"
+ wasBlocked|
+
+ wasBlocked := OperatingSystem blockInterrupts.
+ (readFdArray identityIndexOf:aFileDescriptor startingAt:1) == 0 ifTrue:[
+ idx := readFdArray identityIndexOf:nil startingAt:1.
+ idx ~~ 0 ifTrue:[
+ readFdArray at:idx put:aFileDescriptor.
+ readSemaphoreArray at:idx put:aSemaphore.
+ readCheckArray at:idx put:aBlock
+ ] ifFalse:[
+ readFdArray := readFdArray copyWith:aFileDescriptor.
+ readSemaphoreArray := readSemaphoreArray copyWith:aSemaphore.
+ readCheckArray := readCheckArray copyWith:aBlock.
+ ]
+ ].
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+!
+
+signal:aSemaphore onOutput:aFileDescriptor
+ "arrange for a semaphore to be triggered when output on aFileDescriptor
+ is possible. (i.e. can be written without blocking)"
+
+ |idx "{ Class: SmallInteger }"
+ wasBlocked|
+
+ wasBlocked := OperatingSystem blockInterrupts.
+ (writeFdArray identityIndexOf:aFileDescriptor startingAt:1) == 0 ifTrue:[
+ idx := writeFdArray identityIndexOf:nil startingAt:1.
+ idx ~~ 0 ifTrue:[
+ writeFdArray at:idx put:aFileDescriptor.
+ writeSemaphoreArray at:idx put:aSemaphore.
+ ] ifFalse:[
+ writeFdArray := writeFdArray copyWith:aFileDescriptor.
+ writeSemaphoreArray := writeSemaphoreArray copyWith:aSemaphore.
+ ]
+ ].
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+! !
+
+!ProcessorScheduler methodsFor:'timeout handling'!
+
+addTimedBlock:aBlock afterMilliseconds:delta
+ "add the argument, aBlock to the list of time-scheduled-blocks; to be
+ evaluated after delta milliseconds. The process which installs this timed
+ block will be interrupted for execution of the block.
+ (if it is running, the interrupt will occur in whatever method it is
+ executing; if it is suspended, it will be resumed).
+ The block will be removed from the timed-block list after evaluation
+ (i.e. it will trigger only once)."
+
+ ^ self addTimedBlock:aBlock for:activeProcess afterMilliseconds:delta
+!
+
+addTimedBlock:aBlock afterSeconds:delta
+ "add the argument, aBlock to the list of time-scheduled-blocks.
+ to be evaluated after delta seconds. The process which installs this timed
+ block will be interrupted for execution of the block.
+ (if it is running, the interrupt will occur in whatever method it is
+ executing; if it is suspended, it will be resumed).
+ The block will be removed from the timed-block list after evaluation
+ (i.e. it will trigger only once)."
+
+ self addTimedBlock:aBlock for:activeProcess afterMilliseconds:(delta * 1000) rounded
+!
+
+addTimedBlock:aBlock atMilliseconds:aMillisecondTime
+ "add the argument, aBlock to the list of time-scheduled-blocks; to be
+ evaluated when the millisecondClock value passes aMillisecondTime.
+ The process which installs this timed block will be interrupted for
+ execution of the block.
+ (if it is running, the interrupt will occur in whatever method it is
+ executing; if it is suspended, it will be resumed).
+ The block will be removed from the timed-block list after evaluation
+ (i.e. it will trigger only once)."
+
+ self addTimedBlock:aBlock for:activeProcess atMilliseconds:aMillisecondTime
+!
+
+addTimedBlock:aBlock for:aProcess afterMilliseconds:delta
+ "add the argument, aBlock to the list of time-scheduled-blocks; to be
+ evaluated after delta milliseconds. The process specified by the argument,
+ aProcess will be interrupted for execution of the block.
+ (if it is running, the interrupt will occur in whatever method it is
+ executing; if it is suspended, it will be resumed).
+ If aProcess is nil, the block will be evaluated by the scheduler itself
+ (which is dangerous - the block should not raise any error conditions).
+ The block will be removed from the timed-block list after evaluation
+ (i.e. it will trigger only once)."
+
+ |now then wasBlocked|
+
+ wasBlocked := OperatingSystem blockInterrupts.
+ now := OperatingSystem getMillisecondTime.
+ then := OperatingSystem millisecondTimeAdd:now and:delta.
+ self addTimedBlock:aBlock for:aProcess atMilliseconds:then.
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+!
+
+addTimedBlock:aBlock for:aProcess afterSeconds:delta
+ "add the argument, aBlock to the list of time-scheduled-blocks.
+ to be evaluated after delta seconds. aProcess will be interrupted for
+ execution of the block.
+ (if it is running, the interrupt will occur in whatever method it is
+ executing; if it is suspended, it will be resumed).
+ If aProcess is nil, the block will be evaluated by the scheduler itself
+ (which is dangerous - the block should not raise any error conditions).
+ The block will be removed from the timed-block list after evaluation
+ (i.e. it will trigger only once)."
+
+ self addTimedBlock:aBlock for:aProcess afterMilliseconds:(delta * 1000) rounded
+!
+
+addTimedBlock:aBlock for:aProcess atMilliseconds:aMillisecondTime
+ "add the argument, aBlock to the list of time-scheduled-blocks; to be
+ evaluated by aProcess when the millisecondClock value passes
+ aMillisecondTime.
+ If that block is already in the timeout list,
+ its trigger-time is changed.
+ The process specified by the argument, aProcess will be interrupted
+ for execution of the block.
+ If aProcess is nil, the block will be evaluated by the scheduler itself
+ (which is dangerous - the block should not raise any error conditions).
+ If the process is active at trigger time, the interrupt will occur in
+ whatever method it is executing; if suspended at trigger time, it will be
+ resumed.
+ The block will be removed from the timed-block list after evaluation
+ (i.e. it will trigger only once)."
+
+ |index "{ Class: SmallInteger }"
+ wasBlocked|
+
+ wasBlocked := OperatingSystem blockInterrupts.
+ index := timeoutActionArray identityIndexOf:aBlock startingAt:1.
+ index ~~ 0 ifTrue:[
+ timeoutArray at:index put:aMillisecondTime
+ ] ifFalse:[
+ index := timeoutArray indexOf:nil.
+ index ~~ 0 ifTrue:[
+ timeoutArray at:index put:aMillisecondTime.
+ timeoutActionArray at:index put:aBlock.
+ timeoutSemaphoreArray at:index put:nil.
+ timeoutProcessArray at:index put:aProcess
+ ] ifFalse:[
+ timeoutArray := timeoutArray copyWith:aMillisecondTime.
+ timeoutActionArray := timeoutActionArray copyWith:aBlock.
+ timeoutSemaphoreArray := timeoutSemaphoreArray copyWith:nil.
+ timeoutProcessArray := timeoutProcessArray copyWith:aProcess.
+ ].
+ ].
+
+ anyTimeouts := true.
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+!
+
+evaluateTimeouts
+ "walk through timeouts and evaluate blocks or signal semas that need to be .."
+
+ |sema now aTime block blocksToEvaluate
+ processes n "{ Class: SmallInteger }"|
+
+ anyTimeouts ifFalse:[ ^ self].
+
+ "have to collect the blocks first, then evaluate them. This avoids
+ problems due to newly inserted blocks."
+
+ now := OperatingSystem getMillisecondTime.
+ blocksToEvaluate := nil.
+ n := timeoutArray size.
+ anyTimeouts := false.
+ 1 to:n do:[:index |
+ aTime := timeoutArray at:index.
+ aTime notNil ifTrue:[
+ (OperatingSystem millisecondTime:aTime isAfter:now) ifFalse:[
+ "this one should be triggered"
+
+ sema := timeoutSemaphoreArray at:index.
+ sema notNil ifTrue:[
+ sema signalOnce.
+ timeoutSemaphoreArray at:index put:nil
+ ] ifFalse:[
+ "to support pure-events"
+ block := timeoutActionArray at:index.
+ block notNil ifTrue:[
+ blocksToEvaluate isNil ifTrue:[
+ blocksToEvaluate := OrderedCollection new:10.
+ processes := OrderedCollection new:10.
+ ].
+ blocksToEvaluate add:block.
+ processes add:(timeoutProcessArray at:index).
+ timeoutActionArray at:index put:nil.
+ timeoutProcessArray at:index put:nil.
+ ]
+ ].
+ timeoutArray at:index put:nil.
+ ] ifTrue:[
+ anyTimeouts := true
+ ]
+ ]
+ ].
+
+ blocksToEvaluate notNil ifTrue:[
+ blocksToEvaluate keysAndValuesDo:[:index :block |
+ |p|
+
+ p := processes at:index.
+ (p isNil or:[p == scheduler or:[PureEventDriven]]) ifTrue:[
+ block value
+ ] ifFalse:[
+ p interruptWith:block
+ ]
+ ]
+ ]
+!
+
+removeTimedBlock:aBlock
+ "remove the argument, aBlock from the list of time-sceduled-blocks."
+
+ |index "{ Class: SmallInteger }"
+ wasBlocked|
+
+ wasBlocked := OperatingSystem blockInterrupts.
+ index := timeoutActionArray identityIndexOf:aBlock startingAt:1.
+ (index ~~ 0) ifTrue:[
+ timeoutArray at:index put:nil.
+ timeoutActionArray at:index put:nil.
+ timeoutSemaphoreArray at:index put:nil.
+ timeoutProcessArray at:index put:nil.
+ ].
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
! !
!ProcessorScheduler methodsFor:'waiting'!
+checkForInputWithTimeout:millis
+ "this is called, when there is absolutely nothing to do;
+ hard wait for either input to arrive or a timeout to occur."
+
+ |fd index sema action|
+
+ fd := OperatingSystem
+ selectOnAnyReadable:readFdArray
+ writable:writeFdArray
+ exception:nil
+ withTimeOut:millis.
+ fd notNil ifTrue:[
+ index := readFdArray indexOf:fd.
+ index ~~ 0 ifTrue:[
+ sema := readSemaphoreArray at:index.
+ sema notNil ifTrue:[
+ sema signalOnce.
+ ^ true
+ ] ifFalse:[
+ action := readCheckArray at:index.
+ action notNil ifTrue:[
+ action value.
+ ^ true
+ ]
+ ]
+ ]
+ ].
+ ^ false
+!
+
ioInterrupt
"data arrived while waiting - switch to scheduler process which will decide
what to do now."
@@ -1223,14 +1643,6 @@
self threadSwitch:scheduler
!
-timerInterrupt
- "timer expired while waiting - switch to scheduler process which will decide
- what to do now."
-
- interruptedProcess := activeProcess.
- self threadSwitch:scheduler
-!
-
timeToNextTimeout
"return the delta-T (in millis) to next timeout, or nil if
there is none"
@@ -1261,6 +1673,14 @@
^ minDelta
!
+timerInterrupt
+ "timer expired while waiting - switch to scheduler process which will decide
+ what to do now."
+
+ interruptedProcess := activeProcess.
+ self threadSwitch:scheduler
+!
+
waitForEventOrTimeout
"entered when no process is runnable - wait for either input on
any file descriptors to arrive or a timeout to happen.
@@ -1325,438 +1745,11 @@
millis := millis rounded
].
self checkForInputWithTimeout:millis
-!
-
-checkForInputWithTimeout:millis
- "this is called, when there is absolutely nothing to do;
- hard wait for either input to arrive or a timeout to occur."
-
- |fd index sema action|
-
- fd := OperatingSystem
- selectOnAnyReadable:readFdArray
- writable:writeFdArray
- exception:nil
- withTimeOut:millis.
- fd notNil ifTrue:[
- index := readFdArray indexOf:fd.
- index ~~ 0 ifTrue:[
- sema := readSemaphoreArray at:index.
- sema notNil ifTrue:[
- sema signalOnce.
- ^ true
- ] ifFalse:[
- action := readCheckArray at:index.
- action notNil ifTrue:[
- action value.
- ^ true
- ]
- ]
- ]
- ].
- ^ false
-! !
-
-!ProcessorScheduler methodsFor:'semaphore signalling'!
-
-signal:aSemaphore onInput:aFileDescriptor
- "arrange for a semaphore to be triggered when input on aFileDescriptor
- arrives."
-
- self signal:aSemaphore onInput:aFileDescriptor orCheck:nil
-!
-
-signal:aSemaphore onInput:aFileDescriptor orCheck:aBlock
- "arrange for a semaphore to be triggered when input on aFileDescriptor
- arrives OR checkblock evaluates to true.
- (checkBlock is used for buffered input, where a select may not detect
- data already read into a buffer - as in Xlib)"
-
- |idx "{ Class: SmallInteger }"
- wasBlocked|
-
- wasBlocked := OperatingSystem blockInterrupts.
- (readFdArray identityIndexOf:aFileDescriptor startingAt:1) == 0 ifTrue:[
- idx := readFdArray identityIndexOf:nil startingAt:1.
- idx ~~ 0 ifTrue:[
- readFdArray at:idx put:aFileDescriptor.
- readSemaphoreArray at:idx put:aSemaphore.
- readCheckArray at:idx put:aBlock
- ] ifFalse:[
- readFdArray := readFdArray copyWith:aFileDescriptor.
- readSemaphoreArray := readSemaphoreArray copyWith:aSemaphore.
- readCheckArray := readCheckArray copyWith:aBlock.
- ]
- ].
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
-!
-
-signal:aSemaphore onOutput:aFileDescriptor
- "arrange for a semaphore to be triggered when output on aFileDescriptor
- is possible. (i.e. can be written without blocking)"
-
- |idx "{ Class: SmallInteger }"
- wasBlocked|
-
- wasBlocked := OperatingSystem blockInterrupts.
- (writeFdArray identityIndexOf:aFileDescriptor startingAt:1) == 0 ifTrue:[
- idx := writeFdArray identityIndexOf:nil startingAt:1.
- idx ~~ 0 ifTrue:[
- writeFdArray at:idx put:aFileDescriptor.
- writeSemaphoreArray at:idx put:aSemaphore.
- ] ifFalse:[
- writeFdArray := writeFdArray copyWith:aFileDescriptor.
- writeSemaphoreArray := writeSemaphoreArray copyWith:aSemaphore.
- ]
- ].
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
-!
-
-signal:aSemaphore afterSeconds:seconds
- "arrange for a semaphore to be triggered after some seconds"
-
- self signal:aSemaphore afterMilliseconds:(seconds * 1000)
-!
-
-signal:aSemaphore afterMilliseconds:millis
- "arrange for a semaphore to be triggered after some milliseconds"
-
- |now then wasBlocked|
-
- wasBlocked := OperatingSystem blockInterrupts.
- now := OperatingSystem getMillisecondTime.
- then := OperatingSystem millisecondTimeAdd:now and:millis rounded.
- self signal:aSemaphore atMilliseconds:then.
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
-!
-
-signal:aSemaphore atMilliseconds:aMillisecondTime
- "arrange for a semaphore to be triggered at a specific millisecond time.
- If there is already a pending trigger time, the time is changed."
-
- |index "{ Class: SmallInteger }"
- wasBlocked|
-
- wasBlocked := OperatingSystem blockInterrupts.
- index := timeoutSemaphoreArray identityIndexOf:aSemaphore startingAt:1.
- index ~~ 0 ifTrue:[
- timeoutArray at:index put:aMillisecondTime
- ] ifFalse:[
- index := timeoutArray identityIndexOf:nil startingAt:1.
- index ~~ 0 ifTrue:[
- timeoutSemaphoreArray at:index put:aSemaphore.
- timeoutArray at:index put:aMillisecondTime.
- timeoutActionArray at:index put:nil.
- timeoutProcessArray at:index put:nil
- ] ifFalse:[
- timeoutSemaphoreArray := timeoutSemaphoreArray copyWith:aSemaphore.
- timeoutArray := timeoutArray copyWith:aMillisecondTime.
- timeoutActionArray := timeoutActionArray copyWith:nil.
- timeoutProcessArray := timeoutProcessArray copyWith:nil
- ].
- ].
-
- anyTimeouts := true.
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
-!
-
-disableSemaphore:aSemaphore
- "disable triggering of a semaphore"
-
- |idx "{ Class: SmallInteger }"
- wasBlocked|
-
- wasBlocked := OperatingSystem blockInterrupts.
- idx := readSemaphoreArray identityIndexOf:aSemaphore startingAt:1.
- [idx ~~ 0] whileTrue:[
- readFdArray at:idx put:nil.
- readSemaphoreArray at:idx put:nil.
- readCheckArray at:idx put:nil.
- idx := readSemaphoreArray identityIndexOf:aSemaphore startingAt:idx.
- ].
- idx := writeSemaphoreArray identityIndexOf:aSemaphore startingAt:1.
- [idx ~~ 0] whileTrue:[
- writeFdArray at:idx put:nil.
- writeSemaphoreArray at:idx put:nil.
- idx := writeSemaphoreArray identityIndexOf:aSemaphore startingAt:idx.
- ].
- idx := timeoutSemaphoreArray identityIndexOf:aSemaphore startingAt:1.
- [idx ~~ 0] whileTrue:[
- timeoutArray at:idx put:nil.
- timeoutSemaphoreArray at:idx put:nil.
- timeoutActionArray at:idx put:nil.
- timeoutProcessArray at:idx put:nil.
- idx := timeoutSemaphoreArray identityIndexOf:aSemaphore startingAt:idx.
- ].
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
-! !
-
-!ProcessorScheduler methodsFor:'background processing'!
-
-addIdleBlock:aBlock
- "add the argument, aBlock to the list of idle-actions.
- Idle blocks are evaluated whenever no other process is runnable,
- and no events are pending.
- Use of idle blocks is not recommended, use a low priority processes
- instead, which has the same effect. Idle blcoks are still included
- to support background actions in pure-event systems, where no processes
- are available.
- Support for idle-blocks may vanish."
-
- |wasBlocked|
-
- wasBlocked := OperatingSystem blockInterrupts.
- idleActions isNil ifTrue:[
- idleActions := OrderedCollection new
- ].
- idleActions add:aBlock.
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
-!
-
-removeIdleBlock:aBlock
- "remove the argument, aBlock from the list of idle-blocks.
- Support for idle-blocks may vanish - use low prio processes instead."
-
- |wasBlocked|
-
- wasBlocked := OperatingSystem blockInterrupts.
- idleActions notNil ifTrue:[
- idleActions remove:aBlock
- ].
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
! !
-!ProcessorScheduler methodsFor:'I/O event actions'!
-
-enableIOAction:aBlock onInput:aFileDescriptor
- "half-obsolete event support: arrange for aBlock to be
- evaluated when input on aFileDescriptor arrives.
- This is a leftover support for pure-event systems and may vanish."
-
- |idx "{Class: SmallInteger }"
- wasBlocked|
-
- wasBlocked := OperatingSystem blockInterrupts.
- (readFdArray identityIndexOf:aFileDescriptor startingAt:1) == 0 ifTrue:[
- idx := readFdArray identityIndexOf:nil startingAt:1.
- idx ~~ 0 ifTrue:[
- readFdArray at:idx put:aFileDescriptor.
- readCheckArray at:idx put:aBlock.
- readSemaphoreArray at:idx put:nil
- ] ifFalse:[
- readFdArray := readFdArray copyWith:aFileDescriptor.
- readCheckArray := readCheckArray copyWith:aBlock.
- readSemaphoreArray := readSemaphoreArray copyWith:nil.
- ]
- ].
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
-!
-
-disableFd:aFileDescriptor
- "disable block events on aFileDescriptor.
- This is a leftover support for pure-event systems and may vanish."
-
- |idx "{Class: SmallInteger }"
- wasBlocked|
-
- wasBlocked := OperatingSystem blockInterrupts.
- idx := readFdArray identityIndexOf:aFileDescriptor startingAt:1.
- idx ~~ 0 ifTrue:[
- readFdArray at:idx put:nil.
- readCheckArray at:idx put:nil.
- readSemaphoreArray at:idx put:nil
- ].
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
-! !
-
-!ProcessorScheduler methodsFor:'timeout handling'!
-
-addTimedBlock:aBlock afterSeconds:delta
- "add the argument, aBlock to the list of time-scheduled-blocks.
- to be evaluated after delta seconds. The process which installs this timed
- block will be interrupted for execution of the block.
- (if it is running, the interrupt will occur in whatever method it is
- executing; if it is suspended, it will be resumed).
- The block will be removed from the timed-block list after evaluation
- (i.e. it will trigger only once)."
-
- self addTimedBlock:aBlock for:activeProcess afterMilliseconds:(delta * 1000) rounded
-!
-
-addTimedBlock:aBlock for:aProcess afterSeconds:delta
- "add the argument, aBlock to the list of time-scheduled-blocks.
- to be evaluated after delta seconds. aProcess will be interrupted for
- execution of the block.
- (if it is running, the interrupt will occur in whatever method it is
- executing; if it is suspended, it will be resumed).
- If aProcess is nil, the block will be evaluated by the scheduler itself
- (which is dangerous - the block should not raise any error conditions).
- The block will be removed from the timed-block list after evaluation
- (i.e. it will trigger only once)."
-
- self addTimedBlock:aBlock for:aProcess afterMilliseconds:(delta * 1000) rounded
-!
-
-addTimedBlock:aBlock afterMilliseconds:delta
- "add the argument, aBlock to the list of time-scheduled-blocks; to be
- evaluated after delta milliseconds. The process which installs this timed
- block will be interrupted for execution of the block.
- (if it is running, the interrupt will occur in whatever method it is
- executing; if it is suspended, it will be resumed).
- The block will be removed from the timed-block list after evaluation
- (i.e. it will trigger only once)."
-
- ^ self addTimedBlock:aBlock for:activeProcess afterMilliseconds:delta
-!
-
-addTimedBlock:aBlock for:aProcess afterMilliseconds:delta
- "add the argument, aBlock to the list of time-scheduled-blocks; to be
- evaluated after delta milliseconds. The process specified by the argument,
- aProcess will be interrupted for execution of the block.
- (if it is running, the interrupt will occur in whatever method it is
- executing; if it is suspended, it will be resumed).
- If aProcess is nil, the block will be evaluated by the scheduler itself
- (which is dangerous - the block should not raise any error conditions).
- The block will be removed from the timed-block list after evaluation
- (i.e. it will trigger only once)."
-
- |now then wasBlocked|
-
- wasBlocked := OperatingSystem blockInterrupts.
- now := OperatingSystem getMillisecondTime.
- then := OperatingSystem millisecondTimeAdd:now and:delta.
- self addTimedBlock:aBlock for:aProcess atMilliseconds:then.
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
-!
-
-addTimedBlock:aBlock atMilliseconds:aMillisecondTime
- "add the argument, aBlock to the list of time-scheduled-blocks; to be
- evaluated when the millisecondClock value passes aMillisecondTime.
- The process which installs this timed block will be interrupted for
- execution of the block.
- (if it is running, the interrupt will occur in whatever method it is
- executing; if it is suspended, it will be resumed).
- The block will be removed from the timed-block list after evaluation
- (i.e. it will trigger only once)."
-
- self addTimedBlock:aBlock for:activeProcess atMilliseconds:aMillisecondTime
-!
+!ProcessorScheduler class methodsFor:'documentation'!
-addTimedBlock:aBlock for:aProcess atMilliseconds:aMillisecondTime
- "add the argument, aBlock to the list of time-scheduled-blocks; to be
- evaluated by aProcess when the millisecondClock value passes
- aMillisecondTime.
- If that block is already in the timeout list,
- its trigger-time is changed.
- The process specified by the argument, aProcess will be interrupted
- for execution of the block.
- If aProcess is nil, the block will be evaluated by the scheduler itself
- (which is dangerous - the block should not raise any error conditions).
- If the process is active at trigger time, the interrupt will occur in
- whatever method it is executing; if suspended at trigger time, it will be
- resumed.
- The block will be removed from the timed-block list after evaluation
- (i.e. it will trigger only once)."
-
- |index "{ Class: SmallInteger }"
- wasBlocked|
-
- wasBlocked := OperatingSystem blockInterrupts.
- index := timeoutActionArray identityIndexOf:aBlock startingAt:1.
- index ~~ 0 ifTrue:[
- timeoutArray at:index put:aMillisecondTime
- ] ifFalse:[
- index := timeoutArray indexOf:nil.
- index ~~ 0 ifTrue:[
- timeoutArray at:index put:aMillisecondTime.
- timeoutActionArray at:index put:aBlock.
- timeoutSemaphoreArray at:index put:nil.
- timeoutProcessArray at:index put:aProcess
- ] ifFalse:[
- timeoutArray := timeoutArray copyWith:aMillisecondTime.
- timeoutActionArray := timeoutActionArray copyWith:aBlock.
- timeoutSemaphoreArray := timeoutSemaphoreArray copyWith:nil.
- timeoutProcessArray := timeoutProcessArray copyWith:aProcess.
- ].
- ].
-
- anyTimeouts := true.
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
-!
-
-removeTimedBlock:aBlock
- "remove the argument, aBlock from the list of time-sceduled-blocks."
-
- |index "{ Class: SmallInteger }"
- wasBlocked|
-
- wasBlocked := OperatingSystem blockInterrupts.
- index := timeoutActionArray identityIndexOf:aBlock startingAt:1.
- (index ~~ 0) ifTrue:[
- timeoutArray at:index put:nil.
- timeoutActionArray at:index put:nil.
- timeoutSemaphoreArray at:index put:nil.
- timeoutProcessArray at:index put:nil.
- ].
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
-!
-
-evaluateTimeouts
- "walk through timeouts and evaluate blocks or signal semas that need to be .."
-
- |sema now aTime block blocksToEvaluate
- processes n "{ Class: SmallInteger }"|
-
- anyTimeouts ifFalse:[ ^ self].
-
- "have to collect the blocks first, then evaluate them. This avoids
- problems due to newly inserted blocks."
-
- now := OperatingSystem getMillisecondTime.
- blocksToEvaluate := nil.
- n := timeoutArray size.
- anyTimeouts := false.
- 1 to:n do:[:index |
- aTime := timeoutArray at:index.
- aTime notNil ifTrue:[
- (OperatingSystem millisecondTime:aTime isAfter:now) ifFalse:[
- "this one should be triggered"
-
- sema := timeoutSemaphoreArray at:index.
- sema notNil ifTrue:[
- sema signalOnce.
- timeoutSemaphoreArray at:index put:nil
- ] ifFalse:[
- "to support pure-events"
- block := timeoutActionArray at:index.
- block notNil ifTrue:[
- blocksToEvaluate isNil ifTrue:[
- blocksToEvaluate := OrderedCollection new:10.
- processes := OrderedCollection new:10.
- ].
- blocksToEvaluate add:block.
- processes add:(timeoutProcessArray at:index).
- timeoutActionArray at:index put:nil.
- timeoutProcessArray at:index put:nil.
- ]
- ].
- timeoutArray at:index put:nil.
- ] ifTrue:[
- anyTimeouts := true
- ]
- ]
- ].
-
- blocksToEvaluate notNil ifTrue:[
- blocksToEvaluate keysAndValuesDo:[:index :block |
- |p|
-
- p := processes at:index.
- (p isNil or:[p == scheduler or:[PureEventDriven]]) ifTrue:[
- block value
- ] ifFalse:[
- p interruptWith:block
- ]
- ]
- ]
+version
+ ^ '$Header: /cvs/stx/stx/libbasic/ProcessorScheduler.st,v 1.53 1995-12-07 21:29:55 cg Exp $'
! !
+ProcessorScheduler initialize!
--- a/RecursionLock.st Thu Dec 07 22:24:46 1995 +0100
+++ b/RecursionLock.st Thu Dec 07 22:32:39 1995 +0100
@@ -11,8 +11,6 @@
"
-'From Smalltalk/X, Version:2.10.5 on 28-apr-1995 at 12:37:45 pm'!
-
Object subclass:#RecursionLock
instanceVariableNames:'process sema'
classVariableNames:''
@@ -22,6 +20,21 @@
!RecursionLock 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.
+"
+
+!
+
documentation
"
like a Semaphore for mutual exclusion, but avoids the deadlock
@@ -42,25 +55,6 @@
]
"
-!
-
-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/RecursionLock.st,v 1.5 1995-11-11 15:21:35 cg Exp $'
! !
!RecursionLock class methodsFor:'instance creation'!
@@ -70,6 +64,12 @@
! !
+!RecursionLock methodsFor:'private initialization'!
+
+initialize
+ sema := Semaphore forMutualExclusion
+! !
+
!RecursionLock methodsFor:'wait & signal'!
critical:aBlock
@@ -93,8 +93,8 @@
].
! !
-!RecursionLock methodsFor:'private initialization'!
+!RecursionLock class methodsFor:'documentation'!
-initialize
- sema := Semaphore forMutualExclusion
+version
+ ^ '$Header: /cvs/stx/stx/libbasic/RecursionLock.st,v 1.6 1995-12-07 21:30:23 cg Exp $'
! !
--- a/Semaphore.st Thu Dec 07 22:24:46 1995 +0100
+++ b/Semaphore.st Thu Dec 07 22:32:39 1995 +0100
@@ -14,7 +14,8 @@
instanceVariableNames:'count waitingProcesses'
classVariableNames:''
poolDictionaries:''
- category:'Kernel-Processes'!
+ category:'Kernel-Processes'
+!
!Semaphore class methodsFor:'documentation'!
@@ -32,10 +33,6 @@
"
!
-version
- ^ '$Header: /cvs/stx/stx/libbasic/Semaphore.st,v 1.23 1995-11-15 14:22:56 werner Exp $'
-!
-
documentation
"
Semaphores are used to synchronize processes providing a nonBusy wait
@@ -59,6 +56,13 @@
!Semaphore class methodsFor:'instance creation'!
+forMutualExclusion
+ "create & return a new semaphore which allows exactly one process to
+ wait on it without blocking"
+
+ ^ super new setCount:1
+!
+
new
"create & return a new semaphore which blocks until a signal is sent"
@@ -70,13 +74,12 @@
blocking"
^ super new setCount:n
-!
+! !
-forMutualExclusion
- "create & return a new semaphore which allows exactly one process to
- wait on it without blocking"
+!Semaphore methodsFor:'printing & storing'!
- ^ super new setCount:1
+displayString
+ ^ self class name , '(' , count printString , ')'
! !
!Semaphore methodsFor:'private accessing'!
@@ -95,13 +98,107 @@
^ count == 0
! !
-!Semaphore methodsFor:'printing & storing'!
+!Semaphore methodsFor:'wait & signal'!
+
+critical:aBlock
+ "evaluate aBlock as a critical region; the receiver must be
+ created using Semaphore>>forMutualExclusion"
+
+ self wait.
+ ^ aBlock valueNowOrOnUnwindDo:[self signal].
+
+ "
+ the example below is stupid (it should use a SharedQueue,
+ or at least a Queue with critical regions).
+ Anyhow, it demonstrates how two processes lock each other
+ from accessing coll at the same time
+
+ |sema coll|
+
+ sema := Semaphore forMutualExclusion.
+ coll := OrderedCollection new:10.
+
+ [
+ 1 to:1000 do:[:i |
+ sema critical:[
+ coll addLast:i.
+ (Delay forSeconds:0.1) wait.
+ ]
+ ]
+ ] forkAt:4.
+
+ [
+ 1 to:1000 do:[:i |
+ sema critical:[
+ coll removeFirst.
+ (Delay forSeconds:0.1) wait.
+ ]
+ ]
+ ] forkAt:4.
+ "
+!
+
+signal
+ "waking up (first) waiter"
+
+ |p wasBlocked|
-displayString
- ^ self class name , '(' , count printString , ')'
-! !
+ wasBlocked := OperatingSystem blockInterrupts.
+ count := count + 1.
+ waitingProcesses notEmpty ifTrue:[
+ p := waitingProcesses removeFirst.
+ p resume.
+ ].
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+!
+
+signalForAll
+ "signal the semaphore for all waiters.
+ This can be used for process synchronization, if multiple processes are
+ waiting for a common event."
+
+ |wasBlocked|
+
+ [waitingProcesses notEmpty] whileTrue:[
+ wasBlocked := OperatingSystem blockInterrupts.
+ waitingProcesses notEmpty ifTrue:[
+ self signal
+ ].
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+ ]
+!
-!Semaphore methodsFor:'wait & signal'!
+signalIf
+ "signal the semaphore, but only if being waited upon.
+ This can be used for one-shot semaphores (i.e. not remembering
+ previous signals)"
+
+ |wasBlocked|
+
+ waitingProcesses notEmpty ifTrue:[
+ wasBlocked := OperatingSystem blockInterrupts.
+ waitingProcesses notEmpty ifTrue:[
+ self signal
+ ].
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+ ]
+!
+
+signalOnce
+ "wakeup waiters - but only once.
+ I.e. if the semaphore has already been signalled, this
+ is ignored."
+
+ |wasBlocked|
+
+ count == 0 ifTrue:[
+ wasBlocked := OperatingSystem blockInterrupts.
+ count == 0 ifTrue:[
+ self signal
+ ].
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+ ]
+!
wait
"wait for the semaphore"
@@ -245,104 +342,10 @@
count := count - 1.
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
^ true
-!
-
-signalOnce
- "wakeup waiters - but only once.
- I.e. if the semaphore has already been signalled, this
- is ignored."
-
- |wasBlocked|
-
- count == 0 ifTrue:[
- wasBlocked := OperatingSystem blockInterrupts.
- count == 0 ifTrue:[
- self signal
- ].
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
- ]
-!
-
-signal
- "waking up (first) waiter"
-
- |p wasBlocked|
+! !
- wasBlocked := OperatingSystem blockInterrupts.
- count := count + 1.
- waitingProcesses notEmpty ifTrue:[
- p := waitingProcesses removeFirst.
- p resume.
- ].
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
-!
-
-signalIf
- "signal the semaphore, but only if being waited upon.
- This can be used for one-shot semaphores (i.e. not remembering
- previous signals)"
-
- |wasBlocked|
-
- waitingProcesses notEmpty ifTrue:[
- wasBlocked := OperatingSystem blockInterrupts.
- waitingProcesses notEmpty ifTrue:[
- self signal
- ].
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
- ]
-!
+!Semaphore class methodsFor:'documentation'!
-signalForAll
- "signal the semaphore for all waiters.
- This can be used for process synchronization, if multiple processes are
- waiting for a common event."
-
- |wasBlocked|
-
- [waitingProcesses notEmpty] whileTrue:[
- wasBlocked := OperatingSystem blockInterrupts.
- waitingProcesses notEmpty ifTrue:[
- self signal
- ].
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
- ]
-!
-
-critical:aBlock
- "evaluate aBlock as a critical region; the receiver must be
- created using Semaphore>>forMutualExclusion"
-
- self wait.
- ^ aBlock valueNowOrOnUnwindDo:[self signal].
-
- "
- the example below is stupid (it should use a SharedQueue,
- or at least a Queue with critical regions).
- Anyhow, it demonstrates how two processes lock each other
- from accessing coll at the same time
-
- |sema coll|
-
- sema := Semaphore forMutualExclusion.
- coll := OrderedCollection new:10.
-
- [
- 1 to:1000 do:[:i |
- sema critical:[
- coll addLast:i.
- (Delay forSeconds:0.1) wait.
- ]
- ]
- ] forkAt:4.
-
- [
- 1 to:1000 do:[:i |
- sema critical:[
- coll removeFirst.
- (Delay forSeconds:0.1) wait.
- ]
- ]
- ] forkAt:4.
- "
+version
+ ^ '$Header: /cvs/stx/stx/libbasic/Semaphore.st,v 1.24 1995-12-07 21:30:36 cg Exp $'
! !
--- a/Time.st Thu Dec 07 22:24:46 1995 +0100
+++ b/Time.st Thu Dec 07 22:32:39 1995 +0100
@@ -10,8 +10,6 @@
hereby transferred.
"
-'From Smalltalk/X, Version:2.10.4 on 8-feb-1995 at 12:46:41 pm'!
-
AbstractTime subclass:#Time
instanceVariableNames:'timeEncoding'
classVariableNames:''
@@ -35,10 +33,6 @@
"
!
-version
- ^ '$Header: /cvs/stx/stx/libbasic/Time.st,v 1.22 1995-11-16 23:28:50 cg Exp $'
-!
-
documentation
"
Instances of time represent a particular time-of-day.
@@ -120,24 +114,10 @@
!Time methodsFor:'accessing'!
-minutes
- "return the number of minutes within the hour (i.e. 0..59)"
-
- ^ (timeEncoding \\ 3600) // 60
+day
+ "catch day access - Time does not know about it"
- "
- Time now minutes
- "
-!
-
-seconds
- "return the number of seconds within the minute (i.e. 0..59)"
-
- ^ (timeEncoding \\ 3600) \\ 60
-
- "
- Time now seconds
- "
+ ^ self shouldNotImplement
!
hours
@@ -150,10 +130,14 @@
"
!
-day
- "catch day access - Time does not know about it"
+minutes
+ "return the number of minutes within the hour (i.e. 0..59)"
- ^ self shouldNotImplement
+ ^ (timeEncoding \\ 3600) // 60
+
+ "
+ Time now minutes
+ "
!
month
@@ -162,54 +146,86 @@
^ self shouldNotImplement
!
+seconds
+ "return the number of seconds within the minute (i.e. 0..59)"
+
+ ^ (timeEncoding \\ 3600) \\ 60
+
+ "
+ Time now seconds
+ "
+!
+
year
"catch year access - Time does not know about it"
^ self shouldNotImplement
! !
-!Time methodsFor:'printing & storing'!
+!Time methodsFor:'comparing'!
+
+< aTime
+ "return true if the argument, aTime is before the receiver"
+
+ ^ timeEncoding < aTime timeEncoding
+!
-printOn:aStream
- "append a printed representation of the receiver to aStream.
- Format is hh:mm:ss either in 12-hour or 24-hour format.
- depending on the setting of LanguageTerritory.
- I dont know what ST-80 does here (12-hour format ?)"
+= aTime
+ "return true if the argument, aTime represents the same timeOfDay"
+
+ aTime class == self class ifTrue:[
+ ^ timeEncoding == aTime timeEncoding
+ ].
+ (aTime species == self species) ifFalse:[^ false].
+ ^ self asSeconds == aTime asSeconds
+!
+
+> aTime
+ "return true if the argument, aTime is after the receiver"
- LanguageTerritory = 'usa' ifTrue:[
- self print12HourFormatOn:aStream
- ] ifFalse:[
- self print24HourFormatOn:aStream
- ]
+ ^ timeEncoding > aTime timeEncoding
+!
+
+hash
+ "return an integer useful for hashing on times"
+
+ ^ timeEncoding
+! !
+
+!Time methodsFor:'converting'!
+asAbsoluteTime
+ "return an AbsoluteTime object from the receiver.
+ The date components are taken from today."
+
+ |today|
+
+ today := Date today.
+ ^ AbsoluteTime day:today day month:today month year:today year
+ hour:self hours minutes:self minutes seconds:self seconds
"
- Time now printOn:Transcript. Transcript cr
+ Time now asAbsoluteTime
"
!
-print24HourFormatOn:aStream
- "append a printed representation of the receiver to aStream.
- Format is hh:mm:ss (i.e. 24-hour european format)."
-
- |h m s|
+asSeconds
+ "return the number of seconds elapsed since midnight"
- h := self hours.
- (h < 10) ifTrue:[aStream nextPut:$0].
- h printOn:aStream.
- aStream nextPut:$:.
- m := self minutes.
- (m < 10) ifTrue:[aStream nextPut:$0].
- m printOn:aStream.
- aStream nextPut:$:.
- s := self seconds.
- (s < 10) ifTrue:[aStream nextPut:$0].
- s printOn:aStream
+ ^ timeEncoding
"
- Time now print24HourFormatOn:Transcript. Transcript cr
+ Time now asSeconds
"
!
+asTime
+ "return a Time object from the receiver - thats the receiver."
+
+ ^ self
+! !
+
+!Time methodsFor:'printing & storing'!
+
print12HourFormatOn:aStream
"append a printed representation of the receiver to aStream.
Format is hh:mm:ss am/pm (i.e. 12-hour american format)."
@@ -243,68 +259,46 @@
"
Time now print12HourFormatOn:Transcript. Transcript cr
"
-! !
+!
-!Time methodsFor:'converting'!
+print24HourFormatOn:aStream
+ "append a printed representation of the receiver to aStream.
+ Format is hh:mm:ss (i.e. 24-hour european format)."
+
+ |h m s|
-asSeconds
- "return the number of seconds elapsed since midnight"
-
- ^ timeEncoding
+ h := self hours.
+ (h < 10) ifTrue:[aStream nextPut:$0].
+ h printOn:aStream.
+ aStream nextPut:$:.
+ m := self minutes.
+ (m < 10) ifTrue:[aStream nextPut:$0].
+ m printOn:aStream.
+ aStream nextPut:$:.
+ s := self seconds.
+ (s < 10) ifTrue:[aStream nextPut:$0].
+ s printOn:aStream
"
- Time now asSeconds
+ Time now print24HourFormatOn:Transcript. Transcript cr
"
!
-asTime
- "return a Time object from the receiver - thats the receiver."
-
- ^ self
-!
-
-asAbsoluteTime
- "return an AbsoluteTime object from the receiver.
- The date components are taken from today."
-
- |today|
-
- today := Date today.
- ^ AbsoluteTime day:today day month:today month year:today year
- hour:self hours minutes:self minutes seconds:self seconds
- "
- Time now asAbsoluteTime
- "
-! !
-
-!Time methodsFor:'comparing'!
+printOn:aStream
+ "append a printed representation of the receiver to aStream.
+ Format is hh:mm:ss either in 12-hour or 24-hour format.
+ depending on the setting of LanguageTerritory.
+ I dont know what ST-80 does here (12-hour format ?)"
-> aTime
- "return true if the argument, aTime is after the receiver"
-
- ^ timeEncoding > aTime timeEncoding
-!
-
-< aTime
- "return true if the argument, aTime is before the receiver"
-
- ^ timeEncoding < aTime timeEncoding
-!
+ LanguageTerritory = 'usa' ifTrue:[
+ self print12HourFormatOn:aStream
+ ] ifFalse:[
+ self print24HourFormatOn:aStream
+ ]
-= aTime
- "return true if the argument, aTime represents the same timeOfDay"
-
- aTime class == self class ifTrue:[
- ^ timeEncoding == aTime timeEncoding
- ].
- (aTime species == self species) ifFalse:[^ false].
- ^ self asSeconds == aTime asSeconds
-!
-
-hash
- "return an integer useful for hashing on times"
-
- ^ timeEncoding
+ "
+ Time now printOn:Transcript. Transcript cr
+ "
! !
!Time methodsFor:'private'!
@@ -328,16 +322,23 @@
^ timeEncoding
!
+setHour:h minutes:m seconds:s
+ "set my time given individual values"
+
+ timeEncoding := ((h\\24) * 60 * 60 ) + (m * 60) + s.
+!
+
setSeconds:secs
"set my time given seconds since midnight"
timeEncoding := secs
!
-setHour:h minutes:m seconds:s
- "set my time given individual values"
+timeEncoding
+ "the internal encoding is stricktly private,
+ and should not be used outside."
- timeEncoding := ((h\\24) * 60 * 60 ) + (m * 60) + s.
+ ^ timeEncoding
!
timeEncoding:encoding
@@ -345,11 +346,10 @@
and should not be used outside."
timeEncoding := encoding
-!
+! !
+
+!Time class methodsFor:'documentation'!
-timeEncoding
- "the internal encoding is stricktly private,
- and should not be used outside."
-
- ^ timeEncoding
+version
+ ^ '$Header: /cvs/stx/stx/libbasic/Time.st,v 1.23 1995-12-07 21:32:28 cg Exp $'
! !
--- a/Timestamp.st Thu Dec 07 22:24:46 1995 +0100
+++ b/Timestamp.st Thu Dec 07 22:32:39 1995 +0100
@@ -10,8 +10,6 @@
hereby transferred.
"
-'From Smalltalk/X, Version:2.10.4 on 8-feb-1995 at 12:46:45 pm'!
-
AbstractTime subclass:#AbsoluteTime
instanceVariableNames:'osTime'
classVariableNames:''
@@ -35,10 +33,6 @@
"
!
-version
- ^ '$Header: /cvs/stx/stx/libbasic/Timestamp.st,v 1.17 1995-11-16 23:27:50 cg Exp $'
-!
-
documentation
"
This class represents time values in seconds from 1st. Jan 1970, as
@@ -148,44 +142,6 @@
"Modified: 16.11.1995 / 22:49:39 / cg"
! !
-!AbsoluteTime methodsFor:'private'!
-
-secondsLow
- "strictly private: return the low part of the seconds"
-
- ^ osTime at:1
-!
-
-secondsHi
- "strictly private: return the hi part of the seconds"
-
- ^ osTime at:2
-!
-
-setSecondsLow:secsLow and:secsHi
- "strictly private: set the seconds (since whatever)"
-
- osTime := Array with:secsLow with:secsHi
-!
-
-setSeconds:secs
- "strictly private: set the seconds (since whatever)"
-
- osTime := Array with:(secs // 16r10000) with:(secs \\ 16r10000)
-!
-
-getSeconds
- "strictly private: return the seconds (since whatever)"
-
- ^ ((osTime at:2) * 16r10000) + (osTime at:1)
-!
-
-fromOSTimeLow:secsLow and:secsHi
- "strictly private: set the seconds from an OS time (since whatever)"
-
- osTime := Array with:secsLow with:secsHi
-! !
-
!AbsoluteTime methodsFor:'accessing'!
day
@@ -204,38 +160,6 @@
"
!
-month
- "return the month of the receiver (1..12).
- For compatibility, use instances of Date for this."
-
- |m|
-
- OperatingSystem computeDatePartsOf:osTime for:[ :year :month :day |
- m := month
- ].
- ^ m
-
- "
- AbsoluteTime now month
- "
-!
-
-year
- "return the year of the receiver i.e. 1992.
- For compatibility, use instances of Date for this."
-
- |y|
-
- OperatingSystem computeDatePartsOf:osTime for:[:year :month :day |
- y := year
- ].
- ^ y
-
- "
- AbsoluteTime now year
- "
-!
-
hours
"return the hours (0..23)"
@@ -268,6 +192,22 @@
!
+month
+ "return the month of the receiver (1..12).
+ For compatibility, use instances of Date for this."
+
+ |m|
+
+ OperatingSystem computeDatePartsOf:osTime for:[ :year :month :day |
+ m := month
+ ].
+ ^ m
+
+ "
+ AbsoluteTime now month
+ "
+!
+
seconds
"return the seconds (0..59)"
@@ -282,99 +222,22 @@
AbsoluteTime now seconds
"
-! !
-
-!AbsoluteTime methodsFor:'comparing'!
-
-> aTime
- "return true if the argument, aTime is after the receiver"
-
- |myHi otherHi|
-
- myHi := self secondsHi.
- otherHi := aTime secondsHi.
- myHi > otherHi ifTrue:[^ true].
- myHi < otherHi ifTrue:[^ false].
- ^ self secondsLow > aTime secondsLow
-!
-
-< aTime
- "return true if the argument, aTime is before the receiver"
-
- |myHi otherHi|
-
- myHi := self secondsHi.
- otherHi := aTime secondsHi.
- myHi < otherHi ifTrue:[^ true].
- myHi > otherHi ifTrue:[^ false].
- ^ self secondsLow < aTime secondsLow
-!
-
-= aTime
- "return true if the argument, aTime represents the same time"
-
- (aTime species == self species) ifFalse:[^ false].
- ^ (self secondsLow == aTime secondsLow) and:[self secondsHi == aTime secondsHi]
!
-hash
- "return an integer useful for hashing on times"
-
- ^ self getSeconds
-! !
-
-!AbsoluteTime methodsFor:'converting'!
+year
+ "return the year of the receiver i.e. 1992.
+ For compatibility, use instances of Date for this."
-asSeconds
- "return the number of seconds elapsed since whatever time the
- OperatingSystem bases its time upon. Since this is totally
- OS-dependent, do not interpret the value returned by this method.
- You can use it to add/subtract seconds or get time deltas, though."
+ |y|
- ^ self getSeconds
+ OperatingSystem computeDatePartsOf:osTime for:[:year :month :day |
+ y := year
+ ].
+ ^ y
"
- AbsoluteTime now asSeconds
- AbsoluteTime fromSeconds:(AbsoluteTime now asSeconds + 3600)
- Time hour:23 minutes:33 seconds:0
- Time fromSeconds:((Time hour:23 minutes:33 seconds:0) asSeconds + 3600)
- "
-!
-
-asDate
- "return a Date object from the receiver.
- The returned date will only represent the day - not the timeOfDay."
-
- ^ Date fromOSTime:osTime
-
- "
- AbsoluteTime now
- AbsoluteTime now asDate
- (AbsoluteTime now addTime:3600) asDate
- (AbsoluteTime now addTime:3600) asTime
- AbsoluteTime fromSeconds:(AbsoluteTime now asSeconds + 3600)
- (AbsoluteTime fromSeconds:(AbsoluteTime now asSeconds + 3600)) asDate
+ AbsoluteTime now year
"
-
-!
-
-asTime
- "return a Time object from the receiver.
- The returned time will only represent the timeOfDay - not the day."
-
- ^ Time fromOSTime:osTime
-
- "
- AbsoluteTime now
- AbsoluteTime now asTime
- (AbsoluteTime now addTime:3600) asTime
- "
-!
-
-asAbsoluteTime
- "return an AbsoluteTime object from the receiver - thats the receiver."
-
- ^ self
! !
!AbsoluteTime methodsFor:'arithmetic'!
@@ -413,6 +276,99 @@
"
! !
+!AbsoluteTime methodsFor:'comparing'!
+
+< aTime
+ "return true if the argument, aTime is before the receiver"
+
+ |myHi otherHi|
+
+ myHi := self secondsHi.
+ otherHi := aTime secondsHi.
+ myHi < otherHi ifTrue:[^ true].
+ myHi > otherHi ifTrue:[^ false].
+ ^ self secondsLow < aTime secondsLow
+!
+
+= aTime
+ "return true if the argument, aTime represents the same time"
+
+ (aTime species == self species) ifFalse:[^ false].
+ ^ (self secondsLow == aTime secondsLow) and:[self secondsHi == aTime secondsHi]
+!
+
+> aTime
+ "return true if the argument, aTime is after the receiver"
+
+ |myHi otherHi|
+
+ myHi := self secondsHi.
+ otherHi := aTime secondsHi.
+ myHi > otherHi ifTrue:[^ true].
+ myHi < otherHi ifTrue:[^ false].
+ ^ self secondsLow > aTime secondsLow
+!
+
+hash
+ "return an integer useful for hashing on times"
+
+ ^ self getSeconds
+! !
+
+!AbsoluteTime methodsFor:'converting'!
+
+asAbsoluteTime
+ "return an AbsoluteTime object from the receiver - thats the receiver."
+
+ ^ self
+!
+
+asDate
+ "return a Date object from the receiver.
+ The returned date will only represent the day - not the timeOfDay."
+
+ ^ Date fromOSTime:osTime
+
+ "
+ AbsoluteTime now
+ AbsoluteTime now asDate
+ (AbsoluteTime now addTime:3600) asDate
+ (AbsoluteTime now addTime:3600) asTime
+ AbsoluteTime fromSeconds:(AbsoluteTime now asSeconds + 3600)
+ (AbsoluteTime fromSeconds:(AbsoluteTime now asSeconds + 3600)) asDate
+ "
+
+!
+
+asSeconds
+ "return the number of seconds elapsed since whatever time the
+ OperatingSystem bases its time upon. Since this is totally
+ OS-dependent, do not interpret the value returned by this method.
+ You can use it to add/subtract seconds or get time deltas, though."
+
+ ^ self getSeconds
+
+ "
+ AbsoluteTime now asSeconds
+ AbsoluteTime fromSeconds:(AbsoluteTime now asSeconds + 3600)
+ Time hour:23 minutes:33 seconds:0
+ Time fromSeconds:((Time hour:23 minutes:33 seconds:0) asSeconds + 3600)
+ "
+!
+
+asTime
+ "return a Time object from the receiver.
+ The returned time will only represent the timeOfDay - not the day."
+
+ ^ Time fromOSTime:osTime
+
+ "
+ AbsoluteTime now
+ AbsoluteTime now asTime
+ (AbsoluteTime now addTime:3600) asTime
+ "
+! !
+
!AbsoluteTime methodsFor:'printing & storing'!
printOn:aStream
@@ -463,3 +419,47 @@
AbsoluteTime readFrom:(AbsoluteTime now storeString) readStream
"
! !
+
+!AbsoluteTime methodsFor:'private'!
+
+fromOSTimeLow:secsLow and:secsHi
+ "strictly private: set the seconds from an OS time (since whatever)"
+
+ osTime := Array with:secsLow with:secsHi
+!
+
+getSeconds
+ "strictly private: return the seconds (since whatever)"
+
+ ^ ((osTime at:2) * 16r10000) + (osTime at:1)
+!
+
+secondsHi
+ "strictly private: return the hi part of the seconds"
+
+ ^ osTime at:2
+!
+
+secondsLow
+ "strictly private: return the low part of the seconds"
+
+ ^ osTime at:1
+!
+
+setSeconds:secs
+ "strictly private: set the seconds (since whatever)"
+
+ osTime := Array with:(secs // 16r10000) with:(secs \\ 16r10000)
+!
+
+setSecondsLow:secsLow and:secsHi
+ "strictly private: set the seconds (since whatever)"
+
+ osTime := Array with:secsLow with:secsHi
+! !
+
+!AbsoluteTime class methodsFor:'documentation'!
+
+version
+ ^ '$Header: /cvs/stx/stx/libbasic/Timestamp.st,v 1.18 1995-12-07 21:31:29 cg Exp $'
+! !