# HG changeset patch # User Claus Gittinger # Date 818371959 -3600 # Node ID 12f456343eea813ce4ae52afadfcba5d61d01873 # Parent 04533375e12cd5ddc8fefd704f3d5fd88e2a9e33 checkin from browser diff -r 04533375e12c -r 12f456343eea AbsTime.st --- 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 $' +! ! diff -r 04533375e12c -r 12f456343eea AbsoluteTime.st --- 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 $' +! ! diff -r 04533375e12c -r 12f456343eea AbstrTime.st --- 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 -! ! - diff -r 04533375e12c -r 12f456343eea AbstractTime.st --- 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 -! ! - diff -r 04533375e12c -r 12f456343eea CCReader.st --- 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! diff -r 04533375e12c -r 12f456343eea Character.st --- 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 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 . + Wrap 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 . - Wrap 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 $' +! ! diff -r 04533375e12c -r 12f456343eea ClassCategoryReader.st --- 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! diff -r 04533375e12c -r 12f456343eea Date.st --- 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! diff -r 04533375e12c -r 12f456343eea Magnitude.st --- 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 $' +! ! diff -r 04533375e12c -r 12f456343eea ProcSched.st --- 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! diff -r 04533375e12c -r 12f456343eea Process.st --- 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! diff -r 04533375e12c -r 12f456343eea ProcessorScheduler.st --- 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! diff -r 04533375e12c -r 12f456343eea RecursionLock.st --- 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 $' ! ! diff -r 04533375e12c -r 12f456343eea Semaphore.st --- 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 $' ! ! diff -r 04533375e12c -r 12f456343eea Time.st --- 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 $' ! ! diff -r 04533375e12c -r 12f456343eea Timestamp.st --- 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 $' +! !