--- a/Boolean.st Mon Oct 10 01:29:01 1994 +0100
+++ b/Boolean.st Mon Oct 10 01:29:28 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1988 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -19,9 +19,9 @@
Boolean comment:'
COPYRIGHT (c) 1988 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Boolean.st,v 1.9 1994-08-05 00:54:01 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Boolean.st,v 1.10 1994-10-10 00:25:13 claus Exp $
'!
!Boolean class methodsFor:'documentation'!
@@ -29,7 +29,7 @@
copyright
"
COPYRIGHT (c) 1988 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Boolean.st,v 1.9 1994-08-05 00:54:01 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Boolean.st,v 1.10 1994-10-10 00:25:13 claus Exp $
"
!
@@ -81,6 +81,13 @@
!Boolean methodsFor:'copying'!
+copy
+ "return a shallow copy of the receiver
+ - since both true and false are unique, return the receiver"
+
+ ^ self
+!
+
shallowCopy
"return a shallow copy of the receiver
- since both true and false are unique, return the receiver"
@@ -137,5 +144,5 @@
hasSpecialBinaryRepresentation
"return true, if the receiver has a special binary representation"
- ^true
+ ^true
! !
--- a/CompCode.st Mon Oct 10 01:29:01 1994 +0100
+++ b/CompCode.st Mon Oct 10 01:29:28 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1994 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -13,18 +13,17 @@
ExecutableFunction subclass:#ExecutableCodeObject
instanceVariableNames:'byteCode literals'
classVariableNames:'NoByteCodeSignal InvalidByteCodeSignal
- InvalidInstructionSignal BadLiteralsSignal
- NonBooleanReceiverSignal ArgumentSignal
- AnyExecutionErrorSignal'
+ InvalidInstructionSignal BadLiteralsSignal
+ NonBooleanReceiverSignal ArgumentSignal'
poolDictionaries:''
category:'Kernel-Methods'
!
ExecutableCodeObject comment:'
COPYRIGHT (c) 1994 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Attic/CompCode.st,v 1.5 1994-08-22 12:20:34 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/CompCode.st,v 1.6 1994-10-10 00:25:41 claus Exp $
'!
!ExecutableCodeObject class methodsFor:'documentation'!
@@ -32,7 +31,7 @@
copyright
"
COPYRIGHT (c) 1994 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -45,7 +44,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Attic/CompCode.st,v 1.5 1994-08-22 12:20:34 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/CompCode.st,v 1.6 1994-10-10 00:25:41 claus Exp $
"
!
@@ -56,8 +55,8 @@
Instance variables:
- byteCode <ByteArray> bytecode of home method if its an interpreted codeobject
- literals <Array> the blocks literal array
+ byteCode <ByteArray> bytecode if its an interpreted codeobject
+ literals <Array> the block/methods literal array
NOTICE: layout known by runtime system and compiler - do not change
"
@@ -67,39 +66,40 @@
initialize
NoByteCodeSignal isNil ifTrue:[
- NoByteCodeSignal := (Signal new) mayProceed:true.
- NoByteCodeSignal notifierString:'nil byteCode in code-object - not executable'.
- InvalidByteCodeSignal := (Signal new) mayProceed:true.
- InvalidByteCodeSignal notifierString:'invalid byteCode in code-object - not executable'.
- InvalidInstructionSignal := (Signal new) mayProceed:true.
- InvalidInstructionSignal notifierString:'invalid instruction in code-object - not executable'.
- BadLiteralsSignal := (Signal new) mayProceed:true.
- BadLiteralsSignal notifierString:'bad literal table in code-object - should not happen'.
- NonBooleanReceiverSignal := (Signal new) mayProceed:true.
- NonBooleanReceiverSignal notifierString:'if/while on non-boolean receiver'.
- ArgumentSignal := (Signal new) mayProceed:true.
- ArgumentSignal notifierString:'bad argument(s)'.
+ ExecutableFunction initialize.
+
+ NoByteCodeSignal := ExecutionErrorSignal newSignalMayProceed:true.
+ NoByteCodeSignal nameClass:self message:#noByteCodeSignal.
+ NoByteCodeSignal notifierString:'nil byteCode in code-object - not executable'.
+
+ InvalidByteCodeSignal := ExecutionErrorSignal newSignalMayProceed:true.
+ InvalidByteCodeSignal nameClass:self message:#invalidByteCodeSignal.
+ InvalidByteCodeSignal notifierString:'invalid byteCode in code-object - not executable'.
+
+ InvalidInstructionSignal := ExecutionErrorSignal newSignalMayProceed:true.
+ InvalidInstructionSignal nameClass:self message:#invalidInstructionSignal.
+ InvalidInstructionSignal notifierString:'invalid instruction in code-object - not executable'.
+
+ BadLiteralsSignal := ExecutionErrorSignal newSignalMayProceed:true.
+ BadLiteralsSignal nameClass:self message:#badLiteralsSignal.
+ BadLiteralsSignal notifierString:'bad literal table in code-object - should not happen'.
+
+ NonBooleanReceiverSignal := ExecutionErrorSignal newSignalMayProceed:true.
+ NonBooleanReceiverSignal nameClass:self message:#nonBooleanReceiverSignal.
+ NonBooleanReceiverSignal notifierString:'if/while on non-boolean receiver'.
+
+ ArgumentSignal := ExecutionErrorSignal newSignalMayProceed:true.
+ ArgumentSignal nameClass:self message:#argumentSignal.
+ ArgumentSignal notifierString:'bad argument(s)'.
]
! !
!ExecutableCodeObject class methodsFor:'signal access'!
-anyExecutionErrorSignal
- "return a signalSet with any execution signal.
- This allows easy handling (catching) of execution errors
- in end-user applications."
+executionErrorSignal
+ "return the parent-signal of all execution errors"
- AnyExecutionErrorSignal isNil ifTrue:[
- AnyExecutionErrorSignal := SignalSet new.
- AnyExecutionErrorSignal add:ArgumentSignal;
- add:NonBooleanReceiverSignal;
- add:BadLiteralsSignal;
- add:InvalidInstructionSignal;
- add:InvalidByteCodeSignal;
- add:NoByteCodeSignal;
- add:InvalidCodeSignal.
- ].
- ^ AnyExecutionErrorSignal
+ ^ ExecutionErrorSignal
!
argumentSignal
@@ -197,8 +197,8 @@
if the compiler has been changed without updating the VM."
^ ArgumentSignal
- raiseRequestWith:self
- errorString:'too many args in send'
+ raiseRequestWith:self
+ errorString:'too many args in send'
!
badArgumentArray
@@ -206,6 +206,6 @@
or #value:with:."
^ ArgumentSignal
- raiseRequestWith:self
- errorString:'argumentArray must be an Array'
+ raiseRequestWith:self
+ errorString:'argumentArray must be an Array'
! !
--- a/CompiledCode.st Mon Oct 10 01:29:01 1994 +0100
+++ b/CompiledCode.st Mon Oct 10 01:29:28 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1994 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -13,18 +13,17 @@
ExecutableFunction subclass:#ExecutableCodeObject
instanceVariableNames:'byteCode literals'
classVariableNames:'NoByteCodeSignal InvalidByteCodeSignal
- InvalidInstructionSignal BadLiteralsSignal
- NonBooleanReceiverSignal ArgumentSignal
- AnyExecutionErrorSignal'
+ InvalidInstructionSignal BadLiteralsSignal
+ NonBooleanReceiverSignal ArgumentSignal'
poolDictionaries:''
category:'Kernel-Methods'
!
ExecutableCodeObject comment:'
COPYRIGHT (c) 1994 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/CompiledCode.st,v 1.5 1994-08-22 12:20:34 claus Exp $
+$Header: /cvs/stx/stx/libbasic/CompiledCode.st,v 1.6 1994-10-10 00:25:41 claus Exp $
'!
!ExecutableCodeObject class methodsFor:'documentation'!
@@ -32,7 +31,7 @@
copyright
"
COPYRIGHT (c) 1994 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -45,7 +44,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/CompiledCode.st,v 1.5 1994-08-22 12:20:34 claus Exp $
+$Header: /cvs/stx/stx/libbasic/CompiledCode.st,v 1.6 1994-10-10 00:25:41 claus Exp $
"
!
@@ -56,8 +55,8 @@
Instance variables:
- byteCode <ByteArray> bytecode of home method if its an interpreted codeobject
- literals <Array> the blocks literal array
+ byteCode <ByteArray> bytecode if its an interpreted codeobject
+ literals <Array> the block/methods literal array
NOTICE: layout known by runtime system and compiler - do not change
"
@@ -67,39 +66,40 @@
initialize
NoByteCodeSignal isNil ifTrue:[
- NoByteCodeSignal := (Signal new) mayProceed:true.
- NoByteCodeSignal notifierString:'nil byteCode in code-object - not executable'.
- InvalidByteCodeSignal := (Signal new) mayProceed:true.
- InvalidByteCodeSignal notifierString:'invalid byteCode in code-object - not executable'.
- InvalidInstructionSignal := (Signal new) mayProceed:true.
- InvalidInstructionSignal notifierString:'invalid instruction in code-object - not executable'.
- BadLiteralsSignal := (Signal new) mayProceed:true.
- BadLiteralsSignal notifierString:'bad literal table in code-object - should not happen'.
- NonBooleanReceiverSignal := (Signal new) mayProceed:true.
- NonBooleanReceiverSignal notifierString:'if/while on non-boolean receiver'.
- ArgumentSignal := (Signal new) mayProceed:true.
- ArgumentSignal notifierString:'bad argument(s)'.
+ ExecutableFunction initialize.
+
+ NoByteCodeSignal := ExecutionErrorSignal newSignalMayProceed:true.
+ NoByteCodeSignal nameClass:self message:#noByteCodeSignal.
+ NoByteCodeSignal notifierString:'nil byteCode in code-object - not executable'.
+
+ InvalidByteCodeSignal := ExecutionErrorSignal newSignalMayProceed:true.
+ InvalidByteCodeSignal nameClass:self message:#invalidByteCodeSignal.
+ InvalidByteCodeSignal notifierString:'invalid byteCode in code-object - not executable'.
+
+ InvalidInstructionSignal := ExecutionErrorSignal newSignalMayProceed:true.
+ InvalidInstructionSignal nameClass:self message:#invalidInstructionSignal.
+ InvalidInstructionSignal notifierString:'invalid instruction in code-object - not executable'.
+
+ BadLiteralsSignal := ExecutionErrorSignal newSignalMayProceed:true.
+ BadLiteralsSignal nameClass:self message:#badLiteralsSignal.
+ BadLiteralsSignal notifierString:'bad literal table in code-object - should not happen'.
+
+ NonBooleanReceiverSignal := ExecutionErrorSignal newSignalMayProceed:true.
+ NonBooleanReceiverSignal nameClass:self message:#nonBooleanReceiverSignal.
+ NonBooleanReceiverSignal notifierString:'if/while on non-boolean receiver'.
+
+ ArgumentSignal := ExecutionErrorSignal newSignalMayProceed:true.
+ ArgumentSignal nameClass:self message:#argumentSignal.
+ ArgumentSignal notifierString:'bad argument(s)'.
]
! !
!ExecutableCodeObject class methodsFor:'signal access'!
-anyExecutionErrorSignal
- "return a signalSet with any execution signal.
- This allows easy handling (catching) of execution errors
- in end-user applications."
+executionErrorSignal
+ "return the parent-signal of all execution errors"
- AnyExecutionErrorSignal isNil ifTrue:[
- AnyExecutionErrorSignal := SignalSet new.
- AnyExecutionErrorSignal add:ArgumentSignal;
- add:NonBooleanReceiverSignal;
- add:BadLiteralsSignal;
- add:InvalidInstructionSignal;
- add:InvalidByteCodeSignal;
- add:NoByteCodeSignal;
- add:InvalidCodeSignal.
- ].
- ^ AnyExecutionErrorSignal
+ ^ ExecutionErrorSignal
!
argumentSignal
@@ -197,8 +197,8 @@
if the compiler has been changed without updating the VM."
^ ArgumentSignal
- raiseRequestWith:self
- errorString:'too many args in send'
+ raiseRequestWith:self
+ errorString:'too many args in send'
!
badArgumentArray
@@ -206,6 +206,6 @@
or #value:with:."
^ ArgumentSignal
- raiseRequestWith:self
- errorString:'argumentArray must be an Array'
+ raiseRequestWith:self
+ errorString:'argumentArray must be an Array'
! !
--- a/ExecFunc.st Mon Oct 10 01:29:01 1994 +0100
+++ b/ExecFunc.st Mon Oct 10 01:29:28 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1994 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -12,16 +12,16 @@
Object subclass:#ExecutableFunction
instanceVariableNames:'code* flags'
- classVariableNames:'InvalidCodeSignal'
+ classVariableNames:'ExecutionErrorSignal InvalidCodeSignal'
poolDictionaries:''
category:'Kernel-Methods'
!
ExecutableFunction comment:'
COPYRIGHT (c) 1994 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Attic/ExecFunc.st,v 1.5 1994-08-22 12:20:41 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/ExecFunc.st,v 1.6 1994-10-10 00:25:44 claus Exp $
'!
!ExecutableFunction class methodsFor:'documentation'!
@@ -29,7 +29,7 @@
copyright
"
COPYRIGHT (c) 1994 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Attic/ExecFunc.st,v 1.5 1994-08-22 12:20:41 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/ExecFunc.st,v 1.6 1994-10-10 00:25:44 claus Exp $
"
!
@@ -54,7 +54,7 @@
Instance variables:
code <not_an_object> the function pointer to the machine code.
- Not accessable from smalltalk code.
+ Not accessable from smalltalk code.
flags <SmallInteger> special flag bits coded in a number
@@ -74,11 +74,26 @@
initialize
InvalidCodeSignal isNil ifTrue:[
- InvalidCodeSignal := (Signal new) mayProceed:true.
- InvalidCodeSignal notifierString:'invalid code-object - not executable'.
+ Object initialize.
+
+ ExecutionErrorSignal := ErrorSignal newSignalMayProceed:true.
+ ExecutionErrorSignal nameClass:self message:#executionErrorSignal.
+ ExecutionErrorSignal notifierString:'execution error'.
+
+ InvalidCodeSignal := ExecutionErrorSignal newSignalMayProceed:true.
+ InvalidCodeSignal nameClass:self message:#invalidCodeSignal.
+ InvalidCodeSignal notifierString:'invalid code-object - not executable'.
]
! !
+!ExecutableFunction class methodsFor:'signal access'!
+
+executionErrorSignal
+ "return the parent-signal of all execution errors"
+
+ ^ ExecutionErrorSignal
+! !
+
!ExecutableFunction methodsFor:'accessing'!
instVarAt:index
@@ -102,7 +117,7 @@
%{ /* NOCONTEXT */
if (_INST(code_) != nil) {
- RETURN ( _MKSMALLINT((int)(_INST(code_))) )
+ RETURN ( _MKSMALLINT((int)(_INST(code_))) )
}
%}
.
@@ -121,9 +136,9 @@
%{ /* NOCONTEXT */
if (_isSmallInteger(anAddress))
- _INST(code_) = (OBJ)(_intVal(anAddress));
+ _INST(code_) = (OBJ)(_intVal(anAddress));
else
- _INST(code_) = (OBJ)0;
+ _INST(code_) = (OBJ)0;
%}
!
@@ -137,9 +152,9 @@
/* made this a primitive to get define in stc.h */
if (aBoolean == true)
- newFlags |= F_DYNAMIC;
+ newFlags |= F_DYNAMIC;
else
- newFlags &= ~F_DYNAMIC;
+ newFlags &= ~F_DYNAMIC;
_INST(flags) = _MKSMALLINT(newFlags);
%}
--- a/ExecutableFunction.st Mon Oct 10 01:29:01 1994 +0100
+++ b/ExecutableFunction.st Mon Oct 10 01:29:28 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1994 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -12,16 +12,16 @@
Object subclass:#ExecutableFunction
instanceVariableNames:'code* flags'
- classVariableNames:'InvalidCodeSignal'
+ classVariableNames:'ExecutionErrorSignal InvalidCodeSignal'
poolDictionaries:''
category:'Kernel-Methods'
!
ExecutableFunction comment:'
COPYRIGHT (c) 1994 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/ExecutableFunction.st,v 1.5 1994-08-22 12:20:41 claus Exp $
+$Header: /cvs/stx/stx/libbasic/ExecutableFunction.st,v 1.6 1994-10-10 00:25:44 claus Exp $
'!
!ExecutableFunction class methodsFor:'documentation'!
@@ -29,7 +29,7 @@
copyright
"
COPYRIGHT (c) 1994 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/ExecutableFunction.st,v 1.5 1994-08-22 12:20:41 claus Exp $
+$Header: /cvs/stx/stx/libbasic/ExecutableFunction.st,v 1.6 1994-10-10 00:25:44 claus Exp $
"
!
@@ -54,7 +54,7 @@
Instance variables:
code <not_an_object> the function pointer to the machine code.
- Not accessable from smalltalk code.
+ Not accessable from smalltalk code.
flags <SmallInteger> special flag bits coded in a number
@@ -74,11 +74,26 @@
initialize
InvalidCodeSignal isNil ifTrue:[
- InvalidCodeSignal := (Signal new) mayProceed:true.
- InvalidCodeSignal notifierString:'invalid code-object - not executable'.
+ Object initialize.
+
+ ExecutionErrorSignal := ErrorSignal newSignalMayProceed:true.
+ ExecutionErrorSignal nameClass:self message:#executionErrorSignal.
+ ExecutionErrorSignal notifierString:'execution error'.
+
+ InvalidCodeSignal := ExecutionErrorSignal newSignalMayProceed:true.
+ InvalidCodeSignal nameClass:self message:#invalidCodeSignal.
+ InvalidCodeSignal notifierString:'invalid code-object - not executable'.
]
! !
+!ExecutableFunction class methodsFor:'signal access'!
+
+executionErrorSignal
+ "return the parent-signal of all execution errors"
+
+ ^ ExecutionErrorSignal
+! !
+
!ExecutableFunction methodsFor:'accessing'!
instVarAt:index
@@ -102,7 +117,7 @@
%{ /* NOCONTEXT */
if (_INST(code_) != nil) {
- RETURN ( _MKSMALLINT((int)(_INST(code_))) )
+ RETURN ( _MKSMALLINT((int)(_INST(code_))) )
}
%}
.
@@ -121,9 +136,9 @@
%{ /* NOCONTEXT */
if (_isSmallInteger(anAddress))
- _INST(code_) = (OBJ)(_intVal(anAddress));
+ _INST(code_) = (OBJ)(_intVal(anAddress));
else
- _INST(code_) = (OBJ)0;
+ _INST(code_) = (OBJ)0;
%}
!
@@ -137,9 +152,9 @@
/* made this a primitive to get define in stc.h */
if (aBoolean == true)
- newFlags |= F_DYNAMIC;
+ newFlags |= F_DYNAMIC;
else
- newFlags &= ~F_DYNAMIC;
+ newFlags &= ~F_DYNAMIC;
_INST(flags) = _MKSMALLINT(newFlags);
%}
--- a/ExtStream.st Mon Oct 10 01:29:01 1994 +0100
+++ b/ExtStream.st Mon Oct 10 01:29:28 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1988 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -11,17 +11,20 @@
"
ReadWriteStream subclass:#ExternalStream
- instanceVariableNames:'filePointer mode buffered binary useCRLF hitEOF didWrite'
- classVariableNames:'Lobby LastErrorNumber'
+ instanceVariableNames:'filePointer mode buffered binary useCRLF hitEOF didWrite lastErrorNumber'
+ classVariableNames:'Lobby LastErrorNumber
+ StreamErrorSignal ReadErrorSignal WriteErrorSignal
+ InvalidReadSignal InvalidWriteSignal InvalidModeSignal
+ StreamNotOpenSignal'
poolDictionaries:''
category:'Streams-External'
!
ExternalStream comment:'
COPYRIGHT (c) 1988 by Claus Gittinger
- All Rights Reserved
-
-$Header: /cvs/stx/stx/libbasic/Attic/ExtStream.st,v 1.20 1994-08-11 21:36:34 claus Exp $
+ All Rights Reserved
+
+$Header: /cvs/stx/stx/libbasic/Attic/ExtStream.st,v 1.21 1994-10-10 00:25:47 claus Exp $
'!
%{
@@ -39,7 +42,7 @@
copyright
"
COPYRIGHT (c) 1988 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -52,7 +55,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Attic/ExtStream.st,v 1.20 1994-08-11 21:36:34 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/ExtStream.st,v 1.21 1994-10-10 00:25:47 claus Exp $
"
!
@@ -62,7 +65,7 @@
represent some file or communicationChannel of the underlying OperatingSystem.
ExternalStream is abstract; concrete classes are FileStream, PipeStream etc.
- ExternalStreams can be in two modes: text (the default) and binary.
+ ExternalStreams can be in two modes: text- (the default) and binary-mode.
In text-mode, the elements read/written are characters;
while in binary-mode the basic elements are bytes which read/write as SmallIntegers
in the range 0..255.
@@ -75,7 +78,7 @@
or just forgotten - in this case, the garbage collector will eventually collect the
object AND a close will be performed automatically (but you will NOT know when this
happens - so it is recommended, that you close your files when no longer needed).
- Closing is also suggested since if smalltalk is finished (be it by purpose, or due to
+ Closing is also suggested, since if smalltalk is finished (be it by purpose, or due to
some crash) the data will not be in the file, if unclosed.
All streams understand the close message, so it never hurts to use it (it is defined as
a noop in one of the superclasses).
@@ -91,35 +94,81 @@
Instance variables:
- filePointer <Integer> the unix FILE*; somehow mapped to an integer
- (notice: not the fd)
- mode <Symbol> #readwrite, #readonly or #writeonly
- buffered <Boolean> true, if buffered (i.e. collects characters - does
- not output immediately)
- binary <Boolean> true if in binary mode (reads bytes instead of chars)
- useCRLF <Boolean> true, if lines should be terminated with crlf instead
- of lf. (i.e. if file is an MSDOS-type file)
- hitEOF <Boolean> true, if EOF was reached
-
+ filePointer <Integer> the unix FILE*; somehow mapped to an integer
+ (notice: not the fd)
+ mode <Symbol> #readwrite, #readonly or #writeonly
+ buffered <Boolean> true, if buffered (i.e. collects characters - does
+ not output immediately)
+ binary <Boolean> true if in binary mode (reads bytes instead of chars)
+ useCRLF <Boolean> true, if lines should be terminated with crlf instead
+ of lf. (i.e. if file is an MSDOS-type file)
+ hitEOF <Boolean> true, if EOF was reached
+
+ lastErrorNumber <Integer> the value of errno (only valid right after the error -
+ updated with next i/o operation)
Class variables:
- Lobby <Registry> keeps track of used ext-streams (to free up FILE*'s)
-
- LastErrorNumber <Integer> the value of errno (only valid right after the error -
- updated with next i/o operation)
-
- Question: should lastErrorNumber be kept instance-specific ?
+ Lobby <Registry> keeps track of used ext-streams (to free up FILE*'s)
+
+ StreamErrorSignal <Signal> parent of all stream errors
+ ReadErrorSignal <Signal> raised on read errors
+ WriteErrorSignal <Signal> raised on write errors
+ InvalidReadSignal <Signal> raised on read from writeonly stream
+ InvalidWriteSignal <Signal> raised on write to readonly stream
+ InvalidModeSignal <Signal> raised on text I/O with binary-stream
+ or binary I/O with text-stream
+ StreamNotOpenSignal <Signal> raised on I/O with non-open stream
+
+ Additional notes:
+ This class is implemented using the underlying stdio-c library package, which
+ has both advantages and disadvantages: since it is portable (posix defined), porting
+ ST/X to non-Unix machines is simplified. The disadvantage is that the stdio library
+ has big problems handling unbounded Streams, since the EOF handling in stdio is
+ not prepared for data to arrive after EOF has been reached - time will show, if we need
+ a complete rewrite for UnboundedStream ...
"
! !
!ExternalStream class methodsFor:'initialization'!
initialize
+ StreamErrorSignal isNil ifTrue:[
+ super initialize.
+
+ StreamErrorSignal := Object errorSignal newSignalMayProceed:false.
+ StreamErrorSignal nameClass:self message:#streamErrorSignal.
+ StreamErrorSignal notifierString:'I/O error'.
+
+ ReadErrorSignal := StreamErrorSignal newSignalMayProceed:false.
+ ReadErrorSignal nameClass:self message:#readErrorSignal.
+ ReadErrorSignal notifierString:'read error'.
+
+ WriteErrorSignal := StreamErrorSignal newSignalMayProceed:false.
+ WriteErrorSignal nameClass:self message:#writeErrorSignal.
+ WriteErrorSignal notifierString:'write error'.
+
+ InvalidReadSignal := ReadErrorSignal newSignalMayProceed:false.
+ InvalidReadSignal nameClass:self message:#invalidReadSignal.
+ InvalidReadSignal notifierString:'write error'.
+
+ InvalidWriteSignal := WriteErrorSignal newSignalMayProceed:false.
+ InvalidWriteSignal nameClass:self message:#invalidWriteSignal.
+ InvalidWriteSignal notifierString:'write error'.
+
+ InvalidModeSignal := StreamErrorSignal newSignalMayProceed:false.
+ InvalidModeSignal nameClass:self message:#invalidModeSignal.
+ InvalidModeSignal notifierString:'binary/text mode mismatch'.
+
+ StreamNotOpenSignal := StreamErrorSignal newSignalMayProceed:false.
+ StreamNotOpenSignal nameClass:self message:#streamNotOpenSignal.
+ StreamNotOpenSignal notifierString:'stream is not open'.
+ ].
+
Lobby isNil ifTrue:[
- Lobby := Registry new.
-
- "want to get informed when returning from snapshot"
- ObjectMemory addDependent:self
+ Lobby := Registry new.
+
+ "want to get informed when returning from snapshot"
+ ObjectMemory addDependent:self
]
!
@@ -127,7 +176,7 @@
"reopen all files (if possible) after a snapShot load"
Lobby contentsDo:[:aFileStream |
- aFileStream reOpen
+ aFileStream reOpen
]
!
@@ -135,10 +184,58 @@
"have to reopen files when returning from snapshot"
something == #returnFromSnapshot ifTrue:[
- self reOpenFiles
+ self reOpenFiles
]
! !
+!ExternalStream class methodsFor:'signal access '!
+
+streamErrorSignal
+ "return the parent of all stream errors;
+ handling this one also handles all other errors.
+ Also, this one is raised for errors not related to read/write
+ operations, such as failed ioctls"
+
+ ^ StreamErrorSignal
+!
+
+readErrorSignal
+ "return the signal raised on read errors"
+
+ ^ ReadErrorSignal
+!
+
+writeErrorSignal
+ "return the signal raised on write errors"
+
+ ^ WriteErrorSignal
+!
+
+invalidReadSignal
+ "return the signal raised when reading from writeonly streams"
+
+ ^ InvalidReadSignal
+!
+
+invalidWriteSignal
+ "return the signal raised when writing to readonly streams"
+
+ ^ InvalidWriteSignal
+!
+
+invalidModeSignal
+ "return the signal raised when doing text-I/O with a binary stream
+ or binary-I/O with a text stream"
+
+ ^ InvalidModeSignal
+!
+
+streamNotOpenSignal
+ "return the signal raised on I/O with closed streams"
+
+ ^ StreamNotOpenSignal
+! !
+
!ExternalStream class methodsFor:'instance creation'!
new
@@ -152,9 +249,13 @@
!ExternalStream class methodsFor:'error handling'!
lastErrorNumber
- "return the last error"
+ "return the errno of the last error"
^ LastErrorNumber
+
+ "
+ ExternalStream lastErrorNumber
+ "
!
lastErrorString
@@ -169,6 +270,18 @@
!ExternalStream methodsFor:'instance release'!
+shallowCopyForFinalization
+ "return a copy for finalization-registration;
+ since all we need at finalization time is the fileDescriptor,
+ a cheaper copy is possible."
+
+ ^ self class basicNew setFilePointer:filePointer
+!
+
+setFilePointer:anInteger
+ filePointer := anInteger
+!
+
disposed
"some Stream has been collected - close the file if not already done"
@@ -181,11 +294,11 @@
%{ /* NOCONTEXT */
if (_INST(filePointer) != nil) {
- extern int _immediateInterrupt;
-
- _immediateInterrupt = 1;
- fclose(MKFD(_INST(filePointer)));
- _immediateInterrupt = 0;
+ extern int _immediateInterrupt;
+
+ _immediateInterrupt = 1;
+ fclose(MKFD(_INST(filePointer)));
+ _immediateInterrupt = 0;
}
%}
! !
@@ -203,6 +316,10 @@
self class name errorPrint. ': cannot reOpen stream - stream closed' errorPrintNewline.
filePointer := nil.
Lobby unregister:self.
+!
+
+setLastError:aNumber
+ lastErrorNumber := aNumber
! !
!ExternalStream methodsFor:'error handling'!
@@ -210,49 +327,88 @@
lastErrorNumber
"return the last error"
- ^ LastErrorNumber
+ ^ lastErrorNumber
!
lastErrorString
"return a message string describing the last error"
- ^ self class lastErrorString
+ (lastErrorNumber isNil or:[lastErrorNumber == 0]) ifTrue:[
+ ^ 'I/O error'
+ ].
+ ^ OperatingSystem errorTextForNumber:lastErrorNumber
!
errorNotOpen
"report an error, that the stream has not been opened"
- ^ self error:(self class name , ' not open')
+ ^ StreamNotOpenSignal
+ raiseRequestWith:self
+ errorString:(self class name , ' not open')
!
errorReadOnly
"report an error, that the stream is a readOnly stream"
- ^ self error:(self class name , ' is readonly')
+ ^ InvalidWriteSignal
+ raiseRequestWith:self
+ errorString:(self class name , ' is readonly')
!
errorWriteOnly
"report an error, that the stream is a writeOnly stream"
- ^ self error:(self class name , ' is writeonly')
+ ^ InvalidReadSignal
+ raiseRequestWith:self
+ errorString:(self class name , ' is writeonly')
!
errorNotBinary
"report an error, that the stream is not in binary mode"
- ^ self error:(self class name , ' is not in binary mode')
+ ^ InvalidModeSignal
+ raiseRequestWith:self
+ errorString:(self class name , ' is not in binary mode')
!
errorBinary
"report an error, that the stream is in binary mode"
- ^ self error:(self class name , ' is in binary mode')
+ ^ InvalidModeSignal
+ raiseRequestWith:self
+ errorString:(self class name , ' is in binary mode')
!
errorNotBuffered
"report an error, that the stream is not in buffered mode"
- ^ self error:(self class name , ' is unbuffered - operation not allowed')
+ ^ StreamErrorSignal
+ raiseRequestWith:self
+ errorString:(self class name , ' is unbuffered - operation not allowed')
+!
+
+ioError
+ "report an error, that some I/O error occured"
+
+ ^ StreamErrorSignal
+ raiseRequestWith:self
+ errorString:('I/O error: ' , self lastErrorString)
+!
+
+readError
+ "report an error, that some read error occured"
+
+ ^ ReadErrorSignal
+ raiseRequestWith:self
+ errorString:('read error: ' , self lastErrorString)
+!
+
+writeError
+ "report an error, that some write error occured"
+
+ ^ WriteErrorSignal
+ raiseRequestWith:self
+ errorString:('write error: ' , self lastErrorString)
!
argumentMustBeInteger
@@ -312,8 +468,8 @@
FILE *f;
if (_INST(filePointer) != nil) {
- f = MKFD(_INST(filePointer));
- RETURN ( MKOBJ(fileno(f)) );
+ f = MKFD(_INST(filePointer));
+ RETURN ( MKOBJ(fileno(f)) );
}
%}
.
@@ -349,7 +505,7 @@
(such as upTo)"
binary ifTrue:[
- ^ ByteArray
+ ^ ByteArray
].
^ String
!
@@ -364,41 +520,41 @@
|text l chunks sizes chunk byteCount cnt bytes offset|
binary ifTrue:[
- "adding to a ByteArray produces quadratic time-space
- behavior - therefore we allocate chunks, and concatenate them
- at the end."
-
- chunks := OrderedCollection new.
- sizes := OrderedCollection new.
- byteCount := 0.
- [self atEnd] whileFalse:[
- chunk := ByteArray uninitializedNew:4096.
- cnt := self nextBytes:(chunk size) into:chunk.
- cnt notNil ifTrue:[
- chunks add:chunk.
- sizes add:cnt.
- byteCount := byteCount + cnt
- ]
- ].
-
- "now, create one big ByteArray"
- bytes := ByteArray uninitializedNew:byteCount.
- offset := 1.
- 1 to:chunks size do:[:index |
- chunk := chunks at:index.
- cnt := sizes at:index.
- bytes replaceFrom:offset to:(offset + cnt - 1) with:chunk.
- offset := offset + cnt
- ].
- ^ bytes
+ "adding to a ByteArray produces quadratic time-space
+ behavior - therefore we allocate chunks, and concatenate them
+ at the end."
+
+ chunks := OrderedCollection new.
+ sizes := OrderedCollection new.
+ byteCount := 0.
+ [self atEnd] whileFalse:[
+ chunk := ByteArray uninitializedNew:4096.
+ cnt := self nextBytes:(chunk size) into:chunk.
+ cnt notNil ifTrue:[
+ chunks add:chunk.
+ sizes add:cnt.
+ byteCount := byteCount + cnt
+ ]
+ ].
+
+ "now, create one big ByteArray"
+ bytes := ByteArray uninitializedNew:byteCount.
+ offset := 1.
+ 1 to:chunks size do:[:index |
+ chunk := chunks at:index.
+ cnt := sizes at:index.
+ bytes replaceFrom:offset to:(offset + cnt - 1) with:chunk.
+ offset := offset + cnt
+ ].
+ ^ bytes
].
text := Text new.
[self atEnd] whileFalse:[
- l := self nextLine.
- l notNil ifTrue:[
- text add:l
- ]
+ l := self nextLine.
+ l notNil ifTrue:[
+ text add:l
+ ]
].
^ text
! !
@@ -449,6 +605,18 @@
self position:(self position - 1)
!
+reset
+ "set the read position to the beginning of the collection"
+
+ self position:"0" 1
+!
+
+setToEnd
+ "redefined since it must be implemented differently"
+
+ ^ self subclassResponsibility
+!
+
blocking:aBoolean
"set/clear the blocking attribute - if set (which is the default)
a read (using next) on the receiver will block until data is available.
@@ -464,11 +632,14 @@
the receiver will trigger an ioInterrupt.
If cleared (which is the default) no special notification is made."
+ |fd|
+
filePointer isNil ifTrue:[^ self errorNotOpen].
+ fd := self fileDescriptor.
aBoolean ifTrue:[
- ^ OperatingSystem enableIOInterruptsOn:(self fileDescriptor)
+ ^ OperatingSystem enableIOInterruptsOn:fd
].
- ^ OperatingSystem disableIOInterruptsOn:(self fileDescriptor)
+ ^ OperatingSystem disableIOInterruptsOn:fd
!
ioctl:ioctlNumber
@@ -482,28 +653,32 @@
extern int _immediateInterrupt;
extern errno;
+ _INST(lastErrorNumber) = nil;
if (_INST(filePointer) != nil) {
- if (_isSmallInteger(ioctlNumber)) {
- ioNum = _intVal(ioctlNumber);
- f = MKFD(_INST(filePointer));
-
- _immediateInterrupt = 1;
- do {
- ret = ioctl(fileno(f), ioNum);
- } while ((ret < 0) && (errno == EINTR));
- _immediateInterrupt = 0;
-
- if (ret >= 0) {
- RETURN ( _MKSMALLINT(ret) );
- }
- ExternalStream_LastErrorNumber = _MKSMALLINT(errno);
- RETURN ( nil );
- }
+ if (_isSmallInteger(ioctlNumber)) {
+ ioNum = _intVal(ioctlNumber);
+ f = MKFD(_INST(filePointer));
+
+ _immediateInterrupt = 1;
+ do {
+ ret = ioctl(fileno(f), ioNum);
+ } while ((ret < 0) && (errno == EINTR));
+ _immediateInterrupt = 0;
+
+ if (ret >= 0) {
+ RETURN ( _MKSMALLINT(ret) );
+ }
+ _INST(position) = nil;
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ }
}
-%}
-.
+%}.
+ lastErrorNumber notNil ifTrue:[^ self ioError].
filePointer isNil ifTrue:[^ self errorNotOpen].
- self primitiveFailed
+ "
+ ioctl-number is not an integer
+ "
+ ^ self primitiveFailed
!
ioctl:ioctlNumber with:arg
@@ -514,42 +689,43 @@
the data is passed. This allows performing most ioctls - however,
it might be tricky to setup the buffer."
- |isStructure|
-
- isStructure := arg isKindOf:ByteArray.
-%{
+%{ /* NOCONTEXT */
FILE *f;
int ret, ioNum;
extern int _immediateInterrupt;
extern errno;
+ _INST(lastErrorNumber) = nil;
if (_INST(filePointer) != nil) {
- if (_isSmallInteger(ioctlNumber)
- && (_isSmallInteger(arg) || (isStructure == true))) {
- f = MKFD(_INST(filePointer));
- ioNum = _intVal(ioctlNumber);
-
- _immediateInterrupt = 1;
- do {
- if (isStructure == true) {
- ret = ioctl(fileno(f), ioNum, _ByteArrayInstPtr(arg)->ba_element);
- } else {
- ret = ioctl(fileno(f), ioNum, _intVal(arg));
- }
- } while ((ret < 0) && (errno == EINTR));
- _immediateInterrupt = 0;
-
- if (ret >= 0) {
- RETURN ( _MKSMALLINT(ret) );
- }
- ExternalStream_LastErrorNumber = _MKSMALLINT(errno);
- RETURN ( nil );
- }
+ if (_isSmallInteger(ioctlNumber)
+ && (_isSmallInteger(arg) || __isBytes(arg))) {
+ f = MKFD(_INST(filePointer));
+ ioNum = _intVal(ioctlNumber);
+
+ _immediateInterrupt = 1;
+ do {
+ if (_isSmallInteger(arg)) {
+ ret = ioctl(fileno(f), ioNum, _intVal(arg));
+ } else {
+ ret = ioctl(fileno(f), ioNum, _ByteArrayInstPtr(arg)->ba_element);
+ }
+ } while ((ret < 0) && (errno == EINTR));
+ _immediateInterrupt = 0;
+
+ if (ret >= 0) {
+ RETURN ( _MKSMALLINT(ret) );
+ }
+ _INST(position) = nil;
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ }
}
-%}
-.
+%}.
+ lastErrorNumber notNil ifTrue:[^ self ioError].
filePointer isNil ifTrue:[^ self errorNotOpen].
- self primitiveFailed
+ "
+ ioctl-number is not an integer or argument is not byteArray-like
+ "
+ ^ self primitiveFailed
! !
!ExternalStream methodsFor:'non homogenous reading'!
@@ -567,38 +743,42 @@
extern errno;
extern int _immediateInterrupt;
- if ((_INST(filePointer) != nil) && (_INST(mode) != _writeonly)) {
- f = MKFD(_INST(filePointer));
-
- _immediateInterrupt = 1;
- do {
- if (_INST(buffered) == false) {
- cnt = read(fileno(f), &byte, 1);
- } else {
- if ((_INST(didWrite) != false) && (_INST(mode) == _readwrite)) {
- _INST(didWrite) = false;
- fseek(f, 0L, 1); /* needed in stdio */
- }
- cnt = fread(&byte, 1, 1, f);
- }
- } while ((cnt < 0) && (errno == EINTR));
- _immediateInterrupt = 0;
-
- if (cnt == 1) {
- if (_INST(position) != nil)
- _INST(position) = _MKSMALLINT(_intVal(_INST(position)) + 1);
- RETURN ( _MKSMALLINT(byte) );
- }
- if (cnt < 0) {
- ExternalStream_LastErrorNumber = _MKSMALLINT(errno);
- }
- _INST(hitEOF) = true;
- RETURN ( nil );
+ _INST(lastErrorNumber) = nil;
+ if ((_INST(filePointer) != nil)
+ && (_INST(mode) != @symbol(writeonly))) {
+ f = MKFD(_INST(filePointer));
+
+ _immediateInterrupt = 1;
+ do {
+ if (_INST(buffered) == false) {
+ cnt = read(fileno(f), &byte, 1);
+ } else {
+ if ((_INST(didWrite) != false)
+ && (_INST(mode) == @symbol(readwrite))) {
+ _INST(didWrite) = false;
+ fseek(f, 0L, 1); /* needed in stdio */
+ }
+ cnt = fread(&byte, 1, 1, f);
+ }
+ } while ((cnt < 0) && (errno == EINTR));
+ _immediateInterrupt = 0;
+
+ if (cnt == 1) {
+ if (_INST(position) != nil)
+ _INST(position) = _MKSMALLINT(_intVal(_INST(position)) + 1);
+ RETURN ( _MKSMALLINT(byte) );
+ }
+ if (cnt == 0) {
+ _INST(hitEOF) = true;
+ RETURN (nil);
+ }
+ _INST(position) = nil;
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
}
-%}
-.
+%}.
+ lastErrorNumber notNil ifTrue:[^ self readError].
filePointer isNil ifTrue:[^ self errorNotOpen].
- self errorWriteOnly
+ ^ self errorWriteOnly
!
nextBytesInto:anObject
@@ -642,10 +822,13 @@
nextBytes:count into:anObject startingAt:start
"read the next count bytes into an object and return the number of
- bytes read or nil on error. On EOF, 0 is returned.
- The object must have non-pointer indexed instvars (i.e. it must be
- a ByteArray, String, Float- or DoubleArray).
- Use with care - non object oriented i/o."
+ bytes read or 0 on EOF. Notice, that in contrast to other methods
+ here, this does NOT return nil on EOF, but the actual count.
+ Thus allowing read of partial blocks.
+
+ The object must have non-pointer indexed instvars
+ (i.e. it must be a ByteArray, String, Float- or DoubleArray).
+ Use with care - non object oriented I/O."
%{ /* NOCONTEXT */
@@ -658,388 +841,256 @@
extern int _immediateInterrupt;
OBJ oClass;
- if ((_INST(filePointer) != nil) && (_INST(mode) != _writeonly)) {
- if (_isSmallInteger(count) && _isSmallInteger(start)) {
- oClass = _Class(anObject);
- switch (_intVal(_ClassInstPtr(oClass)->c_flags) & ARRAYMASK) {
- case BYTEARRAY:
- case WORDARRAY:
- case LONGARRAY:
- case FLOATARRAY:
- case DOUBLEARRAY:
- break;
- default:
- goto bad;
- }
- cnt = _intVal(count);
- offs = _intVal(start) - 1;
- f = MKFD(_INST(filePointer));
- nInstVars = _intVal(_ClassInstPtr(oClass)->c_ninstvars);
- nInstBytes = OHDR_SIZE + __OBJS2BYTES__(nInstVars);
- objSize = _Size(anObject) - nInstBytes;
- if ((offs >= 0) && (cnt >= 0) && (objSize >= (cnt + offs))) {
- cp = (char *)_InstPtr(anObject) + nInstBytes + offs;
-
- _immediateInterrupt = 1;
- do {
- if (_INST(buffered) == false) {
- cnt = read(fileno(f), cp, cnt);
- } else {
- if ((_INST(didWrite) != false) && (_INST(mode) == _readwrite)) {
- _INST(didWrite) = false;
- fseek(f, 0L, 1); /* needed in stdio */
- }
- cnt = fread(cp, 1, cnt, f);
- }
- } while ((cnt < 0) && (errno == EINTR));
- _immediateInterrupt = 0;
-
- if (cnt >= 0) {
- if (cnt == 0)
- _INST(hitEOF) = true;
- else {
- pos = _INST(position);
- if (pos != nil)
- _INST(position) = _MKSMALLINT(_intVal(pos) + cnt);
- }
- RETURN ( _MKSMALLINT(cnt) );
- }
- ExternalStream_LastErrorNumber = _MKSMALLINT(errno);
- RETURN ( nil );
- }
- }
+ _INST(lastErrorNumber) = nil;
+ if ((_INST(filePointer) != nil)
+ && (_INST(mode) != @symbol(writeonly))) {
+ if (_isSmallInteger(count) && _isSmallInteger(start)) {
+ oClass = _Class(anObject);
+ switch (_intVal(_ClassInstPtr(oClass)->c_flags) & ARRAYMASK) {
+ case BYTEARRAY:
+ case WORDARRAY:
+ case LONGARRAY:
+ case FLOATARRAY:
+ case DOUBLEARRAY:
+ break;
+ default:
+ goto bad;
+ }
+ cnt = _intVal(count);
+ offs = _intVal(start) - 1;
+ f = MKFD(_INST(filePointer));
+ nInstVars = _intVal(_ClassInstPtr(oClass)->c_ninstvars);
+ nInstBytes = OHDR_SIZE + __OBJS2BYTES__(nInstVars);
+ objSize = _Size(anObject) - nInstBytes;
+ if ((offs >= 0) && (cnt >= 0) && (objSize >= (cnt + offs))) {
+ cp = (char *)_InstPtr(anObject) + nInstBytes + offs;
+
+ _immediateInterrupt = 1;
+ do {
+ if (_INST(buffered) == false) {
+ cnt = read(fileno(f), cp, cnt);
+ } else {
+ if ((_INST(didWrite) != false)
+ && (_INST(mode) == @symbol(readwrite))) {
+ _INST(didWrite) = false;
+ fseek(f, 0L, 1); /* needed in stdio */
+ }
+ cnt = fread(cp, 1, cnt, f);
+ }
+ } while ((cnt < 0) && (errno == EINTR));
+ _immediateInterrupt = 0;
+
+ if (cnt >= 0) {
+ if (cnt == 0)
+ _INST(hitEOF) = true;
+ else {
+ pos = _INST(position);
+ if (pos != nil)
+ _INST(position) = _MKSMALLINT(_intVal(pos) + cnt);
+ }
+ RETURN (_MKSMALLINT(cnt));
+ }
+ _INST(position) = nil;
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ }
+ }
}
bad: ;
-%}
-.
+%}.
+ lastErrorNumber notNil ifTrue:[^ self readError].
filePointer isNil ifTrue:[^ self errorNotOpen].
(mode == #writeonly) ifTrue:[^ self errorWriteOnly].
- self primitiveFailed
-!
-
-nextWord
- "in text-mode:
- read the next word (i.e. up to non letter-or-digit).
- return a string containing those characters.
- in binary-mode:
- read two bytes (msb-first) and return the value as a 16-bit unsigned Integer
- (for compatibility with other smalltalks)"
-
-%{ /* NOCONTEXT */
- extern int _immediateInterrupt;
- int _buffered;
-
- _buffered = (_INST(buffered) == true);
- /*
- * binary mode
- */
- if (_INST(binary) == true) {
- if ((_INST(filePointer) != nil) && (_INST(mode) != _writeonly)) {
- FILE *f;
- unsigned char hi, low;
- int cnt;
- OBJ pos;
-
- f = MKFD(_INST(filePointer));
-
- _immediateInterrupt = 1;
-
- if (_buffered) {
- if ((_INST(didWrite) != false) && (_INST(mode) == _readwrite)) {
- _INST(didWrite) = false;
- fseek(f, 0L, 1); /* needed in stdio */
- }
- }
-
- do {
- if (! _buffered) {
- cnt = read(fileno(f), &hi, 1);
- } else {
- cnt = fread(&hi, 1, 1, f);
- }
- } while ((cnt < 0) && (errno == EINTR));
-
- if (cnt <= 0) {
- _INST(hitEOF) = true;
- if (cnt < 0)
- ExternalStream_LastErrorNumber = _MKSMALLINT(errno);
- _immediateInterrupt = 0;
- RETURN ( nil );
- }
-
- do {
- if (! _buffered) {
- cnt = read(fileno(f), &low, 1);
- } else {
- cnt = fread(&low, 1, 1, f);
- }
- } while ((cnt < 0) && (errno == EINTR));
-
- _immediateInterrupt = 0;
-
- pos = _INST(position);
- if (cnt <= 0) {
- if (pos != nil) {
- _INST(position) = _MKSMALLINT(_intVal(pos) + 1);
- }
- _INST(hitEOF) = true;
- if (cnt < 0)
- ExternalStream_LastErrorNumber = _MKSMALLINT(errno);
- RETURN ( _MKSMALLINT(hi & 0xFF) );
- }
- if (pos != nil) {
- _INST(position) = _MKSMALLINT(_intVal(pos) + 2);
- }
- RETURN ( _MKSMALLINT(((hi & 0xFF)<<8) | (low & 0xFF)) );
- }
- }
-%}
-.
-%{ /* STACK: 2000 */
- FILE *f;
- int len;
- char buffer[1024];
- int ch;
- int cnt = 0;
- extern int _immediateInterrupt;
-
- /*
- * text mode
- */
- if ((_INST(filePointer) != nil) && (_INST(mode) != _writeonly)) {
- f = MKFD(_INST(filePointer));
-
- _immediateInterrupt = 1;
-
- if ((_INST(didWrite) != false) && (_INST(mode) == _readwrite)) {
- _INST(didWrite) = false;
- fseek(f, 0L, 1); /* needed in stdio */
- }
-
- for (;;) {
- ch = getc(f);
- cnt++;
-
- if (ch >= ' ') break;
- if ((ch != ' ') && (ch != '\t') && (ch != '\r')
- && (ch != '\n') && (ch != 0x0b)) break;
- }
- ungetc(ch, f);
- cnt--;
-
- len = 0;
- for (;;) {
- ch = getc(f);
- if (ch == EOF) {
- _INST(hitEOF) = true;
- break;
- }
-
- ch &= 0xFF;
- if (! (((ch >= 'a') && (ch <= 'z')) ||
- ((ch >= 'A') && (ch <= 'Z')) ||
- ((ch >= '0') && (ch <= '9')))) {
- ungetc(ch, f);
- break;
- }
- cnt++;
- buffer[len++] = ch;
- if (len >= sizeof(buffer)-1) {
- /* emergency */
- break;
- }
- }
- _immediateInterrupt = 0;
-
- if (_INST(position) != nil) {
- _INST(position) = _MKSMALLINT(_intVal(_INST(position)) + cnt);
- }
- buffer[len] = '\0';
- if (len != 0) {
- RETURN ( _MKSTRING(buffer COMMA_CON) );
- }
- RETURN ( nil );
- }
-%}
-.
- filePointer isNil ifTrue:[^ self errorNotOpen].
- self errorWriteOnly
+ "
+ count not integer or arg not bit-like (String, ByteArray etc)
+ "
+ ^ self primitiveFailed
!
nextShortMSB:msbFlag
"Read two bytes and return the value as a 16-bit signed Integer.
- If msbFlag is true, value is read with most-significant byte first, otherwise
- least-significant byte comes first.
- A nil is also returned, if endOfFile occurs after the first byte.
+ If msbFlag is true, value is read with most-significant byte first,
+ otherwise least-significant byte comes first.
+ A nil is returned if EOF is reached (also when EOF is hit after the first byte).
Works in both binary and text modes."
%{ /* NOCONTEXT */
extern int _immediateInterrupt;
- if ((_INST(filePointer) != nil) && (_INST(mode) != _writeonly)) {
- FILE *f;
- int first, second;
- short value;
-
- f = MKFD(_INST(filePointer));
-
- _immediateInterrupt = 1;
- if ((_INST(didWrite) != false) && (_INST(mode) == _readwrite)) {
- _INST(didWrite) = false;
- fseek(f, 0L, 1); /* needed in stdio */
- }
- first = getc(f);
- if (first == EOF) {
- _immediateInterrupt = 0;
- _INST(hitEOF) = true;
- RETURN ( nil );
- }
- second = getc(f);
- _immediateInterrupt = 0;
-
- if (second == EOF) {
- _INST(hitEOF) = true;
- RETURN ( nil );
- }
- if (_INST(position) != nil) {
- _INST(position) = _MKSMALLINT(_intVal(_INST(position)) + 2);
- }
- if (msbFlag == true) {
- RETURN ( _MKSMALLINT(((first & 0xFF)<<8) | (second & 0xFF)) );
- }
- RETURN ( _MKSMALLINT(((second & 0xFF)<<8) | (first & 0xFF)) );
+ _INST(lastErrorNumber) = nil;
+ if ((_INST(filePointer) != nil)
+ && (_INST(mode) != @symbol(writeonly))) {
+ FILE *f;
+ int first, second, err;
+ short value;
+
+ f = MKFD(_INST(filePointer));
+
+ _immediateInterrupt = 1;
+ if ((_INST(didWrite) != false)
+ && (_INST(mode) == @symbol(readwrite))) {
+ _INST(didWrite) = false;
+ fseek(f, 0L, 1); /* needed in stdio */
+ }
+ first = getc(f);
+ if (first != EOF) {
+ second = getc(f);
+ _immediateInterrupt = 0;
+ if (second != EOF) {
+ if (_INST(position) != nil) {
+ _INST(position) = _MKSMALLINT(_intVal(_INST(position)) + 2);
+ }
+ if (msbFlag == true) {
+ value = ((first & 0xFF) << 8) | (second & 0xFF);
+ } else {
+ value = ((second & 0xFF) << 8) | (first & 0xFF);
+ }
+ RETURN (_MKSMALLINT(value));
+ }
+ }
+ _immediateInterrupt = 0;
+
+ if (ferror(f)) {
+ _INST(position) = nil;
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ } else {
+ _INST(hitEOF) = true;
+ RETURN (nil);
+ }
}
-%}
-.
+%}.
filePointer isNil ifTrue:[^ self errorNotOpen].
(mode == #writeonly) ifTrue:[^ self errorWriteOnly].
- self primitiveFailed
+ ^ self readError.
!
nextUnsignedShortMSB:msbFlag
"Read two bytes and return the value as a 16-bit unsigned Integer.
If msbFlag is true, value is read with most-significant byte first, otherwise
least-significant byte comes first.
- A nil is also returned, if endOfFile occurs after the first byte.
- Works in both binary and text modes."
-
-%{ /* NOCONTEXT */
- extern int _immediateInterrupt;
-
- if ((_INST(filePointer) != nil) && (_INST(mode) != _writeonly)) {
- FILE *f;
- int first, second;
-
- _immediateInterrupt = 1;
-
- f = MKFD(_INST(filePointer));
-
- if ((_INST(didWrite) != false) && (_INST(mode) == _readwrite)) {
- _INST(didWrite) = false;
- fseek(f, 0L, 1); /* needed in stdio */
- }
-
- first = getc(f);
- if (first == EOF) {
- _immediateInterrupt = 0;
- _INST(hitEOF) = true;
- RETURN ( nil );
- }
- second = getc(f);
- _immediateInterrupt = 0;
-
- if (second == EOF) {
- _INST(hitEOF) = true;
- RETURN ( nil );
- }
- if (_INST(position) != nil) {
- _INST(position) = _MKSMALLINT(_intVal(_INST(position)) + 2);
- }
- if (msbFlag == true) {
- RETURN ( _MKSMALLINT(((first & 0xFF)<<8) | (second & 0xFF)) );
- }
- RETURN ( _MKSMALLINT(((second & 0xFF)<<8) | (first & 0xFF)) );
- }
-%}
-.
- filePointer isNil ifTrue:[^ self errorNotOpen].
- (mode == #writeonly) ifTrue:[^ self errorWriteOnly].
- self primitiveFailed
-!
-
-nextLongMSB:msbFlag
- "Read four bytes and return the value as a 32-bit signed Integer, which may be
- a LargeInteger.
- If msbFlag is true, value is read with most-significant byte first, otherwise
- least-significant byte comes first.
- A nil is returned, if endOfFile occurs before all 4 bytes have been read.
+ A nil is returned if EOF is reached (also when EOF is hit after the first byte).
Works in both binary and text modes."
%{ /* NOCONTEXT */
extern int _immediateInterrupt;
- if ((_INST(filePointer) != nil) && (_INST(mode) != _writeonly)) {
- FILE *f;
- int first, second, third, fourth;
- int value;
-
- _immediateInterrupt = 1;
- f = MKFD(_INST(filePointer));
-
- if ((_INST(didWrite) != false) && (_INST(mode) == _readwrite)) {
- _INST(didWrite) = false;
- fseek(f, 0L, 1); /* needed in stdio */
- }
-
- first = getc(f);
- if (first == EOF) {
- _INST(hitEOF) = true;
- _immediateInterrupt = 0;
- RETURN ( nil );
- }
- second = getc(f);
- if (second == EOF) {
- _INST(hitEOF) = true;
- _immediateInterrupt = 0;
- RETURN ( nil );
- }
- third = getc(f);
- if (third == EOF) {
- _INST(hitEOF) = true;
- _immediateInterrupt = 0;
- RETURN ( nil );
- }
- fourth = getc(f);
- _immediateInterrupt = 0;
-
- if (fourth == EOF) {
- _INST(hitEOF) = true;
- RETURN ( nil );
- }
- if (_INST(position) != nil) {
- _INST(position) = _MKSMALLINT(_intVal(_INST(position)) + 4);
- }
- if (msbFlag == true) {
- value = ((first & 0xFF) << 24)
- | ((second & 0xFF) << 16)
- | ((third & 0xFF) << 8)
- | (fourth & 0xFF);
- } else {
- value = ((fourth & 0xFF) << 24)
- | ((third & 0xFF) << 16)
- | ((second & 0xFF) << 8)
- | (first & 0xFF);
- }
- if ((value >= _MIN_INT) && (value <= _MAX_INT)) {
- RETURN ( _MKSMALLINT(value));
- }
- RETURN ( _makeLarge(value) );
+ _INST(lastErrorNumber) = nil;
+ if ((_INST(filePointer) != nil)
+ && (_INST(mode) != @symbol(writeonly))) {
+ FILE *f;
+ int first, second;
+ unsigned value;
+ _immediateInterrupt = 1;
+
+ f = MKFD(_INST(filePointer));
+
+ if ((_INST(didWrite) != false)
+ && (_INST(mode) == @symbol(readwrite))) {
+ _INST(didWrite) = false;
+ fseek(f, 0L, 1); /* needed in stdio */
+ }
+
+ first = getc(f);
+ if (first != EOF) {
+ second = getc(f);
+ _immediateInterrupt = 0;
+ if (second != EOF) {
+ if (_INST(position) != nil) {
+ _INST(position) = _MKSMALLINT(_intVal(_INST(position)) + 2);
+ }
+ if (msbFlag == true) {
+ value = ((first & 0xFF) << 8) | (second & 0xFF);
+ } else {
+ value = ((second & 0xFF) << 8) | (first & 0xFF);
+ }
+ RETURN (_MKSMALLINT(value));
+ }
+ }
+ _immediateInterrupt = 0;
+
+ if (ferror(f)) {
+ _INST(position) = nil;
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ } else {
+ _INST(hitEOF) = true;
+ RETURN (nil);
+ }
}
-%}
-.
+%}.
filePointer isNil ifTrue:[^ self errorNotOpen].
(mode == #writeonly) ifTrue:[^ self errorWriteOnly].
- self primitiveFailed
+ ^ self readError.
+!
+
+nextLongMSB:msbFlag
+ "Read four bytes and return the value as a 32-bit signed Integer,
+ which may be a LargeInteger.
+ If msbFlag is true, value is read with most-significant byte first,
+ otherwise least-significant byte comes first.
+ A nil is returned, if EOF is hit before all 4 bytes have been read.
+ Works in both binary and text modes."
+
+%{ /* NOCONTEXT */
+ extern int _immediateInterrupt;
+
+ _INST(lastErrorNumber) = nil;
+ if ((_INST(filePointer) != nil)
+ && (_INST(mode) != @symbol(writeonly))) {
+ FILE *f;
+ int first, second, third, fourth;
+ int value;
+
+ _immediateInterrupt = 1;
+ f = MKFD(_INST(filePointer));
+
+ if ((_INST(didWrite) != false)
+ && (_INST(mode) == @symbol(readwrite))) {
+ _INST(didWrite) = false;
+ fseek(f, 0L, 1); /* needed in stdio */
+ }
+
+ first = getc(f);
+ if (first != EOF) {
+ second = getc(f);
+ if (second != EOF) {
+ third = getc(f);
+ if (third != EOF) {
+ fourth = getc(f);
+ if (fourth != EOF) {
+ _immediateInterrupt = 0;
+ if (msbFlag == true) {
+ value = (first & 0xFF);
+ value = (value<<8) | (second & 0xFF);
+ value = (value<<8) | (third & 0xFF);
+ value = (value<<8) | (fourth & 0xFF);
+ } else {
+ value = (fourth & 0xFF);
+ value = (value<<8) | (third & 0xFF);
+ value = (value<<8) | (second & 0xFF);
+ value = (value<<8) | (first & 0xFF);
+ }
+ if (_INST(position) != nil) {
+ _INST(position) = _MKSMALLINT(_intVal(_INST(position)) + 4);
+ }
+ if ((value >= _MIN_INT) && (value <= _MAX_INT)) {
+ RETURN ( _MKSMALLINT(value));
+ }
+ RETURN ( _makeLarge(value) );
+ }
+ }
+ }
+ }
+ if (ferror(f)) {
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ _INST(position) = nil;
+ } else {
+ _INST(hitEOF) = true;
+ RETURN (nil);
+ }
+ }
+%}.
+ filePointer isNil ifTrue:[^ self errorNotOpen].
+ (mode == #writeonly) ifTrue:[^ self errorWriteOnly].
+ ^ self readError.
!
nextUnsignedLongMSB:msbFlag
@@ -1054,67 +1105,79 @@
extern int _immediateInterrupt;
extern OBJ _makeULarge();
- if ((_INST(filePointer) != nil) && (_INST(mode) != _writeonly)) {
- FILE *f;
- int first, second, third, fourth;
- unsigned int value;
-
- _immediateInterrupt = 1;
- f = MKFD(_INST(filePointer));
-
- if ((_INST(didWrite) != false) && (_INST(mode) == _readwrite)) {
- _INST(didWrite) = false;
- fseek(f, 0L, 1); /* needed in stdio */
- }
-
- first = getc(f);
- if (first == EOF) {
- _INST(hitEOF) = true;
- _immediateInterrupt = 0;
- RETURN ( nil );
- }
- second = getc(f);
- if (second == EOF) {
- _INST(hitEOF) = true;
- _immediateInterrupt = 0;
- RETURN ( nil );
- }
- third = getc(f);
- if (third == EOF) {
- _INST(hitEOF) = true;
- _immediateInterrupt = 0;
- RETURN ( nil );
- }
- fourth = getc(f);
- _immediateInterrupt = 0;
- if (fourth == EOF) {
- _INST(hitEOF) = true;
- RETURN ( nil );
- }
- if (_INST(position) != nil) {
- _INST(position) = _MKSMALLINT(_intVal(_INST(position)) + 4);
- }
- if (msbFlag == true) {
- value = ((first & 0xFF) << 24)
- | ((second & 0xFF) << 16)
- | ((third & 0xFF) << 8)
- | (fourth & 0xFF);
- } else {
- value = ((fourth & 0xFF) << 24)
- | ((third & 0xFF) << 16)
- | ((second & 0xFF) << 8)
- | (first & 0xFF);
- }
- if (value <= _MAX_INT) {
- RETURN ( _MKSMALLINT(value));
- }
- RETURN ( _makeULarge(value) );
+ _INST(lastErrorNumber) = nil;
+ if ((_INST(filePointer) != nil)
+ && (_INST(mode) != @symbol(writeonly))) {
+ FILE *f;
+ int first, second, third, fourth;
+ unsigned int value;
+
+ _immediateInterrupt = 1;
+ f = MKFD(_INST(filePointer));
+
+ if ((_INST(didWrite) != false)
+ && (_INST(mode) == @symbol(readwrite))) {
+ _INST(didWrite) = false;
+ fseek(f, 0L, 1); /* needed in stdio */
+ }
+
+ first = getc(f);
+ if (first != EOF) {
+ second = getc(f);
+ if (second != EOF) {
+ third = getc(f);
+ if (third != EOF) {
+ fourth = getc(f);
+ if (fourth != EOF) {
+ _immediateInterrupt = 0;
+ if (msbFlag == true) {
+ value = (first & 0xFF);
+ value = (value<<8) | (second & 0xFF);
+ value = (value<<8) | (third & 0xFF);
+ value = (value<<8) | (fourth & 0xFF);
+ } else {
+ value = (fourth & 0xFF);
+ value = (value<<8) | (third & 0xFF);
+ value = (value<<8) | (second & 0xFF);
+ value = (value<<8) | (first & 0xFF);
+ }
+ if (_INST(position) != nil) {
+ _INST(position) = _MKSMALLINT(_intVal(_INST(position)) + 4);
+ }
+ if (value <= _MAX_INT) {
+ RETURN ( _MKSMALLINT(value));
+ }
+ RETURN ( _makeULarge(value) );
+ }
+ }
+ }
+ }
+ if (ferror(f)) {
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ _INST(position) = nil;
+ } else {
+ _INST(hitEOF) = true;
+ RETURN (nil);
+ }
}
-%}
-.
+%}.
filePointer isNil ifTrue:[^ self errorNotOpen].
(mode == #writeonly) ifTrue:[^ self errorWriteOnly].
- self primitiveFailed
+ ^ self readError.
+!
+
+nextWord
+ "in text-mode:
+ read the alphaNumeric next word (i.e. up to non letter-or-digit).
+ return a string containing those characters.
+ in binary-mode:
+ read two bytes (msb-first) and return the value as a 16-bit unsigned Integer
+ (for compatibility with other smalltalks)"
+
+ binary ifTrue:[
+ ^ self nextShortMSB:true
+ ].
+ ^ self nextAlphaNumericWord
!
nextLong
@@ -1140,44 +1203,47 @@
int cnt;
extern int _immediateInterrupt;
- if ((_INST(filePointer) != nil) && (_INST(mode) != _readonly)) {
- if (_isSmallInteger(aByteValue)) {
- c = _intVal(aByteValue);
- f = MKFD(_INST(filePointer));
- _immediateInterrupt = 1;
+ _INST(lastErrorNumber) = nil;
+ if ((_INST(filePointer) != nil)
+ && (_INST(mode) != @symbol(readonly))) {
+ if (_isSmallInteger(aByteValue)) {
+ c = _intVal(aByteValue);
+ f = MKFD(_INST(filePointer));
+ _immediateInterrupt = 1;
#ifdef OLD
- if (_INST(buffered) == false) {
- cnt = write(fileno(f), &c, 1);
- } else
+ if (_INST(buffered) == false) {
+ cnt = write(fileno(f), &c, 1);
+ } else
#endif
- {
- if ((_INST(didWrite) != true) && (_INST(mode) == _readwrite)) {
- _INST(didWrite) = true;
- fseek(f, 0L, 1); /* needed in stdio */
- }
- cnt = fwrite(&c, 1, 1, f);
+ {
+ if ((_INST(didWrite) != true)
+ && (_INST(mode) == @symbol(readwrite))) {
+ _INST(didWrite) = true;
+ fseek(f, 0L, 1); /* needed in stdio */
+ }
+ cnt = fwrite(&c, 1, 1, f);
#ifndef OLD
- if (_INST(buffered) == false) {
- fflush(f);
- }
+ if (_INST(buffered) == false) {
+ fflush(f);
+ }
#endif
- }
- _immediateInterrupt = 0;
- if (cnt == 1) {
- pos = _INST(position);
- if (pos != nil)
- _INST(position) = _MKSMALLINT(_intVal(pos) + 1);
- RETURN ( self );
- }
- ExternalStream_LastErrorNumber = _MKSMALLINT(errno);
- RETURN (nil);
- }
+ }
+ _immediateInterrupt = 0;
+ if (cnt == 1) {
+ pos = _INST(position);
+ if (pos != nil)
+ _INST(position) = _MKSMALLINT(_intVal(pos) + 1);
+ RETURN (self);
+ }
+ if (cnt < 0) {
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ }
+ }
}
-%}
-.
+%}.
filePointer isNil ifTrue:[^ self errorNotOpen].
(mode == #readonly) ifTrue:[^ self errorReadOnly].
- self primitiveFailed
+ ^ self writeError.
!
nextPutBytesFrom:anObject
@@ -1203,7 +1269,7 @@
nextPutBytes:count from:anObject startingAt:start
"write count bytes from an object starting at index start.
- return the number of bytes written or nil on error.
+ return the number of bytes written - which could be 0.
The object must have non-pointer indexed instvars
(i.e. be a ByteArray, String, Float- or DoubleArray).
Use with care - non object oriented i/o"
@@ -1219,70 +1285,72 @@
OBJ pos;
extern int _immediateInterrupt;
- if ((_INST(filePointer) != nil) && (_INST(mode) != _readonly)) {
- if (_isSmallInteger(count) && _isSmallInteger(start)) {
- oClass = _Class(anObject);
- switch (_intVal(_ClassInstPtr(oClass)->c_flags) & ARRAYMASK) {
- case BYTEARRAY:
- case WORDARRAY:
- case LONGARRAY:
- case FLOATARRAY:
- case DOUBLEARRAY:
- break;
- default:
- goto bad;
- }
- cnt = _intVal(count);
- offs = _intVal(start) - 1;
- f = MKFD(_INST(filePointer));
-
- nInstVars = _intVal(_ClassInstPtr(oClass)->c_ninstvars);
- nInstBytes = OHDR_SIZE + __OBJS2BYTES__(nInstVars);
- objSize = _Size(anObject) - nInstBytes;
- if ( (offs >= 0) && (cnt >= 0) && (objSize >= (cnt + offs)) ) {
- cp = (char *)_InstPtr(anObject) + nInstBytes + offs;
- _immediateInterrupt = 1;
+ _INST(lastErrorNumber) = nil;
+ if ((_INST(filePointer) != nil)
+ && (_INST(mode) != @symbol(readonly))) {
+ if (_isSmallInteger(count) && _isSmallInteger(start)) {
+ oClass = _Class(anObject);
+ switch (_intVal(_ClassInstPtr(oClass)->c_flags) & ARRAYMASK) {
+ case BYTEARRAY:
+ case WORDARRAY:
+ case LONGARRAY:
+ case FLOATARRAY:
+ case DOUBLEARRAY:
+ break;
+ default:
+ goto bad;
+ }
+ cnt = _intVal(count);
+ offs = _intVal(start) - 1;
+ f = MKFD(_INST(filePointer));
+
+ nInstVars = _intVal(_ClassInstPtr(oClass)->c_ninstvars);
+ nInstBytes = OHDR_SIZE + __OBJS2BYTES__(nInstVars);
+ objSize = _Size(anObject) - nInstBytes;
+ if ( (offs >= 0) && (cnt >= 0) && (objSize >= (cnt + offs)) ) {
+ cp = (char *)_InstPtr(anObject) + nInstBytes + offs;
+ _immediateInterrupt = 1;
#ifdef OLD
- if (_INST(buffered) == false) {
- cnt = write(fileno(f), cp, cnt);
- } else
+ if (_INST(buffered) == false) {
+ cnt = write(fileno(f), cp, cnt);
+ } else
#endif
- {
- if ((_INST(didWrite) != true) && (_INST(mode) == _readwrite)) {
- _INST(didWrite) = true;
- fseek(f, 0L, 1); /* needed in stdio */
- }
- cnt = fwrite(cp, 1, cnt, f);
- }
+ {
+ if ((_INST(didWrite) != true)
+ && (_INST(mode) == @symbol(readwrite))) {
+ _INST(didWrite) = true;
+ fseek(f, 0L, 1); /* needed in stdio */
+ }
+ cnt = fwrite(cp, 1, cnt, f);
+ }
#ifndef OLD
- if (_INST(buffered) == false) {
- fflush(f);
- }
+ if (_INST(buffered) == false) {
+ fflush(f);
+ }
#endif
- _immediateInterrupt = 0;
- if (cnt >= 0) {
- pos = _INST(position);
- if (pos != nil)
- _INST(position) = _MKSMALLINT(_intVal(pos) + cnt);
- RETURN ( _MKSMALLINT(cnt) );
- }
- ExternalStream_LastErrorNumber = _MKSMALLINT(errno);
- RETURN ( nil );
- }
- }
+ _immediateInterrupt = 0;
+ if (cnt >= 0) {
+ pos = _INST(position);
+ if (pos != nil)
+ _INST(position) = _MKSMALLINT(_intVal(pos) + cnt);
+ RETURN ( _MKSMALLINT(cnt) );
+ }
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ }
+ }
}
bad: ;
-%}
-.
+%}.
+ lastErrorNumber notNil ifTrue:[^ self writeError].
filePointer isNil ifTrue:[^ self errorNotOpen].
(mode == #readonly) ifTrue:[^ self errorReadOnly].
- self primitiveFailed
+ ^ self primitiveFailed
!
nextPutShort:aNumber MSB:msbFlag
"Write the argument, aNumber as a short (two bytes). If msbFlag is
true, data is written most-significant byte first; otherwise least
- first. Returns the receiver on ok, nil on error.
+ first.
Works in both binary and text modes."
%{ /* NOCONTEXT */
@@ -1294,49 +1362,50 @@
extern int _immediateInterrupt;
int cnt;
- if ((_INST(filePointer) != nil) && (_INST(mode) != _readonly)) {
- if (_isSmallInteger(aNumber)) {
- num = _intVal(aNumber);
- if (msbFlag == true) {
- bytes[0] = (num >> 8) & 0xFF;
- bytes[1] = num & 0xFF;
- } else {
- bytes[1] = (num >> 8) & 0xFF;
- bytes[0] = num & 0xFF;
- }
-
- f = MKFD(_INST(filePointer));
- _immediateInterrupt = 1;
+ _INST(lastErrorNumber) = nil;
+ if ((_INST(filePointer) != nil)
+ && (_INST(mode) != @symbol(readonly))
+ && _isSmallInteger(aNumber)) {
+ num = _intVal(aNumber);
+ if (msbFlag == true) {
+ bytes[0] = (num >> 8) & 0xFF;
+ bytes[1] = num & 0xFF;
+ } else {
+ bytes[1] = (num >> 8) & 0xFF;
+ bytes[0] = num & 0xFF;
+ }
+
+ f = MKFD(_INST(filePointer));
+ _immediateInterrupt = 1;
#ifdef OLD
- if (_INST(buffered) == false) {
- cnt = write(fileno(f), bytes, 2);
- } else
+ if (_INST(buffered) == false) {
+ cnt = write(fileno(f), bytes, 2);
+ } else
#endif
- {
- if ((_INST(didWrite) != true) && (_INST(mode) == _readwrite)) {
- _INST(didWrite) = true;
- fseek(f, 0L, 1); /* needed in stdio */
- }
- cnt = fwrite(bytes, 1, 2, f);
- }
+ {
+ if ((_INST(didWrite) != true)
+ && (_INST(mode) == @symbol(readwrite))) {
+ _INST(didWrite) = true;
+ fseek(f, 0L, 1); /* needed in stdio */
+ }
+ cnt = fwrite(bytes, 1, 2, f);
+ }
#ifndef OLD
- if (_INST(buffered) == false) {
- fflush(f);
- }
+ if (_INST(buffered) == false) {
+ fflush(f);
+ }
#endif
- _immediateInterrupt = 0;
- if (cnt == 2) {
- if (_INST(position) != nil) {
- _INST(position) = _MKSMALLINT(_intVal(_INST(position)) + 2);
- }
- RETURN ( self );
- }
- ExternalStream_LastErrorNumber = _MKSMALLINT(errno);
- return ( nil );
- }
+ _immediateInterrupt = 0;
+ if (cnt == 2) {
+ if (_INST(position) != nil) {
+ _INST(position) = _MKSMALLINT(_intVal(_INST(position)) + 2);
+ }
+ RETURN ( self );
+ }
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
}
-%}
-.
+%}.
+ lastErrorNumber notNil ifTrue:[^ self writeError].
filePointer isNil ifTrue:[^ self errorNotOpen].
(mode == #readonly) ifTrue:[^ self errorReadOnly].
self argumentMustBeInteger
@@ -1345,7 +1414,7 @@
nextPutLong:aNumber MSB:msbFlag
"Write the argument, aNumber as a long (four bytes). If msbFlag is
true, data is written most-significant byte first; otherwise least
- first. Returns the receiver on ok, nil on error.
+ first.
Works in both binary and text modes."
%{ /* NOCONTEXT */
@@ -1357,61 +1426,66 @@
int cnt;
extern int _immediateInterrupt;
- if ((_INST(filePointer) != nil) && (_INST(mode) != _readonly)) {
- if (_isSmallInteger(aNumber)) {
- num = _intVal(aNumber);
- if (msbFlag == true) {
- bytes[0] = (num >> 24) & 0xFF;
- bytes[1] = (num >> 16) & 0xFF;
- bytes[2] = (num >> 8) & 0xFF;
- bytes[3] = num & 0xFF;
- } else {
- bytes[3] = (num >> 24) & 0xFF;
- bytes[2] = (num >> 16) & 0xFF;
- bytes[1] = (num >> 8) & 0xFF;
- bytes[0] = num & 0xFF;
- }
-
- f = MKFD(_INST(filePointer));
- _immediateInterrupt = 1;
+ _INST(lastErrorNumber) = nil;
+ if ((_INST(filePointer) != nil)
+ && (_INST(mode) != @symbol(readonly))
+ && _isSmallInteger(aNumber)) {
+ num = _intVal(aNumber);
+ if (msbFlag == true) {
+ bytes[0] = (num >> 24) & 0xFF;
+ bytes[1] = (num >> 16) & 0xFF;
+ bytes[2] = (num >> 8) & 0xFF;
+ bytes[3] = num & 0xFF;
+ } else {
+ bytes[3] = (num >> 24) & 0xFF;
+ bytes[2] = (num >> 16) & 0xFF;
+ bytes[1] = (num >> 8) & 0xFF;
+ bytes[0] = num & 0xFF;
+ }
+
+ f = MKFD(_INST(filePointer));
+ _immediateInterrupt = 1;
#ifdef OLD
- if (_INST(buffered) == false) {
- cnt = write(fileno(f), bytes, 4);
- } else
+ if (_INST(buffered) == false) {
+ cnt = write(fileno(f), bytes, 4);
+ } else
#endif
- {
- cnt = fwrite(bytes, 1, 4, f);
- }
+ {
+ if ((_INST(didWrite) != true)
+ && (_INST(mode) == @symbol(readwrite))) {
+ _INST(didWrite) = true;
+ fseek(f, 0L, 1); /* needed in stdio */
+ }
+ cnt = fwrite(bytes, 1, 4, f);
+ }
#ifndef OLD
- if (_INST(buffered) == false) {
- fflush(f);
- }
+ if (_INST(buffered) == false) {
+ fflush(f);
+ }
#endif
- _immediateInterrupt = 0;
- if (cnt == 4) {
- if (_INST(position) != nil) {
- _INST(position) = _MKSMALLINT(_intVal(_INST(position)) + 4);
- }
- RETURN ( self );
- }
- ExternalStream_LastErrorNumber = _MKSMALLINT(errno);
- return ( nil );
- }
+ _immediateInterrupt = 0;
+ if (cnt == 4) {
+ if (_INST(position) != nil) {
+ _INST(position) = _MKSMALLINT(_intVal(_INST(position)) + 4);
+ }
+ RETURN ( self );
+ }
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
}
-%}
-.
+%}.
filePointer isNil ifTrue:[^ self errorNotOpen].
(mode == #readonly) ifTrue:[^ self errorReadOnly].
+ lastErrorNumber notNil ifTrue:[^ self writeError].
aNumber isInteger ifTrue:[
- msbFlag ifTrue:[
- "high word first"
- (self nextShortPut:(aNumber // 16r10000) MSB:true) isNil ifTrue:[^ nil].
- ^ self nextShortPut:(aNumber \\ 16r10000) MSB:true
- ].
- "low word first"
- (self nextShortPut:(aNumber \\ 16r10000) MSB:false) isNil ifTrue:[^ nil].
- ^ self nextShortPut:(aNumber // 16r10000) MSB:false.
+ msbFlag ifTrue:[
+ "high word first"
+ (self nextShortPut:(aNumber // 16r10000) MSB:true) isNil ifTrue:[^ nil].
+ ^ self nextShortPut:(aNumber \\ 16r10000) MSB:true
+ ].
+ "low word first"
+ (self nextShortPut:(aNumber \\ 16r10000) MSB:false) isNil ifTrue:[^ nil].
+ ^ self nextShortPut:(aNumber // 16r10000) MSB:false.
].
self argumentMustBeInteger
! !
@@ -1430,40 +1504,45 @@
REGISTER int c;
extern int _immediateInterrupt;
- if (_INST(filePointer) != nil) {
- if (_INST(mode) != _writeonly) {
+ _INST(lastErrorNumber) = nil;
+ if ((_INST(filePointer) != nil)
+ && (_INST(mode) != @symbol(writeonly))) {
#ifdef OLD
- if (_INST(buffered) == true)
+ if (_INST(buffered) == true)
#endif
- {
- f = MKFD(_INST(filePointer));
-
- if ((_INST(didWrite) != false) && (_INST(mode) == _readwrite)) {
- _INST(didWrite) = false;
- fseek(f, 0L, 1); /* needed in stdio */
- }
-
- _immediateInterrupt = 1;
- c = getc(f);
- _immediateInterrupt = 0;
-
- if (c != EOF) {
- ungetc(c, f);
- if (_INST(binary) == true) {
- RETURN ( _MKSMALLINT(c & 0xFF) );
- }
- RETURN ( _MKCHARACTER(c & 0xFF) );
- }
- _INST(hitEOF) = true;
- RETURN ( nil );
- }
- }
+ {
+ f = MKFD(_INST(filePointer));
+
+ if ((_INST(didWrite) != false)
+ && (_INST(mode) == @symbol(readwrite))) {
+ _INST(didWrite) = false;
+ fseek(f, 0L, 1); /* needed in stdio */
+ }
+
+ _immediateInterrupt = 1;
+ c = getc(f);
+ _immediateInterrupt = 0;
+
+ if (c != EOF) {
+ ungetc(c, f);
+ if (_INST(binary) == true) {
+ RETURN ( _MKSMALLINT(c & 0xFF) );
+ }
+ RETURN ( _MKCHARACTER(c & 0xFF) );
+ }
+ if (ferror(f)) {
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ } else {
+ _INST(hitEOF) = true;
+ RETURN ( nil );
+ }
+ }
}
-%}
-.
+%}.
+ lastErrorNumber notNil ifTrue:[^ self readError].
filePointer isNil ifTrue:[^ self errorNotOpen].
buffered ifFalse:[^ self errorNotBuffered].
- self errorWriteOnly
+ ^ self errorWriteOnly
!
next
@@ -1480,48 +1559,54 @@
extern int _immediateInterrupt;
- if (_INST(filePointer) != nil) {
- if (_INST(mode) != _writeonly) {
- f = MKFD(_INST(filePointer));
- _immediateInterrupt = 1;
- do {
+ _INST(lastErrorNumber) = nil;
+ if ((_INST(filePointer) != nil)
+ && (_INST(mode) != @symbol(writeonly))) {
+ f = MKFD(_INST(filePointer));
+ _immediateInterrupt = 1;
+ do {
#ifdef OLD
- if (_INST(buffered) == false) {
- if (read(fileno(f), &ch, 1) != 1)
- c = EOF;
- else
- c = ch;
- } else
+ if (_INST(buffered) == false) {
+ if (read(fileno(f), &ch, 1) != 1)
+ c = EOF;
+ else
+ c = ch;
+ } else
#endif
- {
- if ((_INST(didWrite) != false) && (_INST(mode) == _readwrite)) {
- _INST(didWrite) = false;
- fseek(f, 0L, 1); /* needed in stdio */
- }
- c = getc(f);
- }
- } while ((c < 0) && (errno == EINTR));
-
- _immediateInterrupt = 0;
- if (c != EOF) {
- pos = _INST(position);
- if (_isSmallInteger(pos)) {
- _INST(position) = _MKSMALLINT(_intVal(pos) + 1);
- } else {
- _INST(position) = nil;
- }
- if (_INST(binary) == true) {
- RETURN ( _MKSMALLINT(c & 0xFF) );
- }
- RETURN ( _MKCHARACTER(c & 0xFF) );
- }
- _INST(hitEOF) = true;
- _INST(position) = nil;
- RETURN ( nil );
- }
+ {
+ if ((_INST(didWrite) != false)
+ && (_INST(mode) == @symbol(readwrite))) {
+ _INST(didWrite) = false;
+ fseek(f, 0L, 1); /* needed in stdio */
+ }
+ c = getc(f);
+ }
+ } while ((c < 0) && (errno == EINTR));
+
+ _immediateInterrupt = 0;
+
+ if (c != EOF) {
+ pos = _INST(position);
+ if (_isSmallInteger(pos)) {
+ _INST(position) = _MKSMALLINT(_intVal(pos) + 1);
+ } else {
+ _INST(position) = nil;
+ }
+ if (_INST(binary) == true) {
+ RETURN ( _MKSMALLINT(c & 0xFF) );
+ }
+ RETURN ( _MKCHARACTER(c & 0xFF) );
+ }
+ _INST(position) = nil;
+ if (ferror(f)) {
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ } else {
+ _INST(hitEOF) = true;
+ RETURN ( nil );
+ }
}
-%}
-.
+%}.
+ lastErrorNumber notNil ifTrue:[^ self readError].
filePointer isNil ifTrue:[^ self errorNotOpen].
self errorWriteOnly
!
@@ -1533,12 +1618,12 @@
|coll|
binary ifTrue:[
- coll := ByteArray new:count
+ coll := ByteArray new:count
] ifFalse:[
- coll := String new:count
+ coll := String new:count
].
1 to:count do: [:index |
- coll at:index put:(self next)
+ coll at:index put:(self next)
].
^ coll
! !
@@ -1550,12 +1635,13 @@
%{ /* NOCONTEXT */
+ _INST(lastErrorNumber) = nil;
if (_INST(filePointer) != nil) {
- if (_INST(mode) != _readonly) {
- if (_INST(buffered) == true) {
- fflush( MKFD(_INST(filePointer)) );
- }
- }
+ if (_INST(mode) != @symbol(readonly)) {
+ if (_INST(buffered) == true) {
+ fflush( MKFD(_INST(filePointer)) );
+ }
+ }
}
%}
!
@@ -1572,53 +1658,50 @@
OBJ pos;
extern int _immediateInterrupt;
- if (_INST(filePointer) != nil) {
- if (_INST(mode) != _readonly) {
- if (_INST(binary) != true) {
- if (__isCharacter(aCharacter)) {
- c = _intVal(_CharacterInstPtr(aCharacter)->c_asciivalue);
+ _INST(lastErrorNumber) = nil;
+ if ((_INST(filePointer) != nil)
+ && (_INST(mode) != @symbol(readonly))) {
+ if (_INST(binary) != true) {
+ if (__isCharacter(aCharacter)) {
+ c = _intVal(_CharacterInstPtr(aCharacter)->c_asciivalue);
doWrite:
- f = MKFD(_INST(filePointer));
-
- _immediateInterrupt = 1;
-#ifdef OLD
- if (_INST(buffered) == false) {
- cnt = write(fileno(f), &c, 1);
- } else
-#endif
- {
- if ((_INST(didWrite) != true) && (_INST(mode) == _readwrite)) {
- _INST(didWrite) = true;
- fseek(f, 0L, 1); /* needed in stdio */
- }
- cnt = fwrite(&c, 1, 1, f);
- }
-#ifndef OLD
- if (_INST(buffered) == false) {
- fflush(f);
- }
-#endif
- _immediateInterrupt = 0;
- if (cnt == 1) {
- pos = _INST(position);
- if (pos != nil) {
- _INST(position) = _MKSMALLINT(_intVal(pos) + 1);
- }
- RETURN ( self );
- }
- ExternalStream_LastErrorNumber = _MKSMALLINT(errno);
- RETURN ( nil );
- }
- } else {
- if (_isSmallInteger(aCharacter)) {
- c = _intVal(aCharacter);
- goto doWrite;
- }
- }
- }
+ f = MKFD(_INST(filePointer));
+
+ _immediateInterrupt = 1;
+
+ if ((_INST(didWrite) != true)
+ && (_INST(mode) == @symbol(readwrite))) {
+ _INST(didWrite) = true;
+ fseek(f, 0L, 1); /* needed in stdio */
+ }
+
+ do {
+ cnt = fwrite(&c, 1, 1, f);
+ } while ((cnt != 1) && (errno == EINTR));
+
+ if (_INST(buffered) == false) {
+ fflush(f);
+ }
+
+ _immediateInterrupt = 0;
+ if (cnt == 1) {
+ pos = _INST(position);
+ if (pos != nil) {
+ _INST(position) = _MKSMALLINT(_intVal(pos) + 1);
+ }
+ RETURN ( self );
+ }
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ }
+ } else {
+ if (_isSmallInteger(aCharacter)) {
+ c = _intVal(aCharacter);
+ goto doWrite;
+ }
+ }
}
-%}
-.
+%}.
+ lastErrorNumber notNil ifTrue:[^ self writeError].
filePointer isNil ifTrue:[^ self errorNotOpen].
(mode == #readonly) ifTrue:[^ self errorReadOnly].
binary ifFalse:[^ self argumentMustBeCharacter].
@@ -1639,64 +1722,76 @@
OBJ pos;
extern int _immediateInterrupt;
- if ((_INST(filePointer) != nil) && (_INST(mode) != _readonly)) {
- cp = NULL;
- if (__isString(aCollection) || __isSymbol(aCollection)) {
- cp = _stringVal(aCollection);
- len = _stringSize(aCollection);
- } else {
- if (_INST(binary) == true) {
- if (__isByteArray(aCollection)) {
- cp = _ByteArrayInstPtr(aCollection)->ba_element;
- len = _byteArraySize(aCollection);
- } else {
- if (__isBytes(aCollection)) {
- int nInst;
-
- cp = _ByteArrayInstPtr(aCollection)->ba_element;
- len = _byteArraySize(aCollection);
- nInst = _intVal(_ClassInstPtr(_qClass(aCollection))->c_ninstvars);
- cp += __OBJS2BYTES__(nInst);
- len -= __OBJS2BYTES__(nInst);
- }
- }
- }
- }
- if (cp != NULL) {
- f = MKFD(_INST(filePointer));
-
- _immediateInterrupt = 1;
+ _INST(lastErrorNumber) = nil;
+ if ((_INST(filePointer) != nil)
+ && (_INST(mode) != @symbol(readonly))) {
+ cp = NULL;
+ if (__isString(aCollection) || __isSymbol(aCollection)) {
+ cp = _stringVal(aCollection);
+ len = _stringSize(aCollection);
+ } else {
+ if (_INST(binary) == true) {
+ if (__isByteArray(aCollection)) {
+ cp = _ByteArrayInstPtr(aCollection)->ba_element;
+ len = _byteArraySize(aCollection);
+ } else {
+ if (__isBytes(aCollection)) {
+ int nInst;
+
+ cp = _ByteArrayInstPtr(aCollection)->ba_element;
+ len = _byteArraySize(aCollection);
+ nInst = _intVal(_ClassInstPtr(_qClass(aCollection))->c_ninstvars);
+ cp += __OBJS2BYTES__(nInst);
+ len -= __OBJS2BYTES__(nInst);
+ }
+ }
+ }
+ }
+ if (cp != NULL) {
+ f = MKFD(_INST(filePointer));
+
+ _immediateInterrupt = 1;
#ifdef OLD
- if (_INST(buffered) == false) {
- cnt = write(fileno(f), cp, len);
- } else
+ if (_INST(buffered) == false) {
+ cnt = write(fileno(f), cp, len);
+ } else
#endif
- {
- if ((_INST(didWrite) != true) && (_INST(mode) == _readwrite)) {
- _INST(didWrite) = true;
- fseek(f, 0L, 1); /* needed in stdio */
- }
- cnt = fwrite(cp, 1, len, f);
- }
+ {
+ if ((_INST(didWrite) != true)
+ && (_INST(mode) == @symbol(readwrite))) {
+ _INST(didWrite) = true;
+ fseek(f, 0L, 1); /* needed in stdio */
+ }
+ do {
+ cnt = fwrite(cp, 1, len, f);
+ if (cnt != len) {
+ if (cnt >= 0) {
+ if (errno == EINTR) {
+ cp += cnt;
+ len -= cnt;
+ }
+ }
+ }
+ } while ((cnt != len) && (errno == EINTR));
+ }
#ifndef OLD
- if (_INST(buffered) == false) {
- fflush(f);
- }
+ if (_INST(buffered) == false) {
+ fflush(f);
+ }
#endif
- _immediateInterrupt = 0;
- if (cnt == len) {
- pos = _INST(position);
- if (pos != nil) {
- _INST(position) = _MKSMALLINT(_intVal(pos) + len);
- }
- RETURN ( self );
- }
- ExternalStream_LastErrorNumber = _MKSMALLINT(errno);
- RETURN ( nil );
- }
+ _immediateInterrupt = 0;
+ if (cnt == len) {
+ pos = _INST(position);
+ if (pos != nil) {
+ _INST(position) = _MKSMALLINT(_intVal(pos) + len);
+ }
+ RETURN ( self );
+ }
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ }
}
-%}
-.
+%}.
+ lastErrorNumber notNil ifTrue:[^ self writeError].
^ super nextPutAll:aCollection
!
@@ -1713,73 +1808,80 @@
extern errno;
extern int _immediateInterrupt;
- if ((_INST(filePointer) != nil) && (_INST(mode) != _readonly)) {
- if (_isSmallInteger(start) && _isSmallInteger(stop)) {
- cp = NULL;
- if (_INST(binary) != true) {
- if (__isString(aCollection) || __isSymbol(aCollection)) {
- cp = _stringVal(aCollection);
- len = _stringSize(aCollection);
- }
- } else {
- if (__isByteArray(aCollection)) {
- cp = _ByteArrayInstPtr(aCollection)->ba_element;
- len = _byteArraySize(aCollection);
- } else {
- if (__isBytes(aCollection)) {
- int nInst;
-
- cp = _ByteArrayInstPtr(aCollection)->ba_element;
- len = _byteArraySize(aCollection);
- nInst = _intVal(_ClassInstPtr(_qClass(aCollection))->c_ninstvars);
- cp += __OBJS2BYTES__(nInst);
- len -= __OBJS2BYTES__(nInst);
- }
- }
- }
- if (cp != NULL) {
- f = MKFD(_INST(filePointer));
- index1 = _intVal(start);
- index2 = _intVal(stop);
- if ((index1 < 1) || (index2 > len) || (index2 < index1)) {
- RETURN ( self );
- }
- if (index2 > len)
- index2 = len;
-
- _immediateInterrupt = 1;
- len = index2 - index1 + 1;
-#ifdef OLD
- if (_INST(buffered) == false) {
- cnt = write(fileno(f), cp + index1 - 1, len);
- } else
-#endif
- {
- if ((_INST(didWrite) != true) && (_INST(mode) == _readwrite)) {
- _INST(didWrite) = true;
- fseek(f, 0L, 1); /* needed in stdio */
- }
- cnt = fwrite(cp + index1 - 1, 1, len, f);
- }
-#ifndef OLD
- if (_INST(buffered) == false) {
- fflush(f);
- }
-#endif
- _immediateInterrupt = 0;
- if (cnt == len) {
- if (_INST(position) != nil) {
- _INST(position) = _MKSMALLINT(_intVal(_INST(position)) + len);
- }
- RETURN ( self );
- }
- ExternalStream_LastErrorNumber = _MKSMALLINT(errno);
- RETURN ( nil );
- }
- }
+ _INST(lastErrorNumber) = nil;
+ if ((_INST(filePointer) != nil)
+ && (_INST(mode) != @symbol(readonly))) {
+ if (_isSmallInteger(start) && _isSmallInteger(stop)) {
+ cp = NULL;
+ if (_INST(binary) != true) {
+ if (__isString(aCollection) || __isSymbol(aCollection)) {
+ cp = _stringVal(aCollection);
+ len = _stringSize(aCollection);
+ }
+ } else {
+ if (__isByteArray(aCollection)) {
+ cp = _ByteArrayInstPtr(aCollection)->ba_element;
+ len = _byteArraySize(aCollection);
+ } else {
+ if (__isBytes(aCollection)) {
+ int nInst;
+
+ cp = _ByteArrayInstPtr(aCollection)->ba_element;
+ len = _byteArraySize(aCollection);
+ nInst = _intVal(_ClassInstPtr(_qClass(aCollection))->c_ninstvars);
+ cp += __OBJS2BYTES__(nInst);
+ len -= __OBJS2BYTES__(nInst);
+ }
+ }
+ }
+ if (cp != NULL) {
+ f = MKFD(_INST(filePointer));
+ index1 = _intVal(start);
+ index2 = _intVal(stop);
+ if ((index1 < 1) || (index2 > len) || (index2 < index1)) {
+ RETURN ( self );
+ }
+ if (index2 > len)
+ index2 = len;
+
+ _immediateInterrupt = 1;
+ len = index2 - index1 + 1;
+
+ if ((_INST(didWrite) != true)
+ && (_INST(mode) == @symbol(readwrite))) {
+ _INST(didWrite) = true;
+ fseek(f, 0L, 1); /* needed in stdio */
+ }
+
+ do {
+ cnt = fwrite(cp + index1 - 1, 1, len, f);
+ if (cnt != len) {
+ if (cnt >= 0) {
+ if (errno == EINTR) {
+ cp += cnt;
+ len -= cnt;
+ }
+ }
+ }
+ } while ((cnt != len) && (errno == EINTR));
+
+ if (_INST(buffered) == false) {
+ fflush(f);
+ }
+
+ _immediateInterrupt = 0;
+ if (cnt == len) {
+ if (_INST(position) != nil) {
+ _INST(position) = _MKSMALLINT(_intVal(_INST(position)) + len);
+ }
+ RETURN ( self );
+ }
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ }
+ }
}
-%}
-.
+%}.
+ lastErrorNumber notNil ifTrue:[^ self writeError].
^ super nextPutAll:aCollection startingAt:start to:stop
!
@@ -1793,41 +1895,40 @@
extern int _immediateInterrupt;
int cnt;
- if ((_INST(filePointer) != nil) && (_INST(mode) != _readonly)) {
- if (_INST(binary) != true) {
- f = MKFD(_INST(filePointer));
-
- _immediateInterrupt = 1;
-#ifdef OLD
- if (_INST(buffered) == false) {
- cnt = write(fileno(f), "\n", 1);
- } else
-#endif
- {
- if ((_INST(didWrite) != true) && (_INST(mode) == _readwrite)) {
- _INST(didWrite) = true;
- fseek(f, 0L, 1); /* needed in stdio */
- }
- cnt = fwrite("\n", 1, 1, f);
- }
-#ifndef OLD
- if (_INST(buffered) == false) {
- fflush(f);
- }
-#endif
- _immediateInterrupt = 0;
- if (cnt == 1) {
- if (_INST(position) != nil) {
- _INST(position) = _MKSMALLINT(_intVal(_INST(position)) + 1);
- }
- RETURN ( self );
- }
- ExternalStream_LastErrorNumber = _MKSMALLINT(errno);
- return ( nil );
- }
+ _INST(lastErrorNumber) = nil;
+ if ((_INST(filePointer) != nil)
+ && (_INST(mode) != @symbol(readonly))) {
+ if (_INST(binary) != true) {
+ f = MKFD(_INST(filePointer));
+
+ _immediateInterrupt = 1;
+
+ if ((_INST(didWrite) != true)
+ && (_INST(mode) == @symbol(readwrite))) {
+ _INST(didWrite) = true;
+ fseek(f, 0L, 1); /* needed in stdio */
+ }
+
+ do {
+ cnt = fwrite("\n", 1, 1, f);
+ } while ((cnt != 1) && (errno == EINTR));
+
+ if (_INST(buffered) == false) {
+ fflush(f);
+ }
+
+ _immediateInterrupt = 0;
+ if (cnt == 1) {
+ if (_INST(position) != nil) {
+ _INST(position) = _MKSMALLINT(_intVal(_INST(position)) + 1);
+ }
+ RETURN ( self );
+ }
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ }
}
-%}
-.
+%}.
+ lastErrorNumber notNil ifTrue:[^ self writeError].
filePointer isNil ifTrue:[^ self errorNotOpen].
(mode == #readonly) ifTrue:[^ self errorReadOnly].
self errorBinary
@@ -1853,87 +1954,101 @@
int fd, ch;
int _buffered;
- if ((_INST(filePointer) != nil) && (_INST(mode) != _writeonly)) {
- if (_INST(binary) != true) {
- f = MKFD(_INST(filePointer));
- _immediateInterrupt = 1;
- buffer[0] = 0;
-
- _buffered = (_INST(buffered) == true);
-
- /*
- * mhmh - the following code looks ok to me,
- * but seems not to work for sockets
- */
+ _INST(lastErrorNumber) = nil;
+ if ((_INST(filePointer) != nil)
+ && (_INST(mode) != @symbol(writeonly))) {
+ if (_INST(binary) != true) {
+ f = MKFD(_INST(filePointer));
+ _immediateInterrupt = 1;
+ buffer[0] = 0;
+
+ _buffered = (_INST(buffered) == true);
+
+ /*
+ * mhmh - the following code looks ok to me,
+ * but seems not to work for sockets
+ */
#ifdef DOES_NOT_WORK
- if (_INST(mode) == _readwrite)
- fseek(f, 0L, 1); /* needed in stdio */
- do {
- rslt = fgets(buffer, sizeof(buffer), f);
- } while ((rslt == NULL) && (errno == EINTR));
+ if (_INST(mode) == _readwrite)
+ fseek(f, 0L, 1); /* needed in stdio */
+ do {
+ rslt = fgets(buffer, sizeof(buffer), f);
+ } while ((rslt == NULL) && (errno == EINTR));
#else
- if (_buffered) {
- if ((_INST(didWrite) != false) && (_INST(mode) == _readwrite)) {
- _INST(didWrite) = false;
- fseek(f, 0L, 1); /* needed in stdio */
- }
- }
- rslt = buffer;
- fd = fileno(f);
- for (;;) {
- if (_buffered) {
- ch = getc(f);
- if (ch == EOF)
- len = 0;
- else {
- len = 1;
- *rslt = ch;
- }
- } else {
- do {
- len = read(fd, rslt, 1);
- } while ((len < 0) && (errno == EINTR));
- }
- if (len <= 0) {
- if (rslt == buffer) {
- rslt = NULL;
- } else {
- *rslt = '\0';
- }
- break;
- }
- rslt++;
- if (*(rslt-1) == '\n') {
- *rslt = '\0';
- break;
- }
- if (rslt == (buffer + sizeof(buffer) - 1)) {
- *rslt = '\0';
- break;
- }
- }
+ if (_buffered) {
+ if ((_INST(didWrite) != false)
+ && (_INST(mode) == @symbol(readwrite))) {
+ _INST(didWrite) = false;
+ fseek(f, 0L, 1); /* needed in stdio */
+ }
+ }
+ rslt = buffer;
+ fd = fileno(f);
+ for (;;) {
+ if (_buffered) {
+ ch = getc(f);
+ if (ch == EOF) {
+ if (ferror(f)) {
+ if (errno == EINTR) {
+ clearerr(f);
+ continue;
+ }
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ }
+ len = 0;
+ } else {
+ len = 1;
+ *rslt = ch;
+ }
+ } else {
+ do {
+ len = read(fd, rslt, 1);
+ } while ((len < 0) && (errno == EINTR));
+ }
+ if (len <= 0) {
+ if (rslt == buffer) {
+ rslt = NULL;
+ } else {
+ *rslt = '\0';
+ }
+ break;
+ }
+ rslt++;
+ if (*(rslt-1) == '\n') {
+ *rslt = '\0';
+ break;
+ }
+ if (rslt == (buffer + sizeof(buffer) - 1)) {
+ *rslt = '\0';
+ break;
+ }
+ }
#endif
- _immediateInterrupt = 0;
- if (rslt != NULL) {
- len = strlen(buffer);
- if (_INST(position) != nil) {
- _INST(position) = _MKSMALLINT(_intVal(_INST(position)) + len + 1);
- }
- /* remove EOL character */
- if ((len != 0) && (buffer[len-1] == '\n')) {
- buffer[--len] = '\0';
- }
- if ((len != 0) && (buffer[len-1] == '\r')) {
- buffer[--len] = '\0';
- }
- RETURN ( _MKSTRING(buffer COMMA_CON) );
- }
- _INST(hitEOF) = true;
- RETURN ( nil );
- }
+ _immediateInterrupt = 0;
+ if (rslt != NULL) {
+ len = strlen(buffer);
+ if (_INST(position) != nil) {
+ _INST(position) = _MKSMALLINT(_intVal(_INST(position)) + len + 1);
+ }
+ /* remove EOL character */
+ if ((len != 0) && (buffer[len-1] == '\n')) {
+ buffer[--len] = '\0';
+ }
+ if ((len != 0) && (buffer[len-1] == '\r')) {
+ buffer[--len] = '\0';
+ }
+ RETURN ( _MKSTRING(buffer COMMA_CON) );
+ }
+ if (ferror(f)) {
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ } else {
+ _INST(hitEOF) = true;
+ RETURN ( nil );
+ }
+ }
}
-%}
-.
+%}.
+ lastErrorNumber notNil ifTrue:[^ self readError].
filePointer isNil ifTrue:[^ self errorNotOpen].
(mode == #writeonly) ifTrue:[^ self errorWriteOnly].
self errorBinary
@@ -1951,57 +2066,59 @@
extern errno;
extern int _immediateInterrupt;
- if ((_INST(filePointer) != nil) && (_INST(mode) != _readonly)) {
- if (_INST(binary) != true) {
- if (__isString(aString)) {
- f = MKFD(_INST(filePointer));
- s = (char *) _stringVal(aString);
- len = _stringSize(aString);
-
- _immediateInterrupt = 1;
+ _INST(lastErrorNumber) = nil;
+ if ((_INST(filePointer) != nil)
+ && (_INST(mode) != @symbol(readonly))) {
+ if (_INST(binary) != true) {
+ if (__isString(aString)) {
+ f = MKFD(_INST(filePointer));
+ s = (char *) _stringVal(aString);
+ len = _stringSize(aString);
+
+ _immediateInterrupt = 1;
#ifdef OLD
- if (_INST(buffered) == false) {
- cnt = write(fileno(f), s, len);
- } else
-#endif
- {
- if ((_INST(didWrite) != true) && (_INST(mode) == _readwrite)) {
- _INST(didWrite) = true;
- fseek(f, 0L, 1); /* needed in stdio */
- }
- cnt = fwrite(s, 1, len, f);
- }
- if (cnt == len) {
-#ifdef OLD
- if (_INST(buffered) == false) {
- cnt = write(fileno(f), "\n", 1);
- } else
+ if (_INST(buffered) == false) {
+ cnt = write(fileno(f), s, len);
+ } else
#endif
- {
- cnt = fwrite("\n", 1, 1, f);
- }
-#ifndef OLD
- if (_INST(buffered) == false) {
- fflush(f);
- }
+ {
+ if ((_INST(didWrite) != true)
+ && (_INST(mode) == @symbol(readwrite))) {
+ _INST(didWrite) = true;
+ fseek(f, 0L, 1); /* needed in stdio */
+ }
+ cnt = fwrite(s, 1, len, f);
+ }
+ if (cnt == len) {
+#ifdef OLD
+ if (_INST(buffered) == false) {
+ cnt = write(fileno(f), "\n", 1);
+ } else
#endif
- if (cnt == 1) {
- pos = _INST(position);
- if (pos != nil) {
- _INST(position) = _MKSMALLINT(_intVal(pos)+len+1);
- }
- _immediateInterrupt = 0;
- RETURN ( self );
- }
- }
- _immediateInterrupt = 0;
- ExternalStream_LastErrorNumber = _MKSMALLINT(errno);
- RETURN ( nil );
- }
- }
+ {
+ cnt = fwrite("\n", 1, 1, f);
+ }
+#ifndef OLD
+ if (_INST(buffered) == false) {
+ fflush(f);
+ }
+#endif
+ if (cnt == 1) {
+ pos = _INST(position);
+ if (pos != nil) {
+ _INST(position) = _MKSMALLINT(_intVal(pos)+len+1);
+ }
+ _immediateInterrupt = 0;
+ RETURN ( self );
+ }
+ }
+ _immediateInterrupt = 0;
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ }
+ }
}
-%}
-.
+%}.
+ lastErrorNumber notNil ifTrue:[^ self writeError].
super nextPutAll:aString.
self cr.
!
@@ -2009,13 +2126,13 @@
nextPutLinesFrom:aStream upToLineStartingWith:aStringOrNil
"read from aStream up to and including a line starting with aStringOrNil
and append it to self.
- can be used to copy/create large files or copy from a pipe/socket.
+ Can be used to copy/create large files or copy from a pipe/socket.
If aStringOrNil is nil or not matched, copy preceeds to the end.
(this allows for example to read a Socket and transfer the data quickly
into a file - without creating zillions of temporary strings)"
- |srcFilePointer|
+ |srcFilePointer readError|
(mode == #readonly) ifTrue:[^ self errorReadOnly].
filePointer isNil ifTrue:[^ self errorNotOpen].
@@ -2030,47 +2147,74 @@
char buffer[1024];
extern int _immediateInterrupt;
- if (_isSmallInteger(srcFilePointer)
-#ifdef OLD
- && (_INST(buffered) == true)
-#endif
- ) {
- if ((aStringOrNil == nil) || __isString(aStringOrNil)) {
- if (aStringOrNil != nil) {
- matchString = (char *) _stringVal(aStringOrNil);
- matchLen = _stringSize(aStringOrNil);
- }
- dst = MKFD(_INST(filePointer));
- src = (FILE *)_intVal(srcFilePointer);
- _immediateInterrupt = 1;
- for (;;) {
- if (fgets(buffer, sizeof(buffer), src) == NULL) break;
- if (fputs(buffer, dst) == EOF) break;
+ _INST(lastErrorNumber) = nil;
+ if (_isSmallInteger(srcFilePointer)) {
+ if ((aStringOrNil == nil) || __isString(aStringOrNil)) {
+ if (aStringOrNil != nil) {
+ matchString = (char *) _stringVal(aStringOrNil);
+ matchLen = _stringSize(aStringOrNil);
+ }
+ dst = MKFD(_INST(filePointer));
+ src = (FILE *)_intVal(srcFilePointer);
+ _immediateInterrupt = 1;
+ errno = 0;
+
+ if ((_INST(didWrite) != true)
+ && (_INST(mode) == @symbol(readwrite))) {
+ _INST(didWrite) = true;
+ fseek(dst, 0L, 1); /* needed in stdio */
+ }
+
+ for (;;) {
+ if (fgets(buffer, sizeof(buffer), src) == NULL) {
+ if (ferror(src)) {
+ readError = _MKSMALLINT(errno);
+ goto err;
+ }
+ break;
+ }
+ if (fputs(buffer, dst) == EOF) {
+ if (ferror(dst)) {
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ goto err;
+ }
+ break;
+ }
#ifndef OLD
- if (_INST(buffered) == false) {
- fflush(dst);
- }
+ if (_INST(buffered) == false) {
+ fflush(dst);
+ }
#endif
- if (matchLen) {
- if (strncmp(matchString, buffer, matchLen) == 0)
- break;
- }
- }
- _immediateInterrupt = 0;
- _INST(position) = nil;
- RETURN ( self );
- }
+ if (matchLen) {
+ if (strncmp(matchString, buffer, matchLen) == 0)
+ break;
+ }
+ }
+ _immediateInterrupt = 0;
+ _INST(position) = nil;
+ RETURN (self);
+ }
}
-%}
-.
+err: ;
+%}.
+ readError ifTrue:[
+ aStream setLastErrorNumber:readError.
+ ^ aStream readError
+ ].
+ lastErrorNumber notNil ifTrue:[^ self writeError].
buffered ifFalse:[^ self errorNotBuffered].
+ "
+ argument error
+ "
^ self primitiveFailed
!
peekForLineStartingWith:aString
"read ahead for next line starting with aString;
- return the line-string if found, nil otherwise.
- Do not advance position i.e. nextLine will reread this line"
+ return the line-string if found, or nil if EOF is encountered.
+ If matched, not advance position behond that line
+ i.e. nextLine will read the matched line.
+ If not matched, reposition to original position for firther reading."
(mode == #writeonly) ifTrue:[^ self errorWriteOnly].
filePointer isNil ifTrue:[^ self errorNotOpen].
@@ -2085,45 +2229,53 @@
int firstpos = -1, lastpos;
extern int _immediateInterrupt;
+ _INST(lastErrorNumber) = nil;
if (__isString(aString)) {
- matchString = (char *) _stringVal(aString);
- l = _stringSize(aString);
-
- f = MKFD(_INST(filePointer));
-
- if ((_INST(didWrite) != false) && (_INST(mode) == _readwrite)) {
- _INST(didWrite) = false;
- fseek(f, 0L, 1); /* needed in stdio */
- }
-
- for (;;) {
- lastpos = ftell(f);
- if (firstpos == -1) firstpos = lastpos;
-
- _immediateInterrupt = 1;
- do {
- cp = fgets(buffer, sizeof(buffer), f);
- } while ((cp == NULL) && (errno == EINTR));
- _immediateInterrupt = 0;
-
- if (cp == NULL) {
- fseek(f, firstpos, 0);
- RETURN ( nil );
- }
- if (strncmp(cp, matchString, l) == 0) {
- fseek(f, lastpos, 0);
- break;
- }
- }
- /* remove EOL character */
- cp = buffer;
- while (*cp && (*cp != '\n')) cp++;
- *cp = '\0';
- RETURN ( _MKSTRING(buffer COMMA_CON) );
+ matchString = (char *) _stringVal(aString);
+ l = _stringSize(aString);
+
+ f = MKFD(_INST(filePointer));
+
+ if ((_INST(didWrite) != false)
+ && (_INST(mode) == @symbol(readwrite))) {
+ _INST(didWrite) = false;
+ fseek(f, 0L, 1); /* needed in stdio */
+ }
+
+ for (;;) {
+ lastpos = ftell(f);
+ if (firstpos == -1) firstpos = lastpos;
+
+ _immediateInterrupt = 1;
+ do {
+ cp = fgets(buffer, sizeof(buffer), f);
+ } while ((cp == NULL) && (errno == EINTR));
+ _immediateInterrupt = 0;
+
+ if (cp == NULL) {
+ if (ferror(f)) {
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ goto err;
+ } else {
+ fseek(f, firstpos, 0);
+ RETURN (nil);
+ }
+ }
+ if (strncmp(cp, matchString, l) == 0) {
+ fseek(f, lastpos, 0);
+ break;
+ }
+ }
+ /* remove EOL character */
+ cp = buffer;
+ while (*cp && (*cp != '\n')) cp++;
+ *cp = '\0';
+ RETURN ( _MKSTRING(buffer COMMA_CON) );
}
-%}
-.
- self argumentMustBeString
+err: ;
+%}.
+ lastErrorNumber notNil ifTrue:[^ self readError].
+ ^ self argumentMustBeString
!
peekForLineStartingWithAny:aCollectionOfStrings
@@ -2140,16 +2292,18 @@
startPos := self position.
[self atEnd] whileFalse:[
- linePos := self position.
- line := self nextLine.
- index := 1.
- aCollectionOfStrings do:[:prefix |
- (line startsWith:prefix) ifTrue:[
- self position:linePos.
- ^ index
- ].
- index := index + 1
- ]
+ linePos := self position.
+ line := self nextLine.
+ line notNil ifTrue:[
+ index := 1.
+ aCollectionOfStrings do:[:prefix |
+ (line startsWith:prefix) ifTrue:[
+ self position:linePos.
+ ^ index
+ ].
+ index := index + 1
+ ]
+ ]
].
self position:startPos.
^ nil
@@ -2169,27 +2323,38 @@
extern int _immediateInterrupt;
if (_INST(hitEOF) == _true) {
- RETURN (_true);
+ RETURN (_true);
}
+ _INST(lastErrorNumber) = nil;
if ((t = _INST(filePointer)) != nil) {
- f = MKFD(t);
+ f = MKFD(t);
#ifdef OLD
- RETURN ( feof(f) ? _true : false );
+ RETURN ( feof(f) ? _true : false );
#else
- _immediateInterrupt = 1;
- c = getc(f);
- _immediateInterrupt = 0;
- if (c == EOF) {
- _INST(hitEOF) = _true;
- RETURN (_true);
- }
- ungetc(c, f);
- RETURN (false);
+ if ((_INST(didWrite) != false)
+ && (_INST(mode) == @symbol(readwrite))) {
+ _INST(didWrite) = false;
+ fseek(f, 0L, 1); /* needed in stdio */
+ }
+
+ _immediateInterrupt = 1;
+ c = getc(f);
+ _immediateInterrupt = 0;
+ if (c != EOF) {
+ ungetc(c, f);
+ RETURN (false);
+ }
+ if (ferror(f)) {
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ } else {
+ _INST(hitEOF) = _true;
+ RETURN (_true);
+ }
#endif
}
-%}
-.
- self errorNotOpen
+%}.
+ lastErrorNumber notNil ifTrue:[^ self readError].
+ ^ self errorNotOpen
!
canReadWithoutBlocking
@@ -2198,12 +2363,8 @@
|fd|
- filePointer isNil ifTrue:[
- ^ self errorNotOpen
- ].
- mode == #writeonly ifTrue:[
- ^ self errorWriteOnly
- ].
+ filePointer isNil ifTrue:[^ self errorNotOpen].
+ mode == #writeonly ifTrue:[^ self errorWriteOnly].
fd := self fileDescriptor.
^ OperatingSystem readCheck:fd
@@ -2213,9 +2374,9 @@
pipe := PipeStream readingFrom:'(sleep 10; echo hello)'.
pipe canReadWithoutBlocking ifTrue:[
- Transcript showCr:'data available'
+ Transcript showCr:'data available'
] ifFalse:[
- Transcript showCr:'no data available'
+ Transcript showCr:'no data available'
].
pipe close
"
@@ -2227,12 +2388,8 @@
|fd|
- filePointer isNil ifTrue:[
- ^ self errorNotOpen
- ].
- mode == #readonly ifTrue:[
- ^ self errorReadOnly
- ].
+ filePointer isNil ifTrue:[^ self errorNotOpen].
+ mode == #readonly ifTrue:[^ self errorReadOnly].
fd := self fileDescriptor.
^ OperatingSystem writeCheck:fd
@@ -2258,12 +2415,8 @@
|fd inputSema hasData wasBlocked|
- filePointer isNil ifTrue:[
- ^ self errorNotOpen
- ].
- mode == #writeonly ifTrue:[
- ^ self errorWriteOnly
- ].
+ filePointer isNil ifTrue:[^ self errorNotOpen].
+ mode == #writeonly ifTrue:[^ self errorWriteOnly].
fd := self fileDescriptor.
(OperatingSystem readCheck:fd) ifTrue:[^ true].
@@ -2271,15 +2424,15 @@
wasBlocked := OperatingSystem blockInterrupts.
hasData := OperatingSystem readCheck:fd.
hasData ifFalse:[
- inputSema := Semaphore new.
- timeout notNil ifTrue:[
- Processor signal:inputSema afterSeconds:timeout
- ].
- Processor signal:inputSema onInput:fd.
- Processor activeProcess state:#ioWait.
- inputSema wait.
- Processor disableSemaphore:inputSema.
- hasData := OperatingSystem readCheck:fd
+ inputSema := Semaphore new.
+ timeout notNil ifTrue:[
+ Processor signal:inputSema afterSeconds:timeout
+ ].
+ Processor signal:inputSema onInput:fd.
+ Processor activeProcess state:#ioWait.
+ inputSema wait.
+ Processor disableSemaphore:inputSema.
+ hasData := OperatingSystem readCheck:fd
].
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
^ hasData
@@ -2304,10 +2457,10 @@
|fd outputSema canWrite wasBlocked|
filePointer isNil ifTrue:[
- ^ self errorNotOpen
+ ^ self errorNotOpen
].
mode == #readonly ifTrue:[
- ^ self errorReadOnly
+ ^ self errorReadOnly
].
fd := self fileDescriptor.
@@ -2316,15 +2469,15 @@
wasBlocked := OperatingSystem blockInterrupts.
canWrite := OperatingSystem writeCheck:fd.
canWrite ifFalse:[
- outputSema := Semaphore new.
- timeout notNil ifTrue:[
- Processor signal:outputSema afterSeconds:timeout
- ].
- Processor signal:outputSema onOutput:fd.
- Processor activeProcess state:#ioWait.
- outputSema wait.
- Processor disableSemaphore:outputSema.
- canWrite := OperatingSystem writeCheck:fd
+ outputSema := Semaphore new.
+ timeout notNil ifTrue:[
+ Processor signal:outputSema afterSeconds:timeout
+ ].
+ Processor signal:outputSema onOutput:fd.
+ Processor activeProcess state:#ioWait.
+ outputSema wait.
+ Processor disableSemaphore:outputSema.
+ canWrite := OperatingSystem writeCheck:fd
].
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
^ canWrite
@@ -2333,8 +2486,9 @@
!ExternalStream methodsFor:'reimplemented for speed'!
peekFor:anObject
- "return true and move past if next == something.
- Otherwise, stay and return false."
+ "return true and move past next element, if next == something.
+ Otherwise, stay and return false. False is also returned
+ when EOF is encountered."
%{ /* NOCONTEXT */
@@ -2343,45 +2497,59 @@
int peekValue;
extern int _immediateInterrupt;
- if (_INST(filePointer) != nil) {
- if (_INST(binary) == true) {
- if (_isSmallInteger(anObject)) {
- peekValue = _intVal(anObject) & 0xFF;
- } else {
- goto bad;
- }
- } else {
- if (__isCharacter(anObject)) {
- peekValue = _intVal(_characterVal(anObject)) & 0xFF;
- } else {
- goto bad;
- }
- }
-
- f = MKFD(_INST(filePointer));
- _immediateInterrupt = 1;
- c = getc(f);
- _immediateInterrupt = 0;
-
- if (c == peekValue) {
- OBJ pos;
-
- if ((pos = _INST(position)) != nil) {
- _INST(position) = _MKSMALLINT(_intVal(pos) + 1);
- }
- RETURN ( true );
- }
-
- if (c == EOF) {
- _INST(hitEOF) = true;
- } else {
- ungetc(c, f);
- }
- RETURN ( false );
+ _INST(lastErrorNumber) = nil;
+ if ((_INST(filePointer) != nil)
+ && (_INST(mode) != @symbol(writeonly))) {
+ if (_INST(binary) == true) {
+ if (_isSmallInteger(anObject)) {
+ peekValue = _intVal(anObject) & 0xFF;
+ } else {
+ goto bad;
+ }
+ } else {
+ if (__isCharacter(anObject)) {
+ peekValue = _intVal(_characterVal(anObject)) & 0xFF;
+ } else {
+ goto bad;
+ }
+ }
+
+ if ((_INST(didWrite) != false)
+ && (_INST(mode) == @symbol(readwrite))) {
+ _INST(didWrite) = false;
+ fseek(f, 0L, 1); /* needed in stdio */
+ }
+
+ f = MKFD(_INST(filePointer));
+ _immediateInterrupt = 1;
+ c = getc(f);
+ _immediateInterrupt = 0;
+
+ if (c == peekValue) {
+ OBJ pos;
+
+ if ((pos = _INST(position)) != nil) {
+ _INST(position) = _MKSMALLINT(_intVal(pos) + 1);
+ }
+ RETURN (true);
+ }
+
+ if (c != EOF) {
+ ungetc(c, f);
+ RETURN (false);
+ }
+
+ if (ferror(f)) {
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ } else {
+ _INST(hitEOF) = true;
+ RETURN (false);
+ }
}
bad: ;
-%}
-.
+%}.
+ mode == #writeonly ifTrue:[^ self errorWriteOnly].
+ lastErrorNumber notNil iftrue:[^ self readError].
filePointer isNil ifTrue:[^ self errorNotOpen].
^ super peekFor:anObject
!
@@ -2397,45 +2565,51 @@
int peekValue, c;
extern int _immediateInterrupt;
- if ((_INST(binary) == true) && _isSmallInteger(anObject)) {
- peekValue = _intVal(anObject) & 0xFF;
- } else {
- if ((_INST(binary) != true) && __isCharacter(anObject)) {
- peekValue = _intVal(_characterVal(anObject)) & 0xFF;
- } else
- peekValue = -1;
+ _INST(lastErrorNumber) = nil;
+ if ((_INST(filePointer) != nil)
+ && (_INST(mode) != @symbol(writeonly))) {
+ if ((_INST(binary) == true) && _isSmallInteger(anObject)) {
+ peekValue = _intVal(anObject) & 0xFF;
+ } else {
+ if ((_INST(binary) != true) && __isCharacter(anObject)) {
+ peekValue = _intVal(_characterVal(anObject)) & 0xFF;
+ } else {
+ peekValue = -1;
+ }
+ }
+
+ if (peekValue >= 0) {
+ f = MKFD(_INST(filePointer));
+ _immediateInterrupt = 1;
+ _INST(position) = nil;
+
+ if ((_INST(didWrite) != false)
+ && (_INST(mode) == @symbol(readwrite))) {
+ _INST(didWrite) = false;
+ fseek(f, 0L, 1); /* needed in stdio */
+ }
+
+ for (;;) {
+ c = getc(f);
+ if (c == EOF) {
+ _immediateInterrupt = 0;
+ if (ferror(f)) {
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ break;
+ }
+ _INST(hitEOF) = true;
+ RETURN (nil);
+ }
+ if (c == peekValue) {
+ _immediateInterrupt = 0;
+ RETURN (anObject);
+ }
+ }
+ _immediateInterrupt = 0;
+ }
}
-
- if (peekValue >= 0) {
- if (_INST(filePointer) != nil) {
- if (_INST(mode) != _writeonly) {
- f = MKFD(_INST(filePointer));
- _immediateInterrupt = 1;
- _INST(position) = nil;
-
- if ((_INST(didWrite) != false) && (_INST(mode) == _readwrite)) {
- _INST(didWrite) = false;
- fseek(f, 0L, 1); /* needed in stdio */
- }
-
- for (;;) {
- c = getc(f);
- if (c == EOF) {
- _INST(hitEOF) = true;
- _immediateInterrupt = 0;
- RETURN (nil);
- }
- if (c == peekValue) {
- _immediateInterrupt = 0;
- RETURN (anObject);
- }
- }
- _immediateInterrupt = 0;
- }
- }
- }
-%}
-.
+%}.
+ lastErrorNumber notNil iftrue:[^ self readError].
filePointer isNil ifTrue:[^ self errorNotOpen].
^ super nextMatchFor:anObject
!
@@ -2451,30 +2625,37 @@
char buffer[1024];
extern int _immediateInterrupt;
- if ((_INST(filePointer) != nil) && (_INST(mode) != _writeonly)) {
- if (_INST(binary) != true) {
- f = MKFD(_INST(filePointer));
+ _INST(lastErrorNumber) = nil;
+ if ((_INST(filePointer) != nil)
+ && (_INST(mode) != @symbol(writeonly))) {
+ if (_INST(binary) != true) {
+ f = MKFD(_INST(filePointer));
- if ((_INST(didWrite) != false) && (_INST(mode) == _readwrite)) {
- _INST(didWrite) = false;
- fseek(f, 0L, 1); /* needed in stdio */
- }
-
- _immediateInterrupt = 1;
- if (fgets(buffer, sizeof(buffer), f) != NULL) {
- _immediateInterrupt = 0;
- RETURN ( self );
- }
- _INST(hitEOF) = true;
- _immediateInterrupt = 0;
- RETURN ( nil );
- }
+ if ((_INST(didWrite) != false)
+ && (_INST(mode) == @symbol(readwrite))) {
+ _INST(didWrite) = false;
+ fseek(f, 0L, 1); /* needed in stdio */
+ }
+
+ _immediateInterrupt = 1;
+ if (fgets(buffer, sizeof(buffer), f) != NULL) {
+ _immediateInterrupt = 0;
+ RETURN ( self );
+ }
+ _immediateInterrupt = 0;
+ if (ferror(f)) {
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ } else {
+ _INST(hitEOF) = true;
+ RETURN ( nil );
+ }
+ }
}
-%}
-.
+%}.
+ lastErrorNumber notNil iftrue:[^ self readError].
filePointer isNil ifTrue:[^ self errorNotOpen].
binary ifTrue:[^ self errorBinary].
- self errorWriteOnly
+ ^ self errorWriteOnly
!
skipThroughAll:aString
@@ -2485,26 +2666,26 @@
|buffer len first|
(aString isString and:[binary not]) ifTrue:[
- len := aString size.
- first := aString at:1.
- buffer := String new:len.
- buffer at:1 put:first.
- len := len - 1.
- [true] whileTrue:[
- (self skipThrough:first) isNil ifTrue:[
- ^ nil.
- ].
- (self nextBytes:len into:buffer startingAt:2) == len ifFalse:[
- ^ nil
- ].
- buffer = aString ifTrue:[
- "
- position back, before string
- "
- ^ self
- ].
- ].
- "NOT REACHED"
+ len := aString size.
+ first := aString at:1.
+ buffer := String new:len.
+ buffer at:1 put:first.
+ len := len - 1.
+ [true] whileTrue:[
+ (self skipThrough:first) isNil ifTrue:[
+ ^ nil.
+ ].
+ (self nextBytes:len into:buffer startingAt:2) == len ifFalse:[
+ ^ nil
+ ].
+ buffer = aString ifTrue:[
+ "
+ position back, before string
+ "
+ ^ self
+ ].
+ ].
+ "NOT REACHED"
].
^ super skipThroughAll:aString
@@ -2525,11 +2706,11 @@
oldPos := self position.
(self skipThroughAll:aString) isNil ifTrue:[
- "
- restore position
- "
- self position:oldPos.
- ^ nil
+ "
+ restore position
+ "
+ self position:oldPos.
+ ^ nil
].
"
position before match-string
@@ -2557,49 +2738,58 @@
REGISTER int c, cSearch;
extern int _immediateInterrupt;
- if ((_INST(filePointer) != nil) && (_INST(mode) != _writeonly)) {
- if (_INST(binary) == true) {
- /* searched for object must be a smallInteger */
- if (! _isSmallInteger(aCharacter)) goto badArgument;
- cSearch = _intVal(aCharacter);
- } else {
- /* searched for object must be a character */
- if (! __isCharacter(aCharacter)) goto badArgument;
- cSearch = _intVal(_characterVal(aCharacter));
- }
- /* Q: should we just say: "not found" ? */
- if ((cSearch < 0) || (cSearch > 255)) goto badArgument;
-
- f = MKFD(_INST(filePointer));
+ _INST(lastErrorNumber) = nil;
+ if ((_INST(filePointer) != nil)
+ && (_INST(mode) != @symbol(writeonly))) {
+ if (_INST(binary) == true) {
+ /* searched for object must be a smallInteger */
+ if (! _isSmallInteger(aCharacter)) goto badArgument;
+ cSearch = _intVal(aCharacter);
+ } else {
+ /* searched for object must be a character */
+ if (! __isCharacter(aCharacter)) goto badArgument;
+ cSearch = _intVal(_characterVal(aCharacter));
+ }
+ /* Q: should we just say: "not found" ? */
+ if ((cSearch < 0) || (cSearch > 255)) goto badArgument;
+
+ f = MKFD(_INST(filePointer));
- if ((_INST(didWrite) != false) && (_INST(mode) == _readwrite)) {
- _INST(didWrite) = false;
- fseek(f, 0L, 1); /* needed in stdio */
- }
-
- _immediateInterrupt = 1;
- while (1) {
- if (feof(f)) {
- _immediateInterrupt = 0;
- RETURN ( nil );
- }
-
- c = getc(f);
-
- if (c < 0) {
- _immediateInterrupt = 0;
- _INST(hitEOF) = true;
- RETURN (nil);
- }
- if (c == cSearch) {
- _immediateInterrupt = 0;
- RETURN (self);
- }
- }
+ if ((_INST(didWrite) != false)
+ && (_INST(mode) == @symbol(readwrite))) {
+ _INST(didWrite) = false;
+ fseek(f, 0L, 1); /* needed in stdio */
+ }
+
+ _immediateInterrupt = 1;
+ while (1) {
+#ifdef NOTNEEDED
+ if (feof(f)) {
+ _immediateInterrupt = 0;
+ RETURN ( nil );
+ }
+#endif
+ c = getc(f);
+
+ if (c == cSearch) {
+ _immediateInterrupt = 0;
+ RETURN (self);
+ }
+ if (c < 0) {
+ _immediateInterrupt = 0;
+ if (ferror(f)) {
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ break;
+ } else {
+ _INST(hitEOF) = true;
+ RETURN (nil);
+ }
+ }
+ }
}
badArgument: ;
-%}
-.
+%}.
+ lastErrorNumber notNil iftrue:[^ self readError].
filePointer isNil ifTrue:[^ self errorNotOpen].
(mode == #writeonly) ifTrue:[^ self errorWriteOnly].
"
@@ -2627,48 +2817,54 @@
REGISTER int c;
extern int _immediateInterrupt;
- if ((_INST(filePointer) != nil) && (_INST(mode) != _writeonly)) {
- if (_INST(binary) != true) {
- f = MKFD(_INST(filePointer));
+ _INST(lastErrorNumber) = nil;
+ if ((_INST(filePointer) != nil)
+ && (_INST(mode) != @symbol(writeonly))) {
+ if (_INST(binary) != true) {
+ f = MKFD(_INST(filePointer));
- if ((_INST(didWrite) != false) && (_INST(mode) == _readwrite)) {
- _INST(didWrite) = false;
- fseek(f, 0L, 1); /* needed in stdio */
- }
-
- _immediateInterrupt = 1;
- while (1) {
- if (feof(f)) {
- _immediateInterrupt = 0;
- RETURN ( nil );
- }
-
- c = getc(f);
-
- switch (c) {
- case ' ':
- case '\t':
- case '\n':
- case '\r':
- case '\b':
- case '\014':
- break;
-
- default:
- if (c < 0) {
- _INST(hitEOF) = true;
- _immediateInterrupt = 0;
- RETURN ( nil );
- }
- ungetc(c, f);
- _immediateInterrupt = 0;
- RETURN ( _MKCHARACTER(c & 0xFF) );
- }
- }
- }
+ if ((_INST(didWrite) != false) && (_INST(mode) == _readwrite)) {
+ _INST(didWrite) = false;
+ fseek(f, 0L, 1); /* needed in stdio */
+ }
+
+ _immediateInterrupt = 1;
+ while (1) {
+ if (feof(f)) {
+ _immediateInterrupt = 0;
+ RETURN ( nil );
+ }
+
+ c = getc(f);
+
+ switch (c) {
+ case ' ':
+ case '\t':
+ case '\n':
+ case '\r':
+ case '\b':
+ case '\014':
+ break;
+
+ default:
+ _immediateInterrupt = 0;
+ if (c < 0) {
+ if (ferror(f)) {
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ goto err;
+ }
+ _INST(hitEOF) = true;
+ RETURN ( nil );
+ }
+ ungetc(c, f);
+ RETURN ( _MKCHARACTER(c & 0xFF) );
+ }
+ }
+ }
}
-%}
-.
+err: ;
+%}.
+ lastErrorNumber notNil iftrue:[^ self readError].
filePointer isNil ifTrue:[^ self errorNotOpen].
(mode == #writeonly) ifTrue:[^ self errorWriteOnly].
^ self errorBinary.
@@ -2686,49 +2882,143 @@
int c;
extern int _immediateInterrupt;
- if ((_INST(filePointer) != nil) && (_INST(mode) != _writeonly)) {
- if (_INST(binary) != true) {
- f = MKFD(_INST(filePointer));
-
- if ((_INST(didWrite) != false) && (_INST(mode) == _readwrite)) {
- _INST(didWrite) = false;
- fseek(f, 0L, 1); /* needed in stdio */
- }
-
- _immediateInterrupt = 1;
- while (1) {
+ _INST(lastErrorNumber) = nil;
+ if ((_INST(filePointer) != nil)
+ && (_INST(mode) != @symbol(writeonly))) {
+ if (_INST(binary) != true) {
+ f = MKFD(_INST(filePointer));
+
+ if ((_INST(didWrite) != false)
+ && (_INST(mode) == @symbol(readwrite))) {
+ _INST(didWrite) = false;
+ fseek(f, 0L, 1); /* needed in stdio */
+ }
+
+ _immediateInterrupt = 1;
+ while (1) {
- if (feof(f)) {
- _immediateInterrupt = 0;
- RETURN ( nil );
- }
-
- c = getc(f);
-
- switch (c) {
- case ' ':
- case '\t':
- case '\b':
- break;
-
- default:
- if (c < 0) {
- _INST(hitEOF) = true;
- _immediateInterrupt = 0;
- RETURN ( nil );
- }
- ungetc(c, f);
- _immediateInterrupt = 0;
- RETURN ( _MKCHARACTER(c & 0xFF) );
- }
- }
- }
+ if (feof(f)) {
+ _immediateInterrupt = 0;
+ RETURN ( nil );
+ }
+
+ c = getc(f);
+
+ switch (c) {
+ case ' ':
+ case '\t':
+ case '\b':
+ break;
+
+ default:
+ _immediateInterrupt = 0;
+ if (c < 0) {
+ if (ferror(f)) {
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ goto err;
+ }
+ _INST(hitEOF) = true;
+ RETURN ( nil );
+ }
+ ungetc(c, f);
+ RETURN ( _MKCHARACTER(c & 0xFF) );
+ }
+ }
+ }
}
-%}
-.
+err: ;
+%}.
+ lastErrorNumber notNil iftrue:[^ self readError].
filePointer isNil ifTrue:[^ self errorNotOpen].
(mode == #writeonly) ifTrue:[^ self errorWriteOnly].
- self errorBinary
+ ^ self errorBinary
+!
+
+nextAlphaNumericWord
+ "read the next word (i.e. up to non letter-or-digit).
+ return a string containing those characters."
+
+%{ /* STACK: 2000 */
+ FILE *f;
+ int len;
+ char buffer[1024];
+ int ch;
+ int cnt = 0;
+ extern int _immediateInterrupt;
+
+ if ((_INST(filePointer) != nil)
+ && (_INST(mode) != @symbol(writeonly))) {
+ f = MKFD(_INST(filePointer));
+
+ _immediateInterrupt = 1;
+
+ if ((_INST(didWrite) != false)
+ && (_INST(mode) == @symbol(readwrite))) {
+ _INST(didWrite) = false;
+ fseek(f, 0L, 1); /* needed in stdio */
+ }
+
+ for (;;) {
+ ch = getc(f);
+ if (ch < 0) {
+ if (ferror(f)) {
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ goto err;
+ }
+ _INST(hitEOF) = true;
+ break;
+ }
+ cnt++;
+
+ if (ch >= ' ') break;
+ if ((ch != ' ') && (ch != '\t') && (ch != '\r')
+ && (ch != '\n') && (ch != 0x0b)) break;
+ }
+ ungetc(ch, f);
+ cnt--;
+
+ len = 0;
+ for (;;) {
+ ch = getc(f);
+ if (ch < 0) {
+ if (ferror(f)) {
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ goto err;
+ }
+ _INST(hitEOF) = true;
+ break;
+ }
+
+ ch &= 0xFF;
+ if (! (((ch >= 'a') && (ch <= 'z')) ||
+ ((ch >= 'A') && (ch <= 'Z')) ||
+ ((ch >= '0') && (ch <= '9')))) {
+ ungetc(ch, f);
+ break;
+ }
+ cnt++;
+ buffer[len++] = ch;
+ if (len >= sizeof(buffer)-1) {
+ /* emergency */
+ break;
+ }
+ }
+ _immediateInterrupt = 0;
+
+ if (_INST(position) != nil) {
+ _INST(position) = _MKSMALLINT(_intVal(_INST(position)) + cnt);
+ }
+ buffer[len] = '\0';
+ if (len != 0) {
+ RETURN ( _MKSTRING(buffer COMMA_CON) );
+ }
+ RETURN ( nil );
+ }
+err: ;
+%}.
+ lastErrorNumber notNil ifTrue:[^ self readError].
+ filePointer isNil ifTrue:[^ self errorNotOpen].
+ ^ self errorWriteOnly
!
nextChunk
@@ -2738,29 +3028,32 @@
|retVal|
- filePointer isNil ifTrue:[
- ^ self errorNotOpen
- ].
- binary ifTrue:[
- ^ self errorBinary
- ].
-
+ filePointer isNil ifTrue:[^ self errorNotOpen].
+ binary ifTrue:[^ self errorBinary].
+ (mode == #writeonly) ifTrue:[^ self errorWriteOnly].
%{
FILE *f;
int done = 0;
REGISTER int c;
unsigned char peekC;
- char *buffer, *newBuffer;
+ char *buffer = (char *)0, *newBuffer;
REGISTER int index;
int currSize;
int inComment, inString, inPrimitive = 0;
extern int _immediateInterrupt;
+ _INST(lastErrorNumber) = nil;
f = MKFD(_INST(filePointer));
- if ((_INST(didWrite) != false) && (_INST(mode) == _readwrite)) {
- _INST(didWrite) = false;
- fseek(f, 0L, 1); /* needed in stdio */
+ if ((_INST(didWrite) != false)
+ && (_INST(mode) == @symbol(readwrite))) {
+ _INST(didWrite) = false;
+ fseek(f, 0L, 1); /* needed in stdio */
+ }
+
+ if (feof(f)) {
+ _immediateInterrupt = 0;
+ RETURN (nil);
}
/*
@@ -2768,34 +3061,34 @@
*/
_immediateInterrupt = 1;
while (! done) {
- if (feof(f)) {
- _immediateInterrupt = 0;
- RETURN ( nil );
- }
-
- do {
- c = getc(f);
- } while ((c < 0) && (errno == EINTR));
-
- switch (c) {
- case ' ':
- case '\t':
- case '\n':
- case '\r':
- case '\b':
- case '\014':
- break;
-
- case EOF:
- _immediateInterrupt = 0;
- _INST(hitEOF) = true;
- RETURN ( nil );
-
- default:
- ungetc(c, f);
- done = 1;
- break;
- }
+
+ do {
+ c = getc(f);
+ } while ((c < 0) && (errno == EINTR));
+
+ switch (c) {
+ case ' ':
+ case '\t':
+ case '\n':
+ case '\r':
+ case '\b':
+ case '\014':
+ break;
+
+ case EOF:
+ _immediateInterrupt = 0;
+ if (ferror(f)) {
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ goto err;
+ }
+ _INST(hitEOF) = true;
+ RETURN (nil);
+
+ default:
+ ungetc(c, f);
+ done = 1;
+ break;
+ }
}
/*
@@ -2805,44 +3098,50 @@
currSize = 3000;
index = 0;
while (! feof(f)) {
- /* do we have to resize the buffer ? */
- if ((index+2) >= currSize) {
- newBuffer = (char *)malloc(currSize * 2);
- bcopy(buffer, newBuffer, index);
- free(buffer);
- buffer = newBuffer;
- currSize = currSize * 2;
- }
- do {
- c = getc(f);
- } while (c < 0 && (errno == EINTR));
-
- if (c == '%') {
- peekC = getc(f);
- ungetc(peekC, f);
- if (peekC == '{') {
- inPrimitive++;
- } else if (peekC == '}') {
- inPrimitive--;
- }
- } else {
- if (! inPrimitive) {
- if (c == '!') {
- do {
- c = getc(f);
- } while (c < 0 && (errno == EINTR));
- if (c != '!') {
- ungetc(c, f);
- break;
- }
- }
- }
- }
- if (c == EOF) {
- _INST(hitEOF) = true;
- break;
- }
- buffer[index++] = c;
+ /* do we have to resize the buffer ? */
+ if ((index+2) >= currSize) {
+ newBuffer = (char *)malloc(currSize * 2);
+ bcopy(buffer, newBuffer, index);
+ free(buffer);
+ buffer = newBuffer;
+ currSize = currSize * 2;
+ }
+ do {
+ c = getc(f);
+ } while (c < 0 && (errno == EINTR));
+
+ if (c == '%') {
+ peekC = getc(f);
+ ungetc(peekC, f);
+ if (peekC == '{') {
+ inPrimitive++;
+ } else if (peekC == '}') {
+ inPrimitive--;
+ }
+ } else {
+ if (! inPrimitive) {
+ if (c == '!') {
+ do {
+ c = getc(f);
+ } while (c < 0 && (errno == EINTR));
+ if (c != '!') {
+ ungetc(c, f);
+ break;
+ }
+ }
+ }
+ }
+
+ if (c < 0) {
+ _immediateInterrupt = 0;
+ if (ferror(f)) {
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ goto err;
+ }
+ _INST(hitEOF) = true;
+ break;
+ }
+ buffer[index++] = c;
}
_immediateInterrupt = 0;
@@ -2851,8 +3150,10 @@
* make it a string
*/
retVal = _MKSTRING(buffer COMMA_CON);
- free(buffer);
-%}
-.
+err:
+ if (buffer)
+ free(buffer);
+%}.
+ lastErrorNumber notNil ifTrue:[^ self readError].
^ retVal
! !
--- a/ExternalStream.st Mon Oct 10 01:29:01 1994 +0100
+++ b/ExternalStream.st Mon Oct 10 01:29:28 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1988 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -11,17 +11,20 @@
"
ReadWriteStream subclass:#ExternalStream
- instanceVariableNames:'filePointer mode buffered binary useCRLF hitEOF didWrite'
- classVariableNames:'Lobby LastErrorNumber'
+ instanceVariableNames:'filePointer mode buffered binary useCRLF hitEOF didWrite lastErrorNumber'
+ classVariableNames:'Lobby LastErrorNumber
+ StreamErrorSignal ReadErrorSignal WriteErrorSignal
+ InvalidReadSignal InvalidWriteSignal InvalidModeSignal
+ StreamNotOpenSignal'
poolDictionaries:''
category:'Streams-External'
!
ExternalStream comment:'
COPYRIGHT (c) 1988 by Claus Gittinger
- All Rights Reserved
-
-$Header: /cvs/stx/stx/libbasic/ExternalStream.st,v 1.20 1994-08-11 21:36:34 claus Exp $
+ All Rights Reserved
+
+$Header: /cvs/stx/stx/libbasic/ExternalStream.st,v 1.21 1994-10-10 00:25:47 claus Exp $
'!
%{
@@ -39,7 +42,7 @@
copyright
"
COPYRIGHT (c) 1988 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -52,7 +55,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/ExternalStream.st,v 1.20 1994-08-11 21:36:34 claus Exp $
+$Header: /cvs/stx/stx/libbasic/ExternalStream.st,v 1.21 1994-10-10 00:25:47 claus Exp $
"
!
@@ -62,7 +65,7 @@
represent some file or communicationChannel of the underlying OperatingSystem.
ExternalStream is abstract; concrete classes are FileStream, PipeStream etc.
- ExternalStreams can be in two modes: text (the default) and binary.
+ ExternalStreams can be in two modes: text- (the default) and binary-mode.
In text-mode, the elements read/written are characters;
while in binary-mode the basic elements are bytes which read/write as SmallIntegers
in the range 0..255.
@@ -75,7 +78,7 @@
or just forgotten - in this case, the garbage collector will eventually collect the
object AND a close will be performed automatically (but you will NOT know when this
happens - so it is recommended, that you close your files when no longer needed).
- Closing is also suggested since if smalltalk is finished (be it by purpose, or due to
+ Closing is also suggested, since if smalltalk is finished (be it by purpose, or due to
some crash) the data will not be in the file, if unclosed.
All streams understand the close message, so it never hurts to use it (it is defined as
a noop in one of the superclasses).
@@ -91,35 +94,81 @@
Instance variables:
- filePointer <Integer> the unix FILE*; somehow mapped to an integer
- (notice: not the fd)
- mode <Symbol> #readwrite, #readonly or #writeonly
- buffered <Boolean> true, if buffered (i.e. collects characters - does
- not output immediately)
- binary <Boolean> true if in binary mode (reads bytes instead of chars)
- useCRLF <Boolean> true, if lines should be terminated with crlf instead
- of lf. (i.e. if file is an MSDOS-type file)
- hitEOF <Boolean> true, if EOF was reached
-
+ filePointer <Integer> the unix FILE*; somehow mapped to an integer
+ (notice: not the fd)
+ mode <Symbol> #readwrite, #readonly or #writeonly
+ buffered <Boolean> true, if buffered (i.e. collects characters - does
+ not output immediately)
+ binary <Boolean> true if in binary mode (reads bytes instead of chars)
+ useCRLF <Boolean> true, if lines should be terminated with crlf instead
+ of lf. (i.e. if file is an MSDOS-type file)
+ hitEOF <Boolean> true, if EOF was reached
+
+ lastErrorNumber <Integer> the value of errno (only valid right after the error -
+ updated with next i/o operation)
Class variables:
- Lobby <Registry> keeps track of used ext-streams (to free up FILE*'s)
-
- LastErrorNumber <Integer> the value of errno (only valid right after the error -
- updated with next i/o operation)
-
- Question: should lastErrorNumber be kept instance-specific ?
+ Lobby <Registry> keeps track of used ext-streams (to free up FILE*'s)
+
+ StreamErrorSignal <Signal> parent of all stream errors
+ ReadErrorSignal <Signal> raised on read errors
+ WriteErrorSignal <Signal> raised on write errors
+ InvalidReadSignal <Signal> raised on read from writeonly stream
+ InvalidWriteSignal <Signal> raised on write to readonly stream
+ InvalidModeSignal <Signal> raised on text I/O with binary-stream
+ or binary I/O with text-stream
+ StreamNotOpenSignal <Signal> raised on I/O with non-open stream
+
+ Additional notes:
+ This class is implemented using the underlying stdio-c library package, which
+ has both advantages and disadvantages: since it is portable (posix defined), porting
+ ST/X to non-Unix machines is simplified. The disadvantage is that the stdio library
+ has big problems handling unbounded Streams, since the EOF handling in stdio is
+ not prepared for data to arrive after EOF has been reached - time will show, if we need
+ a complete rewrite for UnboundedStream ...
"
! !
!ExternalStream class methodsFor:'initialization'!
initialize
+ StreamErrorSignal isNil ifTrue:[
+ super initialize.
+
+ StreamErrorSignal := Object errorSignal newSignalMayProceed:false.
+ StreamErrorSignal nameClass:self message:#streamErrorSignal.
+ StreamErrorSignal notifierString:'I/O error'.
+
+ ReadErrorSignal := StreamErrorSignal newSignalMayProceed:false.
+ ReadErrorSignal nameClass:self message:#readErrorSignal.
+ ReadErrorSignal notifierString:'read error'.
+
+ WriteErrorSignal := StreamErrorSignal newSignalMayProceed:false.
+ WriteErrorSignal nameClass:self message:#writeErrorSignal.
+ WriteErrorSignal notifierString:'write error'.
+
+ InvalidReadSignal := ReadErrorSignal newSignalMayProceed:false.
+ InvalidReadSignal nameClass:self message:#invalidReadSignal.
+ InvalidReadSignal notifierString:'write error'.
+
+ InvalidWriteSignal := WriteErrorSignal newSignalMayProceed:false.
+ InvalidWriteSignal nameClass:self message:#invalidWriteSignal.
+ InvalidWriteSignal notifierString:'write error'.
+
+ InvalidModeSignal := StreamErrorSignal newSignalMayProceed:false.
+ InvalidModeSignal nameClass:self message:#invalidModeSignal.
+ InvalidModeSignal notifierString:'binary/text mode mismatch'.
+
+ StreamNotOpenSignal := StreamErrorSignal newSignalMayProceed:false.
+ StreamNotOpenSignal nameClass:self message:#streamNotOpenSignal.
+ StreamNotOpenSignal notifierString:'stream is not open'.
+ ].
+
Lobby isNil ifTrue:[
- Lobby := Registry new.
-
- "want to get informed when returning from snapshot"
- ObjectMemory addDependent:self
+ Lobby := Registry new.
+
+ "want to get informed when returning from snapshot"
+ ObjectMemory addDependent:self
]
!
@@ -127,7 +176,7 @@
"reopen all files (if possible) after a snapShot load"
Lobby contentsDo:[:aFileStream |
- aFileStream reOpen
+ aFileStream reOpen
]
!
@@ -135,10 +184,58 @@
"have to reopen files when returning from snapshot"
something == #returnFromSnapshot ifTrue:[
- self reOpenFiles
+ self reOpenFiles
]
! !
+!ExternalStream class methodsFor:'signal access '!
+
+streamErrorSignal
+ "return the parent of all stream errors;
+ handling this one also handles all other errors.
+ Also, this one is raised for errors not related to read/write
+ operations, such as failed ioctls"
+
+ ^ StreamErrorSignal
+!
+
+readErrorSignal
+ "return the signal raised on read errors"
+
+ ^ ReadErrorSignal
+!
+
+writeErrorSignal
+ "return the signal raised on write errors"
+
+ ^ WriteErrorSignal
+!
+
+invalidReadSignal
+ "return the signal raised when reading from writeonly streams"
+
+ ^ InvalidReadSignal
+!
+
+invalidWriteSignal
+ "return the signal raised when writing to readonly streams"
+
+ ^ InvalidWriteSignal
+!
+
+invalidModeSignal
+ "return the signal raised when doing text-I/O with a binary stream
+ or binary-I/O with a text stream"
+
+ ^ InvalidModeSignal
+!
+
+streamNotOpenSignal
+ "return the signal raised on I/O with closed streams"
+
+ ^ StreamNotOpenSignal
+! !
+
!ExternalStream class methodsFor:'instance creation'!
new
@@ -152,9 +249,13 @@
!ExternalStream class methodsFor:'error handling'!
lastErrorNumber
- "return the last error"
+ "return the errno of the last error"
^ LastErrorNumber
+
+ "
+ ExternalStream lastErrorNumber
+ "
!
lastErrorString
@@ -169,6 +270,18 @@
!ExternalStream methodsFor:'instance release'!
+shallowCopyForFinalization
+ "return a copy for finalization-registration;
+ since all we need at finalization time is the fileDescriptor,
+ a cheaper copy is possible."
+
+ ^ self class basicNew setFilePointer:filePointer
+!
+
+setFilePointer:anInteger
+ filePointer := anInteger
+!
+
disposed
"some Stream has been collected - close the file if not already done"
@@ -181,11 +294,11 @@
%{ /* NOCONTEXT */
if (_INST(filePointer) != nil) {
- extern int _immediateInterrupt;
-
- _immediateInterrupt = 1;
- fclose(MKFD(_INST(filePointer)));
- _immediateInterrupt = 0;
+ extern int _immediateInterrupt;
+
+ _immediateInterrupt = 1;
+ fclose(MKFD(_INST(filePointer)));
+ _immediateInterrupt = 0;
}
%}
! !
@@ -203,6 +316,10 @@
self class name errorPrint. ': cannot reOpen stream - stream closed' errorPrintNewline.
filePointer := nil.
Lobby unregister:self.
+!
+
+setLastError:aNumber
+ lastErrorNumber := aNumber
! !
!ExternalStream methodsFor:'error handling'!
@@ -210,49 +327,88 @@
lastErrorNumber
"return the last error"
- ^ LastErrorNumber
+ ^ lastErrorNumber
!
lastErrorString
"return a message string describing the last error"
- ^ self class lastErrorString
+ (lastErrorNumber isNil or:[lastErrorNumber == 0]) ifTrue:[
+ ^ 'I/O error'
+ ].
+ ^ OperatingSystem errorTextForNumber:lastErrorNumber
!
errorNotOpen
"report an error, that the stream has not been opened"
- ^ self error:(self class name , ' not open')
+ ^ StreamNotOpenSignal
+ raiseRequestWith:self
+ errorString:(self class name , ' not open')
!
errorReadOnly
"report an error, that the stream is a readOnly stream"
- ^ self error:(self class name , ' is readonly')
+ ^ InvalidWriteSignal
+ raiseRequestWith:self
+ errorString:(self class name , ' is readonly')
!
errorWriteOnly
"report an error, that the stream is a writeOnly stream"
- ^ self error:(self class name , ' is writeonly')
+ ^ InvalidReadSignal
+ raiseRequestWith:self
+ errorString:(self class name , ' is writeonly')
!
errorNotBinary
"report an error, that the stream is not in binary mode"
- ^ self error:(self class name , ' is not in binary mode')
+ ^ InvalidModeSignal
+ raiseRequestWith:self
+ errorString:(self class name , ' is not in binary mode')
!
errorBinary
"report an error, that the stream is in binary mode"
- ^ self error:(self class name , ' is in binary mode')
+ ^ InvalidModeSignal
+ raiseRequestWith:self
+ errorString:(self class name , ' is in binary mode')
!
errorNotBuffered
"report an error, that the stream is not in buffered mode"
- ^ self error:(self class name , ' is unbuffered - operation not allowed')
+ ^ StreamErrorSignal
+ raiseRequestWith:self
+ errorString:(self class name , ' is unbuffered - operation not allowed')
+!
+
+ioError
+ "report an error, that some I/O error occured"
+
+ ^ StreamErrorSignal
+ raiseRequestWith:self
+ errorString:('I/O error: ' , self lastErrorString)
+!
+
+readError
+ "report an error, that some read error occured"
+
+ ^ ReadErrorSignal
+ raiseRequestWith:self
+ errorString:('read error: ' , self lastErrorString)
+!
+
+writeError
+ "report an error, that some write error occured"
+
+ ^ WriteErrorSignal
+ raiseRequestWith:self
+ errorString:('write error: ' , self lastErrorString)
!
argumentMustBeInteger
@@ -312,8 +468,8 @@
FILE *f;
if (_INST(filePointer) != nil) {
- f = MKFD(_INST(filePointer));
- RETURN ( MKOBJ(fileno(f)) );
+ f = MKFD(_INST(filePointer));
+ RETURN ( MKOBJ(fileno(f)) );
}
%}
.
@@ -349,7 +505,7 @@
(such as upTo)"
binary ifTrue:[
- ^ ByteArray
+ ^ ByteArray
].
^ String
!
@@ -364,41 +520,41 @@
|text l chunks sizes chunk byteCount cnt bytes offset|
binary ifTrue:[
- "adding to a ByteArray produces quadratic time-space
- behavior - therefore we allocate chunks, and concatenate them
- at the end."
-
- chunks := OrderedCollection new.
- sizes := OrderedCollection new.
- byteCount := 0.
- [self atEnd] whileFalse:[
- chunk := ByteArray uninitializedNew:4096.
- cnt := self nextBytes:(chunk size) into:chunk.
- cnt notNil ifTrue:[
- chunks add:chunk.
- sizes add:cnt.
- byteCount := byteCount + cnt
- ]
- ].
-
- "now, create one big ByteArray"
- bytes := ByteArray uninitializedNew:byteCount.
- offset := 1.
- 1 to:chunks size do:[:index |
- chunk := chunks at:index.
- cnt := sizes at:index.
- bytes replaceFrom:offset to:(offset + cnt - 1) with:chunk.
- offset := offset + cnt
- ].
- ^ bytes
+ "adding to a ByteArray produces quadratic time-space
+ behavior - therefore we allocate chunks, and concatenate them
+ at the end."
+
+ chunks := OrderedCollection new.
+ sizes := OrderedCollection new.
+ byteCount := 0.
+ [self atEnd] whileFalse:[
+ chunk := ByteArray uninitializedNew:4096.
+ cnt := self nextBytes:(chunk size) into:chunk.
+ cnt notNil ifTrue:[
+ chunks add:chunk.
+ sizes add:cnt.
+ byteCount := byteCount + cnt
+ ]
+ ].
+
+ "now, create one big ByteArray"
+ bytes := ByteArray uninitializedNew:byteCount.
+ offset := 1.
+ 1 to:chunks size do:[:index |
+ chunk := chunks at:index.
+ cnt := sizes at:index.
+ bytes replaceFrom:offset to:(offset + cnt - 1) with:chunk.
+ offset := offset + cnt
+ ].
+ ^ bytes
].
text := Text new.
[self atEnd] whileFalse:[
- l := self nextLine.
- l notNil ifTrue:[
- text add:l
- ]
+ l := self nextLine.
+ l notNil ifTrue:[
+ text add:l
+ ]
].
^ text
! !
@@ -449,6 +605,18 @@
self position:(self position - 1)
!
+reset
+ "set the read position to the beginning of the collection"
+
+ self position:"0" 1
+!
+
+setToEnd
+ "redefined since it must be implemented differently"
+
+ ^ self subclassResponsibility
+!
+
blocking:aBoolean
"set/clear the blocking attribute - if set (which is the default)
a read (using next) on the receiver will block until data is available.
@@ -464,11 +632,14 @@
the receiver will trigger an ioInterrupt.
If cleared (which is the default) no special notification is made."
+ |fd|
+
filePointer isNil ifTrue:[^ self errorNotOpen].
+ fd := self fileDescriptor.
aBoolean ifTrue:[
- ^ OperatingSystem enableIOInterruptsOn:(self fileDescriptor)
+ ^ OperatingSystem enableIOInterruptsOn:fd
].
- ^ OperatingSystem disableIOInterruptsOn:(self fileDescriptor)
+ ^ OperatingSystem disableIOInterruptsOn:fd
!
ioctl:ioctlNumber
@@ -482,28 +653,32 @@
extern int _immediateInterrupt;
extern errno;
+ _INST(lastErrorNumber) = nil;
if (_INST(filePointer) != nil) {
- if (_isSmallInteger(ioctlNumber)) {
- ioNum = _intVal(ioctlNumber);
- f = MKFD(_INST(filePointer));
-
- _immediateInterrupt = 1;
- do {
- ret = ioctl(fileno(f), ioNum);
- } while ((ret < 0) && (errno == EINTR));
- _immediateInterrupt = 0;
-
- if (ret >= 0) {
- RETURN ( _MKSMALLINT(ret) );
- }
- ExternalStream_LastErrorNumber = _MKSMALLINT(errno);
- RETURN ( nil );
- }
+ if (_isSmallInteger(ioctlNumber)) {
+ ioNum = _intVal(ioctlNumber);
+ f = MKFD(_INST(filePointer));
+
+ _immediateInterrupt = 1;
+ do {
+ ret = ioctl(fileno(f), ioNum);
+ } while ((ret < 0) && (errno == EINTR));
+ _immediateInterrupt = 0;
+
+ if (ret >= 0) {
+ RETURN ( _MKSMALLINT(ret) );
+ }
+ _INST(position) = nil;
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ }
}
-%}
-.
+%}.
+ lastErrorNumber notNil ifTrue:[^ self ioError].
filePointer isNil ifTrue:[^ self errorNotOpen].
- self primitiveFailed
+ "
+ ioctl-number is not an integer
+ "
+ ^ self primitiveFailed
!
ioctl:ioctlNumber with:arg
@@ -514,42 +689,43 @@
the data is passed. This allows performing most ioctls - however,
it might be tricky to setup the buffer."
- |isStructure|
-
- isStructure := arg isKindOf:ByteArray.
-%{
+%{ /* NOCONTEXT */
FILE *f;
int ret, ioNum;
extern int _immediateInterrupt;
extern errno;
+ _INST(lastErrorNumber) = nil;
if (_INST(filePointer) != nil) {
- if (_isSmallInteger(ioctlNumber)
- && (_isSmallInteger(arg) || (isStructure == true))) {
- f = MKFD(_INST(filePointer));
- ioNum = _intVal(ioctlNumber);
-
- _immediateInterrupt = 1;
- do {
- if (isStructure == true) {
- ret = ioctl(fileno(f), ioNum, _ByteArrayInstPtr(arg)->ba_element);
- } else {
- ret = ioctl(fileno(f), ioNum, _intVal(arg));
- }
- } while ((ret < 0) && (errno == EINTR));
- _immediateInterrupt = 0;
-
- if (ret >= 0) {
- RETURN ( _MKSMALLINT(ret) );
- }
- ExternalStream_LastErrorNumber = _MKSMALLINT(errno);
- RETURN ( nil );
- }
+ if (_isSmallInteger(ioctlNumber)
+ && (_isSmallInteger(arg) || __isBytes(arg))) {
+ f = MKFD(_INST(filePointer));
+ ioNum = _intVal(ioctlNumber);
+
+ _immediateInterrupt = 1;
+ do {
+ if (_isSmallInteger(arg)) {
+ ret = ioctl(fileno(f), ioNum, _intVal(arg));
+ } else {
+ ret = ioctl(fileno(f), ioNum, _ByteArrayInstPtr(arg)->ba_element);
+ }
+ } while ((ret < 0) && (errno == EINTR));
+ _immediateInterrupt = 0;
+
+ if (ret >= 0) {
+ RETURN ( _MKSMALLINT(ret) );
+ }
+ _INST(position) = nil;
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ }
}
-%}
-.
+%}.
+ lastErrorNumber notNil ifTrue:[^ self ioError].
filePointer isNil ifTrue:[^ self errorNotOpen].
- self primitiveFailed
+ "
+ ioctl-number is not an integer or argument is not byteArray-like
+ "
+ ^ self primitiveFailed
! !
!ExternalStream methodsFor:'non homogenous reading'!
@@ -567,38 +743,42 @@
extern errno;
extern int _immediateInterrupt;
- if ((_INST(filePointer) != nil) && (_INST(mode) != _writeonly)) {
- f = MKFD(_INST(filePointer));
-
- _immediateInterrupt = 1;
- do {
- if (_INST(buffered) == false) {
- cnt = read(fileno(f), &byte, 1);
- } else {
- if ((_INST(didWrite) != false) && (_INST(mode) == _readwrite)) {
- _INST(didWrite) = false;
- fseek(f, 0L, 1); /* needed in stdio */
- }
- cnt = fread(&byte, 1, 1, f);
- }
- } while ((cnt < 0) && (errno == EINTR));
- _immediateInterrupt = 0;
-
- if (cnt == 1) {
- if (_INST(position) != nil)
- _INST(position) = _MKSMALLINT(_intVal(_INST(position)) + 1);
- RETURN ( _MKSMALLINT(byte) );
- }
- if (cnt < 0) {
- ExternalStream_LastErrorNumber = _MKSMALLINT(errno);
- }
- _INST(hitEOF) = true;
- RETURN ( nil );
+ _INST(lastErrorNumber) = nil;
+ if ((_INST(filePointer) != nil)
+ && (_INST(mode) != @symbol(writeonly))) {
+ f = MKFD(_INST(filePointer));
+
+ _immediateInterrupt = 1;
+ do {
+ if (_INST(buffered) == false) {
+ cnt = read(fileno(f), &byte, 1);
+ } else {
+ if ((_INST(didWrite) != false)
+ && (_INST(mode) == @symbol(readwrite))) {
+ _INST(didWrite) = false;
+ fseek(f, 0L, 1); /* needed in stdio */
+ }
+ cnt = fread(&byte, 1, 1, f);
+ }
+ } while ((cnt < 0) && (errno == EINTR));
+ _immediateInterrupt = 0;
+
+ if (cnt == 1) {
+ if (_INST(position) != nil)
+ _INST(position) = _MKSMALLINT(_intVal(_INST(position)) + 1);
+ RETURN ( _MKSMALLINT(byte) );
+ }
+ if (cnt == 0) {
+ _INST(hitEOF) = true;
+ RETURN (nil);
+ }
+ _INST(position) = nil;
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
}
-%}
-.
+%}.
+ lastErrorNumber notNil ifTrue:[^ self readError].
filePointer isNil ifTrue:[^ self errorNotOpen].
- self errorWriteOnly
+ ^ self errorWriteOnly
!
nextBytesInto:anObject
@@ -642,10 +822,13 @@
nextBytes:count into:anObject startingAt:start
"read the next count bytes into an object and return the number of
- bytes read or nil on error. On EOF, 0 is returned.
- The object must have non-pointer indexed instvars (i.e. it must be
- a ByteArray, String, Float- or DoubleArray).
- Use with care - non object oriented i/o."
+ bytes read or 0 on EOF. Notice, that in contrast to other methods
+ here, this does NOT return nil on EOF, but the actual count.
+ Thus allowing read of partial blocks.
+
+ The object must have non-pointer indexed instvars
+ (i.e. it must be a ByteArray, String, Float- or DoubleArray).
+ Use with care - non object oriented I/O."
%{ /* NOCONTEXT */
@@ -658,388 +841,256 @@
extern int _immediateInterrupt;
OBJ oClass;
- if ((_INST(filePointer) != nil) && (_INST(mode) != _writeonly)) {
- if (_isSmallInteger(count) && _isSmallInteger(start)) {
- oClass = _Class(anObject);
- switch (_intVal(_ClassInstPtr(oClass)->c_flags) & ARRAYMASK) {
- case BYTEARRAY:
- case WORDARRAY:
- case LONGARRAY:
- case FLOATARRAY:
- case DOUBLEARRAY:
- break;
- default:
- goto bad;
- }
- cnt = _intVal(count);
- offs = _intVal(start) - 1;
- f = MKFD(_INST(filePointer));
- nInstVars = _intVal(_ClassInstPtr(oClass)->c_ninstvars);
- nInstBytes = OHDR_SIZE + __OBJS2BYTES__(nInstVars);
- objSize = _Size(anObject) - nInstBytes;
- if ((offs >= 0) && (cnt >= 0) && (objSize >= (cnt + offs))) {
- cp = (char *)_InstPtr(anObject) + nInstBytes + offs;
-
- _immediateInterrupt = 1;
- do {
- if (_INST(buffered) == false) {
- cnt = read(fileno(f), cp, cnt);
- } else {
- if ((_INST(didWrite) != false) && (_INST(mode) == _readwrite)) {
- _INST(didWrite) = false;
- fseek(f, 0L, 1); /* needed in stdio */
- }
- cnt = fread(cp, 1, cnt, f);
- }
- } while ((cnt < 0) && (errno == EINTR));
- _immediateInterrupt = 0;
-
- if (cnt >= 0) {
- if (cnt == 0)
- _INST(hitEOF) = true;
- else {
- pos = _INST(position);
- if (pos != nil)
- _INST(position) = _MKSMALLINT(_intVal(pos) + cnt);
- }
- RETURN ( _MKSMALLINT(cnt) );
- }
- ExternalStream_LastErrorNumber = _MKSMALLINT(errno);
- RETURN ( nil );
- }
- }
+ _INST(lastErrorNumber) = nil;
+ if ((_INST(filePointer) != nil)
+ && (_INST(mode) != @symbol(writeonly))) {
+ if (_isSmallInteger(count) && _isSmallInteger(start)) {
+ oClass = _Class(anObject);
+ switch (_intVal(_ClassInstPtr(oClass)->c_flags) & ARRAYMASK) {
+ case BYTEARRAY:
+ case WORDARRAY:
+ case LONGARRAY:
+ case FLOATARRAY:
+ case DOUBLEARRAY:
+ break;
+ default:
+ goto bad;
+ }
+ cnt = _intVal(count);
+ offs = _intVal(start) - 1;
+ f = MKFD(_INST(filePointer));
+ nInstVars = _intVal(_ClassInstPtr(oClass)->c_ninstvars);
+ nInstBytes = OHDR_SIZE + __OBJS2BYTES__(nInstVars);
+ objSize = _Size(anObject) - nInstBytes;
+ if ((offs >= 0) && (cnt >= 0) && (objSize >= (cnt + offs))) {
+ cp = (char *)_InstPtr(anObject) + nInstBytes + offs;
+
+ _immediateInterrupt = 1;
+ do {
+ if (_INST(buffered) == false) {
+ cnt = read(fileno(f), cp, cnt);
+ } else {
+ if ((_INST(didWrite) != false)
+ && (_INST(mode) == @symbol(readwrite))) {
+ _INST(didWrite) = false;
+ fseek(f, 0L, 1); /* needed in stdio */
+ }
+ cnt = fread(cp, 1, cnt, f);
+ }
+ } while ((cnt < 0) && (errno == EINTR));
+ _immediateInterrupt = 0;
+
+ if (cnt >= 0) {
+ if (cnt == 0)
+ _INST(hitEOF) = true;
+ else {
+ pos = _INST(position);
+ if (pos != nil)
+ _INST(position) = _MKSMALLINT(_intVal(pos) + cnt);
+ }
+ RETURN (_MKSMALLINT(cnt));
+ }
+ _INST(position) = nil;
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ }
+ }
}
bad: ;
-%}
-.
+%}.
+ lastErrorNumber notNil ifTrue:[^ self readError].
filePointer isNil ifTrue:[^ self errorNotOpen].
(mode == #writeonly) ifTrue:[^ self errorWriteOnly].
- self primitiveFailed
-!
-
-nextWord
- "in text-mode:
- read the next word (i.e. up to non letter-or-digit).
- return a string containing those characters.
- in binary-mode:
- read two bytes (msb-first) and return the value as a 16-bit unsigned Integer
- (for compatibility with other smalltalks)"
-
-%{ /* NOCONTEXT */
- extern int _immediateInterrupt;
- int _buffered;
-
- _buffered = (_INST(buffered) == true);
- /*
- * binary mode
- */
- if (_INST(binary) == true) {
- if ((_INST(filePointer) != nil) && (_INST(mode) != _writeonly)) {
- FILE *f;
- unsigned char hi, low;
- int cnt;
- OBJ pos;
-
- f = MKFD(_INST(filePointer));
-
- _immediateInterrupt = 1;
-
- if (_buffered) {
- if ((_INST(didWrite) != false) && (_INST(mode) == _readwrite)) {
- _INST(didWrite) = false;
- fseek(f, 0L, 1); /* needed in stdio */
- }
- }
-
- do {
- if (! _buffered) {
- cnt = read(fileno(f), &hi, 1);
- } else {
- cnt = fread(&hi, 1, 1, f);
- }
- } while ((cnt < 0) && (errno == EINTR));
-
- if (cnt <= 0) {
- _INST(hitEOF) = true;
- if (cnt < 0)
- ExternalStream_LastErrorNumber = _MKSMALLINT(errno);
- _immediateInterrupt = 0;
- RETURN ( nil );
- }
-
- do {
- if (! _buffered) {
- cnt = read(fileno(f), &low, 1);
- } else {
- cnt = fread(&low, 1, 1, f);
- }
- } while ((cnt < 0) && (errno == EINTR));
-
- _immediateInterrupt = 0;
-
- pos = _INST(position);
- if (cnt <= 0) {
- if (pos != nil) {
- _INST(position) = _MKSMALLINT(_intVal(pos) + 1);
- }
- _INST(hitEOF) = true;
- if (cnt < 0)
- ExternalStream_LastErrorNumber = _MKSMALLINT(errno);
- RETURN ( _MKSMALLINT(hi & 0xFF) );
- }
- if (pos != nil) {
- _INST(position) = _MKSMALLINT(_intVal(pos) + 2);
- }
- RETURN ( _MKSMALLINT(((hi & 0xFF)<<8) | (low & 0xFF)) );
- }
- }
-%}
-.
-%{ /* STACK: 2000 */
- FILE *f;
- int len;
- char buffer[1024];
- int ch;
- int cnt = 0;
- extern int _immediateInterrupt;
-
- /*
- * text mode
- */
- if ((_INST(filePointer) != nil) && (_INST(mode) != _writeonly)) {
- f = MKFD(_INST(filePointer));
-
- _immediateInterrupt = 1;
-
- if ((_INST(didWrite) != false) && (_INST(mode) == _readwrite)) {
- _INST(didWrite) = false;
- fseek(f, 0L, 1); /* needed in stdio */
- }
-
- for (;;) {
- ch = getc(f);
- cnt++;
-
- if (ch >= ' ') break;
- if ((ch != ' ') && (ch != '\t') && (ch != '\r')
- && (ch != '\n') && (ch != 0x0b)) break;
- }
- ungetc(ch, f);
- cnt--;
-
- len = 0;
- for (;;) {
- ch = getc(f);
- if (ch == EOF) {
- _INST(hitEOF) = true;
- break;
- }
-
- ch &= 0xFF;
- if (! (((ch >= 'a') && (ch <= 'z')) ||
- ((ch >= 'A') && (ch <= 'Z')) ||
- ((ch >= '0') && (ch <= '9')))) {
- ungetc(ch, f);
- break;
- }
- cnt++;
- buffer[len++] = ch;
- if (len >= sizeof(buffer)-1) {
- /* emergency */
- break;
- }
- }
- _immediateInterrupt = 0;
-
- if (_INST(position) != nil) {
- _INST(position) = _MKSMALLINT(_intVal(_INST(position)) + cnt);
- }
- buffer[len] = '\0';
- if (len != 0) {
- RETURN ( _MKSTRING(buffer COMMA_CON) );
- }
- RETURN ( nil );
- }
-%}
-.
- filePointer isNil ifTrue:[^ self errorNotOpen].
- self errorWriteOnly
+ "
+ count not integer or arg not bit-like (String, ByteArray etc)
+ "
+ ^ self primitiveFailed
!
nextShortMSB:msbFlag
"Read two bytes and return the value as a 16-bit signed Integer.
- If msbFlag is true, value is read with most-significant byte first, otherwise
- least-significant byte comes first.
- A nil is also returned, if endOfFile occurs after the first byte.
+ If msbFlag is true, value is read with most-significant byte first,
+ otherwise least-significant byte comes first.
+ A nil is returned if EOF is reached (also when EOF is hit after the first byte).
Works in both binary and text modes."
%{ /* NOCONTEXT */
extern int _immediateInterrupt;
- if ((_INST(filePointer) != nil) && (_INST(mode) != _writeonly)) {
- FILE *f;
- int first, second;
- short value;
-
- f = MKFD(_INST(filePointer));
-
- _immediateInterrupt = 1;
- if ((_INST(didWrite) != false) && (_INST(mode) == _readwrite)) {
- _INST(didWrite) = false;
- fseek(f, 0L, 1); /* needed in stdio */
- }
- first = getc(f);
- if (first == EOF) {
- _immediateInterrupt = 0;
- _INST(hitEOF) = true;
- RETURN ( nil );
- }
- second = getc(f);
- _immediateInterrupt = 0;
-
- if (second == EOF) {
- _INST(hitEOF) = true;
- RETURN ( nil );
- }
- if (_INST(position) != nil) {
- _INST(position) = _MKSMALLINT(_intVal(_INST(position)) + 2);
- }
- if (msbFlag == true) {
- RETURN ( _MKSMALLINT(((first & 0xFF)<<8) | (second & 0xFF)) );
- }
- RETURN ( _MKSMALLINT(((second & 0xFF)<<8) | (first & 0xFF)) );
+ _INST(lastErrorNumber) = nil;
+ if ((_INST(filePointer) != nil)
+ && (_INST(mode) != @symbol(writeonly))) {
+ FILE *f;
+ int first, second, err;
+ short value;
+
+ f = MKFD(_INST(filePointer));
+
+ _immediateInterrupt = 1;
+ if ((_INST(didWrite) != false)
+ && (_INST(mode) == @symbol(readwrite))) {
+ _INST(didWrite) = false;
+ fseek(f, 0L, 1); /* needed in stdio */
+ }
+ first = getc(f);
+ if (first != EOF) {
+ second = getc(f);
+ _immediateInterrupt = 0;
+ if (second != EOF) {
+ if (_INST(position) != nil) {
+ _INST(position) = _MKSMALLINT(_intVal(_INST(position)) + 2);
+ }
+ if (msbFlag == true) {
+ value = ((first & 0xFF) << 8) | (second & 0xFF);
+ } else {
+ value = ((second & 0xFF) << 8) | (first & 0xFF);
+ }
+ RETURN (_MKSMALLINT(value));
+ }
+ }
+ _immediateInterrupt = 0;
+
+ if (ferror(f)) {
+ _INST(position) = nil;
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ } else {
+ _INST(hitEOF) = true;
+ RETURN (nil);
+ }
}
-%}
-.
+%}.
filePointer isNil ifTrue:[^ self errorNotOpen].
(mode == #writeonly) ifTrue:[^ self errorWriteOnly].
- self primitiveFailed
+ ^ self readError.
!
nextUnsignedShortMSB:msbFlag
"Read two bytes and return the value as a 16-bit unsigned Integer.
If msbFlag is true, value is read with most-significant byte first, otherwise
least-significant byte comes first.
- A nil is also returned, if endOfFile occurs after the first byte.
- Works in both binary and text modes."
-
-%{ /* NOCONTEXT */
- extern int _immediateInterrupt;
-
- if ((_INST(filePointer) != nil) && (_INST(mode) != _writeonly)) {
- FILE *f;
- int first, second;
-
- _immediateInterrupt = 1;
-
- f = MKFD(_INST(filePointer));
-
- if ((_INST(didWrite) != false) && (_INST(mode) == _readwrite)) {
- _INST(didWrite) = false;
- fseek(f, 0L, 1); /* needed in stdio */
- }
-
- first = getc(f);
- if (first == EOF) {
- _immediateInterrupt = 0;
- _INST(hitEOF) = true;
- RETURN ( nil );
- }
- second = getc(f);
- _immediateInterrupt = 0;
-
- if (second == EOF) {
- _INST(hitEOF) = true;
- RETURN ( nil );
- }
- if (_INST(position) != nil) {
- _INST(position) = _MKSMALLINT(_intVal(_INST(position)) + 2);
- }
- if (msbFlag == true) {
- RETURN ( _MKSMALLINT(((first & 0xFF)<<8) | (second & 0xFF)) );
- }
- RETURN ( _MKSMALLINT(((second & 0xFF)<<8) | (first & 0xFF)) );
- }
-%}
-.
- filePointer isNil ifTrue:[^ self errorNotOpen].
- (mode == #writeonly) ifTrue:[^ self errorWriteOnly].
- self primitiveFailed
-!
-
-nextLongMSB:msbFlag
- "Read four bytes and return the value as a 32-bit signed Integer, which may be
- a LargeInteger.
- If msbFlag is true, value is read with most-significant byte first, otherwise
- least-significant byte comes first.
- A nil is returned, if endOfFile occurs before all 4 bytes have been read.
+ A nil is returned if EOF is reached (also when EOF is hit after the first byte).
Works in both binary and text modes."
%{ /* NOCONTEXT */
extern int _immediateInterrupt;
- if ((_INST(filePointer) != nil) && (_INST(mode) != _writeonly)) {
- FILE *f;
- int first, second, third, fourth;
- int value;
-
- _immediateInterrupt = 1;
- f = MKFD(_INST(filePointer));
-
- if ((_INST(didWrite) != false) && (_INST(mode) == _readwrite)) {
- _INST(didWrite) = false;
- fseek(f, 0L, 1); /* needed in stdio */
- }
-
- first = getc(f);
- if (first == EOF) {
- _INST(hitEOF) = true;
- _immediateInterrupt = 0;
- RETURN ( nil );
- }
- second = getc(f);
- if (second == EOF) {
- _INST(hitEOF) = true;
- _immediateInterrupt = 0;
- RETURN ( nil );
- }
- third = getc(f);
- if (third == EOF) {
- _INST(hitEOF) = true;
- _immediateInterrupt = 0;
- RETURN ( nil );
- }
- fourth = getc(f);
- _immediateInterrupt = 0;
-
- if (fourth == EOF) {
- _INST(hitEOF) = true;
- RETURN ( nil );
- }
- if (_INST(position) != nil) {
- _INST(position) = _MKSMALLINT(_intVal(_INST(position)) + 4);
- }
- if (msbFlag == true) {
- value = ((first & 0xFF) << 24)
- | ((second & 0xFF) << 16)
- | ((third & 0xFF) << 8)
- | (fourth & 0xFF);
- } else {
- value = ((fourth & 0xFF) << 24)
- | ((third & 0xFF) << 16)
- | ((second & 0xFF) << 8)
- | (first & 0xFF);
- }
- if ((value >= _MIN_INT) && (value <= _MAX_INT)) {
- RETURN ( _MKSMALLINT(value));
- }
- RETURN ( _makeLarge(value) );
+ _INST(lastErrorNumber) = nil;
+ if ((_INST(filePointer) != nil)
+ && (_INST(mode) != @symbol(writeonly))) {
+ FILE *f;
+ int first, second;
+ unsigned value;
+ _immediateInterrupt = 1;
+
+ f = MKFD(_INST(filePointer));
+
+ if ((_INST(didWrite) != false)
+ && (_INST(mode) == @symbol(readwrite))) {
+ _INST(didWrite) = false;
+ fseek(f, 0L, 1); /* needed in stdio */
+ }
+
+ first = getc(f);
+ if (first != EOF) {
+ second = getc(f);
+ _immediateInterrupt = 0;
+ if (second != EOF) {
+ if (_INST(position) != nil) {
+ _INST(position) = _MKSMALLINT(_intVal(_INST(position)) + 2);
+ }
+ if (msbFlag == true) {
+ value = ((first & 0xFF) << 8) | (second & 0xFF);
+ } else {
+ value = ((second & 0xFF) << 8) | (first & 0xFF);
+ }
+ RETURN (_MKSMALLINT(value));
+ }
+ }
+ _immediateInterrupt = 0;
+
+ if (ferror(f)) {
+ _INST(position) = nil;
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ } else {
+ _INST(hitEOF) = true;
+ RETURN (nil);
+ }
}
-%}
-.
+%}.
filePointer isNil ifTrue:[^ self errorNotOpen].
(mode == #writeonly) ifTrue:[^ self errorWriteOnly].
- self primitiveFailed
+ ^ self readError.
+!
+
+nextLongMSB:msbFlag
+ "Read four bytes and return the value as a 32-bit signed Integer,
+ which may be a LargeInteger.
+ If msbFlag is true, value is read with most-significant byte first,
+ otherwise least-significant byte comes first.
+ A nil is returned, if EOF is hit before all 4 bytes have been read.
+ Works in both binary and text modes."
+
+%{ /* NOCONTEXT */
+ extern int _immediateInterrupt;
+
+ _INST(lastErrorNumber) = nil;
+ if ((_INST(filePointer) != nil)
+ && (_INST(mode) != @symbol(writeonly))) {
+ FILE *f;
+ int first, second, third, fourth;
+ int value;
+
+ _immediateInterrupt = 1;
+ f = MKFD(_INST(filePointer));
+
+ if ((_INST(didWrite) != false)
+ && (_INST(mode) == @symbol(readwrite))) {
+ _INST(didWrite) = false;
+ fseek(f, 0L, 1); /* needed in stdio */
+ }
+
+ first = getc(f);
+ if (first != EOF) {
+ second = getc(f);
+ if (second != EOF) {
+ third = getc(f);
+ if (third != EOF) {
+ fourth = getc(f);
+ if (fourth != EOF) {
+ _immediateInterrupt = 0;
+ if (msbFlag == true) {
+ value = (first & 0xFF);
+ value = (value<<8) | (second & 0xFF);
+ value = (value<<8) | (third & 0xFF);
+ value = (value<<8) | (fourth & 0xFF);
+ } else {
+ value = (fourth & 0xFF);
+ value = (value<<8) | (third & 0xFF);
+ value = (value<<8) | (second & 0xFF);
+ value = (value<<8) | (first & 0xFF);
+ }
+ if (_INST(position) != nil) {
+ _INST(position) = _MKSMALLINT(_intVal(_INST(position)) + 4);
+ }
+ if ((value >= _MIN_INT) && (value <= _MAX_INT)) {
+ RETURN ( _MKSMALLINT(value));
+ }
+ RETURN ( _makeLarge(value) );
+ }
+ }
+ }
+ }
+ if (ferror(f)) {
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ _INST(position) = nil;
+ } else {
+ _INST(hitEOF) = true;
+ RETURN (nil);
+ }
+ }
+%}.
+ filePointer isNil ifTrue:[^ self errorNotOpen].
+ (mode == #writeonly) ifTrue:[^ self errorWriteOnly].
+ ^ self readError.
!
nextUnsignedLongMSB:msbFlag
@@ -1054,67 +1105,79 @@
extern int _immediateInterrupt;
extern OBJ _makeULarge();
- if ((_INST(filePointer) != nil) && (_INST(mode) != _writeonly)) {
- FILE *f;
- int first, second, third, fourth;
- unsigned int value;
-
- _immediateInterrupt = 1;
- f = MKFD(_INST(filePointer));
-
- if ((_INST(didWrite) != false) && (_INST(mode) == _readwrite)) {
- _INST(didWrite) = false;
- fseek(f, 0L, 1); /* needed in stdio */
- }
-
- first = getc(f);
- if (first == EOF) {
- _INST(hitEOF) = true;
- _immediateInterrupt = 0;
- RETURN ( nil );
- }
- second = getc(f);
- if (second == EOF) {
- _INST(hitEOF) = true;
- _immediateInterrupt = 0;
- RETURN ( nil );
- }
- third = getc(f);
- if (third == EOF) {
- _INST(hitEOF) = true;
- _immediateInterrupt = 0;
- RETURN ( nil );
- }
- fourth = getc(f);
- _immediateInterrupt = 0;
- if (fourth == EOF) {
- _INST(hitEOF) = true;
- RETURN ( nil );
- }
- if (_INST(position) != nil) {
- _INST(position) = _MKSMALLINT(_intVal(_INST(position)) + 4);
- }
- if (msbFlag == true) {
- value = ((first & 0xFF) << 24)
- | ((second & 0xFF) << 16)
- | ((third & 0xFF) << 8)
- | (fourth & 0xFF);
- } else {
- value = ((fourth & 0xFF) << 24)
- | ((third & 0xFF) << 16)
- | ((second & 0xFF) << 8)
- | (first & 0xFF);
- }
- if (value <= _MAX_INT) {
- RETURN ( _MKSMALLINT(value));
- }
- RETURN ( _makeULarge(value) );
+ _INST(lastErrorNumber) = nil;
+ if ((_INST(filePointer) != nil)
+ && (_INST(mode) != @symbol(writeonly))) {
+ FILE *f;
+ int first, second, third, fourth;
+ unsigned int value;
+
+ _immediateInterrupt = 1;
+ f = MKFD(_INST(filePointer));
+
+ if ((_INST(didWrite) != false)
+ && (_INST(mode) == @symbol(readwrite))) {
+ _INST(didWrite) = false;
+ fseek(f, 0L, 1); /* needed in stdio */
+ }
+
+ first = getc(f);
+ if (first != EOF) {
+ second = getc(f);
+ if (second != EOF) {
+ third = getc(f);
+ if (third != EOF) {
+ fourth = getc(f);
+ if (fourth != EOF) {
+ _immediateInterrupt = 0;
+ if (msbFlag == true) {
+ value = (first & 0xFF);
+ value = (value<<8) | (second & 0xFF);
+ value = (value<<8) | (third & 0xFF);
+ value = (value<<8) | (fourth & 0xFF);
+ } else {
+ value = (fourth & 0xFF);
+ value = (value<<8) | (third & 0xFF);
+ value = (value<<8) | (second & 0xFF);
+ value = (value<<8) | (first & 0xFF);
+ }
+ if (_INST(position) != nil) {
+ _INST(position) = _MKSMALLINT(_intVal(_INST(position)) + 4);
+ }
+ if (value <= _MAX_INT) {
+ RETURN ( _MKSMALLINT(value));
+ }
+ RETURN ( _makeULarge(value) );
+ }
+ }
+ }
+ }
+ if (ferror(f)) {
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ _INST(position) = nil;
+ } else {
+ _INST(hitEOF) = true;
+ RETURN (nil);
+ }
}
-%}
-.
+%}.
filePointer isNil ifTrue:[^ self errorNotOpen].
(mode == #writeonly) ifTrue:[^ self errorWriteOnly].
- self primitiveFailed
+ ^ self readError.
+!
+
+nextWord
+ "in text-mode:
+ read the alphaNumeric next word (i.e. up to non letter-or-digit).
+ return a string containing those characters.
+ in binary-mode:
+ read two bytes (msb-first) and return the value as a 16-bit unsigned Integer
+ (for compatibility with other smalltalks)"
+
+ binary ifTrue:[
+ ^ self nextShortMSB:true
+ ].
+ ^ self nextAlphaNumericWord
!
nextLong
@@ -1140,44 +1203,47 @@
int cnt;
extern int _immediateInterrupt;
- if ((_INST(filePointer) != nil) && (_INST(mode) != _readonly)) {
- if (_isSmallInteger(aByteValue)) {
- c = _intVal(aByteValue);
- f = MKFD(_INST(filePointer));
- _immediateInterrupt = 1;
+ _INST(lastErrorNumber) = nil;
+ if ((_INST(filePointer) != nil)
+ && (_INST(mode) != @symbol(readonly))) {
+ if (_isSmallInteger(aByteValue)) {
+ c = _intVal(aByteValue);
+ f = MKFD(_INST(filePointer));
+ _immediateInterrupt = 1;
#ifdef OLD
- if (_INST(buffered) == false) {
- cnt = write(fileno(f), &c, 1);
- } else
+ if (_INST(buffered) == false) {
+ cnt = write(fileno(f), &c, 1);
+ } else
#endif
- {
- if ((_INST(didWrite) != true) && (_INST(mode) == _readwrite)) {
- _INST(didWrite) = true;
- fseek(f, 0L, 1); /* needed in stdio */
- }
- cnt = fwrite(&c, 1, 1, f);
+ {
+ if ((_INST(didWrite) != true)
+ && (_INST(mode) == @symbol(readwrite))) {
+ _INST(didWrite) = true;
+ fseek(f, 0L, 1); /* needed in stdio */
+ }
+ cnt = fwrite(&c, 1, 1, f);
#ifndef OLD
- if (_INST(buffered) == false) {
- fflush(f);
- }
+ if (_INST(buffered) == false) {
+ fflush(f);
+ }
#endif
- }
- _immediateInterrupt = 0;
- if (cnt == 1) {
- pos = _INST(position);
- if (pos != nil)
- _INST(position) = _MKSMALLINT(_intVal(pos) + 1);
- RETURN ( self );
- }
- ExternalStream_LastErrorNumber = _MKSMALLINT(errno);
- RETURN (nil);
- }
+ }
+ _immediateInterrupt = 0;
+ if (cnt == 1) {
+ pos = _INST(position);
+ if (pos != nil)
+ _INST(position) = _MKSMALLINT(_intVal(pos) + 1);
+ RETURN (self);
+ }
+ if (cnt < 0) {
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ }
+ }
}
-%}
-.
+%}.
filePointer isNil ifTrue:[^ self errorNotOpen].
(mode == #readonly) ifTrue:[^ self errorReadOnly].
- self primitiveFailed
+ ^ self writeError.
!
nextPutBytesFrom:anObject
@@ -1203,7 +1269,7 @@
nextPutBytes:count from:anObject startingAt:start
"write count bytes from an object starting at index start.
- return the number of bytes written or nil on error.
+ return the number of bytes written - which could be 0.
The object must have non-pointer indexed instvars
(i.e. be a ByteArray, String, Float- or DoubleArray).
Use with care - non object oriented i/o"
@@ -1219,70 +1285,72 @@
OBJ pos;
extern int _immediateInterrupt;
- if ((_INST(filePointer) != nil) && (_INST(mode) != _readonly)) {
- if (_isSmallInteger(count) && _isSmallInteger(start)) {
- oClass = _Class(anObject);
- switch (_intVal(_ClassInstPtr(oClass)->c_flags) & ARRAYMASK) {
- case BYTEARRAY:
- case WORDARRAY:
- case LONGARRAY:
- case FLOATARRAY:
- case DOUBLEARRAY:
- break;
- default:
- goto bad;
- }
- cnt = _intVal(count);
- offs = _intVal(start) - 1;
- f = MKFD(_INST(filePointer));
-
- nInstVars = _intVal(_ClassInstPtr(oClass)->c_ninstvars);
- nInstBytes = OHDR_SIZE + __OBJS2BYTES__(nInstVars);
- objSize = _Size(anObject) - nInstBytes;
- if ( (offs >= 0) && (cnt >= 0) && (objSize >= (cnt + offs)) ) {
- cp = (char *)_InstPtr(anObject) + nInstBytes + offs;
- _immediateInterrupt = 1;
+ _INST(lastErrorNumber) = nil;
+ if ((_INST(filePointer) != nil)
+ && (_INST(mode) != @symbol(readonly))) {
+ if (_isSmallInteger(count) && _isSmallInteger(start)) {
+ oClass = _Class(anObject);
+ switch (_intVal(_ClassInstPtr(oClass)->c_flags) & ARRAYMASK) {
+ case BYTEARRAY:
+ case WORDARRAY:
+ case LONGARRAY:
+ case FLOATARRAY:
+ case DOUBLEARRAY:
+ break;
+ default:
+ goto bad;
+ }
+ cnt = _intVal(count);
+ offs = _intVal(start) - 1;
+ f = MKFD(_INST(filePointer));
+
+ nInstVars = _intVal(_ClassInstPtr(oClass)->c_ninstvars);
+ nInstBytes = OHDR_SIZE + __OBJS2BYTES__(nInstVars);
+ objSize = _Size(anObject) - nInstBytes;
+ if ( (offs >= 0) && (cnt >= 0) && (objSize >= (cnt + offs)) ) {
+ cp = (char *)_InstPtr(anObject) + nInstBytes + offs;
+ _immediateInterrupt = 1;
#ifdef OLD
- if (_INST(buffered) == false) {
- cnt = write(fileno(f), cp, cnt);
- } else
+ if (_INST(buffered) == false) {
+ cnt = write(fileno(f), cp, cnt);
+ } else
#endif
- {
- if ((_INST(didWrite) != true) && (_INST(mode) == _readwrite)) {
- _INST(didWrite) = true;
- fseek(f, 0L, 1); /* needed in stdio */
- }
- cnt = fwrite(cp, 1, cnt, f);
- }
+ {
+ if ((_INST(didWrite) != true)
+ && (_INST(mode) == @symbol(readwrite))) {
+ _INST(didWrite) = true;
+ fseek(f, 0L, 1); /* needed in stdio */
+ }
+ cnt = fwrite(cp, 1, cnt, f);
+ }
#ifndef OLD
- if (_INST(buffered) == false) {
- fflush(f);
- }
+ if (_INST(buffered) == false) {
+ fflush(f);
+ }
#endif
- _immediateInterrupt = 0;
- if (cnt >= 0) {
- pos = _INST(position);
- if (pos != nil)
- _INST(position) = _MKSMALLINT(_intVal(pos) + cnt);
- RETURN ( _MKSMALLINT(cnt) );
- }
- ExternalStream_LastErrorNumber = _MKSMALLINT(errno);
- RETURN ( nil );
- }
- }
+ _immediateInterrupt = 0;
+ if (cnt >= 0) {
+ pos = _INST(position);
+ if (pos != nil)
+ _INST(position) = _MKSMALLINT(_intVal(pos) + cnt);
+ RETURN ( _MKSMALLINT(cnt) );
+ }
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ }
+ }
}
bad: ;
-%}
-.
+%}.
+ lastErrorNumber notNil ifTrue:[^ self writeError].
filePointer isNil ifTrue:[^ self errorNotOpen].
(mode == #readonly) ifTrue:[^ self errorReadOnly].
- self primitiveFailed
+ ^ self primitiveFailed
!
nextPutShort:aNumber MSB:msbFlag
"Write the argument, aNumber as a short (two bytes). If msbFlag is
true, data is written most-significant byte first; otherwise least
- first. Returns the receiver on ok, nil on error.
+ first.
Works in both binary and text modes."
%{ /* NOCONTEXT */
@@ -1294,49 +1362,50 @@
extern int _immediateInterrupt;
int cnt;
- if ((_INST(filePointer) != nil) && (_INST(mode) != _readonly)) {
- if (_isSmallInteger(aNumber)) {
- num = _intVal(aNumber);
- if (msbFlag == true) {
- bytes[0] = (num >> 8) & 0xFF;
- bytes[1] = num & 0xFF;
- } else {
- bytes[1] = (num >> 8) & 0xFF;
- bytes[0] = num & 0xFF;
- }
-
- f = MKFD(_INST(filePointer));
- _immediateInterrupt = 1;
+ _INST(lastErrorNumber) = nil;
+ if ((_INST(filePointer) != nil)
+ && (_INST(mode) != @symbol(readonly))
+ && _isSmallInteger(aNumber)) {
+ num = _intVal(aNumber);
+ if (msbFlag == true) {
+ bytes[0] = (num >> 8) & 0xFF;
+ bytes[1] = num & 0xFF;
+ } else {
+ bytes[1] = (num >> 8) & 0xFF;
+ bytes[0] = num & 0xFF;
+ }
+
+ f = MKFD(_INST(filePointer));
+ _immediateInterrupt = 1;
#ifdef OLD
- if (_INST(buffered) == false) {
- cnt = write(fileno(f), bytes, 2);
- } else
+ if (_INST(buffered) == false) {
+ cnt = write(fileno(f), bytes, 2);
+ } else
#endif
- {
- if ((_INST(didWrite) != true) && (_INST(mode) == _readwrite)) {
- _INST(didWrite) = true;
- fseek(f, 0L, 1); /* needed in stdio */
- }
- cnt = fwrite(bytes, 1, 2, f);
- }
+ {
+ if ((_INST(didWrite) != true)
+ && (_INST(mode) == @symbol(readwrite))) {
+ _INST(didWrite) = true;
+ fseek(f, 0L, 1); /* needed in stdio */
+ }
+ cnt = fwrite(bytes, 1, 2, f);
+ }
#ifndef OLD
- if (_INST(buffered) == false) {
- fflush(f);
- }
+ if (_INST(buffered) == false) {
+ fflush(f);
+ }
#endif
- _immediateInterrupt = 0;
- if (cnt == 2) {
- if (_INST(position) != nil) {
- _INST(position) = _MKSMALLINT(_intVal(_INST(position)) + 2);
- }
- RETURN ( self );
- }
- ExternalStream_LastErrorNumber = _MKSMALLINT(errno);
- return ( nil );
- }
+ _immediateInterrupt = 0;
+ if (cnt == 2) {
+ if (_INST(position) != nil) {
+ _INST(position) = _MKSMALLINT(_intVal(_INST(position)) + 2);
+ }
+ RETURN ( self );
+ }
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
}
-%}
-.
+%}.
+ lastErrorNumber notNil ifTrue:[^ self writeError].
filePointer isNil ifTrue:[^ self errorNotOpen].
(mode == #readonly) ifTrue:[^ self errorReadOnly].
self argumentMustBeInteger
@@ -1345,7 +1414,7 @@
nextPutLong:aNumber MSB:msbFlag
"Write the argument, aNumber as a long (four bytes). If msbFlag is
true, data is written most-significant byte first; otherwise least
- first. Returns the receiver on ok, nil on error.
+ first.
Works in both binary and text modes."
%{ /* NOCONTEXT */
@@ -1357,61 +1426,66 @@
int cnt;
extern int _immediateInterrupt;
- if ((_INST(filePointer) != nil) && (_INST(mode) != _readonly)) {
- if (_isSmallInteger(aNumber)) {
- num = _intVal(aNumber);
- if (msbFlag == true) {
- bytes[0] = (num >> 24) & 0xFF;
- bytes[1] = (num >> 16) & 0xFF;
- bytes[2] = (num >> 8) & 0xFF;
- bytes[3] = num & 0xFF;
- } else {
- bytes[3] = (num >> 24) & 0xFF;
- bytes[2] = (num >> 16) & 0xFF;
- bytes[1] = (num >> 8) & 0xFF;
- bytes[0] = num & 0xFF;
- }
-
- f = MKFD(_INST(filePointer));
- _immediateInterrupt = 1;
+ _INST(lastErrorNumber) = nil;
+ if ((_INST(filePointer) != nil)
+ && (_INST(mode) != @symbol(readonly))
+ && _isSmallInteger(aNumber)) {
+ num = _intVal(aNumber);
+ if (msbFlag == true) {
+ bytes[0] = (num >> 24) & 0xFF;
+ bytes[1] = (num >> 16) & 0xFF;
+ bytes[2] = (num >> 8) & 0xFF;
+ bytes[3] = num & 0xFF;
+ } else {
+ bytes[3] = (num >> 24) & 0xFF;
+ bytes[2] = (num >> 16) & 0xFF;
+ bytes[1] = (num >> 8) & 0xFF;
+ bytes[0] = num & 0xFF;
+ }
+
+ f = MKFD(_INST(filePointer));
+ _immediateInterrupt = 1;
#ifdef OLD
- if (_INST(buffered) == false) {
- cnt = write(fileno(f), bytes, 4);
- } else
+ if (_INST(buffered) == false) {
+ cnt = write(fileno(f), bytes, 4);
+ } else
#endif
- {
- cnt = fwrite(bytes, 1, 4, f);
- }
+ {
+ if ((_INST(didWrite) != true)
+ && (_INST(mode) == @symbol(readwrite))) {
+ _INST(didWrite) = true;
+ fseek(f, 0L, 1); /* needed in stdio */
+ }
+ cnt = fwrite(bytes, 1, 4, f);
+ }
#ifndef OLD
- if (_INST(buffered) == false) {
- fflush(f);
- }
+ if (_INST(buffered) == false) {
+ fflush(f);
+ }
#endif
- _immediateInterrupt = 0;
- if (cnt == 4) {
- if (_INST(position) != nil) {
- _INST(position) = _MKSMALLINT(_intVal(_INST(position)) + 4);
- }
- RETURN ( self );
- }
- ExternalStream_LastErrorNumber = _MKSMALLINT(errno);
- return ( nil );
- }
+ _immediateInterrupt = 0;
+ if (cnt == 4) {
+ if (_INST(position) != nil) {
+ _INST(position) = _MKSMALLINT(_intVal(_INST(position)) + 4);
+ }
+ RETURN ( self );
+ }
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
}
-%}
-.
+%}.
filePointer isNil ifTrue:[^ self errorNotOpen].
(mode == #readonly) ifTrue:[^ self errorReadOnly].
+ lastErrorNumber notNil ifTrue:[^ self writeError].
aNumber isInteger ifTrue:[
- msbFlag ifTrue:[
- "high word first"
- (self nextShortPut:(aNumber // 16r10000) MSB:true) isNil ifTrue:[^ nil].
- ^ self nextShortPut:(aNumber \\ 16r10000) MSB:true
- ].
- "low word first"
- (self nextShortPut:(aNumber \\ 16r10000) MSB:false) isNil ifTrue:[^ nil].
- ^ self nextShortPut:(aNumber // 16r10000) MSB:false.
+ msbFlag ifTrue:[
+ "high word first"
+ (self nextShortPut:(aNumber // 16r10000) MSB:true) isNil ifTrue:[^ nil].
+ ^ self nextShortPut:(aNumber \\ 16r10000) MSB:true
+ ].
+ "low word first"
+ (self nextShortPut:(aNumber \\ 16r10000) MSB:false) isNil ifTrue:[^ nil].
+ ^ self nextShortPut:(aNumber // 16r10000) MSB:false.
].
self argumentMustBeInteger
! !
@@ -1430,40 +1504,45 @@
REGISTER int c;
extern int _immediateInterrupt;
- if (_INST(filePointer) != nil) {
- if (_INST(mode) != _writeonly) {
+ _INST(lastErrorNumber) = nil;
+ if ((_INST(filePointer) != nil)
+ && (_INST(mode) != @symbol(writeonly))) {
#ifdef OLD
- if (_INST(buffered) == true)
+ if (_INST(buffered) == true)
#endif
- {
- f = MKFD(_INST(filePointer));
-
- if ((_INST(didWrite) != false) && (_INST(mode) == _readwrite)) {
- _INST(didWrite) = false;
- fseek(f, 0L, 1); /* needed in stdio */
- }
-
- _immediateInterrupt = 1;
- c = getc(f);
- _immediateInterrupt = 0;
-
- if (c != EOF) {
- ungetc(c, f);
- if (_INST(binary) == true) {
- RETURN ( _MKSMALLINT(c & 0xFF) );
- }
- RETURN ( _MKCHARACTER(c & 0xFF) );
- }
- _INST(hitEOF) = true;
- RETURN ( nil );
- }
- }
+ {
+ f = MKFD(_INST(filePointer));
+
+ if ((_INST(didWrite) != false)
+ && (_INST(mode) == @symbol(readwrite))) {
+ _INST(didWrite) = false;
+ fseek(f, 0L, 1); /* needed in stdio */
+ }
+
+ _immediateInterrupt = 1;
+ c = getc(f);
+ _immediateInterrupt = 0;
+
+ if (c != EOF) {
+ ungetc(c, f);
+ if (_INST(binary) == true) {
+ RETURN ( _MKSMALLINT(c & 0xFF) );
+ }
+ RETURN ( _MKCHARACTER(c & 0xFF) );
+ }
+ if (ferror(f)) {
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ } else {
+ _INST(hitEOF) = true;
+ RETURN ( nil );
+ }
+ }
}
-%}
-.
+%}.
+ lastErrorNumber notNil ifTrue:[^ self readError].
filePointer isNil ifTrue:[^ self errorNotOpen].
buffered ifFalse:[^ self errorNotBuffered].
- self errorWriteOnly
+ ^ self errorWriteOnly
!
next
@@ -1480,48 +1559,54 @@
extern int _immediateInterrupt;
- if (_INST(filePointer) != nil) {
- if (_INST(mode) != _writeonly) {
- f = MKFD(_INST(filePointer));
- _immediateInterrupt = 1;
- do {
+ _INST(lastErrorNumber) = nil;
+ if ((_INST(filePointer) != nil)
+ && (_INST(mode) != @symbol(writeonly))) {
+ f = MKFD(_INST(filePointer));
+ _immediateInterrupt = 1;
+ do {
#ifdef OLD
- if (_INST(buffered) == false) {
- if (read(fileno(f), &ch, 1) != 1)
- c = EOF;
- else
- c = ch;
- } else
+ if (_INST(buffered) == false) {
+ if (read(fileno(f), &ch, 1) != 1)
+ c = EOF;
+ else
+ c = ch;
+ } else
#endif
- {
- if ((_INST(didWrite) != false) && (_INST(mode) == _readwrite)) {
- _INST(didWrite) = false;
- fseek(f, 0L, 1); /* needed in stdio */
- }
- c = getc(f);
- }
- } while ((c < 0) && (errno == EINTR));
-
- _immediateInterrupt = 0;
- if (c != EOF) {
- pos = _INST(position);
- if (_isSmallInteger(pos)) {
- _INST(position) = _MKSMALLINT(_intVal(pos) + 1);
- } else {
- _INST(position) = nil;
- }
- if (_INST(binary) == true) {
- RETURN ( _MKSMALLINT(c & 0xFF) );
- }
- RETURN ( _MKCHARACTER(c & 0xFF) );
- }
- _INST(hitEOF) = true;
- _INST(position) = nil;
- RETURN ( nil );
- }
+ {
+ if ((_INST(didWrite) != false)
+ && (_INST(mode) == @symbol(readwrite))) {
+ _INST(didWrite) = false;
+ fseek(f, 0L, 1); /* needed in stdio */
+ }
+ c = getc(f);
+ }
+ } while ((c < 0) && (errno == EINTR));
+
+ _immediateInterrupt = 0;
+
+ if (c != EOF) {
+ pos = _INST(position);
+ if (_isSmallInteger(pos)) {
+ _INST(position) = _MKSMALLINT(_intVal(pos) + 1);
+ } else {
+ _INST(position) = nil;
+ }
+ if (_INST(binary) == true) {
+ RETURN ( _MKSMALLINT(c & 0xFF) );
+ }
+ RETURN ( _MKCHARACTER(c & 0xFF) );
+ }
+ _INST(position) = nil;
+ if (ferror(f)) {
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ } else {
+ _INST(hitEOF) = true;
+ RETURN ( nil );
+ }
}
-%}
-.
+%}.
+ lastErrorNumber notNil ifTrue:[^ self readError].
filePointer isNil ifTrue:[^ self errorNotOpen].
self errorWriteOnly
!
@@ -1533,12 +1618,12 @@
|coll|
binary ifTrue:[
- coll := ByteArray new:count
+ coll := ByteArray new:count
] ifFalse:[
- coll := String new:count
+ coll := String new:count
].
1 to:count do: [:index |
- coll at:index put:(self next)
+ coll at:index put:(self next)
].
^ coll
! !
@@ -1550,12 +1635,13 @@
%{ /* NOCONTEXT */
+ _INST(lastErrorNumber) = nil;
if (_INST(filePointer) != nil) {
- if (_INST(mode) != _readonly) {
- if (_INST(buffered) == true) {
- fflush( MKFD(_INST(filePointer)) );
- }
- }
+ if (_INST(mode) != @symbol(readonly)) {
+ if (_INST(buffered) == true) {
+ fflush( MKFD(_INST(filePointer)) );
+ }
+ }
}
%}
!
@@ -1572,53 +1658,50 @@
OBJ pos;
extern int _immediateInterrupt;
- if (_INST(filePointer) != nil) {
- if (_INST(mode) != _readonly) {
- if (_INST(binary) != true) {
- if (__isCharacter(aCharacter)) {
- c = _intVal(_CharacterInstPtr(aCharacter)->c_asciivalue);
+ _INST(lastErrorNumber) = nil;
+ if ((_INST(filePointer) != nil)
+ && (_INST(mode) != @symbol(readonly))) {
+ if (_INST(binary) != true) {
+ if (__isCharacter(aCharacter)) {
+ c = _intVal(_CharacterInstPtr(aCharacter)->c_asciivalue);
doWrite:
- f = MKFD(_INST(filePointer));
-
- _immediateInterrupt = 1;
-#ifdef OLD
- if (_INST(buffered) == false) {
- cnt = write(fileno(f), &c, 1);
- } else
-#endif
- {
- if ((_INST(didWrite) != true) && (_INST(mode) == _readwrite)) {
- _INST(didWrite) = true;
- fseek(f, 0L, 1); /* needed in stdio */
- }
- cnt = fwrite(&c, 1, 1, f);
- }
-#ifndef OLD
- if (_INST(buffered) == false) {
- fflush(f);
- }
-#endif
- _immediateInterrupt = 0;
- if (cnt == 1) {
- pos = _INST(position);
- if (pos != nil) {
- _INST(position) = _MKSMALLINT(_intVal(pos) + 1);
- }
- RETURN ( self );
- }
- ExternalStream_LastErrorNumber = _MKSMALLINT(errno);
- RETURN ( nil );
- }
- } else {
- if (_isSmallInteger(aCharacter)) {
- c = _intVal(aCharacter);
- goto doWrite;
- }
- }
- }
+ f = MKFD(_INST(filePointer));
+
+ _immediateInterrupt = 1;
+
+ if ((_INST(didWrite) != true)
+ && (_INST(mode) == @symbol(readwrite))) {
+ _INST(didWrite) = true;
+ fseek(f, 0L, 1); /* needed in stdio */
+ }
+
+ do {
+ cnt = fwrite(&c, 1, 1, f);
+ } while ((cnt != 1) && (errno == EINTR));
+
+ if (_INST(buffered) == false) {
+ fflush(f);
+ }
+
+ _immediateInterrupt = 0;
+ if (cnt == 1) {
+ pos = _INST(position);
+ if (pos != nil) {
+ _INST(position) = _MKSMALLINT(_intVal(pos) + 1);
+ }
+ RETURN ( self );
+ }
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ }
+ } else {
+ if (_isSmallInteger(aCharacter)) {
+ c = _intVal(aCharacter);
+ goto doWrite;
+ }
+ }
}
-%}
-.
+%}.
+ lastErrorNumber notNil ifTrue:[^ self writeError].
filePointer isNil ifTrue:[^ self errorNotOpen].
(mode == #readonly) ifTrue:[^ self errorReadOnly].
binary ifFalse:[^ self argumentMustBeCharacter].
@@ -1639,64 +1722,76 @@
OBJ pos;
extern int _immediateInterrupt;
- if ((_INST(filePointer) != nil) && (_INST(mode) != _readonly)) {
- cp = NULL;
- if (__isString(aCollection) || __isSymbol(aCollection)) {
- cp = _stringVal(aCollection);
- len = _stringSize(aCollection);
- } else {
- if (_INST(binary) == true) {
- if (__isByteArray(aCollection)) {
- cp = _ByteArrayInstPtr(aCollection)->ba_element;
- len = _byteArraySize(aCollection);
- } else {
- if (__isBytes(aCollection)) {
- int nInst;
-
- cp = _ByteArrayInstPtr(aCollection)->ba_element;
- len = _byteArraySize(aCollection);
- nInst = _intVal(_ClassInstPtr(_qClass(aCollection))->c_ninstvars);
- cp += __OBJS2BYTES__(nInst);
- len -= __OBJS2BYTES__(nInst);
- }
- }
- }
- }
- if (cp != NULL) {
- f = MKFD(_INST(filePointer));
-
- _immediateInterrupt = 1;
+ _INST(lastErrorNumber) = nil;
+ if ((_INST(filePointer) != nil)
+ && (_INST(mode) != @symbol(readonly))) {
+ cp = NULL;
+ if (__isString(aCollection) || __isSymbol(aCollection)) {
+ cp = _stringVal(aCollection);
+ len = _stringSize(aCollection);
+ } else {
+ if (_INST(binary) == true) {
+ if (__isByteArray(aCollection)) {
+ cp = _ByteArrayInstPtr(aCollection)->ba_element;
+ len = _byteArraySize(aCollection);
+ } else {
+ if (__isBytes(aCollection)) {
+ int nInst;
+
+ cp = _ByteArrayInstPtr(aCollection)->ba_element;
+ len = _byteArraySize(aCollection);
+ nInst = _intVal(_ClassInstPtr(_qClass(aCollection))->c_ninstvars);
+ cp += __OBJS2BYTES__(nInst);
+ len -= __OBJS2BYTES__(nInst);
+ }
+ }
+ }
+ }
+ if (cp != NULL) {
+ f = MKFD(_INST(filePointer));
+
+ _immediateInterrupt = 1;
#ifdef OLD
- if (_INST(buffered) == false) {
- cnt = write(fileno(f), cp, len);
- } else
+ if (_INST(buffered) == false) {
+ cnt = write(fileno(f), cp, len);
+ } else
#endif
- {
- if ((_INST(didWrite) != true) && (_INST(mode) == _readwrite)) {
- _INST(didWrite) = true;
- fseek(f, 0L, 1); /* needed in stdio */
- }
- cnt = fwrite(cp, 1, len, f);
- }
+ {
+ if ((_INST(didWrite) != true)
+ && (_INST(mode) == @symbol(readwrite))) {
+ _INST(didWrite) = true;
+ fseek(f, 0L, 1); /* needed in stdio */
+ }
+ do {
+ cnt = fwrite(cp, 1, len, f);
+ if (cnt != len) {
+ if (cnt >= 0) {
+ if (errno == EINTR) {
+ cp += cnt;
+ len -= cnt;
+ }
+ }
+ }
+ } while ((cnt != len) && (errno == EINTR));
+ }
#ifndef OLD
- if (_INST(buffered) == false) {
- fflush(f);
- }
+ if (_INST(buffered) == false) {
+ fflush(f);
+ }
#endif
- _immediateInterrupt = 0;
- if (cnt == len) {
- pos = _INST(position);
- if (pos != nil) {
- _INST(position) = _MKSMALLINT(_intVal(pos) + len);
- }
- RETURN ( self );
- }
- ExternalStream_LastErrorNumber = _MKSMALLINT(errno);
- RETURN ( nil );
- }
+ _immediateInterrupt = 0;
+ if (cnt == len) {
+ pos = _INST(position);
+ if (pos != nil) {
+ _INST(position) = _MKSMALLINT(_intVal(pos) + len);
+ }
+ RETURN ( self );
+ }
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ }
}
-%}
-.
+%}.
+ lastErrorNumber notNil ifTrue:[^ self writeError].
^ super nextPutAll:aCollection
!
@@ -1713,73 +1808,80 @@
extern errno;
extern int _immediateInterrupt;
- if ((_INST(filePointer) != nil) && (_INST(mode) != _readonly)) {
- if (_isSmallInteger(start) && _isSmallInteger(stop)) {
- cp = NULL;
- if (_INST(binary) != true) {
- if (__isString(aCollection) || __isSymbol(aCollection)) {
- cp = _stringVal(aCollection);
- len = _stringSize(aCollection);
- }
- } else {
- if (__isByteArray(aCollection)) {
- cp = _ByteArrayInstPtr(aCollection)->ba_element;
- len = _byteArraySize(aCollection);
- } else {
- if (__isBytes(aCollection)) {
- int nInst;
-
- cp = _ByteArrayInstPtr(aCollection)->ba_element;
- len = _byteArraySize(aCollection);
- nInst = _intVal(_ClassInstPtr(_qClass(aCollection))->c_ninstvars);
- cp += __OBJS2BYTES__(nInst);
- len -= __OBJS2BYTES__(nInst);
- }
- }
- }
- if (cp != NULL) {
- f = MKFD(_INST(filePointer));
- index1 = _intVal(start);
- index2 = _intVal(stop);
- if ((index1 < 1) || (index2 > len) || (index2 < index1)) {
- RETURN ( self );
- }
- if (index2 > len)
- index2 = len;
-
- _immediateInterrupt = 1;
- len = index2 - index1 + 1;
-#ifdef OLD
- if (_INST(buffered) == false) {
- cnt = write(fileno(f), cp + index1 - 1, len);
- } else
-#endif
- {
- if ((_INST(didWrite) != true) && (_INST(mode) == _readwrite)) {
- _INST(didWrite) = true;
- fseek(f, 0L, 1); /* needed in stdio */
- }
- cnt = fwrite(cp + index1 - 1, 1, len, f);
- }
-#ifndef OLD
- if (_INST(buffered) == false) {
- fflush(f);
- }
-#endif
- _immediateInterrupt = 0;
- if (cnt == len) {
- if (_INST(position) != nil) {
- _INST(position) = _MKSMALLINT(_intVal(_INST(position)) + len);
- }
- RETURN ( self );
- }
- ExternalStream_LastErrorNumber = _MKSMALLINT(errno);
- RETURN ( nil );
- }
- }
+ _INST(lastErrorNumber) = nil;
+ if ((_INST(filePointer) != nil)
+ && (_INST(mode) != @symbol(readonly))) {
+ if (_isSmallInteger(start) && _isSmallInteger(stop)) {
+ cp = NULL;
+ if (_INST(binary) != true) {
+ if (__isString(aCollection) || __isSymbol(aCollection)) {
+ cp = _stringVal(aCollection);
+ len = _stringSize(aCollection);
+ }
+ } else {
+ if (__isByteArray(aCollection)) {
+ cp = _ByteArrayInstPtr(aCollection)->ba_element;
+ len = _byteArraySize(aCollection);
+ } else {
+ if (__isBytes(aCollection)) {
+ int nInst;
+
+ cp = _ByteArrayInstPtr(aCollection)->ba_element;
+ len = _byteArraySize(aCollection);
+ nInst = _intVal(_ClassInstPtr(_qClass(aCollection))->c_ninstvars);
+ cp += __OBJS2BYTES__(nInst);
+ len -= __OBJS2BYTES__(nInst);
+ }
+ }
+ }
+ if (cp != NULL) {
+ f = MKFD(_INST(filePointer));
+ index1 = _intVal(start);
+ index2 = _intVal(stop);
+ if ((index1 < 1) || (index2 > len) || (index2 < index1)) {
+ RETURN ( self );
+ }
+ if (index2 > len)
+ index2 = len;
+
+ _immediateInterrupt = 1;
+ len = index2 - index1 + 1;
+
+ if ((_INST(didWrite) != true)
+ && (_INST(mode) == @symbol(readwrite))) {
+ _INST(didWrite) = true;
+ fseek(f, 0L, 1); /* needed in stdio */
+ }
+
+ do {
+ cnt = fwrite(cp + index1 - 1, 1, len, f);
+ if (cnt != len) {
+ if (cnt >= 0) {
+ if (errno == EINTR) {
+ cp += cnt;
+ len -= cnt;
+ }
+ }
+ }
+ } while ((cnt != len) && (errno == EINTR));
+
+ if (_INST(buffered) == false) {
+ fflush(f);
+ }
+
+ _immediateInterrupt = 0;
+ if (cnt == len) {
+ if (_INST(position) != nil) {
+ _INST(position) = _MKSMALLINT(_intVal(_INST(position)) + len);
+ }
+ RETURN ( self );
+ }
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ }
+ }
}
-%}
-.
+%}.
+ lastErrorNumber notNil ifTrue:[^ self writeError].
^ super nextPutAll:aCollection startingAt:start to:stop
!
@@ -1793,41 +1895,40 @@
extern int _immediateInterrupt;
int cnt;
- if ((_INST(filePointer) != nil) && (_INST(mode) != _readonly)) {
- if (_INST(binary) != true) {
- f = MKFD(_INST(filePointer));
-
- _immediateInterrupt = 1;
-#ifdef OLD
- if (_INST(buffered) == false) {
- cnt = write(fileno(f), "\n", 1);
- } else
-#endif
- {
- if ((_INST(didWrite) != true) && (_INST(mode) == _readwrite)) {
- _INST(didWrite) = true;
- fseek(f, 0L, 1); /* needed in stdio */
- }
- cnt = fwrite("\n", 1, 1, f);
- }
-#ifndef OLD
- if (_INST(buffered) == false) {
- fflush(f);
- }
-#endif
- _immediateInterrupt = 0;
- if (cnt == 1) {
- if (_INST(position) != nil) {
- _INST(position) = _MKSMALLINT(_intVal(_INST(position)) + 1);
- }
- RETURN ( self );
- }
- ExternalStream_LastErrorNumber = _MKSMALLINT(errno);
- return ( nil );
- }
+ _INST(lastErrorNumber) = nil;
+ if ((_INST(filePointer) != nil)
+ && (_INST(mode) != @symbol(readonly))) {
+ if (_INST(binary) != true) {
+ f = MKFD(_INST(filePointer));
+
+ _immediateInterrupt = 1;
+
+ if ((_INST(didWrite) != true)
+ && (_INST(mode) == @symbol(readwrite))) {
+ _INST(didWrite) = true;
+ fseek(f, 0L, 1); /* needed in stdio */
+ }
+
+ do {
+ cnt = fwrite("\n", 1, 1, f);
+ } while ((cnt != 1) && (errno == EINTR));
+
+ if (_INST(buffered) == false) {
+ fflush(f);
+ }
+
+ _immediateInterrupt = 0;
+ if (cnt == 1) {
+ if (_INST(position) != nil) {
+ _INST(position) = _MKSMALLINT(_intVal(_INST(position)) + 1);
+ }
+ RETURN ( self );
+ }
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ }
}
-%}
-.
+%}.
+ lastErrorNumber notNil ifTrue:[^ self writeError].
filePointer isNil ifTrue:[^ self errorNotOpen].
(mode == #readonly) ifTrue:[^ self errorReadOnly].
self errorBinary
@@ -1853,87 +1954,101 @@
int fd, ch;
int _buffered;
- if ((_INST(filePointer) != nil) && (_INST(mode) != _writeonly)) {
- if (_INST(binary) != true) {
- f = MKFD(_INST(filePointer));
- _immediateInterrupt = 1;
- buffer[0] = 0;
-
- _buffered = (_INST(buffered) == true);
-
- /*
- * mhmh - the following code looks ok to me,
- * but seems not to work for sockets
- */
+ _INST(lastErrorNumber) = nil;
+ if ((_INST(filePointer) != nil)
+ && (_INST(mode) != @symbol(writeonly))) {
+ if (_INST(binary) != true) {
+ f = MKFD(_INST(filePointer));
+ _immediateInterrupt = 1;
+ buffer[0] = 0;
+
+ _buffered = (_INST(buffered) == true);
+
+ /*
+ * mhmh - the following code looks ok to me,
+ * but seems not to work for sockets
+ */
#ifdef DOES_NOT_WORK
- if (_INST(mode) == _readwrite)
- fseek(f, 0L, 1); /* needed in stdio */
- do {
- rslt = fgets(buffer, sizeof(buffer), f);
- } while ((rslt == NULL) && (errno == EINTR));
+ if (_INST(mode) == _readwrite)
+ fseek(f, 0L, 1); /* needed in stdio */
+ do {
+ rslt = fgets(buffer, sizeof(buffer), f);
+ } while ((rslt == NULL) && (errno == EINTR));
#else
- if (_buffered) {
- if ((_INST(didWrite) != false) && (_INST(mode) == _readwrite)) {
- _INST(didWrite) = false;
- fseek(f, 0L, 1); /* needed in stdio */
- }
- }
- rslt = buffer;
- fd = fileno(f);
- for (;;) {
- if (_buffered) {
- ch = getc(f);
- if (ch == EOF)
- len = 0;
- else {
- len = 1;
- *rslt = ch;
- }
- } else {
- do {
- len = read(fd, rslt, 1);
- } while ((len < 0) && (errno == EINTR));
- }
- if (len <= 0) {
- if (rslt == buffer) {
- rslt = NULL;
- } else {
- *rslt = '\0';
- }
- break;
- }
- rslt++;
- if (*(rslt-1) == '\n') {
- *rslt = '\0';
- break;
- }
- if (rslt == (buffer + sizeof(buffer) - 1)) {
- *rslt = '\0';
- break;
- }
- }
+ if (_buffered) {
+ if ((_INST(didWrite) != false)
+ && (_INST(mode) == @symbol(readwrite))) {
+ _INST(didWrite) = false;
+ fseek(f, 0L, 1); /* needed in stdio */
+ }
+ }
+ rslt = buffer;
+ fd = fileno(f);
+ for (;;) {
+ if (_buffered) {
+ ch = getc(f);
+ if (ch == EOF) {
+ if (ferror(f)) {
+ if (errno == EINTR) {
+ clearerr(f);
+ continue;
+ }
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ }
+ len = 0;
+ } else {
+ len = 1;
+ *rslt = ch;
+ }
+ } else {
+ do {
+ len = read(fd, rslt, 1);
+ } while ((len < 0) && (errno == EINTR));
+ }
+ if (len <= 0) {
+ if (rslt == buffer) {
+ rslt = NULL;
+ } else {
+ *rslt = '\0';
+ }
+ break;
+ }
+ rslt++;
+ if (*(rslt-1) == '\n') {
+ *rslt = '\0';
+ break;
+ }
+ if (rslt == (buffer + sizeof(buffer) - 1)) {
+ *rslt = '\0';
+ break;
+ }
+ }
#endif
- _immediateInterrupt = 0;
- if (rslt != NULL) {
- len = strlen(buffer);
- if (_INST(position) != nil) {
- _INST(position) = _MKSMALLINT(_intVal(_INST(position)) + len + 1);
- }
- /* remove EOL character */
- if ((len != 0) && (buffer[len-1] == '\n')) {
- buffer[--len] = '\0';
- }
- if ((len != 0) && (buffer[len-1] == '\r')) {
- buffer[--len] = '\0';
- }
- RETURN ( _MKSTRING(buffer COMMA_CON) );
- }
- _INST(hitEOF) = true;
- RETURN ( nil );
- }
+ _immediateInterrupt = 0;
+ if (rslt != NULL) {
+ len = strlen(buffer);
+ if (_INST(position) != nil) {
+ _INST(position) = _MKSMALLINT(_intVal(_INST(position)) + len + 1);
+ }
+ /* remove EOL character */
+ if ((len != 0) && (buffer[len-1] == '\n')) {
+ buffer[--len] = '\0';
+ }
+ if ((len != 0) && (buffer[len-1] == '\r')) {
+ buffer[--len] = '\0';
+ }
+ RETURN ( _MKSTRING(buffer COMMA_CON) );
+ }
+ if (ferror(f)) {
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ } else {
+ _INST(hitEOF) = true;
+ RETURN ( nil );
+ }
+ }
}
-%}
-.
+%}.
+ lastErrorNumber notNil ifTrue:[^ self readError].
filePointer isNil ifTrue:[^ self errorNotOpen].
(mode == #writeonly) ifTrue:[^ self errorWriteOnly].
self errorBinary
@@ -1951,57 +2066,59 @@
extern errno;
extern int _immediateInterrupt;
- if ((_INST(filePointer) != nil) && (_INST(mode) != _readonly)) {
- if (_INST(binary) != true) {
- if (__isString(aString)) {
- f = MKFD(_INST(filePointer));
- s = (char *) _stringVal(aString);
- len = _stringSize(aString);
-
- _immediateInterrupt = 1;
+ _INST(lastErrorNumber) = nil;
+ if ((_INST(filePointer) != nil)
+ && (_INST(mode) != @symbol(readonly))) {
+ if (_INST(binary) != true) {
+ if (__isString(aString)) {
+ f = MKFD(_INST(filePointer));
+ s = (char *) _stringVal(aString);
+ len = _stringSize(aString);
+
+ _immediateInterrupt = 1;
#ifdef OLD
- if (_INST(buffered) == false) {
- cnt = write(fileno(f), s, len);
- } else
-#endif
- {
- if ((_INST(didWrite) != true) && (_INST(mode) == _readwrite)) {
- _INST(didWrite) = true;
- fseek(f, 0L, 1); /* needed in stdio */
- }
- cnt = fwrite(s, 1, len, f);
- }
- if (cnt == len) {
-#ifdef OLD
- if (_INST(buffered) == false) {
- cnt = write(fileno(f), "\n", 1);
- } else
+ if (_INST(buffered) == false) {
+ cnt = write(fileno(f), s, len);
+ } else
#endif
- {
- cnt = fwrite("\n", 1, 1, f);
- }
-#ifndef OLD
- if (_INST(buffered) == false) {
- fflush(f);
- }
+ {
+ if ((_INST(didWrite) != true)
+ && (_INST(mode) == @symbol(readwrite))) {
+ _INST(didWrite) = true;
+ fseek(f, 0L, 1); /* needed in stdio */
+ }
+ cnt = fwrite(s, 1, len, f);
+ }
+ if (cnt == len) {
+#ifdef OLD
+ if (_INST(buffered) == false) {
+ cnt = write(fileno(f), "\n", 1);
+ } else
#endif
- if (cnt == 1) {
- pos = _INST(position);
- if (pos != nil) {
- _INST(position) = _MKSMALLINT(_intVal(pos)+len+1);
- }
- _immediateInterrupt = 0;
- RETURN ( self );
- }
- }
- _immediateInterrupt = 0;
- ExternalStream_LastErrorNumber = _MKSMALLINT(errno);
- RETURN ( nil );
- }
- }
+ {
+ cnt = fwrite("\n", 1, 1, f);
+ }
+#ifndef OLD
+ if (_INST(buffered) == false) {
+ fflush(f);
+ }
+#endif
+ if (cnt == 1) {
+ pos = _INST(position);
+ if (pos != nil) {
+ _INST(position) = _MKSMALLINT(_intVal(pos)+len+1);
+ }
+ _immediateInterrupt = 0;
+ RETURN ( self );
+ }
+ }
+ _immediateInterrupt = 0;
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ }
+ }
}
-%}
-.
+%}.
+ lastErrorNumber notNil ifTrue:[^ self writeError].
super nextPutAll:aString.
self cr.
!
@@ -2009,13 +2126,13 @@
nextPutLinesFrom:aStream upToLineStartingWith:aStringOrNil
"read from aStream up to and including a line starting with aStringOrNil
and append it to self.
- can be used to copy/create large files or copy from a pipe/socket.
+ Can be used to copy/create large files or copy from a pipe/socket.
If aStringOrNil is nil or not matched, copy preceeds to the end.
(this allows for example to read a Socket and transfer the data quickly
into a file - without creating zillions of temporary strings)"
- |srcFilePointer|
+ |srcFilePointer readError|
(mode == #readonly) ifTrue:[^ self errorReadOnly].
filePointer isNil ifTrue:[^ self errorNotOpen].
@@ -2030,47 +2147,74 @@
char buffer[1024];
extern int _immediateInterrupt;
- if (_isSmallInteger(srcFilePointer)
-#ifdef OLD
- && (_INST(buffered) == true)
-#endif
- ) {
- if ((aStringOrNil == nil) || __isString(aStringOrNil)) {
- if (aStringOrNil != nil) {
- matchString = (char *) _stringVal(aStringOrNil);
- matchLen = _stringSize(aStringOrNil);
- }
- dst = MKFD(_INST(filePointer));
- src = (FILE *)_intVal(srcFilePointer);
- _immediateInterrupt = 1;
- for (;;) {
- if (fgets(buffer, sizeof(buffer), src) == NULL) break;
- if (fputs(buffer, dst) == EOF) break;
+ _INST(lastErrorNumber) = nil;
+ if (_isSmallInteger(srcFilePointer)) {
+ if ((aStringOrNil == nil) || __isString(aStringOrNil)) {
+ if (aStringOrNil != nil) {
+ matchString = (char *) _stringVal(aStringOrNil);
+ matchLen = _stringSize(aStringOrNil);
+ }
+ dst = MKFD(_INST(filePointer));
+ src = (FILE *)_intVal(srcFilePointer);
+ _immediateInterrupt = 1;
+ errno = 0;
+
+ if ((_INST(didWrite) != true)
+ && (_INST(mode) == @symbol(readwrite))) {
+ _INST(didWrite) = true;
+ fseek(dst, 0L, 1); /* needed in stdio */
+ }
+
+ for (;;) {
+ if (fgets(buffer, sizeof(buffer), src) == NULL) {
+ if (ferror(src)) {
+ readError = _MKSMALLINT(errno);
+ goto err;
+ }
+ break;
+ }
+ if (fputs(buffer, dst) == EOF) {
+ if (ferror(dst)) {
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ goto err;
+ }
+ break;
+ }
#ifndef OLD
- if (_INST(buffered) == false) {
- fflush(dst);
- }
+ if (_INST(buffered) == false) {
+ fflush(dst);
+ }
#endif
- if (matchLen) {
- if (strncmp(matchString, buffer, matchLen) == 0)
- break;
- }
- }
- _immediateInterrupt = 0;
- _INST(position) = nil;
- RETURN ( self );
- }
+ if (matchLen) {
+ if (strncmp(matchString, buffer, matchLen) == 0)
+ break;
+ }
+ }
+ _immediateInterrupt = 0;
+ _INST(position) = nil;
+ RETURN (self);
+ }
}
-%}
-.
+err: ;
+%}.
+ readError ifTrue:[
+ aStream setLastErrorNumber:readError.
+ ^ aStream readError
+ ].
+ lastErrorNumber notNil ifTrue:[^ self writeError].
buffered ifFalse:[^ self errorNotBuffered].
+ "
+ argument error
+ "
^ self primitiveFailed
!
peekForLineStartingWith:aString
"read ahead for next line starting with aString;
- return the line-string if found, nil otherwise.
- Do not advance position i.e. nextLine will reread this line"
+ return the line-string if found, or nil if EOF is encountered.
+ If matched, not advance position behond that line
+ i.e. nextLine will read the matched line.
+ If not matched, reposition to original position for firther reading."
(mode == #writeonly) ifTrue:[^ self errorWriteOnly].
filePointer isNil ifTrue:[^ self errorNotOpen].
@@ -2085,45 +2229,53 @@
int firstpos = -1, lastpos;
extern int _immediateInterrupt;
+ _INST(lastErrorNumber) = nil;
if (__isString(aString)) {
- matchString = (char *) _stringVal(aString);
- l = _stringSize(aString);
-
- f = MKFD(_INST(filePointer));
-
- if ((_INST(didWrite) != false) && (_INST(mode) == _readwrite)) {
- _INST(didWrite) = false;
- fseek(f, 0L, 1); /* needed in stdio */
- }
-
- for (;;) {
- lastpos = ftell(f);
- if (firstpos == -1) firstpos = lastpos;
-
- _immediateInterrupt = 1;
- do {
- cp = fgets(buffer, sizeof(buffer), f);
- } while ((cp == NULL) && (errno == EINTR));
- _immediateInterrupt = 0;
-
- if (cp == NULL) {
- fseek(f, firstpos, 0);
- RETURN ( nil );
- }
- if (strncmp(cp, matchString, l) == 0) {
- fseek(f, lastpos, 0);
- break;
- }
- }
- /* remove EOL character */
- cp = buffer;
- while (*cp && (*cp != '\n')) cp++;
- *cp = '\0';
- RETURN ( _MKSTRING(buffer COMMA_CON) );
+ matchString = (char *) _stringVal(aString);
+ l = _stringSize(aString);
+
+ f = MKFD(_INST(filePointer));
+
+ if ((_INST(didWrite) != false)
+ && (_INST(mode) == @symbol(readwrite))) {
+ _INST(didWrite) = false;
+ fseek(f, 0L, 1); /* needed in stdio */
+ }
+
+ for (;;) {
+ lastpos = ftell(f);
+ if (firstpos == -1) firstpos = lastpos;
+
+ _immediateInterrupt = 1;
+ do {
+ cp = fgets(buffer, sizeof(buffer), f);
+ } while ((cp == NULL) && (errno == EINTR));
+ _immediateInterrupt = 0;
+
+ if (cp == NULL) {
+ if (ferror(f)) {
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ goto err;
+ } else {
+ fseek(f, firstpos, 0);
+ RETURN (nil);
+ }
+ }
+ if (strncmp(cp, matchString, l) == 0) {
+ fseek(f, lastpos, 0);
+ break;
+ }
+ }
+ /* remove EOL character */
+ cp = buffer;
+ while (*cp && (*cp != '\n')) cp++;
+ *cp = '\0';
+ RETURN ( _MKSTRING(buffer COMMA_CON) );
}
-%}
-.
- self argumentMustBeString
+err: ;
+%}.
+ lastErrorNumber notNil ifTrue:[^ self readError].
+ ^ self argumentMustBeString
!
peekForLineStartingWithAny:aCollectionOfStrings
@@ -2140,16 +2292,18 @@
startPos := self position.
[self atEnd] whileFalse:[
- linePos := self position.
- line := self nextLine.
- index := 1.
- aCollectionOfStrings do:[:prefix |
- (line startsWith:prefix) ifTrue:[
- self position:linePos.
- ^ index
- ].
- index := index + 1
- ]
+ linePos := self position.
+ line := self nextLine.
+ line notNil ifTrue:[
+ index := 1.
+ aCollectionOfStrings do:[:prefix |
+ (line startsWith:prefix) ifTrue:[
+ self position:linePos.
+ ^ index
+ ].
+ index := index + 1
+ ]
+ ]
].
self position:startPos.
^ nil
@@ -2169,27 +2323,38 @@
extern int _immediateInterrupt;
if (_INST(hitEOF) == _true) {
- RETURN (_true);
+ RETURN (_true);
}
+ _INST(lastErrorNumber) = nil;
if ((t = _INST(filePointer)) != nil) {
- f = MKFD(t);
+ f = MKFD(t);
#ifdef OLD
- RETURN ( feof(f) ? _true : false );
+ RETURN ( feof(f) ? _true : false );
#else
- _immediateInterrupt = 1;
- c = getc(f);
- _immediateInterrupt = 0;
- if (c == EOF) {
- _INST(hitEOF) = _true;
- RETURN (_true);
- }
- ungetc(c, f);
- RETURN (false);
+ if ((_INST(didWrite) != false)
+ && (_INST(mode) == @symbol(readwrite))) {
+ _INST(didWrite) = false;
+ fseek(f, 0L, 1); /* needed in stdio */
+ }
+
+ _immediateInterrupt = 1;
+ c = getc(f);
+ _immediateInterrupt = 0;
+ if (c != EOF) {
+ ungetc(c, f);
+ RETURN (false);
+ }
+ if (ferror(f)) {
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ } else {
+ _INST(hitEOF) = _true;
+ RETURN (_true);
+ }
#endif
}
-%}
-.
- self errorNotOpen
+%}.
+ lastErrorNumber notNil ifTrue:[^ self readError].
+ ^ self errorNotOpen
!
canReadWithoutBlocking
@@ -2198,12 +2363,8 @@
|fd|
- filePointer isNil ifTrue:[
- ^ self errorNotOpen
- ].
- mode == #writeonly ifTrue:[
- ^ self errorWriteOnly
- ].
+ filePointer isNil ifTrue:[^ self errorNotOpen].
+ mode == #writeonly ifTrue:[^ self errorWriteOnly].
fd := self fileDescriptor.
^ OperatingSystem readCheck:fd
@@ -2213,9 +2374,9 @@
pipe := PipeStream readingFrom:'(sleep 10; echo hello)'.
pipe canReadWithoutBlocking ifTrue:[
- Transcript showCr:'data available'
+ Transcript showCr:'data available'
] ifFalse:[
- Transcript showCr:'no data available'
+ Transcript showCr:'no data available'
].
pipe close
"
@@ -2227,12 +2388,8 @@
|fd|
- filePointer isNil ifTrue:[
- ^ self errorNotOpen
- ].
- mode == #readonly ifTrue:[
- ^ self errorReadOnly
- ].
+ filePointer isNil ifTrue:[^ self errorNotOpen].
+ mode == #readonly ifTrue:[^ self errorReadOnly].
fd := self fileDescriptor.
^ OperatingSystem writeCheck:fd
@@ -2258,12 +2415,8 @@
|fd inputSema hasData wasBlocked|
- filePointer isNil ifTrue:[
- ^ self errorNotOpen
- ].
- mode == #writeonly ifTrue:[
- ^ self errorWriteOnly
- ].
+ filePointer isNil ifTrue:[^ self errorNotOpen].
+ mode == #writeonly ifTrue:[^ self errorWriteOnly].
fd := self fileDescriptor.
(OperatingSystem readCheck:fd) ifTrue:[^ true].
@@ -2271,15 +2424,15 @@
wasBlocked := OperatingSystem blockInterrupts.
hasData := OperatingSystem readCheck:fd.
hasData ifFalse:[
- inputSema := Semaphore new.
- timeout notNil ifTrue:[
- Processor signal:inputSema afterSeconds:timeout
- ].
- Processor signal:inputSema onInput:fd.
- Processor activeProcess state:#ioWait.
- inputSema wait.
- Processor disableSemaphore:inputSema.
- hasData := OperatingSystem readCheck:fd
+ inputSema := Semaphore new.
+ timeout notNil ifTrue:[
+ Processor signal:inputSema afterSeconds:timeout
+ ].
+ Processor signal:inputSema onInput:fd.
+ Processor activeProcess state:#ioWait.
+ inputSema wait.
+ Processor disableSemaphore:inputSema.
+ hasData := OperatingSystem readCheck:fd
].
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
^ hasData
@@ -2304,10 +2457,10 @@
|fd outputSema canWrite wasBlocked|
filePointer isNil ifTrue:[
- ^ self errorNotOpen
+ ^ self errorNotOpen
].
mode == #readonly ifTrue:[
- ^ self errorReadOnly
+ ^ self errorReadOnly
].
fd := self fileDescriptor.
@@ -2316,15 +2469,15 @@
wasBlocked := OperatingSystem blockInterrupts.
canWrite := OperatingSystem writeCheck:fd.
canWrite ifFalse:[
- outputSema := Semaphore new.
- timeout notNil ifTrue:[
- Processor signal:outputSema afterSeconds:timeout
- ].
- Processor signal:outputSema onOutput:fd.
- Processor activeProcess state:#ioWait.
- outputSema wait.
- Processor disableSemaphore:outputSema.
- canWrite := OperatingSystem writeCheck:fd
+ outputSema := Semaphore new.
+ timeout notNil ifTrue:[
+ Processor signal:outputSema afterSeconds:timeout
+ ].
+ Processor signal:outputSema onOutput:fd.
+ Processor activeProcess state:#ioWait.
+ outputSema wait.
+ Processor disableSemaphore:outputSema.
+ canWrite := OperatingSystem writeCheck:fd
].
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
^ canWrite
@@ -2333,8 +2486,9 @@
!ExternalStream methodsFor:'reimplemented for speed'!
peekFor:anObject
- "return true and move past if next == something.
- Otherwise, stay and return false."
+ "return true and move past next element, if next == something.
+ Otherwise, stay and return false. False is also returned
+ when EOF is encountered."
%{ /* NOCONTEXT */
@@ -2343,45 +2497,59 @@
int peekValue;
extern int _immediateInterrupt;
- if (_INST(filePointer) != nil) {
- if (_INST(binary) == true) {
- if (_isSmallInteger(anObject)) {
- peekValue = _intVal(anObject) & 0xFF;
- } else {
- goto bad;
- }
- } else {
- if (__isCharacter(anObject)) {
- peekValue = _intVal(_characterVal(anObject)) & 0xFF;
- } else {
- goto bad;
- }
- }
-
- f = MKFD(_INST(filePointer));
- _immediateInterrupt = 1;
- c = getc(f);
- _immediateInterrupt = 0;
-
- if (c == peekValue) {
- OBJ pos;
-
- if ((pos = _INST(position)) != nil) {
- _INST(position) = _MKSMALLINT(_intVal(pos) + 1);
- }
- RETURN ( true );
- }
-
- if (c == EOF) {
- _INST(hitEOF) = true;
- } else {
- ungetc(c, f);
- }
- RETURN ( false );
+ _INST(lastErrorNumber) = nil;
+ if ((_INST(filePointer) != nil)
+ && (_INST(mode) != @symbol(writeonly))) {
+ if (_INST(binary) == true) {
+ if (_isSmallInteger(anObject)) {
+ peekValue = _intVal(anObject) & 0xFF;
+ } else {
+ goto bad;
+ }
+ } else {
+ if (__isCharacter(anObject)) {
+ peekValue = _intVal(_characterVal(anObject)) & 0xFF;
+ } else {
+ goto bad;
+ }
+ }
+
+ if ((_INST(didWrite) != false)
+ && (_INST(mode) == @symbol(readwrite))) {
+ _INST(didWrite) = false;
+ fseek(f, 0L, 1); /* needed in stdio */
+ }
+
+ f = MKFD(_INST(filePointer));
+ _immediateInterrupt = 1;
+ c = getc(f);
+ _immediateInterrupt = 0;
+
+ if (c == peekValue) {
+ OBJ pos;
+
+ if ((pos = _INST(position)) != nil) {
+ _INST(position) = _MKSMALLINT(_intVal(pos) + 1);
+ }
+ RETURN (true);
+ }
+
+ if (c != EOF) {
+ ungetc(c, f);
+ RETURN (false);
+ }
+
+ if (ferror(f)) {
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ } else {
+ _INST(hitEOF) = true;
+ RETURN (false);
+ }
}
bad: ;
-%}
-.
+%}.
+ mode == #writeonly ifTrue:[^ self errorWriteOnly].
+ lastErrorNumber notNil iftrue:[^ self readError].
filePointer isNil ifTrue:[^ self errorNotOpen].
^ super peekFor:anObject
!
@@ -2397,45 +2565,51 @@
int peekValue, c;
extern int _immediateInterrupt;
- if ((_INST(binary) == true) && _isSmallInteger(anObject)) {
- peekValue = _intVal(anObject) & 0xFF;
- } else {
- if ((_INST(binary) != true) && __isCharacter(anObject)) {
- peekValue = _intVal(_characterVal(anObject)) & 0xFF;
- } else
- peekValue = -1;
+ _INST(lastErrorNumber) = nil;
+ if ((_INST(filePointer) != nil)
+ && (_INST(mode) != @symbol(writeonly))) {
+ if ((_INST(binary) == true) && _isSmallInteger(anObject)) {
+ peekValue = _intVal(anObject) & 0xFF;
+ } else {
+ if ((_INST(binary) != true) && __isCharacter(anObject)) {
+ peekValue = _intVal(_characterVal(anObject)) & 0xFF;
+ } else {
+ peekValue = -1;
+ }
+ }
+
+ if (peekValue >= 0) {
+ f = MKFD(_INST(filePointer));
+ _immediateInterrupt = 1;
+ _INST(position) = nil;
+
+ if ((_INST(didWrite) != false)
+ && (_INST(mode) == @symbol(readwrite))) {
+ _INST(didWrite) = false;
+ fseek(f, 0L, 1); /* needed in stdio */
+ }
+
+ for (;;) {
+ c = getc(f);
+ if (c == EOF) {
+ _immediateInterrupt = 0;
+ if (ferror(f)) {
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ break;
+ }
+ _INST(hitEOF) = true;
+ RETURN (nil);
+ }
+ if (c == peekValue) {
+ _immediateInterrupt = 0;
+ RETURN (anObject);
+ }
+ }
+ _immediateInterrupt = 0;
+ }
}
-
- if (peekValue >= 0) {
- if (_INST(filePointer) != nil) {
- if (_INST(mode) != _writeonly) {
- f = MKFD(_INST(filePointer));
- _immediateInterrupt = 1;
- _INST(position) = nil;
-
- if ((_INST(didWrite) != false) && (_INST(mode) == _readwrite)) {
- _INST(didWrite) = false;
- fseek(f, 0L, 1); /* needed in stdio */
- }
-
- for (;;) {
- c = getc(f);
- if (c == EOF) {
- _INST(hitEOF) = true;
- _immediateInterrupt = 0;
- RETURN (nil);
- }
- if (c == peekValue) {
- _immediateInterrupt = 0;
- RETURN (anObject);
- }
- }
- _immediateInterrupt = 0;
- }
- }
- }
-%}
-.
+%}.
+ lastErrorNumber notNil iftrue:[^ self readError].
filePointer isNil ifTrue:[^ self errorNotOpen].
^ super nextMatchFor:anObject
!
@@ -2451,30 +2625,37 @@
char buffer[1024];
extern int _immediateInterrupt;
- if ((_INST(filePointer) != nil) && (_INST(mode) != _writeonly)) {
- if (_INST(binary) != true) {
- f = MKFD(_INST(filePointer));
+ _INST(lastErrorNumber) = nil;
+ if ((_INST(filePointer) != nil)
+ && (_INST(mode) != @symbol(writeonly))) {
+ if (_INST(binary) != true) {
+ f = MKFD(_INST(filePointer));
- if ((_INST(didWrite) != false) && (_INST(mode) == _readwrite)) {
- _INST(didWrite) = false;
- fseek(f, 0L, 1); /* needed in stdio */
- }
-
- _immediateInterrupt = 1;
- if (fgets(buffer, sizeof(buffer), f) != NULL) {
- _immediateInterrupt = 0;
- RETURN ( self );
- }
- _INST(hitEOF) = true;
- _immediateInterrupt = 0;
- RETURN ( nil );
- }
+ if ((_INST(didWrite) != false)
+ && (_INST(mode) == @symbol(readwrite))) {
+ _INST(didWrite) = false;
+ fseek(f, 0L, 1); /* needed in stdio */
+ }
+
+ _immediateInterrupt = 1;
+ if (fgets(buffer, sizeof(buffer), f) != NULL) {
+ _immediateInterrupt = 0;
+ RETURN ( self );
+ }
+ _immediateInterrupt = 0;
+ if (ferror(f)) {
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ } else {
+ _INST(hitEOF) = true;
+ RETURN ( nil );
+ }
+ }
}
-%}
-.
+%}.
+ lastErrorNumber notNil iftrue:[^ self readError].
filePointer isNil ifTrue:[^ self errorNotOpen].
binary ifTrue:[^ self errorBinary].
- self errorWriteOnly
+ ^ self errorWriteOnly
!
skipThroughAll:aString
@@ -2485,26 +2666,26 @@
|buffer len first|
(aString isString and:[binary not]) ifTrue:[
- len := aString size.
- first := aString at:1.
- buffer := String new:len.
- buffer at:1 put:first.
- len := len - 1.
- [true] whileTrue:[
- (self skipThrough:first) isNil ifTrue:[
- ^ nil.
- ].
- (self nextBytes:len into:buffer startingAt:2) == len ifFalse:[
- ^ nil
- ].
- buffer = aString ifTrue:[
- "
- position back, before string
- "
- ^ self
- ].
- ].
- "NOT REACHED"
+ len := aString size.
+ first := aString at:1.
+ buffer := String new:len.
+ buffer at:1 put:first.
+ len := len - 1.
+ [true] whileTrue:[
+ (self skipThrough:first) isNil ifTrue:[
+ ^ nil.
+ ].
+ (self nextBytes:len into:buffer startingAt:2) == len ifFalse:[
+ ^ nil
+ ].
+ buffer = aString ifTrue:[
+ "
+ position back, before string
+ "
+ ^ self
+ ].
+ ].
+ "NOT REACHED"
].
^ super skipThroughAll:aString
@@ -2525,11 +2706,11 @@
oldPos := self position.
(self skipThroughAll:aString) isNil ifTrue:[
- "
- restore position
- "
- self position:oldPos.
- ^ nil
+ "
+ restore position
+ "
+ self position:oldPos.
+ ^ nil
].
"
position before match-string
@@ -2557,49 +2738,58 @@
REGISTER int c, cSearch;
extern int _immediateInterrupt;
- if ((_INST(filePointer) != nil) && (_INST(mode) != _writeonly)) {
- if (_INST(binary) == true) {
- /* searched for object must be a smallInteger */
- if (! _isSmallInteger(aCharacter)) goto badArgument;
- cSearch = _intVal(aCharacter);
- } else {
- /* searched for object must be a character */
- if (! __isCharacter(aCharacter)) goto badArgument;
- cSearch = _intVal(_characterVal(aCharacter));
- }
- /* Q: should we just say: "not found" ? */
- if ((cSearch < 0) || (cSearch > 255)) goto badArgument;
-
- f = MKFD(_INST(filePointer));
+ _INST(lastErrorNumber) = nil;
+ if ((_INST(filePointer) != nil)
+ && (_INST(mode) != @symbol(writeonly))) {
+ if (_INST(binary) == true) {
+ /* searched for object must be a smallInteger */
+ if (! _isSmallInteger(aCharacter)) goto badArgument;
+ cSearch = _intVal(aCharacter);
+ } else {
+ /* searched for object must be a character */
+ if (! __isCharacter(aCharacter)) goto badArgument;
+ cSearch = _intVal(_characterVal(aCharacter));
+ }
+ /* Q: should we just say: "not found" ? */
+ if ((cSearch < 0) || (cSearch > 255)) goto badArgument;
+
+ f = MKFD(_INST(filePointer));
- if ((_INST(didWrite) != false) && (_INST(mode) == _readwrite)) {
- _INST(didWrite) = false;
- fseek(f, 0L, 1); /* needed in stdio */
- }
-
- _immediateInterrupt = 1;
- while (1) {
- if (feof(f)) {
- _immediateInterrupt = 0;
- RETURN ( nil );
- }
-
- c = getc(f);
-
- if (c < 0) {
- _immediateInterrupt = 0;
- _INST(hitEOF) = true;
- RETURN (nil);
- }
- if (c == cSearch) {
- _immediateInterrupt = 0;
- RETURN (self);
- }
- }
+ if ((_INST(didWrite) != false)
+ && (_INST(mode) == @symbol(readwrite))) {
+ _INST(didWrite) = false;
+ fseek(f, 0L, 1); /* needed in stdio */
+ }
+
+ _immediateInterrupt = 1;
+ while (1) {
+#ifdef NOTNEEDED
+ if (feof(f)) {
+ _immediateInterrupt = 0;
+ RETURN ( nil );
+ }
+#endif
+ c = getc(f);
+
+ if (c == cSearch) {
+ _immediateInterrupt = 0;
+ RETURN (self);
+ }
+ if (c < 0) {
+ _immediateInterrupt = 0;
+ if (ferror(f)) {
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ break;
+ } else {
+ _INST(hitEOF) = true;
+ RETURN (nil);
+ }
+ }
+ }
}
badArgument: ;
-%}
-.
+%}.
+ lastErrorNumber notNil iftrue:[^ self readError].
filePointer isNil ifTrue:[^ self errorNotOpen].
(mode == #writeonly) ifTrue:[^ self errorWriteOnly].
"
@@ -2627,48 +2817,54 @@
REGISTER int c;
extern int _immediateInterrupt;
- if ((_INST(filePointer) != nil) && (_INST(mode) != _writeonly)) {
- if (_INST(binary) != true) {
- f = MKFD(_INST(filePointer));
+ _INST(lastErrorNumber) = nil;
+ if ((_INST(filePointer) != nil)
+ && (_INST(mode) != @symbol(writeonly))) {
+ if (_INST(binary) != true) {
+ f = MKFD(_INST(filePointer));
- if ((_INST(didWrite) != false) && (_INST(mode) == _readwrite)) {
- _INST(didWrite) = false;
- fseek(f, 0L, 1); /* needed in stdio */
- }
-
- _immediateInterrupt = 1;
- while (1) {
- if (feof(f)) {
- _immediateInterrupt = 0;
- RETURN ( nil );
- }
-
- c = getc(f);
-
- switch (c) {
- case ' ':
- case '\t':
- case '\n':
- case '\r':
- case '\b':
- case '\014':
- break;
-
- default:
- if (c < 0) {
- _INST(hitEOF) = true;
- _immediateInterrupt = 0;
- RETURN ( nil );
- }
- ungetc(c, f);
- _immediateInterrupt = 0;
- RETURN ( _MKCHARACTER(c & 0xFF) );
- }
- }
- }
+ if ((_INST(didWrite) != false) && (_INST(mode) == _readwrite)) {
+ _INST(didWrite) = false;
+ fseek(f, 0L, 1); /* needed in stdio */
+ }
+
+ _immediateInterrupt = 1;
+ while (1) {
+ if (feof(f)) {
+ _immediateInterrupt = 0;
+ RETURN ( nil );
+ }
+
+ c = getc(f);
+
+ switch (c) {
+ case ' ':
+ case '\t':
+ case '\n':
+ case '\r':
+ case '\b':
+ case '\014':
+ break;
+
+ default:
+ _immediateInterrupt = 0;
+ if (c < 0) {
+ if (ferror(f)) {
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ goto err;
+ }
+ _INST(hitEOF) = true;
+ RETURN ( nil );
+ }
+ ungetc(c, f);
+ RETURN ( _MKCHARACTER(c & 0xFF) );
+ }
+ }
+ }
}
-%}
-.
+err: ;
+%}.
+ lastErrorNumber notNil iftrue:[^ self readError].
filePointer isNil ifTrue:[^ self errorNotOpen].
(mode == #writeonly) ifTrue:[^ self errorWriteOnly].
^ self errorBinary.
@@ -2686,49 +2882,143 @@
int c;
extern int _immediateInterrupt;
- if ((_INST(filePointer) != nil) && (_INST(mode) != _writeonly)) {
- if (_INST(binary) != true) {
- f = MKFD(_INST(filePointer));
-
- if ((_INST(didWrite) != false) && (_INST(mode) == _readwrite)) {
- _INST(didWrite) = false;
- fseek(f, 0L, 1); /* needed in stdio */
- }
-
- _immediateInterrupt = 1;
- while (1) {
+ _INST(lastErrorNumber) = nil;
+ if ((_INST(filePointer) != nil)
+ && (_INST(mode) != @symbol(writeonly))) {
+ if (_INST(binary) != true) {
+ f = MKFD(_INST(filePointer));
+
+ if ((_INST(didWrite) != false)
+ && (_INST(mode) == @symbol(readwrite))) {
+ _INST(didWrite) = false;
+ fseek(f, 0L, 1); /* needed in stdio */
+ }
+
+ _immediateInterrupt = 1;
+ while (1) {
- if (feof(f)) {
- _immediateInterrupt = 0;
- RETURN ( nil );
- }
-
- c = getc(f);
-
- switch (c) {
- case ' ':
- case '\t':
- case '\b':
- break;
-
- default:
- if (c < 0) {
- _INST(hitEOF) = true;
- _immediateInterrupt = 0;
- RETURN ( nil );
- }
- ungetc(c, f);
- _immediateInterrupt = 0;
- RETURN ( _MKCHARACTER(c & 0xFF) );
- }
- }
- }
+ if (feof(f)) {
+ _immediateInterrupt = 0;
+ RETURN ( nil );
+ }
+
+ c = getc(f);
+
+ switch (c) {
+ case ' ':
+ case '\t':
+ case '\b':
+ break;
+
+ default:
+ _immediateInterrupt = 0;
+ if (c < 0) {
+ if (ferror(f)) {
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ goto err;
+ }
+ _INST(hitEOF) = true;
+ RETURN ( nil );
+ }
+ ungetc(c, f);
+ RETURN ( _MKCHARACTER(c & 0xFF) );
+ }
+ }
+ }
}
-%}
-.
+err: ;
+%}.
+ lastErrorNumber notNil iftrue:[^ self readError].
filePointer isNil ifTrue:[^ self errorNotOpen].
(mode == #writeonly) ifTrue:[^ self errorWriteOnly].
- self errorBinary
+ ^ self errorBinary
+!
+
+nextAlphaNumericWord
+ "read the next word (i.e. up to non letter-or-digit).
+ return a string containing those characters."
+
+%{ /* STACK: 2000 */
+ FILE *f;
+ int len;
+ char buffer[1024];
+ int ch;
+ int cnt = 0;
+ extern int _immediateInterrupt;
+
+ if ((_INST(filePointer) != nil)
+ && (_INST(mode) != @symbol(writeonly))) {
+ f = MKFD(_INST(filePointer));
+
+ _immediateInterrupt = 1;
+
+ if ((_INST(didWrite) != false)
+ && (_INST(mode) == @symbol(readwrite))) {
+ _INST(didWrite) = false;
+ fseek(f, 0L, 1); /* needed in stdio */
+ }
+
+ for (;;) {
+ ch = getc(f);
+ if (ch < 0) {
+ if (ferror(f)) {
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ goto err;
+ }
+ _INST(hitEOF) = true;
+ break;
+ }
+ cnt++;
+
+ if (ch >= ' ') break;
+ if ((ch != ' ') && (ch != '\t') && (ch != '\r')
+ && (ch != '\n') && (ch != 0x0b)) break;
+ }
+ ungetc(ch, f);
+ cnt--;
+
+ len = 0;
+ for (;;) {
+ ch = getc(f);
+ if (ch < 0) {
+ if (ferror(f)) {
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ goto err;
+ }
+ _INST(hitEOF) = true;
+ break;
+ }
+
+ ch &= 0xFF;
+ if (! (((ch >= 'a') && (ch <= 'z')) ||
+ ((ch >= 'A') && (ch <= 'Z')) ||
+ ((ch >= '0') && (ch <= '9')))) {
+ ungetc(ch, f);
+ break;
+ }
+ cnt++;
+ buffer[len++] = ch;
+ if (len >= sizeof(buffer)-1) {
+ /* emergency */
+ break;
+ }
+ }
+ _immediateInterrupt = 0;
+
+ if (_INST(position) != nil) {
+ _INST(position) = _MKSMALLINT(_intVal(_INST(position)) + cnt);
+ }
+ buffer[len] = '\0';
+ if (len != 0) {
+ RETURN ( _MKSTRING(buffer COMMA_CON) );
+ }
+ RETURN ( nil );
+ }
+err: ;
+%}.
+ lastErrorNumber notNil ifTrue:[^ self readError].
+ filePointer isNil ifTrue:[^ self errorNotOpen].
+ ^ self errorWriteOnly
!
nextChunk
@@ -2738,29 +3028,32 @@
|retVal|
- filePointer isNil ifTrue:[
- ^ self errorNotOpen
- ].
- binary ifTrue:[
- ^ self errorBinary
- ].
-
+ filePointer isNil ifTrue:[^ self errorNotOpen].
+ binary ifTrue:[^ self errorBinary].
+ (mode == #writeonly) ifTrue:[^ self errorWriteOnly].
%{
FILE *f;
int done = 0;
REGISTER int c;
unsigned char peekC;
- char *buffer, *newBuffer;
+ char *buffer = (char *)0, *newBuffer;
REGISTER int index;
int currSize;
int inComment, inString, inPrimitive = 0;
extern int _immediateInterrupt;
+ _INST(lastErrorNumber) = nil;
f = MKFD(_INST(filePointer));
- if ((_INST(didWrite) != false) && (_INST(mode) == _readwrite)) {
- _INST(didWrite) = false;
- fseek(f, 0L, 1); /* needed in stdio */
+ if ((_INST(didWrite) != false)
+ && (_INST(mode) == @symbol(readwrite))) {
+ _INST(didWrite) = false;
+ fseek(f, 0L, 1); /* needed in stdio */
+ }
+
+ if (feof(f)) {
+ _immediateInterrupt = 0;
+ RETURN (nil);
}
/*
@@ -2768,34 +3061,34 @@
*/
_immediateInterrupt = 1;
while (! done) {
- if (feof(f)) {
- _immediateInterrupt = 0;
- RETURN ( nil );
- }
-
- do {
- c = getc(f);
- } while ((c < 0) && (errno == EINTR));
-
- switch (c) {
- case ' ':
- case '\t':
- case '\n':
- case '\r':
- case '\b':
- case '\014':
- break;
-
- case EOF:
- _immediateInterrupt = 0;
- _INST(hitEOF) = true;
- RETURN ( nil );
-
- default:
- ungetc(c, f);
- done = 1;
- break;
- }
+
+ do {
+ c = getc(f);
+ } while ((c < 0) && (errno == EINTR));
+
+ switch (c) {
+ case ' ':
+ case '\t':
+ case '\n':
+ case '\r':
+ case '\b':
+ case '\014':
+ break;
+
+ case EOF:
+ _immediateInterrupt = 0;
+ if (ferror(f)) {
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ goto err;
+ }
+ _INST(hitEOF) = true;
+ RETURN (nil);
+
+ default:
+ ungetc(c, f);
+ done = 1;
+ break;
+ }
}
/*
@@ -2805,44 +3098,50 @@
currSize = 3000;
index = 0;
while (! feof(f)) {
- /* do we have to resize the buffer ? */
- if ((index+2) >= currSize) {
- newBuffer = (char *)malloc(currSize * 2);
- bcopy(buffer, newBuffer, index);
- free(buffer);
- buffer = newBuffer;
- currSize = currSize * 2;
- }
- do {
- c = getc(f);
- } while (c < 0 && (errno == EINTR));
-
- if (c == '%') {
- peekC = getc(f);
- ungetc(peekC, f);
- if (peekC == '{') {
- inPrimitive++;
- } else if (peekC == '}') {
- inPrimitive--;
- }
- } else {
- if (! inPrimitive) {
- if (c == '!') {
- do {
- c = getc(f);
- } while (c < 0 && (errno == EINTR));
- if (c != '!') {
- ungetc(c, f);
- break;
- }
- }
- }
- }
- if (c == EOF) {
- _INST(hitEOF) = true;
- break;
- }
- buffer[index++] = c;
+ /* do we have to resize the buffer ? */
+ if ((index+2) >= currSize) {
+ newBuffer = (char *)malloc(currSize * 2);
+ bcopy(buffer, newBuffer, index);
+ free(buffer);
+ buffer = newBuffer;
+ currSize = currSize * 2;
+ }
+ do {
+ c = getc(f);
+ } while (c < 0 && (errno == EINTR));
+
+ if (c == '%') {
+ peekC = getc(f);
+ ungetc(peekC, f);
+ if (peekC == '{') {
+ inPrimitive++;
+ } else if (peekC == '}') {
+ inPrimitive--;
+ }
+ } else {
+ if (! inPrimitive) {
+ if (c == '!') {
+ do {
+ c = getc(f);
+ } while (c < 0 && (errno == EINTR));
+ if (c != '!') {
+ ungetc(c, f);
+ break;
+ }
+ }
+ }
+ }
+
+ if (c < 0) {
+ _immediateInterrupt = 0;
+ if (ferror(f)) {
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ goto err;
+ }
+ _INST(hitEOF) = true;
+ break;
+ }
+ buffer[index++] = c;
}
_immediateInterrupt = 0;
@@ -2851,8 +3150,10 @@
* make it a string
*/
retVal = _MKSTRING(buffer COMMA_CON);
- free(buffer);
-%}
-.
+err:
+ if (buffer)
+ free(buffer);
+%}.
+ lastErrorNumber notNil ifTrue:[^ self readError].
^ retVal
! !
--- a/FileDir.st Mon Oct 10 01:29:01 1994 +0100
+++ b/FileDir.st Mon Oct 10 01:29:28 1994 +0100
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Attic/FileDir.st,v 1.11 1994-08-05 00:54:45 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/FileDir.st,v 1.12 1994-10-10 00:26:00 claus Exp $
'!
!FileDirectory class methodsFor:'documentation'!
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Attic/FileDir.st,v 1.11 1994-08-05 00:54:45 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/FileDir.st,v 1.12 1994-10-10 00:26:00 claus Exp $
"
!
@@ -72,7 +72,7 @@
rootDirectory
"create and return a new FileDirectory for the root directory"
- ^ (self basicNew) pathName:'/'
+ ^ (self basicNew) pathName:(OperatingSystem fileSeparator asString)
"
FileDirectory rootDirectory contents
@@ -110,9 +110,10 @@
"create and return a new FileDirectory for the directory with given name
in another FileDirectory"
- |baseName|
+ |baseName sep|
- ((name at:1) == $/) ifTrue:[
+ sep := OperatingSystem fileSeparator.
+ ((name at:1) == sep) ifTrue:[
^ self directoryNamed:name
].
(aFileDirectory isKindOf:FileDirectory) ifTrue:[
@@ -127,9 +128,9 @@
"
(name = '.') ifTrue:[^ aFileDirectory].
- (baseName = '/') ifFalse:[
- (baseName endsWith:'/') ifFalse:[
- baseName := baseName , '/'
+ (baseName = sep asString) ifFalse:[
+ (baseName endsWith:sep) ifFalse:[
+ baseName := baseName copyWith:sep
]
].
^ (self basicNew) pathName:(baseName , name)
@@ -164,7 +165,7 @@
"set my pathname; return nil if not a valid path; self otherwise"
pathName := dirName.
- (dirName startsWith:'/') ifFalse:[
+ (dirName startsWith:OperatingSystem fileSeparator) ifFalse:[
lazy := true
] ifTrue:[
(dirName includes:$.) ifTrue:[
@@ -226,7 +227,7 @@
|aStream command shortPathName fullPathName|
- (pathName = '/') ifTrue:[
+ (pathName = OperatingSystem fileSeparator asString) ifTrue:[
lazy := false.
^ self
].
@@ -299,16 +300,12 @@
(newName = '.') ifFalse:[
(newName = '..') ifFalse:[
- ((newName at:1) == $/) ifTrue:[
+ ((newName at:1) == OperatingSystem fileSeparator) ifTrue:[
realName := newName copyFrom:2
] ifFalse:[
realName := newName
].
- (realName startsWith:'/') ifTrue:[
- ^ OperatingSystem createDirectory:realName
- ] ifFalse:[
- ^ OperatingSystem createDirectory:(pathName , '/' , realName)
- ]
+ ^ OperatingSystem createDirectory:(self class fullPathNameOf:realName in:pathName)
]
].
^ false
@@ -317,10 +314,7 @@
removeFile:fileName
"remove the file 'fileName' from myself; return true if successful"
- (fileName startsWith:'/') ifTrue:[
- ^ OperatingSystem removeFile:fileName
- ].
- ^ OperatingSystem removeFile:(pathName , '/' , fileName)
+ ^ OperatingSystem removeFile:(self class fullPathNameOf:fileName in:pathName).
!
removeDirectory:dirName
@@ -328,15 +322,11 @@
If the directory is not empty, the containing files/directories are also
removed."
- |absPath|
+ |path|
- (dirName startsWith:'/') ifTrue:[
- absPath := dirName
- ] ifFalse:[
- absPath := pathName , '/' , dirName
- ].
- (OperatingSystem removeDirectory:absPath) ifTrue:[^ true].
- ^ OperatingSystem recursiveRemoveDirectory:absPath
+ path := self class fullPathNameOf:dirName in:pathName.
+ (OperatingSystem removeDirectory:path) ifTrue:[^ true].
+ ^ OperatingSystem recursiveRemoveDirectory:path
!
remove:aFileOrDirectoryName
@@ -344,11 +334,7 @@
|path|
- (aFileOrDirectoryName startsWith:'/') ifTrue:[
- path := aFileOrDirectoryName
- ] ifFalse:[
- path := (pathName , '/' , aFileOrDirectoryName)
- ].
+ path := self class fullPathNameOf:aFileOrDirectoryName in:pathName.
(OperatingSystem isDirectory:path) ifTrue:[
^ OperatingSystem removeDirectory:path
].
@@ -360,16 +346,8 @@
|path1 path2|
- (oldFileName startsWith:'/') ifTrue:[
- path1 := oldFileName
- ] ifFalse:[
- path1 := (pathName , '/' , oldFileName)
- ].
- (newFileName startsWith:'/') ifTrue:[
- path2 := newFileName
- ] ifFalse:[
- path2 := (pathName , '/' , newFileName)
- ].
+ path1 := self class fullPathNameOf:oldFileName in:pathName.
+ path2 := self class fullPathNameOf:newFileName in:pathName.
^ OperatingSystem linkFile:path1 to:path2
!
@@ -378,17 +356,18 @@
|path1 path2|
- (oldFileName startsWith:'/') ifTrue:[
- path1 := oldFileName
- ] ifFalse:[
- path1 := (pathName , '/' , oldFileName)
+ path1 := self class fullPathNameOf:oldFileName in:pathName.
+ path2 := self class fullPathNameOf:newFileName in:pathName.
+ ^ OperatingSystem renameFile:path1 to:path2
+! !
+
+!FileDirectory class methodsFor:'private'!
+
+fullPathNameOf:name in:path
+ (name startsWith:OperatingSystem fileSeparator) ifTrue:[
+ ^ name
].
- (newFileName startsWith:'/') ifTrue:[
- path2 := newFileName
- ] ifFalse:[
- path2 := (pathName , '/' , newFileName)
- ].
- ^ OperatingSystem renameFile:path1 to:path2
+ ^ path , OperatingSystem fileSeparator asString , name
! !
!FileDirectory methodsFor:'queries'!
@@ -403,7 +382,11 @@
"return true if this directory exists"
^ OperatingSystem isDirectory:pathName
- "(FileDirectory directoryNamed:'fooBar') exists"
+
+ "
+ (FileDirectory directoryNamed:'fooBar') exists
+ (FileDirectory directoryNamed:'/tmp') exists
+ "
!
isEmpty
@@ -420,19 +403,13 @@
"return an array filled with file info for the file 'aFileName';
return nil if such a file does not exist"
- (name startsWith:'/') ifTrue:[
- ^ OperatingSystem infoOf:name
- ].
- ^ OperatingSystem infoOf:(pathName , '/' , name)
+ ^ OperatingSystem infoOf:(self class fullPathNameOf:name in:pathName)
!
timeOfLastChange:name
"return the timeStamp of a file in myself"
- (name startsWith:'/') ifTrue:[
- ^ OperatingSystem timeOfLastChange:name
- ].
- ^ OperatingSystem timeOfLastChange:(pathName , '/' , name)
+ ^ OperatingSystem timeOfLastChange:(self class fullPathNameOf:name in:pathName)
!
timeOfLastChange
@@ -441,78 +418,53 @@
^ OperatingSystem timeOfLastChange:pathName
!
-accessModeOf:aFileName
+accessModeOf:name
"return the access-mode bits (rwxrwxrwx) of a file in myself"
- (aFileName startsWith:'/') ifTrue:[
- ^ OperatingSystem accessModeOf:aFileName
- ].
- ^ OperatingSystem accessModeOf:(pathName , '/' , aFileName)
+ ^ OperatingSystem accessModeOf:(self class fullPathNameOf:name in:pathName)
!
-changeAccessModeOf:aFileName to:modeBits
+changeAccessModeOf:name to:modeBits
"set the access-mode bits (rwxrwxrwx) of a file in myself"
- (aFileName startsWith:'/') ifTrue:[
- ^ OperatingSystem changeAccessModeOf:aFileName
- to:modeBits
- ].
- ^ OperatingSystem changeAccessModeOf:(pathName , '/' , aFileName)
+ ^ OperatingSystem changeAccessModeOf:(self class fullPathNameOf:name in:pathName)
to:modeBits
!
-typeOf:aFileName
+typeOf:name
"return the symbolic type of a file in myself"
- (aFileName startsWith:'/') ifTrue:[
- ^ OperatingSystem typeOf:aFileName
- ].
- ^ OperatingSystem typeOf:(pathName , '/' , aFileName)
+ ^ OperatingSystem typeOf:(self class fullPathNameOf:name in:pathName)
!
exists:name
"return true, if the given name exists in myself"
- (name startsWith:'/') ifTrue:[
- ^ OperatingSystem isValidPath:name
- ].
- ^ OperatingSystem isValidPath:(pathName , '/' , name)
+ ^ OperatingSystem isValidPath:(self class fullPathNameOf:name in:pathName)
!
isDirectory:name
"return true, if the given name is that of a directory in myself"
- (name startsWith:'/') ifTrue:[
- ^ OperatingSystem isDirectory:name
- ].
- ^ OperatingSystem isDirectory:(pathName , '/' , name)
+ ^ OperatingSystem isDirectory:(self class fullPathNameOf:name in:pathName)
!
isReadable:name
"return true, if the given file is readable"
- (name startsWith:'/') ifTrue:[
- ^ OperatingSystem isReadable:name
- ].
- ^ OperatingSystem isReadable:(pathName , '/' , name)
+ ^ OperatingSystem isReadable:(self class fullPathNameOf:name in:pathName)
!
isWritable:name
"return true, if the given file is readable"
- (name startsWith:'/') ifTrue:[
- ^ OperatingSystem isWritable:name
- ].
- ^ OperatingSystem isWritable:(pathName , '/' , name)
+ ^ OperatingSystem isWritable:(self class fullPathNameOf:name in:pathName)
!
isExecutable:name
"return true, if the given file is executable"
- (name startsWith:'/') ifTrue:[
- ^ OperatingSystem isExecutable:name
- ].
- ^ OperatingSystem isExecutable:(pathName , '/' , name)
+ ^ OperatingSystem isExecutable:(self class fullPathNameOf:name in:pathName)
! !
!FileDirectory methodsFor:'printing & storing'!
--- a/FileDirectory.st Mon Oct 10 01:29:01 1994 +0100
+++ b/FileDirectory.st Mon Oct 10 01:29:28 1994 +0100
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/FileDirectory.st,v 1.11 1994-08-05 00:54:45 claus Exp $
+$Header: /cvs/stx/stx/libbasic/FileDirectory.st,v 1.12 1994-10-10 00:26:00 claus Exp $
'!
!FileDirectory class methodsFor:'documentation'!
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/FileDirectory.st,v 1.11 1994-08-05 00:54:45 claus Exp $
+$Header: /cvs/stx/stx/libbasic/FileDirectory.st,v 1.12 1994-10-10 00:26:00 claus Exp $
"
!
@@ -72,7 +72,7 @@
rootDirectory
"create and return a new FileDirectory for the root directory"
- ^ (self basicNew) pathName:'/'
+ ^ (self basicNew) pathName:(OperatingSystem fileSeparator asString)
"
FileDirectory rootDirectory contents
@@ -110,9 +110,10 @@
"create and return a new FileDirectory for the directory with given name
in another FileDirectory"
- |baseName|
+ |baseName sep|
- ((name at:1) == $/) ifTrue:[
+ sep := OperatingSystem fileSeparator.
+ ((name at:1) == sep) ifTrue:[
^ self directoryNamed:name
].
(aFileDirectory isKindOf:FileDirectory) ifTrue:[
@@ -127,9 +128,9 @@
"
(name = '.') ifTrue:[^ aFileDirectory].
- (baseName = '/') ifFalse:[
- (baseName endsWith:'/') ifFalse:[
- baseName := baseName , '/'
+ (baseName = sep asString) ifFalse:[
+ (baseName endsWith:sep) ifFalse:[
+ baseName := baseName copyWith:sep
]
].
^ (self basicNew) pathName:(baseName , name)
@@ -164,7 +165,7 @@
"set my pathname; return nil if not a valid path; self otherwise"
pathName := dirName.
- (dirName startsWith:'/') ifFalse:[
+ (dirName startsWith:OperatingSystem fileSeparator) ifFalse:[
lazy := true
] ifTrue:[
(dirName includes:$.) ifTrue:[
@@ -226,7 +227,7 @@
|aStream command shortPathName fullPathName|
- (pathName = '/') ifTrue:[
+ (pathName = OperatingSystem fileSeparator asString) ifTrue:[
lazy := false.
^ self
].
@@ -299,16 +300,12 @@
(newName = '.') ifFalse:[
(newName = '..') ifFalse:[
- ((newName at:1) == $/) ifTrue:[
+ ((newName at:1) == OperatingSystem fileSeparator) ifTrue:[
realName := newName copyFrom:2
] ifFalse:[
realName := newName
].
- (realName startsWith:'/') ifTrue:[
- ^ OperatingSystem createDirectory:realName
- ] ifFalse:[
- ^ OperatingSystem createDirectory:(pathName , '/' , realName)
- ]
+ ^ OperatingSystem createDirectory:(self class fullPathNameOf:realName in:pathName)
]
].
^ false
@@ -317,10 +314,7 @@
removeFile:fileName
"remove the file 'fileName' from myself; return true if successful"
- (fileName startsWith:'/') ifTrue:[
- ^ OperatingSystem removeFile:fileName
- ].
- ^ OperatingSystem removeFile:(pathName , '/' , fileName)
+ ^ OperatingSystem removeFile:(self class fullPathNameOf:fileName in:pathName).
!
removeDirectory:dirName
@@ -328,15 +322,11 @@
If the directory is not empty, the containing files/directories are also
removed."
- |absPath|
+ |path|
- (dirName startsWith:'/') ifTrue:[
- absPath := dirName
- ] ifFalse:[
- absPath := pathName , '/' , dirName
- ].
- (OperatingSystem removeDirectory:absPath) ifTrue:[^ true].
- ^ OperatingSystem recursiveRemoveDirectory:absPath
+ path := self class fullPathNameOf:dirName in:pathName.
+ (OperatingSystem removeDirectory:path) ifTrue:[^ true].
+ ^ OperatingSystem recursiveRemoveDirectory:path
!
remove:aFileOrDirectoryName
@@ -344,11 +334,7 @@
|path|
- (aFileOrDirectoryName startsWith:'/') ifTrue:[
- path := aFileOrDirectoryName
- ] ifFalse:[
- path := (pathName , '/' , aFileOrDirectoryName)
- ].
+ path := self class fullPathNameOf:aFileOrDirectoryName in:pathName.
(OperatingSystem isDirectory:path) ifTrue:[
^ OperatingSystem removeDirectory:path
].
@@ -360,16 +346,8 @@
|path1 path2|
- (oldFileName startsWith:'/') ifTrue:[
- path1 := oldFileName
- ] ifFalse:[
- path1 := (pathName , '/' , oldFileName)
- ].
- (newFileName startsWith:'/') ifTrue:[
- path2 := newFileName
- ] ifFalse:[
- path2 := (pathName , '/' , newFileName)
- ].
+ path1 := self class fullPathNameOf:oldFileName in:pathName.
+ path2 := self class fullPathNameOf:newFileName in:pathName.
^ OperatingSystem linkFile:path1 to:path2
!
@@ -378,17 +356,18 @@
|path1 path2|
- (oldFileName startsWith:'/') ifTrue:[
- path1 := oldFileName
- ] ifFalse:[
- path1 := (pathName , '/' , oldFileName)
+ path1 := self class fullPathNameOf:oldFileName in:pathName.
+ path2 := self class fullPathNameOf:newFileName in:pathName.
+ ^ OperatingSystem renameFile:path1 to:path2
+! !
+
+!FileDirectory class methodsFor:'private'!
+
+fullPathNameOf:name in:path
+ (name startsWith:OperatingSystem fileSeparator) ifTrue:[
+ ^ name
].
- (newFileName startsWith:'/') ifTrue:[
- path2 := newFileName
- ] ifFalse:[
- path2 := (pathName , '/' , newFileName)
- ].
- ^ OperatingSystem renameFile:path1 to:path2
+ ^ path , OperatingSystem fileSeparator asString , name
! !
!FileDirectory methodsFor:'queries'!
@@ -403,7 +382,11 @@
"return true if this directory exists"
^ OperatingSystem isDirectory:pathName
- "(FileDirectory directoryNamed:'fooBar') exists"
+
+ "
+ (FileDirectory directoryNamed:'fooBar') exists
+ (FileDirectory directoryNamed:'/tmp') exists
+ "
!
isEmpty
@@ -420,19 +403,13 @@
"return an array filled with file info for the file 'aFileName';
return nil if such a file does not exist"
- (name startsWith:'/') ifTrue:[
- ^ OperatingSystem infoOf:name
- ].
- ^ OperatingSystem infoOf:(pathName , '/' , name)
+ ^ OperatingSystem infoOf:(self class fullPathNameOf:name in:pathName)
!
timeOfLastChange:name
"return the timeStamp of a file in myself"
- (name startsWith:'/') ifTrue:[
- ^ OperatingSystem timeOfLastChange:name
- ].
- ^ OperatingSystem timeOfLastChange:(pathName , '/' , name)
+ ^ OperatingSystem timeOfLastChange:(self class fullPathNameOf:name in:pathName)
!
timeOfLastChange
@@ -441,78 +418,53 @@
^ OperatingSystem timeOfLastChange:pathName
!
-accessModeOf:aFileName
+accessModeOf:name
"return the access-mode bits (rwxrwxrwx) of a file in myself"
- (aFileName startsWith:'/') ifTrue:[
- ^ OperatingSystem accessModeOf:aFileName
- ].
- ^ OperatingSystem accessModeOf:(pathName , '/' , aFileName)
+ ^ OperatingSystem accessModeOf:(self class fullPathNameOf:name in:pathName)
!
-changeAccessModeOf:aFileName to:modeBits
+changeAccessModeOf:name to:modeBits
"set the access-mode bits (rwxrwxrwx) of a file in myself"
- (aFileName startsWith:'/') ifTrue:[
- ^ OperatingSystem changeAccessModeOf:aFileName
- to:modeBits
- ].
- ^ OperatingSystem changeAccessModeOf:(pathName , '/' , aFileName)
+ ^ OperatingSystem changeAccessModeOf:(self class fullPathNameOf:name in:pathName)
to:modeBits
!
-typeOf:aFileName
+typeOf:name
"return the symbolic type of a file in myself"
- (aFileName startsWith:'/') ifTrue:[
- ^ OperatingSystem typeOf:aFileName
- ].
- ^ OperatingSystem typeOf:(pathName , '/' , aFileName)
+ ^ OperatingSystem typeOf:(self class fullPathNameOf:name in:pathName)
!
exists:name
"return true, if the given name exists in myself"
- (name startsWith:'/') ifTrue:[
- ^ OperatingSystem isValidPath:name
- ].
- ^ OperatingSystem isValidPath:(pathName , '/' , name)
+ ^ OperatingSystem isValidPath:(self class fullPathNameOf:name in:pathName)
!
isDirectory:name
"return true, if the given name is that of a directory in myself"
- (name startsWith:'/') ifTrue:[
- ^ OperatingSystem isDirectory:name
- ].
- ^ OperatingSystem isDirectory:(pathName , '/' , name)
+ ^ OperatingSystem isDirectory:(self class fullPathNameOf:name in:pathName)
!
isReadable:name
"return true, if the given file is readable"
- (name startsWith:'/') ifTrue:[
- ^ OperatingSystem isReadable:name
- ].
- ^ OperatingSystem isReadable:(pathName , '/' , name)
+ ^ OperatingSystem isReadable:(self class fullPathNameOf:name in:pathName)
!
isWritable:name
"return true, if the given file is readable"
- (name startsWith:'/') ifTrue:[
- ^ OperatingSystem isWritable:name
- ].
- ^ OperatingSystem isWritable:(pathName , '/' , name)
+ ^ OperatingSystem isWritable:(self class fullPathNameOf:name in:pathName)
!
isExecutable:name
"return true, if the given file is executable"
- (name startsWith:'/') ifTrue:[
- ^ OperatingSystem isExecutable:name
- ].
- ^ OperatingSystem isExecutable:(pathName , '/' , name)
+ ^ OperatingSystem isExecutable:(self class fullPathNameOf:name in:pathName)
! !
!FileDirectory methodsFor:'printing & storing'!
--- a/FileStr.st Mon Oct 10 01:29:01 1994 +0100
+++ b/FileStr.st Mon Oct 10 01:29:28 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -12,16 +12,16 @@
ExternalStream subclass:#FileStream
instanceVariableNames:'pathName'
- classVariableNames:''
+ classVariableNames:'OpenErrorSignal'
poolDictionaries:''
category:'Streams-External'
!
FileStream comment:'
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Attic/FileStr.st,v 1.14 1994-08-05 00:54:46 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/FileStr.st,v 1.15 1994-10-10 00:26:04 claus Exp $
'!
!FileStream class methodsFor:'documentation'!
@@ -29,7 +29,7 @@
copyright
"
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Attic/FileStr.st,v 1.14 1994-08-05 00:54:46 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/FileStr.st,v 1.15 1994-10-10 00:26:04 claus Exp $
"
!
@@ -88,6 +88,18 @@
%}
+!FileStream class methodsFor:'initialization'!
+
+initialize
+ OpenErrorSignal isNil ifTrue:[
+ super initialize.
+
+ OpenErrorSignal := StreamErrorSignal newSignalMayProceed:true.
+ OpenErrorSignal nameClass:self message:#openErrorSignal.
+ OpenErrorSignal notifierString:'open error'.
+ ].
+! !
+
!FileStream class methodsFor:'instance creation'!
newFileNamed:filename
@@ -179,7 +191,7 @@
stream := self oldFileNamed:filename.
stream isNil ifTrue:[
- stream := self newFileNamed:filename
+ stream := self newFileNamed:filename
].
^ stream
!
@@ -193,7 +205,7 @@
stream := self oldFileNamed:filename in:aDirectory.
stream isNil ifTrue:[
- stream := self newFileNamed:filename in:aDirectory
+ stream := self newFileNamed:filename in:aDirectory
].
^ stream
!
@@ -261,6 +273,26 @@
^ newStream
! !
+!FileStream methodsFor:'error handling'!
+
+errorOpen
+ "report an error, that the stream is already opened"
+
+ ^ StreamErrorSignal
+ raiseRequestWith:self
+ errorString:(self class name , ' is already open')
+!
+
+openError
+ "report an error, that file open failed"
+
+ LastErrorNumber := lastErrorNumber.
+^nil.
+ ^ OpenErrorSignal
+ raiseRequestWith:self
+ errorString:('error on open: ' , self lastErrorString)
+! !
+
!FileStream methodsFor:'accessing'!
store:something
@@ -278,8 +310,8 @@
lastIndex := 0.
index := path indexOf:$/.
[index ~~ 0] whileTrue:[
- lastIndex := index.
- index := path indexOf:$/ startingAt:(index + 1)
+ lastIndex := index.
+ index := path indexOf:$/ startingAt:(index + 1)
].
(lastIndex == 0) ifTrue:[^ '.'].
(lastIndex == 1) ifTrue:[^ '/'].
@@ -293,11 +325,11 @@
lastIndex := 1.
[true] whileTrue:[
- index := pathName indexOf:$/ startingAt:lastIndex.
- (index == 0) ifTrue:[
- ^ pathName copyFrom:lastIndex
- ].
- lastIndex := index + 1
+ index := pathName indexOf:$/ startingAt:lastIndex.
+ (index == 0) ifTrue:[
+ ^ pathName copyFrom:lastIndex
+ ].
+ lastIndex := index + 1
]
!
@@ -319,14 +351,14 @@
"set the pathname starting at aDirectory, a FileDirectory"
((filename at:1) == $/) ifTrue:[
- "filename may not start with a '/'"
- pathName := nil
+ "filename may not start with a '/'"
+ pathName := nil
] ifFalse:[
- pathName := aDirectory pathName.
- (pathName endsWith:'/') ifFalse:[
- pathName := pathName , '/'
- ].
- pathName := pathName , filename
+ pathName := aDirectory pathName.
+ (pathName endsWith:'/') ifFalse:[
+ pathName := pathName , '/'
+ ].
+ pathName := pathName , filename
]
!
@@ -335,12 +367,12 @@
pathName isNil ifTrue:[^nil].
(mode == #readonly) ifTrue: [
- didWrite := false.
- ^ self openWithMode:'r'
+ didWrite := false.
+ ^ self openWithMode:'r'
].
(mode == #writeonly) ifTrue: [
- didWrite := true.
- ^ self openWithMode:'w'
+ didWrite := true.
+ ^ self openWithMode:'w'
].
^ self openWithMode:'r+'
!
@@ -349,44 +381,44 @@
"open the file; openmode is the string defining the way to open"
|retVal|
+
+ filePointer notNil ifTrue:[^ self errorOpen].
%{
FILE *f;
OBJ path;
- extern OBJ Filename;
extern errno;
if (_INST(filePointer) == nil) {
- path = _INST(pathName);
- if (path != nil
- && ((_qClass(path)==String) || (_qClass(path) == Filename))) {
- do {
+ path = _INST(pathName);
+ if (_isNonNilObject(path) && (_qClass(path)==String)) {
+ do {
#ifdef LINUX
- /* LINUX returns a non-NULL f even when interrupted */
- errno = 0;
- f = (FILE *) fopen((char *) _stringVal(path), (char *) _stringVal(openmode));
- if (errno == EINTR)
- f = NULL;
+ /* LINUX returns a non-NULL f even when interrupted */
+ errno = 0;
+ f = (FILE *) fopen((char *) _stringVal(path), (char *) _stringVal(openmode));
+ if (errno == EINTR)
+ f = NULL;
#else
- f = (FILE *) fopen((char *) _stringVal(path), (char *) _stringVal(openmode));
+ f = (FILE *) fopen((char *) _stringVal(path), (char *) _stringVal(openmode));
#endif
- } while ((f == NULL) && (errno == EINTR));
- if (f == NULL) {
- ExternalStream_LastErrorNumber = _MKSMALLINT(errno);
- _INST(position) = nil;
- } else {
- _INST(filePointer) = MKOBJ((int)f);
- _INST(position) = _MKSMALLINT(1);
- retVal = self;
- }
- }
+ } while ((f == NULL) && (errno == EINTR));
+ if (f == NULL) {
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ _INST(position) = nil;
+ } else {
+ _INST(filePointer) = MKOBJ((int)f);
+ _INST(position) = _MKSMALLINT(1);
+ retVal = self;
+ }
+ }
}
-%}
-.
+%}.
retVal notNil ifTrue:[
- buffered := true. "default is buffered"
- Lobby register:self
+ buffered := true. "default is buffered"
+ Lobby register:self
].
+ lastErrorNumber notNil ifTrue:[^ self openError].
^ retVal
!
@@ -451,17 +483,17 @@
"sent after snapin to reopen streams"
filePointer notNil ifTrue:[
- "it was open, when snapped-out"
- filePointer := nil.
- Lobby unregister:self.
- self open.
- filePointer isNil ifTrue:[
- "this happens, if after a restart, the file is no longer accessable ..."
+ "it was open, when snapped-out"
+ filePointer := nil.
+ Lobby unregister:self.
+ self open.
+ filePointer isNil ifTrue:[
+ "this happens, if after a restart, the file is no longer accessable ..."
- ('could not reopen file: ', pathName) errorPrintNewline.
- ] ifFalse:[
- self position:position.
- ]
+ ('could not reopen file: ', pathName) errorPrintNewline.
+ ] ifFalse:[
+ self position:position.
+ ]
]
! !
@@ -477,10 +509,10 @@
int size;
if (_INST(filePointer) != nil) {
- f = (FILE *)MKFD(_INST(filePointer));
- if ((size = filesize(fileno(f))) >= 0) {
- RETURN ( _MKSMALLINT(size) );
- }
+ f = (FILE *)MKFD(_INST(filePointer));
+ if ((size = filesize(fileno(f))) >= 0) {
+ RETURN ( _MKSMALLINT(size) );
+ }
}
#else
FILE *f;
@@ -490,27 +522,28 @@
int fd;
if (_INST(filePointer) != nil) {
- f = (FILE *)MKFD(_INST(filePointer));
- fd = fileno(f);
- do {
- ret = fstat(fd, &buf);
- } while ((ret < 0) && (errno == EINTR));
- if (ret >= 0) {
- RETURN ( _MKSMALLINT(buf.st_size) );
- }
- ExternalStream_LastErrorNumber = _MKSMALLINT(errno);
+ f = (FILE *)MKFD(_INST(filePointer));
+ fd = fileno(f);
+ do {
+ ret = fstat(fd, &buf);
+ } while ((ret < 0) && (errno == EINTR));
+ if (ret >= 0) {
+ RETURN ( _MKSMALLINT(buf.st_size) );
+ }
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
}
#endif
-%}
-.
+%}.
+
"could add a fall-back here:
- oldPosition := self position.
- self setToEnd.
- sz := self position.
- self position:oldPosition.
- ^ sz
+ oldPosition := self position.
+ self setToEnd.
+ sz := self position.
+ self position:oldPosition.
+ ^ sz
"
+ lastErrorNumber notNil ifTrue:[^ self ioError].
filePointer isNil ifTrue:[^ self errorNotOpen].
^ self primitiveFailed
!
@@ -526,24 +559,24 @@
extern errno;
if (_INST(filePointer) != nil) {
- f = (FILE *)MKFD(_INST(filePointer));
- do {
- if (_INST(buffered) == true) {
- currentPosition = (long) ftell(f);
- } else {
- currentPosition = (long) lseek(fileno(f), 0L, SEEK_CUR);
- }
- } while ((currentPosition < 0) && (errno == EINTR));
- if (currentPosition >= 0) {
- /*
- * notice: Smalltalk index starts at 1
- */
- RETURN ( _MKSMALLINT(currentPosition + 1) );
- }
- ExternalStream_LastErrorNumber = _MKSMALLINT(errno);
+ f = (FILE *)MKFD(_INST(filePointer));
+ do {
+ if (_INST(buffered) == true) {
+ currentPosition = (long) ftell(f);
+ } else {
+ currentPosition = (long) lseek(fileno(f), 0L, SEEK_CUR);
+ }
+ } while ((currentPosition < 0) && (errno == EINTR));
+ if (currentPosition >= 0) {
+ /*
+ * notice: Smalltalk index starts at 1
+ */
+ RETURN ( _MKSMALLINT(currentPosition + 1) );
+ }
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
}
-%}
-.
+%}.
+ lastErrorNumber notNil ifTrue:[^ self ioError].
filePointer isNil ifTrue:[^ self errorNotOpen].
^ self primitiveFailed
!
@@ -558,31 +591,31 @@
extern errno;
if (_INST(filePointer) != nil) {
- if (_isSmallInteger(newPos)) {
- f = (FILE *)MKFD(_INST(filePointer));
- /*
- * notice: Smalltalk index starts at 1
- */
- do {
- if (_INST(buffered) == true) {
- ret = fseek(f, (long) (_intVal(newPos) - 1), SEEK_SET);
- } else {
- ret = (long) lseek(fileno(f), (long)(_intVal(newPos) - 1), SEEK_SET);
- }
- } while ((ret < 0) && (errno == EINTR));
- if (ret >= 0) {
- _INST(position) = newPos;
- /*
- * just to make certain ...
- */
- _INST(hitEOF) = false;
- RETURN ( self );
- }
- ExternalStream_LastErrorNumber = _MKSMALLINT(errno);
- }
+ if (_isSmallInteger(newPos)) {
+ f = (FILE *)MKFD(_INST(filePointer));
+ /*
+ * notice: Smalltalk index starts at 1
+ */
+ do {
+ if (_INST(buffered) == true) {
+ ret = fseek(f, (long) (_intVal(newPos) - 1), SEEK_SET);
+ } else {
+ ret = (long) lseek(fileno(f), (long)(_intVal(newPos) - 1), SEEK_SET);
+ }
+ } while ((ret < 0) && (errno == EINTR));
+ if (ret >= 0) {
+ _INST(position) = newPos;
+ /*
+ * just to make certain ...
+ */
+ _INST(hitEOF) = false;
+ RETURN ( self );
+ }
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ }
}
-%}
-.
+%}.
+ lastErrorNumber notNil ifTrue:[^ self ioError].
filePointer isNil ifTrue:[^ self errorNotOpen].
^ self primitiveFailed
!
@@ -596,22 +629,22 @@
extern errno;
if (_INST(filePointer) != nil) {
- f = (FILE *)MKFD(_INST(filePointer));
- _INST(position) = nil;
- do {
- if (_INST(buffered) == true) {
- ret = fseek(f, 0L, SEEK_END);
- } else {
- ret = (long)lseek(fileno(f), 0L, SEEK_END);
- }
- } while ((ret < 0) && (errno == EINTR));
- if (ret >= 0) {
- RETURN ( self );
- }
- ExternalStream_LastErrorNumber = _MKSMALLINT(errno);
+ f = (FILE *)MKFD(_INST(filePointer));
+ _INST(position) = nil;
+ do {
+ if (_INST(buffered) == true) {
+ ret = fseek(f, 0L, SEEK_END);
+ } else {
+ ret = (long)lseek(fileno(f), 0L, SEEK_END);
+ }
+ } while ((ret < 0) && (errno == EINTR));
+ if (ret >= 0) {
+ RETURN ( self );
+ }
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
}
-%}
-.
+%}.
+ lastErrorNumber notNil ifTrue:[^ self ioError].
filePointer isNil ifTrue:[^ self errorNotOpen].
DemoMode ifTrue:[^ self warn:'no save in Demo mode'].
^ self primitiveFailed
@@ -638,8 +671,8 @@
aStream nextPutAll:'(FileStream oldFileNamed:'.
aStream nextPutAll:pathName.
(self position ~~ 1) ifTrue:[
- aStream nextPutAll:'; position:'.
- self position storeOn:aStream
+ aStream nextPutAll:'; position:'.
+ self position storeOn:aStream
].
aStream nextPut:$)
! !
--- a/FileStream.st Mon Oct 10 01:29:01 1994 +0100
+++ b/FileStream.st Mon Oct 10 01:29:28 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -12,16 +12,16 @@
ExternalStream subclass:#FileStream
instanceVariableNames:'pathName'
- classVariableNames:''
+ classVariableNames:'OpenErrorSignal'
poolDictionaries:''
category:'Streams-External'
!
FileStream comment:'
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/FileStream.st,v 1.14 1994-08-05 00:54:46 claus Exp $
+$Header: /cvs/stx/stx/libbasic/FileStream.st,v 1.15 1994-10-10 00:26:04 claus Exp $
'!
!FileStream class methodsFor:'documentation'!
@@ -29,7 +29,7 @@
copyright
"
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/FileStream.st,v 1.14 1994-08-05 00:54:46 claus Exp $
+$Header: /cvs/stx/stx/libbasic/FileStream.st,v 1.15 1994-10-10 00:26:04 claus Exp $
"
!
@@ -88,6 +88,18 @@
%}
+!FileStream class methodsFor:'initialization'!
+
+initialize
+ OpenErrorSignal isNil ifTrue:[
+ super initialize.
+
+ OpenErrorSignal := StreamErrorSignal newSignalMayProceed:true.
+ OpenErrorSignal nameClass:self message:#openErrorSignal.
+ OpenErrorSignal notifierString:'open error'.
+ ].
+! !
+
!FileStream class methodsFor:'instance creation'!
newFileNamed:filename
@@ -179,7 +191,7 @@
stream := self oldFileNamed:filename.
stream isNil ifTrue:[
- stream := self newFileNamed:filename
+ stream := self newFileNamed:filename
].
^ stream
!
@@ -193,7 +205,7 @@
stream := self oldFileNamed:filename in:aDirectory.
stream isNil ifTrue:[
- stream := self newFileNamed:filename in:aDirectory
+ stream := self newFileNamed:filename in:aDirectory
].
^ stream
!
@@ -261,6 +273,26 @@
^ newStream
! !
+!FileStream methodsFor:'error handling'!
+
+errorOpen
+ "report an error, that the stream is already opened"
+
+ ^ StreamErrorSignal
+ raiseRequestWith:self
+ errorString:(self class name , ' is already open')
+!
+
+openError
+ "report an error, that file open failed"
+
+ LastErrorNumber := lastErrorNumber.
+^nil.
+ ^ OpenErrorSignal
+ raiseRequestWith:self
+ errorString:('error on open: ' , self lastErrorString)
+! !
+
!FileStream methodsFor:'accessing'!
store:something
@@ -278,8 +310,8 @@
lastIndex := 0.
index := path indexOf:$/.
[index ~~ 0] whileTrue:[
- lastIndex := index.
- index := path indexOf:$/ startingAt:(index + 1)
+ lastIndex := index.
+ index := path indexOf:$/ startingAt:(index + 1)
].
(lastIndex == 0) ifTrue:[^ '.'].
(lastIndex == 1) ifTrue:[^ '/'].
@@ -293,11 +325,11 @@
lastIndex := 1.
[true] whileTrue:[
- index := pathName indexOf:$/ startingAt:lastIndex.
- (index == 0) ifTrue:[
- ^ pathName copyFrom:lastIndex
- ].
- lastIndex := index + 1
+ index := pathName indexOf:$/ startingAt:lastIndex.
+ (index == 0) ifTrue:[
+ ^ pathName copyFrom:lastIndex
+ ].
+ lastIndex := index + 1
]
!
@@ -319,14 +351,14 @@
"set the pathname starting at aDirectory, a FileDirectory"
((filename at:1) == $/) ifTrue:[
- "filename may not start with a '/'"
- pathName := nil
+ "filename may not start with a '/'"
+ pathName := nil
] ifFalse:[
- pathName := aDirectory pathName.
- (pathName endsWith:'/') ifFalse:[
- pathName := pathName , '/'
- ].
- pathName := pathName , filename
+ pathName := aDirectory pathName.
+ (pathName endsWith:'/') ifFalse:[
+ pathName := pathName , '/'
+ ].
+ pathName := pathName , filename
]
!
@@ -335,12 +367,12 @@
pathName isNil ifTrue:[^nil].
(mode == #readonly) ifTrue: [
- didWrite := false.
- ^ self openWithMode:'r'
+ didWrite := false.
+ ^ self openWithMode:'r'
].
(mode == #writeonly) ifTrue: [
- didWrite := true.
- ^ self openWithMode:'w'
+ didWrite := true.
+ ^ self openWithMode:'w'
].
^ self openWithMode:'r+'
!
@@ -349,44 +381,44 @@
"open the file; openmode is the string defining the way to open"
|retVal|
+
+ filePointer notNil ifTrue:[^ self errorOpen].
%{
FILE *f;
OBJ path;
- extern OBJ Filename;
extern errno;
if (_INST(filePointer) == nil) {
- path = _INST(pathName);
- if (path != nil
- && ((_qClass(path)==String) || (_qClass(path) == Filename))) {
- do {
+ path = _INST(pathName);
+ if (_isNonNilObject(path) && (_qClass(path)==String)) {
+ do {
#ifdef LINUX
- /* LINUX returns a non-NULL f even when interrupted */
- errno = 0;
- f = (FILE *) fopen((char *) _stringVal(path), (char *) _stringVal(openmode));
- if (errno == EINTR)
- f = NULL;
+ /* LINUX returns a non-NULL f even when interrupted */
+ errno = 0;
+ f = (FILE *) fopen((char *) _stringVal(path), (char *) _stringVal(openmode));
+ if (errno == EINTR)
+ f = NULL;
#else
- f = (FILE *) fopen((char *) _stringVal(path), (char *) _stringVal(openmode));
+ f = (FILE *) fopen((char *) _stringVal(path), (char *) _stringVal(openmode));
#endif
- } while ((f == NULL) && (errno == EINTR));
- if (f == NULL) {
- ExternalStream_LastErrorNumber = _MKSMALLINT(errno);
- _INST(position) = nil;
- } else {
- _INST(filePointer) = MKOBJ((int)f);
- _INST(position) = _MKSMALLINT(1);
- retVal = self;
- }
- }
+ } while ((f == NULL) && (errno == EINTR));
+ if (f == NULL) {
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ _INST(position) = nil;
+ } else {
+ _INST(filePointer) = MKOBJ((int)f);
+ _INST(position) = _MKSMALLINT(1);
+ retVal = self;
+ }
+ }
}
-%}
-.
+%}.
retVal notNil ifTrue:[
- buffered := true. "default is buffered"
- Lobby register:self
+ buffered := true. "default is buffered"
+ Lobby register:self
].
+ lastErrorNumber notNil ifTrue:[^ self openError].
^ retVal
!
@@ -451,17 +483,17 @@
"sent after snapin to reopen streams"
filePointer notNil ifTrue:[
- "it was open, when snapped-out"
- filePointer := nil.
- Lobby unregister:self.
- self open.
- filePointer isNil ifTrue:[
- "this happens, if after a restart, the file is no longer accessable ..."
+ "it was open, when snapped-out"
+ filePointer := nil.
+ Lobby unregister:self.
+ self open.
+ filePointer isNil ifTrue:[
+ "this happens, if after a restart, the file is no longer accessable ..."
- ('could not reopen file: ', pathName) errorPrintNewline.
- ] ifFalse:[
- self position:position.
- ]
+ ('could not reopen file: ', pathName) errorPrintNewline.
+ ] ifFalse:[
+ self position:position.
+ ]
]
! !
@@ -477,10 +509,10 @@
int size;
if (_INST(filePointer) != nil) {
- f = (FILE *)MKFD(_INST(filePointer));
- if ((size = filesize(fileno(f))) >= 0) {
- RETURN ( _MKSMALLINT(size) );
- }
+ f = (FILE *)MKFD(_INST(filePointer));
+ if ((size = filesize(fileno(f))) >= 0) {
+ RETURN ( _MKSMALLINT(size) );
+ }
}
#else
FILE *f;
@@ -490,27 +522,28 @@
int fd;
if (_INST(filePointer) != nil) {
- f = (FILE *)MKFD(_INST(filePointer));
- fd = fileno(f);
- do {
- ret = fstat(fd, &buf);
- } while ((ret < 0) && (errno == EINTR));
- if (ret >= 0) {
- RETURN ( _MKSMALLINT(buf.st_size) );
- }
- ExternalStream_LastErrorNumber = _MKSMALLINT(errno);
+ f = (FILE *)MKFD(_INST(filePointer));
+ fd = fileno(f);
+ do {
+ ret = fstat(fd, &buf);
+ } while ((ret < 0) && (errno == EINTR));
+ if (ret >= 0) {
+ RETURN ( _MKSMALLINT(buf.st_size) );
+ }
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
}
#endif
-%}
-.
+%}.
+
"could add a fall-back here:
- oldPosition := self position.
- self setToEnd.
- sz := self position.
- self position:oldPosition.
- ^ sz
+ oldPosition := self position.
+ self setToEnd.
+ sz := self position.
+ self position:oldPosition.
+ ^ sz
"
+ lastErrorNumber notNil ifTrue:[^ self ioError].
filePointer isNil ifTrue:[^ self errorNotOpen].
^ self primitiveFailed
!
@@ -526,24 +559,24 @@
extern errno;
if (_INST(filePointer) != nil) {
- f = (FILE *)MKFD(_INST(filePointer));
- do {
- if (_INST(buffered) == true) {
- currentPosition = (long) ftell(f);
- } else {
- currentPosition = (long) lseek(fileno(f), 0L, SEEK_CUR);
- }
- } while ((currentPosition < 0) && (errno == EINTR));
- if (currentPosition >= 0) {
- /*
- * notice: Smalltalk index starts at 1
- */
- RETURN ( _MKSMALLINT(currentPosition + 1) );
- }
- ExternalStream_LastErrorNumber = _MKSMALLINT(errno);
+ f = (FILE *)MKFD(_INST(filePointer));
+ do {
+ if (_INST(buffered) == true) {
+ currentPosition = (long) ftell(f);
+ } else {
+ currentPosition = (long) lseek(fileno(f), 0L, SEEK_CUR);
+ }
+ } while ((currentPosition < 0) && (errno == EINTR));
+ if (currentPosition >= 0) {
+ /*
+ * notice: Smalltalk index starts at 1
+ */
+ RETURN ( _MKSMALLINT(currentPosition + 1) );
+ }
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
}
-%}
-.
+%}.
+ lastErrorNumber notNil ifTrue:[^ self ioError].
filePointer isNil ifTrue:[^ self errorNotOpen].
^ self primitiveFailed
!
@@ -558,31 +591,31 @@
extern errno;
if (_INST(filePointer) != nil) {
- if (_isSmallInteger(newPos)) {
- f = (FILE *)MKFD(_INST(filePointer));
- /*
- * notice: Smalltalk index starts at 1
- */
- do {
- if (_INST(buffered) == true) {
- ret = fseek(f, (long) (_intVal(newPos) - 1), SEEK_SET);
- } else {
- ret = (long) lseek(fileno(f), (long)(_intVal(newPos) - 1), SEEK_SET);
- }
- } while ((ret < 0) && (errno == EINTR));
- if (ret >= 0) {
- _INST(position) = newPos;
- /*
- * just to make certain ...
- */
- _INST(hitEOF) = false;
- RETURN ( self );
- }
- ExternalStream_LastErrorNumber = _MKSMALLINT(errno);
- }
+ if (_isSmallInteger(newPos)) {
+ f = (FILE *)MKFD(_INST(filePointer));
+ /*
+ * notice: Smalltalk index starts at 1
+ */
+ do {
+ if (_INST(buffered) == true) {
+ ret = fseek(f, (long) (_intVal(newPos) - 1), SEEK_SET);
+ } else {
+ ret = (long) lseek(fileno(f), (long)(_intVal(newPos) - 1), SEEK_SET);
+ }
+ } while ((ret < 0) && (errno == EINTR));
+ if (ret >= 0) {
+ _INST(position) = newPos;
+ /*
+ * just to make certain ...
+ */
+ _INST(hitEOF) = false;
+ RETURN ( self );
+ }
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ }
}
-%}
-.
+%}.
+ lastErrorNumber notNil ifTrue:[^ self ioError].
filePointer isNil ifTrue:[^ self errorNotOpen].
^ self primitiveFailed
!
@@ -596,22 +629,22 @@
extern errno;
if (_INST(filePointer) != nil) {
- f = (FILE *)MKFD(_INST(filePointer));
- _INST(position) = nil;
- do {
- if (_INST(buffered) == true) {
- ret = fseek(f, 0L, SEEK_END);
- } else {
- ret = (long)lseek(fileno(f), 0L, SEEK_END);
- }
- } while ((ret < 0) && (errno == EINTR));
- if (ret >= 0) {
- RETURN ( self );
- }
- ExternalStream_LastErrorNumber = _MKSMALLINT(errno);
+ f = (FILE *)MKFD(_INST(filePointer));
+ _INST(position) = nil;
+ do {
+ if (_INST(buffered) == true) {
+ ret = fseek(f, 0L, SEEK_END);
+ } else {
+ ret = (long)lseek(fileno(f), 0L, SEEK_END);
+ }
+ } while ((ret < 0) && (errno == EINTR));
+ if (ret >= 0) {
+ RETURN ( self );
+ }
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
}
-%}
-.
+%}.
+ lastErrorNumber notNil ifTrue:[^ self ioError].
filePointer isNil ifTrue:[^ self errorNotOpen].
DemoMode ifTrue:[^ self warn:'no save in Demo mode'].
^ self primitiveFailed
@@ -638,8 +671,8 @@
aStream nextPutAll:'(FileStream oldFileNamed:'.
aStream nextPutAll:pathName.
(self position ~~ 1) ifTrue:[
- aStream nextPutAll:'; position:'.
- self position storeOn:aStream
+ aStream nextPutAll:'; position:'.
+ self position storeOn:aStream
].
aStream nextPut:$)
! !
--- a/Filename.st Mon Oct 10 01:29:01 1994 +0100
+++ b/Filename.st Mon Oct 10 01:29:28 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1992 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -11,16 +11,16 @@
"
Object subclass:#Filename
- instanceVariableNames:'nameString'
- classVariableNames:''
- poolDictionaries:''
- category:'ST-80 compatibility'!
+ instanceVariableNames:'nameString'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'System-Support'!
Filename comment:'
COPYRIGHT (c) 1992 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Filename.st,v 1.12 1994-08-22 12:21:05 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Filename.st,v 1.13 1994-10-10 00:26:07 claus Exp $
'!
!Filename class methodsFor:'documentation'!
@@ -28,7 +28,7 @@
copyright
"
COPYRIGHT (c) 1992 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -41,7 +41,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Filename.st,v 1.12 1994-08-22 12:21:05 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Filename.st,v 1.13 1994-10-10 00:26:07 claus Exp $
"
!
@@ -56,9 +56,9 @@
for being correct or existing.
Thus, it is possible to do queries such as:
- '/fee/foo/foe' asFilename exists
- '/not_existing' asFilename isDirectory
- '/foo/bar' asFilename isReadable
+ '/fee/foo/foe' asFilename exists
+ '/not_existing' asFilename isDirectory
+ '/foo/bar' asFilename isReadable
(all of the above usually return false).
@@ -109,8 +109,8 @@
or a subdirectory in that directory)."
nameString = self class separator asString ifTrue:[
- "I am the root"
- ^ (self class basicNew) setName:(nameString , subname)
+ "I am the root"
+ ^ (self class basicNew) setName:(nameString , subname)
].
^ (self class basicNew) setName:(nameString , self class separator asString , subname)
@@ -146,6 +146,12 @@
!Filename methodsFor:'queries'!
+separator
+ "return the directory-separator character (or string)"
+
+ ^ self class separator
+!
+
directoryName
"return the directoryName of the file/directory.
- thats the name of the directory where the file/dir represented by
@@ -179,7 +185,7 @@
"return the full pathname of the file represented by the receiver."
(nameString startsWith:self class separator) ifTrue:[
- ^ nameString
+ ^ nameString
].
^ (FileDirectory directoryNamed:nameString) pathName
@@ -203,6 +209,13 @@
"
!
+isRelative
+ "return true, if this name is interpreted relative to some
+ directory (opposite of absolute)"
+
+ ^ self isAbsolute not
+!
+
isDirectory
"return true, if the receiver represents an existing,
readable directories pathname."
@@ -240,6 +253,12 @@
"
!
+canBeWritten
+ "same as isWritable - for ST-80 compatibility"
+
+ ^ self isWritable
+!
+
isWritable
"return true, if such a file exists and is writable."
@@ -285,9 +304,9 @@
filenameCompletion
"try to complete the filename. This method has both a side effect,
and a return value:
- it returns a collection of matching filename strings,
- and sets (as side effect) the receivers filename to the longest common
- match.
+ it returns a collection of matching filename strings,
+ and sets (as side effect) the receivers filename to the longest common
+ match.
(i.e. if the size of the returned collection is exactly 1,
the completion has succeeded and the receivers name has been changed to
that.
@@ -301,62 +320,62 @@
name := self baseName.
matching := OrderedCollection new.
(FileDirectory directoryNamed:dir) do:[:fileName |
- (fileName startsWith:name) ifTrue:[
- matching add:fileName
- ]
+ (fileName startsWith:name) ifTrue:[
+ matching add:fileName
+ ]
].
"
if there is only one, change my name ...
"
matching size == 1 ifTrue:[
- dir = '/' ifTrue:[
- dir := ''
- ].
- nameString := dir , self class separator asString , matching first.
- matching first = name ifTrue:[
- self isDirectory ifTrue:[
- nameString := nameString , self class separator asString
- ]
- ]
+ dir = '/' ifTrue:[
+ dir := ''
+ ].
+ nameString := dir , self class separator asString , matching first.
+ matching first = name ifTrue:[
+ self isDirectory ifTrue:[
+ nameString := nameString , self class separator asString
+ ]
+ ]
] ifFalse:[
- matching size > 1 ifTrue:[
- "
- find the longest common prefix
- "
- matchLen := name size.
- matchLen > matching first size ifTrue:[
- try := name.
- allMatching := false
- ] ifFalse:[
- try := matching first copyTo:matchLen.
- allMatching := true.
- ].
+ matching size > 1 ifTrue:[
+ "
+ find the longest common prefix
+ "
+ matchLen := name size.
+ matchLen > matching first size ifTrue:[
+ try := name.
+ allMatching := false
+ ] ifFalse:[
+ try := matching first copyTo:matchLen.
+ allMatching := true.
+ ].
- [allMatching] whileTrue:[
- matching do:[:aName |
- (aName startsWith:try) ifFalse:[
- allMatching := false
- ]
- ].
- allMatching ifTrue:[
- matchLen < matching first size ifTrue:[
- matchLen := matchLen + 1.
- try := matching first copyTo:matchLen.
- ] ifFalse:[
- allMatching := false
- ]
- ] ifFalse:[
- try := matching first copyTo:matchLen - 1.
- ]
- ].
- "
- and set my name to the last full match
- "
- dir = '/' ifTrue:[
- dir := ''
- ].
- nameString := dir , self class separator asString , try
- ]
+ [allMatching] whileTrue:[
+ matching do:[:aName |
+ (aName startsWith:try) ifFalse:[
+ allMatching := false
+ ]
+ ].
+ allMatching ifTrue:[
+ matchLen < matching first size ifTrue:[
+ matchLen := matchLen + 1.
+ try := matching first copyTo:matchLen.
+ ] ifFalse:[
+ allMatching := false
+ ]
+ ] ifFalse:[
+ try := matching first copyTo:matchLen - 1.
+ ]
+ ].
+ "
+ and set my name to the last full match
+ "
+ dir = '/' ifTrue:[
+ dir := ''
+ ].
+ nameString := dir , self class separator asString , try
+ ]
].
"
return the match-set, so caller can decide what to do
@@ -373,6 +392,12 @@
!Filename methodsFor:'file access'!
+delete
+ "remove the file - same as remove, for ST-80 compatibility"
+
+ ^ self remove
+!
+
remove
"remove the file - the argument must be convertable to a String"
@@ -395,9 +420,28 @@
!
copyTo:newName
- "copy the file - the argument must be convertable to a String"
+ "copy the file - the argument must be convertable to a filename"
+
+ |inStream outStream buffer bufferSize count|
- ^ OperatingSystem copyFile:nameString to:(newName asString)
+ bufferSize := 8 * 1024.
+ buffer := ByteArray new:bufferSize.
+ inStream := self readStream.
+ outStream := newName asFilename writeStream.
+ (inStream isNil or:[outStream isNil]) ifTrue:[
+ ^ self error:'file copy failed'
+ ].
+
+ [inStream atEnd] whileFalse:[
+ count := inStream nextBytes:bufferSize into:buffer.
+ outStream nextPutBytes:count from:buffer.
+ ].
+ outStream close.
+
+ "
+ 'Makefile' asFilename copyTo:'Makefile.foo'
+ 'smalltalk' asFilename copyTo:'/dev/null'
+ "
!
fileIn
--- a/FloatArray.st Mon Oct 10 01:29:01 1994 +0100
+++ b/FloatArray.st Mon Oct 10 01:29:28 1994 +0100
@@ -14,14 +14,14 @@
instanceVariableNames:''
classVariableNames:''
poolDictionaries:''
- category:'Collections-Indexed'
+ category:'Collections-Arrayed'
!
FloatArray comment:'
COPYRIGHT (c) 1993 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/FloatArray.st,v 1.5 1994-08-05 00:54:53 claus Exp $
+$Header: /cvs/stx/stx/libbasic/FloatArray.st,v 1.6 1994-10-10 00:26:12 claus Exp $
'!
!FloatArray class methodsFor:'documentation'!
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/FloatArray.st,v 1.5 1994-08-05 00:54:53 claus Exp $
+$Header: /cvs/stx/stx/libbasic/FloatArray.st,v 1.6 1994-10-10 00:26:12 claus Exp $
"
!
--- a/Integer.st Mon Oct 10 01:29:01 1994 +0100
+++ b/Integer.st Mon Oct 10 01:29:28 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1988 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -19,9 +19,9 @@
Integer comment:'
COPYRIGHT (c) 1988 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Integer.st,v 1.15 1994-08-22 12:21:15 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Integer.st,v 1.16 1994-10-10 00:26:19 claus Exp $
'!
!Integer class methodsFor:'documentation'!
@@ -29,7 +29,7 @@
copyright
"
COPYRIGHT (c) 1988 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Integer.st,v 1.15 1994-08-22 12:21:15 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Integer.st,v 1.16 1994-10-10 00:26:19 claus Exp $
"
!
@@ -77,7 +77,7 @@
The digits can be stored byte-wise into the result, using digitAt:put:"
^ (LargeInteger basicNew numberOfDigits:numberOfBytes)
- sign:(negative ifTrue:[-1] ifFalse:[1])
+ sign:(negative ifTrue:[-1] ifFalse:[1])
! !
!Integer class methodsFor:'misc'!
@@ -114,7 +114,7 @@
d := aFraction denominator.
^ (Fraction numerator:(aFraction numerator + (self * d))
- denominator:d) reduced
+ denominator:d) reduced
!
differenceFromFraction:aFraction
@@ -124,21 +124,21 @@
d := aFraction denominator.
^ (Fraction numerator:(aFraction numerator - (self * d))
- denominator:d) reduced
+ denominator:d) reduced
!
productFromFraction:aFraction
"sent when a fraction does not know how to multiply the recevier, an integer"
^ (Fraction numerator:(self * aFraction numerator)
- denominator:aFraction denominator) reduced
+ denominator:aFraction denominator) reduced
!
quotientFromFraction:aFraction
"sent when a fraction does not know how to divide the recevier, an integer"
^ (Fraction numerator:aFraction numerator
- denominator:(self * aFraction denominator)) reduced
+ denominator:(self * aFraction denominator)) reduced
! !
!Integer methodsFor:'bit operators'!
@@ -152,11 +152,11 @@
result := self class basicNew numberOfDigits:n.
1 to:n do:[:index |
- byte := (anInteger digitAt:index) bitAnd:(self digitAt:index).
- result digitAt:index put:byte.
+ byte := (anInteger digitAt:index) bitAnd:(self digitAt:index).
+ result digitAt:index put:byte.
].
byte == 0 ifTrue:[
- ^ result normalize
+ ^ result normalize
].
^ result
!
@@ -170,11 +170,11 @@
result := self class basicNew numberOfDigits:n.
1 to:n do:[:index |
- byte := (anInteger digitAt:index) bitOr:(self digitAt:index).
- result digitAt:index put:byte.
+ byte := (anInteger digitAt:index) bitOr:(self digitAt:index).
+ result digitAt:index put:byte.
].
byte == 0 ifTrue:[
- ^ result normalize
+ ^ result normalize
].
^ result
!
@@ -188,11 +188,11 @@
result := self class basicNew numberOfDigits:n.
1 to:n do:[:index |
- byte := (anInteger digitAt:index) bitXor:(self digitAt:index).
- result digitAt:index put:byte.
+ byte := (anInteger digitAt:index) bitXor:(self digitAt:index).
+ result digitAt:index put:byte.
].
byte == 0 ifTrue:[
- ^ result normalize
+ ^ result normalize
].
^ result
!
@@ -223,8 +223,8 @@
bitAt:index
"return the value of the index's bit (index starts at 1).
Notice: the result of bitShift: on negative receivers is not
- defined in the language standard (since the implementation
- is free to choose any internal representation for integers)"
+ defined in the language standard (since the implementation
+ is free to choose any internal representation for integers)"
|i "{Class: SmallInteger}"|
@@ -257,8 +257,8 @@
leftShift if shiftCount > 0; rightShift otherwise.
Notice: the result of bitShift: on negative receivers is not
- defined in the language standard (since the implementation
- is free to choose any internal representation for integers)"
+ defined in the language standard (since the implementation
+ is free to choose any internal representation for integers)"
|result
prev "{ Class: SmallInteger }"
@@ -271,140 +271,140 @@
nn "{ Class: SmallInteger }"|
shiftCount > 0 ifTrue:[
- "left shift"
+ "left shift"
- digitShift := shiftCount // 8.
- bitShift := shiftCount \\ 8.
- n := self digitLength.
+ digitShift := shiftCount // 8.
+ bitShift := shiftCount \\ 8.
+ n := self digitLength.
- "
- modulu 8 shifts can be done faster ...
- "
- bitShift == 0 ifTrue:[
- result := self class basicNew numberOfDigits:n + digitShift.
- result sign:self sign.
- result digits replaceFrom:(digitShift + 1) with:self digits.
- "
- no normalize needed, since receiver was already normalized
- "
- ^ result
- ].
+ "
+ modulu 8 shifts can be done faster ...
+ "
+ bitShift == 0 ifTrue:[
+ result := self class basicNew numberOfDigits:n + digitShift.
+ result sign:self sign.
+ result digits replaceFrom:(digitShift + 1) with:self digits.
+ "
+ no normalize needed, since receiver was already normalized
+ "
+ ^ result
+ ].
- "
- less-than-8 shifts can be done faster ...
- "
- digitShift == 0 ifTrue:[
- n := n + 1.
- result := self class basicNew numberOfDigits:n.
- result sign:self sign.
- prev := 0.
- 1 to:n-1 do:[:index |
- byte := self digitAt:index.
- byte := (byte bitShift:bitShift) bitOr:prev.
- result digitAt:index put:(byte bitAnd:16rFF).
- prev := byte bitShift:-8.
- ].
- result digitAt:n put:prev.
- "
- might have stored a 0-byte ...
- "
- prev == 0 ifTrue:[
- ^ result normalize
- ].
- ^ result.
- ].
+ "
+ less-than-8 shifts can be done faster ...
+ "
+ digitShift == 0 ifTrue:[
+ n := n + 1.
+ result := self class basicNew numberOfDigits:n.
+ result sign:self sign.
+ prev := 0.
+ 1 to:n-1 do:[:index |
+ byte := self digitAt:index.
+ byte := (byte bitShift:bitShift) bitOr:prev.
+ result digitAt:index put:(byte bitAnd:16rFF).
+ prev := byte bitShift:-8.
+ ].
+ result digitAt:n put:prev.
+ "
+ might have stored a 0-byte ...
+ "
+ prev == 0 ifTrue:[
+ ^ result normalize
+ ].
+ ^ result.
+ ].
- "
- slow case ...
- "
- n := n + digitShift + 1.
- result := self class basicNew numberOfDigits:n.
- result sign:self sign.
+ "
+ slow case ...
+ "
+ n := n + digitShift + 1.
+ result := self class basicNew numberOfDigits:n.
+ result sign:self sign.
- byte := ((self digitAt:1) bitShift:bitShift) bitAnd:16rFF.
- result digitAt:(digitShift + 1) put:byte.
- revShift := -8 + bitShift.
- 2 to:(self digitLength) do:[:index |
- byte := (self digitAt:index) bitShift:bitShift.
- byte := byte bitOr:((self digitAt:index-1) bitShift:revShift).
- byte := byte bitAnd:16rFF.
- result digitAt:(index + digitShift) put:byte
- ].
- "
- might have stored a 0-byte ...
- "
- byte == 0 ifTrue:[
- ^ result normalize
- ].
- ^ result
+ byte := ((self digitAt:1) bitShift:bitShift) bitAnd:16rFF.
+ result digitAt:(digitShift + 1) put:byte.
+ revShift := -8 + bitShift.
+ 2 to:(self digitLength) do:[:index |
+ byte := (self digitAt:index) bitShift:bitShift.
+ byte := byte bitOr:((self digitAt:index-1) bitShift:revShift).
+ byte := byte bitAnd:16rFF.
+ result digitAt:(index + digitShift) put:byte
+ ].
+ "
+ might have stored a 0-byte ...
+ "
+ byte == 0 ifTrue:[
+ ^ result normalize
+ ].
+ ^ result
].
shiftCount < 0 ifTrue:[
- "right shift"
+ "right shift"
- digitShift := shiftCount negated // 8.
- bitShift := shiftCount negated \\ 8.
- n := self digitLength.
+ digitShift := shiftCount negated // 8.
+ bitShift := shiftCount negated \\ 8.
+ n := self digitLength.
- digitShift >= n ifTrue:[
- ^ 0
- ].
+ digitShift >= n ifTrue:[
+ ^ 0
+ ].
- "
- modulu 8 shifts can be done faster ...
- "
- bitShift == 0 ifTrue:[
- n := n-digitShift.
- result := self class basicNew numberOfDigits:n.
- result sign:self sign.
- result digits replaceFrom:1 with:self digits startingAt:(digitShift + 1) .
- n <= 4 ifTrue:[
- ^ result normalize
- ].
- ^ result
- ].
+ "
+ modulu 8 shifts can be done faster ...
+ "
+ bitShift == 0 ifTrue:[
+ n := n-digitShift.
+ result := self class basicNew numberOfDigits:n.
+ result sign:self sign.
+ result digits replaceFrom:1 with:self digits startingAt:(digitShift + 1) .
+ n <= 4 ifTrue:[
+ ^ result normalize
+ ].
+ ^ result
+ ].
- "
- less-than-8 shifts can be done faster ...
- "
- digitShift == 0 ifTrue:[
- result := self class basicNew numberOfDigits:n.
- result sign:self sign.
- prev := 0.
- bitShift := bitShift negated.
- revShift := 8 + bitShift.
- n to:1 by:-1 do:[:index |
- byte := self digitAt:index.
- next := (byte bitShift:revShift) bitAnd:16rFF.
- byte := (byte bitShift:bitShift) bitOr:prev.
- result digitAt:index put:(byte bitAnd:16rFF).
- prev := next.
- ].
- (n <= 5) ifTrue:[
- ^ result normalize
- ].
- ^ result
- ].
+ "
+ less-than-8 shifts can be done faster ...
+ "
+ digitShift == 0 ifTrue:[
+ result := self class basicNew numberOfDigits:n.
+ result sign:self sign.
+ prev := 0.
+ bitShift := bitShift negated.
+ revShift := 8 + bitShift.
+ n to:1 by:-1 do:[:index |
+ byte := self digitAt:index.
+ next := (byte bitShift:revShift) bitAnd:16rFF.
+ byte := (byte bitShift:bitShift) bitOr:prev.
+ result digitAt:index put:(byte bitAnd:16rFF).
+ prev := next.
+ ].
+ (n <= 5) ifTrue:[
+ ^ result normalize
+ ].
+ ^ result
+ ].
- "
- slow case ...
- "
- nn := n-digitShift.
- result := self class basicNew numberOfDigits:nn.
- result sign:self sign.
+ "
+ slow case ...
+ "
+ nn := n-digitShift.
+ result := self class basicNew numberOfDigits:nn.
+ result sign:self sign.
- prev := 0.
- bitShift := bitShift negated.
- revShift := 8 + bitShift.
- n to:(1 + digitShift) by:-1 do:[:index |
- byte := self digitAt:index.
- next := (byte bitShift:revShift) bitAnd:16rFF.
- byte := (byte bitShift:bitShift) bitOr:prev.
- result digitAt:(index - digitShift) put:byte.
- prev := next.
- ].
- "the last stored byte ..."
- ^ result normalize
+ prev := 0.
+ bitShift := bitShift negated.
+ revShift := 8 + bitShift.
+ n to:(1 + digitShift) by:-1 do:[:index |
+ byte := self digitAt:index.
+ next := (byte bitShift:revShift) bitAnd:16rFF.
+ byte := (byte bitShift:bitShift) bitOr:prev.
+ result digitAt:(index - digitShift) put:byte.
+ prev := next.
+ ].
+ "the last stored byte ..."
+ ^ result normalize
].
^ self "no shift"
@@ -471,8 +471,8 @@
num := self.
count := n.
[count > 1] whileTrue:[
- num := num // 256.
- count := count - 1
+ num := num // 256.
+ count := count - 1
].
^ num \\ 256
@@ -499,7 +499,7 @@
"return 1*2*3...*self"
(self > 2) ifTrue:[
- ^ self * (self - 1) factorial
+ ^ self * (self - 1) factorial
].
^ self
!
@@ -512,9 +512,9 @@
ttt := anInteger.
selfInteger := self.
[ttt ~~ 0] whileTrue:[
- temp := selfInteger \\ ttt.
- selfInteger := ttt.
- ttt := temp
+ temp := selfInteger \\ ttt.
+ selfInteger := ttt.
+ ttt := temp
].
^ selfInteger
@@ -542,7 +542,7 @@
(use fastFib instead and dont ever try 60 fib ...)"
(self > 1) ifTrue:[
- ^ (self - 1) fib + (self - 2) fib
+ ^ (self - 1) fib + (self - 2) fib
].
^ 1
@@ -576,7 +576,7 @@
self <= 1 ifTrue:[^ 1].
fibCache size >= self ifTrue:[
- ^ fibCache at:self
+ ^ fibCache at:self
].
fib := ((self - 2) fibUsingCache:fibCache) + ((self - 1) fibUsingCache:fibCache).
@@ -632,7 +632,7 @@
DefaultDisplayRadix (see Integer>>displayRadix:)"
(DefaultDisplayRadix isNil or:[DefaultDisplayRadix == 10]) ifTrue:[
- ^ self printString
+ ^ self printString
].
^ self radixPrintStringRadix:DefaultDisplayRadix
@@ -663,13 +663,13 @@
|num s "rx leftPart"|
(aRadix between:2 and:36) ifFalse:[
- self error:'invalid radix'.
- ^ self printStringRadix:10
+ self error:'invalid radix'.
+ ^ self printStringRadix:10
].
(self = 0) ifTrue:[^ '0'].
(self < 0) ifTrue:[
- ^ '-' , (self negated printStringRadix:aRadix)
+ ^ '-' , (self negated printStringRadix:aRadix)
].
"
@@ -687,8 +687,8 @@
s := (Character digitValue:(num \\ aRadix)) asString.
num := num // aRadix.
[num ~= 0] whileTrue:[
- s := (Character digitValue:(num \\ aRadix)) asString , s.
- num := num // aRadix.
+ s := (Character digitValue:(num \\ aRadix)) asString , s.
+ num := num // aRadix.
].
^ s
!
@@ -702,7 +702,7 @@
s := self printStringRadix:aRadix.
s size < sz ifTrue:[
- s := ((String new:(sz - s size)) atAllPut:fillCharacter) , s
+ s := ((String new:(sz - s size)) atAllPut:fillCharacter) , s
].
^ s
@@ -716,53 +716,82 @@
!Integer class methodsFor:'instance creation'!
readFrom:aStream radix:radix
- "return the next Integer from the (character-)stream aStream in radix;
- (assumes that the initial XXr has already been read)
- no whitespace-skipping; returns 0 if no number available"
+ "return the next unsigned Integer from the (character-)stream aStream
+ in radix; (assumes that the initial XXr has already been read).
+ No whitespace-skipping is done.
+ Returns 0 if no number available"
|nextChar value|
nextChar := aStream peek.
value := 0.
[nextChar notNil and:[nextChar isDigitRadix:radix]] whileTrue:[
- value := value * radix + nextChar digitValue.
- nextChar := aStream nextPeek
+ value := value * radix + nextChar digitValue.
+ nextChar := aStream nextPeek
].
^ value
+
+ "
+ Integer readFrom:(ReadStream on:'12345') radix:10
+ Integer readFrom:(ReadStream on:'FFFF') radix:16
+ Integer readFrom:(ReadStream on:'1010') radix:2
+ "
!
readFrom:aStream
"return the next Integer from the (character-)stream aStream,
handling initial XXr for arbitrary radix numbers and initial
sign.
- skipping all whitespace first; return nil if no number"
+ Also, all initial whitespace is skipped.
+ Q: If the string does not represent a valid integer number,
+ should nil be returned, or an error be raised (see Object>>readFrom:)
+ A: for now, return nil.
+ This may be changed, once the ANSI spec defines this."
|nextChar value negative|
nextChar := aStream skipSeparators.
(nextChar == $-) ifTrue:[
- negative := true.
- nextChar := aStream nextPeek
+ negative := true.
+ nextChar := aStream nextPeek
] ifFalse:[
- negative := false
+ negative := false
].
- nextChar isDigit ifFalse:[ ^ nil].
- value := Integer readFrom:aStream radix:10.
+ nextChar isDigit ifFalse:[
+ "
+ the string does not represent an integer
+ "
+ ^ nil
+"
+ ^ self error:'expected Integer'.
+"
+ ].
+ value := self readFrom:aStream radix:10.
nextChar := aStream peek.
((nextChar == $r) or:[ nextChar == $R]) ifTrue:[
- "-xxr<number> is invalid; should be xxr-<val>"
+ "-xxr<number> is invalid; should be xxr-<val>"
- negative ifTrue:[
- 'invalid (negative) radix ignored' errorPrintNewline.
- negative := false
- ].
- aStream next.
- value := Integer readFrom:aStream radix:value
+ negative ifTrue:[
+ 'invalid (negative) radix ignored' errorPrintNL.
+ negative := false
+ ].
+ aStream next.
+ value := self readFrom:aStream radix:value
].
negative ifTrue:[
- ^ value negated
+ ^ value negated
].
^ value
+
+ "
+ Integer readFrom:(ReadStream on:'12345')
+ Integer readFrom:(ReadStream on:'16rFFFF')
+ Integer readFrom:(ReadStream on:'12345.1234')
+ Integer readFrom:(ReadStream on:'foo')
+
+ Object errorSignal handle:[:ex | ex returnWith:0]
+ do:[Integer readFrom:(ReadStream on:'foo')]
+ "
! !
!Integer methodsFor:'benchmarking'!
@@ -779,23 +808,23 @@
Transcript cr.
time := Time millisecondsToRun:[
- self timesRepeat:[
- count := 0.
- flags atAllPut:1.
- i := 1.
- num timesRepeat:[
- (flags at:i) == 1 ifTrue:[
- prime := i + i + 3.
- k := i + prime.
- [k <= num] whileTrue:[
- flags at:k put:0.
- k := k + prime
- ].
- count := count + 1
- ].
- i := i + 1
- ].
- ].
+ self timesRepeat:[
+ count := 0.
+ flags atAllPut:1.
+ i := 1.
+ num timesRepeat:[
+ (flags at:i) == 1 ifTrue:[
+ prime := i + i + 3.
+ k := i + prime.
+ [k <= num] whileTrue:[
+ flags at:k put:0.
+ k := k + prime
+ ].
+ count := count + 1
+ ].
+ i := i + 1
+ ].
+ ].
].
Transcript show:'Sieve in Smalltalk: '.
Transcript show:self printString.
@@ -827,23 +856,23 @@
Transcript cr.
time := Time millisecondsToRun:[
- self timesRepeat:[
- count := 0.
- flags atAllPut:1.
- i := 1.
- num timesRepeat:[
- (flags at:i) == 1 ifTrue:[
- prime := i + i + 3.
- k := i + prime.
- [k <= num] whileTrue:[
- flags at:k put:0.
- k := k + prime
- ].
- count := count + 1
- ].
- i := i + 1
- ].
- ].
+ self timesRepeat:[
+ count := 0.
+ flags atAllPut:1.
+ i := 1.
+ num timesRepeat:[
+ (flags at:i) == 1 ifTrue:[
+ prime := i + i + 3.
+ k := i + prime.
+ [k <= num] whileTrue:[
+ flags at:k put:0.
+ k := k + prime
+ ].
+ count := count + 1
+ ].
+ i := i + 1
+ ].
+ ].
].
Transcript show:'Sieve in Smalltalk: '.
Transcript show:self printString.
@@ -872,7 +901,7 @@
|t|
t := Time millisecondsToRun:[
- 1 recur1:15
+ 1 recur1:15
].
Transcript showCr:(t printString)
@@ -883,8 +912,8 @@
"lots of recursion for testing send without arg"
(self > 0) ifTrue:[
- (self - 1) doRecur2.
- ^ (self - 1) doRecur2
+ (self - 1) doRecur2.
+ ^ (self - 1) doRecur2
]
!
@@ -894,7 +923,7 @@
|t|
t := Time millisecondsToRun:[
- 15 doRecur2
+ 15 doRecur2
].
Transcript showCr:(t printString)
@@ -907,10 +936,10 @@
|t|
t := Time millisecondsToRun:[
- |b|
+ |b|
- b := [99].
- 1000000 timesRepeat:[b value]
+ b := [99].
+ 1000000 timesRepeat:[b value]
].
Transcript showCr:(t printString)
@@ -923,10 +952,10 @@
|t index|
t := Time millisecondsToRun:[
- index := 100000.
- [index > 0] whileTrue:[
- index := index - 1
- ].
+ index := 100000.
+ [index > 0] whileTrue:[
+ index := index - 1
+ ].
].
Transcript showCr:(t printString)
@@ -939,12 +968,12 @@
|t|
t := Time millisecondsToRun:[
- |index|
+ |index|
- index := 100000.
- [index > 0] whileTrue:[
- index := index - 1
- ].
+ index := 100000.
+ [index > 0] whileTrue:[
+ index := index - 1
+ ].
].
Transcript showCr:(t printString)
@@ -971,9 +1000,9 @@
|t|
t := Time millisecondsToRun:[
- self timesRepeat:[
- self noopSelf
- ].
+ self timesRepeat:[
+ self noopSelf
+ ].
].
Transcript showCr:(t printString)
@@ -987,9 +1016,9 @@
|t|
t := Time millisecondsToRun:[
- 1000000 timesRepeat:[
- self noopSelf
- ].
+ 1000000 timesRepeat:[
+ self noopSelf
+ ].
].
Transcript showCr:(t printString)
@@ -1003,9 +1032,9 @@
|t|
t := Time millisecondsToRun:[
- 1000000 timesRepeat:[
- self noopNil
- ].
+ 1000000 timesRepeat:[
+ self noopNil
+ ].
].
Transcript showCr:(t printString)
@@ -1019,9 +1048,9 @@
|t|
t := Time millisecondsToRun:[
- 1000000 timesRepeat:[
- self noopTrue
- ].
+ 1000000 timesRepeat:[
+ self noopTrue
+ ].
].
Transcript showCr:(t printString)
@@ -1036,10 +1065,10 @@
|t|
t := Time millisecondsToRun:[
- |a|
+ |a|
- a := 1->2.
- self timesRepeat:[a key].
+ a := 1->2.
+ self timesRepeat:[a key].
].
Transcript showCr:(t printString)
@@ -1054,10 +1083,10 @@
|t|
t := Time millisecondsToRun:[
- |a|
+ |a|
- a := 1->2.
- 1000000 timesRepeat:[a key].
+ a := 1->2.
+ 1000000 timesRepeat:[a key].
].
Transcript showCr:(t printString)
@@ -1075,9 +1104,9 @@
|t|
t := Time millisecondsToRun:[
- self timesRepeat:[
- Array new:500
- ].
+ self timesRepeat:[
+ Array new:500
+ ].
].
Transcript showCr:(t printString)
@@ -1096,9 +1125,9 @@
|t|
t := Time millisecondsToRun:[
- 100000 timesRepeat:[
- Array new:500
- ].
+ 100000 timesRepeat:[
+ Array new:500
+ ].
].
Transcript showCr:(t printString)
@@ -1118,9 +1147,9 @@
m := 5.5.
t := Time millisecondsToRun:[
- self timesRepeat:[
- p := 5 / n + m
- ]
+ self timesRepeat:[
+ p := 5 / n + m
+ ]
].
Transcript showCr:(t printString)
@@ -1141,9 +1170,9 @@
|t|
t := Time millisecondsToRun:[
- |x|
- x := 0.0.
- 1000000 timesRepeat:[x := x + 1.0]
+ |x|
+ x := 0.0.
+ 1000000 timesRepeat:[x := x + 1.0]
].
Transcript showCr:(t printString)
@@ -1162,9 +1191,9 @@
|t|
t := Time millisecondsToRun:[
- |x|
- x := 0.0.
- self timesRepeat:[x := x + 1.0]
+ |x|
+ x := 0.0.
+ self timesRepeat:[x := x + 1.0]
].
Transcript showCr:(t printString)
@@ -1181,9 +1210,9 @@
|t|
t := Time millisecondsToRun:[
- |x "{ Class: Float }" |
- x := 0.0.
- 1000000 timesRepeat:[x := x + 1.0]
+ |x "{ Class: Float }" |
+ x := 0.0.
+ 1000000 timesRepeat:[x := x + 1.0]
].
Transcript showCr:(t printString)
@@ -1200,9 +1229,9 @@
|t|
t := Time millisecondsToRun:[
- self timesRepeat:[
- Object new
- ]
+ self timesRepeat:[
+ Object new
+ ]
].
Transcript showCr:(t printString)
@@ -1218,9 +1247,9 @@
|t|
t := Time millisecondsToRun:[
- self timesRepeat:[
- Object basicNew
- ]
+ self timesRepeat:[
+ Object basicNew
+ ]
].
Transcript showCr:(t printString)
@@ -1237,9 +1266,9 @@
|t|
t := Time millisecondsToRun:[
- self timesRepeat:[
- Array basicNew
- ]
+ self timesRepeat:[
+ Array basicNew
+ ]
].
Transcript showCr:(t printString)
@@ -1255,9 +1284,9 @@
|t|
t := Time millisecondsToRun:[
- self timesRepeat:[
- Array new
- ]
+ self timesRepeat:[
+ Array new
+ ]
].
Transcript showCr:(t printString)
@@ -1273,7 +1302,7 @@
s := Set new.
t := Time millisecondsToRun:[
- 1 to:4500 do:[:i | s add:i]
+ 1 to:4500 do:[:i | s add:i]
].
Transcript showCr:(t printString)
@@ -1289,9 +1318,9 @@
|t|
t := Time millisecondsToRun:[
- |s|
- s := Set new.
- 1 to:4500 do:[:i | s add:i]
+ |s|
+ s := Set new.
+ 1 to:4500 do:[:i | s add:i]
].
Transcript showCr:(t printString)
@@ -1307,9 +1336,9 @@
|t|
t := Time millisecondsToRun:[
- |s|
- s := Set new:4500.
- 1 to:4500 do:[:i | s add:i]
+ |s|
+ s := Set new:4500.
+ 1 to:4500 do:[:i | s add:i]
].
Transcript showCr:(t printString)
@@ -1333,10 +1362,10 @@
|val|
100 timesRepeat:[
- val := 0.
- 1 to:10000 do:[:i |
- val := val + i
- ]
+ val := 0.
+ 1 to:10000 do:[:i |
+ val := val + i
+ ]
].
"Transcript showCr:(Time millisecondsToRun:[1 sumTo])"
!
@@ -1345,12 +1374,12 @@
|val i|
100 timesRepeat:[
- val := 0.
- i := 1.
- [i <= 10000] whileTrue:[
- val := val + i.
- i := i + 1
- ].
+ val := 0.
+ i := 1.
+ [i <= 10000] whileTrue:[
+ val := val + i.
+ i := i + 1
+ ].
].
"Transcript showCr:(Time millisecondsToRun:[1 fastSumTo])"
!
@@ -1359,12 +1388,12 @@
|i|
100 timesRepeat:[
- i := 0.
- 1 to:100 do:[:l1 |
- 1 to:100 do:[:l2 |
- i := i + 1
- ]
- ]
+ i := 0.
+ 1 to:100 do:[:l1 |
+ 1 to:100 do:[:l2 |
+ i := i + 1
+ ]
+ ]
]
"Transcript showCr:(Time millisecondsToRun:[1 nestedLoop])"
!
@@ -1374,9 +1403,9 @@
vec := Array new:100000.
t := Time millisecondsToRun:[
- 1 to:100000 do:[:i |
- vec at:i put:7
- ]
+ 1 to:100000 do:[:i |
+ vec at:i put:7
+ ]
].
^ t
@@ -1388,13 +1417,13 @@
vec := Array new:100000.
1 to:100000 do:[:i |
- vec at:i put:7
+ vec at:i put:7
].
s := 0.
t := Time millisecondsToRun:[
- 1 to:100000 do:[:i |
- s := s + (vec at:i)
- ]
+ 1 to:100000 do:[:i |
+ s := s + (vec at:i)
+ ]
].
^ t
--- a/LinkList.st Mon Oct 10 01:29:01 1994 +0100
+++ b/LinkList.st Mon Oct 10 01:29:28 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -11,7 +11,7 @@
"
SequenceableCollection subclass:#LinkedList
- instanceVariableNames:'firstLink lastLink nodeClass numberOfNodes'
+ instanceVariableNames:'firstLink lastLink numberOfNodes'
classVariableNames:''
poolDictionaries:''
category:'Collections-Sequenceable'
@@ -19,9 +19,9 @@
LinkedList comment:'
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Attic/LinkList.st,v 1.8 1994-08-05 00:58:53 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/LinkList.st,v 1.9 1994-10-10 00:26:30 claus Exp $
'!
!LinkedList class methodsFor:'documentation'!
@@ -29,7 +29,7 @@
copyright
"
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Attic/LinkList.st,v 1.8 1994-08-05 00:58:53 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/LinkList.st,v 1.9 1994-10-10 00:26:30 claus Exp $
"
!
@@ -70,45 +70,74 @@
!LinkedList methodsFor:'copying'!
-deepCopy
+XXXdeepCopy
"a kludge, to be removed when deepCopy handles recursive structures"
|newList|
+
newList := self shallowCopy.
- newList setFirstNode:(firstLink deepCopy).
- newList setLastNode:(firstLink last).
+ newList setFirstNode:(firstLink deepCopy) lastNode:(firstLink last).
^ newList
+
+ "
+ |l|
+ l := LinkedList new.
+ l add:(ValueLink new value:1).
+ l add:(ValueLink new value:2).
+ l add:(ValueLink new value:3).
+ l inspect.
+ l deepCopy inspect
+ "
+! !
+
+!LinkedList methodsFor:'private accessing'!
+
+XXsetFirstNode:first lastNode:last
+ "set the first node to be the argument, aNode"
+
+ firstLink := first.
+ lastLink := last
! !
!LinkedList methodsFor:'accessing'!
-setFirstNode:aNode
- "set the first node to be the argument, aNode"
-
- firstLink := aNode
-!
-
-setLastNode:aNode
- "set the last node to be the argument, aNode"
-
- lastLink := aNode
-!
-
first
"return the first node in the list"
+ firstLink isNil ifTrue:[self emptyCollectionError].
^ firstLink
!
last
"return last node in the list"
+ lastLink isNil ifTrue:[self emptyCollectionError].
^ lastLink
+!
+
+at:index
+ "return the n'th element - use of this method should be avoided,
+ since it is slow to walk through the list - think about using
+ another collection if you need index access.
+ Notice, that many methods in SeqColl are based on at:-access."
+
+ |theLink
+ runIndex "{Class: SmallInteger}"|
+
+ theLink := firstLink.
+ runIndex := 1.
+ [theLink isNil or:[runIndex == index]] whileFalse:[
+ theLink := theLink nextLink.
+ runIndex := runIndex + 1.
+ ].
+ theLink isNil ifTrue:[
+ ^ self subscriptBoundsError:index
+ ].
+ ^ theLink
! !
!LinkedList methodsFor:'queries'!
-
size
"return the size of the LinkedList i.e. the number of nodes"
@@ -130,8 +159,8 @@
theNode := firstLink.
[theNode notNil] whileTrue:[
- (anObject = theNode) ifTrue:[^ true].
- theNode := theNode nextLink
+ (anObject = theNode) ifTrue:[^ true].
+ theNode := theNode nextLink
].
^ false
! !
@@ -142,11 +171,11 @@
"adds aLink to the beginning of the sequence. Returns aLink"
firstLink isNil ifTrue:[
- firstLink := aLink.
- lastLink := aLink
+ firstLink := aLink.
+ lastLink := aLink
] ifFalse: [
- aLink nextLink:firstLink.
- firstLink := aLink
+ aLink nextLink:firstLink.
+ firstLink := aLink
].
numberOfNodes := numberOfNodes + 1.
^ aLink
@@ -157,9 +186,9 @@
aLink nextLink:nil.
lastLink isNil ifTrue:[
- firstLink := aLink
+ firstLink := aLink
] ifFalse: [
- lastLink nextLink:aLink
+ lastLink nextLink:aLink
].
lastLink := aLink.
numberOfNodes := numberOfNodes + 1.
@@ -172,13 +201,13 @@
|this|
- aLink isNil ifTrue:[ ^ self addFirst:linkToAdd ].
+ aLink isNil ifTrue:[^ self addFirst:linkToAdd ].
this := firstLink.
[this notNil and:[this ~~ aLink]] whileTrue:[
- this := this nextLink
+ this := this nextLink
].
- this isNil ifTrue:[ ^ self add:linkToAdd ].
+ this isNil ifTrue:[^ self add:linkToAdd ].
linkToAdd nextLink:(this nextLink).
this nextLink:linkToAdd.
^ linkToAdd
@@ -190,17 +219,17 @@
|link|
firstLink isNil ifTrue:[
- self errorIsEmpty
+ self errorIsEmpty
] ifFalse:[
- link := firstLink.
- (firstLink == lastLink) ifTrue:[
- firstLink := nil.
- lastLink := nil
- ] ifFalse:[
- firstLink := firstLink nextLink
- ].
- link nextLink:nil.
- numberOfNodes := numberOfNodes - 1
+ link := firstLink.
+ (firstLink == lastLink) ifTrue:[
+ firstLink := nil.
+ lastLink := nil
+ ] ifFalse:[
+ firstLink := firstLink nextLink
+ ].
+ link nextLink:nil.
+ numberOfNodes := numberOfNodes - 1
].
^ link
!
@@ -213,26 +242,26 @@
thisNode := firstLink.
[thisNode notNil] whileTrue:[
- nextNode := thisNode nextLink.
- (thisNode == aLink) ifTrue:[
- prevNode isNil ifTrue:[
- firstLink := thisNode nextLink
- ] ifFalse:[
- prevNode nextLink:(thisNode nextLink)
- ].
- (lastLink == thisNode) ifTrue:[
- thisNode nextLink isNil ifTrue:[
- lastLink := prevNode
- ] ifFalse:[
- lastLink := thisNode nextLink
- ]
- ].
- numberOfNodes := numberOfNodes - 1.
- thisNode nextLink:nil.
- ^ self
- ].
- prevNode := thisNode.
- thisNode := nextNode
+ nextNode := thisNode nextLink.
+ (thisNode == aLink) ifTrue:[
+ prevNode isNil ifTrue:[
+ firstLink := thisNode nextLink
+ ] ifFalse:[
+ prevNode nextLink:(thisNode nextLink)
+ ].
+ (lastLink == thisNode) ifTrue:[
+ thisNode nextLink isNil ifTrue:[
+ lastLink := prevNode
+ ] ifFalse:[
+ lastLink := thisNode nextLink
+ ]
+ ].
+ numberOfNodes := numberOfNodes - 1.
+ thisNode nextLink:nil.
+ ^ self
+ ].
+ prevNode := thisNode.
+ thisNode := nextNode
].
^ exceptionBlock value
! !
@@ -246,19 +275,19 @@
thisNode := firstLink.
[thisNode notNil] whileTrue:[
- aBlock value:thisNode.
- thisNode := thisNode nextLink
+ aBlock value:thisNode.
+ thisNode := thisNode nextLink
]
!
reverseDo:aBlock fromNode:aNode
- "helper for reverseDo:"
+ "helper for reverseDo: - this implementation is very expensive."
aNode notNil ifTrue:[
- aNode nextLink notNil ifTrue:[
- self reverseDo:aBlock fromNode:(aNode nextLink)
- ].
- aBlock value:aNode
+ aNode nextLink notNil ifTrue:[
+ self reverseDo:aBlock fromNode:(aNode nextLink)
+ ].
+ aBlock value:aNode
]
!
--- a/LinkedList.st Mon Oct 10 01:29:01 1994 +0100
+++ b/LinkedList.st Mon Oct 10 01:29:28 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -11,7 +11,7 @@
"
SequenceableCollection subclass:#LinkedList
- instanceVariableNames:'firstLink lastLink nodeClass numberOfNodes'
+ instanceVariableNames:'firstLink lastLink numberOfNodes'
classVariableNames:''
poolDictionaries:''
category:'Collections-Sequenceable'
@@ -19,9 +19,9 @@
LinkedList comment:'
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/LinkedList.st,v 1.8 1994-08-05 00:58:53 claus Exp $
+$Header: /cvs/stx/stx/libbasic/LinkedList.st,v 1.9 1994-10-10 00:26:30 claus Exp $
'!
!LinkedList class methodsFor:'documentation'!
@@ -29,7 +29,7 @@
copyright
"
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/LinkedList.st,v 1.8 1994-08-05 00:58:53 claus Exp $
+$Header: /cvs/stx/stx/libbasic/LinkedList.st,v 1.9 1994-10-10 00:26:30 claus Exp $
"
!
@@ -70,45 +70,74 @@
!LinkedList methodsFor:'copying'!
-deepCopy
+XXXdeepCopy
"a kludge, to be removed when deepCopy handles recursive structures"
|newList|
+
newList := self shallowCopy.
- newList setFirstNode:(firstLink deepCopy).
- newList setLastNode:(firstLink last).
+ newList setFirstNode:(firstLink deepCopy) lastNode:(firstLink last).
^ newList
+
+ "
+ |l|
+ l := LinkedList new.
+ l add:(ValueLink new value:1).
+ l add:(ValueLink new value:2).
+ l add:(ValueLink new value:3).
+ l inspect.
+ l deepCopy inspect
+ "
+! !
+
+!LinkedList methodsFor:'private accessing'!
+
+XXsetFirstNode:first lastNode:last
+ "set the first node to be the argument, aNode"
+
+ firstLink := first.
+ lastLink := last
! !
!LinkedList methodsFor:'accessing'!
-setFirstNode:aNode
- "set the first node to be the argument, aNode"
-
- firstLink := aNode
-!
-
-setLastNode:aNode
- "set the last node to be the argument, aNode"
-
- lastLink := aNode
-!
-
first
"return the first node in the list"
+ firstLink isNil ifTrue:[self emptyCollectionError].
^ firstLink
!
last
"return last node in the list"
+ lastLink isNil ifTrue:[self emptyCollectionError].
^ lastLink
+!
+
+at:index
+ "return the n'th element - use of this method should be avoided,
+ since it is slow to walk through the list - think about using
+ another collection if you need index access.
+ Notice, that many methods in SeqColl are based on at:-access."
+
+ |theLink
+ runIndex "{Class: SmallInteger}"|
+
+ theLink := firstLink.
+ runIndex := 1.
+ [theLink isNil or:[runIndex == index]] whileFalse:[
+ theLink := theLink nextLink.
+ runIndex := runIndex + 1.
+ ].
+ theLink isNil ifTrue:[
+ ^ self subscriptBoundsError:index
+ ].
+ ^ theLink
! !
!LinkedList methodsFor:'queries'!
-
size
"return the size of the LinkedList i.e. the number of nodes"
@@ -130,8 +159,8 @@
theNode := firstLink.
[theNode notNil] whileTrue:[
- (anObject = theNode) ifTrue:[^ true].
- theNode := theNode nextLink
+ (anObject = theNode) ifTrue:[^ true].
+ theNode := theNode nextLink
].
^ false
! !
@@ -142,11 +171,11 @@
"adds aLink to the beginning of the sequence. Returns aLink"
firstLink isNil ifTrue:[
- firstLink := aLink.
- lastLink := aLink
+ firstLink := aLink.
+ lastLink := aLink
] ifFalse: [
- aLink nextLink:firstLink.
- firstLink := aLink
+ aLink nextLink:firstLink.
+ firstLink := aLink
].
numberOfNodes := numberOfNodes + 1.
^ aLink
@@ -157,9 +186,9 @@
aLink nextLink:nil.
lastLink isNil ifTrue:[
- firstLink := aLink
+ firstLink := aLink
] ifFalse: [
- lastLink nextLink:aLink
+ lastLink nextLink:aLink
].
lastLink := aLink.
numberOfNodes := numberOfNodes + 1.
@@ -172,13 +201,13 @@
|this|
- aLink isNil ifTrue:[ ^ self addFirst:linkToAdd ].
+ aLink isNil ifTrue:[^ self addFirst:linkToAdd ].
this := firstLink.
[this notNil and:[this ~~ aLink]] whileTrue:[
- this := this nextLink
+ this := this nextLink
].
- this isNil ifTrue:[ ^ self add:linkToAdd ].
+ this isNil ifTrue:[^ self add:linkToAdd ].
linkToAdd nextLink:(this nextLink).
this nextLink:linkToAdd.
^ linkToAdd
@@ -190,17 +219,17 @@
|link|
firstLink isNil ifTrue:[
- self errorIsEmpty
+ self errorIsEmpty
] ifFalse:[
- link := firstLink.
- (firstLink == lastLink) ifTrue:[
- firstLink := nil.
- lastLink := nil
- ] ifFalse:[
- firstLink := firstLink nextLink
- ].
- link nextLink:nil.
- numberOfNodes := numberOfNodes - 1
+ link := firstLink.
+ (firstLink == lastLink) ifTrue:[
+ firstLink := nil.
+ lastLink := nil
+ ] ifFalse:[
+ firstLink := firstLink nextLink
+ ].
+ link nextLink:nil.
+ numberOfNodes := numberOfNodes - 1
].
^ link
!
@@ -213,26 +242,26 @@
thisNode := firstLink.
[thisNode notNil] whileTrue:[
- nextNode := thisNode nextLink.
- (thisNode == aLink) ifTrue:[
- prevNode isNil ifTrue:[
- firstLink := thisNode nextLink
- ] ifFalse:[
- prevNode nextLink:(thisNode nextLink)
- ].
- (lastLink == thisNode) ifTrue:[
- thisNode nextLink isNil ifTrue:[
- lastLink := prevNode
- ] ifFalse:[
- lastLink := thisNode nextLink
- ]
- ].
- numberOfNodes := numberOfNodes - 1.
- thisNode nextLink:nil.
- ^ self
- ].
- prevNode := thisNode.
- thisNode := nextNode
+ nextNode := thisNode nextLink.
+ (thisNode == aLink) ifTrue:[
+ prevNode isNil ifTrue:[
+ firstLink := thisNode nextLink
+ ] ifFalse:[
+ prevNode nextLink:(thisNode nextLink)
+ ].
+ (lastLink == thisNode) ifTrue:[
+ thisNode nextLink isNil ifTrue:[
+ lastLink := prevNode
+ ] ifFalse:[
+ lastLink := thisNode nextLink
+ ]
+ ].
+ numberOfNodes := numberOfNodes - 1.
+ thisNode nextLink:nil.
+ ^ self
+ ].
+ prevNode := thisNode.
+ thisNode := nextNode
].
^ exceptionBlock value
! !
@@ -246,19 +275,19 @@
thisNode := firstLink.
[thisNode notNil] whileTrue:[
- aBlock value:thisNode.
- thisNode := thisNode nextLink
+ aBlock value:thisNode.
+ thisNode := thisNode nextLink
]
!
reverseDo:aBlock fromNode:aNode
- "helper for reverseDo:"
+ "helper for reverseDo: - this implementation is very expensive."
aNode notNil ifTrue:[
- aNode nextLink notNil ifTrue:[
- self reverseDo:aBlock fromNode:(aNode nextLink)
- ].
- aBlock value:aNode
+ aNode nextLink notNil ifTrue:[
+ self reverseDo:aBlock fromNode:(aNode nextLink)
+ ].
+ aBlock value:aNode
]
!
--- a/Make.proto Mon Oct 10 01:29:01 1994 +0100
+++ b/Make.proto Mon Oct 10 01:29:28 1994 +0100
@@ -1,4 +1,4 @@
-# $Header: /cvs/stx/stx/libbasic/Make.proto,v 1.15 1994-08-23 23:11:45 claus Exp $
+# $Header: /cvs/stx/stx/libbasic/Make.proto,v 1.16 1994-10-10 00:29:28 claus Exp $
#
# -------------- no need to change anything below ----------
@@ -11,93 +11,96 @@
all:: abbrev.stc objs classList.stc $(OBJTARGET)
-objs:: \
- Object.$(O) \
+objs:: \
+ Object.$(O) \
Autoload.$(O) \
Behavior.$(O) \
- ClassDescr.$(O) \
- Class.$(O) \
- Metaclass.$(O) \
+ ClassDescr.$(O) \
+ Class.$(O) \
+ Metaclass.$(O) \
Boolean.$(O) \
- True.$(O) \
- False.$(O) \
+ True.$(O) \
+ False.$(O) \
CCReader.$(O) \
Coll.$(O) \
- Bag.$(O) \
- FileDir.$(O) \
- SeqColl.$(O) \
- ArrColl.$(O) \
- Array.$(O) \
- WeakArr.$(O) \
- ByteArray.$(O) \
- AbstrStr.$(O) \
- String.$(O) \
- Symbol.$(O) \
- UIBytes.$(O) \
- DoubleArray.$(O) \
- ExtBytes.$(O) \
- FloatArray.$(O) \
- Interval.$(O) \
- LinkList.$(O) \
- Semaphore.$(O) \
- OrdColl.$(O) \
- SortColl.$(O) \
- Set.$(O) \
- Dict.$(O) \
- IdDict.$(O) \
- WeakIdDict.$(O) \
- IdSet.$(O) \
- WeakIdSet.$(O) \
- SignalSet.$(O) \
+ Bag.$(O) \
+ FileDir.$(O) \
+ SeqColl.$(O) \
+ ArrColl.$(O) \
+ Array.$(O) \
+ WeakArr.$(O) \
+ ByteArray.$(O) \
+ AbstrStr.$(O) \
+ String.$(O) \
+ Symbol.$(O) \
+ UIBytes.$(O) \
+ DoubleArray.$(O) \
+ ExtBytes.$(O) \
+ FloatArray.$(O) \
+ Interval.$(O) \
+ LinkList.$(O) \
+ Semaphore.$(O) \
+ OrdColl.$(O) \
+ SortColl.$(O) \
+ Set.$(O) \
+ Dict.$(O) \
+ IdDict.$(O) \
+ WeakIdDict.$(O) \
+ IdSet.$(O) \
+ WeakIdSet.$(O) \
+ SignalSet.$(O) \
Context.$(O) \
- BContext.$(O) \
- Delay.$(O) \
+ BContext.$(O) \
+ Delay.$(O) \
Exception.$(O) \
ExecFunc.$(O) \
- ExecCode.$(O) \
- Block.$(O) \
- Method.$(O) \
+ ExecCode.$(O) \
+ Block.$(O) \
+ CheapBlk.$(O) \
+ Method.$(O) \
Filename.$(O) \
Link.$(O) \
- Process.$(O) \
+ Process.$(O) \
Magnitude.$(O) \
- Assoc.$(O) \
- AbsTime.$(O) \
- Time.$(O) \
- ArithVal.$(O) \
- Number.$(O) \
- Fraction.$(O) \
- Integer.$(O) \
- LargeInt.$(O) \
- SmallInt.$(O) \
- LPReal.$(O) \
- Float.$(O) \
- Point.$(O) \
- Character.$(O) \
- Date.$(O) \
+ LookupKey.$(O) \
+ Assoc.$(O) \
+ AbsTime.$(O) \
+ Time.$(O) \
+ ArithVal.$(O) \
+ Number.$(O) \
+ Fraction.$(O) \
+ Integer.$(O) \
+ LargeInt.$(O) \
+ SmallInt.$(O) \
+ LPReal.$(O) \
+ Float.$(O) \
+ Point.$(O) \
+ Character.$(O) \
+ Date.$(O) \
Message.$(O) \
MiniDebug.$(O) \
MiniIns.$(O) \
ObjMem.$(O) \
ProcSched.$(O) \
- Queue.$(O) \
- SharedQueue.$(O) \
+ Queue.$(O) \
+ SharedQueue.$(O) \
Rectangle.$(O) \
Registry.$(O) \
Signal.$(O) \
SMALLTALK \
Stream.$(O) \
- PeekStr.$(O) \
- PosStream.$(O) \
- ReadStr.$(O) \
- WriteStr.$(O) \
- RWStream.$(O) \
- ActorStr.$(O) \
- ExtStream.$(O) \
- FileStr.$(O) \
- DirStr.$(O) \
- NPExtStr.$(O) \
- PipeStr.$(O) \
+ PeekStr.$(O) \
+ PosStream.$(O) \
+ ReadStr.$(O) \
+ WriteStr.$(O) \
+ RWStream.$(O) \
+ ActorStr.$(O) \
+ ExtStream.$(O) \
+ FileStr.$(O) \
+ DirStr.$(O) \
+ UnbndExtStr.$(O) \
+ NPExtStr.$(O) \
+ PipeStr.$(O) \
UndefObj.$(O) \
Unix.$(O)
@@ -120,25 +123,25 @@
SMALLTALK:
$(MAKE) Smalltalk.$(O) \
- DEFS="$(DEFS) -DCONFIGURATION_STRING='\\\"$(CONF_STRING)\\\"' "
+ DEFS="$(DEFS) -DCONFIGURATION_STRING='\\\"$(CONF_STRING)\\\"' "
# Class:
-# $(MAKE) Class.$(O) OPT=""
+# $(MAKE) Class.$(O) OPT=""
#
# Metaclass:
-# $(MAKE) Metaclass.$(O) OPT=""
+# $(MAKE) Metaclass.$(O) OPT=""
#
# i_Class.$(O):
-# $(MAKE) I_CLASS OPT=""
+# $(MAKE) I_CLASS OPT=""
#
# i_Metaclass.$(O):
-# $(MAKE) I_METACLASS OPT=""
+# $(MAKE) I_METACLASS OPT=""
#
# I_CLASS:
-# $(CC) -c $(CFLAGS) i_Class.c
+# $(CC) -c $(CFLAGS) i_Class.c
#
# I_METACLASS:
-# $(CC) -c $(CFLAGS) i_Metaclass.c
+# $(CC) -c $(CFLAGS) i_Metaclass.c
cleanjunk::
-rm -f *.c *.H
@@ -152,9 +155,9 @@
tar:
rm -f $(TOP)/DISTRIB/libbasic.tar*
(cd $(TOP); tar cvf DISTRIB/libbasic.tar \
- libbasic/Make.proto \
- libbasic/*.st \
- libbasic/resources) \
+ libbasic/Make.proto \
+ libbasic/*.st \
+ libbasic/resources) \
compress $(TOP)/DISTRIB/libbasic.tar
@@ -180,9 +183,9 @@
Autoload.$(O): Autoload.st $(OBJECT)
Smalltalk.$(O): Smalltalk.st $(OBJECT)
ObjMem.$(O): ObjMem.st $(OBJECT)
-Process.$(O): Process.st $(OBJECT)
+Process.$(O): Process.st $(I)/Link.H $(OBJECT)
ProcSched.$(O): ProcSched.st $(OBJECT)
-Semaphore.$(O): Semaphore.st $(OBJECT)
+Semaphore.$(O): Semaphore.st $(I)/LinkList.H $(OBJECT)
Queue.$(O): Queue.st $(OBJECT)
Delay.$(O): Delay.st $(OBJECT)
SharedQueue.$(O): SharedQueue.st $(I)/Queue.H $(OBJECT)
@@ -191,10 +194,11 @@
MiniIns.$(O): MiniIns.st $(OBJECT)
Context.$(O): Context.st $(OBJECT)
BContext.$(O): BContext.st $(I)/Context.H $(OBJECT)
-ExecFunc.$(O): ExecFunc.st $(OBJECT)
-ExecCode.$(O): ExecCode.st $(I)/ExecFunc.H $(OBJECT)
+ExecFunc.$(O): ExecFunc.st $(OBJECT)
+ExecCode.$(O): ExecCode.st $(I)/ExecFunc.H $(OBJECT)
Method.$(O): Method.st $(I)/ExecCode.H $(I)/ExecFunc.H $(OBJECT)
Block.$(O): Block.st $(I)/ExecCode.H $(I)/ExecFunc.H $(OBJECT)
+CheapBlk.$(O): CheapBlk.st $(I)/Block.H $(I)/ExecCode.H $(I)/ExecFunc.H $(OBJECT)
BlckContext.$(O): BlckContext.st $(OBJECT)
Signal.$(O): Signal.st $(OBJECT)
@@ -222,7 +226,8 @@
INTEGER=$(I)/Integer.H $(NUMBER)
Magnitude.$(O): Magnitude.st $(OBJECT)
-Assoc.$(O): Assoc.st $(MAGNITUDE)
+LookupKey.$(O): LookupKey.st $(MAGNITUDE)
+Assoc.$(O): Assoc.st $(I)/LookupKey.H $(MAGNITUDE)
Point.$(O): Point.st $(MAGNITUDE)
Character.$(O): Character.st $(MAGNITUDE)
ArithVal.$(O): ArithVal.st $(MAGNITUDE)
@@ -253,7 +258,7 @@
Coll.$(O): Coll.st $(OBJECT)
FileDir.$(O): FileDir.st $(COLL)
SeqColl.$(O): SeqColl.st $(COLL)
-MappedColl.$(O): MappedColl.st $(COLL)
+# MappedColl.$(O): MappedColl.st $(COLL)
Set.$(O): Set.st $(COLL)
IdSet.$(O): IdSet.st $(SET)
SignalSet.$(O): SignalSet.st $(I)/IdSet.H $(SET)
@@ -261,22 +266,22 @@
Dict.$(O): Dict.st $(COLL)
IdDict.$(O): IdDict.st $(DICT)
WeakIdSet.$(O): WeakIdSet.st $(IDDICT)
-CacheDict.$(O): CacheDict.st $(DICT)
+# CacheDict.$(O): CacheDict.st $(DICT)
WeakIdDict.$(O): WeakIdDict.st $(IDDICT)
OrdColl.$(O): OrdColl.st $(SEQCOLL)
SortColl.$(O): SortColl.st $(I)/OrdColl.H $(SEQCOLL)
-ChangeSet.$(O): ChangeSet.st $(I)/OrdColl.H $(SEQCOLL)
+# ChangeSet.$(O): ChangeSet.st $(I)/OrdColl.H $(SEQCOLL)
Interval.$(O): Interval.st $(SEQCOLL)
-Node.$(O): Node.st $(COLL)
-Tree.$(O): Tree.st $(COLL)
+# Node.$(O): Node.st $(COLL)
+# Tree.$(O): Tree.st $(COLL)
LinkList.$(O): LinkList.st $(SEQCOLL)
Link.$(O): Link.st $(OBJECT)
-ValLink.$(O): ValLink.st $(I)/Link.H $(OBJECT)
+# ValLink.$(O): ValLink.st $(I)/Link.H $(OBJECT)
ArrColl.$(O): ArrColl.st $(SEQCOLL)
-VarArray.$(O): VarArray.st $(ARRCOLL)
-VarString.$(O): VarString.st $(ARRCOLL)
-Text.$(O): Text.st $(VARARRAY)
-FileText.$(O): FileText.st $(I)/Text.H $(VARARRAY)
+# VarArray.$(O): VarArray.st $(ARRCOLL)
+# VarString.$(O): VarString.st $(ARRCOLL)
+# Text.$(O): Text.st $(VARARRAY)
+# FileText.$(O): FileText.st $(I)/Text.H $(VARARRAY)
Array.$(O): Array.st $(ARRCOLL)
WeakArr.$(O): WeakArr.st $(ARRAY)
FloatArray.$(O): FloatArray.st $(ARRCOLL)
@@ -286,26 +291,27 @@
UIBytes.$(O): UIBytes.st $(BYTEARRAY)
AbstrStr.$(O): AbstrStr.st $(BYTEARRAY)
String.$(O): String.st $(I)/AbstrStr.H $(BYTEARRAY)
-TwoByteStr.$(O): TwoByteStr.st $(I)/AbstrStr.H $(BYTEARRAY)
+# TwoByteStr.$(O): TwoByteStr.st $(I)/AbstrStr.H $(BYTEARRAY)
Symbol.$(O): Symbol.st $(STRING)
Filename.$(O): Filename.st $(STRING)
-Change.$(O): Change.st $(OBJECT)
-ClassChg.$(O): ClassChg.st $(OBJECT)
-ClsDefChg.$(O): ClsDefChg.st $(OBJECT)
-ClsComChg.$(O): ClsComChg.st $(OBJECT)
-MethodChg.$(O): MethodChg.st $(OBJECT)
+# Change.$(O): Change.st $(OBJECT)
+# ClassChg.$(O): ClassChg.st $(OBJECT)
+# ClsDefChg.$(O): ClsDefChg.st $(OBJECT)
+# ClsComChg.$(O): ClsComChg.st $(OBJECT)
+# MethodChg.$(O): MethodChg.st $(OBJECT)
STREAM=$(I)/Stream.H $(OBJECT)
POSSTREAM=$(I)/PosStream.H $(STREAM)
WRITESTREAM=$(I)/WriteStr.H $(POSSTREAM)
RWSTREAM=$(I)/RWStream.H $(WRITESTREAM)
EXTSTREAM=$(I)/ExtStream.H $(RWSTREAM)
-NPEXTSTREAM=$(I)/NPExtStr.H $(EXTSTREAM)
-PIPESTREAM=$(I)/PipeStr.H $(NPEXTSTREAM)
+UNBNDEXTSTREAM=$(I)/UnbndExtStr.H $(EXTSTREAM)
+NPEXTSTREAM=$(I)/NPExtStr.H $(UNBNDEXTSTREAM)
+PIPESTREAM=$(I)/PipeStr.H $(UNBNDEXTSTREAM)
Stream.$(O): Stream.st $(OBJECT)
-Random.$(O): Random.st $(STREAM)
+# Random.$(O): Random.st $(STREAM)
PeekStr.$(O): PeekStr.st $(STREAM)
PosStream.$(O): PosStream.st $(I)/PeekStr.H $(STREAM)
ReadStr.$(O): ReadStr.st $(POSSTREAM)
@@ -313,10 +319,11 @@
RWStream.$(O): RWStream.st $(WRITESTREAM)
ActorStr.$(O): ActorStr.st $(RWSTREAM)
ExtStream.$(O): ExtStream.st $(RWSTREAM)
-NPExtStr.$(O): NPExtStr.st $(EXTSTREAM)
-TTYStream.$(O): TTYStream.st $(NPEXTSTREAM)
-PipeStr.$(O): PipeStr.st $(NPEXTSTREAM)
-Socket.$(O): Socket.st $(NPEXTSTREAM)
+UnbndExtStr.$(O): UnbndExtStr.st $(EXTSTREAM)
+NPExtStr.$(O): NPExtStr.st $(UNBNDEXTSTREAM)
+# TTYStream.$(O): TTYStream.st $(UNBNDEXTSTREAM)
+PipeStr.$(O): PipeStr.st $(UNBNDEXTSTREAM)
+# Socket.$(O): Socket.st $(NPEXTSTREAM)
FileStr.$(O): FileStr.st $(EXTSTREAM)
-SoundStr.$(O): SoundStr.st $(I)/FileStr.H $(EXTSTREAM)
+# SoundStr.$(O): SoundStr.st $(I)/FileStr.H $(EXTSTREAM)
DirStr.$(O): DirStr.st $(I)/FileStr.H $(EXTSTREAM)
--- a/Message.st Mon Oct 10 01:29:01 1994 +0100
+++ b/Message.st Mon Oct 10 01:29:28 1994 +0100
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1988 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Message.st,v 1.10 1994-08-24 21:51:39 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Message.st,v 1.11 1994-10-10 00:26:37 claus Exp $
'!
!Message class methodsFor:'documentation'!
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Message.st,v 1.10 1994-08-24 21:51:39 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Message.st,v 1.11 1994-10-10 00:26:37 claus Exp $
"
!
@@ -71,35 +71,40 @@
selector:aSymbol
"return a new message object for a send without arguments"
- ^ self basicNew selector:aSymbol
- arguments:nil
+ ^ self basicNew setSelector:aSymbol arguments:nil
!
selector:aSymbol with:anArg
- "return a new message object for a send with one argument"
+ "return a new message object for a send with one argument.
+ OBSOLETE: use #selector:argument: for ST-80 compatibility."
- ^ self basicNew selector:aSymbol
- arguments:(Array with:anArg)
+ ^ self basicNew setSelector:aSymbol arguments:(Array with:anArg)
!
selector:aSymbol with:arg1 with:arg2
- "return a new message object for a send with two arguments"
+ "return a new message object for a send with two arguments.
+ OBSOLETE: use #selector:arguments: for ST-80 compatibility."
- ^ self basicNew selector:aSymbol
- arguments:(Array with:arg1 with:arg2)
+ ^ self basicNew setSelector:aSymbol arguments:(Array with:arg1 with:arg2)
!
selector:aSymbol withAll:argArray
"return a new message object for a send with many arguments.
- This is going to be obsolete; use #selector:arguments:"
+ OBSOLETE: use #selector:arguments: for ST-80 compatibilty."
+
+ ^ self basicNew setSelector:aSymbol arguments:argArray
+!
- ^ self basicNew selector:aSymbol arguments:argArray
+selector:aSymbol argument:anArg
+ "return a new message object for a send with one argument"
+
+ ^ self basicNew setSelector:aSymbol arguments:(Array with:anArg)
!
selector:aSymbol arguments:argArray
"return a new message object for a send with many arguments"
- ^ self basicNew selector:aSymbol arguments:argArray
+ ^ self basicNew setSelector:aSymbol arguments:argArray
! !
!Message class methodsFor:'queries'!
@@ -112,7 +117,7 @@
!Message methodsFor:'private accessing'!
-selector:aSymbol arguments:argArray
+setSelector:aSymbol arguments:argArray
"set selector and arguments of the receiver"
selector := aSymbol.
--- a/Metaclass.st Mon Oct 10 01:29:01 1994 +0100
+++ b/Metaclass.st Mon Oct 10 01:29:28 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1988 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -19,9 +19,9 @@
Metaclass comment:'
COPYRIGHT (c) 1988 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Metaclass.st,v 1.14 1994-08-05 00:58:57 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Metaclass.st,v 1.15 1994-10-10 00:26:39 claus Exp $
'!
!Metaclass class methodsFor:'documentation'!
@@ -29,7 +29,7 @@
copyright
"
COPYRIGHT (c) 1988 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Metaclass.st,v 1.14 1994-08-05 00:58:57 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Metaclass.st,v 1.15 1994-10-10 00:26:39 claus Exp $
"
!
@@ -57,16 +57,16 @@
!Metaclass methodsFor:'creating classes'!
name:newName inEnvironment:aSystemDictionary
- subclassOf:aClass
- instanceVariableNames:stringOfInstVarNames
- variable:variableBoolean
- words:wordsBoolean
- pointers:pointersBoolean
- classVariableNames:stringOfClassVarNames
- poolDictionaries:stringOfPoolNames
- category:categoryString
- comment:commentString
- changed:changed
+ subclassOf:aClass
+ instanceVariableNames:stringOfInstVarNames
+ variable:variableBoolean
+ words:wordsBoolean
+ pointers:pointersBoolean
+ classVariableNames:stringOfClassVarNames
+ poolDictionaries:stringOfPoolNames
+ category:categoryString
+ comment:commentString
+ changed:changed
"this is the main workhorse for installing new classes - special care
has to be taken, when changing an existing classes definition. In this
@@ -84,18 +84,19 @@
"NOTICE:
this method is too complex and should be splitted into managable pieces ...
- I dont like it anymore :-)
+ I dont like it anymore :-)
+ (However, its a good test for the compilers ability to handle big, complex methods ;-)
"
newName = aClass name ifTrue:[
- self error:'trying to create circular class definition'.
- ^ nil
+ self error:'trying to create circular class definition'.
+ ^ nil
].
"check for invalid subclassing of UndefinedObject and SmallInteger"
aClass canBeSubclassed ifFalse:[
- self error:('it is not possible to subclass ' , aClass name).
- ^ oldClass
+ self error:('it is not possible to subclass ' , aClass name).
+ ^ oldClass
].
nInstVars := stringOfInstVarNames countWords.
@@ -106,52 +107,52 @@
"look, if it already exists as a class"
oldClass := aSystemDictionary at:classSymbol ifAbsent:[nil].
oldClass isBehavior ifFalse:[
- oldClass := nil.
+ oldClass := nil.
] ifTrue:[
- oldClass superclass notNil ifTrue:[
- oldClass allSuperclasses do:[:cls |
- cls name = nameString ifTrue:[
- self error:'trying to create circular class definition'.
- ^ nil
- ]
- ]
- ].
+ oldClass superclass notNil ifTrue:[
+ oldClass allSuperclasses do:[:cls |
+ cls name = nameString ifTrue:[
+ self error:'trying to create circular class definition'.
+ ^ nil
+ ]
+ ]
+ ].
- aClass superclass notNil ifTrue:[
- aClass allSuperclasses do:[:cls |
- cls name = nameString ifTrue:[
- self error:'trying to create circular class definition'.
- ^ nil
- ]
- ].
- ].
+ aClass superclass notNil ifTrue:[
+ aClass allSuperclasses do:[:cls |
+ cls name = nameString ifTrue:[
+ self error:'trying to create circular class definition'.
+ ^ nil
+ ]
+ ].
+ ].
- newComment isNil ifTrue:[
- newComment := oldClass comment
- ].
+ newComment isNil ifTrue:[
+ newComment := oldClass comment
+ ].
- "
- warn, if it exists with different category and different instvars,
- and the existing is not an autoload class.
- Usually, this indicates that someone wants to create a new class with
- a name, which already exists (it happened a few times to myself, while
- I wanted to create a new class called ReturnNode ...).
- This will be much less of a problem, once multiple name spaces are
- implemented and classes can be put into separate packages.
- "
- oldClass isLoaded ifTrue:[
- oldClass category ~= categoryString ifTrue:[
- oldClass instanceVariableString asCollectionOfWords
- ~= stringOfInstVarNames asCollectionOfWords ifTrue:[
- (self confirm:'a class named ' , oldClass name , ' already exists -
+ "
+ warn, if it exists with different category and different instvars,
+ and the existing is not an autoload class.
+ Usually, this indicates that someone wants to create a new class with
+ a name, which already exists (it happened a few times to myself, while
+ I wanted to create a new class called ReturnNode ...).
+ This will be much less of a problem, once multiple name spaces are
+ implemented and classes can be put into separate packages.
+ "
+ oldClass isLoaded ifTrue:[
+ oldClass category ~= categoryString ifTrue:[
+ oldClass instanceVariableString asCollectionOfWords
+ ~= stringOfInstVarNames asCollectionOfWords ifTrue:[
+ (self confirm:'a class named ' , oldClass name , ' already exists -
create (i.e. change) anyway ?' withCRs)
- ifFalse:[
- ^ nil
- ]
- ]
- ]
- ]
+ ifFalse:[
+ ^ nil
+ ]
+ ]
+ ]
+ ]
].
"
@@ -166,50 +167,50 @@
"
oldClass isNil ifTrue:[
- "let user confirm, if the classname is no good"
- newName first isUppercase ifFalse:[
- (self confirm:'classenames should start with an uppercase letter
+ "let user confirm, if the classname is no good"
+ newName first isUppercase ifFalse:[
+ (self confirm:'classenames should start with an uppercase letter
(by convention only)
install anyway ?' withCRs)
- ifFalse:[
- ^ nil
- ]
- ].
+ ifFalse:[
+ ^ nil
+ ]
+ ].
- "let user confirm, if any instvarname is no good"
- (stringOfInstVarNames asCollectionOfWords
- inject:true
- into:[:okSoFar :word |
- okSoFar and:[word first isLowercase]
- ]
+ "let user confirm, if any instvarname is no good"
+ (stringOfInstVarNames asCollectionOfWords
+ inject:true
+ into:[:okSoFar :word |
+ okSoFar and:[word first isLowercase]
+ ]
- ) ifFalse:[
- (self confirm:'instance variable names should start with a lowercase letter
+ ) ifFalse:[
+ (self confirm:'instance variable names should start with a lowercase letter
(by convention only)
install anyway ?' withCRs)
- ifFalse:[
- ^ nil
- ]
- ].
+ ifFalse:[
+ ^ nil
+ ]
+ ].
- "let user confirm, if any classvarname is no good"
- (stringOfClassVarNames asCollectionOfWords
- inject:true
- into:[:okSoFar :word |
- okSoFar and:[word first isUppercase]
- ]
+ "let user confirm, if any classvarname is no good"
+ (stringOfClassVarNames asCollectionOfWords
+ inject:true
+ into:[:okSoFar :word |
+ okSoFar and:[word first isUppercase]
+ ]
- ) ifFalse:[
- (self confirm:'class variable names should start with an uppercase letter
+ ) ifFalse:[
+ (self confirm:'class variable names should start with an uppercase letter
(by convention only)
install anyway ?' withCRs)
- ifFalse:[
- ^ nil
- ]
- ]
+ ifFalse:[
+ ^ nil
+ ]
+ ]
].
"create the metaclass first"
@@ -234,49 +235,49 @@
while ST/X also calls it with symbols such as #float, #double etc.
"
(variableBoolean == true) ifTrue:[
- pointersBoolean ifTrue:[
- newFlags := Behavior flagPointers
- ] ifFalse:[
- wordsBoolean ifTrue:[
- newFlags := Behavior flagWords
- ] ifFalse:[
- newFlags := Behavior flagBytes
- ]
- ]
+ pointersBoolean ifTrue:[
+ newFlags := Behavior flagPointers
+ ] ifFalse:[
+ wordsBoolean ifTrue:[
+ newFlags := Behavior flagWords
+ ] ifFalse:[
+ newFlags := Behavior flagBytes
+ ]
+ ]
] ifFalse:[
- (variableBoolean == #float) ifTrue:[
- newFlags := Behavior flagFloats
- ] ifFalse:[
- (variableBoolean == #double) ifTrue:[
- newFlags := Behavior flagDoubles
- ] ifFalse:[
- (variableBoolean == #long) ifTrue:[
- newFlags := Behavior flagLongs
- ] ifFalse:[
- newFlags := Behavior flagNotIndexed
- ]
- ]
- ].
+ (variableBoolean == #float) ifTrue:[
+ newFlags := Behavior flagFloats
+ ] ifFalse:[
+ (variableBoolean == #double) ifTrue:[
+ newFlags := Behavior flagDoubles
+ ] ifFalse:[
+ (variableBoolean == #long) ifTrue:[
+ newFlags := Behavior flagLongs
+ ] ifFalse:[
+ newFlags := Behavior flagNotIndexed
+ ]
+ ]
+ ].
].
superFlags := aClass flags bitAnd:(Behavior maskIndexType bitInvert). "preserve other bits"
oldClass notNil ifTrue:[
- oldClass isBuiltInClass ifTrue:[
- "
- special care when redefining Method, Block and other built-in classes,
- which might have other flag bits ...
- "
+ oldClass isBuiltInClass ifTrue:[
+ "
+ special care when redefining Method, Block and other built-in classes,
+ which might have other flag bits ...
+ "
- newFlags := newFlags bitOr:(oldClass flags bitAnd:(Behavior maskIndexType bitInvert))
- ]
+ newFlags := newFlags bitOr:(oldClass flags bitAnd:(Behavior maskIndexType bitInvert))
+ ]
].
newClass flags:(newFlags bitOr:superFlags). "preserve inherited special bits"
(nInstVars ~~ 0) ifTrue:[
- newClass instanceVariableString:stringOfInstVarNames
+ newClass instanceVariableString:stringOfInstVarNames
].
oldClass notNil ifTrue:[
- "setting first will make new class clear obsolete classvars"
- newClass setClassVariableString:(oldClass classVariableString)
+ "setting first will make new class clear obsolete classvars"
+ newClass setClassVariableString:(oldClass classVariableString)
].
newClass classVariableString:stringOfClassVarNames.
@@ -285,17 +286,17 @@
(also for autoloaded classes)
"
(oldClass isNil or:[oldClass isLoaded not]) ifTrue:[
- oldClass isNil ifTrue:[
- self addChangeRecordForClass:newClass.
- ].
+ oldClass isNil ifTrue:[
+ self addChangeRecordForClass:newClass.
+ ].
- commentString notNil ifTrue:[
- newClass comment:commentString
- ].
+ commentString notNil ifTrue:[
+ newClass comment:commentString
+ ].
- aSystemDictionary at:classSymbol put:newClass.
- aSystemDictionary changed.
- ^ newClass
+ aSystemDictionary at:classSymbol put:newClass.
+ aSystemDictionary changed:#newClass with:newClass.
+ ^ newClass
].
@@ -318,111 +319,108 @@
"
(oldClass superclass == newClass superclass) ifTrue:[
(oldClass instSize == newClass instSize) ifTrue:[
- (oldClass flags == newClass flags) ifTrue:[
- (oldClass name = newClass name) ifTrue:[
- (oldInstVars = newInstVars) ifTrue:[
-
- (newComment ~= oldClass comment) ifTrue:[
- oldClass comment:newComment. "writes a change-chunk"
- ].
+ (oldClass flags == newClass flags) ifTrue:[
+ (oldClass name = newClass name) ifTrue:[
+ (oldInstVars = newInstVars) ifTrue:[
- (oldClassVars = newClassVars) ifTrue:[
- "
- really no change (just comment and/or category)
- "
- anyChange := false.
+ (newComment ~= oldClass comment) ifTrue:[
+ oldClass setComment:newComment. "writes a change-chunk"
+ oldClass changed:#comment with:oldClass comment.
+ self addChangeRecordForClassComment:oldClass.
+ ].
- oldClass instanceVariableString:(newClass instanceVariableString).
- oldClass setClassVariableString:(newClass classVariableString).
+ (oldClassVars = newClassVars) ifTrue:[
+ "
+ really no change (just comment and/or category)
+ "
+ anyChange := false.
- oldClass category ~= categoryString ifTrue:[
- "notify change of organization"
+ oldClass instanceVariableString:(newClass instanceVariableString).
+ oldClass setClassVariableString:(newClass classVariableString).
- oldClass category:categoryString.
- self addChangeRecordForClass:newClass.
- aSystemDictionary changed
- ].
- "notify change of class"
- oldClass changed.
- ^ oldClass
- ].
+ oldClass category ~= categoryString ifTrue:[
+ oldClass category:categoryString.
+ self addChangeRecordForClass:newClass.
+ "notify change of organization"
+ aSystemDictionary changed
+ ].
+ "notify change of class"
+"/ oldClass changed.
+ ^ oldClass
+ ].
- "
- when we arrive here, class variables have changed
- "
- oldClass category ~= categoryString ifTrue:[
- "notify change of organization"
- oldClass category:categoryString.
- aSystemDictionary changed
- ].
-
- "
- set class variable string;
- this also updates the set of class variables
- by creating new / deleting obsolete ones.
- "
- oldClass classVariableString:stringOfClassVarNames.
+ "
+ when we arrive here, class variables have changed
+ "
+ oldClass category ~= categoryString ifTrue:[
+ "notify change of organization"
+ oldClass category:categoryString.
+ "notify change of organization"
+ aSystemDictionary changed
+ ].
- "
- get the set of changed class variables
- "
- changeSet1 := Set new.
- oldClassVars do:[:nm |
- (newClassVars includes:nm) ifFalse:[
- changeSet1 add:nm
- ]
- ].
- newClassVars do:[:nm |
- (oldClassVars includes:nm) ifFalse:[
- changeSet1 add:nm
- ]
- ].
+ "
+ set class variable string;
+ this also updates the set of class variables
+ by creating new / deleting obsolete ones.
+ "
+ oldClass classVariableString:stringOfClassVarNames.
- "
- recompile all methods accessing set of changed classvars
- here and also in all subclasses ...
- "
+ "
+ get the set of changed class variables
+ "
+ changeSet1 := Set new.
+ oldClassVars do:[:nm |
+ (newClassVars includes:nm) ifFalse:[
+ changeSet1 add:nm
+ ]
+ ].
+ newClassVars do:[:nm |
+ (oldClassVars includes:nm) ifFalse:[
+ changeSet1 add:nm
+ ]
+ ].
- "
- dont update change file for the recompilation
- "
- upd := Class updateChanges:false.
- [
+ "
+ recompile all methods accessing set of changed classvars
+ here and also in all subclasses ...
+ "
+
+ "
+ dont update change file for the recompilation
+ "
+ upd := Class updateChanges:false.
+ [
" "
- Transcript showCr:'recompiling class & inst methods accessing ' , changeSet1 printString.
- Transcript endEntry.
+ Transcript showCr:'recompiling class & inst methods accessing ' , changeSet1 printString.
+ Transcript endEntry.
" "
- oldClass withAllSubclasses do:[:aClass |
- aClass class recompileMethodsAccessingAny:changeSet1.
- aClass recompileMethodsAccessingAny:changeSet1.
- ].
- ] valueNowOrOnUnwindDo:[
- Class updateChanges:upd.
- ].
+ oldClass withAllSubclasses do:[:aClass |
+ aClass class recompileMethodsAccessingAny:changeSet1.
+ aClass recompileMethodsAccessingAny:changeSet1.
+ ].
+ ] valueNowOrOnUnwindDo:[
+ Class updateChanges:upd.
+ ].
- "notify change of class"
- self addChangeRecordForClass:oldClass.
- oldClass changed.
+ "notify change of class"
+ self addChangeRecordForClass:oldClass.
+ oldClass changed:#definition.
- ^ oldClass
- ]
- ]
- ]
+ ^ oldClass
+ ]
+ ]
+ ]
]
].
- "tell dependents ..."
-"OLD:
- oldClass changed.
-"
-
-
"
here we enter the darkness of mordor ...
+ since instance variable layout and/or inheritance has changed.
"
(newComment ~= oldClass comment) ifTrue:[
- newClass comment:newComment
+ newClass comment:newComment
].
superClassChange := oldClass superclass ~~ newClass superclass.
@@ -431,8 +429,8 @@
dont allow built-in classes to be modified this way
"
(oldClass notNil and:[oldClass isBuiltInClass and:[superClassChange]]) ifTrue:[
- self error:'the inheritance of this class is fixed - you cannot change it'.
- ^ oldClass
+ self error:'the inheritance of this class is fixed - you cannot change it'.
+ ^ oldClass
].
"
@@ -445,7 +443,7 @@
and:[(oldClassVars = newClassVars)
and:[(oldInstVars = newInstVars)
and:[newComment = oldClass comment]]]]) ifFalse:[
- self addChangeRecordForClass:newClass.
+ self addChangeRecordForClass:newClass.
].
"
@@ -456,61 +454,64 @@
classVarChange := false.
superClassChange ifTrue:[
- "
- superclass changed:
- must recompile all class methods accessing ANY classvar
- (
- actually, we could be less strict and handle the case where
- both the old and the new superclass have a common ancestor,
- and both have no new classvariables in between.
- This would speedup the case when a class is inserted into
- the inheritance chain.
- )
- "
+ "
+ superclass changed:
+ must recompile all class methods accessing ANY classvar
+ (
+ actually, we could be less strict and handle the case where
+ both the old and the new superclass have a common ancestor,
+ and both have no new classvariables in between.
+ This would speedup the case when a class is inserted into
+ the inheritance chain.
+ )
+ "
- oldClass allClassVarNames do:[:nm | changeSet1 add:nm].
- newClass allClassVarNames do:[:nm | changeSet1 add:nm].
+ oldClass allClassVarNames do:[:nm | changeSet1 add:nm].
+ newClass allClassVarNames do:[:nm | changeSet1 add:nm].
" "
- Transcript showCr:'recompiling class methods accessing any classvar'.
- Transcript endEntry.
+ Transcript showCr:'recompiling class methods accessing any classvar'.
+ Transcript endEntry.
" "
- self copyInvalidatedMethodsFrom:(oldClass class) for:newMetaclass accessingAny:changeSet1.
- newMetaclass recompileInvalidatedMethods:(Metaclass compiledMethodAt:#invalidMethod).
+ self copyInvalidatedMethodsFrom:(oldClass class)
+ for:newMetaclass
+ accessingAny:changeSet1
+ orSuper:true.
+ newMetaclass recompileInvalidatedMethods:(Metaclass compiledMethodAt:#invalidMethod).
] ifFalse:[
- "
- same superclass, find out which classvars have changed
- "
- classVarChange := oldClassVars ~= newClassVars.
- classVarChange ifTrue:[
- oldClassVars do:[:nm |
- (newClassVars includes:nm) ifFalse:[
- changeSet1 add:nm
- ]
- ].
- newClassVars do:[:nm |
- (oldClassVars includes:nm) ifFalse:[
- changeSet1 add:nm
- ]
- ].
- ].
+ "
+ same superclass, find out which classvars have changed
+ "
+ classVarChange := oldClassVars ~= newClassVars.
+ classVarChange ifTrue:[
+ oldClassVars do:[:nm |
+ (newClassVars includes:nm) ifFalse:[
+ changeSet1 add:nm
+ ]
+ ].
+ newClassVars do:[:nm |
+ (oldClassVars includes:nm) ifFalse:[
+ changeSet1 add:nm
+ ]
+ ].
+ ].
- classVarChange ifTrue:[
- "
- must recompile some class-methods
- "
+ classVarChange ifTrue:[
+ "
+ must recompile some class-methods
+ "
" "
- Transcript showCr:'recompiling class methods accessing ' , changeSet1 printString.
- Transcript endEntry.
+ Transcript showCr:'recompiling class methods accessing ' , changeSet1 printString.
+ Transcript endEntry.
" "
- self copyInvalidatedMethodsFrom:(oldClass class) for:newMetaclass accessingAny:changeSet1.
- newMetaclass recompileInvalidatedMethods:(Metaclass compiledMethodAt:#invalidMethod).
- ] ifFalse:[
- "
- class methods still work
- "
- self copyMethodsFrom:(oldClass class) for:newMetaclass
- ].
+ self copyInvalidatedMethodsFrom:(oldClass class) for:newMetaclass accessingAny:changeSet1.
+ newMetaclass recompileInvalidatedMethods:(Metaclass compiledMethodAt:#invalidMethod).
+ ] ifFalse:[
+ "
+ class methods still work
+ "
+ self copyMethodsFrom:(oldClass class) for:newMetaclass
+ ].
].
"
@@ -519,162 +520,165 @@
changeSet2 := Set new.
superClassChange ifTrue:[
- "superclass changed,
- must recompile all methods accessing any class or instvar.
- If number of instvars (i.e. the instances instSize) is the same,
- we can limit the set of recompiled instance methods to those methods,
- which refer to an instvar with a different inst-index
- "
+ "superclass changed,
+ must recompile all methods accessing any class or instvar.
+ If number of instvars (i.e. the instances instSize) is the same,
+ we can limit the set of recompiled instance methods to those methods,
+ which refer to an instvar with a different inst-index
+ "
- "
- collect the instvar-indices in the old and new class
- "
- offset := 0. oldOffsets := Dictionary new.
- oldClass allInstVarNames do:[:nm | offset := offset + 1. oldOffsets at:nm put:offset].
- offset := 0. newOffsets := Dictionary new.
- newClass allInstVarNames do:[:nm | offset := offset + 1. newOffsets at:nm put:offset].
+ "
+ collect the instvar-indices in the old and new class
+ "
+ offset := 0. oldOffsets := Dictionary new.
+ oldClass allInstVarNames do:[:nm | offset := offset + 1. oldOffsets at:nm put:offset].
+ offset := 0. newOffsets := Dictionary new.
+ newClass allInstVarNames do:[:nm | offset := offset + 1. newOffsets at:nm put:offset].
- "
- the changeset consists of instance variables,
- whith a different position
- "
- oldOffsets associationsDo:[:a |
- |k|
+ "
+ the changeset consists of instance variables,
+ whith a different position
+ "
+ oldOffsets associationsDo:[:a |
+ |k|
- k := a key.
- (newOffsets includesKey:k) ifFalse:[
- changeSet2 add:k
- ] ifTrue:[
- (a value ~~ (newOffsets at:k)) ifTrue:[
- changeSet2 add:k
- ]
- ]
- ].
- newOffsets associationsDo:[:a |
- |k|
+ k := a key.
+ (newOffsets includesKey:k) ifFalse:[
+ changeSet2 add:k
+ ] ifTrue:[
+ (a value ~~ (newOffsets at:k)) ifTrue:[
+ changeSet2 add:k
+ ]
+ ]
+ ].
+ newOffsets associationsDo:[:a |
+ |k|
- k := a key.
- (oldOffsets includesKey:k) ifFalse:[
- changeSet2 add:k
- ] ifTrue:[
- (a value ~~ (oldOffsets at:k)) ifTrue:[
- changeSet2 add:k
- ]
- ]
- ].
+ k := a key.
+ (oldOffsets includesKey:k) ifFalse:[
+ changeSet2 add:k
+ ] ifTrue:[
+ (a value ~~ (oldOffsets at:k)) ifTrue:[
+ changeSet2 add:k
+ ]
+ ]
+ ].
- "
- merge in the changed class variables
- "
- changeSet1 do:[:nm | changeSet2 add:nm].
+ "
+ merge in the changed class variables
+ "
+ changeSet1 do:[:nm | changeSet2 add:nm].
" "
- Transcript showCr:'recompiling instance methods accessing ' , changeSet2 printString , ' ...'.
- Transcript endEntry.
+ Transcript showCr:'recompiling instance methods accessing ' , changeSet2 printString , ' ...'.
+ Transcript endEntry.
" "
- self copyInvalidatedMethodsFrom:oldClass for:newClass accessingAny:changeSet2.
- newClass recompileInvalidatedMethods:(Metaclass compiledMethodAt:#invalidMethod).
+ self copyInvalidatedMethodsFrom:oldClass
+ for:newClass
+ accessingAny:changeSet2
+ orSuper:true.
+ newClass recompileInvalidatedMethods:(Metaclass compiledMethodAt:#invalidMethod).
] ifFalse:[
- "
- same inheritance ...
- "
- instVarChange := oldInstVars ~= newInstVars.
- instVarChange ifFalse:[
- "
- same instance variables ...
- "
- classVarChange ifTrue:[
- "recompile all inst methods accessing changed classvars"
+ "
+ same inheritance ...
+ "
+ instVarChange := oldInstVars ~= newInstVars.
+ instVarChange ifFalse:[
+ "
+ same instance variables ...
+ "
+ classVarChange ifTrue:[
+ "recompile all inst methods accessing changed classvars"
" "
- Transcript showCr:'recompiling instance methods accessing ' , changeSet1 printString , ' ...'.
- Transcript endEntry.
+ Transcript showCr:'recompiling instance methods accessing ' , changeSet1 printString , ' ...'.
+ Transcript endEntry.
" "
- self copyInvalidatedMethodsFrom:oldClass for:newClass accessingAny:changeSet1.
- newClass recompileInvalidatedMethods:(Metaclass compiledMethodAt:#invalidMethod).
- ]
- ] ifTrue:[
- "
- dont allow built-in classes to be modified
- "
- (oldClass notNil and:[oldClass isBuiltInClass and:[instVarChange]]) ifTrue:[
- self error:'the layout of this class is fixed - you cannot change it'.
- ^ oldClass
- ].
+ self copyInvalidatedMethodsFrom:oldClass for:newClass accessingAny:changeSet1.
+ newClass recompileInvalidatedMethods:(Metaclass compiledMethodAt:#invalidMethod).
+ ]
+ ] ifTrue:[
+ "
+ dont allow built-in classes to be modified
+ "
+ (oldClass notNil and:[oldClass isBuiltInClass and:[instVarChange]]) ifTrue:[
+ self error:'the layout of this class is fixed - you cannot change it'.
+ ^ oldClass
+ ].
- ((oldInstVars size == 0)
- or:[newInstVars startsWith:oldInstVars]) ifTrue:[
- "
- only new inst variable(s) has/have been added -
- old methods still work (the existing inst-indices are still valid)
- "
+ ((oldInstVars size == 0)
+ or:[newInstVars startsWith:oldInstVars]) ifTrue:[
+ "
+ only new inst variable(s) has/have been added -
+ old methods still work (the existing inst-indices are still valid)
+ "
" "
- Transcript showCr:'copying methods ...'.
- Transcript endEntry.
+ Transcript showCr:'copying methods ...'.
+ Transcript endEntry.
" "
- self copyMethodsFrom:oldClass for:newClass.
+ self copyMethodsFrom:oldClass for:newClass.
- "
- but: we have to recompile all methods accessing new instars
- (it might have been a classVar/global before ...)
- "
- addedNames := newInstVars select:[:nm | (oldInstVars includes:nm) not].
- "merge in class variables"
- changeSet1 do:[:nm | addedNames add:nm].
+ "
+ but: we have to recompile all methods accessing new instars
+ (it might have been a classVar/global before ...)
+ "
+ addedNames := newInstVars select:[:nm | (oldInstVars includes:nm) not].
+ "merge in class variables"
+ changeSet1 do:[:nm | addedNames add:nm].
" "
- Transcript showCr:'recompiling instance methods accessing ' , addedNames printString , '...'.
- Transcript endEntry.
+ Transcript showCr:'recompiling instance methods accessing ' , addedNames printString , '...'.
+ Transcript endEntry.
" "
- newClass recompileMethodsAccessingAny:addedNames.
- ] ifFalse:[
- "
- collect the instvar-indices in the old and new class
- "
- offset := 0. oldOffsets := Dictionary new.
- oldInstVars do:[:nm | offset := offset + 1. oldOffsets at:nm put:offset].
- offset := 0. newOffsets := Dictionary new.
- newInstVars do:[:nm | offset := offset + 1. newOffsets at:nm put:offset].
+ newClass recompileMethodsAccessingAny:addedNames.
+ ] ifFalse:[
+ "
+ collect the instvar-indices in the old and new class
+ "
+ offset := 0. oldOffsets := Dictionary new.
+ oldInstVars do:[:nm | offset := offset + 1. oldOffsets at:nm put:offset].
+ offset := 0. newOffsets := Dictionary new.
+ newInstVars do:[:nm | offset := offset + 1. newOffsets at:nm put:offset].
- "
- the changeset consists of instance variables,
- whith a different position
- "
- oldOffsets associationsDo:[:a |
- |k|
+ "
+ the changeset consists of instance variables,
+ whith a different position
+ "
+ oldOffsets associationsDo:[:a |
+ |k|
- k := a key.
- (newOffsets includesKey:k) ifFalse:[
- changeSet2 add:k
- ] ifTrue:[
- (a value ~~ (newOffsets at:k)) ifTrue:[
- changeSet2 add:k
- ]
- ]
- ].
- newOffsets associationsDo:[:a |
- |k|
+ k := a key.
+ (newOffsets includesKey:k) ifFalse:[
+ changeSet2 add:k
+ ] ifTrue:[
+ (a value ~~ (newOffsets at:k)) ifTrue:[
+ changeSet2 add:k
+ ]
+ ]
+ ].
+ newOffsets associationsDo:[:a |
+ |k|
- k := a key.
- (oldOffsets includesKey:k) ifFalse:[
- changeSet2 add:k
- ] ifTrue:[
- (a value ~~ (oldOffsets at:k)) ifTrue:[
- changeSet2 add:k
- ]
- ]
- ].
- "merge in class variables"
- changeSet1 do:[:nm | changeSet2 add:nm].
+ k := a key.
+ (oldOffsets includesKey:k) ifFalse:[
+ changeSet2 add:k
+ ] ifTrue:[
+ (a value ~~ (oldOffsets at:k)) ifTrue:[
+ changeSet2 add:k
+ ]
+ ]
+ ].
+ "merge in class variables"
+ changeSet1 do:[:nm | changeSet2 add:nm].
" "
- Transcript showCr:'recompiling instance methods accessing ' , changeSet2 printString , ' ...'.
- Transcript endEntry.
+ Transcript showCr:'recompiling instance methods accessing ' , changeSet2 printString , ' ...'.
+ Transcript endEntry.
" "
- self copyInvalidatedMethodsFrom:oldClass for:newClass accessingAny:changeSet2.
- newClass recompileInvalidatedMethods:(Metaclass compiledMethodAt:#invalidMethod).
- ].
- ].
+ self copyInvalidatedMethodsFrom:oldClass for:newClass accessingAny:changeSet2.
+ newClass recompileInvalidatedMethods:(Metaclass compiledMethodAt:#invalidMethod).
+ ].
+ ].
].
"
@@ -697,15 +701,15 @@
"
upd := Class updateChanges:false.
[
- oldClass subclassesDo:[:aClass |
+ oldClass subclassesDo:[:aClass |
" "
- Transcript showCr:'changing superclass of:' , aClass name.
- Transcript endEntry.
+ Transcript showCr:'changing superclass of:' , aClass name.
+ Transcript endEntry.
" "
- aClass superclass:newClass
- ]
+ aClass superclass:newClass
+ ]
] valueNowOrOnUnwindDo:[
- Class updateChanges:upd.
+ Class updateChanges:upd.
].
"
@@ -720,23 +724,23 @@
aSystemDictionary at:classSymbol put:newClass.
oldClass category ~= categoryString ifTrue:[
- "notify change of organization"
- aSystemDictionary changed
+ "notify change of organization"
+ aSystemDictionary changed
].
"
Not becoming the old class creates some update problems;
the browsers must check carefully - a simple identity compare is
- not enought ...
+ not enough ...
QUESTION: is this a good idea ?
"
newClass dependents:(oldClass dependents).
newClass changed.
- "just to make certain ... - telle dependents of oldClass, that something changed
+ "just to make certain ... - tell dependents of oldClass, that something changed
(systemBrowsers will react on this, and update their views)"
- oldClass changed:newClass.
+ oldClass changed:#definition with:newClass.
ObjectMemory flushCaches.
@@ -750,10 +754,10 @@
newClass := self basicNew.
newClass setSuperclass:(Object class)
- selectors:(Array new:0)
- methods:(Array new:0)
- instSize:0
- flags:(Behavior flagNotIndexed).
+ selectors:(Array new:0)
+ methods:(Array new:0)
+ instSize:0
+ flags:(Behavior flagNotIndexed).
newClass setComment:(self comment) category:(self category).
^ newClass
! !
@@ -778,9 +782,9 @@
oldVars := self instanceVariableString.
aString = oldVars ifTrue:[
"
- Transcript showCr:'no change (', oldVars , ') -> (', aString , ')'.
+ Transcript showCr:'no change (', oldVars , ') -> (', aString , ')'.
"
- ^ self
+ ^ self
].
oldNames := oldVars asCollectionOfWords.
@@ -788,35 +792,35 @@
oldNames = newNames ifTrue:[
"
- Transcript showCr:'no real change'.
+ Transcript showCr:'no real change'.
"
- "no real change (just formatting)"
- self instanceVariableString:aString.
- ^ self
+ "no real change (just formatting)"
+ self instanceVariableString:aString.
+ ^ self
].
"
let user confirm, if any name is no good (and was good before)
"
(oldNames inject:true
- into:[:okSoFar :word |
- okSoFar and:[word first isUppercase]
- ])
+ into:[:okSoFar :word |
+ okSoFar and:[word first isUppercase]
+ ])
ifTrue:[
- "was ok before"
- (newNames inject:true
- into:[:okSoFar :word |
- okSoFar and:[word first isUppercase]
- ])
- ifFalse:[
- (self confirm:'class instance variable names should start with an uppercase letter
+ "was ok before"
+ (newNames inject:true
+ into:[:okSoFar :word |
+ okSoFar and:[word first isUppercase]
+ ])
+ ifFalse:[
+ (self confirm:'class instance variable names should start with an uppercase letter
(by convention only)
install anyway ?' withCRs)
- ifFalse:[
- ^ nil
- ]
- ]
+ ifFalse:[
+ ^ nil
+ ]
+ ]
].
nClassInstVars := newNames size.
@@ -830,7 +834,7 @@
newMetaclass setSuperclass:superclass.
newMetaclass instSize:(superclass instSize + nClassInstVars).
(nClassInstVars ~~ 0) ifTrue:[
- newMetaclass instanceVariableString:aString
+ newMetaclass instanceVariableString:aString
].
newMetaclass flags:(Behavior flagNotIndexed).
newMetaclass setName:name.
@@ -842,8 +846,8 @@
t := Smalltalk allClasses select:[:element | element class == self].
(t size ~~ 1) ifTrue:[
- self error:'oops - I should have exactly one instance'.
- ^ nil
+ self error:'oops - I should have exactly one instance'.
+ ^ nil
].
oldClass := t anElement.
@@ -865,61 +869,61 @@
changeSet := Set new.
oldOffsets associationsDo:[:a |
- |k|
+ |k|
- k := a key.
- (newOffsets includesKey:k) ifFalse:[
- changeSet add:k
- ] ifTrue:[
- (a value ~~ (newOffsets at:k)) ifTrue:[
- changeSet add:k
- ]
- ]
+ k := a key.
+ (newOffsets includesKey:k) ifFalse:[
+ changeSet add:k
+ ] ifTrue:[
+ (a value ~~ (newOffsets at:k)) ifTrue:[
+ changeSet add:k
+ ]
+ ]
].
newOffsets associationsDo:[:a |
- |k|
+ |k|
- k := a key.
- (oldOffsets includesKey:k) ifFalse:[
- changeSet add:k
- ] ifTrue:[
- (a value ~~ (oldOffsets at:k)) ifTrue:[
- changeSet add:k
- ]
- ]
+ k := a key.
+ (oldOffsets includesKey:k) ifFalse:[
+ changeSet add:k
+ ] ifTrue:[
+ (a value ~~ (oldOffsets at:k)) ifTrue:[
+ changeSet add:k
+ ]
+ ]
].
((oldNames size == 0)
or:[newNames startsWith:oldNames]) ifTrue:[
- "new variable(s) has/have been added - old methods still work"
+ "new variable(s) has/have been added - old methods still work"
" "
- Transcript showCr:'copying methods ...'.
- Transcript endEntry.
+ Transcript showCr:'copying methods ...'.
+ Transcript endEntry.
" "
- self copyMethodsFrom:self for:newMetaclass.
- self copyMethodsFrom:oldClass for:newClass.
+ self copyMethodsFrom:self for:newMetaclass.
+ self copyMethodsFrom:oldClass for:newClass.
- "but have to recompile methods accessing stuff now defined
- (it might have been a global before ...)"
+ "but have to recompile methods accessing stuff now defined
+ (it might have been a global before ...)"
- addedNames := newNames select:[:nm | (oldNames includes:nm) not].
+ addedNames := newNames select:[:nm | (oldNames includes:nm) not].
"
- Transcript showCr:'recompiling methods accessing ' , addedNames printString , '...'.
- Transcript endEntry.
+ Transcript showCr:'recompiling methods accessing ' , addedNames printString , '...'.
+ Transcript endEntry.
"
- "recompile class-methods"
- newMetaclass recompileMethodsAccessingAny:addedNames.
+ "recompile class-methods"
+ newMetaclass recompileMethodsAccessingAny:addedNames.
] ifFalse:[
"
- Transcript showCr:'recompiling methods accessing ' , changeSet printString , ' ...'.
- Transcript endEntry.
+ Transcript showCr:'recompiling methods accessing ' , changeSet printString , ' ...'.
+ Transcript endEntry.
"
- "recompile class-methods"
- self copyInvalidatedMethodsFrom:self for:newMetaclass accessingAny:changeSet.
- newMetaclass recompileInvalidatedMethods:(Metaclass compiledMethodAt:#invalidMethod).
+ "recompile class-methods"
+ self copyInvalidatedMethodsFrom:self for:newMetaclass accessingAny:changeSet.
+ newMetaclass recompileInvalidatedMethods:(Metaclass compiledMethodAt:#invalidMethod).
- self copyMethodsFrom:oldClass for:newClass.
+ self copyMethodsFrom:oldClass for:newClass.
].
delta := newNames size - oldNames size.
@@ -929,74 +933,74 @@
"
allSubclasses := oldClass allSubclasses.
allSubclasses := allSubclasses asSortedCollection:[:a :b |
- b isSubclassOf:a
- ].
+ b isSubclassOf:a
+ ].
oldToNew := IdentityDictionary new.
"create a new class tree, based on new version"
allSubclasses do:[:aSubclass |
- oldSuper := aSubclass superclass.
- oldSubMeta := aSubclass class.
+ oldSuper := aSubclass superclass.
+ oldSubMeta := aSubclass class.
- newSubMeta := Metaclass new.
- oldSuper == oldClass ifTrue:[
- newSubMeta setSuperclass:newMetaclass.
- ] ifFalse:[
- newSubMeta setSuperclass:(oldToNew at:oldSuper) class.
- ].
- newSubMeta instSize:(oldSubMeta instSize + delta).
- newSubMeta flags:(oldSubMeta flags).
- newSubMeta setName:(oldSubMeta name).
- newSubMeta classVariableString:(oldSubMeta classVariableString).
- newSubMeta setComment:(oldSubMeta comment).
- newSubMeta category:(oldSubMeta category).
+ newSubMeta := Metaclass new.
+ oldSuper == oldClass ifTrue:[
+ newSubMeta setSuperclass:newMetaclass.
+ ] ifFalse:[
+ newSubMeta setSuperclass:(oldToNew at:oldSuper) class.
+ ].
+ newSubMeta instSize:(oldSubMeta instSize + delta).
+ newSubMeta flags:(oldSubMeta flags).
+ newSubMeta setName:(oldSubMeta name).
+ newSubMeta classVariableString:(oldSubMeta classVariableString).
+ newSubMeta setComment:(oldSubMeta comment).
+ newSubMeta category:(oldSubMeta category).
- newSub := newSubMeta new.
- oldSuper == oldClass ifTrue:[
- newSub setSuperclass:newClass.
- ] ifFalse:[
- newSub setSuperclass:(oldToNew at:oldSuper).
- ].
- newSub setSelectorArray:(aSubclass selectorArray).
- newSub setMethodArray:(aSubclass methodArray).
- newSub setName:(aSubclass name).
- newSub classVariableString:(aSubclass classVariableString).
- newSub setComment:(aSubclass comment).
- newSub category:(aSubclass category).
+ newSub := newSubMeta new.
+ oldSuper == oldClass ifTrue:[
+ newSub setSuperclass:newClass.
+ ] ifFalse:[
+ newSub setSuperclass:(oldToNew at:oldSuper).
+ ].
+ newSub setSelectorArray:(aSubclass selectorArray).
+ newSub setMethodArray:(aSubclass methodArray).
+ newSub setName:(aSubclass name).
+ newSub classVariableString:(aSubclass classVariableString).
+ newSub setComment:(aSubclass comment).
+ newSub category:(aSubclass category).
- oldToNew at:aSubclass put:newSub.
+ oldToNew at:aSubclass put:newSub.
"
- aSubclass setName:(aSubclass name , '-old').
- aSubclass category:'obsolete classes'
+ aSubclass setName:(aSubclass name , '-old').
+ aSubclass category:'obsolete classes'
"
- aSubclass category:'obsolete'.
- aSubclass class category:'obsolete'.
+ aSubclass category:'obsolete'.
+ aSubclass class category:'obsolete'.
].
"recompile what needs to be"
delta == 0 ifTrue:[
- "only have to recompile class methods accessing
- class instvars from changeset
- "
+ "only have to recompile class methods accessing
+ class instvars from changeset
+ "
- allSubclasses do:[:aClass |
- aClass class recompileMethodsAccessingAny:changeSet.
- ]
+ allSubclasses do:[:aClass |
+ aClass class recompileMethodsAccessingAny:changeSet.
+ ]
] ifFalse:[
- "
- have to recompile all class methods accessing class instvars
- "
+ "
+ have to recompile all class methods accessing class instvars
+ "
- allSubclasses do:[:aClass |
- |classInstVars|
+ allSubclasses do:[:aClass |
+ |classInstVars|
- classInstVars := aClass class allInstVarNames.
- aClass class recompileMethodsAccessingAny:classInstVars.
- ]
+ classInstVars := aClass class allInstVarNames.
+ aClass class recompileMethodsAccessingAny:classInstVars.
+ ]
].
self addChangeRecordForClassInstvars:newClass.
@@ -1006,8 +1010,8 @@
Smalltalk at:(oldClass name asSymbol) put:newClass.
ObjectMemory flushCachesFor:oldClass.
allSubclasses do:[:aClass |
- Smalltalk at:(oldToNew at:aClass) name asSymbol put:(oldToNew at:aClass).
- ObjectMemory flushCachesFor:aClass.
+ Smalltalk at:(oldToNew at:aClass) name asSymbol put:(oldToNew at:aClass).
+ ObjectMemory flushCachesFor:aClass.
].
"tell dependents ..."
@@ -1039,18 +1043,23 @@
!
copyMethodsFrom:oldClass for:newClass
- "when a class has changed, but metaclass is unaffected (i.e. classVars
- have not changed) there is no need to recompile them"
+ "copy all methods from oldClass to newClass.
+ This is used for class-methods when a class has changed, but metaclass is
+ unaffected (i.e. classVars/inheritance have not changed) so there is no need
+ to recompile the class methods."
newClass selectors:(oldClass selectorArray copy)
- methods:(oldClass methodArray copy)
+ methods:(oldClass methodArray copy)
!
copyInvalidatedMethodsFrom:oldClass for:newClass
- "when a class has been changed, copy all old methods into the new class
- - changing code to a trap method giving an error message;
- this allows us to keep the source while trapping uncompilable (due to
- now undefined instvars) methods"
+ "copy all methods from oldClass to newClass and change their code
+ to a trap method reporting an error.
+ This is used when a class has been changed its layout or inheritance,
+ for all methods; before recompilation is attempted.
+ This allows us to keep the source while trapping uncompilable (due to
+ now undefined instvars) methods. Compilation of these methods will show
+ an error on the transcript and lead to the debugger once called."
|trap trapCode trapByteCode newMethod oldMethodArray newMethodArray|
@@ -1061,20 +1070,34 @@
oldMethodArray := oldClass methodArray.
newMethodArray := Array new:(oldMethodArray size).
newClass selectors:(oldClass selectorArray copy)
- methods:newMethodArray.
+ methods:newMethodArray.
1 to:oldMethodArray size do:[:i |
- newMethod := (oldMethodArray at:i) copy.
- newMethod code:trapCode.
- newMethod literals:nil.
- newMethod byteCode:trapByteCode.
- newMethodArray at:i put:newMethod
+ newMethod := (oldMethodArray at:i) copy.
+ newMethod code:trapCode.
+ newMethod literals:nil.
+ newMethod byteCode:trapByteCode.
+ newMethodArray at:i put:newMethod
]
!
copyInvalidatedMethodsFrom:oldClass for:newClass accessingAny:setOfNames
"copy all methods from oldClass to newClass. Those methods accessing
a variable in setOfNames will be copied as invalid method, leading to
- a trap when its executed."
+ a trap when its executed. This is used when a class has changed its
+ layout for all methods which are affected by the change."
+
+ self copyInvalidatedMethodsFrom:oldClass
+ for:newClass
+ accessingAny:setOfNames
+ orSuper:false
+!
+
+copyInvalidatedMethodsFrom:oldClass for:newClass accessingAny:setOfNames orSuper:superBoolean
+ "copy all methods from oldClass to newClass.
+ Those methods accessing a variable in setOfNames will be copied as invalid method,
+ leading to a trap when its executed. If superBoolean is true, this is also done
+ for methods accessing super. This is used when a class has changed its
+ layout for all methods which are affected by the change."
|trap trapCode trapByteCode p oldMethod newMethod oldMethodArray newMethodArray|
@@ -1085,19 +1108,21 @@
oldMethodArray := oldClass methodArray.
newMethodArray := Array new:(oldMethodArray size).
newClass selectors:(oldClass selectorArray copy)
- methods:newMethodArray.
+ methods:newMethodArray.
1 to:oldMethodArray size do:[:i |
- oldMethod := oldMethodArray at:i.
- p := Parser parseMethod:(oldMethod source) in:newClass.
- (p isNil or:[p usedVars notNil and:[p usedVars includesAny:setOfNames]]) ifTrue:[
- newMethod := oldMethod copy.
- newMethod code:trapCode.
- newMethod literals:nil.
- newMethod byteCode:trapByteCode
- ] ifFalse:[
- newMethod := oldMethod.
- ].
- newMethodArray at:i put:newMethod
+ oldMethod := oldMethodArray at:i.
+ p := Parser parseMethod:(oldMethod source) in:newClass.
+ (p isNil
+ or:[(p usedVars notNil and:[p usedVars includesAny:setOfNames])
+ or:[superBoolean and:[p usesSuper]]]) ifTrue:[
+ newMethod := oldMethod copy.
+ newMethod code:trapCode.
+ newMethod literals:nil.
+ newMethod byteCode:trapByteCode
+ ] ifFalse:[
+ newMethod := oldMethod.
+ ].
+ newMethodArray at:i put:newMethod
]
!
@@ -1111,12 +1136,12 @@
trapByteCode := trap byteCode.
aClass methodArray do:[:aMethod |
- trapCode notNil ifTrue:[
- (aMethod code == trapCode) ifTrue:[^ true]
- ].
- trapByteCode notNil ifTrue:[
- (aMethod byteCode == trapByteCode) ifTrue:[^ true]
- ]
+ trapCode notNil ifTrue:[
+ (aMethod code == trapCode) ifTrue:[^ true]
+ ].
+ trapByteCode notNil ifTrue:[
+ (aMethod byteCode == trapByteCode) ifTrue:[^ true]
+ ]
].
^ false
! !
--- a/Method.st Mon Oct 10 01:29:01 1994 +0100
+++ b/Method.st Mon Oct 10 01:29:28 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -19,9 +19,9 @@
Method comment:'
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Method.st,v 1.18 1994-08-23 23:09:46 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Method.st,v 1.19 1994-10-10 00:26:43 claus Exp $
'!
!Method class methodsFor:'documentation'!
@@ -29,7 +29,7 @@
copyright
"
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Method.st,v 1.18 1994-08-23 23:09:46 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Method.st,v 1.19 1994-10-10 00:26:43 claus Exp $
"
!
@@ -67,14 +67,14 @@
Instance variables:
- source <String> the source itself (if sourcePosition isNil)
- or the fileName where the source is found
+ source <String> the source itself (if sourcePosition isNil)
+ or the fileName where the source is found
- sourcePosition <Integer> the position of the methods chunk in the file
+ sourcePosition <Integer> the position of the methods chunk in the file
- category <Symbol> the methods category
- package <Symbol> the package, in which the methods was defined
- (nil if its the standard system package)
+ category <Symbol> the methods category
+ package <Symbol> the package, in which the methods was defined
+ (nil if its the standard system package)
WARNING: layout known by compiler and runtime system - dont change
"
@@ -84,12 +84,21 @@
initialize
PrivateMethodSignal isNil ifTrue:[
- "EXPERIMENTAL"
- PrivateMethodSignal := (Signal new) mayProceed:true.
- PrivateMethodSignal notifierString:'attempt to execute private method'.
+ ExecutableCodeObject initialize.
+
+ "EXPERIMENTAL"
+ PrivateMethodSignal := ExecutionErrorSignal newSignalMayProceed:true.
+ PrivateMethodSignal nameClass:self message:#privateMethodSignal.
+ PrivateMethodSignal notifierString:'attempt to execute private method'.
]
! !
+!Method class methodsFor:'signal access'!
+
+privateMethodSignal
+ ^ PrivateMethodSignal
+! !
+
!Method class methodsFor:'queries'!
isBuiltInClass
@@ -112,13 +121,13 @@
|aStream junk|
source notNil ifTrue:[
- sourcePosition isNil ifTrue:[^ source].
- aStream := Smalltalk systemFileStreamFor:('source/' , source).
- aStream notNil ifTrue:[
- aStream position:sourcePosition.
- junk := aStream nextChunk.
- aStream close
- ]
+ sourcePosition isNil ifTrue:[^ source].
+ aStream := Smalltalk systemFileStreamFor:('source/' , source).
+ aStream notNil ifTrue:[
+ aStream position:sourcePosition.
+ junk := aStream nextChunk.
+ aStream close
+ ]
].
^ junk
!
@@ -153,49 +162,20 @@
comment
"return the methods comment.
This is done by searching for and returning the first comment
- from the methods source.
+ from the methods source (excluding any double-quotes).
Returns nil if there is no comment (or source is not available)."
- |text lines line nQuote index i1 i2 commLines|
+ |src stream|
- text := self source.
- text isNil ifTrue:[^ nil].
- lines := text asCollectionOfLines.
- (lines size < 2) ifTrue:[^ nil].
+ src := self source.
+ src isNil ifTrue:[^ nil].
- index := 2.
+ stream := ReadStream on:src.
+ (stream skipThrough:Character doubleQuote) isNil ifTrue:[^ nil].
+ ^ stream upTo:Character doubleQuote.
"
- skip empty lines
- "
- line := (lines at:index).
- [line isBlank] whileTrue:[
- index := index + 1.
- index > lines size ifTrue:[^ nil].
- line := (lines at:index).
- ].
-
- nQuote := line occurrencesOf:(Character doubleQuote).
- (nQuote == 0) ifTrue:[^ nil].
- (nQuote == 2) ifTrue:[^ line].
- (nQuote > 2) ifTrue:[
- i1 := line indexOf:(Character doubleQuote).
- i2 := line indexOf:(Character doubleQuote) startingAt:(i1 + 1).
- ^ line copyFrom:i1+1 to:i2-1
- ].
- commLines := Text new.
- commLines add:line.
- [nQuote ~~ 1] whileTrue:[
- index := index + 1.
- index > lines size ifTrue:[^ nil]. "unclosed comment - could warn here"
- line := lines at:index.
- nQuote := line occurrencesOf:(Character doubleQuote).
- commLines add:line.
- ].
- ^ commLines asString
-
- "
- (Method compiledMethodAt:#comment) comment
+ (Method compiledMethodAt:#comment) comment
"
!
@@ -231,7 +211,7 @@
"protect myself a bit - putting in an object would crash me ..."
(newFlags isMemberOf:SmallInteger) ifTrue:[
- flags := newFlags
+ flags := newFlags
]
!
@@ -246,9 +226,9 @@
/* made this a primitive to get define in stc.h */
#ifdef F_PRIVATE
if (aBoolean == true)
- f = f | F_PRIVATE;
+ f = f | F_PRIVATE;
else
- f = f & ~F_PRIVATE;
+ f = f & ~F_PRIVATE;
_INST(flags) = _MKSMALLINT(f);
#endif
%}
@@ -266,7 +246,7 @@
/* made this a primitive to get define in stc.h */
#ifdef F_PRIVATE
if (f & F_PRIVATE) {
- RETURN (true);
+ RETURN (true);
}
#endif
%}.
@@ -284,10 +264,10 @@
- for use by compiler only."
(aNumber between:0 and:self class maxNumberOfArguments) ifFalse:[
- self error:('ST/X only supports up to a maximum of ' ,
- self class maxNumberOfArguments printString ,
- ' method arguments').
- ^ self
+ self error:('ST/X only supports up to a maximum of ' ,
+ self class maxNumberOfArguments printString ,
+ ' method arguments').
+ ^ self
].
%{
/* made this a primitive to get define in stc.h */
@@ -320,15 +300,15 @@
numberOfMethodVars:aNumber
"set the number of method variables - for use by compiler only.
WARNING: playing around here with incorrect values
- may crash smalltalk badly."
+ may crash smalltalk badly."
%{ /* NOCONTEXT */
int f = _intVal(_INST(flags));
/* made this a primitive to get define in stc.h */
if (_isSmallInteger(aNumber)) {
- f = (f & ~F_NVARS) | (_intVal(aNumber) << F_NVARSHIFT);
- _INST(flags) = _MKSMALLINT(f);
+ f = (f & ~F_NVARS) | (_intVal(aNumber) << F_NVARSHIFT);
+ _INST(flags) = _MKSMALLINT(f);
}
%}
!
@@ -350,17 +330,17 @@
stackSize:aNumber
"set the depth of the local stack - for use by compiler only.
WARNING: playing around here with incorrect values
- may crash smalltalk badly.
- (if the runtime library was compiled with DEBUG,
- a bad stack will be detected and triggers an error)"
+ may crash smalltalk badly.
+ (if the runtime library was compiled with DEBUG,
+ a bad stack will be detected and triggers an error)"
%{ /* NOCONTEXT */
int f = _intVal(_INST(flags));
/* made this a primitive to get define in stc.h */
if (_isSmallInteger(aNumber)) {
- f = (f & ~F_NSTACK) | (_intVal(aNumber) << F_NSTACKSHIFT);
- _INST(flags) = _MKSMALLINT(f);
+ f = (f & ~F_NSTACK) | (_intVal(aNumber) << F_NSTACKSHIFT);
+ _INST(flags) = _MKSMALLINT(f);
}
%}
!
@@ -380,34 +360,88 @@
!Method methodsFor:'queries'!
-containingClass
- "return the class I am defined in.
+who
+ "return the class and selector of where I am defined in.
Since there is no information of the containing class
- in the method, we have to search here.
+ in the method, we have to do a search here.
Normally, this is not a problem, except when a method is
- accepted in the debugger - the information about which
- class the original method was in is then lost.
+ accepted in the debugger or redefined from within a method
+ (maybe done indirectly, if doIt is done recursively)
+ - the information about which class the original method was
+ defined in is lost in this case.
Q: should we add a backref from the method to the class ?"
+ "
+ first, limit the search to global classes only -
+ since probability is high, that the receiver is found in there ...
+ "
Smalltalk allBehaviorsDo:[:aClass |
- (aClass containsMethod:self) ifTrue:[^ aClass].
- (aClass class containsMethod:self) ifTrue:[^ aClass class]
+ |sel|
+
+ sel := aClass selectorForMethod:self.
+ sel notNil ifTrue:[^ Array with:aClass with:sel].
+ sel := aClass class selectorForMethod:self.
+ sel notNil ifTrue:[^ Array with:aClass class with:sel].
].
"
mhmh - must be a method of some anonymous class (i.e. one not
in the Smalltalk dictionary; search all instances of Behavior
"
Behavior allDerivedInstancesDo:[:someClass |
- (someClass containsMethod:self) ifTrue:[
- ^ someClass
- ].
+ |sel|
+
+ sel := someClass selectorForMethod:self.
+ sel notNil ifTrue:[^ Array with:someClass with:sel]
].
"
none found - sorry
"
^ nil
+
+ "typical situation: some well-known class"
+ "
+ |m|
+ m := Object compiledMethodAt:#copy.
+ m who
+ "
+
+ "untypical situation: an anonymous class"
+ "
+ |m cls|
+
+ Object
+ subclass:#FunnyClass
+ instanceVariableNames:'foo'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'testing'.
+ cls := Smalltalk at:#FunnyClass.
+ Smalltalk removeClass:cls.
+
+ cls compile:'testMethod1:arg foo:=arg'.
+ cls compile:'testMethod2 ^ foo'.
+ m := cls compiledMethodAt:#testMethod1:.
+
+ m who
+ "
+!
+
+containingClass
+ "return the class I am defined in.
+ See comment in who."
+
+ "based on who, which has been added for ST-80 compatibility"
+
+ |pair|
+
+ pair := self who.
+ pair notNil ifTrue:[^ pair at:1].
+ "
+ none found - sorry
+ "
+ ^ nil
!
methodArgNames
@@ -418,9 +452,9 @@
sourceString := self source.
sourceString notNil ifTrue:[
- parser := Parser parseMethodSpecification:sourceString.
- (parser isNil or:[parser == #Error]) ifTrue:[^ nil].
- ^ parser methodArgs
+ parser := Parser parseMethodSpecification:sourceString.
+ (parser isNil or:[parser == #Error]) ifTrue:[^ nil].
+ ^ parser methodArgs
].
^ nil
@@ -437,9 +471,9 @@
sourceString := self source.
sourceString notNil ifTrue:[
- parser := Parser parseMethodArgAndVarSpecification:sourceString.
- (parser isNil or:[parser == #Error]) ifTrue:[^ nil].
- ^ parser methodVars
+ parser := Parser parseMethodArgAndVarSpecification:sourceString.
+ (parser isNil or:[parser == #Error]) ifTrue:[^ nil].
+ ^ parser methodVars
].
^ nil
@@ -456,13 +490,13 @@
sourceString := self source.
sourceString notNil ifTrue:[
- parser := Parser parseMethodArgAndVarSpecification:sourceString.
- (parser isNil or:[parser == #Error]) ifTrue:[^ nil].
- argNames := parser methodArgs.
- varNames := parser methodVars.
- argNames isNil ifTrue:[^ varNames].
- varNames isNil ifTrue:[^ argNames].
- ^ (argNames , varNames)
+ parser := Parser parseMethodArgAndVarSpecification:sourceString.
+ (parser isNil or:[parser == #Error]) ifTrue:[^ nil].
+ argNames := parser methodArgs.
+ varNames := parser methodVars.
+ argNames isNil ifTrue:[^ varNames].
+ varNames isNil ifTrue:[^ argNames].
+ ^ (argNames , varNames)
].
^ nil
@@ -483,25 +517,25 @@
line := (text at:2).
nQuote := line occurrencesOf:(Character doubleQuote).
(nQuote == 2) ifTrue:[
- qIndex := line indexOf:(Character doubleQuote).
- qIndex2 := line indexOf:(Character doubleQuote) startingAt:(qIndex + 1).
- ^ line copyFrom:(qIndex + 1) to:(qIndex2 - 1)
+ qIndex := line indexOf:(Character doubleQuote).
+ qIndex2 := line indexOf:(Character doubleQuote) startingAt:(qIndex + 1).
+ ^ line copyFrom:(qIndex + 1) to:(qIndex2 - 1)
].
(nQuote == 1) ifTrue:[
- qIndex := line indexOf:(Character doubleQuote).
- comment := line copyFrom:(qIndex + 1).
+ qIndex := line indexOf:(Character doubleQuote).
+ comment := line copyFrom:(qIndex + 1).
- index := 3.
- line := text at:index.
- nQuote := line occurrencesOf:(Character doubleQuote).
- [nQuote ~~ 1] whileTrue:[
- comment := comment , Character cr asString , line withoutSpaces.
- index := index + 1.
- line := text at:index.
- nQuote := line occurrencesOf:(Character doubleQuote)
- ].
- qIndex := line indexOf:(Character doubleQuote).
- ^ comment , Character cr asString , (line copyTo:(qIndex - 1)) withoutSpaces
+ index := 3.
+ line := text at:index.
+ nQuote := line occurrencesOf:(Character doubleQuote).
+ [nQuote ~~ 1] whileTrue:[
+ comment := comment , Character cr asString , line withoutSpaces.
+ index := index + 1.
+ line := text at:index.
+ nQuote := line occurrencesOf:(Character doubleQuote)
+ ].
+ qIndex := line indexOf:(Character doubleQuote).
+ ^ comment , Character cr asString , (line copyTo:(qIndex - 1)) withoutSpaces
].
^ nil
@@ -572,8 +606,8 @@
or you ignore the error messages during some recompile."
^ InvalidCodeSignal
- raiseRequestWith:self
- errorString:'invalid method - not executable'.
+ raiseRequestWith:self
+ errorString:'invalid method - not executable'.
!
wrongNumberOfArguments:numberGiven
@@ -582,9 +616,9 @@
With a normal send, this error cannot happen."
^ ArgumentSignal
- raiseRequestWith:self
- errorString:('method got ' , numberGiven printString ,
- ' args while ' , self numberOfMethodArgs printString , ' where expected')
+ raiseRequestWith:self
+ errorString:('method got ' , numberGiven printString ,
+ ' args while ' , self numberOfMethodArgs printString , ' where expected')
!
privateMethodCalled
@@ -660,184 +694,184 @@
extern OBJ interpret();
if (__isArray(argArray)) {
- nargs = _arraySize(argArray);
- ap = _ArrayInstPtr(argArray)->a_element;
+ nargs = _arraySize(argArray);
+ ap = _ArrayInstPtr(argArray)->a_element;
} else {
- if (argArray == nil) {
- nargs = 0;
- } else
- nargs = -1;
+ if (argArray == nil) {
+ nargs = 0;
+ } else
+ nargs = -1;
}
#ifdef F_NARGS
if (((_intVal(_INST(flags)) & F_NARGS) >> F_NARGSHIFT) == nargs)
#endif
{
- code = _MethodInstPtr(self)->m_code;
- if (aClass == nil) {
- searchClass = dummy.ilc_class = _Class(anObject);
- } else {
- searchClass = dummy.ilc_class = aClass;
- }
+ code = _MethodInstPtr(self)->m_code;
+ if (aClass == nil) {
+ searchClass = dummy.ilc_class = _Class(anObject);
+ } else {
+ searchClass = dummy.ilc_class = aClass;
+ }
- if (code) {
- /* compiled code */
- switch (nargs) {
- case 0:
- RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy) );
+ if (code) {
+ /* compiled code */
+ switch (nargs) {
+ case 0:
+ RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy) );
- case 1:
- RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy, ap[0]) );
+ case 1:
+ RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy, ap[0]) );
- case 2:
- RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy, ap[0], ap[1]) );
+ case 2:
+ RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy, ap[0], ap[1]) );
- case 3:
- RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy, ap[0], ap[1], ap[2]) );
+ case 3:
+ RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy, ap[0], ap[1], ap[2]) );
- case 4:
- RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy,
- ap[0], ap[1], ap[2], ap[3]) );
+ case 4:
+ RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy,
+ ap[0], ap[1], ap[2], ap[3]) );
- case 5:
- RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy,
- ap[0], ap[1], ap[2], ap[3], ap[4]) );
+ case 5:
+ RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy,
+ ap[0], ap[1], ap[2], ap[3], ap[4]) );
- case 6:
- RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy,
- ap[0], ap[1], ap[2], ap[3], ap[4], ap[5]) );
+ case 6:
+ RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy,
+ ap[0], ap[1], ap[2], ap[3], ap[4], ap[5]) );
- case 7:
- RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy,
- ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6]) );
+ case 7:
+ RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy,
+ ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6]) );
- case 8:
- RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy,
- ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6], ap[7]) );
+ case 8:
+ RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy,
+ ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6], ap[7]) );
- case 9:
- RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy,
- ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6], ap[7], ap[8]) );
+ case 9:
+ RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy,
+ ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6], ap[7], ap[8]) );
- case 10:
- RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy,
- ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6], ap[7], ap[8],
- ap[9]) );
+ case 10:
+ RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy,
+ ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6], ap[7], ap[8],
+ ap[9]) );
- case 11:
- RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy,
- ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6], ap[7], ap[8],
- ap[9], ap[10]) );
+ case 11:
+ RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy,
+ ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6], ap[7], ap[8],
+ ap[9], ap[10]) );
- case 12:
- RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy,
- ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6], ap[7], ap[8],
- ap[9], ap[10], ap[11]) );
+ case 12:
+ RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy,
+ ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6], ap[7], ap[8],
+ ap[9], ap[10], ap[11]) );
- case 13:
- RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy,
- ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6], ap[7], ap[8],
- ap[9], ap[10], ap[11], ap[12]) );
+ case 13:
+ RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy,
+ ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6], ap[7], ap[8],
+ ap[9], ap[10], ap[11], ap[12]) );
- case 14:
- RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy,
- ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6], ap[7], ap[8],
- ap[9], ap[10], ap[11], ap[12], ap[13]) );
+ case 14:
+ RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy,
+ ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6], ap[7], ap[8],
+ ap[9], ap[10], ap[11], ap[12], ap[13]) );
- case 15:
- RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy,
- ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6], ap[7], ap[8],
- ap[9], ap[10], ap[11], ap[12], ap[13], ap[14]) );
- }
- } else {
- /* interpreted code */
- switch (nargs) {
- case 0:
- RETURN ( interpret(self, 0, anObject, aSymbol, SND_COMMA searchClass) );
+ case 15:
+ RETURN ( (*code)(anObject, aSymbol, SND_COMMA searchClass, &dummy,
+ ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6], ap[7], ap[8],
+ ap[9], ap[10], ap[11], ap[12], ap[13], ap[14]) );
+ }
+ } else {
+ /* interpreted code */
+ switch (nargs) {
+ case 0:
+ RETURN ( interpret(self, 0, anObject, aSymbol, SND_COMMA searchClass) );
- case 1:
- RETURN ( interpret(self, 1, anObject, aSymbol, SND_COMMA searchClass,
- ap[0]) );
+ case 1:
+ RETURN ( interpret(self, 1, anObject, aSymbol, SND_COMMA searchClass,
+ ap[0]) );
- case 2:
- RETURN ( interpret(self, 2, anObject, aSymbol, SND_COMMA searchClass,
- ap[0], ap[1]) );
+ case 2:
+ RETURN ( interpret(self, 2, anObject, aSymbol, SND_COMMA searchClass,
+ ap[0], ap[1]) );
- case 3:
- RETURN ( interpret(self, 3, anObject, aSymbol, SND_COMMA searchClass,
- ap[0], ap[1], ap[2]) );
+ case 3:
+ RETURN ( interpret(self, 3, anObject, aSymbol, SND_COMMA searchClass,
+ ap[0], ap[1], ap[2]) );
- case 4:
- RETURN ( interpret(self, 4, anObject, aSymbol, SND_COMMA searchClass,
- ap[0], ap[1], ap[2], ap[3]) );
+ case 4:
+ RETURN ( interpret(self, 4, anObject, aSymbol, SND_COMMA searchClass,
+ ap[0], ap[1], ap[2], ap[3]) );
- case 5:
- RETURN ( interpret(self, 5, anObject, aSymbol, SND_COMMA searchClass,
- ap[0], ap[1], ap[2], ap[3], ap[4]) );
+ case 5:
+ RETURN ( interpret(self, 5, anObject, aSymbol, SND_COMMA searchClass,
+ ap[0], ap[1], ap[2], ap[3], ap[4]) );
- case 6:
- RETURN ( interpret(self, 6, anObject, aSymbol, SND_COMMA searchClass,
- ap[0], ap[1], ap[2], ap[3], ap[4], ap[5]) );
+ case 6:
+ RETURN ( interpret(self, 6, anObject, aSymbol, SND_COMMA searchClass,
+ ap[0], ap[1], ap[2], ap[3], ap[4], ap[5]) );
- case 7:
- RETURN ( interpret(self, 7, anObject, aSymbol, SND_COMMA searchClass,
- ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6]) );
+ case 7:
+ RETURN ( interpret(self, 7, anObject, aSymbol, SND_COMMA searchClass,
+ ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6]) );
- case 8:
- RETURN ( interpret(self, 8, anObject, aSymbol, SND_COMMA searchClass,
- ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6],
- ap[7]) );
+ case 8:
+ RETURN ( interpret(self, 8, anObject, aSymbol, SND_COMMA searchClass,
+ ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6],
+ ap[7]) );
- case 9:
- RETURN ( interpret(self, 9, anObject, aSymbol, SND_COMMA searchClass,
- ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6],
- ap[7], ap[8]) );
+ case 9:
+ RETURN ( interpret(self, 9, anObject, aSymbol, SND_COMMA searchClass,
+ ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6],
+ ap[7], ap[8]) );
- case 10:
- RETURN ( interpret(self, 10, anObject, aSymbol, SND_COMMA searchClass,
- ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6],
- ap[7], ap[8], ap[9]) );
+ case 10:
+ RETURN ( interpret(self, 10, anObject, aSymbol, SND_COMMA searchClass,
+ ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6],
+ ap[7], ap[8], ap[9]) );
- case 11:
- RETURN ( interpret(self, 11, anObject, aSymbol, SND_COMMA searchClass,
- ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6],
- ap[7], ap[8], ap[9], ap[10]) );
+ case 11:
+ RETURN ( interpret(self, 11, anObject, aSymbol, SND_COMMA searchClass,
+ ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6],
+ ap[7], ap[8], ap[9], ap[10]) );
- case 12:
- RETURN ( interpret(self, 12, anObject, aSymbol, SND_COMMA searchClass,
- ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6],
- ap[7], ap[8], ap[9], ap[11]) );
+ case 12:
+ RETURN ( interpret(self, 12, anObject, aSymbol, SND_COMMA searchClass,
+ ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6],
+ ap[7], ap[8], ap[9], ap[11]) );
- case 13:
- RETURN ( interpret(self, 13, anObject, aSymbol, SND_COMMA searchClass,
- ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6],
- ap[7], ap[8], ap[9], ap[11], ap[12]) );
+ case 13:
+ RETURN ( interpret(self, 13, anObject, aSymbol, SND_COMMA searchClass,
+ ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6],
+ ap[7], ap[8], ap[9], ap[11], ap[12]) );
- case 14:
- RETURN ( interpret(self, 14, anObject, aSymbol, SND_COMMA searchClass,
- ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6],
- ap[7], ap[8], ap[9], ap[11], ap[12], ap[13]) );
+ case 14:
+ RETURN ( interpret(self, 14, anObject, aSymbol, SND_COMMA searchClass,
+ ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6],
+ ap[7], ap[8], ap[9], ap[11], ap[12], ap[13]) );
- case 15:
- RETURN ( interpret(self, 15, anObject, aSymbol, SND_COMMA searchClass,
- ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6],
- ap[7], ap[8], ap[9], ap[11], ap[12], ap[13], ap[14]) );
- }
- }
+ case 15:
+ RETURN ( interpret(self, 15, anObject, aSymbol, SND_COMMA searchClass,
+ ap[0], ap[1], ap[2], ap[3], ap[4], ap[5], ap[6],
+ ap[7], ap[8], ap[9], ap[11], ap[12], ap[13], ap[14]) );
+ }
+ }
}
%}
.
(argArray isMemberOf:Array) ifFalse:[
- "
- arguments must be either nil or an array
- "
- ^ self badArgumentArray
+ "
+ arguments must be either nil or an array
+ "
+ ^ self badArgumentArray
].
(argArray size ~~ self numberOfMethodArgs) ifTrue:[
- "
- the method expects a different number of arguments
- "
- ^ self wrongNumberOfArguments:argArray size
+ "
+ the method expects a different number of arguments
+ "
+ ^ self wrongNumberOfArguments:argArray size
].
"
the VM only supports a limited number of arguments in sends
@@ -846,29 +880,29 @@
"
(Float compiledMethodAt:#+)
- valueWithReceiver:1.0 arguments:#(2.0)
+ valueWithReceiver:1.0 arguments:#(2.0)
'the next example is a wrong one - which is detected by True's method ...'.
(True compiledMethodAt:#printString)
- valueWithReceiver:false arguments:nil
+ valueWithReceiver:false arguments:nil
'the next example is a wrong one - it is nowhere detected
and a wrong value returned ...'.
(Point compiledMethodAt:#x)
- valueWithReceiver:(1->2) arguments:nil
+ valueWithReceiver:(1->2) arguments:nil
'the next example is VERY bad one - it is nowhere detected
and may crash the system WARNING: save your work before doing this ...'.
(Point compiledMethodAt:#x)
- valueWithReceiver:(Object new) arguments:nil
+ valueWithReceiver:(Object new) arguments:nil
'the next example is a wrong one - which is detected here ...'.
(Object compiledMethodAt:#printOn:)
- valueWithReceiver:false arguments:nil
+ valueWithReceiver:false arguments:nil
'the next example is a wrong one - which is detected here ...'.
(Object compiledMethodAt:#printOn:)
- valueWithReceiver:false arguments:#()
+ valueWithReceiver:false arguments:#()
"
! !
@@ -881,18 +915,49 @@
|myClass|
- aStream nextPutAll:'a Method('.
+ aStream nextPutAll:(self classNameWithArticle).
+ aStream nextPut:$(.
myClass := self containingClass.
myClass notNil ifTrue:[
- myClass name printOn:aStream.
- aStream nextPutAll:' '.
- (myClass selectorForMethod:self) printOn:aStream
+ myClass name printOn:aStream.
+ aStream nextPutAll:' '.
+ (myClass selectorForMethod:self) printOn:aStream
] ifFalse:[
- aStream nextPutAll:'???'
+ aStream nextPutAll:'no class'
].
aStream nextPut:$)
! !
+!Method class methodsFor:'binary storage'!
+
+binaryDefinitionFrom: stream manager: manager
+ "read my definition from stream."
+
+ |cls sel|
+
+ "type-byte"
+ stream nextByte == 0 ifTrue:[
+ "
+ built-in method
+ "
+ cls := manager nextObject.
+ sel := manager nextObject.
+
+ "
+ mhmh - on the source system, this was a machinecode
+ method, while here its an interpreted one ...
+ "
+ cls isLoaded ifFalse:[
+ cls autoload
+ ].
+ ^ cls compiledMethodAt:sel
+ ].
+ "
+ bytecode method
+ "
+ ^ super binaryDefinitionFrom:stream manager:manager
+! !
+
!Method methodsFor:'binary storage'!
asByteCodeMethod
@@ -903,35 +968,47 @@
Can be used to obtain a bytecode version of a machine-code method
for binary storage or dynamic recompilation (which is not yet finished)."
- |temporaryMethod cls sourceString upd silent|
+ |temporaryMethod cls sourceString upd silent lazy|
byteCode notNil ifTrue:[
- ^ self
+ "
+ is already a bytecoded method
+ "
+ ^ self
].
cls := self containingClass.
+ cls isNil ifTrue:[
+ 'cannot generate bytecode (no class for compilation)' errorPrintNL.
+ ^ nil
+ ].
sourceString := self source.
sourceString isNil ifTrue:[
- 'cannot generate bytecode (no source for compilation)' errorPrintNL.
+ 'cannot generate bytecode (no source for compilation)' errorPrintNL.
^ nil
].
"
- dont want this to go into the changes file
+ dont want this to go into the changes file,
+ dont want output on Transcript and definitely
+ dont want a lazy method ...
"
upd := Class updateChanges:false.
silent := Smalltalk silentLoading:true.
+ lazy := Compiler compileLazy:false.
+
[
- temporaryMethod := cls compiler compile:sourceString
- forClass:cls
- inCategory:(self category)
- notifying:nil
- install:false.
+ temporaryMethod := cls compiler compile:sourceString
+ forClass:cls
+ inCategory:(self category)
+ notifying:nil
+ install:false.
] valueNowOrOnUnwindDo:[
- Class updateChanges:upd.
- Smalltalk silentLoading:silent.
+ Class updateChanges:upd.
+ Compiler compileLazy:lazy.
+ Smalltalk silentLoading:silent.
].
(temporaryMethod isNil or:[temporaryMethod == #Error]) ifTrue:[
- 'cannot generate bytecode (contains primitive code or error)' errorPrintNL.
+ 'cannot generate bytecode (contains primitive code or error)' errorPrintNL.
^ nil.
].
"
@@ -946,84 +1023,54 @@
"
!
-storeBinaryDefinitionOn: stream manager: manager
- "can only store bytecode - machine code is not storable.
+storeBinaryDefinitionOn:stream manager:manager
+ "only store bytecode-methods - machinecode methods are stored
+ as class/selector pair and a lookup is done when restored.
+
If the receiver method is a built-in (i.e. machine coded)
method, a temporary interpreted byte code method is created,
and its bytecode stored.
This works only, if the source of the method is available and the
method does not contain primitive code."
- |storedMethod|
+ |storedMethod who|
byteCode isNil ifTrue:[
- storedMethod := self asByteCodeMethod.
- storedMethod isNil ifTrue:[
- self error:'store of built-in method failed'.
- ^ nil
- ].
- ^ storedMethod storeBinaryDefinitionOn:stream manager:manager
- ].
- ^ super storeBinaryDefinitionOn:stream manager:manager
-! !
-
-!Method methodsFor:'obsolete binary fileOut'!
-
-binaryFileOutLiteralsOn:aStream
- |index n|
-
- literals isNil ifTrue:[
- aStream nextPutAll:'0'.
- aStream nextPut:$!!.
- ^ self
- ].
- aStream nextPutAll:literals size printString.
- aStream nextPut:$!!.
+ self code notNil ifTrue:[
+ (who := self who) notNil ifTrue:[
+ "
+ machine code only - assume its a built-in method,
+ and store the class/selector information.
+ The restored method may not be exactly the same ...
+ "
+ manager putIdOf:(self class) on:stream.
+ stream nextPutByte:0. "means built-in method"
+ manager putIdOf:(who at:1) on:stream.
+ manager putIdOf:(who at:2) on:stream.
+ ^ self
+ ]
+ ].
- index := 1.
- literals do:[:lit |
- lit isNumber ifTrue:[
- lit storeOn:aStream
- ] ifFalse:[
- ((lit isKindOf:String) or:[lit isKindOf:Character]) ifTrue:[
- lit storeOn:aStream
- ] ifFalse:[
- (lit isKindOf:Array) ifTrue:[
- aStream nextPut:$(.
- lit storeOn:aStream.
- aStream nextPut:$)
- ] ifFalse:[
- lit isBehavior ifTrue:[
- aStream nextPutAll:'(Smalltalk at:#'.
- n := lit name.
- lit isMeta ifTrue:[
- n := (n copyTo:(n size - 5)) , ') class'
- ] ifFalse:[
- n := n , ')'
- ].
- aStream nextPutAll:n
- ] ifFalse:[
- self error:('invalid literal ' , lit class name)
- ]
- ]
- ]
- ].
- aStream nextPut:$!!.
- index := index + 1
- ]
+ storedMethod := self asByteCodeMethod.
+ storedMethod isNil ifTrue:[
+ self error:'store of built-in method failed'.
+ ^ nil
+ ].
+ ^ storedMethod storeBinaryDefinitionOn:stream manager:manager
+ ].
+
+ manager putIdOf:(self class) on:stream.
+ stream nextPutByte:1. "means byte-coded method"
+ self storeBinaryDefinitionBodyOn:stream manager:manager
!
-binaryFileOutOn:aStream
- byteCode isNil ifTrue:[
- self notify:'no bytecodes to fileout'.
- ^ self
- ].
- self binaryFileOutLiteralsOn:aStream.
+readBinaryContentsFrom: stream manager: manager
+ "tell the newly restored Font about restoration"
- flags storeOn:aStream.
- aStream nextPut:$!!.
+ self code notNil ifTrue:[
+ "built-in method - already complete"
+ ^ self
+ ].
- byteCode size storeOn:aStream.
- aStream nextPut:$!!.
- aStream nextPutBytes:(byteCode size) from:byteCode
+ ^ super readBinaryContentsFrom: stream manager: manager
! !
--- a/MiniDebug.st Mon Oct 10 01:29:01 1994 +0100
+++ b/MiniDebug.st Mon Oct 10 01:29:28 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1988 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -19,9 +19,9 @@
MiniDebugger comment:'
COPYRIGHT (c) 1988 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Attic/MiniDebug.st,v 1.8 1994-08-05 00:59:02 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/MiniDebug.st,v 1.9 1994-10-10 00:26:48 claus Exp $
'!
!MiniDebugger class methodsFor: 'documentation'!
@@ -29,7 +29,7 @@
copyright
"
COPYRIGHT (c) 1988 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Attic/MiniDebug.st,v 1.8 1994-08-05 00:59:02 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/MiniDebug.st,v 1.9 1994-10-10 00:26:48 claus Exp $
"
!
@@ -61,7 +61,7 @@
new
TheOneAndOnlyDebugger printNL.
TheOneAndOnlyDebugger isNil ifTrue:[
- TheOneAndOnlyDebugger := self basicNew initialize
+ TheOneAndOnlyDebugger := self basicNew initialize
].
^ TheOneAndOnlyDebugger
!
@@ -85,7 +85,7 @@
trace:aBlock on:aStream
self trace:aBlock with:[:where | where printString printOn:aStream.
- aStream cr]
+ aStream cr]
!
trace:aBlock with:aTraceBlock
@@ -108,8 +108,10 @@
StepInterruptPending := nil.
aString printNL.
- active := Processor activeProcess.
- 'process: id=' print. active id print. ' name=' print. active name printNL.
+ Processor notNil ifTrue:[
+ active := Processor activeProcess.
+ 'process: id=' print. active id print. ' name=' print. active name printNL.
+ ].
self new enter.
^ nil
! !
@@ -140,14 +142,14 @@
|backtrace|
backtrace := thisContext.
(backtrace notNil) ifTrue: [
- "remove Context getContext frame"
- backtrace := backtrace sender.
- "remove Debugger showContext frame"
- backtrace := backtrace sender.
- "remove Debugger commandLoop frame"
- backtrace := backtrace sender.
- "remove Debugger enter frame"
- backtrace := backtrace sender
+ "remove Context getContext frame"
+ backtrace := backtrace sender.
+ "remove Debugger showContext frame"
+ backtrace := backtrace sender.
+ "remove Debugger commandLoop frame"
+ backtrace := backtrace sender.
+ "remove Debugger enter frame"
+ backtrace := backtrace sender
].
^ backtrace
!
@@ -157,11 +159,11 @@
con := thisContext sender.
[con notNil] whileTrue:[
- (con isBlockContext not and:[con selector == aSelector]) ifTrue:[
- "got it"
- ^ con
- ].
- con := con sender
+ (con isBlockContext not and:[con selector == aSelector]) ifTrue:[
+ "got it"
+ ^ con
+ ].
+ con := con sender
].
^ nil
! !
@@ -173,69 +175,69 @@
where := thisContext. "where is stepInterrupt context"
where notNil ifTrue:[
- where := where sender "where is now interrupted methods context"
+ where := where sender "where is now interrupted methods context"
].
stepping ifTrue:[
- where notNil ifTrue:[
- where fullPrint
- ] ifFalse:[
- 'stepInterrupt: no context' errorPrintNewline
- ].
- self enter
+ where notNil ifTrue:[
+ where fullPrint
+ ] ifFalse:[
+ 'stepInterrupt: no context' errorPrintNewline
+ ].
+ self enter
] ifFalse:[
- where notNil ifTrue:[
- traceBlock notNil ifTrue:[
- traceBlock value:where
- ]
- ] ifFalse:[
- 'traceInterrupt: no context' errorPrintNewline
- ].
- ObjectMemory flushInlineCaches.
- StepInterruptPending := true.
- InterruptPending := true
+ where notNil ifTrue:[
+ traceBlock notNil ifTrue:[
+ traceBlock value:where
+ ]
+ ] ifFalse:[
+ 'traceInterrupt: no context' errorPrintNewline
+ ].
+ ObjectMemory flushInlineCaches.
+ StepInterruptPending := true.
+ InterruptPending := true
]
!
enter
- |cmd stillHere|
+ |leaveCmd stillHere|
stillHere := true.
[stillHere] whileTrue:[
- cmd := self commandLoop.
+ leaveCmd := self commandLoop.
- (cmd == $s) ifTrue: [
- self stepping.
- ObjectMemory flushInlineCaches.
- ObjectMemory stepInterruptHandler:self.
- stillHere := false.
- StepInterruptPending := true.
- InterruptPending := true
- ].
- (cmd == $t) ifTrue: [
- traceBlock := [:where | where fullPrint].
- ObjectMemory flushInlineCaches.
- ObjectMemory stepInterruptHandler:self.
- stillHere := false.
- StepInterruptPending := true.
- InterruptPending := true
- ].
- (cmd == $c) ifTrue: [
- stillHere := false.
- stepping := false.
- tracing := false.
- StepInterruptPending := nil.
- InterruptPending := nil
- ].
- (cmd == $a) ifTrue: [
- "abort"
- stepping := false.
- tracing := false.
- StepInterruptPending := nil.
- InterruptPending := nil.
- self doAbort.
- stillHere := true.
- "failed abort"
- ].
+ (leaveCmd == $s) ifTrue: [
+ self stepping.
+ ObjectMemory flushInlineCaches.
+ ObjectMemory stepInterruptHandler:self.
+ stillHere := false.
+ StepInterruptPending := true.
+ InterruptPending := true
+ ].
+ (leaveCmd == $t) ifTrue: [
+ traceBlock := [:where | where fullPrint].
+ ObjectMemory flushInlineCaches.
+ ObjectMemory stepInterruptHandler:self.
+ stillHere := false.
+ StepInterruptPending := true.
+ InterruptPending := true
+ ].
+ (leaveCmd == $c) ifTrue: [
+ stillHere := false.
+ stepping := false.
+ tracing := false.
+ StepInterruptPending := nil.
+ InterruptPending := nil
+ ].
+ (leaveCmd == $a) ifTrue: [
+ "abort"
+ stepping := false.
+ tracing := false.
+ StepInterruptPending := nil.
+ InterruptPending := nil.
+ self doAbort.
+ stillHere := true.
+ "failed abort"
+ ].
].
^ nil
! !
@@ -246,8 +248,8 @@
|con sig|
(sig := Object abortSignal) isHandled ifTrue:[
- sig raise.
- 'abort raise failed' errorPrintNewline.
+ sig raise.
+ 'abort raise failed' errorPrintNewline.
].
"TEMPORARY kludge - find event handler context
@@ -255,12 +257,12 @@
"
con := self findContext:#processEvent.
con isNil ifTrue:[
- con := self findContext:#dispatch.
+ con := self findContext:#dispatch.
].
con notNil ifTrue:[
- "got it"
- con return.
- 'return failed' errorPrintNewline.
+ "got it"
+ con return.
+ 'return failed' errorPrintNewline.
].
'found no context to resume' errorPrintNewline.
@@ -273,8 +275,8 @@
'current id=' print. active id print. ' name=' print. active name printNewline.
Process allInstancesDo:[:p |
- 'proc id=' print. p id print. ' name=' print. p name print. ' state=' print.
- p state printNewline.
+ 'proc id=' print. p id print. ' name=' print. p name print. ' state=' print.
+ p state printNewline.
]
!
@@ -283,82 +285,83 @@
done := false.
[done] whileFalse:[
- valid := false.
- cmd := self getCommand.
- (cmd == $p) ifTrue:[
- valid := true.
- context isNil ifTrue: [
- context := self getContext
- ].
- context notNil ifTrue:[
- context fullPrintAll
- ] ifFalse:[
- 'no context' errorPrintNewline
- ]
- ].
- (cmd == $P) ifTrue:[
- valid := true.
- self showProcesses.
- ].
- (cmd == $r) ifTrue:[
- valid := true.
- context isNil ifTrue: [
- context := self getContext
- ].
- context notNil ifTrue:[
- "remove Debugger stepinterrupt/halt frame"
- context sender receiver printNewline
- ] ifFalse:[
- 'no context - dont know receiver' errorPrintNewline
- ]
- ].
- (cmd == $R) ifTrue:[
- valid := true.
- context isNil ifTrue: [
- context := self getContext
- ].
- context notNil ifTrue:[
- "remove Debugger stepinterrupt/halt frame"
- context sender receiver storeOn:Stdout
- ] ifFalse:[
- 'no context - dont know receiver' errorPrintNewline
- ]
- ].
- (cmd == $i) ifTrue:[
- valid := true.
- context isNil ifTrue: [
- context := self getContext
- ].
- context notNil ifTrue:[
- "remove Debugger stepinterrupt/halt frame"
- MiniInspector openOn:(context sender receiver)
- ] ifFalse:[
- 'no context - dont know receiver' errorPrintNewline
- ]
- ].
- (cmd == $I) ifTrue:[
- valid := true.
- context isNil ifTrue: [
- context := self getContext
- ].
- context notNil ifTrue:[
- "remove Debugger stepinterrupt/halt frame"
- self interpreterLoopWith:(context sender receiver)
- ] ifFalse:[
- 'no context - dont know receiver' errorPrintNewline.
- self interpreterLoopWith:nil
- ]
- ].
- context := nil.
- (cmd == $c) ifTrue:[valid := true. done := true].
- (cmd == $s) ifTrue:[valid := true. done := true].
- (cmd == $t) ifTrue:[valid := true. done := true].
- (cmd == $a) ifTrue:[valid := true. done := true].
- (cmd == $T) ifTrue:[valid := true. Processor activeProcess terminate].
- (cmd == $X) ifTrue:[Smalltalk fatalAbort].
- (cmd == $x) ifTrue:[Smalltalk exit].
- valid ifFalse: [
- 'valid commands:
+ valid := false.
+ cmd := self getCommand.
+ (cmd == $p) ifTrue:[
+ valid := true.
+ context isNil ifTrue: [
+ context := self getContext
+ ].
+ context notNil ifTrue:[
+ context fullPrintAll
+ ] ifFalse:[
+ 'no context' errorPrintNewline
+ ]
+ ].
+ (cmd == $P) ifTrue:[
+ valid := true.
+ self showProcesses.
+ ].
+ (cmd == $r) ifTrue:[
+ valid := true.
+ context isNil ifTrue: [
+ context := self getContext
+ ].
+ context notNil ifTrue:[
+ "remove Debugger stepinterrupt/halt frame"
+ context sender receiver printNewline
+ ] ifFalse:[
+ 'no context - dont know receiver' errorPrintNewline
+ ]
+ ].
+ (cmd == $R) ifTrue:[
+ valid := true.
+ context isNil ifTrue: [
+ context := self getContext
+ ].
+ context notNil ifTrue:[
+ "remove Debugger stepinterrupt/halt frame"
+ context sender receiver storeOn:Stdout
+ ] ifFalse:[
+ 'no context - dont know receiver' errorPrintNewline
+ ]
+ ].
+ (cmd == $i) ifTrue:[
+ valid := true.
+ context isNil ifTrue: [
+ context := self getContext
+ ].
+ context notNil ifTrue:[
+ "remove Debugger stepinterrupt/halt frame"
+ MiniInspector openOn:(context sender receiver)
+ ] ifFalse:[
+ 'no context - dont know receiver' errorPrintNewline
+ ]
+ ].
+ (cmd == $I) ifTrue:[
+ valid := true.
+ context isNil ifTrue: [
+ context := self getContext
+ ].
+ context notNil ifTrue:[
+ "remove Debugger stepinterrupt/halt frame"
+ self interpreterLoopWith:(context sender receiver)
+ ] ifFalse:[
+ 'no context - dont know receiver' errorPrintNewline.
+ self interpreterLoopWith:nil
+ ]
+ ].
+ context := nil.
+ (cmd == $c) ifTrue:[valid := true. done := true].
+ (cmd == $s) ifTrue:[valid := true. done := true].
+ (cmd == $t) ifTrue:[valid := true. done := true].
+ (cmd == $a) ifTrue:[valid := true. done := true].
+ (cmd == $T) ifTrue:[valid := true. Processor terminateActive].
+ (cmd == $Q) ifTrue:[valid := true. Processor terminateActiveNoSignal].
+ (cmd == $X) ifTrue:[Smalltalk fatalAbort].
+ (cmd == $x) ifTrue:[Smalltalk exit].
+ valid ifFalse: [
+ 'valid commands:
(c)ontinue
(s)tep
(t)race
@@ -370,9 +373,10 @@
(a)bort
(P)rocesses
(T)terminate current process
+ (Q)uick terminate current process (no unwinds)
(X)exit (+core)
(x)exit Smalltalk' errorPrintNewline
- ]
+ ]
].
^ cmd
!
@@ -382,21 +386,25 @@
'MiniDebugger> ' print.
- cmd := Character fromUser.
- cmd isNil ifTrue:[
- "
- mhmh end-of-file;
- return a 'c' (for continue); hope thats ok.
- "
- cmd := $c
- ].
+ Object userInterruptSignal handle:[:ex |
+ ex restart
+ ] do:[
+ cmd := Character fromUser.
+ cmd isNil ifTrue:[
+ "
+ mhmh end-of-file;
+ return a 'c' (for continue); hope thats ok.
+ "
+ cmd := $c
+ ].
- "
- ignore to end-of-line
- "
- c := cmd.
- [c isNil or:[c isEndOfLineCharacter]] whileFalse: [
- c := Character fromUser.
+ "
+ ignore to end-of-line
+ "
+ c := cmd.
+ [c isNil or:[c isEndOfLineCharacter]] whileFalse: [
+ c := Character fromUser.
+ ].
].
^ cmd
!
@@ -406,13 +414,13 @@
'read-eval-print loop; exit with empty line' printNewline.
done := false.
[done] whileFalse:[
- line := Stdin nextLine.
- (line size == 0) ifTrue:[
- done := true
- ] ifFalse:[
- (Compiler evaluate:line
- receiver:anObject
- notifying:nil) printNewline
- ]
+ line := Stdin nextLine.
+ (line size == 0) ifTrue:[
+ done := true
+ ] ifFalse:[
+ (Compiler evaluate:line
+ receiver:anObject
+ notifying:nil) printNewline
+ ]
]
! !
--- a/MiniDebugger.st Mon Oct 10 01:29:01 1994 +0100
+++ b/MiniDebugger.st Mon Oct 10 01:29:28 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1988 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -19,9 +19,9 @@
MiniDebugger comment:'
COPYRIGHT (c) 1988 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/MiniDebugger.st,v 1.8 1994-08-05 00:59:02 claus Exp $
+$Header: /cvs/stx/stx/libbasic/MiniDebugger.st,v 1.9 1994-10-10 00:26:48 claus Exp $
'!
!MiniDebugger class methodsFor: 'documentation'!
@@ -29,7 +29,7 @@
copyright
"
COPYRIGHT (c) 1988 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/MiniDebugger.st,v 1.8 1994-08-05 00:59:02 claus Exp $
+$Header: /cvs/stx/stx/libbasic/MiniDebugger.st,v 1.9 1994-10-10 00:26:48 claus Exp $
"
!
@@ -61,7 +61,7 @@
new
TheOneAndOnlyDebugger printNL.
TheOneAndOnlyDebugger isNil ifTrue:[
- TheOneAndOnlyDebugger := self basicNew initialize
+ TheOneAndOnlyDebugger := self basicNew initialize
].
^ TheOneAndOnlyDebugger
!
@@ -85,7 +85,7 @@
trace:aBlock on:aStream
self trace:aBlock with:[:where | where printString printOn:aStream.
- aStream cr]
+ aStream cr]
!
trace:aBlock with:aTraceBlock
@@ -108,8 +108,10 @@
StepInterruptPending := nil.
aString printNL.
- active := Processor activeProcess.
- 'process: id=' print. active id print. ' name=' print. active name printNL.
+ Processor notNil ifTrue:[
+ active := Processor activeProcess.
+ 'process: id=' print. active id print. ' name=' print. active name printNL.
+ ].
self new enter.
^ nil
! !
@@ -140,14 +142,14 @@
|backtrace|
backtrace := thisContext.
(backtrace notNil) ifTrue: [
- "remove Context getContext frame"
- backtrace := backtrace sender.
- "remove Debugger showContext frame"
- backtrace := backtrace sender.
- "remove Debugger commandLoop frame"
- backtrace := backtrace sender.
- "remove Debugger enter frame"
- backtrace := backtrace sender
+ "remove Context getContext frame"
+ backtrace := backtrace sender.
+ "remove Debugger showContext frame"
+ backtrace := backtrace sender.
+ "remove Debugger commandLoop frame"
+ backtrace := backtrace sender.
+ "remove Debugger enter frame"
+ backtrace := backtrace sender
].
^ backtrace
!
@@ -157,11 +159,11 @@
con := thisContext sender.
[con notNil] whileTrue:[
- (con isBlockContext not and:[con selector == aSelector]) ifTrue:[
- "got it"
- ^ con
- ].
- con := con sender
+ (con isBlockContext not and:[con selector == aSelector]) ifTrue:[
+ "got it"
+ ^ con
+ ].
+ con := con sender
].
^ nil
! !
@@ -173,69 +175,69 @@
where := thisContext. "where is stepInterrupt context"
where notNil ifTrue:[
- where := where sender "where is now interrupted methods context"
+ where := where sender "where is now interrupted methods context"
].
stepping ifTrue:[
- where notNil ifTrue:[
- where fullPrint
- ] ifFalse:[
- 'stepInterrupt: no context' errorPrintNewline
- ].
- self enter
+ where notNil ifTrue:[
+ where fullPrint
+ ] ifFalse:[
+ 'stepInterrupt: no context' errorPrintNewline
+ ].
+ self enter
] ifFalse:[
- where notNil ifTrue:[
- traceBlock notNil ifTrue:[
- traceBlock value:where
- ]
- ] ifFalse:[
- 'traceInterrupt: no context' errorPrintNewline
- ].
- ObjectMemory flushInlineCaches.
- StepInterruptPending := true.
- InterruptPending := true
+ where notNil ifTrue:[
+ traceBlock notNil ifTrue:[
+ traceBlock value:where
+ ]
+ ] ifFalse:[
+ 'traceInterrupt: no context' errorPrintNewline
+ ].
+ ObjectMemory flushInlineCaches.
+ StepInterruptPending := true.
+ InterruptPending := true
]
!
enter
- |cmd stillHere|
+ |leaveCmd stillHere|
stillHere := true.
[stillHere] whileTrue:[
- cmd := self commandLoop.
+ leaveCmd := self commandLoop.
- (cmd == $s) ifTrue: [
- self stepping.
- ObjectMemory flushInlineCaches.
- ObjectMemory stepInterruptHandler:self.
- stillHere := false.
- StepInterruptPending := true.
- InterruptPending := true
- ].
- (cmd == $t) ifTrue: [
- traceBlock := [:where | where fullPrint].
- ObjectMemory flushInlineCaches.
- ObjectMemory stepInterruptHandler:self.
- stillHere := false.
- StepInterruptPending := true.
- InterruptPending := true
- ].
- (cmd == $c) ifTrue: [
- stillHere := false.
- stepping := false.
- tracing := false.
- StepInterruptPending := nil.
- InterruptPending := nil
- ].
- (cmd == $a) ifTrue: [
- "abort"
- stepping := false.
- tracing := false.
- StepInterruptPending := nil.
- InterruptPending := nil.
- self doAbort.
- stillHere := true.
- "failed abort"
- ].
+ (leaveCmd == $s) ifTrue: [
+ self stepping.
+ ObjectMemory flushInlineCaches.
+ ObjectMemory stepInterruptHandler:self.
+ stillHere := false.
+ StepInterruptPending := true.
+ InterruptPending := true
+ ].
+ (leaveCmd == $t) ifTrue: [
+ traceBlock := [:where | where fullPrint].
+ ObjectMemory flushInlineCaches.
+ ObjectMemory stepInterruptHandler:self.
+ stillHere := false.
+ StepInterruptPending := true.
+ InterruptPending := true
+ ].
+ (leaveCmd == $c) ifTrue: [
+ stillHere := false.
+ stepping := false.
+ tracing := false.
+ StepInterruptPending := nil.
+ InterruptPending := nil
+ ].
+ (leaveCmd == $a) ifTrue: [
+ "abort"
+ stepping := false.
+ tracing := false.
+ StepInterruptPending := nil.
+ InterruptPending := nil.
+ self doAbort.
+ stillHere := true.
+ "failed abort"
+ ].
].
^ nil
! !
@@ -246,8 +248,8 @@
|con sig|
(sig := Object abortSignal) isHandled ifTrue:[
- sig raise.
- 'abort raise failed' errorPrintNewline.
+ sig raise.
+ 'abort raise failed' errorPrintNewline.
].
"TEMPORARY kludge - find event handler context
@@ -255,12 +257,12 @@
"
con := self findContext:#processEvent.
con isNil ifTrue:[
- con := self findContext:#dispatch.
+ con := self findContext:#dispatch.
].
con notNil ifTrue:[
- "got it"
- con return.
- 'return failed' errorPrintNewline.
+ "got it"
+ con return.
+ 'return failed' errorPrintNewline.
].
'found no context to resume' errorPrintNewline.
@@ -273,8 +275,8 @@
'current id=' print. active id print. ' name=' print. active name printNewline.
Process allInstancesDo:[:p |
- 'proc id=' print. p id print. ' name=' print. p name print. ' state=' print.
- p state printNewline.
+ 'proc id=' print. p id print. ' name=' print. p name print. ' state=' print.
+ p state printNewline.
]
!
@@ -283,82 +285,83 @@
done := false.
[done] whileFalse:[
- valid := false.
- cmd := self getCommand.
- (cmd == $p) ifTrue:[
- valid := true.
- context isNil ifTrue: [
- context := self getContext
- ].
- context notNil ifTrue:[
- context fullPrintAll
- ] ifFalse:[
- 'no context' errorPrintNewline
- ]
- ].
- (cmd == $P) ifTrue:[
- valid := true.
- self showProcesses.
- ].
- (cmd == $r) ifTrue:[
- valid := true.
- context isNil ifTrue: [
- context := self getContext
- ].
- context notNil ifTrue:[
- "remove Debugger stepinterrupt/halt frame"
- context sender receiver printNewline
- ] ifFalse:[
- 'no context - dont know receiver' errorPrintNewline
- ]
- ].
- (cmd == $R) ifTrue:[
- valid := true.
- context isNil ifTrue: [
- context := self getContext
- ].
- context notNil ifTrue:[
- "remove Debugger stepinterrupt/halt frame"
- context sender receiver storeOn:Stdout
- ] ifFalse:[
- 'no context - dont know receiver' errorPrintNewline
- ]
- ].
- (cmd == $i) ifTrue:[
- valid := true.
- context isNil ifTrue: [
- context := self getContext
- ].
- context notNil ifTrue:[
- "remove Debugger stepinterrupt/halt frame"
- MiniInspector openOn:(context sender receiver)
- ] ifFalse:[
- 'no context - dont know receiver' errorPrintNewline
- ]
- ].
- (cmd == $I) ifTrue:[
- valid := true.
- context isNil ifTrue: [
- context := self getContext
- ].
- context notNil ifTrue:[
- "remove Debugger stepinterrupt/halt frame"
- self interpreterLoopWith:(context sender receiver)
- ] ifFalse:[
- 'no context - dont know receiver' errorPrintNewline.
- self interpreterLoopWith:nil
- ]
- ].
- context := nil.
- (cmd == $c) ifTrue:[valid := true. done := true].
- (cmd == $s) ifTrue:[valid := true. done := true].
- (cmd == $t) ifTrue:[valid := true. done := true].
- (cmd == $a) ifTrue:[valid := true. done := true].
- (cmd == $T) ifTrue:[valid := true. Processor activeProcess terminate].
- (cmd == $X) ifTrue:[Smalltalk fatalAbort].
- (cmd == $x) ifTrue:[Smalltalk exit].
- valid ifFalse: [
- 'valid commands:
+ valid := false.
+ cmd := self getCommand.
+ (cmd == $p) ifTrue:[
+ valid := true.
+ context isNil ifTrue: [
+ context := self getContext
+ ].
+ context notNil ifTrue:[
+ context fullPrintAll
+ ] ifFalse:[
+ 'no context' errorPrintNewline
+ ]
+ ].
+ (cmd == $P) ifTrue:[
+ valid := true.
+ self showProcesses.
+ ].
+ (cmd == $r) ifTrue:[
+ valid := true.
+ context isNil ifTrue: [
+ context := self getContext
+ ].
+ context notNil ifTrue:[
+ "remove Debugger stepinterrupt/halt frame"
+ context sender receiver printNewline
+ ] ifFalse:[
+ 'no context - dont know receiver' errorPrintNewline
+ ]
+ ].
+ (cmd == $R) ifTrue:[
+ valid := true.
+ context isNil ifTrue: [
+ context := self getContext
+ ].
+ context notNil ifTrue:[
+ "remove Debugger stepinterrupt/halt frame"
+ context sender receiver storeOn:Stdout
+ ] ifFalse:[
+ 'no context - dont know receiver' errorPrintNewline
+ ]
+ ].
+ (cmd == $i) ifTrue:[
+ valid := true.
+ context isNil ifTrue: [
+ context := self getContext
+ ].
+ context notNil ifTrue:[
+ "remove Debugger stepinterrupt/halt frame"
+ MiniInspector openOn:(context sender receiver)
+ ] ifFalse:[
+ 'no context - dont know receiver' errorPrintNewline
+ ]
+ ].
+ (cmd == $I) ifTrue:[
+ valid := true.
+ context isNil ifTrue: [
+ context := self getContext
+ ].
+ context notNil ifTrue:[
+ "remove Debugger stepinterrupt/halt frame"
+ self interpreterLoopWith:(context sender receiver)
+ ] ifFalse:[
+ 'no context - dont know receiver' errorPrintNewline.
+ self interpreterLoopWith:nil
+ ]
+ ].
+ context := nil.
+ (cmd == $c) ifTrue:[valid := true. done := true].
+ (cmd == $s) ifTrue:[valid := true. done := true].
+ (cmd == $t) ifTrue:[valid := true. done := true].
+ (cmd == $a) ifTrue:[valid := true. done := true].
+ (cmd == $T) ifTrue:[valid := true. Processor terminateActive].
+ (cmd == $Q) ifTrue:[valid := true. Processor terminateActiveNoSignal].
+ (cmd == $X) ifTrue:[Smalltalk fatalAbort].
+ (cmd == $x) ifTrue:[Smalltalk exit].
+ valid ifFalse: [
+ 'valid commands:
(c)ontinue
(s)tep
(t)race
@@ -370,9 +373,10 @@
(a)bort
(P)rocesses
(T)terminate current process
+ (Q)uick terminate current process (no unwinds)
(X)exit (+core)
(x)exit Smalltalk' errorPrintNewline
- ]
+ ]
].
^ cmd
!
@@ -382,21 +386,25 @@
'MiniDebugger> ' print.
- cmd := Character fromUser.
- cmd isNil ifTrue:[
- "
- mhmh end-of-file;
- return a 'c' (for continue); hope thats ok.
- "
- cmd := $c
- ].
+ Object userInterruptSignal handle:[:ex |
+ ex restart
+ ] do:[
+ cmd := Character fromUser.
+ cmd isNil ifTrue:[
+ "
+ mhmh end-of-file;
+ return a 'c' (for continue); hope thats ok.
+ "
+ cmd := $c
+ ].
- "
- ignore to end-of-line
- "
- c := cmd.
- [c isNil or:[c isEndOfLineCharacter]] whileFalse: [
- c := Character fromUser.
+ "
+ ignore to end-of-line
+ "
+ c := cmd.
+ [c isNil or:[c isEndOfLineCharacter]] whileFalse: [
+ c := Character fromUser.
+ ].
].
^ cmd
!
@@ -406,13 +414,13 @@
'read-eval-print loop; exit with empty line' printNewline.
done := false.
[done] whileFalse:[
- line := Stdin nextLine.
- (line size == 0) ifTrue:[
- done := true
- ] ifFalse:[
- (Compiler evaluate:line
- receiver:anObject
- notifying:nil) printNewline
- ]
+ line := Stdin nextLine.
+ (line size == 0) ifTrue:[
+ done := true
+ ] ifFalse:[
+ (Compiler evaluate:line
+ receiver:anObject
+ notifying:nil) printNewline
+ ]
]
! !
--- a/NPExtStr.st Mon Oct 10 01:29:01 1994 +0100
+++ b/NPExtStr.st Mon Oct 10 01:29:28 1994 +0100
@@ -10,7 +10,7 @@
hereby transferred.
"
-ExternalStream subclass:#NonPositionableExternalStream
+UnboundedExternalStream subclass:#NonPositionableExternalStream
instanceVariableNames:''
classVariableNames:'StdInStream StdOutStream StdErrorStream'
poolDictionaries:''
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Attic/NPExtStr.st,v 1.8 1994-08-05 00:59:05 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/NPExtStr.st,v 1.9 1994-10-10 00:26:52 claus Exp $
'!
%{
@@ -46,7 +46,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Attic/NPExtStr.st,v 1.8 1994-08-05 00:59:05 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/NPExtStr.st,v 1.9 1994-10-10 00:26:52 claus Exp $
"
!
@@ -59,6 +59,9 @@
There are three special instances of this class, representing stdin,
stdout and stderr of the smalltalk/X process (see Unix manuals, if you
dont know what those are used for).
+
+ The name of this class is a historical leftover - it should be called
+ 'TTYStream' or similar.
"
! !
@@ -141,23 +144,3 @@
].
^ super reOpen
! !
-
-!NonPositionableExternalStream methodsFor:'redefind basic'!
-
-size
- "report an error that this stream has no concept of size"
-
- self shouldNotImplement
-!
-
-position
- "report an error that this stream has no concept of position"
-
- self shouldNotImplement
-!
-
-position:anInteger
- "report an error that this stream has no concept of position"
-
- self shouldNotImplement
-! !
--- a/NonPositionableExternalStream.st Mon Oct 10 01:29:01 1994 +0100
+++ b/NonPositionableExternalStream.st Mon Oct 10 01:29:28 1994 +0100
@@ -10,7 +10,7 @@
hereby transferred.
"
-ExternalStream subclass:#NonPositionableExternalStream
+UnboundedExternalStream subclass:#NonPositionableExternalStream
instanceVariableNames:''
classVariableNames:'StdInStream StdOutStream StdErrorStream'
poolDictionaries:''
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/NonPositionableExternalStream.st,v 1.8 1994-08-05 00:59:05 claus Exp $
+$Header: /cvs/stx/stx/libbasic/NonPositionableExternalStream.st,v 1.9 1994-10-10 00:26:52 claus Exp $
'!
%{
@@ -46,7 +46,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/NonPositionableExternalStream.st,v 1.8 1994-08-05 00:59:05 claus Exp $
+$Header: /cvs/stx/stx/libbasic/NonPositionableExternalStream.st,v 1.9 1994-10-10 00:26:52 claus Exp $
"
!
@@ -59,6 +59,9 @@
There are three special instances of this class, representing stdin,
stdout and stderr of the smalltalk/X process (see Unix manuals, if you
dont know what those are used for).
+
+ The name of this class is a historical leftover - it should be called
+ 'TTYStream' or similar.
"
! !
@@ -141,23 +144,3 @@
].
^ super reOpen
! !
-
-!NonPositionableExternalStream methodsFor:'redefind basic'!
-
-size
- "report an error that this stream has no concept of size"
-
- self shouldNotImplement
-!
-
-position
- "report an error that this stream has no concept of position"
-
- self shouldNotImplement
-!
-
-position:anInteger
- "report an error that this stream has no concept of position"
-
- self shouldNotImplement
-! !
--- a/ObjMem.st Mon Oct 10 01:29:01 1994 +0100
+++ b/ObjMem.st Mon Oct 10 01:29:28 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1992 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -13,25 +13,25 @@
Object subclass:#ObjectMemory
instanceVariableNames:''
classVariableNames:'InternalErrorHandler UserInterruptHandler TimerInterruptHandler
- SpyInterruptHandler StepInterruptHandler ExceptionInterruptHandler
- ErrorInterruptHandler MemoryInterruptHandler SignalInterruptHandler
- ChildSignalInterruptHandler DisposeInterruptHandler
- RecursionInterruptHandler IOInterruptHandler
- CustomInterruptHandler
+ SpyInterruptHandler StepInterruptHandler ExceptionInterruptHandler
+ ErrorInterruptHandler MemoryInterruptHandler SignalInterruptHandler
+ ChildSignalInterruptHandler DisposeInterruptHandler
+ RecursionInterruptHandler IOInterruptHandler
+ CustomInterruptHandler
- AllocationFailureSignal
- IncrementalGCLimit
- Dependents
- ImageName'
+ AllocationFailureSignal
+ IncrementalGCLimit
+ Dependents
+ ImageName'
poolDictionaries:''
category:'System-Support'
!
ObjectMemory comment:'
COPYRIGHT (c) 1992 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Attic/ObjMem.st,v 1.14 1994-08-22 12:21:33 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/ObjMem.st,v 1.15 1994-10-10 00:26:56 claus Exp $
'!
!ObjectMemory class methodsFor:'documentation'!
@@ -39,7 +39,7 @@
copyright
"
COPYRIGHT (c) 1992 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -52,7 +52,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Attic/ObjMem.st,v 1.14 1994-08-22 12:21:33 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/ObjMem.st,v 1.15 1994-10-10 00:26:56 claus Exp $
"
!
@@ -73,30 +73,30 @@
ClassVariables:
- InternalErrorHandler gets informed (by VM), when some runtime
- error occurs (usually fatal)
+ InternalErrorHandler gets informed (by VM), when some runtime
+ error occurs (usually fatal)
- UserInterruptHandler gets informed (by VM) when CNTL-C is pressed
- TimerInterruptHandler gets alarm timer interrupts (from VM)
- SpyInterruptHandler another alarm timer (from VM)
- StepInterruptHandler gets single step interrupts (from VM)
- ExceptionInterruptHandler gets floating point exceptions (from VM)
- ErrorInterruptHandler gets graphic device errors (from VM)
- MemoryInterruptHandler gets soon-out-of-memory conditions (from VM)
- SignalInterruptHandler gets unix signals (from VM)
- ChildSignalInterruptHandler gets child death signals (from VM)
- DisposeInterruptHandler gets informed, when an object is disposed from
- a shadowArray (from VM)
- RecursionInterruptHandler gets recursion limit violations (from VM)
- IOInterruptHandler gets SIGIO unix signals (from VM)
- CustomInterruptHandler gets custom interrupts (from VM)
+ UserInterruptHandler gets informed (by VM) when CNTL-C is pressed
+ TimerInterruptHandler gets alarm timer interrupts (from VM)
+ SpyInterruptHandler another alarm timer (from VM)
+ StepInterruptHandler gets single step interrupts (from VM)
+ ExceptionInterruptHandler gets floating point exceptions (from VM)
+ ErrorInterruptHandler gets graphic device errors (from VM)
+ MemoryInterruptHandler gets soon-out-of-memory conditions (from VM)
+ SignalInterruptHandler gets unix signals (from VM)
+ ChildSignalInterruptHandler gets child death signals (from VM)
+ DisposeInterruptHandler gets informed, when an object is disposed from
+ a shadowArray (from VM)
+ RecursionInterruptHandler gets recursion limit violations (from VM)
+ IOInterruptHandler gets SIGIO unix signals (from VM)
+ CustomInterruptHandler gets custom interrupts (from VM)
- AllocationFailureSignal signal raised when a new fails (see Behavior)
- IngrementalGCLimit number of bytes, that must be allocated since
- last full garbage collect to turn on incremental
- collector.
- Dependents keep my dependents locally (its faster) for
- all those registries
+ AllocationFailureSignal signal raised when a new fails (see Behavior)
+ IngrementalGCLimit number of bytes, that must be allocated since
+ last full garbage collect to turn on incremental
+ collector.
+ Dependents keep my dependents locally (its faster) for
+ all those registries
"
!
@@ -105,18 +105,18 @@
The system uses various caches to speed up method-lookup.
Currently, there is a three-level cache hierarchy:
- inline-cache keeps the target of the last send at the caller-
- side (i.e. every send goes through its private
- 1-slot inline-cache, where the address of the last
- called function at this call location is kept.)
+ inline-cache keeps the target of the last send at the caller-
+ side (i.e. every send goes through its private
+ 1-slot inline-cache, where the address of the last
+ called function at this call location is kept.)
- polymorph-inline-cache keeps a limited list of all targets ever reched
- at this call location. The list is flushed if it
- grows too large or the total number of poly-chache
- entries exceeds a limit.
+ polymorph-inline-cache keeps a limited list of all targets ever reched
+ at this call location. The list is flushed if it
+ grows too large or the total number of poly-chache
+ entries exceeds a limit.
- method-lookup-cache a global cache. Hashes on class-selector pairs,
- returning the target method.
+ method-lookup-cache a global cache. Hashes on class-selector pairs,
+ returning the target method.
Whenever methods are added or removed from the system, or the inheritance
hierarchy changes, some or all caches have to be flushed.
@@ -235,8 +235,11 @@
initialize
AllocationFailureSignal isNil ifTrue:[
- AllocationFailureSignal := (Signal new) mayProceed:true.
- AllocationFailureSignal notifierString:'allocation failure'.
+ Object initialize.
+
+ AllocationFailureSignal := Object errorSignal newSignalMayProceed:true.
+ AllocationFailureSignal nameClass:self message:#allocationFailureSignal.
+ AllocationFailureSignal notifierString:'allocation failure'.
].
IncrementalGCLimit := 500000.
MemoryInterruptHandler := self
@@ -349,7 +352,7 @@
* allObjectsDo needs a temporary to hold newSpace objects
*/
if (__allObjectsDo(&aBlock, &work COMMA_CON) < 0) {
- RETURN (false);
+ RETURN (false);
}
%}.
^ true
@@ -360,7 +363,7 @@
For debugging and tests only - do not use"
%{
if (__allObjectsDo(&aBlock, (OBJ *)0 COMMA_CON) < 0) {
- RETURN (false);
+ RETURN (false);
}
%}.
^ true
@@ -639,13 +642,13 @@
aCollection := IdentitySet new.
self allObjectsDo:[:o |
- (o references:anObject) ifTrue:[
- aCollection add:o
- ]
+ (o references:anObject) ifTrue:[
+ aCollection add:o
+ ]
].
(aCollection size == 0) ifTrue:[
- "actually this cannot happen - there is always one"
- ^ nil
+ "actually this cannot happen - there is always one"
+ ^ nil
].
^ aCollection
!
@@ -659,7 +662,7 @@
%{ /* NOCONTEXT */
if (! _isNonNilObject(anObject)) {
- RETURN ( nil );
+ RETURN ( nil );
}
RETURN ( _MKSMALLINT( (int)anObject ) );
%}
@@ -672,6 +675,24 @@
"
!
+objectAt:anAddress
+ "return whatever anAddress points to as object.
+ BIG BIG danger alert: this method is only to be used for debugging
+ ST/X itself - you can easily (and badly) crash the system.
+ This method will be removed from the final shipping version"
+
+ |low high|
+
+ low := anAddress bitAnd:16rFFFF.
+ high := (anAddress bitShift:16) bitAnd:16rFFFF.
+%{
+ if (_isSmallInteger(low)
+ && _isSmallInteger(high)) {
+ RETURN ((OBJ)((_intVal(high) << 16) | _intVal(low)));
+ }
+%}
+!
+
sizeOf:anObject
"return the size of anObject in bytes.
Use only for debugging/memory monitoring."
@@ -686,12 +707,12 @@
hist := Array new:100 withAll:0.
big := 0.
ObjectMemory allObjectsDo:[:o |
- nw := (ObjectMemory sizeOf:o) // 4 + 1.
- nw > 100 ifTrue:[
- big := big + 1
- ] ifFalse:[
- hist at:nw put:(hist at:nw) + 1
- ].
+ nw := (ObjectMemory sizeOf:o) // 4 + 1.
+ nw > 100 ifTrue:[
+ big := big + 1
+ ] ifFalse:[
+ hist at:nw put:(hist at:nw) + 1
+ ].
].
hist printNL.
big printNL
@@ -707,22 +728,26 @@
%{ /* NOCONTEXT */
if (! _isNonNilObject(anObject)) {
- RETURN ( nil );
+ RETURN ( nil );
}
RETURN ( _MKSMALLINT( _qSpace(anObject) ) );
%}
+!
+
+flagsOf:anObject
+%{ /* NOCONTEXT */
+
+ if (! _isNonNilObject(anObject)) {
+ RETURN ( nil );
+ }
+ RETURN ( _MKSMALLINT( anObject->o_flags ) );
+%}
"
- |p|
- p := Point new.
- (ObjectMemory spaceOf:p) printNL.
- 1 to:100 do:[:i |
- ObjectMemory scavenge.
- ].
- (ObjectMemory spaceOf:p) printNL.
- 1 to:100 do:[:i |
- ObjectMemory tenuringScavenge.
- ].
- (ObjectMemory spaceOf:p) printNL.
+F_ISREMEMBERED 1 /* a new-space thing on rem-list */
+F_ISFORWARDED 2 /* a forwarded object (only valid after scavenge) */
+F_DEREFERENCED 4 /* a collection after grow (not currently used) */
+F_ISONLIFOLIST 8 /* a non-lifo-context-referencing-obj already on list */
+F_MARK 16 /* mark bit for background collector */
"
!
@@ -734,7 +759,7 @@
%{ /* NOCONTEXT */
if (! _isNonNilObject(anObject)) {
- RETURN ( 0 );
+ RETURN ( 0 );
}
RETURN ( _MKSMALLINT( _GET_AGE(anObject) ) );
%}
@@ -830,7 +855,7 @@
reclaimSymbols
"reclaim unused symbols;
- Unused symbols are (currently) not reclaimed automativally,
+ Unused symbols are (currently) not reclaimed automatically,
but only upon request with this method. It takes some time
to do this ...
Future versions may do this while garbage collecting."
@@ -875,7 +900,11 @@
However, #incrementalGC is interruptable while #markAndSweep
blocks for a while. Thus this method can be called from a low
prio (background) process to collect without disturbing
- foreground processes too much."
+ foreground processes too much.
+ For example, someone allocating huge amounts of memory could
+ ask for the possibility of a quick allocation using
+ #checkForFastNew: and try a #incrementalGC if not. In many
+ cases, this can avoid a pause due to a blocking GC."
[self gcStep] whileFalse:[]
@@ -916,7 +945,7 @@
%{
if (_isSmallInteger(howMuch))
- __moreOldSpace(__context, _intVal(howMuch));
+ __moreOldSpace(__context, _intVal(howMuch));
%}
"
ObjectMemory moreOldSpace:1000000
@@ -931,10 +960,10 @@
Notice: this is a nonstandard interface - use only in special situations."
(self checkForFastNew:howMuch) ifFalse:[
- self incrementalGC.
- (self checkForFastNew:howMuch) ifFalse:[
- self moreOldSpace:howMuch
- ]
+ self incrementalGC.
+ (self checkForFastNew:howMuch) ifFalse:[
+ self moreOldSpace:howMuch
+ ]
]
"
@@ -964,7 +993,7 @@
extern unsigned __oldSpaceIncrement();
if (_isSmallInteger(amount)) {
- RETURN (_MKSMALLINT( __oldSpaceIncrement(_intVal(amount)) ));
+ RETURN (_MKSMALLINT( __oldSpaceIncrement(_intVal(amount)) ));
}
%}
!
@@ -983,9 +1012,9 @@
extern __checkForFastNew();
if (_isSmallInteger(amount)) {
- if (! __checkForFastNew(_intVal(amount))) {
- RETURN (false);
- }
+ if (! __checkForFastNew(_intVal(amount))) {
+ RETURN (false);
+ }
}
%}.
@@ -1023,7 +1052,7 @@
it may vanish. Dont use it."
%{
if (__moveToOldSpace(anObject, __context) < 0) {
- RETURN (false);
+ RETURN (false);
}
%}.
^ true
@@ -1035,7 +1064,7 @@
For internal & debugging use only."
%{
if (__newSpacePagesDo(&aBlock COMMA_CON) < 0) {
- RETURN (false);
+ RETURN (false);
}
%}.
^ true
@@ -1047,7 +1076,7 @@
For internal & debugging use only."
%{
if (__oldSpacePagesDo(&aBlock COMMA_CON) < 0) {
- RETURN (false);
+ RETURN (false);
}
%}.
^ true
@@ -1059,7 +1088,7 @@
For internal & debugging use only."
%{
if (__collectedOldSpacePagesDo(&aBlock COMMA_CON) < 0) {
- RETURN (false);
+ RETURN (false);
}
%}.
^ true
@@ -1078,12 +1107,12 @@
INT addr;
if (_isSmallInteger(aPageNumber)) {
- addr = _intVal(aPageNumber) & ~(pageSize - 1);
+ addr = _intVal(aPageNumber) & ~(pageSize - 1);
} else {
- addr = ((INT)aPageNumber) & ~(pageSize - 1);
+ addr = ((INT)aPageNumber) & ~(pageSize - 1);
}
if (mincore(addr, pageSize-1, result) < 0) {
- RETURN (true);
+ RETURN (true);
}
RETURN ((result[0] & 1) ? true : false);
#endif
@@ -1099,7 +1128,7 @@
remove possibly cached data - this may help a bit"
Smalltalk allClasses do:[:aClass |
- aClass lowSpaceCleanup
+ aClass lowSpaceCleanup
].
self error:'almost out of memory'
@@ -1115,16 +1144,16 @@
fName := self fileNameForClass:aClassName.
fName notNil ifTrue:[
- upd := Class updateChanges:false.
- [
- self loadBinary:(fName , '.o')
- ] valueNowOrOnUnwindDo:[
- Class updateChanges:upd
- ].
- newClass := self at:(aClassName asSymbol).
- (newClass notNil and:[newClass implements:#initialize]) ifTrue:[
- newClass initialize
- ]
+ upd := Class updateChanges:false.
+ [
+ self loadBinary:(fName , '.o')
+ ] valueNowOrOnUnwindDo:[
+ Class updateChanges:upd
+ ].
+ newClass := self at:(aClassName asSymbol).
+ (newClass notNil and:[newClass implements:#initialize]) ifTrue:[
+ newClass initialize
+ ]
]
!
@@ -1133,33 +1162,56 @@
if not running from an image."
^ ImageName
+
+ "
+ ObjectMemory ImageName
+ "
!
nameForSnapshot
- "return the filename of the current image or,
+ "return a reasonable filename to store the snapshot image into.
+ This is the filename of the current image or,
if not running from an image, the default name 'st.img'"
(ImageName isNil or:[ImageName isBlank]) ifTrue:[
- ^ 'st.img'
+ ^ 'st.img'
+ ].
+ (ImageName endsWith:'.sav') ifTrue:[
+ ^ ImageName copyTo:(ImageName size - 4)
].
^ ImageName
+
+ "
+ ObjectMemory nameForSnapshot
+ "
!
snapShot
- "create a snapshot"
+ "create a snapshot file containing all of the current state."
- ImageName isNil ifTrue:[
- ImageName := 'st.img'
- ].
+"/ ImageName isNil ifTrue:[
+"/ ImageName := 'st.img'
+"/ ].
self snapShotOn:(self nameForSnapshot)
- "ObjectMemory snapShot"
+ "
+ ObjectMemory snapShot
+ "
!
snapShotOn:aFileName
"create a snapshot in the given file"
- |ok|
+ |ok oldImageName|
+
+ "
+ keep a save version - just in case something
+ bad happens while writing the image.
+ (could be st/x internal error or file-system errors etc)
+ "
+ (OperatingSystem isValidPath:aFileName) ifTrue:[
+ OperatingSystem renameFile:aFileName to:(aFileName , '.sav').
+ ].
"
give others a chance to fix things
@@ -1170,33 +1222,56 @@
ST-80 compatibility; send #preSnapshot to all classes
"
Smalltalk allClassesDo:[:aClass |
- aClass preSnapshot
+ aClass preSnapshot
].
+ "
+ save the name with it ...
+ "
+ oldImageName := ImageName.
+ ImageName := aFileName.
+ ok := self primSnapShotOn:aFileName.
+ ImageName := oldImageName.
+
+ ok ifTrue:[
+ Class addChangeRecordForSnapshot:aFileName.
+
+
+ "
+ ST-80 compatibility; send #postSnapshot to all classes
+ "
+ Smalltalk allClassesDo:[:aClass |
+ aClass postSnapshot
+ ].
+ ].
+ ^ ok
+
+ "
+ ObjectMemory snapShotOn:'myimage.img'
+ "
+!
+
+primSnapShotOn:aFileName
+ "create a snapshot in the given file.
+ Low level entry. Does not notify classes or write an entry to
+ the changes file. Also, no image backup is created. Returns true if
+ the snapshot worked, false if it failed for some reason.
+ This method should not be used in normal cases."
+
+ |ok|
+
%{ /* STACK:32000 */
OBJ __snapShotOn();
- OBJ retVal;
+ OBJ funny = @symbol(funnySnapshotSymbol);
if (__isString(aFileName)) {
- BLOCKINTERRUPTS();
- ok = __snapShotOn(__context, _stringVal(aFileName));
- UNBLOCKINTERRUPTS();
+ BLOCKINTERRUPTS();
+ ok = __snapShotOn(__context, _stringVal(aFileName), funny);
+ UNBLOCKINTERRUPTS();
}
-%}
-.
- ok ifTrue:[
- Class addChangeRecordForSnapshot:aFileName
- ].
- "
- ST-80 compatibility; send #postSnapshot to all classes
- "
- Smalltalk allClassesDo:[:aClass |
- aClass postSnapshot
- ].
+%}.
^ ok
-
- "ObjectMemory snapShotOn:'myimage.img'"
!
applicationImageOn:aFileName for:startupClass selector:startupSelector
@@ -1246,11 +1321,11 @@
self snapShotOn:'temp.img'.
Display knownViews do:[:aView |
- aView notNil ifTrue:[
- aView superView isNil ifTrue:[
- aView destroy
- ]
- ]
+ aView notNil ifTrue:[
+ aView superView isNil ifTrue:[
+ aView destroy
+ ]
+ ]
].
self stripImage.
@@ -1260,7 +1335,7 @@
"continue in old image"
OperatingSystem exec:(Arguments at:1)
- withArguments:#('smalltalk' '-i' 'temp.img') , (Arguments copyFrom:2)
+ withArguments:#('smalltalk' '-i' 'temp.img') , (Arguments copyFrom:2)
"ObjectMemory minimumApplicationImageOn:'clock1.img' for:Clock selector:#start"
"ObjectMemory applicationImageOn:'clock2.img' for:Clock selector:#start"
@@ -1273,11 +1348,11 @@
"remove all class comments & source"
Smalltalk allBehaviorsDo:[:aClass |
- aClass setComment:nil.
- aClass methodArray do:[:aMethod |
- aMethod source:''.
- aMethod category:#none
- ]
+ aClass setComment:nil.
+ aClass methodArray do:[:aMethod |
+ aMethod source:''.
+ aMethod category:#none
+ ]
].
self garbageCollect
! !
--- a/Object.st Mon Oct 10 01:29:01 1994 +0100
+++ b/Object.st Mon Oct 10 01:29:28 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1988 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -13,22 +13,23 @@
Object subclass:#Object
instanceVariableNames:''
classVariableNames:'ErrorSignal HaltSignal
- MessageNotUnderstoodSignal UserInterruptSignal
- RecursionInterruptSignal ExceptionInterruptSignal
- SubscriptOutOfBoundsSignal NonIntegerIndexSignal
- NotFoundSignal KeyNotFoundSignal ElementOutOfBoundsSignal
- InformationSignal PrimitiveFailureSignal
- AbortSignal
- ErrorRecursion Dependencies'
+ MessageNotUnderstoodSignal UserInterruptSignal
+ RecursionInterruptSignal ExceptionInterruptSignal
+ SubscriptOutOfBoundsSignal NonIntegerIndexSignal
+ NotFoundSignal KeyNotFoundSignal ElementOutOfBoundsSignal
+ InformationSignal PrimitiveFailureSignal
+ DeepCopyErrorSignal
+ AbortSignal
+ ErrorRecursion Dependencies'
poolDictionaries:''
category:'Kernel-Objects'
!
Object comment:'
COPYRIGHT (c) 1988 by Claus Gittinger
- All Rights Reserved
-
-$Header: /cvs/stx/stx/libbasic/Object.st,v 1.22 1994-08-23 23:10:03 claus Exp $
+ All Rights Reserved
+
+$Header: /cvs/stx/stx/libbasic/Object.st,v 1.23 1994-10-10 00:27:00 claus Exp $
'!
!Object class methodsFor:'documentation'!
@@ -36,7 +37,7 @@
copyright
"
COPYRIGHT (c) 1988 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -49,50 +50,52 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Object.st,v 1.22 1994-08-23 23:10:03 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Object.st,v 1.23 1994-10-10 00:27:00 claus Exp $
"
!
documentation
"
- Class Object is the superclass of all other classes. Protocol common to
- all objects is defined here.
+ Object is the superclass of all other classes. Protocol common to
+ every object is defined here.
Also some utility stuff (like notify) and error handling is implemented here.
Object has no instance variables (and may not get any added). One reason is, that
- UndefinedObject and SmallIntegers are also object - these two cannot have instance
+ UndefinedObject and SmallInteger are also inheriting from Object - these two cannot have instance
variables (due to their implementation). The other reason is that the runtime system
- (VM) knows about the layout of some built-in classes (think of classes, methods, blocks
- and also integers). If you where allowed to add instance variables to Object, the
- VM had to be recompiled (and also rewritten in some places).
+ (VM) knows about the layout of some built-in classes (think of Class, Method, Block
+ and also Integer or Float). If you where allowed to add instance variables to Object,
+ the VM had to be recompiled (and also rewritten in some places).
Class variables:
- ErrorSignal <Signal> Signal raised for error/error: messages
-
- HaltSignal <Signal> Signal raised for halt/halt: messages
-
- MessageNotUnderstoodSignal Signals raised for various error conditions
- UserInterruptSignal
- RecursionInterruptSignal
- ExceptionInterruptSignal
- SubscriptOutOfBoundsSignal
- NonIntegerIndexSignal
- NotFoundSignal
- KeyNotFoundSignal
- ElementOutOfBoundsSignal
- InformationSignal
-
- AbortSignal <Signal> Signal raised by debugger, to abort a computation
- BUT, the debugger will only raise it if it is handled.
- By handling the abortSignal, you can control where the
- debuggers abort-function resumes execution in case of
- an error.
-
- ErrorRecursion <Boolean> controls behavior when recursive errors occur (i.e.
- an error while handling an error).
-
- Dependencies <Dictionary> keeps track of object dependencies
+ ErrorSignal <Signal> Signal raised for error/error: messages
+ also, parent of all other signals.
+
+ HaltSignal <Signal> Signal raised for halt/halt: messages
+
+ MessageNotUnderstoodSignal Signals raised for various error conditions
+ UserInterruptSignal
+ RecursionInterruptSignal
+ ExceptionInterruptSignal
+ SubscriptOutOfBoundsSignal
+ NonIntegerIndexSignal
+ NotFoundSignal
+ KeyNotFoundSignal
+ ElementOutOfBoundsSignal
+ InformationSignal
+ DeepCopyErrorSignal
+
+ AbortSignal <Signal> Signal raised by debugger, to abort a computation
+ BUT, the debugger will only raise it if it is handled.
+ By handling the abortSignal, you can control where the
+ debuggers abort-function resumes execution in case of
+ an error.
+
+ ErrorRecursion <Boolean> controls behavior when recursive errors occur (i.e.
+ an error while handling an error).
+
+ Dependencies <Dictionary> keeps track of object dependencies
"
! !
@@ -102,55 +105,73 @@
"called only once - initialize signals"
ErrorSignal isNil ifTrue:[
- ErrorSignal := (Signal new) mayProceed:true.
- ErrorSignal notifierString:'error encountered'.
-
- HaltSignal := (Signal new) mayProceed:true.
- HaltSignal notifierString:'halt encountered'.
-
- MessageNotUnderstoodSignal := (Signal new) mayProceed:true.
- MessageNotUnderstoodSignal notifierString:'message not understood'.
-
- "EXPERIMENTAL"
- PrivateMethodSignal := (Signal new) mayProceed:true.
- PrivateMethodSignal notifierString:'attempt to execute private method'.
-
- PrimitiveFailureSignal := (Signal new) mayProceed:true.
- PrimitiveFailureSignal notifierString:'primitive failed'.
-
- UserInterruptSignal := (Signal new) mayProceed:true.
- UserInterruptSignal notifierString:'user Interrupt'.
-
- RecursionInterruptSignal := (Signal new) mayProceed:false.
- RecursionInterruptSignal notifierString:'recursion limit reached'.
-
- ExceptionInterruptSignal := (Signal new) mayProceed:true.
- ExceptionInterruptSignal notifierString:'exception Interrupt'.
-
- SubscriptOutOfBoundsSignal := (Signal new) mayProceed:false.
- SubscriptOutOfBoundsSignal notifierString:'subscript out of bounds'.
-
- ElementOutOfBoundsSignal := (Signal new) mayProceed:false.
- ElementOutOfBoundsSignal notifierString:'element not appropriate or out of bounds'.
-
- NotFoundSignal := (Signal new) mayProceed:true.
- NotFoundSignal notifierString:'no such element'.
-
- KeyNotFoundSignal := (Signal new) mayProceed:true.
- KeyNotFoundSignal notifierString:'no such key'.
-
- NonIntegerIndexSignal := (Signal new) mayProceed:false.
- NonIntegerIndexSignal notifierString:'index must be integer'.
-
- InformationSignal := (Signal new) mayProceed:true.
- InformationSignal notifierString:'information'.
-
- AbortSignal := (Signal new) mayProceed:true.
- AbortSignal notifierString:'unhandled abort signal'.
-
- Dependencies isNil ifTrue:[
- Dependencies := WeakIdentityDictionary new.
- ]
+ ErrorSignal := (Signal new) mayProceed:true.
+ ErrorSignal nameClass:self message:#errorSignal.
+ ErrorSignal notifierString:'error encountered'.
+
+ HaltSignal := ErrorSignal newSignalMayProceed:true.
+ HaltSignal nameClass:self message:#haltSignal.
+ HaltSignal notifierString:'halt encountered'.
+
+ MessageNotUnderstoodSignal := ErrorSignal newSignalMayProceed:true.
+ MessageNotUnderstoodSignal nameClass:self message:#messageNotUnderstoodSignal.
+ MessageNotUnderstoodSignal notifierString:'message not understood'.
+
+ PrimitiveFailureSignal := ErrorSignal newSignalMayProceed:true.
+ PrimitiveFailureSignal nameClass:self message:#primitiveFailureSignal.
+ PrimitiveFailureSignal notifierString:'primitive failed'.
+
+ UserInterruptSignal := ErrorSignal newSignalMayProceed:true.
+ UserInterruptSignal nameClass:self message:#userInterruptSignal.
+ UserInterruptSignal notifierString:'user Interrupt'.
+
+ RecursionInterruptSignal := ErrorSignal newSignalMayProceed:false.
+ RecursionInterruptSignal nameClass:self message:#recursionInterruptSignal.
+ RecursionInterruptSignal notifierString:'recursion limit reached'.
+
+ ExceptionInterruptSignal := ErrorSignal newSignalMayProceed:true.
+ ExceptionInterruptSignal nameClass:self message:#exceptionInterruptSignal.
+ ExceptionInterruptSignal notifierString:'exception Interrupt'.
+
+ SubscriptOutOfBoundsSignal := ErrorSignal newSignalMayProceed:false.
+ SubscriptOutOfBoundsSignal nameClass:self message:#subscriptOutOfBoundsSignal.
+ SubscriptOutOfBoundsSignal notifierString:'subscript out of bounds'.
+
+ ElementOutOfBoundsSignal := ErrorSignal newSignalMayProceed:false.
+ ElementOutOfBoundsSignal nameClass:self message:#elementOutOfBoundsSignal.
+ ElementOutOfBoundsSignal notifierString:'element not appropriate or out of bounds'.
+
+ NotFoundSignal := ErrorSignal newSignalMayProceed:true.
+ NotFoundSignal nameClass:self message:#notFoundSignal.
+ NotFoundSignal notifierString:'no such element'.
+
+ KeyNotFoundSignal := ErrorSignal newSignalMayProceed:true.
+ KeyNotFoundSignal nameClass:self message:#keyNotFoundSignal.
+ KeyNotFoundSignal notifierString:'no such key'.
+
+ NonIntegerIndexSignal := ErrorSignal newSignalMayProceed:false.
+ NonIntegerIndexSignal nameClass:self message:#nonIntegerIndexSignal.
+ NonIntegerIndexSignal notifierString:'index must be integer'.
+
+ InformationSignal := ErrorSignal newSignalMayProceed:true.
+ InformationSignal nameClass:self message:#informationSignal.
+ InformationSignal notifierString:'information'.
+
+ DeepCopyErrorSignal := ErrorSignal newSignalMayProceed:true.
+ DeepCopyErrorSignal nameClass:self message:#deepCopyErrorSignal.
+ DeepCopyErrorSignal notifierString:'object cannot be deepCopy-ed'.
+
+ "
+ AbortSignal is not a child of ErrorSignal -
+ this would complicate abort from within a signal handler
+ "
+ AbortSignal := Signal new mayProceed:true.
+ AbortSignal nameClass:self message:#abortSignal.
+ AbortSignal notifierString:'unhandled abort signal'.
+
+ Dependencies isNil ifTrue:[
+ Dependencies := WeakIdentityDictionary new.
+ ]
]
"Object initialize"
@@ -246,6 +267,14 @@
^ InformationSignal
!
+deepCopyErrorSignal
+ "return the signal raised when a deepcopy is asked for
+ an object which cannot do this (for example, BlockClosures
+ or Contexts)."
+
+ ^ DeepCopyErrorSignal
+!
+
abortSignal
"return the signal used to abort user actions. This signal is only
raised if cought (by the debugger), and will lead way out of the
@@ -299,7 +328,7 @@
- the Collection-classes have been rewritten to not use it.)"
%{
if (__primBecome(self, anotherObject COMMA_CON))
- RETURN ( self );
+ RETURN ( self );
%}
.
self primitiveFailed
@@ -312,7 +341,7 @@
%{
if (__primBecomeNil(self COMMA_CON ))
- RETURN ( nil );
+ RETURN ( nil );
%}
.
self primitiveFailed
@@ -334,58 +363,58 @@
&& _isNonNilObject(otherClass)
&& (otherClass != UndefinedObject)
&& (otherClass != SmallInteger)) {
- ok = true;
+ ok = true;
} else {
- ok = false;
+ ok = false;
}
%}.
ok ifTrue:[
- ok := false.
- myClass := self class.
- myClass flags == otherClass flags ifTrue:[
- myClass instSize == otherClass instSize ifTrue:[
- "same instance layout and types: its ok to do it"
- ok := true.
- ] ifFalse:[
- myClass isPointers ifTrue:[
- myClass isVariable ifTrue:[
- ok := true
- ]
- ]
- ]
- ] ifFalse:[
- myClass isPointers ifTrue:[
- "if newClass is a variable class, with instSize <= my instsize,
- we can do it (effectively mapping additional instvars into the
- variable part) - usefulness is questionable, though"
-
- otherClass isPointers ifTrue:[
- otherClass isVariable ifTrue:[
- otherClass instSize <= (myClass instSize + self basicSize)
- ifTrue:[
- ok := true
- ]
- ] ifFalse:[
- otherClass instSize == (myClass instSize + self basicSize)
- ifTrue:[
- ok := true
- ]
- ]
- ] ifFalse:[
- "it does not make sense to convert pointers to bytes ..."
- ]
- ] ifFalse:[
- "does it make sense, to convert bits ?"
- "could allow byteArray->wordArray->longArray->floatArray->doubleArray here ..."
- ]
- ]
+ ok := false.
+ myClass := self class.
+ myClass flags == otherClass flags ifTrue:[
+ myClass instSize == otherClass instSize ifTrue:[
+ "same instance layout and types: its ok to do it"
+ ok := true.
+ ] ifFalse:[
+ myClass isPointers ifTrue:[
+ myClass isVariable ifTrue:[
+ ok := true
+ ]
+ ]
+ ]
+ ] ifFalse:[
+ myClass isPointers ifTrue:[
+ "if newClass is a variable class, with instSize <= my instsize,
+ we can do it (effectively mapping additional instvars into the
+ variable part) - usefulness is questionable, though"
+
+ otherClass isPointers ifTrue:[
+ otherClass isVariable ifTrue:[
+ otherClass instSize <= (myClass instSize + self basicSize)
+ ifTrue:[
+ ok := true
+ ]
+ ] ifFalse:[
+ otherClass instSize == (myClass instSize + self basicSize)
+ ifTrue:[
+ ok := true
+ ]
+ ]
+ ] ifFalse:[
+ "it does not make sense to convert pointers to bytes ..."
+ ]
+ ] ifFalse:[
+ "does it make sense, to convert bits ?"
+ "could allow byteArray->wordArray->longArray->floatArray->doubleArray here ..."
+ ]
+ ]
].
ok ifTrue:[
- "now, change the receivers class ..."
+ "now, change the receivers class ..."
%{
- _qClass(self) = otherClass;
- __STORE(self, otherClass);
- RETURN ( self );
+ _qClass(self) = otherClass;
+ __STORE(self, otherClass);
+ RETURN ( self );
%}.
].
self primitiveFailed
@@ -428,34 +457,34 @@
*/
myClass = _qClass(self);
nbytes = _qSize(self)
- - OHDR_SIZE
- - __OBJS2BYTES__(_intVal(_ClassInstPtr(myClass)->c_ninstvars));
+ - OHDR_SIZE
+ - __OBJS2BYTES__(_intVal(_ClassInstPtr(myClass)->c_ninstvars));
switch (_intVal(_ClassInstPtr(myClass)->c_flags) & ARRAYMASK) {
- case BYTEARRAY:
- RETURN ( _MKSMALLINT(nbytes / sizeof(char)) );
-
- case WORDARRAY:
- RETURN ( _MKSMALLINT(nbytes / sizeof(short)) );
-
- case LONGARRAY:
- RETURN ( _MKSMALLINT(nbytes / sizeof(long)) );
-
- case FLOATARRAY:
- RETURN ( _MKSMALLINT(nbytes / sizeof(float)) );
-
- case DOUBLEARRAY:
+ case BYTEARRAY:
+ RETURN ( _MKSMALLINT(nbytes / sizeof(char)) );
+
+ case WORDARRAY:
+ RETURN ( _MKSMALLINT(nbytes / sizeof(short)) );
+
+ case LONGARRAY:
+ RETURN ( _MKSMALLINT(nbytes / sizeof(long)) );
+
+ case FLOATARRAY:
+ RETURN ( _MKSMALLINT(nbytes / sizeof(float)) );
+
+ case DOUBLEARRAY:
#ifdef NEED_DOUBLE_ALIGN
- /*
- * care for filler
- */
- nbytes -= sizeof(FILLTYPE);
+ /*
+ * care for filler
+ */
+ nbytes -= sizeof(FILLTYPE);
#endif
- RETURN ( _MKSMALLINT(nbytes / sizeof(double)) );
-
- case WKPOINTERARRAY:
- case POINTERARRAY:
- RETURN ( _MKSMALLINT(__BYTES2OBJS__(nbytes)) );
+ RETURN ( _MKSMALLINT(nbytes / sizeof(double)) );
+
+ case WKPOINTERARRAY:
+ case POINTERARRAY:
+ RETURN ( _MKSMALLINT(__BYTES2OBJS__(nbytes)) );
}
%}
.
@@ -615,11 +644,11 @@
isMemberOf:aClass
"return true, if the receiver is an instance of aClass, false otherwise.
Advice: use of this to check objects for certain attributes/protocoll should
- be avoided; it limits the reusability of your classes by limiting use
- to instances of a certain class.
- Use check-methods to check an object for a certain attributes/protocol
- (such as respondsTo: or isNumber);
- or check via #respondsTo: if a it understands your message."
+ be avoided; it limits the reusability of your classes by limiting use
+ to instances of a certain class.
+ Use check-methods to check an object for a certain attributes/protocol
+ (such as respondsTo: or isNumber);
+ or check via #respondsTo: if a it understands your message."
^ (self class) == aClass
!
@@ -628,21 +657,21 @@
"return true, if the receiver is an instance of aClass or one of its
subclasses, false otherwise.
Advice: use of this to check objects for certain attributes/protocoll should
- be avoided; it limits the reusability of your classes by limiting use
- to instances of certain classes and fences you into a specific inheritance
- hierarchy.
- Use check-methods to check an object for a certain attributes/protocol
- (such as isXXXX, respondsTo: or isNumber)"
+ be avoided; it limits the reusability of your classes by limiting use
+ to instances of certain classes and fences you into a specific inheritance
+ hierarchy.
+ Use check-methods to check an object for a certain attributes/protocol
+ (such as isXXXX, respondsTo: or isNumber)"
%{ /* NOCONTEXT */
register OBJ thisClass;
thisClass = _Class(self);
while (thisClass != nil) {
- if (thisClass == aClass) {
- RETURN ( true );
- }
- thisClass = _ClassInstPtr(thisClass)->c_superclass;
+ if (thisClass == aClass) {
+ RETURN ( true );
+ }
+ thisClass = _ClassInstPtr(thisClass)->c_superclass;
}
%}
.
@@ -678,7 +707,7 @@
extern OBJ lookup();
if (lookup(_Class(self), aSelector) == nil) {
- RETURN ( false );
+ RETURN ( false );
}
RETURN ( true );
%}
@@ -714,15 +743,15 @@
"check the instance variables"
numInst := myClass instSize.
1 to:numInst do:[:i |
- ((self instVarAt:i) == anObject) ifTrue:[^ true]
+ ((self instVarAt:i) == anObject) ifTrue:[^ true]
].
"check the indexed variables"
myClass isVariable ifTrue:[
- numInst := myClass basicSize.
- 1 to:numInst do:[:i |
- ((self basicAt:i) == anObject) ifTrue:[^ true]
- ]
+ numInst := myClass basicSize.
+ 1 to:numInst do:[:i |
+ ((self basicAt:i) == anObject) ifTrue:[^ true]
+ ]
].
^ false
!
@@ -742,10 +771,36 @@
^ Association key:self value:anObject
! !
+!Object methodsFor:'evaluation'!
+
+value
+ "this allows every object to be used where blocks are typically used.
+ Time will show, if this is a good idea or leads to sloppy programming
+ style ... (idea borrowed from the Self language).
+ WARNING: dont 'optimize' away ifXXX: blocks - the compilers will
+ only generate inline code for the if, if the argument(s) are blocks.
+ It will work, but run slower instead."
+
+ ^ self
+
+ "
+ #(1 2 3 4) indexOf:5 ifAbsent:0
+ "
+! !
+
!Object methodsFor:'copying'!
copy
- "return a copy of the receiver - defaults to shallowcopy here"
+ "return a copy of the receiver - defaults to shallowcopy here.
+ Notice, that copy does not copy dependents."
+
+ ^ self shallowCopy postCopyFrom:self
+!
+
+shallowCopyForFinalization
+ "this is used to aquire a copy to be used for finalization -
+ (the copy will get a dispose-notification; see the documentation in the Registry class)
+ This method can be redefined for more efficient copying - especially for large objects."
^ self shallowCopy
!
@@ -759,41 +814,58 @@
myClass := self class.
myClass isVariable ifTrue:[
- sz := self basicSize.
- aCopy := myClass basicNew:sz.
-
- "copy the indexed variables"
- 1 to:sz do:[:i |
- aCopy basicAt:i put:(self basicAt:i)
- ]
+ sz := self basicSize.
+ aCopy := myClass basicNew:sz.
+
+ "copy the indexed variables"
+ 1 to:sz do:[:i |
+ aCopy basicAt:i put:(self basicAt:i)
+ ]
] ifFalse:[
- aCopy := myClass basicNew
+ aCopy := myClass basicNew
].
"copy the instance variables"
sz := myClass instSize.
1 to:sz do:[:i |
- aCopy instVarAt:i put:(self instVarAt:i)
+ aCopy instVarAt:i put:(self instVarAt:i)
].
^ aCopy
!
+postCopy
+ "this is for compatibility with ST-80 code, which uses postCopy for
+ cleanup after copying, while ST/X passes the original in postCopyFrom:
+ (see there)"
+
+ ^ self
+!
+
+postCopyFrom:original
+ "sent to a freshly deep-copied object to give it a chance to adjust things.
+ (a font could flush its device-handle for example).
+ Notice, that for Sets/Dicts etc. a rehash is not needed, since the deepCopy
+ will have the same hash key as the receiver (as long as ST/X provides the
+ setHash: functionality)."
+
+ "for ST-80 compatibility, we try postCopy here ..."
+ ^ self postCopy
+!
+
deepCopy
"return a copy of the object with all subobjects also copied.
This method DOES handle cycles/self-refs; however the receivers
- class is not copied (to avoid the 'total' copy)."
+ class is not copied (to avoid the 'total' copy).
+ Notice, that copy does not copy dependents."
^ self deepCopyUsing:(IdentityDictionary new)
!
-finalizeCopyFrom:original
- "sent to a freshly deep-copied object to give it a chance to adjust things.
- (a font could flush its device-handle for example). Notice, that for Sets/Dicts
- etc. a rehash is not needed, since the deepCopy will have the same hash key as the
- receiver (as long as ST/X provides the setHash: functionality)."
-
- ^ self
+deepCopyError
+ "raise a signal, that deepCopy is not allowed for this object"
+
+ ^ DeepCopyErrorSignal raise
!
deepCopyUsing:aDictionary
@@ -808,52 +880,51 @@
myClass := self class.
myClass isVariable ifTrue:[
- sz := self basicSize.
- aCopy := myClass basicNew:sz.
+ sz := self basicSize.
+ aCopy := myClass basicNew:sz.
] ifFalse:[
- sz := 0.
- aCopy := myClass basicNew
+ sz := 0.
+ aCopy := myClass basicNew
].
aCopy setHashFrom:self.
aDictionary at:self put:aCopy.
sz ~~ 0 ifTrue:[
- self class isBits ifTrue:[
- "block-copy indexed instvars"
- aCopy replaceFrom:1 to:sz with:self startingAt:1
- ] ifFalse:[
- "individual deep copy the indexed variables"
- 1 to:sz do:[:i |
- iOrig := self basicAt:i.
- iOrig notNil ifTrue:[
- (aDictionary includesKey:iOrig) ifTrue:[
- iCopy := aDictionary at:iOrig
- ] ifFalse:[
- iCopy := iOrig deepCopyUsing:aDictionary.
- ].
- aCopy basicAt:i put:iCopy
- ]
- ]
- ]
+ self class isBits ifTrue:[
+ "block-copy indexed instvars"
+ aCopy replaceFrom:1 to:sz with:self startingAt:1
+ ] ifFalse:[
+ "individual deep copy the indexed variables"
+ 1 to:sz do:[:i |
+ iOrig := self basicAt:i.
+ iOrig notNil ifTrue:[
+ (aDictionary includesKey:iOrig) ifTrue:[
+ iCopy := aDictionary at:iOrig
+ ] ifFalse:[
+ iCopy := iOrig deepCopyUsing:aDictionary.
+ ].
+ aCopy basicAt:i put:iCopy
+ ]
+ ]
+ ]
].
"copy the instance variables"
sz := myClass instSize.
sz ~~ 0 ifTrue:[
- 1 to:sz do:[:i |
- iOrig := self instVarAt:i.
- iOrig notNil ifTrue:[
- (aDictionary includesKey:iOrig) ifTrue:[
- iCopy := aDictionary at:iOrig
- ] ifFalse:[
- iCopy := iOrig deepCopyUsing:aDictionary.
- ].
- aCopy instVarAt:i put:iCopy
- ]
- ].
+ 1 to:sz do:[:i |
+ iOrig := self instVarAt:i.
+ iOrig notNil ifTrue:[
+ (aDictionary includesKey:iOrig) ifTrue:[
+ iCopy := aDictionary at:iOrig
+ ] ifFalse:[
+ iCopy := iOrig deepCopyUsing:aDictionary.
+ ].
+ aCopy instVarAt:i put:iCopy
+ ]
+ ].
].
- aCopy finalizeCopyFrom:self.
^ aCopy
!
@@ -872,21 +943,21 @@
myClass := self class.
myClass isVariable ifTrue:[
- sz := self basicSize.
- aCopy := myClass basicNew:sz.
-
- "copy the indexed variables"
- 1 to:sz do:[:i |
- aCopy basicAt:i put:((self basicAt:i) simpleDeepCopy)
- ]
+ sz := self basicSize.
+ aCopy := myClass basicNew:sz.
+
+ "copy the indexed variables"
+ 1 to:sz do:[:i |
+ aCopy basicAt:i put:((self basicAt:i) simpleDeepCopy)
+ ]
] ifFalse:[
- aCopy := myClass basicNew
+ aCopy := myClass basicNew
].
"copy the instance variables"
sz := myClass instSize.
1 to:sz do:[:i |
- aCopy instVarAt:i put:((self instVarAt:i) simpleDeepCopy)
+ aCopy instVarAt:i put:((self instVarAt:i) simpleDeepCopy)
].
^ aCopy
@@ -911,9 +982,9 @@
REGISTER unsigned h;
if (_isNonNilObject(self) && _isNonNilObject(anObject)) {
- h = _GET_HASH(anObject);
- _SET_HASH(self, h);
- RETURN (self);
+ h = _GET_HASH(anObject);
+ _SET_HASH(self, h);
+ RETURN (self);
}
%}
.
@@ -993,32 +1064,32 @@
OBJ cls;
if (_isNonNilObject(self)) {
- v1 = _GET_HASH(self);
- if (v1 == 0) {
- v1 = nextHash++;
- if (v1 == 0)
- v1 = nextHash++;
- _SET_HASH(self, v1);
- }
+ v1 = _GET_HASH(self);
+ if (v1 == 0) {
+ v1 = nextHash++;
+ if (v1 == 0)
+ v1 = nextHash++;
+ _SET_HASH(self, v1);
+ }
#ifdef NOTDEF
- /*
- * this is no good - a class becoming another one or
- * if an object changes its class, hashkey would change.
- * changing hashkeys has bad effects on IdentityDictionary and
- * IdentitySet (and others as well).
- */
- cls = _qClass(self);
- v2 = _GET_HASH(cls);
- if (v2 == 0) {
- v2 = nextHash++;
- if (v2 == 0)
- v2 = nextHash++;
- _SET_HASH(cls, v2);
- }
- RETURN ( _MKSMALLINT((v2<<12) | v1) );
+ /*
+ * this is no good - a class becoming another one or
+ * if an object changes its class, hashkey would change.
+ * changing hashkeys has bad effects on IdentityDictionary and
+ * IdentitySet (and others as well).
+ */
+ cls = _qClass(self);
+ v2 = _GET_HASH(cls);
+ if (v2 == 0) {
+ v2 = nextHash++;
+ if (v2 == 0)
+ v2 = nextHash++;
+ _SET_HASH(cls, v2);
+ }
+ RETURN ( _MKSMALLINT((v2<<12) | v1) );
#endif
- RETURN ( _MKSMALLINT(v1 << 8) );
+ RETURN ( _MKSMALLINT(v1 << 8) );
}
%}
.
@@ -1032,7 +1103,8 @@
such as corrupted class, corrupted method/selector array
etc. (for example, if you set an objects class to a small-
integer, nil etc).
- Its not guaranteed, that the system is in a working condition ...."
+ Its not guaranteed, that the system is in a working condition once
+ this error occurred ...."
^ self error:msg
!
@@ -1099,16 +1171,16 @@
special case - since SIGPIPE has an ST-signal associated
"
(signalNumber == 13) ifTrue:[
- "SIGPIPE - write on a pipe with no one to read"
-
- ^ PipeStream brokenPipeSignal raise.
+ "SIGPIPE - write on a pipe with no one to read"
+
+ ^ PipeStream brokenPipeSignal raise.
].
"if there has been an ST-signal installed, use it ..."
sig := OperatingSystem operatingSystemSignal:signalNumber.
sig notNil ifTrue:[
- ^ sig raise
+ ^ sig raise
].
"
@@ -1128,21 +1200,21 @@
another signal - to avoid frustration, better not offer this option.
"
ignorable := (signalNumber ~~ OperatingSystem sigBUS)
- and:[signalNumber ~~ OperatingSystem sigILL
- and:[signalNumber ~~ OperatingSystem sigSEGV]].
+ and:[signalNumber ~~ OperatingSystem sigILL
+ and:[signalNumber ~~ OperatingSystem sigSEGV]].
ignorable ifFalse:[
- here isRecursive ifTrue:[
- 'fatal: signal ' errorPrint. signalNumber errorPrintNL.
- MiniDebugger enterWithMessage:'recursive signal'.
- ^ self
- ].
- "
- a hard signal - go into debugger immediately
- "
- Debugger enter:here withMessage:('Signal ', name).
- badContext return.
- ^ nil.
+ here isRecursive ifTrue:[
+ 'fatal: signal ' errorPrint. signalNumber errorPrintNL.
+ MiniDebugger enterWithMessage:'recursive signal'.
+ ^ self
+ ].
+ "
+ a hard signal - go into debugger immediately
+ "
+ Debugger enter:here withMessage:('Signal ', name).
+ badContext return.
+ ^ nil.
].
"
@@ -1150,42 +1222,42 @@
otherwise display stays locked
"
ActiveGrab notNil ifTrue:[
- Display ungrabPointer.
- ActiveGrab := nil
+ Display ungrabPointer.
+ ActiveGrab := nil
].
OptionBox isNil ifTrue:[
- "
- a system without GUI ...
- go into minidebugger (if there is one)
- "
- MiniDebugger isNil ifTrue:[
- "
- a system without debugging facilities
- (i.e. a standalone system)
- output a message and exit.
- "
- ('exit due to Signal ' , name) errorPrintNL.
- Smalltalk exit.
- ].
- MiniDebugger enterWithMessage:'Signal cought (' , name, ')'.
- ^ self
+ "
+ a system without GUI ...
+ go into minidebugger (if there is one)
+ "
+ MiniDebugger isNil ifTrue:[
+ "
+ a system without debugging facilities
+ (i.e. a standalone system)
+ output a message and exit.
+ "
+ ('exit due to Signal ' , name) errorPrintNL.
+ Smalltalk exit.
+ ].
+ MiniDebugger enterWithMessage:'Signal cought (' , name, ')'.
+ ^ self
].
box := OptionBox
- title:'Signal cought (' , name, ')'
- numberOfOptions:(ignorable ifTrue:[5] ifFalse:[4]).
+ title:'Signal cought (' , name, ')'
+ numberOfOptions:(ignorable ifTrue:[5] ifFalse:[4]).
titles := #('return' 'debug' 'dump' 'exit').
actions := Array
- with:[badContext return]
- with:[Debugger enter:here withMessage:('Signal ', name). ^nil]
- with:[Smalltalk fatalAbort]
- with:[Smalltalk exit].
+ with:[badContext return]
+ with:[Debugger enter:here withMessage:('Signal ', name). ^nil]
+ with:[Smalltalk fatalAbort]
+ with:[Smalltalk exit].
ignorable ifTrue:[
- titles := #('ignore') , titles.
- actions := (Array with:[^ nil]) , actions.
+ titles := #('ignore') , titles.
+ actions := (Array with:[^ nil]) , actions.
].
box buttonTitles:titles.
box actions:actions.
@@ -1199,7 +1271,7 @@
could be cought and the stackLimit increased in the handler."
thisContext isRecursive ifFalse:[
- ^ RecursionInterruptSignal raise
+ ^ RecursionInterruptSignal raise
]
!
@@ -1218,6 +1290,13 @@
^ SubscriptOutOfBoundsSignal raise
!
+subscriptBoundsError:anIndex
+ "report error that anIndex is out of bounds.
+ (when accessing indexable collections)"
+
+ ^ SubscriptOutOfBoundsSignal raiseRequestWith:anIndex
+!
+
indexNotInteger
"report error that index is not an Integer.
(when accessing collections indexed by an integer key)"
@@ -1281,7 +1360,7 @@
value assigned"
^ self error:'bad assign of ' , self printString ,
- ' (' , self class name , ') to integer-typed variable'
+ ' (' , self class name , ') to integer-typed variable'
!
typeCheckError
@@ -1289,7 +1368,7 @@
value assigned"
^ self error:'bad assign of ' , self printString ,
- ' (' , self class name , ') to typed variable'
+ ' (' , self class name , ') to typed variable'
!
primitiveFailed
@@ -1361,12 +1440,12 @@
|sel errorString|
aMessage selector isNil ifTrue:[
- "happens when things go mad, or a method has been
- called by valueWithReceiver: with a wrong receiver"
-
- sel := '(nil)'
+ "happens when things go mad, or a method has been
+ called by valueWithReceiver: with a wrong receiver"
+
+ sel := '(nil)'
] ifFalse:[
- sel := aMessage selector
+ sel := aMessage selector
].
errorString := 'Message not understood: ' , sel.
@@ -1374,46 +1453,44 @@
this only happens, when YOU play around with my classvars ...
"
MessageNotUnderstoodSignal isNil ifTrue:[
- ^ self enterDebuggerWith:nil
- message:'oops - MessageNotUnderstoodSignal is gone'.
+ ^ self enterDebuggerWith:nil
+ message:'oops - MessageNotUnderstoodSignal is gone'.
].
^ MessageNotUnderstoodSignal
- raiseRequestWith:aMessage
- errorString:errorString
+ raiseRequestWith:aMessage
+ errorString:errorString
!
-checkForRecursiveError
- "helper for all error-methods; catch error while in Debugger.
- If Debugger is DebugView, try switching to MiniDebugger (as
- a last chance) otherwise abort.
- There should not be an error in the debugger, this will only
- happen if some classes have been changed badly."
+appropriateDebugger:aMessage
+ "return an appropriate debugger to use.
+ If there is already a debugger active on the stack, and it is
+ the DebugView, return MiniDebugger (as a last chance) otherwise abort."
|context|
context := thisContext.
context := context sender.
[context notNil] whileTrue:[
- ((context receiver class == Debugger)
- and:[context selector == #enterWithMessage:]) ifTrue:[
- "we are already in some Debugger"
- (Debugger == MiniDebugger) ifTrue:[
- "we are in the MiniDebugger"
- ErrorRecursion ifFalse:[
- Smalltalk fatalAbort:'recursive error ...'
- ]
- ].
- MiniDebugger isNil ifTrue:[
- Smalltalk fatalAbort:'no debugger'
- ].
-
- "ok, an error occured while in the graphical debugger;
- lets try MiniDebugger"
- ^ MiniDebugger
- ].
- context := context sender
+ ((context receiver class == Debugger)
+ and:[context selector == aMessage]) ifTrue:[
+ "we are already in some Debugger"
+ (Debugger == MiniDebugger) ifTrue:[
+ "we are already in the MiniDebugger"
+ ErrorRecursion ifFalse:[
+ Smalltalk fatalAbort:'recursive error ...'
+ ]
+ ].
+ MiniDebugger isNil ifTrue:[
+ Smalltalk fatalAbort:'no debugger'
+ ].
+
+ "ok, an error occured while in the graphical debugger;
+ lets try MiniDebugger"
+ ^ MiniDebugger
+ ].
+ context := context sender
].
- "not within Debugger - go there"
+ "not within Debugger - no problem"
^ Debugger
!
@@ -1426,13 +1503,13 @@
if there is no debugger, exit smalltalk
"
Debugger isNil ifTrue:[
- 'error: ' errorPrint. aString errorPrintNL.
- Smalltalk fatalAbort:'no Debugger defined'
+ 'error: ' errorPrint. aString errorPrintNL.
+ Smalltalk fatalAbort:'no Debugger defined'
].
"
find an appropriate debugger to use
"
- debugger := self checkForRecursiveError.
+ debugger := self appropriateDebugger:#enterWithMessage.
^ debugger enterWithMessage:aString.
! !
@@ -1441,15 +1518,15 @@
notify:aString
"launch a Notifier, telling user something"
- Notifier isNil ifTrue:[
- "
- in systems without GUI, simply show
- the message on the Transcript.
- "
- Transcript showCr:aString.
- ^ self
+ DialogView isNil ifTrue:[
+ "
+ on systems without GUI, simply show
+ the message on the Transcript.
+ "
+ Transcript showCr:aString.
+ ^ self
].
- (Notifier new title:aString) showAtPointer
+ DialogView information:aString
"
nil notify:'hello there'
@@ -1460,15 +1537,7 @@
information:aString
"launch an InfoBox, telling user something"
- InfoBox isNil ifTrue:[
- "
- on systems without GUI, simply show
- the message on the Transcript.
- "
- Transcript showCr:aString.
- ^ self
- ].
- (InfoBox new title:aString) showAtPointer
+ self notify:aString
"
nil information:'hello there'
@@ -1479,15 +1548,15 @@
warn:aString
"launch a WarningBox, telling user something"
- WarningBox isNil ifTrue:[
- "
- on systems without GUI, simply show
- the message on the Transcript.
- "
- Transcript showCr:aString.
- ^ self
+ DialogView isNil ifTrue:[
+ "
+ on systems without GUI, simply show
+ the message on the Transcript.
+ "
+ Transcript showCr:aString.
+ ^ self
].
- (WarningBox new title:aString) showAtPointer
+ DialogView warn:aString
"
nil warn:'hello there'
@@ -1499,21 +1568,16 @@
"launch a confirmer, which allows user to enter yes or no.
return true for yes, false for no"
- |box|
-
- YesNoBox isNil ifTrue:[
- "
- on systems without GUI, output a message
- and return true (as if yes was answered)
- Q: should we ask user by reading Stdin ?
- "
- Transcript showCr:aString.
- ^ true
+ DialogView isNil ifTrue:[
+ "
+ on systems without GUI, output a message
+ and return true (as if yes was answered)
+ Q: should we ask user by reading Stdin ?
+ "
+ Transcript showCr:aString.
+ ^ true
].
- box := YesNoBox new.
- box title:aString.
- box yesAction:[^ true] noAction:[^ false].
- box showAtPointer
+ ^ DialogView confirm:aString
"
nil confirm:'hello'
@@ -1526,12 +1590,12 @@
this method should NOT be redefined in subclasses."
Inspector isNil ifTrue:[
- "
- for systems without GUI
- "
- Transcript showCr:'no Inspector'
+ "
+ for systems without GUI
+ "
+ Transcript showCr:'no Inspector'
] ifFalse:[
- Inspector openOn:self
+ Inspector openOn:self
]
!
@@ -1576,76 +1640,76 @@
* and SmallInteger
*/
if (_isSmallInteger(index)) {
- myClass = _qClass(self);
- indx = _intVal(index) - 1;
- ninstvars = _intVal(_ClassInstPtr(myClass)->c_ninstvars);
- nInstBytes = OHDR_SIZE + __OBJS2BYTES__(ninstvars);
- nbytes = _qSize(self) - nInstBytes;
- pFirst = (char *)(_InstPtr(self)) + nInstBytes;
-
- switch (_intVal(_ClassInstPtr(myClass)->c_flags) & ARRAYMASK) {
- case BYTEARRAY:
- if ((indx >= 0) && (indx < (nbytes / sizeof(char)))) {
- cp = (unsigned char *)pFirst + indx;
- RETURN ( _MKSMALLINT(*cp & 0xFF) );
- }
- break;
-
- case WORDARRAY:
- if ((indx >= 0) && (indx < (nbytes / sizeof(short)))) {
- sp = (unsigned short *)pFirst + indx;
- RETURN ( _MKSMALLINT(*sp & 0xFFFF) );
- }
- break;
-
- case LONGARRAY:
- if ((indx >= 0) && (indx < (nbytes / sizeof(long)))) {
- lp = (long *)pFirst + indx;
- if ((*lp >= _MIN_INT) && (*lp <= _MAX_INT))
- RETURN ( _MKSMALLINT(*lp) );
- RETURN ( _makeLarge(*lp) );
- }
- break;
-
- case FLOATARRAY:
- if ((indx >= 0) && (indx < (nbytes / sizeof(float)))) {
- float *fp;
-
- fp = (float *)pFirst + indx;
- RETURN ( _MKFLOAT((double)(*fp)) COMMA_CON );
- }
- break;
-
- case DOUBLEARRAY:
- if ((indx >= 0) && (indx < (nbytes / sizeof(double)))) {
- double *dp;
+ myClass = _qClass(self);
+ indx = _intVal(index) - 1;
+ ninstvars = _intVal(_ClassInstPtr(myClass)->c_ninstvars);
+ nInstBytes = OHDR_SIZE + __OBJS2BYTES__(ninstvars);
+ nbytes = _qSize(self) - nInstBytes;
+ pFirst = (char *)(_InstPtr(self)) + nInstBytes;
+
+ switch (_intVal(_ClassInstPtr(myClass)->c_flags) & ARRAYMASK) {
+ case BYTEARRAY:
+ if ((indx >= 0) && (indx < (nbytes / sizeof(char)))) {
+ cp = (unsigned char *)pFirst + indx;
+ RETURN ( _MKSMALLINT(*cp & 0xFF) );
+ }
+ break;
+
+ case WORDARRAY:
+ if ((indx >= 0) && (indx < (nbytes / sizeof(short)))) {
+ sp = (unsigned short *)pFirst + indx;
+ RETURN ( _MKSMALLINT(*sp & 0xFFFF) );
+ }
+ break;
+
+ case LONGARRAY:
+ if ((indx >= 0) && (indx < (nbytes / sizeof(long)))) {
+ lp = (long *)pFirst + indx;
+ if ((*lp >= _MIN_INT) && (*lp <= _MAX_INT))
+ RETURN ( _MKSMALLINT(*lp) );
+ RETURN ( _makeLarge(*lp) );
+ }
+ break;
+
+ case FLOATARRAY:
+ if ((indx >= 0) && (indx < (nbytes / sizeof(float)))) {
+ float *fp;
+
+ fp = (float *)pFirst + indx;
+ RETURN ( _MKFLOAT((double)(*fp)) COMMA_CON );
+ }
+ break;
+
+ case DOUBLEARRAY:
+ if ((indx >= 0) && (indx < (nbytes / sizeof(double)))) {
+ double *dp;
#ifdef NEED_DOUBLE_ALIGN
- /*
- * care for filler
- */
- pFirst += sizeof(FILLTYPE);
+ /*
+ * care for filler
+ */
+ pFirst += sizeof(FILLTYPE);
#endif
- dp = (double *)pFirst + indx;
- RETURN ( _MKFLOAT(*dp) COMMA_CON );
- }
- break;
-
- case WKPOINTERARRAY:
- case POINTERARRAY:
- if ((indx >= 0) && (indx < (__BYTES2OBJS__(nbytes)))) {
- op = (OBJ *)pFirst + indx;
- RETURN ( *op );
- }
- break;
- }
+ dp = (double *)pFirst + indx;
+ RETURN ( _MKFLOAT(*dp) COMMA_CON );
+ }
+ break;
+
+ case WKPOINTERARRAY:
+ case POINTERARRAY:
+ if ((indx >= 0) && (indx < (__BYTES2OBJS__(nbytes)))) {
+ op = (OBJ *)pFirst + indx;
+ RETURN ( *op );
+ }
+ break;
+ }
}
%}
.
index isInteger ifFalse:[
- ^ self indexNotInteger
+ ^ self indexNotInteger
].
- ^ self subscriptBoundsError
+ ^ self subscriptBoundsError:index
!
at:index put:anObject
@@ -1677,126 +1741,141 @@
and SmallInteger */
if (_isSmallInteger(index)) {
- indx = _intVal(index) - 1;
- myClass = _qClass(self);
- ninstvars = _intVal(_ClassInstPtr(myClass)->c_ninstvars);
- nInstBytes = OHDR_SIZE + __OBJS2BYTES__(ninstvars);
- nbytes = _qSize(self) - nInstBytes;
- pFirst = (char *)(_InstPtr(self)) + nInstBytes;
-
- switch (_intVal(_ClassInstPtr(myClass)->c_flags) & ARRAYMASK) {
- case BYTEARRAY:
- if (_isSmallInteger(anObject)) {
- val = _intVal(anObject);
- if ((val >= 0) && (val <= 255)) {
- if ((indx >= 0) && (indx < (nbytes / sizeof(char)))) {
- cp = pFirst + indx;
- *cp = val;
- RETURN ( anObject );
- }
- }
- }
- break;
-
- case WORDARRAY:
- if (_isSmallInteger(anObject)) {
- val = _intVal(anObject);
- if ((val >= 0) && (val <= 0xFFFF)) {
- if ((indx >= 0) && (indx < (nbytes / sizeof(short)))) {
- sp = (short *)pFirst + indx;
- *sp = val;
- RETURN ( anObject );
- }
- }
- }
- break;
-
- case LONGARRAY:
- if (_isSmallInteger(anObject)) {
- if ((indx >= 0) && (indx < (nbytes / sizeof(long)))) {
- lp = (long *)pFirst + indx;
- *lp = _intVal(anObject);
- RETURN ( anObject );
- }
- }
- /* XXX
- * XXX must add possibility to put in a large number here
- * XXX
- */
- break;
-
- case FLOATARRAY:
- if ((indx >= 0) && (indx < (nbytes / sizeof(float)))) {
- float *fp;
-
- fp = (float *)pFirst + indx;
- if (__isFloat(anObject)) {
- *fp = _floatVal(anObject);
- RETURN ( anObject );
- } else if (_isSmallInteger(anObject)) {
- *fp = (float) _intVal(anObject);
- RETURN ( anObject );
- }
- }
-
- break;
-
- case DOUBLEARRAY:
- if ((indx >= 0) && (indx < (nbytes / sizeof(double)))) {
- double *dp;
+ indx = _intVal(index) - 1;
+ myClass = _qClass(self);
+ ninstvars = _intVal(_ClassInstPtr(myClass)->c_ninstvars);
+ nInstBytes = OHDR_SIZE + __OBJS2BYTES__(ninstvars);
+ nbytes = _qSize(self) - nInstBytes;
+ pFirst = (char *)(_InstPtr(self)) + nInstBytes;
+
+ switch (_intVal(_ClassInstPtr(myClass)->c_flags) & ARRAYMASK) {
+ case BYTEARRAY:
+ if (_isSmallInteger(anObject)) {
+ val = _intVal(anObject);
+ if ((val >= 0) && (val <= 255)) {
+ if ((indx >= 0) && (indx < (nbytes / sizeof(char)))) {
+ cp = pFirst + indx;
+ *cp = val;
+ RETURN ( anObject );
+ }
+ }
+ }
+ break;
+
+ case WORDARRAY:
+ if (_isSmallInteger(anObject)) {
+ val = _intVal(anObject);
+ if ((val >= 0) && (val <= 0xFFFF)) {
+ if ((indx >= 0) && (indx < (nbytes / sizeof(short)))) {
+ sp = (short *)pFirst + indx;
+ *sp = val;
+ RETURN ( anObject );
+ }
+ }
+ }
+ break;
+
+ case LONGARRAY:
+ if (_isSmallInteger(anObject)) {
+ if ((indx >= 0) && (indx < (nbytes / sizeof(long)))) {
+ lp = (long *)pFirst + indx;
+ *lp = _intVal(anObject);
+ RETURN ( anObject );
+ }
+ }
+ /* XXX
+ * XXX must add possibility to put in a large number here
+ * XXX
+ */
+ break;
+
+ case FLOATARRAY:
+ if ((indx >= 0) && (indx < (nbytes / sizeof(float)))) {
+ float *fp;
+
+ fp = (float *)pFirst + indx;
+ if (__isFloat(anObject)) {
+ *fp = _floatVal(anObject);
+ RETURN ( anObject );
+ } else if (_isSmallInteger(anObject)) {
+ *fp = (float) _intVal(anObject);
+ RETURN ( anObject );
+ }
+ }
+
+ break;
+
+ case DOUBLEARRAY:
+ if ((indx >= 0) && (indx < (nbytes / sizeof(double)))) {
+ double *dp;
#ifdef NEED_DOUBLE_ALIGN
- /*
- * care for filler
- */
- pFirst += sizeof(FILLTYPE);
+ /*
+ * care for filler
+ */
+ pFirst += sizeof(FILLTYPE);
#endif
- dp = (double *)pFirst + indx;
- if (__isFloat(anObject)) {
- *dp = _floatVal(anObject);
- RETURN ( anObject );
- } else if (_isSmallInteger(anObject)) {
- *dp = (double) _intVal(anObject);
- RETURN ( anObject );
- }
- }
- break;
-
- case WKPOINTERARRAY:
- case POINTERARRAY:
- if ((indx >= 0) && (indx < (__BYTES2OBJS__(nbytes)))) {
- op = (OBJ *)pFirst + indx;
- *op = anObject;
- __STORE(self, anObject);
- RETURN ( anObject );
- }
- break;
-
- default:
- break;
- }
+ dp = (double *)pFirst + indx;
+ if (__isFloat(anObject)) {
+ *dp = _floatVal(anObject);
+ RETURN ( anObject );
+ } else if (_isSmallInteger(anObject)) {
+ *dp = (double) _intVal(anObject);
+ RETURN ( anObject );
+ }
+ }
+ break;
+
+ case WKPOINTERARRAY:
+ case POINTERARRAY:
+ if ((indx >= 0) && (indx < (__BYTES2OBJS__(nbytes)))) {
+ op = (OBJ *)pFirst + indx;
+ *op = anObject;
+ __STORE(self, anObject);
+ RETURN ( anObject );
+ }
+ break;
+
+ default:
+ break;
+ }
}
%}
.
index isInteger ifFalse:[
- ^ self indexNotInteger
+ "
+ the index should be an integer number
+ "
+ ^ self indexNotInteger
].
(index between:1 and:self size) ifFalse:[
- ^ self subscriptBoundsError
+ "
+ the index is less than 1 or greater than the size of the
+ recevier collection
+ "
+ ^ self subscriptBoundsError:index
].
(self class isFloats) ifTrue:[
- anObject isNumber ifTrue:[
- ^ self basicAt:index put:(anObject asFloat)
- ]
+ anObject isNumber ifTrue:[
+ ^ self basicAt:index put:(anObject asFloat)
+ ]
].
(self class isDoubles) ifTrue:[
- anObject isNumber ifTrue:[
- ^ self basicAt:index put:(anObject asFloat)
- ]
+ anObject isNumber ifTrue:[
+ ^ self basicAt:index put:(anObject asFloat)
+ ]
].
anObject isInteger ifFalse:[
- ^ self elementNotInteger
+ "
+ the object to put into the recevier collection
+ should be an integer number
+ "
+ ^ self elementNotInteger
].
+ "
+ the object to put into the recevier collection
+ is not an instance of the expected element class
+ "
^ self elementBoundsError
!
@@ -1811,19 +1890,19 @@
int idx, ninstvars;
if (_isSmallInteger(index)) {
- myClass = _Class(self);
- ninstvars = _intVal(_ClassInstPtr(myClass)->c_ninstvars);
- idx = _intVal(index) - 1;
- if ((idx >= 0) && (idx < ninstvars)) {
- RETURN ( _InstPtr(self)->i_instvars[idx] );
- }
+ myClass = _Class(self);
+ ninstvars = _intVal(_ClassInstPtr(myClass)->c_ninstvars);
+ idx = _intVal(index) - 1;
+ if ((idx >= 0) && (idx < ninstvars)) {
+ RETURN ( _InstPtr(self)->i_instvars[idx] );
+ }
}
%}
.
index isInteger ifFalse:[
- ^ self indexNotInteger
+ ^ self indexNotInteger
].
- ^ self subscriptBoundsError
+ ^ self subscriptBoundsError:index
!
instVarAt:index put:value
@@ -1837,21 +1916,21 @@
int idx, ninstvars;
if (_isSmallInteger(index)) {
- myClass = _Class(self);
- ninstvars = _intVal(_ClassInstPtr(myClass)->c_ninstvars);
- idx = _intVal(index) - 1;
- if ((idx >= 0) && (idx < ninstvars)) {
- _InstPtr(self)->i_instvars[idx] = value;
- __STORE(self, value);
- RETURN ( value );
- }
+ myClass = _Class(self);
+ ninstvars = _intVal(_ClassInstPtr(myClass)->c_ninstvars);
+ idx = _intVal(index) - 1;
+ if ((idx >= 0) && (idx < ninstvars)) {
+ _InstPtr(self)->i_instvars[idx] = value;
+ __STORE(self, value);
+ RETURN ( value );
+ }
}
%}
.
index isInteger ifFalse:[
- ^ self indexNotInteger
+ ^ self indexNotInteger
].
- ^ self subscriptBoundsError
+ ^ self subscriptBoundsError:index
! !
!Object methodsFor:'dependents access'!
@@ -1861,7 +1940,7 @@
The default implementation here uses a global Dictionary to store
dependents - some classes (Model) redefine this for better performance."
- ^ Dependencies at:self ifAbsent:[]
+ ^ Dependencies at:self ifAbsent:[nil]
!
dependents:aCollection
@@ -1870,9 +1949,20 @@
dependents - some classes (Model) redefine this for better performance."
(aCollection isNil or:[aCollection isEmpty]) ifTrue:[
- Dependencies removeKey:self ifAbsent:[]
+ Dependencies removeKey:self ifAbsent:[]
] ifFalse:[
- Dependencies at:self put:aCollection
+ Dependencies at:self put:aCollection
+ ]
+!
+
+dependentsDo:aBlock
+ "evaluate aBlock for all of my dependents"
+
+ |deps|
+
+ deps := self dependents.
+ deps notNil ifTrue:[
+ deps do:aBlock
]
!
@@ -1883,9 +1973,9 @@
deps := self dependents.
deps isNil ifTrue:[
- self dependents:(WeakIdentitySet with:anObject)
+ self dependents:(WeakIdentitySet with:anObject)
] ifFalse:[
- deps add:anObject
+ deps add:anObject
]
!
@@ -1896,10 +1986,10 @@
deps := self dependents.
deps notNil ifTrue:[
- deps remove:anObject ifAbsent:[].
- deps isEmpty ifTrue:[
- self dependents:nil
- ]
+ deps remove:anObject ifAbsent:[].
+ deps isEmpty ifTrue:[
+ self dependents:nil
+ ]
]
!
@@ -1911,19 +2001,44 @@
!Object methodsFor:'change and update'!
+changeRequest
+ "the receiver wants to change - check if all dependents
+ grant the request, and return true if so"
+
+ self dependentsDo:[:dependent |
+ dependent updateRequest ifFalse:[^ false].
+ ].
+ ^ true
+!
+
+changeRequest:aParameter
+ "the receiver wants to change - check if all dependents
+ grant the request, and return true if so"
+
+ self dependentsDo:[:dependent |
+ (dependent updateRequest:aParameter) ifFalse:[^ false].
+ ].
+ ^ true
+!
+
+changeRequestFrom:anObject
+ "the receiver wants to change - check if all dependents
+ except anObject grant the request, and return true if so"
+
+ self dependentsDo:[:dependent |
+ dependent == anObject ifFalse:[
+ (dependent updateRequest) ifFalse:[^ false].
+ ]
+ ].
+ ^ true
+!
+
changed
"notify all dependents that the receiver has changed.
Each dependent gets a '#update:'-message with the original
receiver as argument."
- |deps|
-
- deps := self dependents.
- deps notNil ifTrue:[
- deps do:[:dependent |
- dependent update:self
- ]
- ]
+ self changed:nil
!
changed:aParameter
@@ -1931,41 +2046,24 @@
Each dependent gets a '#update:'-message with aParameter
as argument."
- |deps|
-
- deps := self dependents.
- deps notNil ifTrue:[
- deps do:[:dependent |
- dependent update:aParameter
- ]
- ]
+ self changed:aParameter with:nil
!
changed:aParameter with:anArgument
"notify all dependents that the receiver has changed somehow.
- Each dependent gets a '#update:with:'-message, with aParameter
+ Each dependent gets a '#update:with:from:'-message, with aParameter
and anArgument as arguments."
- |deps|
-
- deps := self dependents.
- deps notNil ifTrue:[
- deps do:[:dependent |
- dependent update:aParameter with:anArgument
- ]
+ self dependentsDo:[:dependent |
+ dependent update:aParameter with:anArgument from:self
]
!
broadcast:aSelectorSymbol
"send a message with selector aSelectorSymbol to all my dependents"
- |deps|
-
- deps := self dependents.
- deps notNil ifTrue:[
- deps do:[:dependent |
- dependent perform:aSelectorSymbol
- ]
+ self dependentsDo:[:dependent |
+ dependent perform:aSelectorSymbol
]
!
@@ -1973,13 +2071,8 @@
"send a message with selector aSelectorSymbol with an additional
argument anArgument to all my dependents."
- |deps|
-
- deps := self dependents.
- deps notNil ifTrue:[
- deps do:[:dependent |
- dependent perform:aSelectorSymbol with:anArgument
- ]
+ self dependentsDo:[:dependent |
+ dependent perform:aSelectorSymbol with:anArgument
]
!
@@ -1995,16 +2088,32 @@
update:aParameter with:anArgument
"dependent is notified of some change -
- Default is to try simple update"
+ Default is to try update:"
^ self update:aParameter
!
update:aParameter with:anArgument from:sender
"dependent is notified of some change -
- Default is to try simple update"
+ Default is to try update:with:"
^ self update:aParameter with:anArgument
+!
+
+updateRequest
+ "return true, if an update request is granted.
+ Default here is to grant updates - may be used
+ to lock updates if someone is making other changes
+ from within an update"
+
+ ^ true
+!
+
+updateRequest:aSymbol
+ "return true, if an update request is granted.
+ Default here a simple updateRequest"
+
+ ^ self updateRequest
! !
!Object methodsFor:'secure message sending'!
@@ -2031,9 +2140,9 @@
|val|
MessageNotUnderstoodSignal handle:[:ex |
- ^ exceptionBlock value
+ ^ exceptionBlock value
] do:[
- val := self perform:aSelector
+ val := self perform:aSelector
].
^ val
@@ -2050,9 +2159,9 @@
|val|
MessageNotUnderstoodSignal handle:[:ex |
- ^ exceptionBlock value
+ ^ exceptionBlock value
] do:[
- val := self perform:aSelector with:argument
+ val := self perform:aSelector with:argument
].
^ val
@@ -2073,6 +2182,7 @@
%{ /* NOCONTEXT */
+#define PRE_2_11
#ifdef PRE_2_11
static struct inlineCache ilc = _ILC0;
struct inlineCache lilc = _DUMMYILC0;
@@ -2091,8 +2201,8 @@
#ifdef PRE_2_11
if (aSelector != lastSelector) {
- ilc.ilc_func = _SEND0;
- lastSelector = aSelector;
+ ilc.ilc_func = _SEND0;
+ lastSelector = aSelector;
}
#else
lilc = ilc;
@@ -2122,39 +2232,35 @@
#ifdef PRE_2_11
static struct inlineCache ilc = _ILC1;
struct inlineCache lilc = _DUMMYILC1;
-#else
- static struct inlineCache ilc = _DUMMYILC1;
- struct inlineCache lilc;
-#endif
+
static OBJ lastSelector = nil;
-#if defined(THIS_CONTEXT)
+# if defined(THIS_CONTEXT)
/*
* must set lineno in sender by hand here ... (because of NOCONTEXT)
*/
_ContextInstPtr(__thisContext)->c_lineno = __pilc->ilc_lineNo;
-#endif
-
-#ifdef PRE_2_11
+# endif
+
if (aSelector != lastSelector) {
- ilc.ilc_func = _SEND1;
- lastSelector = aSelector;
+ ilc.ilc_func = _SEND1;
+ lastSelector = aSelector;
}
-#else
- lilc = ilc;
-#endif
-
-#if defined(xxTHIS_CONTEXT)
-# ifdef PRE_2_11
ilc.ilc_lineNo = __pilc->ilc_lineNo;
-# else
- lilc.ilc_lineNo = __pilc->ilc_lineNo;
-# endif
-#endif
-
-#ifdef PRE_2_11
RETURN ( (*ilc.ilc_func)(self, aSelector, CON_COMMA nil, &ilc, anObject) );
#else
+ static struct inlineCache ilc = _DUMMYILC1;
+ struct inlineCache lilc;
+
+# if defined(THIS_CONTEXT)
+ /*
+ * must set lineno in sender by hand here ... (because of NOCONTEXT)
+ */
+ _ContextInstPtr(__thisContext)->c_lineno = __pilc->ilc_lineNo;
+# endif
+
+ lilc = ilc;
+ lilc.ilc_lineNo = __pilc->ilc_lineNo;
RETURN ( (*ilc.ilc_func)(self, aSelector, CON_COMMA nil, &lilc, anObject) );
#endif
%}
@@ -2183,8 +2289,8 @@
#ifdef PRE_2_11
if (aSelector != lastSelector) {
- ilc.ilc_func = _SEND2;
- lastSelector = aSelector;
+ ilc.ilc_func = _SEND2;
+ lastSelector = aSelector;
}
#else
lilc = ilc;
@@ -2229,8 +2335,8 @@
#ifdef PRE_2_11
if (aSelector != lastSelector) {
- ilc.ilc_func = _SEND3;
- lastSelector = aSelector;
+ ilc.ilc_func = _SEND3;
+ lastSelector = aSelector;
}
#else
lilc = ilc;
@@ -2288,207 +2394,207 @@
#endif
if (_isSmallInteger(numberOfArgs)) {
- nargs = _intVal(numberOfArgs);
- if (nargs == 0) {
- if (aSelector != last0) {
- ilc0.ilc_func = _SEND0;
- last0 = aSelector;
- }
+ nargs = _intVal(numberOfArgs);
+ if (nargs == 0) {
+ if (aSelector != last0) {
+ ilc0.ilc_func = _SEND0;
+ last0 = aSelector;
+ }
#ifdef xxTHIS_CONTEXT
- ilc0.ilc_lineNo = __pilc->ilc_lineNo;
+ ilc0.ilc_lineNo = __pilc->ilc_lineNo;
#endif
- RETURN ((*ilc0.ilc_func)(self, aSelector, CON_COMMA nil, &ilc0));
- }
-
- if (__isArray(argArray)) {
- argP = _ArrayInstPtr(argArray)->a_element;
- } else {
- argP = (OBJ *)(&a1);
- for (i=1; i <= nargs; i++) {
- *argP++ = _AT_(argArray, CON_COMMA _MKSMALLINT(i));
- }
- }
- switch (nargs) {
- case 1:
- if (aSelector != last1) {
- ilc1.ilc_func = _SEND1;
- last1 = aSelector;
- }
+ RETURN ((*ilc0.ilc_func)(self, aSelector, CON_COMMA nil, &ilc0));
+ }
+
+ if (__isArray(argArray)) {
+ argP = _ArrayInstPtr(argArray)->a_element;
+ } else {
+ argP = (OBJ *)(&a1);
+ for (i=1; i <= nargs; i++) {
+ *argP++ = _AT_(argArray, CON_COMMA _MKSMALLINT(i));
+ }
+ }
+ switch (nargs) {
+ case 1:
+ if (aSelector != last1) {
+ ilc1.ilc_func = _SEND1;
+ last1 = aSelector;
+ }
#ifdef xxTHIS_CONTEXT
- ilc1.ilc_lineNo = __pilc->ilc_lineNo;
+ ilc1.ilc_lineNo = __pilc->ilc_lineNo;
#endif
- RETURN ( (*ilc1.ilc_func)(self, aSelector, CON_COMMA nil, &ilc1, argP[0]));
-
- case 2:
- if (aSelector != last2) {
- ilc2.ilc_func = _SEND2;
- last2 = aSelector;
- }
+ RETURN ( (*ilc1.ilc_func)(self, aSelector, CON_COMMA nil, &ilc1, argP[0]));
+
+ case 2:
+ if (aSelector != last2) {
+ ilc2.ilc_func = _SEND2;
+ last2 = aSelector;
+ }
#ifdef xxTHIS_CONTEXT
- ilc2.ilc_lineNo = __pilc->ilc_lineNo;
+ ilc2.ilc_lineNo = __pilc->ilc_lineNo;
#endif
- RETURN ( (*ilc2.ilc_func)(self, aSelector, CON_COMMA nil, &ilc2,
- argP[0], argP[1]));
-
- case 3:
- if (aSelector != last3) {
- ilc3.ilc_func = _SEND3;
- last3 = aSelector;
- }
+ RETURN ( (*ilc2.ilc_func)(self, aSelector, CON_COMMA nil, &ilc2,
+ argP[0], argP[1]));
+
+ case 3:
+ if (aSelector != last3) {
+ ilc3.ilc_func = _SEND3;
+ last3 = aSelector;
+ }
#ifdef xxTHIS_CONTEXT
- ilc3.ilc_lineNo = __pilc->ilc_lineNo;
+ ilc3.ilc_lineNo = __pilc->ilc_lineNo;
#endif
- RETURN ( (*ilc3.ilc_func)(self, aSelector, CON_COMMA nil, &ilc3,
- argP[0], argP[1], argP[2]));
-
- case 4:
- if (aSelector != last4) {
- ilc4.ilc_func = _SEND4;
- last4 = aSelector;
- }
+ RETURN ( (*ilc3.ilc_func)(self, aSelector, CON_COMMA nil, &ilc3,
+ argP[0], argP[1], argP[2]));
+
+ case 4:
+ if (aSelector != last4) {
+ ilc4.ilc_func = _SEND4;
+ last4 = aSelector;
+ }
#ifdef xxTHIS_CONTEXT
- ilc4.ilc_lineNo = __pilc->ilc_lineNo;
+ ilc4.ilc_lineNo = __pilc->ilc_lineNo;
#endif
- RETURN ( (*ilc4.ilc_func)(self, aSelector, CON_COMMA nil, &ilc4,
- argP[0], argP[1], argP[2], argP[3]));
-
- case 5:
- if (aSelector != last5) {
- ilc5.ilc_func = _SEND5;
- last5 = aSelector;
- }
+ RETURN ( (*ilc4.ilc_func)(self, aSelector, CON_COMMA nil, &ilc4,
+ argP[0], argP[1], argP[2], argP[3]));
+
+ case 5:
+ if (aSelector != last5) {
+ ilc5.ilc_func = _SEND5;
+ last5 = aSelector;
+ }
#ifdef xxTHIS_CONTEXT
- ilc5.ilc_lineNo = __pilc->ilc_lineNo;
+ ilc5.ilc_lineNo = __pilc->ilc_lineNo;
#endif
- RETURN ( (*ilc5.ilc_func)(self, aSelector, CON_COMMA nil, &ilc5,
- argP[0], argP[1], argP[2], argP[3], argP[4]));
-
- case 6:
- if (aSelector != last6) {
- ilc6.ilc_func = _SEND6;
- last6 = aSelector;
- }
+ RETURN ( (*ilc5.ilc_func)(self, aSelector, CON_COMMA nil, &ilc5,
+ argP[0], argP[1], argP[2], argP[3], argP[4]));
+
+ case 6:
+ if (aSelector != last6) {
+ ilc6.ilc_func = _SEND6;
+ last6 = aSelector;
+ }
#ifdef xxTHIS_CONTEXT
- ilc6.ilc_lineNo = __pilc->ilc_lineNo;
+ ilc6.ilc_lineNo = __pilc->ilc_lineNo;
#endif
- RETURN ( (*ilc6.ilc_func)(self, aSelector, CON_COMMA nil, &ilc6,
- argP[0], argP[1], argP[2], argP[3], argP[4],
- argP[5]));
-
- case 7:
- if (aSelector != last7) {
- ilc7.ilc_func = _SEND7;
- last7 = aSelector;
- }
+ RETURN ( (*ilc6.ilc_func)(self, aSelector, CON_COMMA nil, &ilc6,
+ argP[0], argP[1], argP[2], argP[3], argP[4],
+ argP[5]));
+
+ case 7:
+ if (aSelector != last7) {
+ ilc7.ilc_func = _SEND7;
+ last7 = aSelector;
+ }
#ifdef xxTHIS_CONTEXT
- ilc7.ilc_lineNo = __pilc->ilc_lineNo;
+ ilc7.ilc_lineNo = __pilc->ilc_lineNo;
#endif
- RETURN ( (*ilc7.ilc_func)(self, aSelector, CON_COMMA nil, &ilc7,
- argP[0], argP[1], argP[2], argP[3], argP[4],
- argP[5], argP[6]));
-
- case 8:
- if (aSelector != last8) {
- ilc8.ilc_func = _SEND8;
- last8 = aSelector;
- }
+ RETURN ( (*ilc7.ilc_func)(self, aSelector, CON_COMMA nil, &ilc7,
+ argP[0], argP[1], argP[2], argP[3], argP[4],
+ argP[5], argP[6]));
+
+ case 8:
+ if (aSelector != last8) {
+ ilc8.ilc_func = _SEND8;
+ last8 = aSelector;
+ }
#ifdef xxTHIS_CONTEXT
- ilc8.ilc_lineNo = __pilc->ilc_lineNo;
+ ilc8.ilc_lineNo = __pilc->ilc_lineNo;
#endif
- RETURN ( (*ilc8.ilc_func)(self, aSelector, CON_COMMA nil, &ilc8,
- argP[0], argP[1], argP[2], argP[3], argP[4],
- argP[5], argP[6], argP[7]));
-
- case 9:
- if (aSelector != last9) {
- ilc9.ilc_func = _SEND9;
- last9 = aSelector;
- }
+ RETURN ( (*ilc8.ilc_func)(self, aSelector, CON_COMMA nil, &ilc8,
+ argP[0], argP[1], argP[2], argP[3], argP[4],
+ argP[5], argP[6], argP[7]));
+
+ case 9:
+ if (aSelector != last9) {
+ ilc9.ilc_func = _SEND9;
+ last9 = aSelector;
+ }
#ifdef xxTHIS_CONTEXT
- ilc9.ilc_lineNo = __pilc->ilc_lineNo;
+ ilc9.ilc_lineNo = __pilc->ilc_lineNo;
#endif
- RETURN ( (*ilc9.ilc_func)(self, aSelector, CON_COMMA nil, &ilc9,
- argP[0], argP[1], argP[2], argP[3], argP[4],
- argP[5], argP[6], argP[7], argP[8]));
-
- case 10:
- if (aSelector != last10) {
- ilc10.ilc_func = _SEND10;
- last10 = aSelector;
- }
+ RETURN ( (*ilc9.ilc_func)(self, aSelector, CON_COMMA nil, &ilc9,
+ argP[0], argP[1], argP[2], argP[3], argP[4],
+ argP[5], argP[6], argP[7], argP[8]));
+
+ case 10:
+ if (aSelector != last10) {
+ ilc10.ilc_func = _SEND10;
+ last10 = aSelector;
+ }
#ifdef xxTHIS_CONTEXT
- ilc10.ilc_lineNo = __pilc->ilc_lineNo;
+ ilc10.ilc_lineNo = __pilc->ilc_lineNo;
#endif
- RETURN ( (*ilc10.ilc_func)(self, aSelector, CON_COMMA nil, &ilc10,
- argP[0], argP[1], argP[2], argP[3], argP[4],
- argP[5], argP[6], argP[7], argP[8], argP[9]));
-
- case 11:
- if (aSelector != last11) {
- ilc11.ilc_func = _SEND11;
- last11 = aSelector;
- }
+ RETURN ( (*ilc10.ilc_func)(self, aSelector, CON_COMMA nil, &ilc10,
+ argP[0], argP[1], argP[2], argP[3], argP[4],
+ argP[5], argP[6], argP[7], argP[8], argP[9]));
+
+ case 11:
+ if (aSelector != last11) {
+ ilc11.ilc_func = _SEND11;
+ last11 = aSelector;
+ }
#ifdef xxTHIS_CONTEXT
- ilc11.ilc_lineNo = __pilc->ilc_lineNo;
+ ilc11.ilc_lineNo = __pilc->ilc_lineNo;
#endif
- RETURN ( (*ilc11.ilc_func)(self, aSelector, CON_COMMA nil, &ilc11,
- argP[0], argP[1], argP[2], argP[3], argP[4],
- argP[5], argP[6], argP[7], argP[8], argP[9],
- argP[10]));
-
- case 12:
- if (aSelector != last12) {
- ilc12.ilc_func = _SEND12;
- last12 = aSelector;
- }
+ RETURN ( (*ilc11.ilc_func)(self, aSelector, CON_COMMA nil, &ilc11,
+ argP[0], argP[1], argP[2], argP[3], argP[4],
+ argP[5], argP[6], argP[7], argP[8], argP[9],
+ argP[10]));
+
+ case 12:
+ if (aSelector != last12) {
+ ilc12.ilc_func = _SEND12;
+ last12 = aSelector;
+ }
#ifdef xxTHIS_CONTEXT
- ilc12.ilc_lineNo = __pilc->ilc_lineNo;
+ ilc12.ilc_lineNo = __pilc->ilc_lineNo;
#endif
- RETURN ( (*ilc12.ilc_func)(self, aSelector, CON_COMMA nil, &ilc12,
- argP[0], argP[1], argP[2], argP[3], argP[4],
- argP[5], argP[6], argP[7], argP[8], argP[9],
- argP[10], argP[11]));
-
- case 13:
- if (aSelector != last13) {
- ilc13.ilc_func = _SEND13;
- last13 = aSelector;
- }
+ RETURN ( (*ilc12.ilc_func)(self, aSelector, CON_COMMA nil, &ilc12,
+ argP[0], argP[1], argP[2], argP[3], argP[4],
+ argP[5], argP[6], argP[7], argP[8], argP[9],
+ argP[10], argP[11]));
+
+ case 13:
+ if (aSelector != last13) {
+ ilc13.ilc_func = _SEND13;
+ last13 = aSelector;
+ }
#ifdef xxTHIS_CONTEXT
- ilc13.ilc_lineNo = __pilc->ilc_lineNo;
+ ilc13.ilc_lineNo = __pilc->ilc_lineNo;
#endif
- RETURN ( (*ilc13.ilc_func)(self, aSelector, CON_COMMA nil, &ilc13,
- argP[0], argP[1], argP[2], argP[3], argP[4],
- argP[5], argP[6], argP[7], argP[8], argP[9],
- argP[10], argP[11], argP[12]));
-
- case 14:
- if (aSelector != last14) {
- ilc14.ilc_func = _SEND14;
- last14 = aSelector;
- }
+ RETURN ( (*ilc13.ilc_func)(self, aSelector, CON_COMMA nil, &ilc13,
+ argP[0], argP[1], argP[2], argP[3], argP[4],
+ argP[5], argP[6], argP[7], argP[8], argP[9],
+ argP[10], argP[11], argP[12]));
+
+ case 14:
+ if (aSelector != last14) {
+ ilc14.ilc_func = _SEND14;
+ last14 = aSelector;
+ }
#ifdef xxTHIS_CONTEXT
- ilc14.ilc_lineNo = __pilc->ilc_lineNo;
+ ilc14.ilc_lineNo = __pilc->ilc_lineNo;
#endif
- RETURN ( (*ilc14.ilc_func)(self, aSelector, CON_COMMA nil, &ilc14,
- argP[0], argP[1], argP[2], argP[3], argP[4],
- argP[5], argP[6], argP[7], argP[8], argP[9],
- argP[10], argP[11], argP[12], argP[13]));
-
- case 15:
- if (aSelector != last15) {
- ilc15.ilc_func = _SEND15;
- last15 = aSelector;
- }
+ RETURN ( (*ilc14.ilc_func)(self, aSelector, CON_COMMA nil, &ilc14,
+ argP[0], argP[1], argP[2], argP[3], argP[4],
+ argP[5], argP[6], argP[7], argP[8], argP[9],
+ argP[10], argP[11], argP[12], argP[13]));
+
+ case 15:
+ if (aSelector != last15) {
+ ilc15.ilc_func = _SEND15;
+ last15 = aSelector;
+ }
#ifdef xxTHIS_CONTEXT
- ilc15.ilc_lineNo = __pilc->ilc_lineNo;
+ ilc15.ilc_lineNo = __pilc->ilc_lineNo;
#endif
- RETURN ( (*ilc15.ilc_func)(self, aSelector, CON_COMMA nil, &ilc15,
- argP[0], argP[1], argP[2], argP[3], argP[4],
- argP[5], argP[6], argP[7], argP[8], argP[9],
- argP[10], argP[11], argP[12], argP[13],
- argP[14]));
- }
+ RETURN ( (*ilc15.ilc_func)(self, aSelector, CON_COMMA nil, &ilc15,
+ argP[0], argP[1], argP[2], argP[3], argP[4],
+ argP[5], argP[6], argP[7], argP[8], argP[9],
+ argP[10], argP[11], argP[12], argP[13],
+ argP[14]));
+ }
}
%}
.
@@ -2502,7 +2608,7 @@
to execute a method in ANY superclass of the receiver (not just the
immediate superclass).
Thus, it is (theoretically) possible to do
- '5 perform:#< inClass:Magnitude withArguments:#(6)'
+ '5 perform:#< inClass:Magnitude withArguments:#(6)'
and evaluate Magnitudes compare method even if there was one in Number.
This method is used by the interpreter to evaluate super sends
and could be used for very special behavior (language extension ?).
@@ -2515,8 +2621,8 @@
check, if aClass is really a superclass of the receiver
"
(self class isSubclassOf:aClass) ifFalse:[
- self error:'class argument is not a superclass of the receiver'.
- ^ nil
+ self error:'class argument is not a superclass of the receiver'.
+ ^ nil
].
numberOfArgs := argArray size.
%{
@@ -2541,81 +2647,81 @@
static struct inlineCache ilc15 = _DUMMYILC15;
if (_isSmallInteger(numberOfArgs)) {
- nargs = _intVal(numberOfArgs);
- if (nargs == 0) {
- RETURN (_SEND0(self, aSelector, CON_COMMA aClass, &ilc0));
- }
-
- argP = (OBJ *)(&a1);
- if (_Class(argArray) == Array) {
- for (i=0; i < nargs; i++) {
- *argP++ = _ArrayInstPtr(argArray)->a_element[i];
- }
- } else {
- for (i=1; i <= nargs; i++) {
- *argP++ = _AT_(argArray, CON_COMMA _MKSMALLINT(i));
- }
- }
- switch (nargs) {
- case 1:
- RETURN ( _SEND1(self, aSelector, CON_COMMA aClass, &ilc1, a1));
-
- case 2:
- RETURN ( _SEND2(self, aSelector, CON_COMMA aClass, &ilc2, a1, a2));
-
- case 3:
- RETURN ( _SEND3(self, aSelector, CON_COMMA aClass, &ilc3, a1, a2, a3));
-
- case 4:
- RETURN ( _SEND4(self, aSelector, CON_COMMA aClass, &ilc4, a1, a2, a3, a4));
-
- case 5:
- RETURN ( _SEND5(self, aSelector, CON_COMMA aClass, &ilc5,
- a1, a2, a3, a4, a5));
-
- case 6:
- RETURN ( _SEND6(self, aSelector, CON_COMMA aClass, &ilc6,
- a1, a2, a3, a4, a5, a6));
-
- case 7:
- RETURN ( _SEND7(self, aSelector, CON_COMMA aClass, &ilc7,
- a1, a2, a3, a4, a5, a6, a7));
-
- case 8:
- RETURN ( _SEND8(self, aSelector, CON_COMMA aClass, &ilc8,
- a1, a2, a3, a4, a5, a6, a7, a8));
-
- case 9:
- RETURN ( _SEND9(self, aSelector, CON_COMMA aClass, &ilc9,
- a1, a2, a3, a4, a5, a6, a7, a8, a9));
-
- case 10:
- RETURN ( _SEND10(self, aSelector, CON_COMMA aClass, &ilc10,
- a1, a2, a3, a4, a5, a6, a7, a8, a9, a10));
-
- case 11:
- RETURN ( _SEND11(self, aSelector, CON_COMMA aClass, &ilc11,
- a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11));
-
- case 12:
- RETURN ( _SEND12(self, aSelector, CON_COMMA aClass, &ilc12,
- a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12));
-
- case 13:
- RETURN ( _SEND13(self, aSelector, CON_COMMA aClass, &ilc13,
- a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12,
- a13));
-
- case 14:
- RETURN ( _SEND14(self, aSelector, CON_COMMA aClass, &ilc14,
- a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12,
- a13, a14));
-
- case 15:
- RETURN ( _SEND15(self, aSelector, CON_COMMA aClass, &ilc15,
- a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12,
- a13, a14, a15));
- }
+ nargs = _intVal(numberOfArgs);
+ if (nargs == 0) {
+ RETURN (_SEND0(self, aSelector, CON_COMMA aClass, &ilc0));
+ }
+
+ argP = (OBJ *)(&a1);
+ if (_Class(argArray) == Array) {
+ for (i=0; i < nargs; i++) {
+ *argP++ = _ArrayInstPtr(argArray)->a_element[i];
+ }
+ } else {
+ for (i=1; i <= nargs; i++) {
+ *argP++ = _AT_(argArray, CON_COMMA _MKSMALLINT(i));
+ }
+ }
+ switch (nargs) {
+ case 1:
+ RETURN ( _SEND1(self, aSelector, CON_COMMA aClass, &ilc1, a1));
+
+ case 2:
+ RETURN ( _SEND2(self, aSelector, CON_COMMA aClass, &ilc2, a1, a2));
+
+ case 3:
+ RETURN ( _SEND3(self, aSelector, CON_COMMA aClass, &ilc3, a1, a2, a3));
+
+ case 4:
+ RETURN ( _SEND4(self, aSelector, CON_COMMA aClass, &ilc4, a1, a2, a3, a4));
+
+ case 5:
+ RETURN ( _SEND5(self, aSelector, CON_COMMA aClass, &ilc5,
+ a1, a2, a3, a4, a5));
+
+ case 6:
+ RETURN ( _SEND6(self, aSelector, CON_COMMA aClass, &ilc6,
+ a1, a2, a3, a4, a5, a6));
+
+ case 7:
+ RETURN ( _SEND7(self, aSelector, CON_COMMA aClass, &ilc7,
+ a1, a2, a3, a4, a5, a6, a7));
+
+ case 8:
+ RETURN ( _SEND8(self, aSelector, CON_COMMA aClass, &ilc8,
+ a1, a2, a3, a4, a5, a6, a7, a8));
+
+ case 9:
+ RETURN ( _SEND9(self, aSelector, CON_COMMA aClass, &ilc9,
+ a1, a2, a3, a4, a5, a6, a7, a8, a9));
+
+ case 10:
+ RETURN ( _SEND10(self, aSelector, CON_COMMA aClass, &ilc10,
+ a1, a2, a3, a4, a5, a6, a7, a8, a9, a10));
+
+ case 11:
+ RETURN ( _SEND11(self, aSelector, CON_COMMA aClass, &ilc11,
+ a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11));
+
+ case 12:
+ RETURN ( _SEND12(self, aSelector, CON_COMMA aClass, &ilc12,
+ a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12));
+
+ case 13:
+ RETURN ( _SEND13(self, aSelector, CON_COMMA aClass, &ilc13,
+ a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12,
+ a13));
+
+ case 14:
+ RETURN ( _SEND14(self, aSelector, CON_COMMA aClass, &ilc14,
+ a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12,
+ a13, a14));
+
+ case 15:
+ RETURN ( _SEND15(self, aSelector, CON_COMMA aClass, &ilc15,
+ a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12,
+ a13, a14, a15));
+ }
}
%}
.
@@ -2652,92 +2758,100 @@
size := self class instSize.
1 to:size do:[:i |
- self instVarAt:i put:(manager nextObject)
+ self instVarAt:i put:(manager nextObject)
].
size := self basicSize.
size ~~ 0 ifTrue:[
- self class isPointers ifTrue:[
- 1 to:size do:[:i |
- self basicAt:i put:(manager nextObject)
- ]
- ]
+ self class isPointers ifTrue:[
+ 1 to:size do:[:i |
+ self basicAt:i put:(manager nextObject)
+ ]
+ ]
]
!
storeBinaryDefinitionOn: stream manager: manager
"append a binary representation of the receiver onto stream.
+ This method first stores the class, then the body, which is done
+ in a separate method to allow redefinition of the bodies format.
+ Can be redefined in subclasses (see String, SmallInteger etc)."
+
+ manager putIdOf:(self class) on:stream.
+ self storeBinaryDefinitionBodyOn:stream manager:manager
+!
+
+storeBinaryDefinitionBodyOn: stream manager: manager
+ "append a binary representation of the receivers body onto stream.
This is a general implementation walking over instances storing
each recursively as an ID using manager.
- Can be redefined in subclasses (see String, SmallInteger etc)."
+ Can be redefined in subclasses."
|basicSize "{ Class: SmallInteger }"
instSize "{ Class: SmallInteger }"|
- manager putIdOf:(self class) on:stream.
-
instSize := self class instSize.
self class isPointers ifTrue:[
- stream nextPut:instSize. "mhmh this limits us to 255 named instvars"
-
- self class isVariable ifTrue:[
- stream nextNumber:3 put:(basicSize := self basicSize)
- ] ifFalse:[
- basicSize := 0
- ].
-
- 1 to:instSize do:[:i |
- manager putIdOf:(self instVarAt:i) on:stream
- ].
-
- 1 to:basicSize do:[:i |
- manager putIdOf:(self basicAt:i) on: stream
- ]
+ stream nextPut:instSize. "mhmh this limits us to 255 named instvars"
+
+ self class isVariable ifTrue:[
+ stream nextNumber:3 put:(basicSize := self basicSize)
+ ] ifFalse:[
+ basicSize := 0
+ ].
+
+ 1 to:instSize do:[:i |
+ manager putIdOf:(self instVarAt:i) on:stream
+ ].
+
+ 1 to:basicSize do:[:i |
+ manager putIdOf:(self basicAt:i) on: stream
+ ]
] ifFalse: [
- stream nextNumber:4 put:(basicSize := self basicSize).
- self class isBytes ifTrue:[
- 1 to:basicSize do:[:i |
- stream nextPut:(self basicAt:i)
- ]
- ] ifFalse:[
- self class isWords ifTrue:[
- 1 to:basicSize do:[:i |
- stream nextNumber:2 put: (self basicAt: i)
- ]
- ] ifFalse:[
- self class isLongs ifTrue:[
- 1 to:basicSize do:[:i |
- stream nextNumber:4 put: (self basicAt: i)
- ]
- ] ifFalse:[
- self class isFloats ifTrue:[
- "could do it in one big write on machines which use IEEE floats ..."
- 1 to:basicSize do:[:i |
- Float storeBinaryIEEESingle:(self basicAt:i) on:stream
- ]
- ] ifFalse:[
- self class isDoubles ifTrue:[
- "could do it in one big write on machines which use IEEE doubles ..."
- 1 to:basicSize do:[:i |
- Float storeBinaryIEEEDouble:(self basicAt:i) on:stream
- ]
- ] ifFalse:[
- 1 to:basicSize do:[:i |
- manager putIdOf:(self basicAt:i) on: stream
- ]
- ]
- ]
- ]
- ]
- ].
- "dont forget the instvars"
- 1 to:instSize do:[:i |
- manager putIdOf:(self instVarAt:i) on:stream
- ].
+ stream nextNumber:4 put:(basicSize := self basicSize).
+ self class isBytes ifTrue:[
+ 1 to:basicSize do:[:i |
+ stream nextPut:(self basicAt:i)
+ ]
+ ] ifFalse:[
+ self class isWords ifTrue:[
+ 1 to:basicSize do:[:i |
+ stream nextNumber:2 put: (self basicAt: i)
+ ]
+ ] ifFalse:[
+ self class isLongs ifTrue:[
+ 1 to:basicSize do:[:i |
+ stream nextNumber:4 put: (self basicAt: i)
+ ]
+ ] ifFalse:[
+ self class isFloats ifTrue:[
+ "could do it in one big write on machines which use IEEE floats ..."
+ 1 to:basicSize do:[:i |
+ Float storeBinaryIEEESingle:(self basicAt:i) on:stream
+ ]
+ ] ifFalse:[
+ self class isDoubles ifTrue:[
+ "could do it in one big write on machines which use IEEE doubles ..."
+ 1 to:basicSize do:[:i |
+ Float storeBinaryIEEEDouble:(self basicAt:i) on:stream
+ ]
+ ] ifFalse:[
+ 1 to:basicSize do:[:i |
+ manager putIdOf:(self basicAt:i) on: stream
+ ]
+ ]
+ ]
+ ]
+ ]
+ ].
+ "dont forget the instvars"
+ 1 to:instSize do:[:i |
+ manager putIdOf:(self instVarAt:i) on:stream
+ ].
]
!
-storeBinaryOn: stream manager: manager
+storeBinaryOn:stream manager:manager
"append a binary representation of the receiver onto stream."
manager putIdOf:self on:stream
@@ -2956,9 +3070,9 @@
|myClass hasSemi sz "{ Class: SmallInteger }" |
thisContext isRecursive ifTrue:[
- Transcript showCr:'Error: storeString of self referencing object.'.
- aStream nextPutAll:'#("recursive")'.
- ^ self
+ Transcript showCr:'Error: storeString of self referencing object.'.
+ aStream nextPutAll:'#("recursive")'.
+ ^ self
].
myClass := self class.
@@ -2967,34 +3081,34 @@
hasSemi := false.
myClass isVariable ifTrue:[
- aStream nextPutAll:' basicNew:'.
- self basicSize printOn:aStream
+ aStream nextPutAll:' basicNew:'.
+ self basicSize printOn:aStream
] ifFalse:[
- aStream nextPutAll:' basicNew'
+ aStream nextPutAll:' basicNew'
].
sz := myClass instSize.
1 to:sz do:[:i |
- aStream nextPutAll:' instVarAt:'.
- i printOn:aStream.
- aStream nextPutAll:' put:'.
- (self instVarAt:i) storeOn:aStream.
- aStream nextPut:$;.
- hasSemi := true
+ aStream nextPutAll:' instVarAt:'.
+ i printOn:aStream.
+ aStream nextPutAll:' put:'.
+ (self instVarAt:i) storeOn:aStream.
+ aStream nextPut:$;.
+ hasSemi := true
].
myClass isVariable ifTrue:[
- sz := self basicSize.
- 1 to:sz do:[:i |
- aStream nextPutAll:' basicAt:'.
- i printOn:aStream.
- aStream nextPutAll:' put:'.
- (self basicAt:i) storeOn:aStream.
- aStream nextPut:$;.
- hasSemi := true
- ]
+ sz := self basicSize.
+ 1 to:sz do:[:i |
+ aStream nextPutAll:' basicAt:'.
+ i printOn:aStream.
+ aStream nextPutAll:' put:'.
+ (self basicAt:i) storeOn:aStream.
+ aStream nextPut:$;.
+ hasSemi := true
+ ]
].
hasSemi ifTrue:[
- aStream nextPutAll:' yourself'
+ aStream nextPutAll:' yourself'
].
aStream nextPut:$).
!
--- a/ObjectMemory.st Mon Oct 10 01:29:01 1994 +0100
+++ b/ObjectMemory.st Mon Oct 10 01:29:28 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1992 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -13,25 +13,25 @@
Object subclass:#ObjectMemory
instanceVariableNames:''
classVariableNames:'InternalErrorHandler UserInterruptHandler TimerInterruptHandler
- SpyInterruptHandler StepInterruptHandler ExceptionInterruptHandler
- ErrorInterruptHandler MemoryInterruptHandler SignalInterruptHandler
- ChildSignalInterruptHandler DisposeInterruptHandler
- RecursionInterruptHandler IOInterruptHandler
- CustomInterruptHandler
+ SpyInterruptHandler StepInterruptHandler ExceptionInterruptHandler
+ ErrorInterruptHandler MemoryInterruptHandler SignalInterruptHandler
+ ChildSignalInterruptHandler DisposeInterruptHandler
+ RecursionInterruptHandler IOInterruptHandler
+ CustomInterruptHandler
- AllocationFailureSignal
- IncrementalGCLimit
- Dependents
- ImageName'
+ AllocationFailureSignal
+ IncrementalGCLimit
+ Dependents
+ ImageName'
poolDictionaries:''
category:'System-Support'
!
ObjectMemory comment:'
COPYRIGHT (c) 1992 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/ObjectMemory.st,v 1.14 1994-08-22 12:21:33 claus Exp $
+$Header: /cvs/stx/stx/libbasic/ObjectMemory.st,v 1.15 1994-10-10 00:26:56 claus Exp $
'!
!ObjectMemory class methodsFor:'documentation'!
@@ -39,7 +39,7 @@
copyright
"
COPYRIGHT (c) 1992 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -52,7 +52,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/ObjectMemory.st,v 1.14 1994-08-22 12:21:33 claus Exp $
+$Header: /cvs/stx/stx/libbasic/ObjectMemory.st,v 1.15 1994-10-10 00:26:56 claus Exp $
"
!
@@ -73,30 +73,30 @@
ClassVariables:
- InternalErrorHandler gets informed (by VM), when some runtime
- error occurs (usually fatal)
+ InternalErrorHandler gets informed (by VM), when some runtime
+ error occurs (usually fatal)
- UserInterruptHandler gets informed (by VM) when CNTL-C is pressed
- TimerInterruptHandler gets alarm timer interrupts (from VM)
- SpyInterruptHandler another alarm timer (from VM)
- StepInterruptHandler gets single step interrupts (from VM)
- ExceptionInterruptHandler gets floating point exceptions (from VM)
- ErrorInterruptHandler gets graphic device errors (from VM)
- MemoryInterruptHandler gets soon-out-of-memory conditions (from VM)
- SignalInterruptHandler gets unix signals (from VM)
- ChildSignalInterruptHandler gets child death signals (from VM)
- DisposeInterruptHandler gets informed, when an object is disposed from
- a shadowArray (from VM)
- RecursionInterruptHandler gets recursion limit violations (from VM)
- IOInterruptHandler gets SIGIO unix signals (from VM)
- CustomInterruptHandler gets custom interrupts (from VM)
+ UserInterruptHandler gets informed (by VM) when CNTL-C is pressed
+ TimerInterruptHandler gets alarm timer interrupts (from VM)
+ SpyInterruptHandler another alarm timer (from VM)
+ StepInterruptHandler gets single step interrupts (from VM)
+ ExceptionInterruptHandler gets floating point exceptions (from VM)
+ ErrorInterruptHandler gets graphic device errors (from VM)
+ MemoryInterruptHandler gets soon-out-of-memory conditions (from VM)
+ SignalInterruptHandler gets unix signals (from VM)
+ ChildSignalInterruptHandler gets child death signals (from VM)
+ DisposeInterruptHandler gets informed, when an object is disposed from
+ a shadowArray (from VM)
+ RecursionInterruptHandler gets recursion limit violations (from VM)
+ IOInterruptHandler gets SIGIO unix signals (from VM)
+ CustomInterruptHandler gets custom interrupts (from VM)
- AllocationFailureSignal signal raised when a new fails (see Behavior)
- IngrementalGCLimit number of bytes, that must be allocated since
- last full garbage collect to turn on incremental
- collector.
- Dependents keep my dependents locally (its faster) for
- all those registries
+ AllocationFailureSignal signal raised when a new fails (see Behavior)
+ IngrementalGCLimit number of bytes, that must be allocated since
+ last full garbage collect to turn on incremental
+ collector.
+ Dependents keep my dependents locally (its faster) for
+ all those registries
"
!
@@ -105,18 +105,18 @@
The system uses various caches to speed up method-lookup.
Currently, there is a three-level cache hierarchy:
- inline-cache keeps the target of the last send at the caller-
- side (i.e. every send goes through its private
- 1-slot inline-cache, where the address of the last
- called function at this call location is kept.)
+ inline-cache keeps the target of the last send at the caller-
+ side (i.e. every send goes through its private
+ 1-slot inline-cache, where the address of the last
+ called function at this call location is kept.)
- polymorph-inline-cache keeps a limited list of all targets ever reched
- at this call location. The list is flushed if it
- grows too large or the total number of poly-chache
- entries exceeds a limit.
+ polymorph-inline-cache keeps a limited list of all targets ever reched
+ at this call location. The list is flushed if it
+ grows too large or the total number of poly-chache
+ entries exceeds a limit.
- method-lookup-cache a global cache. Hashes on class-selector pairs,
- returning the target method.
+ method-lookup-cache a global cache. Hashes on class-selector pairs,
+ returning the target method.
Whenever methods are added or removed from the system, or the inheritance
hierarchy changes, some or all caches have to be flushed.
@@ -235,8 +235,11 @@
initialize
AllocationFailureSignal isNil ifTrue:[
- AllocationFailureSignal := (Signal new) mayProceed:true.
- AllocationFailureSignal notifierString:'allocation failure'.
+ Object initialize.
+
+ AllocationFailureSignal := Object errorSignal newSignalMayProceed:true.
+ AllocationFailureSignal nameClass:self message:#allocationFailureSignal.
+ AllocationFailureSignal notifierString:'allocation failure'.
].
IncrementalGCLimit := 500000.
MemoryInterruptHandler := self
@@ -349,7 +352,7 @@
* allObjectsDo needs a temporary to hold newSpace objects
*/
if (__allObjectsDo(&aBlock, &work COMMA_CON) < 0) {
- RETURN (false);
+ RETURN (false);
}
%}.
^ true
@@ -360,7 +363,7 @@
For debugging and tests only - do not use"
%{
if (__allObjectsDo(&aBlock, (OBJ *)0 COMMA_CON) < 0) {
- RETURN (false);
+ RETURN (false);
}
%}.
^ true
@@ -639,13 +642,13 @@
aCollection := IdentitySet new.
self allObjectsDo:[:o |
- (o references:anObject) ifTrue:[
- aCollection add:o
- ]
+ (o references:anObject) ifTrue:[
+ aCollection add:o
+ ]
].
(aCollection size == 0) ifTrue:[
- "actually this cannot happen - there is always one"
- ^ nil
+ "actually this cannot happen - there is always one"
+ ^ nil
].
^ aCollection
!
@@ -659,7 +662,7 @@
%{ /* NOCONTEXT */
if (! _isNonNilObject(anObject)) {
- RETURN ( nil );
+ RETURN ( nil );
}
RETURN ( _MKSMALLINT( (int)anObject ) );
%}
@@ -672,6 +675,24 @@
"
!
+objectAt:anAddress
+ "return whatever anAddress points to as object.
+ BIG BIG danger alert: this method is only to be used for debugging
+ ST/X itself - you can easily (and badly) crash the system.
+ This method will be removed from the final shipping version"
+
+ |low high|
+
+ low := anAddress bitAnd:16rFFFF.
+ high := (anAddress bitShift:16) bitAnd:16rFFFF.
+%{
+ if (_isSmallInteger(low)
+ && _isSmallInteger(high)) {
+ RETURN ((OBJ)((_intVal(high) << 16) | _intVal(low)));
+ }
+%}
+!
+
sizeOf:anObject
"return the size of anObject in bytes.
Use only for debugging/memory monitoring."
@@ -686,12 +707,12 @@
hist := Array new:100 withAll:0.
big := 0.
ObjectMemory allObjectsDo:[:o |
- nw := (ObjectMemory sizeOf:o) // 4 + 1.
- nw > 100 ifTrue:[
- big := big + 1
- ] ifFalse:[
- hist at:nw put:(hist at:nw) + 1
- ].
+ nw := (ObjectMemory sizeOf:o) // 4 + 1.
+ nw > 100 ifTrue:[
+ big := big + 1
+ ] ifFalse:[
+ hist at:nw put:(hist at:nw) + 1
+ ].
].
hist printNL.
big printNL
@@ -707,22 +728,26 @@
%{ /* NOCONTEXT */
if (! _isNonNilObject(anObject)) {
- RETURN ( nil );
+ RETURN ( nil );
}
RETURN ( _MKSMALLINT( _qSpace(anObject) ) );
%}
+!
+
+flagsOf:anObject
+%{ /* NOCONTEXT */
+
+ if (! _isNonNilObject(anObject)) {
+ RETURN ( nil );
+ }
+ RETURN ( _MKSMALLINT( anObject->o_flags ) );
+%}
"
- |p|
- p := Point new.
- (ObjectMemory spaceOf:p) printNL.
- 1 to:100 do:[:i |
- ObjectMemory scavenge.
- ].
- (ObjectMemory spaceOf:p) printNL.
- 1 to:100 do:[:i |
- ObjectMemory tenuringScavenge.
- ].
- (ObjectMemory spaceOf:p) printNL.
+F_ISREMEMBERED 1 /* a new-space thing on rem-list */
+F_ISFORWARDED 2 /* a forwarded object (only valid after scavenge) */
+F_DEREFERENCED 4 /* a collection after grow (not currently used) */
+F_ISONLIFOLIST 8 /* a non-lifo-context-referencing-obj already on list */
+F_MARK 16 /* mark bit for background collector */
"
!
@@ -734,7 +759,7 @@
%{ /* NOCONTEXT */
if (! _isNonNilObject(anObject)) {
- RETURN ( 0 );
+ RETURN ( 0 );
}
RETURN ( _MKSMALLINT( _GET_AGE(anObject) ) );
%}
@@ -830,7 +855,7 @@
reclaimSymbols
"reclaim unused symbols;
- Unused symbols are (currently) not reclaimed automativally,
+ Unused symbols are (currently) not reclaimed automatically,
but only upon request with this method. It takes some time
to do this ...
Future versions may do this while garbage collecting."
@@ -875,7 +900,11 @@
However, #incrementalGC is interruptable while #markAndSweep
blocks for a while. Thus this method can be called from a low
prio (background) process to collect without disturbing
- foreground processes too much."
+ foreground processes too much.
+ For example, someone allocating huge amounts of memory could
+ ask for the possibility of a quick allocation using
+ #checkForFastNew: and try a #incrementalGC if not. In many
+ cases, this can avoid a pause due to a blocking GC."
[self gcStep] whileFalse:[]
@@ -916,7 +945,7 @@
%{
if (_isSmallInteger(howMuch))
- __moreOldSpace(__context, _intVal(howMuch));
+ __moreOldSpace(__context, _intVal(howMuch));
%}
"
ObjectMemory moreOldSpace:1000000
@@ -931,10 +960,10 @@
Notice: this is a nonstandard interface - use only in special situations."
(self checkForFastNew:howMuch) ifFalse:[
- self incrementalGC.
- (self checkForFastNew:howMuch) ifFalse:[
- self moreOldSpace:howMuch
- ]
+ self incrementalGC.
+ (self checkForFastNew:howMuch) ifFalse:[
+ self moreOldSpace:howMuch
+ ]
]
"
@@ -964,7 +993,7 @@
extern unsigned __oldSpaceIncrement();
if (_isSmallInteger(amount)) {
- RETURN (_MKSMALLINT( __oldSpaceIncrement(_intVal(amount)) ));
+ RETURN (_MKSMALLINT( __oldSpaceIncrement(_intVal(amount)) ));
}
%}
!
@@ -983,9 +1012,9 @@
extern __checkForFastNew();
if (_isSmallInteger(amount)) {
- if (! __checkForFastNew(_intVal(amount))) {
- RETURN (false);
- }
+ if (! __checkForFastNew(_intVal(amount))) {
+ RETURN (false);
+ }
}
%}.
@@ -1023,7 +1052,7 @@
it may vanish. Dont use it."
%{
if (__moveToOldSpace(anObject, __context) < 0) {
- RETURN (false);
+ RETURN (false);
}
%}.
^ true
@@ -1035,7 +1064,7 @@
For internal & debugging use only."
%{
if (__newSpacePagesDo(&aBlock COMMA_CON) < 0) {
- RETURN (false);
+ RETURN (false);
}
%}.
^ true
@@ -1047,7 +1076,7 @@
For internal & debugging use only."
%{
if (__oldSpacePagesDo(&aBlock COMMA_CON) < 0) {
- RETURN (false);
+ RETURN (false);
}
%}.
^ true
@@ -1059,7 +1088,7 @@
For internal & debugging use only."
%{
if (__collectedOldSpacePagesDo(&aBlock COMMA_CON) < 0) {
- RETURN (false);
+ RETURN (false);
}
%}.
^ true
@@ -1078,12 +1107,12 @@
INT addr;
if (_isSmallInteger(aPageNumber)) {
- addr = _intVal(aPageNumber) & ~(pageSize - 1);
+ addr = _intVal(aPageNumber) & ~(pageSize - 1);
} else {
- addr = ((INT)aPageNumber) & ~(pageSize - 1);
+ addr = ((INT)aPageNumber) & ~(pageSize - 1);
}
if (mincore(addr, pageSize-1, result) < 0) {
- RETURN (true);
+ RETURN (true);
}
RETURN ((result[0] & 1) ? true : false);
#endif
@@ -1099,7 +1128,7 @@
remove possibly cached data - this may help a bit"
Smalltalk allClasses do:[:aClass |
- aClass lowSpaceCleanup
+ aClass lowSpaceCleanup
].
self error:'almost out of memory'
@@ -1115,16 +1144,16 @@
fName := self fileNameForClass:aClassName.
fName notNil ifTrue:[
- upd := Class updateChanges:false.
- [
- self loadBinary:(fName , '.o')
- ] valueNowOrOnUnwindDo:[
- Class updateChanges:upd
- ].
- newClass := self at:(aClassName asSymbol).
- (newClass notNil and:[newClass implements:#initialize]) ifTrue:[
- newClass initialize
- ]
+ upd := Class updateChanges:false.
+ [
+ self loadBinary:(fName , '.o')
+ ] valueNowOrOnUnwindDo:[
+ Class updateChanges:upd
+ ].
+ newClass := self at:(aClassName asSymbol).
+ (newClass notNil and:[newClass implements:#initialize]) ifTrue:[
+ newClass initialize
+ ]
]
!
@@ -1133,33 +1162,56 @@
if not running from an image."
^ ImageName
+
+ "
+ ObjectMemory ImageName
+ "
!
nameForSnapshot
- "return the filename of the current image or,
+ "return a reasonable filename to store the snapshot image into.
+ This is the filename of the current image or,
if not running from an image, the default name 'st.img'"
(ImageName isNil or:[ImageName isBlank]) ifTrue:[
- ^ 'st.img'
+ ^ 'st.img'
+ ].
+ (ImageName endsWith:'.sav') ifTrue:[
+ ^ ImageName copyTo:(ImageName size - 4)
].
^ ImageName
+
+ "
+ ObjectMemory nameForSnapshot
+ "
!
snapShot
- "create a snapshot"
+ "create a snapshot file containing all of the current state."
- ImageName isNil ifTrue:[
- ImageName := 'st.img'
- ].
+"/ ImageName isNil ifTrue:[
+"/ ImageName := 'st.img'
+"/ ].
self snapShotOn:(self nameForSnapshot)
- "ObjectMemory snapShot"
+ "
+ ObjectMemory snapShot
+ "
!
snapShotOn:aFileName
"create a snapshot in the given file"
- |ok|
+ |ok oldImageName|
+
+ "
+ keep a save version - just in case something
+ bad happens while writing the image.
+ (could be st/x internal error or file-system errors etc)
+ "
+ (OperatingSystem isValidPath:aFileName) ifTrue:[
+ OperatingSystem renameFile:aFileName to:(aFileName , '.sav').
+ ].
"
give others a chance to fix things
@@ -1170,33 +1222,56 @@
ST-80 compatibility; send #preSnapshot to all classes
"
Smalltalk allClassesDo:[:aClass |
- aClass preSnapshot
+ aClass preSnapshot
].
+ "
+ save the name with it ...
+ "
+ oldImageName := ImageName.
+ ImageName := aFileName.
+ ok := self primSnapShotOn:aFileName.
+ ImageName := oldImageName.
+
+ ok ifTrue:[
+ Class addChangeRecordForSnapshot:aFileName.
+
+
+ "
+ ST-80 compatibility; send #postSnapshot to all classes
+ "
+ Smalltalk allClassesDo:[:aClass |
+ aClass postSnapshot
+ ].
+ ].
+ ^ ok
+
+ "
+ ObjectMemory snapShotOn:'myimage.img'
+ "
+!
+
+primSnapShotOn:aFileName
+ "create a snapshot in the given file.
+ Low level entry. Does not notify classes or write an entry to
+ the changes file. Also, no image backup is created. Returns true if
+ the snapshot worked, false if it failed for some reason.
+ This method should not be used in normal cases."
+
+ |ok|
+
%{ /* STACK:32000 */
OBJ __snapShotOn();
- OBJ retVal;
+ OBJ funny = @symbol(funnySnapshotSymbol);
if (__isString(aFileName)) {
- BLOCKINTERRUPTS();
- ok = __snapShotOn(__context, _stringVal(aFileName));
- UNBLOCKINTERRUPTS();
+ BLOCKINTERRUPTS();
+ ok = __snapShotOn(__context, _stringVal(aFileName), funny);
+ UNBLOCKINTERRUPTS();
}
-%}
-.
- ok ifTrue:[
- Class addChangeRecordForSnapshot:aFileName
- ].
- "
- ST-80 compatibility; send #postSnapshot to all classes
- "
- Smalltalk allClassesDo:[:aClass |
- aClass postSnapshot
- ].
+%}.
^ ok
-
- "ObjectMemory snapShotOn:'myimage.img'"
!
applicationImageOn:aFileName for:startupClass selector:startupSelector
@@ -1246,11 +1321,11 @@
self snapShotOn:'temp.img'.
Display knownViews do:[:aView |
- aView notNil ifTrue:[
- aView superView isNil ifTrue:[
- aView destroy
- ]
- ]
+ aView notNil ifTrue:[
+ aView superView isNil ifTrue:[
+ aView destroy
+ ]
+ ]
].
self stripImage.
@@ -1260,7 +1335,7 @@
"continue in old image"
OperatingSystem exec:(Arguments at:1)
- withArguments:#('smalltalk' '-i' 'temp.img') , (Arguments copyFrom:2)
+ withArguments:#('smalltalk' '-i' 'temp.img') , (Arguments copyFrom:2)
"ObjectMemory minimumApplicationImageOn:'clock1.img' for:Clock selector:#start"
"ObjectMemory applicationImageOn:'clock2.img' for:Clock selector:#start"
@@ -1273,11 +1348,11 @@
"remove all class comments & source"
Smalltalk allBehaviorsDo:[:aClass |
- aClass setComment:nil.
- aClass methodArray do:[:aMethod |
- aMethod source:''.
- aMethod category:#none
- ]
+ aClass setComment:nil.
+ aClass methodArray do:[:aMethod |
+ aMethod source:''.
+ aMethod category:#none
+ ]
].
self garbageCollect
! !
--- a/OrdColl.st Mon Oct 10 01:29:01 1994 +0100
+++ b/OrdColl.st Mon Oct 10 01:29:28 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -11,17 +11,17 @@
"
SequenceableCollection subclass:#OrderedCollection
- instanceVariableNames:'contentsArray firstIndex lastIndex'
- classVariableNames:''
- poolDictionaries:''
- category:'Collections-Sequenceable'
+ instanceVariableNames:'contentsArray firstIndex lastIndex'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Collections-Sequenceable'
!
OrderedCollection comment:'
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Attic/OrdColl.st,v 1.15 1994-08-22 12:11:03 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/OrdColl.st,v 1.16 1994-10-10 00:27:12 claus Exp $
'!
!OrderedCollection class methodsFor:'documentation'!
@@ -29,7 +29,7 @@
copyright
"
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Attic/OrdColl.st,v 1.15 1994-08-22 12:11:03 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/OrdColl.st,v 1.16 1994-10-10 00:27:12 claus Exp $
"
!
@@ -90,6 +90,12 @@
!OrderedCollection methodsFor:'copying'!
+postCopyFrom:someOriginal
+ "have to copy the contentsArray too"
+
+ contentsArray := contentsArray shallowCopy
+!
+
, aCollection
"return a new collection formed from concatenating the receiver with
the argument"
@@ -97,12 +103,12 @@
|newCollection|
newCollection := self species new:(self size + aCollection size).
- newCollection finalizeCopyFrom:self.
+ newCollection postCopyFrom:self.
self do:[:element |
- newCollection add:element
+ newCollection add:element
].
aCollection do:[:element |
- newCollection add:element
+ newCollection add:element
].
^ newCollection
@@ -121,7 +127,7 @@
mySize := self size.
newSize := mySize + 1.
"/ newCollection := self species new:newSize.
- newCollection := (self species new:newSize) finalizeCopyFrom:self.
+ newCollection := (self species new:newSize) postCopyFrom:self.
newCollection grow:newSize.
newCollection replaceFrom:1 to:mySize with:self startingAt:1.
newCollection at:newSize put:newElement.
@@ -153,7 +159,7 @@
sz := stop - start + 1.
"/ newCollection := self species new:sz.
- newCollection := (self species new:sz) finalizeCopyFrom:self.
+ newCollection := (self species new:sz) postCopyFrom:self.
newCollection grow:sz.
newCollection replaceFrom:1 to:sz with:self startingAt:start.
^ newCollection
@@ -167,17 +173,16 @@
|anObject |
firstIndex > lastIndex ifTrue:[
- "error if collection is empty"
- self subscriptBoundsError.
- ^ nil
+ "error if collection is empty"
+ ^ self emptyCollectionError.
].
anObject := contentsArray at:firstIndex.
contentsArray at:firstIndex put:nil.
firstIndex := firstIndex + 1.
firstIndex > lastIndex ifTrue:[
- "reset to avoid ever growing"
- firstIndex := 1.
- lastIndex := 0
+ "reset to avoid ever growing"
+ firstIndex := 1.
+ lastIndex := 0
].
^ anObject
@@ -192,17 +197,16 @@
|anObject |
firstIndex > lastIndex ifTrue:[
- "error if collection is empty"
- self subscriptBoundsError.
- ^ nil
+ "error if collection is empty"
+ ^ self emptyCollectionError.
].
anObject := contentsArray at:lastIndex.
contentsArray at:lastIndex put:nil.
lastIndex := lastIndex - 1.
firstIndex > lastIndex ifTrue:[
- "reset to avoid ever growing"
- firstIndex := 1.
- lastIndex := 0
+ "reset to avoid ever growing"
+ firstIndex := 1.
+ lastIndex := 0
].
^ anObject
@@ -219,18 +223,18 @@
nDeleted := stopIndex - startIndex + 1.
contentsArray replaceFrom:(firstIndex + startIndex)
- to:(lastIndex - nDeleted)
- with:contentsArray
- startingAt:(firstIndex + stopIndex + 1).
+ to:(lastIndex - nDeleted)
+ with:contentsArray
+ startingAt:(firstIndex + stopIndex + 1).
contentsArray from:(lastIndex - nDeleted + 1)
- to:lastIndex
- put:nil.
+ to:lastIndex
+ put:nil.
lastIndex := lastIndex - nDeleted.
firstIndex > lastIndex ifTrue:[
- "reset to avoid ever growing"
- firstIndex := 1.
- lastIndex := 0
+ "reset to avoid ever growing"
+ firstIndex := 1.
+ lastIndex := 0
]
"
@@ -247,19 +251,19 @@
index := firstIndex.
[index <= lastIndex] whileTrue:[
- anObject = (contentsArray at:index) ifTrue:[
- contentsArray replaceFrom:index to:(contentsArray size - 1)
- with:contentsArray startingAt:(index + 1).
- contentsArray at:lastIndex put:nil.
- lastIndex := lastIndex - 1.
- firstIndex > lastIndex ifTrue:[
- "reset to avoid ever growing"
- firstIndex := 1.
- lastIndex := 0
- ].
- ^ anObject
- ].
- index := index + 1
+ anObject = (contentsArray at:index) ifTrue:[
+ contentsArray replaceFrom:index to:(contentsArray size - 1)
+ with:contentsArray startingAt:(index + 1).
+ contentsArray at:lastIndex put:nil.
+ lastIndex := lastIndex - 1.
+ firstIndex > lastIndex ifTrue:[
+ "reset to avoid ever growing"
+ firstIndex := 1.
+ lastIndex := 0
+ ].
+ ^ anObject
+ ].
+ index := index + 1
].
^ exceptionBlock value
!
@@ -275,7 +279,7 @@
Return the argument, anObject."
(lastIndex == contentsArray size) ifTrue:[
- self makeRoomAtLast
+ self makeRoomAtLast
].
lastIndex := lastIndex + 1.
contentsArray at:lastIndex put:anObject.
@@ -293,7 +297,7 @@
Return the argument, anObject."
(firstIndex == 1) ifTrue:[
- self makeRoomAtFront
+ self makeRoomAtFront
].
firstIndex := firstIndex - 1.
contentsArray at:firstIndex put:anObject.
@@ -337,7 +341,7 @@
idx := self indexOf:oldObject.
idx ~~ 0 ifTrue:[
- ^ self add:newObject beforeIndex:(idx + 1).
+ ^ self add:newObject beforeIndex:(idx + 1).
].
self errorNotFound
@@ -359,7 +363,7 @@
idx := self indexOf:oldObject.
idx ~~ 0 ifTrue:[
- ^ self add:newObject beforeIndex:idx.
+ ^ self add:newObject beforeIndex:idx.
].
self errorNotFound
@@ -379,15 +383,15 @@
|newContents oldLast|
newSize <= (lastIndex - firstIndex + 1) ifTrue:[
- oldLast := lastIndex.
- lastIndex := firstIndex + newSize - 1.
- contentsArray from:lastIndex + 1 to:oldLast put:nil.
+ oldLast := lastIndex.
+ lastIndex := firstIndex + newSize - 1.
+ contentsArray from:lastIndex + 1 to:oldLast put:nil.
] ifFalse:[
- newContents := Array new:newSize.
- newContents replaceFrom:1 to:(lastIndex - firstIndex + 1) with:contentsArray.
- contentsArray := newContents.
- firstIndex := 1.
- lastIndex := newSize
+ newContents := Array new:newSize.
+ newContents replaceFrom:1 to:(lastIndex - firstIndex + 1) with:contentsArray.
+ contentsArray := newContents.
+ firstIndex := 1.
+ lastIndex := newSize
]
! !
@@ -400,9 +404,9 @@
idx := anInteger + firstIndex - 1.
((anInteger < 1) or:[idx > lastIndex]) ifTrue:[
- self subscriptBoundsError
+ ^ self subscriptBoundsError:anInteger
] ifFalse:[
- ^ contentsArray at:idx
+ ^ contentsArray at:idx
]
!
@@ -413,9 +417,9 @@
idx := anInteger + firstIndex - 1.
((anInteger < 1) or:[idx > lastIndex]) ifTrue:[
- self subscriptBoundsError
+ ^ self subscriptBoundsError:anInteger
] ifFalse:[
- ^ contentsArray at:idx put:anObject
+ ^ contentsArray at:idx put:anObject
]
!
@@ -423,10 +427,10 @@
"return the first element"
firstIndex <= lastIndex ifTrue:[
- ^ contentsArray at:firstIndex
+ ^ contentsArray at:firstIndex
].
"error if collection is empty"
- self subscriptBoundsError
+ ^ self emptyCollectionError
"(OrderedCollection withAll:#(1 2 3 4 5)) first"
"(SortedCollection withAll:#(5 4 3 2 1)) first"
@@ -436,10 +440,10 @@
"return the last element"
firstIndex <= lastIndex ifTrue:[
- ^ contentsArray at:lastIndex
+ ^ contentsArray at:lastIndex
].
"error if collection is empty"
- self subscriptBoundsError
+ ^ self emptyCollectionError
"(OrderedCollection withAll:#(1 2 3 4 5)) last"
"(SortedCollection withAll:#(5 4 3 2 1)) last"
@@ -454,12 +458,12 @@
end := stop + firstIndex - 1.
((start >= 1) and:[end <= lastIndex]) ifTrue:[
- contentsArray
- replaceFrom:(start + firstIndex - 1)
- to:end
- with:aCollection
- startingAt:repStart.
- ^ self
+ contentsArray
+ replaceFrom:(start + firstIndex - 1)
+ to:end
+ with:aCollection
+ startingAt:repStart.
+ ^ self
].
^ super replaceFrom:start to:stop with:aCollection startingAt:repStart
! !
@@ -487,8 +491,8 @@
idx := self indexOf:anObject.
idx ~~ 0 ifTrue:[
- idx == lastIndex ifTrue:[^ nil].
- ^ self at:(idx + 1).
+ idx == lastIndex ifTrue:[^ nil].
+ ^ self at:(idx + 1).
].
^ exceptionBlock value
@@ -520,8 +524,8 @@
idx := self indexOf:anObject.
idx ~~ 0 ifTrue:[
- idx == firstIndex ifTrue:[^ nil].
- ^ self at:(idx - 1).
+ idx == firstIndex ifTrue:[^ nil].
+ ^ self at:(idx - 1).
].
^ exceptionBlock value
@@ -556,16 +560,16 @@
"if there is lots of room at the beginning (> 50%), shift instead of growing"
oldSize > (sz * 2) ifTrue:[
- startIndex := firstIndex // 4.
- contentsArray
- replaceFrom:startIndex
- to:startIndex + sz - 1
- with:contentsArray
- startingAt:firstIndex.
- contentsArray from:startIndex + sz to:lastIndex put:nil.
- firstIndex := startIndex.
- lastIndex := startIndex + sz - 1.
- ^ self
+ startIndex := firstIndex // 4.
+ contentsArray
+ replaceFrom:startIndex
+ to:startIndex + sz - 1
+ with:contentsArray
+ startingAt:firstIndex.
+ contentsArray from:startIndex + sz to:lastIndex put:nil.
+ firstIndex := startIndex.
+ lastIndex := startIndex + sz - 1.
+ ^ self
].
newSize := oldSize * 2.
newSize == 0 ifTrue:[ newSize := 1].
@@ -585,34 +589,34 @@
oldSize := contentsArray size.
oldSize == 0 ifTrue:[
- contentsArray := Array new:3.
- firstIndex := 2. lastIndex := 1.
- ^ self
+ contentsArray := Array new:3.
+ firstIndex := 2. lastIndex := 1.
+ ^ self
].
sz := self size.
"if there is lots of room at the end (> 50%), shift instead of growing"
oldSize > (sz * 2) ifTrue:[
- startIndex := oldSize // 4.
- contentsArray
- replaceFrom:startIndex
- to:startIndex + sz - 1
- with:contentsArray
- startingAt:1.
- contentsArray from:1 to:(startIndex - 1) put:nil.
- firstIndex := startIndex.
- lastIndex := startIndex + sz - 1.
- ^ self
+ startIndex := oldSize // 4.
+ contentsArray
+ replaceFrom:startIndex
+ to:startIndex + sz - 1
+ with:contentsArray
+ startingAt:1.
+ contentsArray from:1 to:(startIndex - 1) put:nil.
+ firstIndex := startIndex.
+ lastIndex := startIndex + sz - 1.
+ ^ self
].
newSize := oldSize * 2.
newSize == 0 ifTrue:[ newSize := 1].
newContents := Array new:newSize.
newContents
- replaceFrom:(oldSize + 1)
- to:newSize
- with:contentsArray
- startingAt:1.
+ replaceFrom:(oldSize + 1)
+ to:newSize
+ with:contentsArray
+ startingAt:1.
contentsArray := newContents.
firstIndex := firstIndex + oldSize.
lastIndex := lastIndex + oldSize
@@ -631,46 +635,46 @@
oldSize := contentsArray size.
((firstIndex > 1) and:[firstIndex > (oldSize // 4)]) ifTrue:[
- "there is room (>25%) at the beginning"
+ "there is room (>25%) at the beginning"
- index == 1 ifFalse:[
- contentsArray
- replaceFrom:(firstIndex - 1)
- to:(index - 1)
- with:contentsArray
- startingAt:firstIndex.
- contentsArray at:index put:nil.
- ].
- firstIndex := firstIndex - 1.
- ^ self
+ index == 1 ifFalse:[
+ contentsArray
+ replaceFrom:(firstIndex - 1)
+ to:(index - 1)
+ with:contentsArray
+ startingAt:firstIndex.
+ contentsArray at:index put:nil.
+ ].
+ firstIndex := firstIndex - 1.
+ ^ self
].
lastIndex < (oldSize * 3 // 4) ifTrue:[
- "there is room (>25%) at the end"
+ "there is room (>25%) at the end"
- index == (lastIndex + 1) ifFalse:[
- contentsArray
- replaceFrom:(index + 1)
- to:(lastIndex + 1)
- with:contentsArray
- startingAt:index.
- contentsArray at:index put:nil
- ].
- lastIndex := lastIndex + 1.
- ^ self
+ index == (lastIndex + 1) ifFalse:[
+ contentsArray
+ replaceFrom:(index + 1)
+ to:(lastIndex + 1)
+ with:contentsArray
+ startingAt:index.
+ contentsArray at:index put:nil
+ ].
+ lastIndex := lastIndex + 1.
+ ^ self
].
newSize := oldSize * 2.
newContents := Array new:newSize.
index == 1 ifFalse:[
- newContents replaceFrom:1 to:index-1
- with:contentsArray startingAt:1.
+ newContents replaceFrom:1 to:index-1
+ with:contentsArray startingAt:1.
].
index == newSize ifFalse:[
- newContents
- replaceFrom:index + 1
- to:oldSize + 1
- with:contentsArray
- startingAt:index.
+ newContents
+ replaceFrom:index + 1
+ to:oldSize + 1
+ with:contentsArray
+ startingAt:index.
].
contentsArray := newContents.
lastIndex := lastIndex + 1
@@ -746,7 +750,7 @@
"could be an instance of a subclass..."
self class == OrderedCollection ifTrue:[
- ^ self
+ ^ self
].
^ super asOrderedCollection
! !
@@ -776,7 +780,7 @@
stop := lastIndex.
start := firstIndex.
start to:stop do:[:index |
- aTwoArgBlock value:index value:(contentsArray at:index)
+ aTwoArgBlock value:index value:(contentsArray at:index)
]
!
@@ -789,11 +793,11 @@
stop "{ Class:SmallInteger }" |
"/ newCollection := (self species new).
- newCollection := (self species new) finalizeCopyFrom:self.
+ newCollection := (self species new) postCopyFrom:self.
stop := lastIndex.
start := firstIndex.
start to:stop do:[:index |
- newCollection add:(aBlock value:(contentsArray at:index)).
+ newCollection add:(aBlock value:(contentsArray at:index)).
].
^ newCollection
! !
@@ -805,9 +809,9 @@
(instead of the default InspectorView)."
OrderedCollectionInspectorView isNil ifTrue:[
- super inspect
+ super inspect
] ifFalse:[
- OrderedCollectionInspectorView openOn:self
+ OrderedCollectionInspectorView openOn:self
]
"(OrderedCollection withAll:#(3 2 1)) inspect"
--- a/OrderedCollection.st Mon Oct 10 01:29:01 1994 +0100
+++ b/OrderedCollection.st Mon Oct 10 01:29:28 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -11,17 +11,17 @@
"
SequenceableCollection subclass:#OrderedCollection
- instanceVariableNames:'contentsArray firstIndex lastIndex'
- classVariableNames:''
- poolDictionaries:''
- category:'Collections-Sequenceable'
+ instanceVariableNames:'contentsArray firstIndex lastIndex'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Collections-Sequenceable'
!
OrderedCollection comment:'
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/OrderedCollection.st,v 1.15 1994-08-22 12:11:03 claus Exp $
+$Header: /cvs/stx/stx/libbasic/OrderedCollection.st,v 1.16 1994-10-10 00:27:12 claus Exp $
'!
!OrderedCollection class methodsFor:'documentation'!
@@ -29,7 +29,7 @@
copyright
"
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/OrderedCollection.st,v 1.15 1994-08-22 12:11:03 claus Exp $
+$Header: /cvs/stx/stx/libbasic/OrderedCollection.st,v 1.16 1994-10-10 00:27:12 claus Exp $
"
!
@@ -90,6 +90,12 @@
!OrderedCollection methodsFor:'copying'!
+postCopyFrom:someOriginal
+ "have to copy the contentsArray too"
+
+ contentsArray := contentsArray shallowCopy
+!
+
, aCollection
"return a new collection formed from concatenating the receiver with
the argument"
@@ -97,12 +103,12 @@
|newCollection|
newCollection := self species new:(self size + aCollection size).
- newCollection finalizeCopyFrom:self.
+ newCollection postCopyFrom:self.
self do:[:element |
- newCollection add:element
+ newCollection add:element
].
aCollection do:[:element |
- newCollection add:element
+ newCollection add:element
].
^ newCollection
@@ -121,7 +127,7 @@
mySize := self size.
newSize := mySize + 1.
"/ newCollection := self species new:newSize.
- newCollection := (self species new:newSize) finalizeCopyFrom:self.
+ newCollection := (self species new:newSize) postCopyFrom:self.
newCollection grow:newSize.
newCollection replaceFrom:1 to:mySize with:self startingAt:1.
newCollection at:newSize put:newElement.
@@ -153,7 +159,7 @@
sz := stop - start + 1.
"/ newCollection := self species new:sz.
- newCollection := (self species new:sz) finalizeCopyFrom:self.
+ newCollection := (self species new:sz) postCopyFrom:self.
newCollection grow:sz.
newCollection replaceFrom:1 to:sz with:self startingAt:start.
^ newCollection
@@ -167,17 +173,16 @@
|anObject |
firstIndex > lastIndex ifTrue:[
- "error if collection is empty"
- self subscriptBoundsError.
- ^ nil
+ "error if collection is empty"
+ ^ self emptyCollectionError.
].
anObject := contentsArray at:firstIndex.
contentsArray at:firstIndex put:nil.
firstIndex := firstIndex + 1.
firstIndex > lastIndex ifTrue:[
- "reset to avoid ever growing"
- firstIndex := 1.
- lastIndex := 0
+ "reset to avoid ever growing"
+ firstIndex := 1.
+ lastIndex := 0
].
^ anObject
@@ -192,17 +197,16 @@
|anObject |
firstIndex > lastIndex ifTrue:[
- "error if collection is empty"
- self subscriptBoundsError.
- ^ nil
+ "error if collection is empty"
+ ^ self emptyCollectionError.
].
anObject := contentsArray at:lastIndex.
contentsArray at:lastIndex put:nil.
lastIndex := lastIndex - 1.
firstIndex > lastIndex ifTrue:[
- "reset to avoid ever growing"
- firstIndex := 1.
- lastIndex := 0
+ "reset to avoid ever growing"
+ firstIndex := 1.
+ lastIndex := 0
].
^ anObject
@@ -219,18 +223,18 @@
nDeleted := stopIndex - startIndex + 1.
contentsArray replaceFrom:(firstIndex + startIndex)
- to:(lastIndex - nDeleted)
- with:contentsArray
- startingAt:(firstIndex + stopIndex + 1).
+ to:(lastIndex - nDeleted)
+ with:contentsArray
+ startingAt:(firstIndex + stopIndex + 1).
contentsArray from:(lastIndex - nDeleted + 1)
- to:lastIndex
- put:nil.
+ to:lastIndex
+ put:nil.
lastIndex := lastIndex - nDeleted.
firstIndex > lastIndex ifTrue:[
- "reset to avoid ever growing"
- firstIndex := 1.
- lastIndex := 0
+ "reset to avoid ever growing"
+ firstIndex := 1.
+ lastIndex := 0
]
"
@@ -247,19 +251,19 @@
index := firstIndex.
[index <= lastIndex] whileTrue:[
- anObject = (contentsArray at:index) ifTrue:[
- contentsArray replaceFrom:index to:(contentsArray size - 1)
- with:contentsArray startingAt:(index + 1).
- contentsArray at:lastIndex put:nil.
- lastIndex := lastIndex - 1.
- firstIndex > lastIndex ifTrue:[
- "reset to avoid ever growing"
- firstIndex := 1.
- lastIndex := 0
- ].
- ^ anObject
- ].
- index := index + 1
+ anObject = (contentsArray at:index) ifTrue:[
+ contentsArray replaceFrom:index to:(contentsArray size - 1)
+ with:contentsArray startingAt:(index + 1).
+ contentsArray at:lastIndex put:nil.
+ lastIndex := lastIndex - 1.
+ firstIndex > lastIndex ifTrue:[
+ "reset to avoid ever growing"
+ firstIndex := 1.
+ lastIndex := 0
+ ].
+ ^ anObject
+ ].
+ index := index + 1
].
^ exceptionBlock value
!
@@ -275,7 +279,7 @@
Return the argument, anObject."
(lastIndex == contentsArray size) ifTrue:[
- self makeRoomAtLast
+ self makeRoomAtLast
].
lastIndex := lastIndex + 1.
contentsArray at:lastIndex put:anObject.
@@ -293,7 +297,7 @@
Return the argument, anObject."
(firstIndex == 1) ifTrue:[
- self makeRoomAtFront
+ self makeRoomAtFront
].
firstIndex := firstIndex - 1.
contentsArray at:firstIndex put:anObject.
@@ -337,7 +341,7 @@
idx := self indexOf:oldObject.
idx ~~ 0 ifTrue:[
- ^ self add:newObject beforeIndex:(idx + 1).
+ ^ self add:newObject beforeIndex:(idx + 1).
].
self errorNotFound
@@ -359,7 +363,7 @@
idx := self indexOf:oldObject.
idx ~~ 0 ifTrue:[
- ^ self add:newObject beforeIndex:idx.
+ ^ self add:newObject beforeIndex:idx.
].
self errorNotFound
@@ -379,15 +383,15 @@
|newContents oldLast|
newSize <= (lastIndex - firstIndex + 1) ifTrue:[
- oldLast := lastIndex.
- lastIndex := firstIndex + newSize - 1.
- contentsArray from:lastIndex + 1 to:oldLast put:nil.
+ oldLast := lastIndex.
+ lastIndex := firstIndex + newSize - 1.
+ contentsArray from:lastIndex + 1 to:oldLast put:nil.
] ifFalse:[
- newContents := Array new:newSize.
- newContents replaceFrom:1 to:(lastIndex - firstIndex + 1) with:contentsArray.
- contentsArray := newContents.
- firstIndex := 1.
- lastIndex := newSize
+ newContents := Array new:newSize.
+ newContents replaceFrom:1 to:(lastIndex - firstIndex + 1) with:contentsArray.
+ contentsArray := newContents.
+ firstIndex := 1.
+ lastIndex := newSize
]
! !
@@ -400,9 +404,9 @@
idx := anInteger + firstIndex - 1.
((anInteger < 1) or:[idx > lastIndex]) ifTrue:[
- self subscriptBoundsError
+ ^ self subscriptBoundsError:anInteger
] ifFalse:[
- ^ contentsArray at:idx
+ ^ contentsArray at:idx
]
!
@@ -413,9 +417,9 @@
idx := anInteger + firstIndex - 1.
((anInteger < 1) or:[idx > lastIndex]) ifTrue:[
- self subscriptBoundsError
+ ^ self subscriptBoundsError:anInteger
] ifFalse:[
- ^ contentsArray at:idx put:anObject
+ ^ contentsArray at:idx put:anObject
]
!
@@ -423,10 +427,10 @@
"return the first element"
firstIndex <= lastIndex ifTrue:[
- ^ contentsArray at:firstIndex
+ ^ contentsArray at:firstIndex
].
"error if collection is empty"
- self subscriptBoundsError
+ ^ self emptyCollectionError
"(OrderedCollection withAll:#(1 2 3 4 5)) first"
"(SortedCollection withAll:#(5 4 3 2 1)) first"
@@ -436,10 +440,10 @@
"return the last element"
firstIndex <= lastIndex ifTrue:[
- ^ contentsArray at:lastIndex
+ ^ contentsArray at:lastIndex
].
"error if collection is empty"
- self subscriptBoundsError
+ ^ self emptyCollectionError
"(OrderedCollection withAll:#(1 2 3 4 5)) last"
"(SortedCollection withAll:#(5 4 3 2 1)) last"
@@ -454,12 +458,12 @@
end := stop + firstIndex - 1.
((start >= 1) and:[end <= lastIndex]) ifTrue:[
- contentsArray
- replaceFrom:(start + firstIndex - 1)
- to:end
- with:aCollection
- startingAt:repStart.
- ^ self
+ contentsArray
+ replaceFrom:(start + firstIndex - 1)
+ to:end
+ with:aCollection
+ startingAt:repStart.
+ ^ self
].
^ super replaceFrom:start to:stop with:aCollection startingAt:repStart
! !
@@ -487,8 +491,8 @@
idx := self indexOf:anObject.
idx ~~ 0 ifTrue:[
- idx == lastIndex ifTrue:[^ nil].
- ^ self at:(idx + 1).
+ idx == lastIndex ifTrue:[^ nil].
+ ^ self at:(idx + 1).
].
^ exceptionBlock value
@@ -520,8 +524,8 @@
idx := self indexOf:anObject.
idx ~~ 0 ifTrue:[
- idx == firstIndex ifTrue:[^ nil].
- ^ self at:(idx - 1).
+ idx == firstIndex ifTrue:[^ nil].
+ ^ self at:(idx - 1).
].
^ exceptionBlock value
@@ -556,16 +560,16 @@
"if there is lots of room at the beginning (> 50%), shift instead of growing"
oldSize > (sz * 2) ifTrue:[
- startIndex := firstIndex // 4.
- contentsArray
- replaceFrom:startIndex
- to:startIndex + sz - 1
- with:contentsArray
- startingAt:firstIndex.
- contentsArray from:startIndex + sz to:lastIndex put:nil.
- firstIndex := startIndex.
- lastIndex := startIndex + sz - 1.
- ^ self
+ startIndex := firstIndex // 4.
+ contentsArray
+ replaceFrom:startIndex
+ to:startIndex + sz - 1
+ with:contentsArray
+ startingAt:firstIndex.
+ contentsArray from:startIndex + sz to:lastIndex put:nil.
+ firstIndex := startIndex.
+ lastIndex := startIndex + sz - 1.
+ ^ self
].
newSize := oldSize * 2.
newSize == 0 ifTrue:[ newSize := 1].
@@ -585,34 +589,34 @@
oldSize := contentsArray size.
oldSize == 0 ifTrue:[
- contentsArray := Array new:3.
- firstIndex := 2. lastIndex := 1.
- ^ self
+ contentsArray := Array new:3.
+ firstIndex := 2. lastIndex := 1.
+ ^ self
].
sz := self size.
"if there is lots of room at the end (> 50%), shift instead of growing"
oldSize > (sz * 2) ifTrue:[
- startIndex := oldSize // 4.
- contentsArray
- replaceFrom:startIndex
- to:startIndex + sz - 1
- with:contentsArray
- startingAt:1.
- contentsArray from:1 to:(startIndex - 1) put:nil.
- firstIndex := startIndex.
- lastIndex := startIndex + sz - 1.
- ^ self
+ startIndex := oldSize // 4.
+ contentsArray
+ replaceFrom:startIndex
+ to:startIndex + sz - 1
+ with:contentsArray
+ startingAt:1.
+ contentsArray from:1 to:(startIndex - 1) put:nil.
+ firstIndex := startIndex.
+ lastIndex := startIndex + sz - 1.
+ ^ self
].
newSize := oldSize * 2.
newSize == 0 ifTrue:[ newSize := 1].
newContents := Array new:newSize.
newContents
- replaceFrom:(oldSize + 1)
- to:newSize
- with:contentsArray
- startingAt:1.
+ replaceFrom:(oldSize + 1)
+ to:newSize
+ with:contentsArray
+ startingAt:1.
contentsArray := newContents.
firstIndex := firstIndex + oldSize.
lastIndex := lastIndex + oldSize
@@ -631,46 +635,46 @@
oldSize := contentsArray size.
((firstIndex > 1) and:[firstIndex > (oldSize // 4)]) ifTrue:[
- "there is room (>25%) at the beginning"
+ "there is room (>25%) at the beginning"
- index == 1 ifFalse:[
- contentsArray
- replaceFrom:(firstIndex - 1)
- to:(index - 1)
- with:contentsArray
- startingAt:firstIndex.
- contentsArray at:index put:nil.
- ].
- firstIndex := firstIndex - 1.
- ^ self
+ index == 1 ifFalse:[
+ contentsArray
+ replaceFrom:(firstIndex - 1)
+ to:(index - 1)
+ with:contentsArray
+ startingAt:firstIndex.
+ contentsArray at:index put:nil.
+ ].
+ firstIndex := firstIndex - 1.
+ ^ self
].
lastIndex < (oldSize * 3 // 4) ifTrue:[
- "there is room (>25%) at the end"
+ "there is room (>25%) at the end"
- index == (lastIndex + 1) ifFalse:[
- contentsArray
- replaceFrom:(index + 1)
- to:(lastIndex + 1)
- with:contentsArray
- startingAt:index.
- contentsArray at:index put:nil
- ].
- lastIndex := lastIndex + 1.
- ^ self
+ index == (lastIndex + 1) ifFalse:[
+ contentsArray
+ replaceFrom:(index + 1)
+ to:(lastIndex + 1)
+ with:contentsArray
+ startingAt:index.
+ contentsArray at:index put:nil
+ ].
+ lastIndex := lastIndex + 1.
+ ^ self
].
newSize := oldSize * 2.
newContents := Array new:newSize.
index == 1 ifFalse:[
- newContents replaceFrom:1 to:index-1
- with:contentsArray startingAt:1.
+ newContents replaceFrom:1 to:index-1
+ with:contentsArray startingAt:1.
].
index == newSize ifFalse:[
- newContents
- replaceFrom:index + 1
- to:oldSize + 1
- with:contentsArray
- startingAt:index.
+ newContents
+ replaceFrom:index + 1
+ to:oldSize + 1
+ with:contentsArray
+ startingAt:index.
].
contentsArray := newContents.
lastIndex := lastIndex + 1
@@ -746,7 +750,7 @@
"could be an instance of a subclass..."
self class == OrderedCollection ifTrue:[
- ^ self
+ ^ self
].
^ super asOrderedCollection
! !
@@ -776,7 +780,7 @@
stop := lastIndex.
start := firstIndex.
start to:stop do:[:index |
- aTwoArgBlock value:index value:(contentsArray at:index)
+ aTwoArgBlock value:index value:(contentsArray at:index)
]
!
@@ -789,11 +793,11 @@
stop "{ Class:SmallInteger }" |
"/ newCollection := (self species new).
- newCollection := (self species new) finalizeCopyFrom:self.
+ newCollection := (self species new) postCopyFrom:self.
stop := lastIndex.
start := firstIndex.
start to:stop do:[:index |
- newCollection add:(aBlock value:(contentsArray at:index)).
+ newCollection add:(aBlock value:(contentsArray at:index)).
].
^ newCollection
! !
@@ -805,9 +809,9 @@
(instead of the default InspectorView)."
OrderedCollectionInspectorView isNil ifTrue:[
- super inspect
+ super inspect
] ifFalse:[
- OrderedCollectionInspectorView openOn:self
+ OrderedCollectionInspectorView openOn:self
]
"(OrderedCollection withAll:#(3 2 1)) inspect"
--- a/PipeStr.st Mon Oct 10 01:29:01 1994 +0100
+++ b/PipeStr.st Mon Oct 10 01:29:28 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -10,7 +10,7 @@
hereby transferred.
"
-NonPositionableExternalStream subclass:#PipeStream
+UnboundedExternalStream subclass:#PipeStream
instanceVariableNames:'commandString'
classVariableNames:'BrokenPipeSignal'
poolDictionaries:''
@@ -19,9 +19,9 @@
PipeStream comment:'
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Attic/PipeStr.st,v 1.13 1994-08-06 10:32:00 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/PipeStr.st,v 1.14 1994-10-10 00:27:18 claus Exp $
'!
!PipeStream class methodsFor:'documentation'!
@@ -29,7 +29,7 @@
copyright
"
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Attic/PipeStr.st,v 1.13 1994-08-06 10:32:00 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/PipeStr.st,v 1.14 1994-10-10 00:27:18 claus Exp $
"
!
@@ -52,7 +52,7 @@
For example, to get a stream reading the output of an 'ls -l'
command, a PipeStream can be created with:
- PipeStream readingFrom:'ls -l'
+ PipeStream readingFrom:'ls -l'
the characters of the commands output can be read using the
standard stream messages as next, nextLine etc.
@@ -62,18 +62,18 @@
BrokenPipeSignal.
Thus, to handle this condition correctly, the following code is suggested:
- |p|
- p := PipeStream writingTo:'echo hello'.
- PipeStream brokenPipeSignal handle:[:ex |
- 'broken pipe' printNewline.
- p shutDown.
- ex return
- ] do:[
- p nextPutLine:'oops'.
- 'after write' printNewline.
- p close.
- 'after close' printNewline
- ]
+ |p|
+ p := PipeStream writingTo:'echo hello'.
+ PipeStream brokenPipeSignal handle:[:ex |
+ 'broken pipe' printNewline.
+ p shutDown.
+ ex return
+ ] do:[
+ p nextPutLine:'oops'.
+ 'after write' printNewline.
+ p close.
+ 'after close' printNewline
+ ]
Notice, that if the Stream is buffered, the Signal may occur some time after
the write - or even at close time; to avoid a recursive signal in the exception
@@ -96,8 +96,11 @@
"setup the signal"
BrokenPipeSignal isNil ifTrue:[
- BrokenPipeSignal := (Signal new) mayProceed:true.
- BrokenPipeSignal notifierString:'write on a pipe with no one to read'.
+ Object initialize.
+
+ BrokenPipeSignal := Object errorSignal newSignalMayProceed:true.
+ BrokenPipeSignal nameClass:self message:#brokenPipeSignal.
+ BrokenPipeSignal notifierString:'write on a pipe with no one to read'.
]
! !
@@ -153,12 +156,12 @@
extern int _immediateInterrupt;
if (_INST(filePointer) != nil) {
- /*
- * allow interrupt even when blocking here ...
- */
- _immediateInterrupt = 1;
- pclose(MKFD(_INST(filePointer)));
- _immediateInterrupt = 0;
+ /*
+ * allow interrupt even when blocking here ...
+ */
+ _immediateInterrupt = 1;
+ pclose(MKFD(_INST(filePointer)));
+ _immediateInterrupt = 0;
}
#endif
%}
@@ -166,7 +169,7 @@
!PipeStream methodsFor:'private'!
-atEnd
+XXatEnd
"return true, if position is at end"
%{ /* NOCONTEXT */
@@ -177,15 +180,15 @@
int c;
if (_INST(hitEOF) == _true) {
- RETURN (_true);
+ RETURN (_true);
}
if ((t = _INST(filePointer)) != nil) {
- f = MKFD(t);
- if (feof(f)) {
- _INST(hitEOF) = true;
- RETURN (true);
- }
- RETURN ( false );
+ f = MKFD(t);
+ if (feof(f)) {
+ _INST(hitEOF) = true;
+ RETURN (true);
+ }
+ RETURN ( false );
}
#endif
%}
@@ -203,42 +206,42 @@
%{ /* STACK: 32000 */
#ifndef transputer
{
- FILE *f;
- extern errno;
- extern int _immediateInterrupt;
+ FILE *f;
+ extern errno;
+ extern int _immediateInterrupt;
- if (__isString(aCommandString) && __isString(mode)) {
- _immediateInterrupt = 1;
- do {
+ if (__isString(aCommandString) && __isString(mode)) {
+ _immediateInterrupt = 1;
+ do {
#ifdef LINUX
- /* LINUX returns a non-NULL f even when interrupted */
- errno = 0;
- f = (FILE *)popen((char *) _stringVal(aCommandString),
- (char *) _stringVal(mode));
- if (errno == EINTR)
- f = NULL;
+ /* LINUX returns a non-NULL f even when interrupted */
+ errno = 0;
+ f = (FILE *)popen((char *) _stringVal(aCommandString),
+ (char *) _stringVal(mode));
+ if (errno == EINTR)
+ f = NULL;
#else
- f = (FILE *)popen((char *) _stringVal(aCommandString),
- (char *) _stringVal(mode));
+ f = (FILE *)popen((char *) _stringVal(aCommandString),
+ (char *) _stringVal(mode));
#endif
- } while ((f == NULL) && (errno == EINTR));
- _immediateInterrupt = 0;
- if (f == NULL) {
- ExternalStream_LastErrorNumber = _MKSMALLINT(errno);
- } else {
- _INST(filePointer) = MKOBJ(f);
- retVal = self;
- }
- }
+ } while ((f == NULL) && (errno == EINTR));
+ _immediateInterrupt = 0;
+ if (f == NULL) {
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ } else {
+ _INST(filePointer) = MKOBJ(f);
+ retVal = self;
+ }
+ }
}
#endif
%}
.
retVal notNil ifTrue:[
- commandString := aCommandString.
- buffered := true.
- hitEOF := false.
- Lobby register:self
+ commandString := aCommandString.
+ buffered := true.
+ hitEOF := false.
+ Lobby register:self
].
^ retVal
!
--- a/PipeStream.st Mon Oct 10 01:29:01 1994 +0100
+++ b/PipeStream.st Mon Oct 10 01:29:28 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -10,7 +10,7 @@
hereby transferred.
"
-NonPositionableExternalStream subclass:#PipeStream
+UnboundedExternalStream subclass:#PipeStream
instanceVariableNames:'commandString'
classVariableNames:'BrokenPipeSignal'
poolDictionaries:''
@@ -19,9 +19,9 @@
PipeStream comment:'
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/PipeStream.st,v 1.13 1994-08-06 10:32:00 claus Exp $
+$Header: /cvs/stx/stx/libbasic/PipeStream.st,v 1.14 1994-10-10 00:27:18 claus Exp $
'!
!PipeStream class methodsFor:'documentation'!
@@ -29,7 +29,7 @@
copyright
"
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/PipeStream.st,v 1.13 1994-08-06 10:32:00 claus Exp $
+$Header: /cvs/stx/stx/libbasic/PipeStream.st,v 1.14 1994-10-10 00:27:18 claus Exp $
"
!
@@ -52,7 +52,7 @@
For example, to get a stream reading the output of an 'ls -l'
command, a PipeStream can be created with:
- PipeStream readingFrom:'ls -l'
+ PipeStream readingFrom:'ls -l'
the characters of the commands output can be read using the
standard stream messages as next, nextLine etc.
@@ -62,18 +62,18 @@
BrokenPipeSignal.
Thus, to handle this condition correctly, the following code is suggested:
- |p|
- p := PipeStream writingTo:'echo hello'.
- PipeStream brokenPipeSignal handle:[:ex |
- 'broken pipe' printNewline.
- p shutDown.
- ex return
- ] do:[
- p nextPutLine:'oops'.
- 'after write' printNewline.
- p close.
- 'after close' printNewline
- ]
+ |p|
+ p := PipeStream writingTo:'echo hello'.
+ PipeStream brokenPipeSignal handle:[:ex |
+ 'broken pipe' printNewline.
+ p shutDown.
+ ex return
+ ] do:[
+ p nextPutLine:'oops'.
+ 'after write' printNewline.
+ p close.
+ 'after close' printNewline
+ ]
Notice, that if the Stream is buffered, the Signal may occur some time after
the write - or even at close time; to avoid a recursive signal in the exception
@@ -96,8 +96,11 @@
"setup the signal"
BrokenPipeSignal isNil ifTrue:[
- BrokenPipeSignal := (Signal new) mayProceed:true.
- BrokenPipeSignal notifierString:'write on a pipe with no one to read'.
+ Object initialize.
+
+ BrokenPipeSignal := Object errorSignal newSignalMayProceed:true.
+ BrokenPipeSignal nameClass:self message:#brokenPipeSignal.
+ BrokenPipeSignal notifierString:'write on a pipe with no one to read'.
]
! !
@@ -153,12 +156,12 @@
extern int _immediateInterrupt;
if (_INST(filePointer) != nil) {
- /*
- * allow interrupt even when blocking here ...
- */
- _immediateInterrupt = 1;
- pclose(MKFD(_INST(filePointer)));
- _immediateInterrupt = 0;
+ /*
+ * allow interrupt even when blocking here ...
+ */
+ _immediateInterrupt = 1;
+ pclose(MKFD(_INST(filePointer)));
+ _immediateInterrupt = 0;
}
#endif
%}
@@ -166,7 +169,7 @@
!PipeStream methodsFor:'private'!
-atEnd
+XXatEnd
"return true, if position is at end"
%{ /* NOCONTEXT */
@@ -177,15 +180,15 @@
int c;
if (_INST(hitEOF) == _true) {
- RETURN (_true);
+ RETURN (_true);
}
if ((t = _INST(filePointer)) != nil) {
- f = MKFD(t);
- if (feof(f)) {
- _INST(hitEOF) = true;
- RETURN (true);
- }
- RETURN ( false );
+ f = MKFD(t);
+ if (feof(f)) {
+ _INST(hitEOF) = true;
+ RETURN (true);
+ }
+ RETURN ( false );
}
#endif
%}
@@ -203,42 +206,42 @@
%{ /* STACK: 32000 */
#ifndef transputer
{
- FILE *f;
- extern errno;
- extern int _immediateInterrupt;
+ FILE *f;
+ extern errno;
+ extern int _immediateInterrupt;
- if (__isString(aCommandString) && __isString(mode)) {
- _immediateInterrupt = 1;
- do {
+ if (__isString(aCommandString) && __isString(mode)) {
+ _immediateInterrupt = 1;
+ do {
#ifdef LINUX
- /* LINUX returns a non-NULL f even when interrupted */
- errno = 0;
- f = (FILE *)popen((char *) _stringVal(aCommandString),
- (char *) _stringVal(mode));
- if (errno == EINTR)
- f = NULL;
+ /* LINUX returns a non-NULL f even when interrupted */
+ errno = 0;
+ f = (FILE *)popen((char *) _stringVal(aCommandString),
+ (char *) _stringVal(mode));
+ if (errno == EINTR)
+ f = NULL;
#else
- f = (FILE *)popen((char *) _stringVal(aCommandString),
- (char *) _stringVal(mode));
+ f = (FILE *)popen((char *) _stringVal(aCommandString),
+ (char *) _stringVal(mode));
#endif
- } while ((f == NULL) && (errno == EINTR));
- _immediateInterrupt = 0;
- if (f == NULL) {
- ExternalStream_LastErrorNumber = _MKSMALLINT(errno);
- } else {
- _INST(filePointer) = MKOBJ(f);
- retVal = self;
- }
- }
+ } while ((f == NULL) && (errno == EINTR));
+ _immediateInterrupt = 0;
+ if (f == NULL) {
+ _INST(lastErrorNumber) = _MKSMALLINT(errno);
+ } else {
+ _INST(filePointer) = MKOBJ(f);
+ retVal = self;
+ }
+ }
}
#endif
%}
.
retVal notNil ifTrue:[
- commandString := aCommandString.
- buffered := true.
- hitEOF := false.
- Lobby register:self
+ commandString := aCommandString.
+ buffered := true.
+ hitEOF := false.
+ Lobby register:self
].
^ retVal
!
--- a/PosStream.st Mon Oct 10 01:29:01 1994 +0100
+++ b/PosStream.st Mon Oct 10 01:29:28 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -19,9 +19,9 @@
PositionableStream comment:'
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Attic/PosStream.st,v 1.15 1994-08-05 00:59:23 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/PosStream.st,v 1.16 1994-10-10 00:27:25 claus Exp $
'!
!PositionableStream class methodsFor:'documentation'!
@@ -29,7 +29,7 @@
copyright
"
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Attic/PosStream.st,v 1.15 1994-08-05 00:59:23 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/PosStream.st,v 1.16 1994-10-10 00:27:25 claus Exp $
"
!
@@ -61,8 +61,11 @@
"setup the signal used to handle errors during fileIn"
ErrorDuringFileInSignal isNil ifTrue:[
- ErrorDuringFileInSignal := (Signal new) mayProceed:true.
- ErrorDuringFileInSignal notifierString:'error during fileIn'.
+ Object initialize.
+
+ ErrorDuringFileInSignal := Object errorSignal newSignalMayProceed:true.
+ ErrorDuringFileInSignal nameClass:self message:#errorDuringFileInSignal.
+ ErrorDuringFileInSignal notifierString:'error during fileIn'.
]
! !
@@ -150,7 +153,7 @@
otherwise stay and let position unchanged"
self next == something ifTrue:[
- ^ true
+ ^ true
].
self backStep.
^ false
@@ -236,47 +239,47 @@
inPrimitive := false.
[done] whileFalse:[
- ((index + 2) <= currSize) ifFalse:[
- newString := String new:(currSize * 2).
- newString replaceFrom:1 to:currSize with:theString.
- currSize := currSize * 2.
- theString := newString
- ].
- thisChar isNil ifTrue:[
- done := true
- ] ifFalse:[
- (thisChar == $% ) ifTrue:[
- nextChar := self peek.
- (nextChar == ${ ) ifTrue:[
- inPrimitive := true.
- index := index + 1.
- theString at:index put:thisChar.
- thisChar := self next
- ] ifFalse:[
- (nextChar == $} ) ifTrue:[
- inPrimitive := false.
- index := index + 1.
- theString at:index put:thisChar.
- thisChar := self next
- ]
- ]
- ] ifFalse:[
- inPrimitive ifFalse:[
- (thisChar == sep) ifTrue:[
- (self peek == sep) ifFalse:[
- done := true
- ] ifTrue:[
- self next
- ]
- ]
- ]
- ]
- ].
- done ifFalse:[
- index := index + 1.
- theString at:index put:thisChar.
- thisChar := self next
- ]
+ ((index + 2) <= currSize) ifFalse:[
+ newString := String new:(currSize * 2).
+ newString replaceFrom:1 to:currSize with:theString.
+ currSize := currSize * 2.
+ theString := newString
+ ].
+ thisChar isNil ifTrue:[
+ done := true
+ ] ifFalse:[
+ (thisChar == $% ) ifTrue:[
+ nextChar := self peek.
+ (nextChar == ${ ) ifTrue:[
+ inPrimitive := true.
+ index := index + 1.
+ theString at:index put:thisChar.
+ thisChar := self next
+ ] ifFalse:[
+ (nextChar == $} ) ifTrue:[
+ inPrimitive := false.
+ index := index + 1.
+ theString at:index put:thisChar.
+ thisChar := self next
+ ]
+ ]
+ ] ifFalse:[
+ inPrimitive ifFalse:[
+ (thisChar == sep) ifTrue:[
+ (self peek == sep) ifFalse:[
+ done := true
+ ] ifTrue:[
+ self next
+ ]
+ ]
+ ]
+ ]
+ ].
+ done ifFalse:[
+ index := index + 1.
+ theString at:index put:thisChar.
+ thisChar := self next
+ ]
].
(index == 0) ifTrue:[^ ''].
^ theString copyTo:index
@@ -298,48 +301,48 @@
endIndex := aString size.
[index <= endIndex] whileTrue:[
- next := aString indexOf:$% startingAt:index ifAbsent:[endIndex + 1].
- next := next min:
- (aString indexOf:${ startingAt:index ifAbsent:[endIndex + 1]).
- next := next min:
- (aString indexOf:$} startingAt:index ifAbsent:[endIndex + 1]).
- next := next min:
- (aString indexOf:sep startingAt:index ifAbsent:[endIndex + 1]).
+ next := aString indexOf:$% startingAt:index ifAbsent:[endIndex + 1].
+ next := next min:
+ (aString indexOf:${ startingAt:index ifAbsent:[endIndex + 1]).
+ next := next min:
+ (aString indexOf:$} startingAt:index ifAbsent:[endIndex + 1]).
+ next := next min:
+ (aString indexOf:sep startingAt:index ifAbsent:[endIndex + 1]).
- ((index == 1) and:[next == (endIndex + 1)]) ifTrue:[
- self nextPutAll:aString
- ] ifFalse:[
- self nextPutAll:(aString copyFrom:index to:(next - 1))
- ].
+ ((index == 1) and:[next == (endIndex + 1)]) ifTrue:[
+ self nextPutAll:aString
+ ] ifFalse:[
+ self nextPutAll:(aString copyFrom:index to:(next - 1))
+ ].
- index := next.
- (index <= endIndex) ifTrue:[
- character := aString at:index.
- (character == $% ) ifTrue:[
- gotPercent := true
- ] ifFalse:[
- (character == ${ ) ifTrue:[
- gotPercent ifTrue:[
- inPrimitive := true
- ]
- ] ifFalse:[
- (character == $} ) ifTrue:[
- gotPercent ifTrue:[
- inPrimitive := false
- ]
- ] ifFalse:[
- inPrimitive ifFalse:[
- (character == sep) ifTrue:[
- self nextPut:sep
- ]
- ]
- ]
- ].
- gotPercent := false
- ].
- self nextPut:character.
- index := index + 1
- ]
+ index := next.
+ (index <= endIndex) ifTrue:[
+ character := aString at:index.
+ (character == $% ) ifTrue:[
+ gotPercent := true
+ ] ifFalse:[
+ (character == ${ ) ifTrue:[
+ gotPercent ifTrue:[
+ inPrimitive := true
+ ]
+ ] ifFalse:[
+ (character == $} ) ifTrue:[
+ gotPercent ifTrue:[
+ inPrimitive := false
+ ]
+ ] ifFalse:[
+ inPrimitive ifFalse:[
+ (character == sep) ifTrue:[
+ self nextPut:sep
+ ]
+ ]
+ ]
+ ].
+ gotPercent := false
+ ].
+ self nextPut:character.
+ index := index + 1
+ ]
].
self nextPut:sep
! !
@@ -366,39 +369,39 @@
|lastValue|
- SignalSet anySignal handle:[:ex |
- |action what|
+ Object errorSignal handle:[:ex |
+ |action what|
- "handle the case where no GUI has been built in,
- just abort the fileIn with a notification"
+ "handle the case where no GUI has been built in,
+ just abort the fileIn with a notification"
- Display isNil ifTrue:[
- self notify:(ex signal notifierString ,
- ' in ' , ex suspendedContext sender receiver class name ,
- '>>>' , ex suspendedContext sender selector).
- ex return
- ].
+ Display isNil ifTrue:[
+ self notify:(ex signal notifierString ,
+ ' in ' , ex suspendedContext sender receiver class name ,
+ '>>>' , ex suspendedContext sender selector).
+ ex return
+ ].
- "otherwise ask what should be done now and either
- continue or abort the fileIn"
+ "otherwise ask what should be done now and either
+ continue or abort the fileIn"
- what := ex errorString.
- what isNil ifTrue:[
- what := ex signal notifierString.
- ].
- action := self askForDebug:('error in fileIn: ' , what) withCRs.
- action == #continue ifTrue:[
- ex proceed
- ].
- action == #abort ifTrue:[
- ex return
- ].
- Debugger enter:ex suspendedContext
- "ex reject"
+ what := ex errorString.
+ what isNil ifTrue:[
+ what := ex signal notifierString.
+ ].
+ action := self askForDebug:('error in fileIn: ' , what) withCRs.
+ action == #continue ifTrue:[
+ ex proceed
+ ].
+ action == #abort ifTrue:[
+ ex return
+ ].
+ Debugger enter:ex suspendedContext
+ "ex reject"
] do:[
- [self atEnd] whileFalse:[
- lastValue := self fileInNextChunkNotifying:someone
- ]
+ [self atEnd] whileFalse:[
+ lastValue := self fileInNextChunkNotifying:someone
+ ]
].
^ lastValue
!
@@ -407,27 +410,26 @@
"read next chunk, evaluate it and return the result;
someone (which is usually some codeView) is notified of errors."
- |aString sawExcla sep|
+ |aString sawExcla sep rslt|
sep := self class chunkSeparator.
self skipSeparators.
self atEnd ifFalse:[
- sawExcla := self peekFor:sep.
- aString := self nextChunk.
- aString size ~~ 0 ifTrue:[
- sawExcla ifFalse:[
- ^ Compiler evaluate:aString notifying:someone
- ].
- "
- usually, the chunk consists of some methodsFor:-expression
- evaluate it (usually returning a ClassCategoryReader) and
- let this reader compile the methods
- "
- ^ (Compiler evaluate:aString notifying:someone)
- fileInFrom:self notifying:someone
- ]
+ sawExcla := self peekFor:sep.
+ aString := self nextChunk.
+ aString size ~~ 0 ifTrue:[
+ rslt := Compiler evaluate:aString notifying:someone.
+ sawExcla ifTrue:[
+ "
+ usually, the above chunk consists of some methodsFor:-expression
+ in this case, the returned value is a ClassCategoryReader,
+ which is used to load & compile the methods ...
+ "
+ rslt := rslt fileInFrom:self notifying:someone
+ ]
+ ]
].
- ^ nil
+ ^ rslt
!
@@ -439,8 +441,8 @@
box := OptionBox title:message numberOfOptions:3.
box actions:(Array with:[^ #abort]
- with:[^ #debug]
- with:[^ #continue]).
+ with:[^ #debug]
+ with:[^ #continue]).
box buttonTitles:#('abort' 'debug' 'continue').
box showAtPointer.
^ #abort
--- a/PositionableStream.st Mon Oct 10 01:29:01 1994 +0100
+++ b/PositionableStream.st Mon Oct 10 01:29:28 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -19,9 +19,9 @@
PositionableStream comment:'
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/PositionableStream.st,v 1.15 1994-08-05 00:59:23 claus Exp $
+$Header: /cvs/stx/stx/libbasic/PositionableStream.st,v 1.16 1994-10-10 00:27:25 claus Exp $
'!
!PositionableStream class methodsFor:'documentation'!
@@ -29,7 +29,7 @@
copyright
"
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/PositionableStream.st,v 1.15 1994-08-05 00:59:23 claus Exp $
+$Header: /cvs/stx/stx/libbasic/PositionableStream.st,v 1.16 1994-10-10 00:27:25 claus Exp $
"
!
@@ -61,8 +61,11 @@
"setup the signal used to handle errors during fileIn"
ErrorDuringFileInSignal isNil ifTrue:[
- ErrorDuringFileInSignal := (Signal new) mayProceed:true.
- ErrorDuringFileInSignal notifierString:'error during fileIn'.
+ Object initialize.
+
+ ErrorDuringFileInSignal := Object errorSignal newSignalMayProceed:true.
+ ErrorDuringFileInSignal nameClass:self message:#errorDuringFileInSignal.
+ ErrorDuringFileInSignal notifierString:'error during fileIn'.
]
! !
@@ -150,7 +153,7 @@
otherwise stay and let position unchanged"
self next == something ifTrue:[
- ^ true
+ ^ true
].
self backStep.
^ false
@@ -236,47 +239,47 @@
inPrimitive := false.
[done] whileFalse:[
- ((index + 2) <= currSize) ifFalse:[
- newString := String new:(currSize * 2).
- newString replaceFrom:1 to:currSize with:theString.
- currSize := currSize * 2.
- theString := newString
- ].
- thisChar isNil ifTrue:[
- done := true
- ] ifFalse:[
- (thisChar == $% ) ifTrue:[
- nextChar := self peek.
- (nextChar == ${ ) ifTrue:[
- inPrimitive := true.
- index := index + 1.
- theString at:index put:thisChar.
- thisChar := self next
- ] ifFalse:[
- (nextChar == $} ) ifTrue:[
- inPrimitive := false.
- index := index + 1.
- theString at:index put:thisChar.
- thisChar := self next
- ]
- ]
- ] ifFalse:[
- inPrimitive ifFalse:[
- (thisChar == sep) ifTrue:[
- (self peek == sep) ifFalse:[
- done := true
- ] ifTrue:[
- self next
- ]
- ]
- ]
- ]
- ].
- done ifFalse:[
- index := index + 1.
- theString at:index put:thisChar.
- thisChar := self next
- ]
+ ((index + 2) <= currSize) ifFalse:[
+ newString := String new:(currSize * 2).
+ newString replaceFrom:1 to:currSize with:theString.
+ currSize := currSize * 2.
+ theString := newString
+ ].
+ thisChar isNil ifTrue:[
+ done := true
+ ] ifFalse:[
+ (thisChar == $% ) ifTrue:[
+ nextChar := self peek.
+ (nextChar == ${ ) ifTrue:[
+ inPrimitive := true.
+ index := index + 1.
+ theString at:index put:thisChar.
+ thisChar := self next
+ ] ifFalse:[
+ (nextChar == $} ) ifTrue:[
+ inPrimitive := false.
+ index := index + 1.
+ theString at:index put:thisChar.
+ thisChar := self next
+ ]
+ ]
+ ] ifFalse:[
+ inPrimitive ifFalse:[
+ (thisChar == sep) ifTrue:[
+ (self peek == sep) ifFalse:[
+ done := true
+ ] ifTrue:[
+ self next
+ ]
+ ]
+ ]
+ ]
+ ].
+ done ifFalse:[
+ index := index + 1.
+ theString at:index put:thisChar.
+ thisChar := self next
+ ]
].
(index == 0) ifTrue:[^ ''].
^ theString copyTo:index
@@ -298,48 +301,48 @@
endIndex := aString size.
[index <= endIndex] whileTrue:[
- next := aString indexOf:$% startingAt:index ifAbsent:[endIndex + 1].
- next := next min:
- (aString indexOf:${ startingAt:index ifAbsent:[endIndex + 1]).
- next := next min:
- (aString indexOf:$} startingAt:index ifAbsent:[endIndex + 1]).
- next := next min:
- (aString indexOf:sep startingAt:index ifAbsent:[endIndex + 1]).
+ next := aString indexOf:$% startingAt:index ifAbsent:[endIndex + 1].
+ next := next min:
+ (aString indexOf:${ startingAt:index ifAbsent:[endIndex + 1]).
+ next := next min:
+ (aString indexOf:$} startingAt:index ifAbsent:[endIndex + 1]).
+ next := next min:
+ (aString indexOf:sep startingAt:index ifAbsent:[endIndex + 1]).
- ((index == 1) and:[next == (endIndex + 1)]) ifTrue:[
- self nextPutAll:aString
- ] ifFalse:[
- self nextPutAll:(aString copyFrom:index to:(next - 1))
- ].
+ ((index == 1) and:[next == (endIndex + 1)]) ifTrue:[
+ self nextPutAll:aString
+ ] ifFalse:[
+ self nextPutAll:(aString copyFrom:index to:(next - 1))
+ ].
- index := next.
- (index <= endIndex) ifTrue:[
- character := aString at:index.
- (character == $% ) ifTrue:[
- gotPercent := true
- ] ifFalse:[
- (character == ${ ) ifTrue:[
- gotPercent ifTrue:[
- inPrimitive := true
- ]
- ] ifFalse:[
- (character == $} ) ifTrue:[
- gotPercent ifTrue:[
- inPrimitive := false
- ]
- ] ifFalse:[
- inPrimitive ifFalse:[
- (character == sep) ifTrue:[
- self nextPut:sep
- ]
- ]
- ]
- ].
- gotPercent := false
- ].
- self nextPut:character.
- index := index + 1
- ]
+ index := next.
+ (index <= endIndex) ifTrue:[
+ character := aString at:index.
+ (character == $% ) ifTrue:[
+ gotPercent := true
+ ] ifFalse:[
+ (character == ${ ) ifTrue:[
+ gotPercent ifTrue:[
+ inPrimitive := true
+ ]
+ ] ifFalse:[
+ (character == $} ) ifTrue:[
+ gotPercent ifTrue:[
+ inPrimitive := false
+ ]
+ ] ifFalse:[
+ inPrimitive ifFalse:[
+ (character == sep) ifTrue:[
+ self nextPut:sep
+ ]
+ ]
+ ]
+ ].
+ gotPercent := false
+ ].
+ self nextPut:character.
+ index := index + 1
+ ]
].
self nextPut:sep
! !
@@ -366,39 +369,39 @@
|lastValue|
- SignalSet anySignal handle:[:ex |
- |action what|
+ Object errorSignal handle:[:ex |
+ |action what|
- "handle the case where no GUI has been built in,
- just abort the fileIn with a notification"
+ "handle the case where no GUI has been built in,
+ just abort the fileIn with a notification"
- Display isNil ifTrue:[
- self notify:(ex signal notifierString ,
- ' in ' , ex suspendedContext sender receiver class name ,
- '>>>' , ex suspendedContext sender selector).
- ex return
- ].
+ Display isNil ifTrue:[
+ self notify:(ex signal notifierString ,
+ ' in ' , ex suspendedContext sender receiver class name ,
+ '>>>' , ex suspendedContext sender selector).
+ ex return
+ ].
- "otherwise ask what should be done now and either
- continue or abort the fileIn"
+ "otherwise ask what should be done now and either
+ continue or abort the fileIn"
- what := ex errorString.
- what isNil ifTrue:[
- what := ex signal notifierString.
- ].
- action := self askForDebug:('error in fileIn: ' , what) withCRs.
- action == #continue ifTrue:[
- ex proceed
- ].
- action == #abort ifTrue:[
- ex return
- ].
- Debugger enter:ex suspendedContext
- "ex reject"
+ what := ex errorString.
+ what isNil ifTrue:[
+ what := ex signal notifierString.
+ ].
+ action := self askForDebug:('error in fileIn: ' , what) withCRs.
+ action == #continue ifTrue:[
+ ex proceed
+ ].
+ action == #abort ifTrue:[
+ ex return
+ ].
+ Debugger enter:ex suspendedContext
+ "ex reject"
] do:[
- [self atEnd] whileFalse:[
- lastValue := self fileInNextChunkNotifying:someone
- ]
+ [self atEnd] whileFalse:[
+ lastValue := self fileInNextChunkNotifying:someone
+ ]
].
^ lastValue
!
@@ -407,27 +410,26 @@
"read next chunk, evaluate it and return the result;
someone (which is usually some codeView) is notified of errors."
- |aString sawExcla sep|
+ |aString sawExcla sep rslt|
sep := self class chunkSeparator.
self skipSeparators.
self atEnd ifFalse:[
- sawExcla := self peekFor:sep.
- aString := self nextChunk.
- aString size ~~ 0 ifTrue:[
- sawExcla ifFalse:[
- ^ Compiler evaluate:aString notifying:someone
- ].
- "
- usually, the chunk consists of some methodsFor:-expression
- evaluate it (usually returning a ClassCategoryReader) and
- let this reader compile the methods
- "
- ^ (Compiler evaluate:aString notifying:someone)
- fileInFrom:self notifying:someone
- ]
+ sawExcla := self peekFor:sep.
+ aString := self nextChunk.
+ aString size ~~ 0 ifTrue:[
+ rslt := Compiler evaluate:aString notifying:someone.
+ sawExcla ifTrue:[
+ "
+ usually, the above chunk consists of some methodsFor:-expression
+ in this case, the returned value is a ClassCategoryReader,
+ which is used to load & compile the methods ...
+ "
+ rslt := rslt fileInFrom:self notifying:someone
+ ]
+ ]
].
- ^ nil
+ ^ rslt
!
@@ -439,8 +441,8 @@
box := OptionBox title:message numberOfOptions:3.
box actions:(Array with:[^ #abort]
- with:[^ #debug]
- with:[^ #continue]).
+ with:[^ #debug]
+ with:[^ #continue]).
box buttonTitles:#('abort' 'debug' 'continue').
box showAtPointer.
^ #abort
--- a/ProcSched.st Mon Oct 10 01:29:01 1994 +0100
+++ b/ProcSched.st Mon Oct 10 01:29:28 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -11,28 +11,28 @@
"
Object subclass:#ProcessorScheduler
- instanceVariableNames:'quiescentProcessLists scheduler
- zombie
- activeProcess currentPriority
- readFds readSemaphores readChecks
- writeFds writeSemaphores
- timeouts timeoutActions timeoutProcesses timeoutSemaphores
- idleActions anyTimeouts dispatching'
- classVariableNames:'KnownProcesses KnownProcessIds
- PureEventDriven
- UserSchedulingPriority
- UserInterruptPriority
- TimingPriority
- SchedulingPriority'
- poolDictionaries:''
- category:'Kernel-Processes'
+ instanceVariableNames:'quiescentProcessLists scheduler
+ zombie
+ activeProcess currentPriority
+ readFds readSemaphores readChecks
+ writeFds writeSemaphores
+ timeouts timeoutActions timeoutProcesses timeoutSemaphores
+ idleActions anyTimeouts dispatching'
+ classVariableNames:'KnownProcesses KnownProcessIds
+ PureEventDriven
+ UserSchedulingPriority
+ UserInterruptPriority
+ TimingPriority
+ SchedulingPriority'
+ poolDictionaries:''
+ category:'Kernel-Processes'
!
ProcessorScheduler comment:'
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Attic/ProcSched.st,v 1.20 1994-08-23 23:11:00 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/ProcSched.st,v 1.21 1994-10-10 00:27:28 claus Exp $
'!
Smalltalk at:#Processor put:nil!
@@ -42,7 +42,7 @@
copyright
"
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -55,7 +55,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Attic/ProcSched.st,v 1.20 1994-08-23 23:11:00 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/ProcSched.st,v 1.21 1994-10-10 00:27:28 claus Exp $
"
!
@@ -67,11 +67,12 @@
Scheduling is fully done in smalltalk (the always runnable scheduler-
process, running at highest priority does this).
- The main primitive support is used in threadSwitch, which passes
+ The main primitive to support this is found in threadSwitch, which passes
control to another process (usually selected by the scheduler).
- Thus it is possible to modify the schedulers policy.
+ Thus it is possible to modify the schedulers policy and implementation
+ at the smalltalk level.
(To answer a frequently asked question:
- dont add preemtive round-robin here; this can be implemented without
+ dont add preemptive round-robin here; this can be implemented without
any need to change the scheduler. See goodies/timeslicing.st for how
this is done in a very elegant way).
@@ -88,38 +89,38 @@
class variables:
- KnownProcesses <Collection> all known processes
- KnownProcessIds <Collection> and their IDs
- PureEventDriven <Boolean> true, if no process support
- is available
- UserSchedulingPriority <Integer> the priority at which normal
- user interfaces run
- UserInterruptPriority the priority at which user-
- interrupts (Cntl-C) processing
- takes place. Processes with
- a greater or equal priority are
- not interruptable.
- TimingPriority the priority used for timing.
- Processes with a greater or
- equal priority are not interrupted
- by timers.
- SchedulingPriority The priority of the scheduler (must
- me higher than any other).
+ KnownProcesses <Collection> all known processes
+ KnownProcessIds <Collection> and their IDs
+ PureEventDriven <Boolean> true, if no process support
+ is available
+ UserSchedulingPriority <Integer> the priority at which normal
+ user interfaces run
+ UserInterruptPriority the priority at which user-
+ interrupts (Cntl-C) processing
+ takes place. Processes with
+ a greater or equal priority are
+ not interruptable.
+ TimingPriority the priority used for timing.
+ Processes with a greater or
+ equal priority are not interrupted
+ by timers.
+ SchedulingPriority The priority of the scheduler (must
+ me higher than any other).
most interresting methods:
- Processor>>suspend: (see also Process>>suspend)
- Processor>>resume: (see also Process>>resume)
- Processor>>terminate: (see also Process>>terminate)
- Processor>>yield
- Processor>>changePriority:for: (see also Process>>priority:
+ Processor>>suspend: (see also Process>>suspend)
+ Processor>>resume: (see also Process>>resume)
+ Processor>>terminate: (see also Process>>terminate)
+ Processor>>yield
+ Processor>>changePriority:for: (see also Process>>priority:
- Processor>>signal:afterSeconds: (see also Delay>>forSeconds:)
- Processor>>signal:afterMilliseconds: (see also Delay>>forMilliseconds:)
- Processor>>signal:onInput: (see also ExternalStream>>readWait)
- Processor>>signal:onOutput: (see also ExternalStream>>writeWait)
- Processor>>disableSemaphore:
+ Processor>>signal:afterSeconds: (see also Delay>>forSeconds:)
+ Processor>>signal:afterMilliseconds: (see also Delay>>forMilliseconds:)
+ Processor>>signal:onInput: (see also ExternalStream>>readWait)
+ Processor>>signal:onOutput: (see also ExternalStream>>writeWait)
+ Processor>>disableSemaphore:
"
! !
@@ -134,19 +135,10 @@
TimingPriority := 16.
SchedulingPriority := 31.
- KnownProcesses isNil ifTrue:[
- KnownProcesses := WeakArray new:10.
- KnownProcesses watcher:self.
- KnownProcessIds := OrderedCollection new.
+ Processor isNil ifTrue:[
+ "create the one and only processor"
- "want to get informed when returning from snapshot"
- ObjectMemory addDependent:self
- ].
-
- Processor isNil ifTrue:[
- "create the one and only processor"
-
- Processor := self new.
+ Processor := self basicNew initialize.
].
"
@@ -154,33 +146,8 @@
"
PureEventDriven := self threadsAvailable not.
PureEventDriven ifTrue:[
- 'no process support - running event driven' errorPrintNL
+ 'no process support - running event driven' errorPrintNL
].
-!
-
-update:something
- "being a dependent of the ObjectMemory, this is the notification
- that something happened"
-
- something == #restarted ifTrue:[
- self reinstallProcesses
- ]
-!
-
-reinstallProcesses
- "recreate all processes after a snapShot load.
- This is currently not implemented (and might never be).
- All we could do is to restart the processes. Time will show."
-
- KnownProcesses do:[:p |
- p notNil ifTrue:[
- "how, exactly should this be done ?"
-
- p id ~~ 0 ifTrue:[
- 'process restart not implemented' errorPrintNL
- ]
- ]
- ]
! !
!ProcessorScheduler class methodsFor:'instance creation'!
@@ -188,31 +155,31 @@
new
"there is (currently) only one processor ..."
- Processor isNil ifTrue:[
- Processor := self basicNew initialize
- ].
- ^ Processor.
+ self error:'only one processor is allowed in the system'
! !
!ProcessorScheduler class methodsFor:'instance release'!
informDispose
- "some Process has been collected - terminate the underlying thread"
+ "some Process has been garbage collected
+ - terminate the underlying thread. Usually this does not happen,
+ but the thread terminates itself by using #terminate."
|id sz "{ Class: SmallInteger }"|
sz := KnownProcessIds size.
1 to:sz do:[:index |
- (KnownProcesses at:index) isNil ifTrue:[
- id := KnownProcessIds at:index.
- id notNil ifTrue:[
- Transcript showCr:('terminate thread ',
- id printString,
- ' (no longer refd)').
- self threadDestroy:id.
- KnownProcessIds at:index put:nil.
- ]
- ]
+ (KnownProcesses at:index) isNil ifTrue:[
+ id := KnownProcessIds at:index.
+ id notNil ifTrue:[
+ 'PROCESSOR: terminating thread ' errorPrint.
+ id errorPrint.
+ ' (no longer refd)' errorPrintNL.
+
+ self threadDestroy:id.
+ KnownProcessIds at:index put:nil.
+ ]
+ ]
]
! !
@@ -270,13 +237,13 @@
%{ /* NOCONTEXT */
if (_isSmallInteger(id)) {
- __threadInterrupt(_intVal(id));
+ __threadInterrupt(_intVal(id));
}
%}
!
-threadCreate:aBlock
- "physical creation of a process executing aBlock.
+threadCreate:aProcess
+ "physical creation of a process.
(warning: low level entry, no administration done).
This may return nil, if process could not be created."
@@ -284,15 +251,17 @@
int tid;
extern int __threadCreate();
- tid = __threadCreate(aBlock, 0 /* stackSize no longer needed */);
+ tid = __threadCreate(aProcess, 0 /* stackSize no longer needed */);
if (tid != 0) {
- RETURN ( _MKSMALLINT(tid));
+ RETURN ( _MKSMALLINT(tid));
}
%}
.
"
arrive here, if creation of process in VM failed.
- (no memory for process)
+ This may happen, if the VM does not support more processes,
+ or if it ran out of memory, when allocating internal data
+ structures.
"
^ ObjectMemory allocationFailureSignal raise.
!
@@ -304,7 +273,7 @@
%{ /* NOCONTEXT */
if (_isSmallInteger(id)) {
- __threadDestroy(_intVal(id));
+ __threadDestroy(_intVal(id));
}
%}
! !
@@ -317,8 +286,7 @@
|id pri ok oldProcess oldPri p singleStep wasBlocked|
- aProcess isNil ifTrue:[^ self].
- aProcess == activeProcess ifTrue:[^ self].
+ (aProcess isNil or:[aProcess == activeProcess]) ifTrue:[^ self].
wasBlocked := OperatingSystem blockInterrupts.
@@ -329,9 +297,7 @@
pri := aProcess priority.
singleStep := aProcess isSingleStepping.
aProcess state:#active.
- oldProcess state == #active ifTrue:[
- oldProcess state:#run.
- ].
+ oldProcess setStateTo:#run if:#active.
"no interrupts now - activeProcess has already been changed
(dont add any message sends here)"
@@ -341,29 +307,30 @@
extern OBJ __threadSwitch(), __threadSwitchWithSingleStep();
if (singleStep == true)
- ok = __threadSwitchWithSingleStep(__context, _intVal(id));
+ ok = __threadSwitchWithSingleStep(__context, _intVal(id));
else
- ok = __threadSwitch(__context, _intVal(id));
+ ok = __threadSwitch(__context, _intVal(id));
%}.
"time passes ...
... here again"
ok ifFalse:[
- "
- switch failed for some reason -
- destroy the bad process
- "
- p := activeProcess.
- activeProcess := oldProcess.
- currentPriority := oldPri.
- p id ~~ 0 ifTrue:[
- p state:#suspended.
- p terminate.
- ]
+ "
+ switch failed for some reason -
+ destroy the bad process
+ "
+ p := activeProcess.
+ activeProcess := oldProcess.
+ currentPriority := oldPri.
+ p id ~~ 0 ifTrue:[
+ 'process switch failed' errorPrintNL.
+ p state:#suspended.
+ self terminateNoSignal:p.
+ ]
].
zombie notNil ifTrue:[
- self class threadDestroy:zombie.
- zombie := nil
+ self class threadDestroy:zombie.
+ zombie := nil
].
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
!
@@ -457,6 +424,12 @@
|nPrios l p|
+ KnownProcesses isNil ifTrue:[
+ KnownProcesses := WeakArray new:10.
+ KnownProcesses watcher:self class.
+ KnownProcessIds := OrderedCollection new.
+ ].
+
nPrios := SchedulingPriority.
quiescentProcessLists := Array new:nPrios.
@@ -481,10 +454,9 @@
currentPriority := SchedulingPriority.
p := Process new.
- p setId:0.
+ p setId:0 state:#run.
+ p setPriority:currentPriority.
p name:'scheduler'.
- p state:#run.
- p setPriority:currentPriority.
l := LinkedList new.
l add:p.
@@ -496,13 +468,24 @@
ObjectMemory timerInterruptHandler:self.
!
-reInitialize
- "all previous stuff is obsolete - each object should reinstall itself
- upon restart."
+reinitialize
+ "all previous processes are dead - each object should reinstall its
+ process(s) upon restart - especially, windowgroups have to."
+
+ KnownProcesses do:[:p |
+ p notNil ifTrue:[
+ "how, exactly should this be done ?"
- KnownProcesses := WeakArray new:5.
- KnownProcesses watcher:self class.
- KnownProcessIds := OrderedCollection new.
+ 'process restart not implemented' errorPrintNL.
+ p setId:nil state:#dead
+ ].
+ scheduler setId:nil state:#dead
+ ].
+
+ "
+ now, start from scratch
+ "
+ KnownProcesses := nil.
self initialize
! !
@@ -520,17 +503,17 @@
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
+ (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.
@@ -538,10 +521,10 @@
oldSize := KnownProcesses size.
(index > oldSize) ifTrue:[
- newShadow := WeakArray new:(oldSize * 2).
- newShadow watcher:self class.
- newShadow replaceFrom:1 with:KnownProcesses.
- KnownProcesses := newShadow
+ 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].
@@ -555,82 +538,37 @@
wasBlocked := OperatingSystem blockInterrupts.
index := KnownProcesses identityIndexOf:aProcess.
index ~~ 0 ifTrue:[
- KnownProcessIds at:index put:nil.
- KnownProcesses at:index put:nil.
+ KnownProcessIds at:index put:nil.
+ KnownProcesses at:index put:nil.
].
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
! !
!ProcessorScheduler methodsFor:'process creation'!
-newProcessFor:aBlock
- "create a new process executing aBlock.
- Return a process (or nil if fail). The new process is not scheduled.
- To start it running, it needs a Process>>resume."
+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."
- |id p|
+ |id|
- id := self class threadCreate:aBlock.
- id isNil ifTrue:[
- "
- this may happen, if the VM does not support more processes,
- or if it ran out of memory, when allocating internal data
- structures
- "
- self error:'cannot create new Process'.
- ^ nil
- ].
- p := Process new.
- p setId:id.
- p startBlock:aBlock.
- p state:#light. "meaning: has no stack yet"
- p setPriority:currentPriority.
- "
- give it a user-friendly name
- "
- activeProcess name notNil ifTrue:[
- p name:(activeProcess name , ' (sub)')
- ].
- self remember:p.
- ^ p
+ id := self class threadCreate:aProcess.
+ 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 there is always a switch.
- (if you want to implement your own scheduler stuff, uncomment below)"
+ "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
-
-"/ |l p maxPri "{ Class: SmallInteger }"|
-"/
-"/ maxPri := SchedulingPriority.
-"/ maxPri to:1 by:-1 do:[:prio |
-"/ l := quiescentProcessLists at:prio.
-"/ l notNil ifTrue:[
-"/ p := l first.
-"/ p notNil ifTrue:[
-"/ activeProcess state == #active ifTrue:[
-"/ activeProcess state:#run.
-"/ ].
-"/ ^ self threadSwitch:p
-"/ ].
-"/ quiescentProcessLists at:prio put:nil
-"/ ]
-"/ ].
-"/ "
-"/ no process to run - this 'cannot' happen
-"/ (well, not quite: it may happen if the scheduler process is
-"/ suspended - which btw. should be avoided, since noone is there
-"/ to schedule processes then)
-"/ "
-"/
-"/ MiniDebugger enterWithMessage:'fatal dispatcher should never be suspended'.
-"/
-"/ "try to repair by just resuming ..."
-"/ activeProcess resume
!
yield
@@ -647,22 +585,22 @@
debugging consistency checks - will be removed later
"
l isNil ifTrue:[
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
- 'oops - nil runnable list' errorPrintNL.
- ^ self
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+ 'oops - nil runnable list' errorPrintNL.
+ ^ self
].
l isEmpty ifTrue:[
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
- 'oops - empty runnable list' errorPrintNL.
- ^ self
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+ 'oops - empty runnable list' errorPrintNL.
+ ^ self
].
l size == 1 ifTrue:[
- "
- the running one is the only one
- "
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
- ^ self
+ "
+ the running one is the only one
+ "
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+ ^ self
].
"
@@ -690,17 +628,18 @@
some debugging stuff
"
aProcess isNil ifTrue:[
- MiniDebugger enterWithMessage:'nil suspend'.
- ^ self
+ MiniDebugger enterWithMessage:'nil suspend'.
+ ^ self
].
aProcess id isNil ifTrue:[
- MiniDebugger enterWithMessage:'bad suspend: already dead'.
- self reschedule.
- ^ self
+ MiniDebugger enterWithMessage:'bad suspend: already dead'.
+ self threadSwitch:scheduler.
+ ^ self
].
aProcess == scheduler ifTrue:[
- MiniDebugger enterWithMessage:'scheduler should never be suspended'.
- ^ self
+ 'scheduler should never be suspended' printNL.
+ "/ MiniDebugger enterWithMessage:'scheduler should never be suspended'.
+ ^ self
].
wasBlocked := OperatingSystem blockInterrupts.
@@ -712,45 +651,44 @@
debugging consisteny checks - will be removed later
"
l isNil ifTrue:[
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
- 'bad suspend: empty run list' printNL.
- "/ MiniDebugger enterWithMessage:'bad suspend: empty run list'.
- self reschedule.
- ^ self
+ 'bad suspend: empty run list' printNL.
+ "/ MiniDebugger enterWithMessage:'bad suspend: empty run list'.
+ self threadSwitch:scheduler.
+ ^ self
].
l remove:aProcess ifAbsent:[
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
- MiniDebugger enterWithMessage:'bad suspend: not on run list'.
- ^ self
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+ 'bad suspend: not on run list' printNL.
+ "/ MiniDebugger enterWithMessage:'bad suspend: not on run list'.
+ self threadSwitch:scheduler.
+ ^ self
].
l isEmpty ifTrue:[
- quiescentProcessLists at:pri put:nil.
- l := nil
+ quiescentProcessLists at:pri put:nil.
+ l := nil
].
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.
+ 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 ...
"
- s := aProcess state.
- ((s == #active) or:[s == #run]) ifTrue:[
- aProcess state:#suspended.
- ].
+ aProcess setStateTo:#suspended if:#active or:#run.
+
(aProcess == activeProcess) ifTrue:[
- "we can immediately switch sometimes"
- l notNil ifTrue:[
- p := l first
- ] ifFalse:[
- p := scheduler
- ].
- self threadSwitch:p
-"/ self reschedule
+ "we can immediately switch sometimes"
+ l notNil ifTrue:[
+ p := l first
+ ] ifFalse:[
+ p := scheduler
+ ].
+ self threadSwitch:p
].
!
@@ -772,28 +710,28 @@
l := quiescentProcessLists at:pri.
l isNil ifTrue:[
- l := LinkedList new.
- quiescentProcessLists at:pri put:l
+ l := LinkedList new.
+ quiescentProcessLists at:pri put:l
] ifFalse:[
- "if already running, ignore"
- (l includes:aProcess) ifTrue:[
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
- ^ self
- ]
+ "if already running, ignore"
+ (l includes:aProcess) 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
+ "
+ 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
+ "
+ its prio is lower; it will have to wait for a while ...
+ "
+ aProcess state:#run
]
!
@@ -816,36 +754,40 @@
l := quiescentProcessLists at:pri.
l isNil ifTrue:[
- l := LinkedList new.
- quiescentProcessLists at:pri put:l
+ l := LinkedList new.
+ quiescentProcessLists at:pri put:l
] ifFalse:[
- "if already running, ignore"
- (l includes:aProcess) ifTrue:[
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
- ^ self
- ]
+ "if already running, ignore"
+ (l includes:aProcess) 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
- "
+ "
+ its prio is higher; immediately transfer control to it
+ "
"/ activeProcess state:#run.
- self threadSwitch:aProcess
+ self threadSwitch:aProcess
] ifFalse:[
- "
- its prio is lower; it will have to wait for a while ...
- "
- aProcess state:#suspended
+ "
+ its prio is lower; it will have to wait for a while ...
+ "
+ aProcess state:#suspended
]
!
-terminate:aProcess
- "terminate aProcess. If its not the current process, its simply
- removed from its list and destroyed. Otherwise, a switch is forced
- and the process is destroyed by the next running process."
+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|
@@ -853,8 +795,8 @@
id := aProcess id.
id isNil ifTrue:[^ self]. "already dead"
- aProcess setId:nil.
- aProcess startBlock:nil.
+ aProcess setId:nil state:#dead.
+"/ aProcess setStartBlock:nil.
wasBlocked := OperatingSystem blockInterrupts.
@@ -863,48 +805,58 @@
pri := aProcess priority.
l := quiescentProcessLists at:pri.
(l notNil and:[l includes:aProcess]) ifTrue:[
- l remove:aProcess.
- l isEmpty ifTrue:[quiescentProcessLists at:pri put:nil].
+ l remove:aProcess.
+ l isEmpty ifTrue:[quiescentProcessLists at:pri put:nil].
].
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
- aProcess exitAction notNil ifTrue:[
- aProcess exitAction value.
- aProcess exitAction:nil
- ].
-
- aProcess state:#dead.
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.
-"/ self reschedule.
- ^ self
+ "
+ 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
!
-processTermination
- "current process finished its startup block without termination,
- lay him to rest now."
+terminateActiveNoSignal
+ "hard terminate the active process, without sending any
+ terminate signal thus no unwind blocks are evaluated."
+
+ self terminateNoSignal:activeProcess
+!
- self terminate: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
-"/ self reschedule
+!
+
+terminate:aProcess
+ "terminate aProcess. This is deon 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 currently running process kills itself)"
+ "terminate the current process (i.e. the currently running process kills itself).
+ The active process is sent the terminateSignal so it will evaluate any
+ unwind blocks."
- self terminate:activeProcess
+ activeProcess terminate
!
interruptActive
@@ -926,11 +878,11 @@
"
newPrio := prio.
newPrio < 1 ifTrue:[
- newPrio := 1.
+ newPrio := 1.
] ifFalse:[
- newPrio >= SchedulingPriority ifTrue:[
- newPrio := SchedulingPriority - 1
- ]
+ newPrio >= SchedulingPriority ifTrue:[
+ newPrio := SchedulingPriority - 1
+ ]
].
wasBlocked := OperatingSystem blockInterrupts.
@@ -939,8 +891,8 @@
oldList := quiescentProcessLists at:oldPrio.
(oldList isNil or:[(oldList includes:aProcess) not]) ifTrue:[
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
- ^ self
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+ ^ self
].
oldList remove:aProcess.
@@ -948,8 +900,8 @@
newList := quiescentProcessLists at:newPrio.
newList isNil ifTrue:[
- newList := LinkedList new.
- quiescentProcessLists at:newPrio put:newList
+ newList := LinkedList new.
+ quiescentProcessLists at:newPrio put:newList
].
newList addLast:aProcess.
@@ -957,16 +909,15 @@
or another one raising, we have to reschedule"
aProcess == activeProcess ifTrue:[
- currentPriority := newPrio.
- newPrio < oldPrio ifTrue:[
- self threadSwitch:scheduler.
-"/ self reschedule.
- ]
+ currentPriority := newPrio.
+ newPrio < oldPrio ifTrue:[
+ self threadSwitch:scheduler.
+ ]
] ifFalse:[
- newPrio > currentPriority ifTrue:[
+ newPrio > currentPriority ifTrue:[
"/ activeProcess state:#run.
- self threadSwitch:aProcess.
- ]
+ self threadSwitch:aProcess.
+ ]
].
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
! !
@@ -983,7 +934,7 @@
activePriority
"return the priority of the currently running process.
- GNU-ST compatibility; this is the same as currentPriority"
+ GNU-ST & ST-80 compatibility; this is the same as currentPriority"
^ currentPriority
!
@@ -1005,26 +956,26 @@
maxPri := self highestPriority.
maxPri to:1 by:-1 do:[:prio |
- l := quiescentProcessLists at:prio.
- l notNil ifTrue:[
- l isEmpty ifTrue:[
- "
- on the fly clear out empty lists
- "
- quiescentProcessLists at:prio put:nil
- ] ifFalse:[
- p := l first.
- "
- if it got corrupted somehow
- "
- p id isNil ifTrue:[
- 'process with nil id removed' printNL.
- l removeFirst.
- ^ nil.
- ].
- ^ p
- ].
- ]
+ l := quiescentProcessLists at:prio.
+ l notNil ifTrue:[
+ l isEmpty ifTrue:[
+ "
+ on the fly clear out empty lists
+ "
+ quiescentProcessLists at:prio put:nil
+ ] ifFalse:[
+ p := l first.
+ "
+ if it got corrupted somehow
+ "
+ p id isNil ifTrue:[
+ 'process with nil id removed' printNL.
+ l removeFirst.
+ ^ nil.
+ ].
+ ^ p
+ ].
+ ]
].
^ nil
! !
@@ -1042,7 +993,7 @@
of the dispatch-handling code in the running system.
"
[true] whileTrue:[
- self dispatch
+ self dispatch
]
!
@@ -1057,7 +1008,7 @@
handle all timeout actions
"
anyTimeouts ifTrue:[
- self evaluateTimeouts
+ self evaluateTimeouts
].
"first do a quick check using checkActions - this is needed for
@@ -1067,26 +1018,26 @@
any := false.
nActions := readChecks size.
1 to:nActions do:[:index |
- |checkBlock sema action|
+ |checkBlock sema action|
- checkBlock := readChecks at:index.
- (checkBlock notNil and:[checkBlock value]) ifTrue:[
- sema := readSemaphores at:index.
- sema notNil ifTrue:[
- sema signalOnce.
- ].
- any := true.
- ]
+ checkBlock := readChecks at:index.
+ (checkBlock notNil and:[checkBlock value]) ifTrue:[
+ sema := readSemaphores at:index.
+ sema notNil ifTrue:[
+ sema signalOnce.
+ ].
+ any := true.
+ ]
].
"now, someone might be runnable:"
p := self highestPriorityRunnableProcess.
p isNil ifTrue:[
- "no one runnable, hard wait for event or timeout"
+ "no one runnable, hard wait for event or timeout"
- self waitForEventOrTimeout.
- ^ self
+ self waitForEventOrTimeout.
+ ^ self
].
pri := p priority.
@@ -1113,10 +1064,10 @@
"
pri < TimingPriority ifTrue:[
- anyTimeouts ifTrue:[
- millis := self timeToNextTimeout.
- millis == 0 ifTrue:[^ self].
- ]
+ anyTimeouts ifTrue:[
+ millis := self timeToNextTimeout.
+ millis == 0 ifTrue:[^ self].
+ ]
].
"
@@ -1129,30 +1080,30 @@
pri < UserInterruptPriority ifTrue:[
"comment out this if above is uncommented"
- anyTimeouts ifTrue:[
- millis := self timeToNextTimeout.
- millis == 0 ifTrue:[^ self].
- ].
+ anyTimeouts ifTrue:[
+ millis := self timeToNextTimeout.
+ millis == 0 ifTrue:[^ self].
+ ].
"---"
- OperatingSystem supportsIOInterrupts ifTrue:[
- readFds do:[:fd |
- fd notNil ifTrue:[
- OperatingSystem enableIOInterruptsOn:fd
- ].
- ].
- ] ifFalse:[
- millis notNil ifTrue:[
- millis := millis min:50
- ] ifFalse:[
- millis := 50
- ]
- ]
+ OperatingSystem supportsIOInterrupts ifTrue:[
+ readFds do:[:fd |
+ fd notNil ifTrue:[
+ OperatingSystem enableIOInterruptsOn:fd
+ ].
+ ].
+ ] ifFalse:[
+ millis notNil ifTrue:[
+ millis := millis min:50
+ ] ifFalse:[
+ millis := 50
+ ]
+ ]
].
millis notNil ifTrue:[
- "schedule a clock interrupt after millis milliseconds"
- OperatingSystem enableTimer:millis rounded.
+ "schedule a clock interrupt after millis milliseconds"
+ OperatingSystem enableTimer:millis rounded.
].
"now let the process run - will come back here by reschedule
@@ -1164,25 +1115,25 @@
"... when we arrive here, we are back on stage"
millis notNil ifTrue:[
- OperatingSystem disableTimer.
- self checkForInputWithTimeout:0.
+ OperatingSystem disableTimer.
+ self checkForInputWithTimeout:0.
]
! !
!ProcessorScheduler methodsFor:'waiting'!
ioInterrupt
- "data arrived while waiting - reschedule to bring dispatcher into play"
+ "data arrived while waiting - switch to scheduler process which will decide
+ what to do now."
self threadSwitch:scheduler
-"/ self reschedule
!
timerInterrupt
- "timer expired while waiting - reschedule to bring dispatcher into play"
+ "timer expired while waiting - switch to scheduler process which will decide
+ what to do now."
self threadSwitch:scheduler
-"/ self reschedule
!
timeToNextTimeout
@@ -1197,17 +1148,17 @@
n := timeouts size.
1 to:n do:[:index |
- aTime := timeouts at:index.
- aTime notNil ifTrue:[
- minDelta isNil ifTrue:[
- now := OperatingSystem getMillisecondTime.
- (OperatingSystem millisecondTime:aTime isAfter:now) ifFalse:[^ 0].
- minDelta := OperatingSystem millisecondTimeDeltaBetween:aTime and:now.
- ] ifFalse:[
- (OperatingSystem millisecondTime:aTime isAfter:now) ifFalse:[^ 0].
- minDelta := minDelta min:(OperatingSystem millisecondTimeDeltaBetween:aTime and:now)
- ]
- ]
+ aTime := timeouts at:index.
+ aTime notNil ifTrue:[
+ minDelta isNil ifTrue:[
+ now := OperatingSystem getMillisecondTime.
+ (OperatingSystem millisecondTime:aTime isAfter:now) ifFalse:[^ 0].
+ minDelta := OperatingSystem millisecondTimeDeltaBetween:aTime and:now.
+ ] ifFalse:[
+ (OperatingSystem millisecondTime:aTime isAfter:now) ifFalse:[^ 0].
+ minDelta := minDelta min:(OperatingSystem millisecondTimeDeltaBetween:aTime and:now)
+ ]
+ ]
].
^ minDelta
@@ -1224,54 +1175,54 @@
doingGC := true.
[doingGC] whileTrue:[
- anyTimeouts ifTrue:[
- millis := self timeToNextTimeout.
- (millis notNil and:[millis <= 0]) ifTrue:[
- ^ self "oops - hurry up checking"
- ].
- ].
+ anyTimeouts ifTrue:[
+ millis := self timeToNextTimeout.
+ (millis notNil and:[millis <= 0]) ifTrue:[
+ ^ self "oops - hurry up checking"
+ ].
+ ].
- "if its worth doing, collect a bit of garbage"
- limit := ObjectMemory incrementalGCLimit.
- doingGC := limit notNil and:[ObjectMemory oldSpaceAllocatedSinceLastGC > limit].
- doingGC ifTrue:[
- ObjectMemory gcStep.
- ].
+ "if its worth doing, collect a bit of garbage"
+ limit := ObjectMemory incrementalGCLimit.
+ doingGC := limit notNil and:[ObjectMemory oldSpaceAllocatedSinceLastGC > limit].
+ doingGC ifTrue:[
+ ObjectMemory gcStep.
+ ].
- "then do idle actions"
- (idleActions size ~~ 0) ifTrue:[
- idleActions do:[:aBlock |
- aBlock value.
- ].
- ^ self "go back checking"
- ].
+ "then do idle actions"
+ (idleActions size ~~ 0) ifTrue:[
+ idleActions do:[:aBlock |
+ aBlock value.
+ ].
+ ^ self "go back checking"
+ ].
- doingGC ifTrue:[
- (self checkForInputWithTimeout:0) ifTrue:[
- ^ self "go back checking"
- ]
- ]
+ doingGC ifTrue:[
+ (self checkForInputWithTimeout:0) ifTrue:[
+ ^ self "go back checking"
+ ]
+ ]
].
(self checkForInputWithTimeout:0) ifTrue:[
- ^ self "go back checking"
+ ^ self "go back checking"
].
"no, really nothing to do - simply wait"
OperatingSystem supportsSelect ifFalse:[
- "SCO instant ShitStation has a bug here,
- waiting always 1 sec in the select - therefore we delay a bit and
- return - effectively polling in 50ms cycles
- "
- OperatingSystem millisecondDelay:50.
- ^ self
+ "SCO instant ShitStation has a bug here,
+ waiting always 1 sec in the select - therefore we delay a bit and
+ return - effectively polling in 50ms cycles
+ "
+ OperatingSystem millisecondDelay:50.
+ ^ self
].
millis isNil ifTrue:[
- millis := 9999.
+ millis := 9999.
] ifFalse:[
- millis := millis rounded
+ millis := millis rounded
].
self checkForInputWithTimeout:millis
!
@@ -1283,84 +1234,27 @@
|fd index sema action|
fd := OperatingSystem
- selectOnAnyReadable:readFds
- writable:writeFds
- exception:nil
- withTimeOut:millis.
+ selectOnAnyReadable:readFds
+ writable:writeFds
+ exception:nil
+ withTimeOut:millis.
fd notNil ifTrue:[
- index := readFds indexOf:fd.
- index ~~ 0 ifTrue:[
- sema := readSemaphores at:index.
- sema notNil ifTrue:[
- sema signalOnce.
- ^ true
- ] ifFalse:[
- action := readChecks at:index.
- action notNil ifTrue:[
- action value.
- ^ true
- ]
- ]
- ]
+ index := readFds indexOf:fd.
+ index ~~ 0 ifTrue:[
+ sema := readSemaphores at:index.
+ sema notNil ifTrue:[
+ sema signalOnce.
+ ^ true
+ ] ifFalse:[
+ action := readChecks at:index.
+ action notNil ifTrue:[
+ action value.
+ ^ true
+ ]
+ ]
+ ]
].
^ false
-!
-
-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 := timeouts size.
- anyTimeouts := false.
- 1 to:n do:[:index |
- aTime := timeouts at:index.
- aTime notNil ifTrue:[
- (OperatingSystem millisecondTime:aTime isAfter:now) ifFalse:[
- "this one should be triggered"
-
- sema := timeoutSemaphores at:index.
- sema notNil ifTrue:[
- sema signalOnce.
- timeoutSemaphores at:index put:nil
- ] ifFalse:[
- "to support pure-events"
- block := timeoutActions at:index.
- block notNil ifTrue:[
- blocksToEvaluate isNil ifTrue:[
- blocksToEvaluate := OrderedCollection new:10.
- processes := OrderedCollection new:10.
- ].
- blocksToEvaluate add:block.
- processes add:(timeoutProcesses at:index).
- timeoutActions at:index put:nil.
- timeoutProcesses at:index put:nil.
- ]
- ].
- timeouts at:index put:nil.
- ] ifTrue:[
- anyTimeouts := true
- ]
- ]
- ].
-
- blocksToEvaluate notNil ifTrue:[
- 1 to:blocksToEvaluate size do:[:index |
- PureEventDriven ifTrue:[
- (blocksToEvaluate at:index) value
- ] ifFalse:[
- (processes at:index) interruptWith:(blocksToEvaluate at:index)
- ]
- ]
- ]
! !
!ProcessorScheduler methodsFor:'semaphore signalling'!
@@ -1382,16 +1276,16 @@
wasBlocked := OperatingSystem blockInterrupts.
(readFds includes:aFileDescriptor) ifFalse:[
- idx := readFds indexOf:nil.
- idx ~~ 0 ifTrue:[
- readFds at:idx put:aFileDescriptor.
- readSemaphores at:idx put:aSemaphore.
- readChecks at:idx put:aBlock
- ] ifFalse:[
- readFds := readFds copyWith:aFileDescriptor.
- readSemaphores := readSemaphores copyWith:aSemaphore.
- readChecks := readChecks copyWith:aBlock.
- ]
+ idx := readFds indexOf:nil.
+ idx ~~ 0 ifTrue:[
+ readFds at:idx put:aFileDescriptor.
+ readSemaphores at:idx put:aSemaphore.
+ readChecks at:idx put:aBlock
+ ] ifFalse:[
+ readFds := readFds copyWith:aFileDescriptor.
+ readSemaphores := readSemaphores copyWith:aSemaphore.
+ readChecks := readChecks copyWith:aBlock.
+ ]
].
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
!
@@ -1404,14 +1298,14 @@
wasBlocked := OperatingSystem blockInterrupts.
(writeFds includes:aFileDescriptor) ifFalse:[
- idx := writeFds indexOf:nil.
- idx ~~ 0 ifTrue:[
- writeFds at:idx put:aFileDescriptor.
- writeSemaphores at:idx put:aSemaphore.
- ] ifFalse:[
- writeFds := writeFds copyWith:aFileDescriptor.
- writeSemaphores := writeSemaphores copyWith:aSemaphore.
- ]
+ idx := writeFds indexOf:nil.
+ idx ~~ 0 ifTrue:[
+ writeFds at:idx put:aFileDescriptor.
+ writeSemaphores at:idx put:aSemaphore.
+ ] ifFalse:[
+ writeFds := writeFds copyWith:aFileDescriptor.
+ writeSemaphores := writeSemaphores copyWith:aSemaphore.
+ ]
].
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
!
@@ -1442,20 +1336,20 @@
wasBlocked := OperatingSystem blockInterrupts.
index := timeoutSemaphores identityIndexOf:aSemaphore.
index ~~ 0 ifTrue:[
- timeouts at:index put:aMillisecondTime
+ timeouts at:index put:aMillisecondTime
] ifFalse:[
- index := timeouts indexOf:nil.
- index ~~ 0 ifTrue:[
- timeoutSemaphores at:index put:aSemaphore.
- timeouts at:index put:aMillisecondTime.
- timeoutActions at:index put:nil.
- timeoutProcesses at:index put:nil
- ] ifFalse:[
- timeoutSemaphores := timeoutSemaphores copyWith:aSemaphore.
- timeouts := timeouts copyWith:aMillisecondTime.
- timeoutActions := timeoutActions copyWith:nil.
- timeoutProcesses := timeoutProcesses copyWith:nil
- ].
+ index := timeouts indexOf:nil.
+ index ~~ 0 ifTrue:[
+ timeoutSemaphores at:index put:aSemaphore.
+ timeouts at:index put:aMillisecondTime.
+ timeoutActions at:index put:nil.
+ timeoutProcesses at:index put:nil
+ ] ifFalse:[
+ timeoutSemaphores := timeoutSemaphores copyWith:aSemaphore.
+ timeouts := timeouts copyWith:aMillisecondTime.
+ timeoutActions := timeoutActions copyWith:nil.
+ timeoutProcesses := timeoutProcesses copyWith:nil
+ ].
].
anyTimeouts := true.
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
@@ -1469,16 +1363,21 @@
wasBlocked := OperatingSystem blockInterrupts.
idx := readSemaphores identityIndexOf:aSemaphore.
idx ~~ 0 ifTrue:[
- readFds at:idx put:nil.
- readSemaphores at:idx put:nil.
- readChecks at:idx put:nil
+ readFds at:idx put:nil.
+ readSemaphores at:idx put:nil.
+ readChecks at:idx put:nil
+ ].
+ idx := writeSemaphores identityIndexOf:aSemaphore.
+ idx ~~ 0 ifTrue:[
+ writeFds at:idx put:nil.
+ writeSemaphores at:idx put:nil.
].
idx := timeoutSemaphores identityIndexOf:aSemaphore.
idx ~~ 0 ifTrue:[
- timeouts at:idx put:nil.
- timeoutSemaphores at:idx put:nil.
- timeoutActions at:idx put:nil.
- timeoutProcesses at:idx put:nil.
+ timeouts at:idx put:nil.
+ timeoutSemaphores at:idx put:nil.
+ timeoutActions at:idx put:nil.
+ timeoutProcesses at:idx put:nil.
].
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
! !
@@ -1490,16 +1389,16 @@
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. They have been implemented to support
- background actions in pure-event systems, where no processes are
- available.
+ 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 := OrderedCollection new
].
idleActions add:aBlock.
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
@@ -1520,7 +1419,7 @@
!ProcessorScheduler methodsFor:'I/O event actions'!
-enableIOAction:aBlock on:aFileDescriptor
+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."
@@ -1529,16 +1428,16 @@
wasBlocked := OperatingSystem blockInterrupts.
(readFds includes:aFileDescriptor) ifFalse:[
- idx := readFds indexOf:nil.
- idx ~~ 0 ifTrue:[
- readFds at:idx put:aFileDescriptor.
- readChecks at:idx put:aBlock.
- readSemaphores at:idx put:nil
- ] ifFalse:[
- readFds := readFds copyWith:aFileDescriptor.
- readChecks := readChecks copyWith:aBlock.
- readSemaphores := readSemaphores copyWith:nil.
- ]
+ idx := readFds indexOf:nil.
+ idx ~~ 0 ifTrue:[
+ readFds at:idx put:aFileDescriptor.
+ readChecks at:idx put:aBlock.
+ readSemaphores at:idx put:nil
+ ] ifFalse:[
+ readFds := readFds copyWith:aFileDescriptor.
+ readChecks := readChecks copyWith:aBlock.
+ readSemaphores := readSemaphores copyWith:nil.
+ ]
].
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
!
@@ -1552,21 +1451,21 @@
wasBlocked := OperatingSystem blockInterrupts.
idx := readFds indexOf:aFileDescriptor.
idx ~~ 0 ifTrue:[
- readFds at:idx put:nil.
- readChecks at:idx put:nil.
- readSemaphores at:idx put:nil
+ readFds at:idx put:nil.
+ readChecks at:idx put:nil.
+ readSemaphores at:idx put:nil
].
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
! !
-!ProcessorScheduler methodsFor:'timed block'!
+!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 for the execution).
+ 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)."
@@ -1578,7 +1477,9 @@
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 for the execution).
+ 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)."
@@ -1590,7 +1491,7 @@
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 for the execution).
+ 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)."
@@ -1599,10 +1500,12 @@
addTimedBlock:aBlock for:aProcess afterMilliseconds:delta
"add the argument, aBlock to the list of time-scheduled-blocks; to be
- evaluated after delta milliseconds. aProcess will be interrupted for
- execution of the block.
+ 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 for the execution).
+ 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)."
@@ -1621,7 +1524,7 @@
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 for the execution).
+ 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)."
@@ -1631,10 +1534,12 @@
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.
- aProcess will be interrupted for execution of the block.
+ aMillisecondTime. 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 it is running, the interrupt will occur in whatever method it is
- executing; if it is suspended, it will be resumed for the execution).
+ 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)."
@@ -1643,20 +1548,20 @@
wasBlocked := OperatingSystem blockInterrupts.
index := timeoutActions identityIndexOf:aBlock.
index ~~ 0 ifTrue:[
- timeouts at:index put:aMillisecondTime
+ timeouts at:index put:aMillisecondTime
] ifFalse:[
- index := timeouts indexOf:nil.
- index ~~ 0 ifTrue:[
- timeouts at:index put:aMillisecondTime.
- timeoutActions at:index put:aBlock.
- timeoutSemaphores at:index put:nil.
- timeoutProcesses at:index put:aProcess
- ] ifFalse:[
- timeouts := timeouts copyWith:aMillisecondTime.
- timeoutActions := timeoutActions copyWith:aBlock.
- timeoutSemaphores := timeoutSemaphores copyWith:nil.
- timeoutProcesses := timeoutProcesses copyWith:aProcess.
- ].
+ index := timeouts indexOf:nil.
+ index ~~ 0 ifTrue:[
+ timeouts at:index put:aMillisecondTime.
+ timeoutActions at:index put:aBlock.
+ timeoutSemaphores at:index put:nil.
+ timeoutProcesses at:index put:aProcess
+ ] ifFalse:[
+ timeouts := timeouts copyWith:aMillisecondTime.
+ timeoutActions := timeoutActions copyWith:aBlock.
+ timeoutSemaphores := timeoutSemaphores copyWith:nil.
+ timeoutProcesses := timeoutProcesses copyWith:aProcess.
+ ].
].
anyTimeouts := true.
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
@@ -1670,10 +1575,70 @@
wasBlocked := OperatingSystem blockInterrupts.
index := timeoutActions identityIndexOf:aBlock.
(index ~~ 0) ifTrue:[
- timeouts at:index put:nil.
- timeoutActions at:index put:nil.
- timeoutSemaphores at:index put:nil.
- timeoutProcesses at:index put:nil.
+ timeouts at:index put:nil.
+ timeoutActions at:index put:nil.
+ timeoutSemaphores at:index put:nil.
+ timeoutProcesses 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 := timeouts size.
+ anyTimeouts := false.
+ 1 to:n do:[:index |
+ aTime := timeouts at:index.
+ aTime notNil ifTrue:[
+ (OperatingSystem millisecondTime:aTime isAfter:now) ifFalse:[
+ "this one should be triggered"
+
+ sema := timeoutSemaphores at:index.
+ sema notNil ifTrue:[
+ sema signalOnce.
+ timeoutSemaphores at:index put:nil
+ ] ifFalse:[
+ "to support pure-events"
+ block := timeoutActions at:index.
+ block notNil ifTrue:[
+ blocksToEvaluate isNil ifTrue:[
+ blocksToEvaluate := OrderedCollection new:10.
+ processes := OrderedCollection new:10.
+ ].
+ blocksToEvaluate add:block.
+ processes add:(timeoutProcesses at:index).
+ timeoutActions at:index put:nil.
+ timeoutProcesses at:index put:nil.
+ ]
+ ].
+ timeouts at:index put:nil.
+ ] ifTrue:[
+ anyTimeouts := true
+ ]
+ ]
+ ].
+
+ blocksToEvaluate notNil ifTrue:[
+ blocksToEvaluate keysAndValuesDo:[:index :block |
+ |p|
+
+ p := processes at:index.
+ (p isNil or:[PureEventDriven]) ifTrue:[
+ block value
+ ] ifFalse:[
+ p interruptWith:block
+ ]
+ ]
+ ]
! !
--- a/Process.st Mon Oct 10 01:29:01 1994 +0100
+++ b/Process.st Mon Oct 10 01:29:28 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1992 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -11,20 +11,20 @@
"
Link subclass:#Process
- instanceVariableNames:'id prio state startBlock name
- restartable interruptActions
- exitAction singleStepping
- emergencySignalHandler'
- classVariableNames:''
- poolDictionaries:''
- category:'Kernel-Processes'
+ instanceVariableNames:'id prio state startBlock name
+ restartable interruptActions
+ exitAction singleStepping
+ emergencySignalHandler'
+ classVariableNames:'TerminateSignal'
+ poolDictionaries:''
+ category:'Kernel-Processes'
!
Process comment:'
COPYRIGHT (c) 1992 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Process.st,v 1.14 1994-08-22 12:11:52 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Process.st,v 1.15 1994-10-10 00:27:33 claus Exp $
'!
!Process class methodsFor:'documentation'!
@@ -32,7 +32,7 @@
copyright
"
COPYRIGHT (c) 1992 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -45,7 +45,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Process.st,v 1.14 1994-08-22 12:11:52 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Process.st,v 1.15 1994-10-10 00:27:33 claus Exp $
"
!
@@ -73,21 +73,84 @@
Instance variables:
- id <SmallInteger> a unique process-id
- prio <SmallInteger> the processes priority
- state <Symbol> the processes state
- (for process-monitor)
- startBlock <Block> the startup-block
- name <String-or-nil> the processes name (if any)
- (for process-monitor)
- restartable <Boolean> is restartable (not yet implemented)
- interruptActions <Collection> interrupt actions (not yet tested)
- exitAction <Block> action to perform on termination
- emergencySignalHandler <Block> can be used for per-process
- emergency signal handling
+ id <SmallInteger> a unique process-id
+ prio <SmallInteger> the processes priority
+ state <Symbol> the processes state
+ (for process-monitor)
+ startBlock <Block> the startup-block
+ name <String-or-nil> the processes name (if any)
+ (for process-monitor)
+ restartable <Boolean> is restartable (not yet implemented)
+ interruptActions <Collection> interrupt actions as defined by interruptWith:,
+ performed at interrupt time
+ exitAction <Block> action to perform on termination
+ emergencySignalHandler <Block> can be used for per-process
+ emergency signal handling
+ Class variables:
+
+ TerminateSignal <Signal> signal used to terminate processes
+ (should not be cought - or at least
+ rejected in handlers)
"
! !
+!Process class methodsFor:'initialization'!
+
+initialize
+ TerminateSignal isNil ifTrue:[
+ TerminateSignal := Signal new mayProceed:true.
+ TerminateSignal nameClass:self message:#terminateSignal.
+ TerminateSignal notifierString:'unhandled process termination'.
+ ]
+! !
+
+!Process class methodsFor:'signal access'!
+
+terminateSignal
+ ^ TerminateSignal
+! !
+
+!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 methodsFor:'private'!
+
+for:aBlock priority:aPrio
+ "setup the new process - the receiver is not scheduled for
+ execution, to get it running, send it #resume"
+
+ |nm|
+
+ prio := aPrio.
+ startBlock := aBlock.
+
+ (Processor newProcessFor:self) ifFalse:[
+ "for some reason, the Processor was unable to create
+ a VM process for me ...."
+ ^ nil
+ ].
+
+ "
+ give me a user-friendly name
+ "
+ (nm := Processor activeProcess name) notNil ifTrue:[
+ "
+ avoid name inflation
+ "
+ (nm endsWith:'(sub)') ifFalse:[
+ nm := nm , ' (sub)'
+ ].
+ name := nm
+ ]
+! !
+
!Process methodsFor:'accessing'!
state
@@ -102,10 +165,10 @@
state := aSymbol
!
-startBlock:aBlock
- "set the receivers startup block"
+startBlock
+ "return the processes startup-block"
- startBlock := aBlock
+ ^ startBlock
!
emergencySignalHandler:aOneArgBlock
@@ -153,12 +216,6 @@
singleStepping := aBoolean
!
-setPriority:aNumber
- "set priority without telling processor - no public use"
-
- prio := aNumber
-!
-
id
"return the processes id"
@@ -204,7 +261,7 @@
OBJ i;
if (_isSmallInteger(i = _INST(id))) {
- RETURN (__threadContext(_intVal(i)));
+ RETURN (__threadContext(_intVal(i)));
}
%}
.
@@ -220,7 +277,7 @@
OBJ i;
if (_isSmallInteger(i = _INST(id))) {
- RETURN( _MKSMALLINT(__threadUsedStackSize(_intVal(i))) );
+ RETURN( _MKSMALLINT(__threadUsedStackSize(_intVal(i))) );
}
%}
.
@@ -236,7 +293,7 @@
OBJ i;
if (_isSmallInteger(i = _INST(id))) {
- RETURN( _MKSMALLINT(__threadTotalStackSize(_intVal(i))) );
+ RETURN( _MKSMALLINT(__threadTotalStackSize(_intVal(i))) );
}
%}
.
@@ -253,7 +310,7 @@
OBJ i;
if (_isSmallInteger(i = _INST(id))) {
- RETURN( _MKSMALLINT(__threadMaxStackSize(_intVal(i))) );
+ RETURN( _MKSMALLINT(__threadMaxStackSize(_intVal(i))) );
}
%}
.
@@ -272,7 +329,7 @@
if (_isSmallInteger(i = _INST(id))
&& _isSmallInteger(limit) ) {
- RETURN ( _MKSMALLINT(__threadSetMaxStackSize(_intVal(i), _intVal(limit))) );
+ RETURN ( _MKSMALLINT(__threadSetMaxStackSize(_intVal(i), _intVal(limit))) );
}
%}
.
@@ -281,17 +338,63 @@
!Process methodsFor:'private scheduler access'!
-setId:aNumber
- "set the processes id"
+setPriority:aNumber
+ "set priority without telling processor - not for public use"
+
+ prio := aNumber
+!
+
+setStartBlock:aBlock
+ "set the receivers startup block"
+
+ startBlock := aBlock
+!
- id := aNumber
+setStateTo:newState if:oldState
+ state == oldState ifTrue:[state := newState]
+!
+
+setStateTo:newState if:oldState1 or:oldState2
+ (state == oldState1 or:[state == oldState2]) ifTrue:[state := newState]
+!
+
+setId:idNumber state:stateSymbol
+ "set id and state - not for public use"
+
+ id := idNumber.
+ state := stateSymbol.
!
start
- "start the process (sent from VM)"
+ "start the process - this is sent by the VM to the process to get
+ the process up and running.
+ Sending start to the process allows more flexible handling
+ of processes, since anything that responds to #start can be handled
+ by the VM then ..."
+
+ |block|
- startBlock notNil ifTrue:[
- startBlock value.
+ (block := startBlock) notNil ifTrue:[
+ "
+ just for your convenience ...
+ "
+ name isNil ifTrue:[
+ name := '(' , startBlock displayString , ')'
+ ].
+ startBlock := nil.
+ TerminateSignal handle:[:ex |
+ ex return
+ ] do:[
+ block value
+ ].
+ (block := exitAction) notNil ifTrue:[
+ exitAction := nil.
+ block value.
+ ].
+ Processor terminateActiveNoSignal
+ ] ifFalse:[
+ "is this artificial restriction useful ?"
+ self error:'a process cannot be started twice'
]
! !
@@ -316,52 +419,105 @@
!
terminate
- "terminate the receiver process"
+ "terminate the receiver process. All unwind actions and the exit-action (if any)
+ will be performed before the process is really terminated."
- Processor terminate:self
+ Processor activeProcess == self ifTrue:[
+ Signal noHandlerSignal handle:[:ex |
+ ex return.
+ ] do:[
+ TerminateSignal raise.
+ ].
+ Processor terminateNoSignal:self
+ ] ifFalse:[
+ self interruptWith:[self terminate]
+ ]
+!
+
+terminateNoSignal
+ "terminate the receiver process without performing any unwind- or exit-actions"
+
+ Processor terminateNoSignal:self
! !
-!Process methodsFor:'special'!
+!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."
- |wasBlocked|
-
- wasBlocked := OperatingSystem blockInterrupts.
- interruptActions isNil ifTrue:[
- interruptActions := OrderedCollection with:aBlock.
- ] ifFalse:[
- interruptActions addLast:aBlock.
+ self uninterruptablyDo:[
+ interruptActions isNil ifTrue:[
+ interruptActions := OrderedCollection with:aBlock.
+ ] ifFalse:[
+ interruptActions addLast:aBlock.
+ ].
].
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
Processor scheduleForInterrupt:self.
!
interrupt
- "
- evaluate my interrupt-actions
+ "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
+ 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
+ ]
+!
+
+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
+!
+
+uninterruptablyDo:aBlock
+ "execute aBlock with interrupts blocked. This does not prevent
+ preemption by higher priority processes."
+
+ |wasBlocked|
+
+ "we must keep track of blocking-state if this is called nested"
+
+ wasBlocked := OperatingSystem blockInterrupts.
+ ^ aBlock valueNowOrOnUnwindDo:[
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts]
+ ]
+! !
!Process methodsFor:'printing & storing'!
printOn:aStream
aStream nextPutAll:state article;
- space;
- nextPutAll:state;
- nextPutAll:' Process (';
- nextPutAll:self nameOrId;
- nextPutAll:')'
+ space;
+ nextPutAll:state;
+ nextPutAll:' Process (';
+ nextPutAll:self nameOrId;
+ nextPutAll:')'
! !
--- a/ProcessorScheduler.st Mon Oct 10 01:29:01 1994 +0100
+++ b/ProcessorScheduler.st Mon Oct 10 01:29:28 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -11,28 +11,28 @@
"
Object subclass:#ProcessorScheduler
- instanceVariableNames:'quiescentProcessLists scheduler
- zombie
- activeProcess currentPriority
- readFds readSemaphores readChecks
- writeFds writeSemaphores
- timeouts timeoutActions timeoutProcesses timeoutSemaphores
- idleActions anyTimeouts dispatching'
- classVariableNames:'KnownProcesses KnownProcessIds
- PureEventDriven
- UserSchedulingPriority
- UserInterruptPriority
- TimingPriority
- SchedulingPriority'
- poolDictionaries:''
- category:'Kernel-Processes'
+ instanceVariableNames:'quiescentProcessLists scheduler
+ zombie
+ activeProcess currentPriority
+ readFds readSemaphores readChecks
+ writeFds writeSemaphores
+ timeouts timeoutActions timeoutProcesses timeoutSemaphores
+ idleActions anyTimeouts dispatching'
+ classVariableNames:'KnownProcesses KnownProcessIds
+ PureEventDriven
+ UserSchedulingPriority
+ UserInterruptPriority
+ TimingPriority
+ SchedulingPriority'
+ poolDictionaries:''
+ category:'Kernel-Processes'
!
ProcessorScheduler comment:'
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/ProcessorScheduler.st,v 1.20 1994-08-23 23:11:00 claus Exp $
+$Header: /cvs/stx/stx/libbasic/ProcessorScheduler.st,v 1.21 1994-10-10 00:27:28 claus Exp $
'!
Smalltalk at:#Processor put:nil!
@@ -42,7 +42,7 @@
copyright
"
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -55,7 +55,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/ProcessorScheduler.st,v 1.20 1994-08-23 23:11:00 claus Exp $
+$Header: /cvs/stx/stx/libbasic/ProcessorScheduler.st,v 1.21 1994-10-10 00:27:28 claus Exp $
"
!
@@ -67,11 +67,12 @@
Scheduling is fully done in smalltalk (the always runnable scheduler-
process, running at highest priority does this).
- The main primitive support is used in threadSwitch, which passes
+ The main primitive to support this is found in threadSwitch, which passes
control to another process (usually selected by the scheduler).
- Thus it is possible to modify the schedulers policy.
+ Thus it is possible to modify the schedulers policy and implementation
+ at the smalltalk level.
(To answer a frequently asked question:
- dont add preemtive round-robin here; this can be implemented without
+ dont add preemptive round-robin here; this can be implemented without
any need to change the scheduler. See goodies/timeslicing.st for how
this is done in a very elegant way).
@@ -88,38 +89,38 @@
class variables:
- KnownProcesses <Collection> all known processes
- KnownProcessIds <Collection> and their IDs
- PureEventDriven <Boolean> true, if no process support
- is available
- UserSchedulingPriority <Integer> the priority at which normal
- user interfaces run
- UserInterruptPriority the priority at which user-
- interrupts (Cntl-C) processing
- takes place. Processes with
- a greater or equal priority are
- not interruptable.
- TimingPriority the priority used for timing.
- Processes with a greater or
- equal priority are not interrupted
- by timers.
- SchedulingPriority The priority of the scheduler (must
- me higher than any other).
+ KnownProcesses <Collection> all known processes
+ KnownProcessIds <Collection> and their IDs
+ PureEventDriven <Boolean> true, if no process support
+ is available
+ UserSchedulingPriority <Integer> the priority at which normal
+ user interfaces run
+ UserInterruptPriority the priority at which user-
+ interrupts (Cntl-C) processing
+ takes place. Processes with
+ a greater or equal priority are
+ not interruptable.
+ TimingPriority the priority used for timing.
+ Processes with a greater or
+ equal priority are not interrupted
+ by timers.
+ SchedulingPriority The priority of the scheduler (must
+ me higher than any other).
most interresting methods:
- Processor>>suspend: (see also Process>>suspend)
- Processor>>resume: (see also Process>>resume)
- Processor>>terminate: (see also Process>>terminate)
- Processor>>yield
- Processor>>changePriority:for: (see also Process>>priority:
+ Processor>>suspend: (see also Process>>suspend)
+ Processor>>resume: (see also Process>>resume)
+ Processor>>terminate: (see also Process>>terminate)
+ Processor>>yield
+ Processor>>changePriority:for: (see also Process>>priority:
- Processor>>signal:afterSeconds: (see also Delay>>forSeconds:)
- Processor>>signal:afterMilliseconds: (see also Delay>>forMilliseconds:)
- Processor>>signal:onInput: (see also ExternalStream>>readWait)
- Processor>>signal:onOutput: (see also ExternalStream>>writeWait)
- Processor>>disableSemaphore:
+ Processor>>signal:afterSeconds: (see also Delay>>forSeconds:)
+ Processor>>signal:afterMilliseconds: (see also Delay>>forMilliseconds:)
+ Processor>>signal:onInput: (see also ExternalStream>>readWait)
+ Processor>>signal:onOutput: (see also ExternalStream>>writeWait)
+ Processor>>disableSemaphore:
"
! !
@@ -134,19 +135,10 @@
TimingPriority := 16.
SchedulingPriority := 31.
- KnownProcesses isNil ifTrue:[
- KnownProcesses := WeakArray new:10.
- KnownProcesses watcher:self.
- KnownProcessIds := OrderedCollection new.
+ Processor isNil ifTrue:[
+ "create the one and only processor"
- "want to get informed when returning from snapshot"
- ObjectMemory addDependent:self
- ].
-
- Processor isNil ifTrue:[
- "create the one and only processor"
-
- Processor := self new.
+ Processor := self basicNew initialize.
].
"
@@ -154,33 +146,8 @@
"
PureEventDriven := self threadsAvailable not.
PureEventDriven ifTrue:[
- 'no process support - running event driven' errorPrintNL
+ 'no process support - running event driven' errorPrintNL
].
-!
-
-update:something
- "being a dependent of the ObjectMemory, this is the notification
- that something happened"
-
- something == #restarted ifTrue:[
- self reinstallProcesses
- ]
-!
-
-reinstallProcesses
- "recreate all processes after a snapShot load.
- This is currently not implemented (and might never be).
- All we could do is to restart the processes. Time will show."
-
- KnownProcesses do:[:p |
- p notNil ifTrue:[
- "how, exactly should this be done ?"
-
- p id ~~ 0 ifTrue:[
- 'process restart not implemented' errorPrintNL
- ]
- ]
- ]
! !
!ProcessorScheduler class methodsFor:'instance creation'!
@@ -188,31 +155,31 @@
new
"there is (currently) only one processor ..."
- Processor isNil ifTrue:[
- Processor := self basicNew initialize
- ].
- ^ Processor.
+ self error:'only one processor is allowed in the system'
! !
!ProcessorScheduler class methodsFor:'instance release'!
informDispose
- "some Process has been collected - terminate the underlying thread"
+ "some Process has been garbage collected
+ - terminate the underlying thread. Usually this does not happen,
+ but the thread terminates itself by using #terminate."
|id sz "{ Class: SmallInteger }"|
sz := KnownProcessIds size.
1 to:sz do:[:index |
- (KnownProcesses at:index) isNil ifTrue:[
- id := KnownProcessIds at:index.
- id notNil ifTrue:[
- Transcript showCr:('terminate thread ',
- id printString,
- ' (no longer refd)').
- self threadDestroy:id.
- KnownProcessIds at:index put:nil.
- ]
- ]
+ (KnownProcesses at:index) isNil ifTrue:[
+ id := KnownProcessIds at:index.
+ id notNil ifTrue:[
+ 'PROCESSOR: terminating thread ' errorPrint.
+ id errorPrint.
+ ' (no longer refd)' errorPrintNL.
+
+ self threadDestroy:id.
+ KnownProcessIds at:index put:nil.
+ ]
+ ]
]
! !
@@ -270,13 +237,13 @@
%{ /* NOCONTEXT */
if (_isSmallInteger(id)) {
- __threadInterrupt(_intVal(id));
+ __threadInterrupt(_intVal(id));
}
%}
!
-threadCreate:aBlock
- "physical creation of a process executing aBlock.
+threadCreate:aProcess
+ "physical creation of a process.
(warning: low level entry, no administration done).
This may return nil, if process could not be created."
@@ -284,15 +251,17 @@
int tid;
extern int __threadCreate();
- tid = __threadCreate(aBlock, 0 /* stackSize no longer needed */);
+ tid = __threadCreate(aProcess, 0 /* stackSize no longer needed */);
if (tid != 0) {
- RETURN ( _MKSMALLINT(tid));
+ RETURN ( _MKSMALLINT(tid));
}
%}
.
"
arrive here, if creation of process in VM failed.
- (no memory for process)
+ This may happen, if the VM does not support more processes,
+ or if it ran out of memory, when allocating internal data
+ structures.
"
^ ObjectMemory allocationFailureSignal raise.
!
@@ -304,7 +273,7 @@
%{ /* NOCONTEXT */
if (_isSmallInteger(id)) {
- __threadDestroy(_intVal(id));
+ __threadDestroy(_intVal(id));
}
%}
! !
@@ -317,8 +286,7 @@
|id pri ok oldProcess oldPri p singleStep wasBlocked|
- aProcess isNil ifTrue:[^ self].
- aProcess == activeProcess ifTrue:[^ self].
+ (aProcess isNil or:[aProcess == activeProcess]) ifTrue:[^ self].
wasBlocked := OperatingSystem blockInterrupts.
@@ -329,9 +297,7 @@
pri := aProcess priority.
singleStep := aProcess isSingleStepping.
aProcess state:#active.
- oldProcess state == #active ifTrue:[
- oldProcess state:#run.
- ].
+ oldProcess setStateTo:#run if:#active.
"no interrupts now - activeProcess has already been changed
(dont add any message sends here)"
@@ -341,29 +307,30 @@
extern OBJ __threadSwitch(), __threadSwitchWithSingleStep();
if (singleStep == true)
- ok = __threadSwitchWithSingleStep(__context, _intVal(id));
+ ok = __threadSwitchWithSingleStep(__context, _intVal(id));
else
- ok = __threadSwitch(__context, _intVal(id));
+ ok = __threadSwitch(__context, _intVal(id));
%}.
"time passes ...
... here again"
ok ifFalse:[
- "
- switch failed for some reason -
- destroy the bad process
- "
- p := activeProcess.
- activeProcess := oldProcess.
- currentPriority := oldPri.
- p id ~~ 0 ifTrue:[
- p state:#suspended.
- p terminate.
- ]
+ "
+ switch failed for some reason -
+ destroy the bad process
+ "
+ p := activeProcess.
+ activeProcess := oldProcess.
+ currentPriority := oldPri.
+ p id ~~ 0 ifTrue:[
+ 'process switch failed' errorPrintNL.
+ p state:#suspended.
+ self terminateNoSignal:p.
+ ]
].
zombie notNil ifTrue:[
- self class threadDestroy:zombie.
- zombie := nil
+ self class threadDestroy:zombie.
+ zombie := nil
].
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
!
@@ -457,6 +424,12 @@
|nPrios l p|
+ KnownProcesses isNil ifTrue:[
+ KnownProcesses := WeakArray new:10.
+ KnownProcesses watcher:self class.
+ KnownProcessIds := OrderedCollection new.
+ ].
+
nPrios := SchedulingPriority.
quiescentProcessLists := Array new:nPrios.
@@ -481,10 +454,9 @@
currentPriority := SchedulingPriority.
p := Process new.
- p setId:0.
+ p setId:0 state:#run.
+ p setPriority:currentPriority.
p name:'scheduler'.
- p state:#run.
- p setPriority:currentPriority.
l := LinkedList new.
l add:p.
@@ -496,13 +468,24 @@
ObjectMemory timerInterruptHandler:self.
!
-reInitialize
- "all previous stuff is obsolete - each object should reinstall itself
- upon restart."
+reinitialize
+ "all previous processes are dead - each object should reinstall its
+ process(s) upon restart - especially, windowgroups have to."
+
+ KnownProcesses do:[:p |
+ p notNil ifTrue:[
+ "how, exactly should this be done ?"
- KnownProcesses := WeakArray new:5.
- KnownProcesses watcher:self class.
- KnownProcessIds := OrderedCollection new.
+ 'process restart not implemented' errorPrintNL.
+ p setId:nil state:#dead
+ ].
+ scheduler setId:nil state:#dead
+ ].
+
+ "
+ now, start from scratch
+ "
+ KnownProcesses := nil.
self initialize
! !
@@ -520,17 +503,17 @@
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
+ (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.
@@ -538,10 +521,10 @@
oldSize := KnownProcesses size.
(index > oldSize) ifTrue:[
- newShadow := WeakArray new:(oldSize * 2).
- newShadow watcher:self class.
- newShadow replaceFrom:1 with:KnownProcesses.
- KnownProcesses := newShadow
+ 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].
@@ -555,82 +538,37 @@
wasBlocked := OperatingSystem blockInterrupts.
index := KnownProcesses identityIndexOf:aProcess.
index ~~ 0 ifTrue:[
- KnownProcessIds at:index put:nil.
- KnownProcesses at:index put:nil.
+ KnownProcessIds at:index put:nil.
+ KnownProcesses at:index put:nil.
].
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
! !
!ProcessorScheduler methodsFor:'process creation'!
-newProcessFor:aBlock
- "create a new process executing aBlock.
- Return a process (or nil if fail). The new process is not scheduled.
- To start it running, it needs a Process>>resume."
+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."
- |id p|
+ |id|
- id := self class threadCreate:aBlock.
- id isNil ifTrue:[
- "
- this may happen, if the VM does not support more processes,
- or if it ran out of memory, when allocating internal data
- structures
- "
- self error:'cannot create new Process'.
- ^ nil
- ].
- p := Process new.
- p setId:id.
- p startBlock:aBlock.
- p state:#light. "meaning: has no stack yet"
- p setPriority:currentPriority.
- "
- give it a user-friendly name
- "
- activeProcess name notNil ifTrue:[
- p name:(activeProcess name , ' (sub)')
- ].
- self remember:p.
- ^ p
+ id := self class threadCreate:aProcess.
+ 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 there is always a switch.
- (if you want to implement your own scheduler stuff, uncomment below)"
+ "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
-
-"/ |l p maxPri "{ Class: SmallInteger }"|
-"/
-"/ maxPri := SchedulingPriority.
-"/ maxPri to:1 by:-1 do:[:prio |
-"/ l := quiescentProcessLists at:prio.
-"/ l notNil ifTrue:[
-"/ p := l first.
-"/ p notNil ifTrue:[
-"/ activeProcess state == #active ifTrue:[
-"/ activeProcess state:#run.
-"/ ].
-"/ ^ self threadSwitch:p
-"/ ].
-"/ quiescentProcessLists at:prio put:nil
-"/ ]
-"/ ].
-"/ "
-"/ no process to run - this 'cannot' happen
-"/ (well, not quite: it may happen if the scheduler process is
-"/ suspended - which btw. should be avoided, since noone is there
-"/ to schedule processes then)
-"/ "
-"/
-"/ MiniDebugger enterWithMessage:'fatal dispatcher should never be suspended'.
-"/
-"/ "try to repair by just resuming ..."
-"/ activeProcess resume
!
yield
@@ -647,22 +585,22 @@
debugging consistency checks - will be removed later
"
l isNil ifTrue:[
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
- 'oops - nil runnable list' errorPrintNL.
- ^ self
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+ 'oops - nil runnable list' errorPrintNL.
+ ^ self
].
l isEmpty ifTrue:[
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
- 'oops - empty runnable list' errorPrintNL.
- ^ self
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+ 'oops - empty runnable list' errorPrintNL.
+ ^ self
].
l size == 1 ifTrue:[
- "
- the running one is the only one
- "
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
- ^ self
+ "
+ the running one is the only one
+ "
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+ ^ self
].
"
@@ -690,17 +628,18 @@
some debugging stuff
"
aProcess isNil ifTrue:[
- MiniDebugger enterWithMessage:'nil suspend'.
- ^ self
+ MiniDebugger enterWithMessage:'nil suspend'.
+ ^ self
].
aProcess id isNil ifTrue:[
- MiniDebugger enterWithMessage:'bad suspend: already dead'.
- self reschedule.
- ^ self
+ MiniDebugger enterWithMessage:'bad suspend: already dead'.
+ self threadSwitch:scheduler.
+ ^ self
].
aProcess == scheduler ifTrue:[
- MiniDebugger enterWithMessage:'scheduler should never be suspended'.
- ^ self
+ 'scheduler should never be suspended' printNL.
+ "/ MiniDebugger enterWithMessage:'scheduler should never be suspended'.
+ ^ self
].
wasBlocked := OperatingSystem blockInterrupts.
@@ -712,45 +651,44 @@
debugging consisteny checks - will be removed later
"
l isNil ifTrue:[
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
- 'bad suspend: empty run list' printNL.
- "/ MiniDebugger enterWithMessage:'bad suspend: empty run list'.
- self reschedule.
- ^ self
+ 'bad suspend: empty run list' printNL.
+ "/ MiniDebugger enterWithMessage:'bad suspend: empty run list'.
+ self threadSwitch:scheduler.
+ ^ self
].
l remove:aProcess ifAbsent:[
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
- MiniDebugger enterWithMessage:'bad suspend: not on run list'.
- ^ self
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+ 'bad suspend: not on run list' printNL.
+ "/ MiniDebugger enterWithMessage:'bad suspend: not on run list'.
+ self threadSwitch:scheduler.
+ ^ self
].
l isEmpty ifTrue:[
- quiescentProcessLists at:pri put:nil.
- l := nil
+ quiescentProcessLists at:pri put:nil.
+ l := nil
].
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.
+ 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 ...
"
- s := aProcess state.
- ((s == #active) or:[s == #run]) ifTrue:[
- aProcess state:#suspended.
- ].
+ aProcess setStateTo:#suspended if:#active or:#run.
+
(aProcess == activeProcess) ifTrue:[
- "we can immediately switch sometimes"
- l notNil ifTrue:[
- p := l first
- ] ifFalse:[
- p := scheduler
- ].
- self threadSwitch:p
-"/ self reschedule
+ "we can immediately switch sometimes"
+ l notNil ifTrue:[
+ p := l first
+ ] ifFalse:[
+ p := scheduler
+ ].
+ self threadSwitch:p
].
!
@@ -772,28 +710,28 @@
l := quiescentProcessLists at:pri.
l isNil ifTrue:[
- l := LinkedList new.
- quiescentProcessLists at:pri put:l
+ l := LinkedList new.
+ quiescentProcessLists at:pri put:l
] ifFalse:[
- "if already running, ignore"
- (l includes:aProcess) ifTrue:[
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
- ^ self
- ]
+ "if already running, ignore"
+ (l includes:aProcess) 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
+ "
+ 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
+ "
+ its prio is lower; it will have to wait for a while ...
+ "
+ aProcess state:#run
]
!
@@ -816,36 +754,40 @@
l := quiescentProcessLists at:pri.
l isNil ifTrue:[
- l := LinkedList new.
- quiescentProcessLists at:pri put:l
+ l := LinkedList new.
+ quiescentProcessLists at:pri put:l
] ifFalse:[
- "if already running, ignore"
- (l includes:aProcess) ifTrue:[
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
- ^ self
- ]
+ "if already running, ignore"
+ (l includes:aProcess) 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
- "
+ "
+ its prio is higher; immediately transfer control to it
+ "
"/ activeProcess state:#run.
- self threadSwitch:aProcess
+ self threadSwitch:aProcess
] ifFalse:[
- "
- its prio is lower; it will have to wait for a while ...
- "
- aProcess state:#suspended
+ "
+ its prio is lower; it will have to wait for a while ...
+ "
+ aProcess state:#suspended
]
!
-terminate:aProcess
- "terminate aProcess. If its not the current process, its simply
- removed from its list and destroyed. Otherwise, a switch is forced
- and the process is destroyed by the next running process."
+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|
@@ -853,8 +795,8 @@
id := aProcess id.
id isNil ifTrue:[^ self]. "already dead"
- aProcess setId:nil.
- aProcess startBlock:nil.
+ aProcess setId:nil state:#dead.
+"/ aProcess setStartBlock:nil.
wasBlocked := OperatingSystem blockInterrupts.
@@ -863,48 +805,58 @@
pri := aProcess priority.
l := quiescentProcessLists at:pri.
(l notNil and:[l includes:aProcess]) ifTrue:[
- l remove:aProcess.
- l isEmpty ifTrue:[quiescentProcessLists at:pri put:nil].
+ l remove:aProcess.
+ l isEmpty ifTrue:[quiescentProcessLists at:pri put:nil].
].
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
- aProcess exitAction notNil ifTrue:[
- aProcess exitAction value.
- aProcess exitAction:nil
- ].
-
- aProcess state:#dead.
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.
-"/ self reschedule.
- ^ self
+ "
+ 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
!
-processTermination
- "current process finished its startup block without termination,
- lay him to rest now."
+terminateActiveNoSignal
+ "hard terminate the active process, without sending any
+ terminate signal thus no unwind blocks are evaluated."
+
+ self terminateNoSignal:activeProcess
+!
- self terminate: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
-"/ self reschedule
+!
+
+terminate:aProcess
+ "terminate aProcess. This is deon 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 currently running process kills itself)"
+ "terminate the current process (i.e. the currently running process kills itself).
+ The active process is sent the terminateSignal so it will evaluate any
+ unwind blocks."
- self terminate:activeProcess
+ activeProcess terminate
!
interruptActive
@@ -926,11 +878,11 @@
"
newPrio := prio.
newPrio < 1 ifTrue:[
- newPrio := 1.
+ newPrio := 1.
] ifFalse:[
- newPrio >= SchedulingPriority ifTrue:[
- newPrio := SchedulingPriority - 1
- ]
+ newPrio >= SchedulingPriority ifTrue:[
+ newPrio := SchedulingPriority - 1
+ ]
].
wasBlocked := OperatingSystem blockInterrupts.
@@ -939,8 +891,8 @@
oldList := quiescentProcessLists at:oldPrio.
(oldList isNil or:[(oldList includes:aProcess) not]) ifTrue:[
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
- ^ self
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+ ^ self
].
oldList remove:aProcess.
@@ -948,8 +900,8 @@
newList := quiescentProcessLists at:newPrio.
newList isNil ifTrue:[
- newList := LinkedList new.
- quiescentProcessLists at:newPrio put:newList
+ newList := LinkedList new.
+ quiescentProcessLists at:newPrio put:newList
].
newList addLast:aProcess.
@@ -957,16 +909,15 @@
or another one raising, we have to reschedule"
aProcess == activeProcess ifTrue:[
- currentPriority := newPrio.
- newPrio < oldPrio ifTrue:[
- self threadSwitch:scheduler.
-"/ self reschedule.
- ]
+ currentPriority := newPrio.
+ newPrio < oldPrio ifTrue:[
+ self threadSwitch:scheduler.
+ ]
] ifFalse:[
- newPrio > currentPriority ifTrue:[
+ newPrio > currentPriority ifTrue:[
"/ activeProcess state:#run.
- self threadSwitch:aProcess.
- ]
+ self threadSwitch:aProcess.
+ ]
].
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
! !
@@ -983,7 +934,7 @@
activePriority
"return the priority of the currently running process.
- GNU-ST compatibility; this is the same as currentPriority"
+ GNU-ST & ST-80 compatibility; this is the same as currentPriority"
^ currentPriority
!
@@ -1005,26 +956,26 @@
maxPri := self highestPriority.
maxPri to:1 by:-1 do:[:prio |
- l := quiescentProcessLists at:prio.
- l notNil ifTrue:[
- l isEmpty ifTrue:[
- "
- on the fly clear out empty lists
- "
- quiescentProcessLists at:prio put:nil
- ] ifFalse:[
- p := l first.
- "
- if it got corrupted somehow
- "
- p id isNil ifTrue:[
- 'process with nil id removed' printNL.
- l removeFirst.
- ^ nil.
- ].
- ^ p
- ].
- ]
+ l := quiescentProcessLists at:prio.
+ l notNil ifTrue:[
+ l isEmpty ifTrue:[
+ "
+ on the fly clear out empty lists
+ "
+ quiescentProcessLists at:prio put:nil
+ ] ifFalse:[
+ p := l first.
+ "
+ if it got corrupted somehow
+ "
+ p id isNil ifTrue:[
+ 'process with nil id removed' printNL.
+ l removeFirst.
+ ^ nil.
+ ].
+ ^ p
+ ].
+ ]
].
^ nil
! !
@@ -1042,7 +993,7 @@
of the dispatch-handling code in the running system.
"
[true] whileTrue:[
- self dispatch
+ self dispatch
]
!
@@ -1057,7 +1008,7 @@
handle all timeout actions
"
anyTimeouts ifTrue:[
- self evaluateTimeouts
+ self evaluateTimeouts
].
"first do a quick check using checkActions - this is needed for
@@ -1067,26 +1018,26 @@
any := false.
nActions := readChecks size.
1 to:nActions do:[:index |
- |checkBlock sema action|
+ |checkBlock sema action|
- checkBlock := readChecks at:index.
- (checkBlock notNil and:[checkBlock value]) ifTrue:[
- sema := readSemaphores at:index.
- sema notNil ifTrue:[
- sema signalOnce.
- ].
- any := true.
- ]
+ checkBlock := readChecks at:index.
+ (checkBlock notNil and:[checkBlock value]) ifTrue:[
+ sema := readSemaphores at:index.
+ sema notNil ifTrue:[
+ sema signalOnce.
+ ].
+ any := true.
+ ]
].
"now, someone might be runnable:"
p := self highestPriorityRunnableProcess.
p isNil ifTrue:[
- "no one runnable, hard wait for event or timeout"
+ "no one runnable, hard wait for event or timeout"
- self waitForEventOrTimeout.
- ^ self
+ self waitForEventOrTimeout.
+ ^ self
].
pri := p priority.
@@ -1113,10 +1064,10 @@
"
pri < TimingPriority ifTrue:[
- anyTimeouts ifTrue:[
- millis := self timeToNextTimeout.
- millis == 0 ifTrue:[^ self].
- ]
+ anyTimeouts ifTrue:[
+ millis := self timeToNextTimeout.
+ millis == 0 ifTrue:[^ self].
+ ]
].
"
@@ -1129,30 +1080,30 @@
pri < UserInterruptPriority ifTrue:[
"comment out this if above is uncommented"
- anyTimeouts ifTrue:[
- millis := self timeToNextTimeout.
- millis == 0 ifTrue:[^ self].
- ].
+ anyTimeouts ifTrue:[
+ millis := self timeToNextTimeout.
+ millis == 0 ifTrue:[^ self].
+ ].
"---"
- OperatingSystem supportsIOInterrupts ifTrue:[
- readFds do:[:fd |
- fd notNil ifTrue:[
- OperatingSystem enableIOInterruptsOn:fd
- ].
- ].
- ] ifFalse:[
- millis notNil ifTrue:[
- millis := millis min:50
- ] ifFalse:[
- millis := 50
- ]
- ]
+ OperatingSystem supportsIOInterrupts ifTrue:[
+ readFds do:[:fd |
+ fd notNil ifTrue:[
+ OperatingSystem enableIOInterruptsOn:fd
+ ].
+ ].
+ ] ifFalse:[
+ millis notNil ifTrue:[
+ millis := millis min:50
+ ] ifFalse:[
+ millis := 50
+ ]
+ ]
].
millis notNil ifTrue:[
- "schedule a clock interrupt after millis milliseconds"
- OperatingSystem enableTimer:millis rounded.
+ "schedule a clock interrupt after millis milliseconds"
+ OperatingSystem enableTimer:millis rounded.
].
"now let the process run - will come back here by reschedule
@@ -1164,25 +1115,25 @@
"... when we arrive here, we are back on stage"
millis notNil ifTrue:[
- OperatingSystem disableTimer.
- self checkForInputWithTimeout:0.
+ OperatingSystem disableTimer.
+ self checkForInputWithTimeout:0.
]
! !
!ProcessorScheduler methodsFor:'waiting'!
ioInterrupt
- "data arrived while waiting - reschedule to bring dispatcher into play"
+ "data arrived while waiting - switch to scheduler process which will decide
+ what to do now."
self threadSwitch:scheduler
-"/ self reschedule
!
timerInterrupt
- "timer expired while waiting - reschedule to bring dispatcher into play"
+ "timer expired while waiting - switch to scheduler process which will decide
+ what to do now."
self threadSwitch:scheduler
-"/ self reschedule
!
timeToNextTimeout
@@ -1197,17 +1148,17 @@
n := timeouts size.
1 to:n do:[:index |
- aTime := timeouts at:index.
- aTime notNil ifTrue:[
- minDelta isNil ifTrue:[
- now := OperatingSystem getMillisecondTime.
- (OperatingSystem millisecondTime:aTime isAfter:now) ifFalse:[^ 0].
- minDelta := OperatingSystem millisecondTimeDeltaBetween:aTime and:now.
- ] ifFalse:[
- (OperatingSystem millisecondTime:aTime isAfter:now) ifFalse:[^ 0].
- minDelta := minDelta min:(OperatingSystem millisecondTimeDeltaBetween:aTime and:now)
- ]
- ]
+ aTime := timeouts at:index.
+ aTime notNil ifTrue:[
+ minDelta isNil ifTrue:[
+ now := OperatingSystem getMillisecondTime.
+ (OperatingSystem millisecondTime:aTime isAfter:now) ifFalse:[^ 0].
+ minDelta := OperatingSystem millisecondTimeDeltaBetween:aTime and:now.
+ ] ifFalse:[
+ (OperatingSystem millisecondTime:aTime isAfter:now) ifFalse:[^ 0].
+ minDelta := minDelta min:(OperatingSystem millisecondTimeDeltaBetween:aTime and:now)
+ ]
+ ]
].
^ minDelta
@@ -1224,54 +1175,54 @@
doingGC := true.
[doingGC] whileTrue:[
- anyTimeouts ifTrue:[
- millis := self timeToNextTimeout.
- (millis notNil and:[millis <= 0]) ifTrue:[
- ^ self "oops - hurry up checking"
- ].
- ].
+ anyTimeouts ifTrue:[
+ millis := self timeToNextTimeout.
+ (millis notNil and:[millis <= 0]) ifTrue:[
+ ^ self "oops - hurry up checking"
+ ].
+ ].
- "if its worth doing, collect a bit of garbage"
- limit := ObjectMemory incrementalGCLimit.
- doingGC := limit notNil and:[ObjectMemory oldSpaceAllocatedSinceLastGC > limit].
- doingGC ifTrue:[
- ObjectMemory gcStep.
- ].
+ "if its worth doing, collect a bit of garbage"
+ limit := ObjectMemory incrementalGCLimit.
+ doingGC := limit notNil and:[ObjectMemory oldSpaceAllocatedSinceLastGC > limit].
+ doingGC ifTrue:[
+ ObjectMemory gcStep.
+ ].
- "then do idle actions"
- (idleActions size ~~ 0) ifTrue:[
- idleActions do:[:aBlock |
- aBlock value.
- ].
- ^ self "go back checking"
- ].
+ "then do idle actions"
+ (idleActions size ~~ 0) ifTrue:[
+ idleActions do:[:aBlock |
+ aBlock value.
+ ].
+ ^ self "go back checking"
+ ].
- doingGC ifTrue:[
- (self checkForInputWithTimeout:0) ifTrue:[
- ^ self "go back checking"
- ]
- ]
+ doingGC ifTrue:[
+ (self checkForInputWithTimeout:0) ifTrue:[
+ ^ self "go back checking"
+ ]
+ ]
].
(self checkForInputWithTimeout:0) ifTrue:[
- ^ self "go back checking"
+ ^ self "go back checking"
].
"no, really nothing to do - simply wait"
OperatingSystem supportsSelect ifFalse:[
- "SCO instant ShitStation has a bug here,
- waiting always 1 sec in the select - therefore we delay a bit and
- return - effectively polling in 50ms cycles
- "
- OperatingSystem millisecondDelay:50.
- ^ self
+ "SCO instant ShitStation has a bug here,
+ waiting always 1 sec in the select - therefore we delay a bit and
+ return - effectively polling in 50ms cycles
+ "
+ OperatingSystem millisecondDelay:50.
+ ^ self
].
millis isNil ifTrue:[
- millis := 9999.
+ millis := 9999.
] ifFalse:[
- millis := millis rounded
+ millis := millis rounded
].
self checkForInputWithTimeout:millis
!
@@ -1283,84 +1234,27 @@
|fd index sema action|
fd := OperatingSystem
- selectOnAnyReadable:readFds
- writable:writeFds
- exception:nil
- withTimeOut:millis.
+ selectOnAnyReadable:readFds
+ writable:writeFds
+ exception:nil
+ withTimeOut:millis.
fd notNil ifTrue:[
- index := readFds indexOf:fd.
- index ~~ 0 ifTrue:[
- sema := readSemaphores at:index.
- sema notNil ifTrue:[
- sema signalOnce.
- ^ true
- ] ifFalse:[
- action := readChecks at:index.
- action notNil ifTrue:[
- action value.
- ^ true
- ]
- ]
- ]
+ index := readFds indexOf:fd.
+ index ~~ 0 ifTrue:[
+ sema := readSemaphores at:index.
+ sema notNil ifTrue:[
+ sema signalOnce.
+ ^ true
+ ] ifFalse:[
+ action := readChecks at:index.
+ action notNil ifTrue:[
+ action value.
+ ^ true
+ ]
+ ]
+ ]
].
^ false
-!
-
-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 := timeouts size.
- anyTimeouts := false.
- 1 to:n do:[:index |
- aTime := timeouts at:index.
- aTime notNil ifTrue:[
- (OperatingSystem millisecondTime:aTime isAfter:now) ifFalse:[
- "this one should be triggered"
-
- sema := timeoutSemaphores at:index.
- sema notNil ifTrue:[
- sema signalOnce.
- timeoutSemaphores at:index put:nil
- ] ifFalse:[
- "to support pure-events"
- block := timeoutActions at:index.
- block notNil ifTrue:[
- blocksToEvaluate isNil ifTrue:[
- blocksToEvaluate := OrderedCollection new:10.
- processes := OrderedCollection new:10.
- ].
- blocksToEvaluate add:block.
- processes add:(timeoutProcesses at:index).
- timeoutActions at:index put:nil.
- timeoutProcesses at:index put:nil.
- ]
- ].
- timeouts at:index put:nil.
- ] ifTrue:[
- anyTimeouts := true
- ]
- ]
- ].
-
- blocksToEvaluate notNil ifTrue:[
- 1 to:blocksToEvaluate size do:[:index |
- PureEventDriven ifTrue:[
- (blocksToEvaluate at:index) value
- ] ifFalse:[
- (processes at:index) interruptWith:(blocksToEvaluate at:index)
- ]
- ]
- ]
! !
!ProcessorScheduler methodsFor:'semaphore signalling'!
@@ -1382,16 +1276,16 @@
wasBlocked := OperatingSystem blockInterrupts.
(readFds includes:aFileDescriptor) ifFalse:[
- idx := readFds indexOf:nil.
- idx ~~ 0 ifTrue:[
- readFds at:idx put:aFileDescriptor.
- readSemaphores at:idx put:aSemaphore.
- readChecks at:idx put:aBlock
- ] ifFalse:[
- readFds := readFds copyWith:aFileDescriptor.
- readSemaphores := readSemaphores copyWith:aSemaphore.
- readChecks := readChecks copyWith:aBlock.
- ]
+ idx := readFds indexOf:nil.
+ idx ~~ 0 ifTrue:[
+ readFds at:idx put:aFileDescriptor.
+ readSemaphores at:idx put:aSemaphore.
+ readChecks at:idx put:aBlock
+ ] ifFalse:[
+ readFds := readFds copyWith:aFileDescriptor.
+ readSemaphores := readSemaphores copyWith:aSemaphore.
+ readChecks := readChecks copyWith:aBlock.
+ ]
].
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
!
@@ -1404,14 +1298,14 @@
wasBlocked := OperatingSystem blockInterrupts.
(writeFds includes:aFileDescriptor) ifFalse:[
- idx := writeFds indexOf:nil.
- idx ~~ 0 ifTrue:[
- writeFds at:idx put:aFileDescriptor.
- writeSemaphores at:idx put:aSemaphore.
- ] ifFalse:[
- writeFds := writeFds copyWith:aFileDescriptor.
- writeSemaphores := writeSemaphores copyWith:aSemaphore.
- ]
+ idx := writeFds indexOf:nil.
+ idx ~~ 0 ifTrue:[
+ writeFds at:idx put:aFileDescriptor.
+ writeSemaphores at:idx put:aSemaphore.
+ ] ifFalse:[
+ writeFds := writeFds copyWith:aFileDescriptor.
+ writeSemaphores := writeSemaphores copyWith:aSemaphore.
+ ]
].
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
!
@@ -1442,20 +1336,20 @@
wasBlocked := OperatingSystem blockInterrupts.
index := timeoutSemaphores identityIndexOf:aSemaphore.
index ~~ 0 ifTrue:[
- timeouts at:index put:aMillisecondTime
+ timeouts at:index put:aMillisecondTime
] ifFalse:[
- index := timeouts indexOf:nil.
- index ~~ 0 ifTrue:[
- timeoutSemaphores at:index put:aSemaphore.
- timeouts at:index put:aMillisecondTime.
- timeoutActions at:index put:nil.
- timeoutProcesses at:index put:nil
- ] ifFalse:[
- timeoutSemaphores := timeoutSemaphores copyWith:aSemaphore.
- timeouts := timeouts copyWith:aMillisecondTime.
- timeoutActions := timeoutActions copyWith:nil.
- timeoutProcesses := timeoutProcesses copyWith:nil
- ].
+ index := timeouts indexOf:nil.
+ index ~~ 0 ifTrue:[
+ timeoutSemaphores at:index put:aSemaphore.
+ timeouts at:index put:aMillisecondTime.
+ timeoutActions at:index put:nil.
+ timeoutProcesses at:index put:nil
+ ] ifFalse:[
+ timeoutSemaphores := timeoutSemaphores copyWith:aSemaphore.
+ timeouts := timeouts copyWith:aMillisecondTime.
+ timeoutActions := timeoutActions copyWith:nil.
+ timeoutProcesses := timeoutProcesses copyWith:nil
+ ].
].
anyTimeouts := true.
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
@@ -1469,16 +1363,21 @@
wasBlocked := OperatingSystem blockInterrupts.
idx := readSemaphores identityIndexOf:aSemaphore.
idx ~~ 0 ifTrue:[
- readFds at:idx put:nil.
- readSemaphores at:idx put:nil.
- readChecks at:idx put:nil
+ readFds at:idx put:nil.
+ readSemaphores at:idx put:nil.
+ readChecks at:idx put:nil
+ ].
+ idx := writeSemaphores identityIndexOf:aSemaphore.
+ idx ~~ 0 ifTrue:[
+ writeFds at:idx put:nil.
+ writeSemaphores at:idx put:nil.
].
idx := timeoutSemaphores identityIndexOf:aSemaphore.
idx ~~ 0 ifTrue:[
- timeouts at:idx put:nil.
- timeoutSemaphores at:idx put:nil.
- timeoutActions at:idx put:nil.
- timeoutProcesses at:idx put:nil.
+ timeouts at:idx put:nil.
+ timeoutSemaphores at:idx put:nil.
+ timeoutActions at:idx put:nil.
+ timeoutProcesses at:idx put:nil.
].
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
! !
@@ -1490,16 +1389,16 @@
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. They have been implemented to support
- background actions in pure-event systems, where no processes are
- available.
+ 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 := OrderedCollection new
].
idleActions add:aBlock.
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
@@ -1520,7 +1419,7 @@
!ProcessorScheduler methodsFor:'I/O event actions'!
-enableIOAction:aBlock on:aFileDescriptor
+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."
@@ -1529,16 +1428,16 @@
wasBlocked := OperatingSystem blockInterrupts.
(readFds includes:aFileDescriptor) ifFalse:[
- idx := readFds indexOf:nil.
- idx ~~ 0 ifTrue:[
- readFds at:idx put:aFileDescriptor.
- readChecks at:idx put:aBlock.
- readSemaphores at:idx put:nil
- ] ifFalse:[
- readFds := readFds copyWith:aFileDescriptor.
- readChecks := readChecks copyWith:aBlock.
- readSemaphores := readSemaphores copyWith:nil.
- ]
+ idx := readFds indexOf:nil.
+ idx ~~ 0 ifTrue:[
+ readFds at:idx put:aFileDescriptor.
+ readChecks at:idx put:aBlock.
+ readSemaphores at:idx put:nil
+ ] ifFalse:[
+ readFds := readFds copyWith:aFileDescriptor.
+ readChecks := readChecks copyWith:aBlock.
+ readSemaphores := readSemaphores copyWith:nil.
+ ]
].
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
!
@@ -1552,21 +1451,21 @@
wasBlocked := OperatingSystem blockInterrupts.
idx := readFds indexOf:aFileDescriptor.
idx ~~ 0 ifTrue:[
- readFds at:idx put:nil.
- readChecks at:idx put:nil.
- readSemaphores at:idx put:nil
+ readFds at:idx put:nil.
+ readChecks at:idx put:nil.
+ readSemaphores at:idx put:nil
].
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
! !
-!ProcessorScheduler methodsFor:'timed block'!
+!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 for the execution).
+ 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)."
@@ -1578,7 +1477,9 @@
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 for the execution).
+ 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)."
@@ -1590,7 +1491,7 @@
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 for the execution).
+ 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)."
@@ -1599,10 +1500,12 @@
addTimedBlock:aBlock for:aProcess afterMilliseconds:delta
"add the argument, aBlock to the list of time-scheduled-blocks; to be
- evaluated after delta milliseconds. aProcess will be interrupted for
- execution of the block.
+ 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 for the execution).
+ 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)."
@@ -1621,7 +1524,7 @@
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 for the execution).
+ 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)."
@@ -1631,10 +1534,12 @@
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.
- aProcess will be interrupted for execution of the block.
+ aMillisecondTime. 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 it is running, the interrupt will occur in whatever method it is
- executing; if it is suspended, it will be resumed for the execution).
+ 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)."
@@ -1643,20 +1548,20 @@
wasBlocked := OperatingSystem blockInterrupts.
index := timeoutActions identityIndexOf:aBlock.
index ~~ 0 ifTrue:[
- timeouts at:index put:aMillisecondTime
+ timeouts at:index put:aMillisecondTime
] ifFalse:[
- index := timeouts indexOf:nil.
- index ~~ 0 ifTrue:[
- timeouts at:index put:aMillisecondTime.
- timeoutActions at:index put:aBlock.
- timeoutSemaphores at:index put:nil.
- timeoutProcesses at:index put:aProcess
- ] ifFalse:[
- timeouts := timeouts copyWith:aMillisecondTime.
- timeoutActions := timeoutActions copyWith:aBlock.
- timeoutSemaphores := timeoutSemaphores copyWith:nil.
- timeoutProcesses := timeoutProcesses copyWith:aProcess.
- ].
+ index := timeouts indexOf:nil.
+ index ~~ 0 ifTrue:[
+ timeouts at:index put:aMillisecondTime.
+ timeoutActions at:index put:aBlock.
+ timeoutSemaphores at:index put:nil.
+ timeoutProcesses at:index put:aProcess
+ ] ifFalse:[
+ timeouts := timeouts copyWith:aMillisecondTime.
+ timeoutActions := timeoutActions copyWith:aBlock.
+ timeoutSemaphores := timeoutSemaphores copyWith:nil.
+ timeoutProcesses := timeoutProcesses copyWith:aProcess.
+ ].
].
anyTimeouts := true.
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
@@ -1670,10 +1575,70 @@
wasBlocked := OperatingSystem blockInterrupts.
index := timeoutActions identityIndexOf:aBlock.
(index ~~ 0) ifTrue:[
- timeouts at:index put:nil.
- timeoutActions at:index put:nil.
- timeoutSemaphores at:index put:nil.
- timeoutProcesses at:index put:nil.
+ timeouts at:index put:nil.
+ timeoutActions at:index put:nil.
+ timeoutSemaphores at:index put:nil.
+ timeoutProcesses 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 := timeouts size.
+ anyTimeouts := false.
+ 1 to:n do:[:index |
+ aTime := timeouts at:index.
+ aTime notNil ifTrue:[
+ (OperatingSystem millisecondTime:aTime isAfter:now) ifFalse:[
+ "this one should be triggered"
+
+ sema := timeoutSemaphores at:index.
+ sema notNil ifTrue:[
+ sema signalOnce.
+ timeoutSemaphores at:index put:nil
+ ] ifFalse:[
+ "to support pure-events"
+ block := timeoutActions at:index.
+ block notNil ifTrue:[
+ blocksToEvaluate isNil ifTrue:[
+ blocksToEvaluate := OrderedCollection new:10.
+ processes := OrderedCollection new:10.
+ ].
+ blocksToEvaluate add:block.
+ processes add:(timeoutProcesses at:index).
+ timeoutActions at:index put:nil.
+ timeoutProcesses at:index put:nil.
+ ]
+ ].
+ timeouts at:index put:nil.
+ ] ifTrue:[
+ anyTimeouts := true
+ ]
+ ]
+ ].
+
+ blocksToEvaluate notNil ifTrue:[
+ blocksToEvaluate keysAndValuesDo:[:index :block |
+ |p|
+
+ p := processes at:index.
+ (p isNil or:[PureEventDriven]) ifTrue:[
+ block value
+ ] ifFalse:[
+ p interruptWith:block
+ ]
+ ]
+ ]
! !
--- a/Registry.st Mon Oct 10 01:29:01 1994 +0100
+++ b/Registry.st Mon Oct 10 01:29:28 1994 +0100
@@ -11,7 +11,7 @@
"
Object subclass:#Registry
- instanceVariableNames:'registeredObjects phantoms cleanState'
+ instanceVariableNames:'registeredObjects phantomArray cleanState'
classVariableNames:''
poolDictionaries:''
category:'System-Support'
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1993 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Registry.st,v 1.9 1994-08-22 12:12:55 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Registry.st,v 1.10 1994-10-10 00:27:59 claus Exp $
'!
!Registry class methodsFor:'documentation'!
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Registry.st,v 1.9 1994-08-22 12:12:55 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Registry.st,v 1.10 1994-10-10 00:27:59 claus Exp $
"
!
@@ -50,9 +50,9 @@
"
Registries provide an easy interface to using WeakArrays.
A class, which wants to be informed of instance-death, can put a created object
- into a registry. The registry will create a copy of the object, and
- watch out for death of the registered object. When it dies, the copy will
- be sent the message >>disposed.
+ into a registry. The registry will create a (shallow-)copy of the object, and
+ watch out for death of the original object. When it dies, the copy will
+ be sent the #disposed-message.
The trick with the shallow copy is especially nice, you can think of it as
being the original object which died.
@@ -62,6 +62,13 @@
Of course, you too can use it to do whatever you need to do in case of the
death of an object.
+
+ Registries use #shallowCopyForFinalization to aquire the copy of the original,
+ this can be redefined in registered classes for faster copying
+ (typically, not all internal state but only some device handles are needed for
+ finalization).
+
+ See axample uses in Form, Color, ExternalStream and Font
"
! !
@@ -70,14 +77,16 @@
informDispose
"an instance has been destroyed - look which one it was"
- |phantom|
+ |phantom
+ sz "{ Class: SmallInteger }"|
cleanState ifTrue:[
- 1 to:phantoms size do:[:index |
+ sz := phantomArray size.
+ 1 to:sz do:[:index |
(registeredObjects at:index) isNil ifTrue:[
- phantom := phantoms at:index.
+ phantom := phantomArray at:index.
phantom notNil ifTrue:[
- phantoms at:index put:nil.
+ phantomArray at:index put:nil.
phantom disposed
]
]
@@ -91,10 +100,8 @@
"evaluate aBlock for each registered object"
registeredObjects notNil ifTrue:[
- registeredObjects do:[:o |
- o notNil ifTrue:[
- aBlock value:o
- ]
+ registeredObjects nonNilElementsDo:[:o |
+ aBlock value:o
]
]
! !
@@ -114,7 +121,7 @@
index := registeredObjects identityIndexOf:anObject ifAbsent:[0].
index ~~ 0 ifTrue:[
- phantoms at:index put:anObject shallowCopy.
+ phantomArray at:index put:anObject shallowCopyForFinalization.
]
!
@@ -123,17 +130,18 @@
when anObject dies (some time in the future)"
|phantom newColl newPhantoms
- count "{ Class: SmallInteger }"
- p index|
+ size "{ Class: SmallInteger }"
+ index "{ Class: SmallInteger }"
+ p|
- phantom := anObject shallowCopy.
+ phantom := anObject shallowCopyForFinalization.
registeredObjects isNil ifTrue:[
registeredObjects := WeakArray new:10.
registeredObjects watcher:self.
registeredObjects at:1 put:anObject.
- phantoms := Array new:10.
- phantoms at:1 put:phantom.
+ phantomArray := Array new:10.
+ phantomArray at:1 put:phantom.
cleanState := true.
ObjectMemory addDependent:self.
^ self
@@ -142,41 +150,41 @@
index := registeredObjects identityIndexOf:anObject ifAbsent:[0].
index ~~ 0 ifTrue:[
"already registered"
- phantoms at:index put:phantom.
+ phantomArray at:index put:phantom.
self error:'object is already registered'.
^ self
].
"search for a free slot, on the fly look for leftovers"
- count := phantoms size.
- 1 to:count do:[:i |
- (registeredObjects at:i) isNil ifTrue:[
- "is there a leftover ?"
- p := phantoms at:i.
- p notNil ifTrue:[
- "tell the phantom"
- phantoms at:i put:nil.
- p disposed.
- p := nil.
- ].
- registeredObjects at:i put:anObject.
- phantoms at:i put:phantom.
- ^ self
- ]
+ index := registeredObjects identityIndexOf:nil startingAt:1.
+ index ~~ 0 ifTrue:[
+ "is there a leftover ?"
+ p := phantomArray at:index.
+ p notNil ifTrue:[
+ "tell the phantom"
+ phantomArray at:index put:nil.
+ p disposed.
+ p := nil.
+ ].
+ registeredObjects at:index put:anObject.
+ phantomArray at:index put:phantom.
+ ^ self
].
"no free slot, add at the end"
- newColl := WeakArray new:(count * 2).
- newColl replaceFrom:1 to:count with:registeredObjects.
+ size := registeredObjects size.
+ index := size + 1.
+ newColl := WeakArray new:(size * 2).
+ newColl replaceFrom:1 to:size with:registeredObjects.
registeredObjects := newColl.
registeredObjects watcher:self.
- registeredObjects at:(count + 1) put:anObject.
+ registeredObjects at:index put:anObject.
- newPhantoms := Array new:(count * 2).
- newPhantoms replaceFrom:1 to:count with:phantoms.
- phantoms := newPhantoms.
- phantoms at:(count + 1) put:phantom.
+ newPhantoms := Array new:(size * 2).
+ newPhantoms replaceFrom:1 to:size with:phantomArray.
+ phantomArray := newPhantoms.
+ phantomArray at:index put:phantom.
!
unregister:anObject
@@ -188,7 +196,7 @@
index := registeredObjects identityIndexOf:anObject ifAbsent:[0].
index ~~ 0 ifTrue:[
- phantoms at:index put:nil.
+ phantomArray at:index put:nil.
registeredObjects at:index put:nil
]
! !
@@ -197,8 +205,8 @@
update:aParameter
aParameter == #earlyRestart ifTrue:[
- phantoms notNil ifTrue:[
- phantoms atAllPut:nil
+ phantomArray notNil ifTrue:[
+ phantomArray atAllPut:nil
]
].
aParameter == #returnFromSnapshot ifTrue:[
--- a/Semaphore.st Mon Oct 10 01:29:01 1994 +0100
+++ b/Semaphore.st Mon Oct 10 01:29:28 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -11,17 +11,17 @@
"
LinkedList subclass:#Semaphore
- instanceVariableNames:'count waitingProcesses'
+ instanceVariableNames:'count waitingProcesses'
"/ instanceVariableNames:'count'
- classVariableNames:''
- poolDictionaries:''
- category:'Kernel-Processes'!
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Kernel-Processes'!
Semaphore comment:'
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Semaphore.st,v 1.11 1994-08-05 00:59:40 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Semaphore.st,v 1.12 1994-10-10 00:28:02 claus Exp $
'!
!Semaphore class methodsFor:'documentation'!
@@ -29,7 +29,7 @@
copyright
"
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Semaphore.st,v 1.11 1994-08-05 00:59:40 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Semaphore.st,v 1.12 1994-10-10 00:28:02 claus Exp $
"
!
@@ -53,11 +53,15 @@
performing a Semaphore>>wait, which will suspend the process until the
resource becomes available. Signalling is done by (another process performing)
Semaphore>>signal.
- If the resource has been alrady available before the wait, no suspending is
+ If the resource has been already available before the wait, no suspending is
done, but the resource immediately allocated.
There are also semaphores for mutual access to a critical region
(Semaphore>>forMutualExclusion and Semaphore>>critical:).
+ You can also attach semaphores to external events (such as I/O arrival or
+ timer events. This is done by telling the Processor to signal the semaphore.
+ See 'Processor>>signal:afterSeconds:', 'Processor>>signal:onInput:' etc.
+
See examples in doc/coding.
"
! !
@@ -98,15 +102,10 @@
|current wasBlocked|
"
- need a while-loop here, since more than one process may
- wait for it and another one may also wake up.
- Thus, the count is not always non-zero after returning from
- suspend.
- "
-
- "
- this works only due to interrupts being serviced at message send
- and method-return time only ....
+ this works only since interrupts are only serviced at
+ message send and method-return time ....
+ If you add a message send into the ifTrue:-block, things will
+ go mad ... (especially be careful when adding a debugPrint-here)
"
count ~~ 0 ifTrue:[
count := count - 1.
@@ -114,40 +113,120 @@
].
wasBlocked := OperatingSystem blockInterrupts.
+
+ current := Processor activeProcess.
+ waitingProcesses isNil ifTrue:[
+ waitingProcesses := OrderedCollection with:current
+ ] ifFalse:[
+ waitingProcesses add:current
+ ].
+"/ self add:current.
+
+ "
+ need a while-loop here, since more than one process may
+ wait for it and another one may also wake up.
+ Thus, the count is not always non-zero after returning from
+ suspend.
+ "
[count == 0] whileTrue:[
-"/ (count == 0) ifTrue:[
- current := Processor activeProcess.
- waitingProcesses isNil ifTrue:[
- waitingProcesses := OrderedCollection with:current
- ] ifFalse:[
- waitingProcesses add:current
- ].
-"/ self add:current.
- "
- for some more info in processMonitor ...
- "
- current state == #active ifTrue:[
- current state:#wait.
- ].
- Processor suspend:current
-"/ ].
+ "
+ for some more descriptive info in processMonitor ...
+ (notice that state could already be #ioWait or #timeWait)
+ "
+ current setStateTo:#wait if:#active.
+ Processor suspend:current
].
count := count - 1.
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
!
+waitWithTimeout:seconds
+ "wait for the semaphore, but abort the wait after some time.
+ return true if semaphore triggered normal, false if we return
+ due to a timeout. With zero timeout, this can be used to poll
+ a semaphore (which is not the intend of semaphores, though)."
+
+ |current timeoutOccured wasBlocked unblock now endTime|
+
+ "
+ this works only since interrupts are only serviced at
+ message send and method-return time ....
+ If you add a message send into the ifTrue:-block, things will
+ go mad ... (especially be careful when adding a debugPrint-here)
+ "
+ count ~~ 0 ifTrue:[
+ count := count - 1.
+ ^ true
+ ].
+
+ "
+ with zero-timeout, this is a poll
+ "
+ seconds = 0 ifTrue:[
+ ^ false
+ ].
+
+ wasBlocked := OperatingSystem blockInterrupts.
+
+ "
+ calculate the end-time
+ "
+ now := OperatingSystem getMillisecondTime.
+ endTime := OperatingSystem millisecondTimeAdd:now and:(seconds * 1000).
+
+ current := Processor activeProcess.
+ waitingProcesses isNil ifTrue:[
+ waitingProcesses := OrderedCollection with:current
+ ] ifFalse:[
+ waitingProcesses add:current
+ ].
+"/ self add:current.
+
+ unblock := [timeoutOccured := true. Processor resume:current].
+ Processor addTimedBlock:unblock for:current atMilliseconds:endTime.
+
+ "
+ need a while-loop here, since more than one process may
+ wait for it and another one may also wake up.
+ Thus, the count is not always non-zero after returning from
+ suspend.
+ "
+ [count == 0] whileTrue:[
+ "
+ for some more descriptive info in processMonitor ...
+ (notice that state could already be #ioWait or #timeWait)
+ "
+ current setStateTo:#wait if:#active.
+
+ timeoutOccured := false.
+ Processor suspend:current.
+
+ timeoutOccured ifTrue:[
+ waitingProcesses remove:current ifAbsent:[].
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+ ^ false
+ ].
+ ].
+ Processor removeTimedBlock:unblock.
+ count := count - 1.
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+ ^ true
+!
+
signalOnce
"wakeup waiters - but only once.
- I.e. if the receiver has already been signalled, this
+ I.e. if the semaphore has already been signalled, this
is ignored."
|wasBlocked|
- wasBlocked := OperatingSystem blockInterrupts.
count == 0 ifTrue:[
- self signal
- ].
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+ wasBlocked := OperatingSystem blockInterrupts.
+ count == 0 ifTrue:[
+ self signal
+ ].
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+ ]
!
signal
@@ -158,13 +237,13 @@
wasBlocked := OperatingSystem blockInterrupts.
count := count + 1.
(waitingProcesses notNil and:[waitingProcesses notEmpty]) ifTrue:[
- p := waitingProcesses removeFirst.
+ p := waitingProcesses removeFirst.
"/ self isEmpty ifFalse:[
"/ p := self removeFirst.
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
- p resume.
- ^ self
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+ p resume.
+ ^ self
].
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
!
--- a/SeqColl.st Mon Oct 10 01:29:01 1994 +0100
+++ b/SeqColl.st Mon Oct 10 01:29:28 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -19,9 +19,9 @@
SequenceableCollection comment:'
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Attic/SeqColl.st,v 1.14 1994-08-22 12:13:09 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/SeqColl.st,v 1.15 1994-10-10 00:28:06 claus Exp $
'!
!SequenceableCollection class methodsFor:'documentation'!
@@ -29,7 +29,7 @@
copyright
"
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Attic/SeqColl.st,v 1.14 1994-08-22 12:13:09 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/SeqColl.st,v 1.15 1994-10-10 00:28:06 claus Exp $
"
!
@@ -88,15 +88,15 @@
the exceptionblock."
((index < 1) or:[index > self size]) ifTrue:[
- ^ exceptionBlock value
+ ^ exceptionBlock value
].
^ self at:index
"
#(1 2 3) at:4 ifAbsent:['no such index']
(Dictionary with:(#foo -> #bar)
- with:(#frob -> #baz))
- at:#foobar ifAbsent:['no such index']
+ with:(#frob -> #baz))
+ at:#foobar ifAbsent:['no such index']
"
! !
@@ -134,7 +134,7 @@
sz := self size.
sz == 0 ifTrue:[
- ^ #()
+ ^ #()
].
^ 1 to:sz
! !
@@ -156,8 +156,8 @@
index := 1.
[index <= stop] whileTrue:[
- (self at:index) = (aCollection at:index) ifFalse:[^false].
- index := index + 1
+ (self at:index) = (aCollection at:index) ifFalse:[^false].
+ index := index + 1
].
^ true
@@ -199,8 +199,8 @@
index := 1.
[index <= stop] whileTrue:[
- (self at:index) = (aCollection at:index) ifFalse:[^false].
- index := index + 1
+ (self at:index) = (aCollection at:index) ifFalse:[^false].
+ index := index + 1
].
^ true
@@ -230,9 +230,9 @@
index1 := sz.
index2 := stop.
[index2 > 0] whileTrue:[
- (self at:index1) = (aCollection at:index2) ifFalse:[^ false].
- index1 := index1 - 1.
- index2 := index2 - 1
+ (self at:index1) = (aCollection at:index2) ifFalse:[^ false].
+ index1 := index1 - 1.
+ index2 := index2 - 1
].
^ true
@@ -260,22 +260,21 @@
mySize := self size.
otherSize := aCollection size.
newSize := mySize + otherSize.
-"/ newCollection := self species new:newSize.
- newCollection := (self species new:newSize) finalizeCopyFrom:self.
+ newCollection := (self species new:newSize) postCopyFrom:self.
newCollection replaceFrom:1 to:mySize with:self startingAt:1.
dstIndex := mySize + 1.
(aCollection isSequenceableCollection) ifTrue:[
- "yes, aCollection has indexed elements"
- newCollection replaceFrom:dstIndex to:newSize
- with:aCollection startingAt:1.
- ^ newCollection
+ "yes, aCollection has indexed elements"
+ newCollection replaceFrom:dstIndex to:newSize
+ with:aCollection startingAt:1.
+ ^ newCollection
] ifFalse:[
- "no, enumerate aCollection"
- aCollection do:[:element |
- newCollection at:dstIndex put:element.
- dstIndex := dstIndex + 1
- ]
+ "no, enumerate aCollection"
+ aCollection do:[:element |
+ newCollection at:dstIndex put:element.
+ dstIndex := dstIndex + 1
+ ]
].
^ newCollection
@@ -297,8 +296,7 @@
mySize := self size.
newSize := mySize + 1.
-"/ newCollection := self species new:newSize.
- newCollection := (self species new:newSize) finalizeCopyFrom:self.
+ newCollection := (self species new:newSize) postCopyFrom:self.
newCollection replaceFrom:1 to:mySize with:self startingAt:1.
newCollection at:newSize put:newElement.
^newCollection
@@ -322,8 +320,7 @@
(skipIndex == 0) ifTrue:[^ self copy].
sz := self size.
-"/ copy := self class new:(sz - 1).
- copy := (self species new:(sz - 1)) finalizeCopyFrom:self.
+ copy := (self species new:(sz - 1)) postCopyFrom:self.
copy replaceFrom:1 to:(skipIndex - 1) with:self startingAt:1.
copy replaceFrom:skipIndex to:(sz - 1) with:self startingAt:(skipIndex + 1).
^ copy
@@ -351,25 +348,24 @@
n == 0 ifTrue:[^ self copy].
sz := self size.
-"/ copy := self species new:(sz - n).
- copy := (self species new:(sz - n)) finalizeCopyFrom:self.
+ copy := (self species new:(sz - n)) postCopyFrom:self.
srcIndex := 1.
dstIndex := 1.
n timesRepeat:[
- skipIndex := self indexOf:elementToSkip startingAt:srcIndex.
- l := skipIndex - srcIndex.
- l ~~ 0 ifTrue:[
- copy replaceFrom:dstIndex to:(dstIndex + l - 1)
- with:self startingAt:srcIndex.
- dstIndex := dstIndex + l
- ].
- srcIndex := skipIndex + 1
+ skipIndex := self indexOf:elementToSkip startingAt:srcIndex.
+ l := skipIndex - srcIndex.
+ l ~~ 0 ifTrue:[
+ copy replaceFrom:dstIndex to:(dstIndex + l - 1)
+ with:self startingAt:srcIndex.
+ dstIndex := dstIndex + l
+ ].
+ srcIndex := skipIndex + 1
].
l := sz - srcIndex.
copy replaceFrom:dstIndex to:(dstIndex + l)
- with:self startingAt:srcIndex.
+ with:self startingAt:srcIndex.
^ copy
"
@@ -390,16 +386,15 @@
|copy sz|
sz := self size.
-"/ copy := self species new:(sz - 1).
- copy := (self species new:(sz - 1)) finalizeCopyFrom:self.
+ copy := (self species new:(sz - 1)) postCopyFrom:self.
copy replaceFrom:1
- to:(omitIndex - 1)
- with:self
- startingAt:1.
+ to:(omitIndex - 1)
+ with:self
+ startingAt:1.
copy replaceFrom:omitIndex
- to:sz - 1
- with:self
- startingAt:(omitIndex + 1).
+ to:sz - 1
+ with:self
+ startingAt:(omitIndex + 1).
^ copy
"
@@ -415,8 +410,7 @@
|newCollection newSize|
newSize := stop - start + 1.
-"/ newCollection := self species new:newSize.
- newCollection := (self species new:newSize) finalizeCopyFrom:self.
+ newCollection := (self species new:newSize) postCopyFrom:self.
newCollection replaceFrom:1 to:newSize with:self startingAt:start.
^ newCollection
@@ -485,7 +479,7 @@
idx := self indexOf:element.
idx == 0 ifTrue:[^ nil]. "question: is this ok?"
- idx == 1 ifTrue:[^ self species new finalizeCopyFrom:self].
+ idx == 1 ifTrue:[^ self species new postCopyFrom:self].
^ self copyFrom:1 to:(idx-1)
"
@@ -522,7 +516,7 @@
replSize := aCollection size.
newColl := self species new:(self size - (endIndex - startIndex + 1) + replSize).
- newColl finalizeCopyFrom:self.
+ newColl postCopyFrom:self.
newColl replaceFrom:1 to:(startIndex - 1) with:self.
newColl replaceFrom:startIndex with:aCollection.
newColl replaceFrom:(startIndex + replSize) with:self startingAt:(endIndex + 1).
@@ -548,8 +542,8 @@
index := index1.
end := index2.
[index <= end] whileTrue:[
- self at:index put:anObject.
- index := index + 1
+ self at:index put:anObject.
+ index := index + 1
]
"
@@ -590,9 +584,9 @@
therefore the change may affect all others referencing the receiver."
1 to:self size do:[:index |
- (self at:index) = oldObject ifTrue:[
- self at:index put:newObject
- ]
+ (self at:index) = oldObject ifTrue:[
+ self at:index put:newObject
+ ]
]
"
@@ -607,9 +601,9 @@
therefore the change may affect all others referencing the receiver."
1 to:self size do:[:index |
- (aCollection includes:(self at:index)) ifTrue:[
- self at:index put:newObject
- ]
+ (aCollection includes:(self at:index)) ifTrue:[
+ self at:index put:newObject
+ ]
]
"
@@ -626,9 +620,9 @@
therefore the change may affect all others referencing the receiver."
^ self replaceFrom:start
- to:(start + replacementCollection size - 1)
- with:replacementCollection
- startingAt:1
+ to:(start + replacementCollection size - 1)
+ with:replacementCollection
+ startingAt:1
"
'1234567890' replaceFrom:5 with:'abc'
@@ -644,9 +638,9 @@
therefore the change may affect all others referencing the receiver."
^ self replaceFrom:start
- to:(start + replacementCollection size - offset)
- with:replacementCollection
- startingAt:offset
+ to:(start + replacementCollection size - offset)
+ with:replacementCollection
+ startingAt:offset
"
'1234567890' replaceFrom:5 with:'abcdef' startingAt:3
@@ -661,9 +655,9 @@
therefore the change may affect all others referencing the receiver."
^ self replaceFrom:start
- to:stop
- with:replacementCollection
- startingAt:1
+ to:stop
+ with:replacementCollection
+ startingAt:1
"
'1234567890' replaceFrom:5 to:7 with:'abcdef'
@@ -682,27 +676,27 @@
end "{ Class: SmallInteger }" |
(replacementCollection == self) ifTrue:[
- (repStart < start) ifTrue:[
- " must do reverse copy "
- srcIndex := repStart + (stop - start).
- dstIndex := stop.
- end := start.
- [dstIndex >= end] whileTrue:[
- self at:dstIndex put:(replacementCollection at:srcIndex).
- srcIndex := srcIndex - 1.
- dstIndex := dstIndex - 1
- ].
- ^ self
- ]
+ (repStart < start) ifTrue:[
+ " must do reverse copy "
+ srcIndex := repStart + (stop - start).
+ dstIndex := stop.
+ end := start.
+ [dstIndex >= end] whileTrue:[
+ self at:dstIndex put:(replacementCollection at:srcIndex).
+ srcIndex := srcIndex - 1.
+ dstIndex := dstIndex - 1
+ ].
+ ^ self
+ ]
].
srcIndex := repStart.
dstIndex := start.
end := stop.
[dstIndex <= end] whileTrue:[
- self at:dstIndex put:(replacementCollection at:srcIndex).
- srcIndex := srcIndex + 1.
- dstIndex := dstIndex + 1
+ self at:dstIndex put:(replacementCollection at:srcIndex).
+ srcIndex := srcIndex + 1.
+ dstIndex := dstIndex + 1
]
"
@@ -751,8 +745,9 @@
Return the argument, anObject.
Notice, that this is modifies the receiver NOT a copy.
- Also note, that it may be a slow operation for some collections due to the grow:
- (i.e. for Strings and Arrays it is not recommened)"
+ Also note, that it may be a slow operation for some collections,
+ due to the grow:-message, which is inefficient for fixed size
+ collections (i.e. for Strings and Arrays it is not recommened)."
|newSize|
@@ -766,7 +761,7 @@
|a|
a:= #(1 2 3 4 5 6 7 8).
a addFirst:'hello'.
- a
+ a
"
"
|c|
@@ -781,8 +776,9 @@
Return the argument, anObject.
Notice, that this is modifies the receiver NOT a copy.
- Also note, that it may be a slow operation for some collections due to the grow:
- (i.e. for Strings and Arrays it is not recommened)"
+ Also note, that it may be a slow operation for some collections,
+ due to the grow:-message, which is inefficient for fixed size
+ collections (i.e. for Strings and Arrays it is not recommened)."
|newSize|
@@ -810,8 +806,9 @@
Return the receiver (sigh - ST-80 compatibility).
Notice, that this is modifies the receiver NOT a copy.
- Also note, that it may be a slow operation for some collections due to the grow:
- (i.e. for Strings and Arrays it is not recommened)"
+ Also note, that it may be a slow operation for some collections,
+ due to the grow:-message, which is inefficient for fixed size
+ collections (i.e. for Strings and Arrays it is not recommened)."
|newSize|
@@ -830,8 +827,9 @@
If not present, return the value of evaluating aBlock.
Notice, that this is modifies the receiver NOT a copy.
- Also note, that it may be a slow operation for some collections due to the grow:
- (i.e. for Strings and Arrays it is not recommened)"
+ Also note, that it may be a slow operation for some collections,
+ due to the grow:-message, which is inefficient for fixed size
+ collections (i.e. for Strings and Arrays it is not recommened)."
|any
dstIndex "{ Class: SmallInteger }"
@@ -841,18 +839,18 @@
any := false.
sz := self size.
1 to:sz do:[:srcIndex |
- (anElement = (self at:srcIndex)) ifTrue:[
- any := true
- ] ifFalse:[
- (dstIndex ~~ srcIndex) ifTrue:[
- self at:dstIndex put:(self at:srcIndex)
- ].
- dstIndex := dstIndex + 1
- ]
+ (anElement = (self at:srcIndex)) ifTrue:[
+ any := true
+ ] ifFalse:[
+ (dstIndex ~~ srcIndex) ifTrue:[
+ self at:dstIndex put:(self at:srcIndex)
+ ].
+ dstIndex := dstIndex + 1
+ ]
].
any ifTrue:[
- self grow:dstIndex - 1.
- ^ anElement
+ self grow:dstIndex - 1.
+ ^ anElement
].
^ aBlock value
@@ -867,17 +865,18 @@
Notice, that this is modifies the receiver - NOT a copy;
therefore any other users of the receiver will also see this change.
- Also note, that it may be a slow operation for some collections due to the grow:
- (i.e. for Strings and Arrays it is not recommened)"
+ Also note, that it may be a slow operation for some collections,
+ due to the grow:-message, which is inefficient for fixed size
+ collections (i.e. for Strings and Arrays it is not recommened)."
|newSize|
newSize := self size - endIndex + startIndex - 1.
newSize <= 0 ifTrue:[
- self grow:0
+ self grow:0
] ifFalse:[
- self replaceFrom:startIndex to:newSize with:self startingAt:(endIndex + 1).
- self grow:newSize
+ self replaceFrom:startIndex to:newSize with:self startingAt:(endIndex + 1).
+ self grow:newSize
]
"
@@ -892,8 +891,9 @@
"remove the argument stored at index and return it.
Notice, that this is modifies the receiver NOT a copy.
- Also note, that it may be a slow operation for some collections due to the grow:
- (i.e. for Strings and Arrays it is not recommened)"
+ Also note, that it may be a slow operation for some collections,
+ due to the grow:-message, which is inefficient for fixed size
+ collections (i.e. for Strings and Arrays it is not recommened)."
|element|
@@ -910,8 +910,9 @@
"remove the argument stored at index. Return the receiver.
Notice, that this is modifies the receiver NOT a copy.
- Also note, that it may be a slow operation for some collections due to the grow:
- (i.e. for Strings and Arrays it is not recommened)"
+ Also note, that it may be a slow operation for some collections,
+ due to the grow:-message, which is inefficient for fixed size
+ collections (i.e. for Strings and Arrays it is not recommened)."
self removeFromIndex:index toIndex:index
@@ -924,8 +925,9 @@
"remove the first element of the receiver and return it.
Notice, that this is modifies the receiver NOT a copy.
- Also note, that it may be a slow operation for some collections due to the grow:
- (i.e. for Strings and Arrays it is not recommened)"
+ Also note, that it may be a slow operation for some collections,
+ due to the grow:-message, which is inefficient for fixed size
+ collections (i.e. for Strings and Arrays it is not recommened)."
^ self removeAtIndex:1
@@ -941,8 +943,9 @@
"remove the last element of the receiver and return it.
Notice, that this is modifies the receiver NOT a copy.
- Also note, that it may be a slow operation for some collections due to the grow:
- (i.e. for Strings and Arrays it is not recommened)"
+ Also note, that it may be a slow operation for some collections,
+ due to the grow:-message, which is inefficient for fixed size
+ collections (i.e. for Strings and Arrays it is not recommened)."
^ self removeAtIndex:(self size)
@@ -950,7 +953,7 @@
|a|
a := #(1 2 3 4 5 6).
a removeLast.
- a
+ a
"
! !
@@ -967,12 +970,17 @@
stop := self size.
1 to:stop do:[:index |
- element := self at:index.
- (aBlock value:element) ifTrue:[
- ^ element
- ].
+ element := self at:index.
+ (aBlock value:element) ifTrue:[
+ ^ element
+ ].
].
^ exceptionBlock value
+
+ "
+ #(11 12 13 14) detect:[:n | n odd] ifNone:['sorry']
+ #(12 14 16 18) detect:[:n | n odd] ifNone:['sorry']
+ "
!
indexOf:anElement
@@ -1001,10 +1009,16 @@
index := self indexOf:anElement startingAt:1.
(index == 0) ifTrue:[^ exceptionBlock value].
^ index
+
+ "
+ #(10 20 30 40 10 20 30 40) indexOf:40 ifAbsent:['none']
+ #(10 20 30 40 10 20 30 40) indexOf:40.0 ifAbsent:['none']
+ #(10 20 30 40 10 20 30 40) indexOf:35 ifAbsent:['none']
+ "
!
indexOf:anElement startingAt:start
- "search the collection for anElement staring search at index start;
+ "search the collection for anElement, starting the search at index start;
if found, return the index otherwise return 0.
The comparison is done using =
(i.e. equality test - not identity test)."
@@ -1015,9 +1029,10 @@
startIndex := start.
stop := self size.
startIndex to:stop do:[:index |
- anElement = (self at:index) ifTrue:[^ index].
+ anElement = (self at:index) ifTrue:[^ index].
].
^ 0
+
"
#(10 20 30 40 10 20 30 40) indexOf:40 startingAt:5
#(10 20 30 40 10 20 30 40) indexOf:40.0 startingAt:5
@@ -1025,7 +1040,7 @@
!
indexOf:anElement startingAt:start ifAbsent:exceptionBlock
- "search the collection for anElement starting search at start;
+ "search the collection for anElement starting the search at index start;
if found, return the index otherwise return the value of the
exceptionBlock.
The comparison is done using =
@@ -1036,6 +1051,12 @@
index := self indexOf:anElement startingAt:start.
(index == 0) ifTrue:[^ exceptionBlock value].
^ index
+
+ "
+ #(10 20 30 40 10 20 30 40) indexOf:40 startingAt:5 ifAbsent:['none']
+ #(10 20 30 40 10 20 30 40) indexOf:40.0 startingAt:5 ifAbsent:['none']
+ #(10 20 30 40 10 20 30 40) indexOf:35 startingAt:5 ifAbsent:['none']
+ "
!
identityIndexOf:anElement
@@ -1045,9 +1066,9 @@
^ self identityIndexOf:anElement startingAt:1
"
- #(10 20 30 40 50 60 70) identityIndexOf: 40
- #(10 20 30 40 50 60 70) identityIndexOf: 40.0
- #(10 20 30 40 50 60 70) indexOf: 40.0
+ #(10 20 30 40 50 60 70) identityIndexOf:40
+ #(10 20 30 40 50 60 70) identityIndexOf:40.0
+ #(10 20 30 40 50 60 70) indexOf:40.0
"
!
@@ -1061,10 +1082,17 @@
index := self identityIndexOf:anElement startingAt:1.
(index == 0) ifTrue:[^ exceptionBlock value].
^ index
+
+ "
+ #(10 20 30 40 50 60 70) identityIndexOf:40 ifAbsent:['none']
+ #(10 20 30 40 50 60 70) identityIndexOf:35 ifAbsent:['none']
+ #(10 20 30 40 50 60 70) identityIndexOf:40.0 ifAbsent:['none']
+ #(10 20 30 40 50 60 70) indexOf:40.0 ifAbsent:['none']
+ "
!
identityIndexOf:anElement startingAt:start
- "search the collection for anElement staring search at index start
+ "search the collection for anElement, starting search at index start
using identity compare (i.e. ==);
if found, return the index otherwise return 0."
@@ -1074,19 +1102,19 @@
startIndex := start.
stop := self size.
startIndex to:stop do:[:index |
- anElement == (self at:index) ifTrue:[^ index].
+ anElement == (self at:index) ifTrue:[^ index].
].
^ 0
"
- #(10 20 30 40 10 20 30 40) identityIndexOf: 40 startingAt:5
- #(10 20 30 40 10 20 30 40) identityIndexOf: 40.0 startingAt:5
- #(10 20 30 40 10 20 30 40) indexOf: 40.0 startingAt:5
+ #(10 20 30 40 10 20 30 40) identityIndexOf:40 startingAt:5
+ #(10 20 30 40 10 20 30 40) identityIndexOf:40.0 startingAt:5
+ #(10 20 30 40 10 20 30 40) indexOf:40.0 startingAt:5
"
!
identityIndexOf:anElement startingAt:start ifAbsent:exceptionBlock
- "search the collection for anElement starting search at start;
+ "search the collection for anElement, starting search at index start;
if found, return the index otherwise return the value of the
exceptionBlock.
This one searches for identical objects (i.e. ==)."
@@ -1096,17 +1124,67 @@
index := self identityIndexOf:anElement startingAt:start.
(index == 0) ifTrue:[^ exceptionBlock value].
^ index
+
+ "
+ #(10 20 30 40 10) identityIndexOf:10 startingAt:3 ifAbsent:['none']
+ #(10 20 30 40 10) identityIndexOf:35 startingAt:3 ifAbsent:['none']
+ "
+!
+
+indexOfAny:aCollection
+ "search the collection for an element in aCollection.
+ if found, return the index otherwise return 0.
+ The comparison is done using =
+ (i.e. equality test - not identity test).
+
+ Notice, that for big collections, the runtime of this search
+ grows proportional to size(receiver) * size(aCollection).
+ You may think about using other mechanisms (Sets, Dictionaries etc)."
+
+ ^ self indexOfAny:aCollection startingAt:1
+
+ "
+ #(10 20 30 40 50 60 70) indexOfAny:#(40 30 50)
+ #(10 20 30 40 50 60 70) indexOfAny:#(40.0 30.0 50)
+ "
+!
+
+indexOfAny:aCollection startingAt:start
+ "search the collection for an element in aCollection,
+ starting the search at index start;
+ if found, return the index otherwise return 0.
+ The comparison is done using =
+ (i.e. equality test - not identity test).
+
+ Notice, that for big collections, the runtime of this search
+ grows proportional to size(receiver) * size(aCollection).
+ You may think about using other mechanisms (Sets, Dictionaries etc)."
+
+
+ |startIndex "{ Class: SmallInteger }"
+ stop "{ Class: SmallInteger }" |
+
+ startIndex := start.
+ stop := self size.
+ startIndex to:stop do:[:index |
+ (aCollection includes:(self at:index)) ifTrue:[^ index].
+ ].
+ ^ 0
+ "
+ #(10 20 30 40 10 20 30 40) indexOfAny:#(40 50 30) startingAt:5
+ #(10 20 30 40 10 20 30 40) indexOfAny:#(40.0 50 30.0) startingAt:5
+ "
!
findFirst:aBlock
"find the first element, for which evaluation of the argument, aBlock
- return true; return its index or 0 if none detected."
+ returns true; return its index or 0 if none detected."
|stop "{ Class: SmallInteger }" |
stop := self size.
1 to:stop do:[:index |
- (aBlock value:(self at:index)) ifTrue:[^ index].
+ (aBlock value:(self at:index)) ifTrue:[^ index].
].
^ 0
@@ -1119,13 +1197,13 @@
findLast:aBlock
"find the last element, for which evaluation of the argument, aBlock
- return true; return its index or 0 if none detected."
+ returns true; return its index or 0 if none detected."
|start "{ Class: SmallInteger }"|
start := self size.
start to:1 by:-1 do:[:index |
- (aBlock value:(self at:index)) ifTrue:[^ index].
+ (aBlock value:(self at:index)) ifTrue:[^ index].
].
^ 0
@@ -1162,11 +1240,11 @@
hiIndex := self size.
lowIndex := 1.
[lowIndex < hiIndex] whileTrue:[
- t := self at:lowIndex.
- self at:lowIndex put:(self at:hiIndex).
- self at:hiIndex put:t.
- lowIndex := lowIndex + 1.
- hiIndex := hiIndex - 1
+ t := self at:lowIndex.
+ self at:lowIndex put:(self at:hiIndex).
+ self at:hiIndex put:t.
+ lowIndex := lowIndex + 1.
+ hiIndex := hiIndex - 1
]
"
#(4 5 6 7 7) reverse
@@ -1186,18 +1264,18 @@
middleElement := self at:((b + e) // 2).
[b < e] whileTrue:[
- [b < end and:[(self at:b) < middleElement]] whileTrue:[b := b + 1].
- [e > begin and:[middleElement < (self at:e)]] whileTrue:[e := e - 1].
+ [b < end and:[(self at:b) < middleElement]] whileTrue:[b := b + 1].
+ [e > begin and:[middleElement < (self at:e)]] whileTrue:[e := e - 1].
- (b <= e) ifTrue:[
- (b == e) ifFalse:[
- temp := self at:b.
- self at:b put:(self at:e).
- self at:e put:temp
- ].
- b := b + 1.
- e := e - 1
- ]
+ (b <= e) ifTrue:[
+ (b == e) ifFalse:[
+ temp := self at:b.
+ self at:b put:(self at:e).
+ self at:e put:temp
+ ].
+ b := b + 1.
+ e := e - 1
+ ]
].
(begin < e) ifTrue:[self quickSortFrom:begin to:e].
(b < end) ifTrue:[self quickSortFrom:b to:end]
@@ -1215,21 +1293,21 @@
middleElement := self at:((b + e) // 2).
[b < e] whileTrue:[
- [b < end and:[(self at:b) < middleElement]] whileTrue:[b := b + 1].
- [e > begin and:[middleElement < (self at:e)]] whileTrue:[e := e - 1].
+ [b < end and:[(self at:b) < middleElement]] whileTrue:[b := b + 1].
+ [e > begin and:[middleElement < (self at:e)]] whileTrue:[e := e - 1].
- (b <= e) ifTrue:[
- (b == e) ifFalse:[
- temp := self at:b.
- self at:b put:(self at:e).
- self at:e put:temp.
- temp := aCollection at:b.
- aCollection at:b put:(aCollection at:e).
- aCollection at:e put:temp
- ].
- b := b + 1.
- e := e - 1
- ]
+ (b <= e) ifTrue:[
+ (b == e) ifFalse:[
+ temp := self at:b.
+ self at:b put:(self at:e).
+ self at:e put:temp.
+ temp := aCollection at:b.
+ aCollection at:b put:(aCollection at:e).
+ aCollection at:e put:temp
+ ].
+ b := b + 1.
+ e := e - 1
+ ]
].
(begin < e) ifTrue:[self quickSortFrom:begin to:e with:aCollection].
(b < end) ifTrue:[self quickSortFrom:b to:end with:aCollection]
@@ -1247,18 +1325,18 @@
middleElement := self at:((b + e) // 2).
[b < e] whileTrue:[
- [b < end and:[sortBlock value:(self at:b) value:middleElement]] whileTrue:[b := b + 1].
- [e > begin and:[sortBlock value:middleElement value:(self at:e)]] whileTrue:[e := e - 1].
+ [b < end and:[sortBlock value:(self at:b) value:middleElement]] whileTrue:[b := b + 1].
+ [e > begin and:[sortBlock value:middleElement value:(self at:e)]] whileTrue:[e := e - 1].
- (b <= e) ifTrue:[
- (b == e) ifFalse:[
- temp := self at:b.
- self at:b put:(self at:e).
- self at:e put:temp
- ].
- b := b + 1.
- e := e - 1
- ]
+ (b <= e) ifTrue:[
+ (b == e) ifFalse:[
+ temp := self at:b.
+ self at:b put:(self at:e).
+ self at:e put:temp
+ ].
+ b := b + 1.
+ e := e - 1
+ ]
].
(begin < e) ifTrue:[self quickSortFrom:begin to:e sortBlock:sortBlock].
(b < end) ifTrue:[self quickSortFrom:b to:end sortBlock:sortBlock]
@@ -1276,21 +1354,21 @@
middleElement := self at:((b + e) // 2).
[b < e] whileTrue:[
- [b < end and:[sortBlock value:(self at:b) value:middleElement]] whileTrue:[b := b + 1].
- [e > begin and:[sortBlock value:middleElement value:(self at:e)]] whileTrue:[e := e - 1].
+ [b < end and:[sortBlock value:(self at:b) value:middleElement]] whileTrue:[b := b + 1].
+ [e > begin and:[sortBlock value:middleElement value:(self at:e)]] whileTrue:[e := e - 1].
- (b <= e) ifTrue:[
- (b == e) ifFalse:[
- temp := self at:b.
- self at:b put:(self at:e).
- self at:e put:temp.
- temp := aCollection at:b.
- aCollection at:b put:(aCollection at:e).
- aCollection at:e put:temp
- ].
- b := b + 1.
- e := e - 1
- ]
+ (b <= e) ifTrue:[
+ (b == e) ifFalse:[
+ temp := self at:b.
+ self at:b put:(self at:e).
+ self at:e put:temp.
+ temp := aCollection at:b.
+ aCollection at:b put:(aCollection at:e).
+ aCollection at:e put:temp
+ ].
+ b := b + 1.
+ e := e - 1
+ ]
].
(begin < e) ifTrue:[self quickSortFrom:begin to:e sortBlock:sortBlock with:aCollection].
(b < end) ifTrue:[self quickSortFrom:b to:end sortBlock:sortBlock with:aCollection]
@@ -1298,7 +1376,7 @@
topologicalSort:sortBlock
"sort the collection inplace using a sloooow sort algorithm.
- This algorithm has O-square runtime behavior ad should be used only
+ This algorithm has O-square runtime behavior and should be used only
in special situations.
It compares all elements, thus can be used when a>b, b>c does NOT imply
a>c (for example, to sort classes by inheritance)
@@ -1314,21 +1392,21 @@
end := self size.
1 to:end do:[:index |
- smallest := self at:index.
- smallestIndex := index.
+ smallest := self at:index.
+ smallestIndex := index.
- (index + 1) to:end do:[:index2 |
- thisOne := self at:index2.
- (sortBlock value:thisOne value:smallest) ifTrue:[
- smallestIndex := index2.
- smallest := thisOne
- ].
- ].
- (smallestIndex ~~ index) ifTrue:[
- thisOne := self at:index.
- self at:index put:smallest.
- self at:smallestIndex put:thisOne
- ].
+ (index + 1) to:end do:[:index2 |
+ thisOne := self at:index2.
+ (sortBlock value:thisOne value:smallest) ifTrue:[
+ smallestIndex := index2.
+ smallest := thisOne
+ ].
+ ].
+ (smallestIndex ~~ index) ifTrue:[
+ thisOne := self at:index.
+ self at:index put:smallest.
+ self at:smallestIndex put:thisOne
+ ].
]
"
@@ -1341,13 +1419,15 @@
sort
"sort the collection inplace. The elements are compared using
- > and < i.e. they should offer a magnitude-like protocol."
+ > and < i.e. they should offer a magnitude-like protocol.
+ The implementation uses the quicksort algorithm, which may not be
+ the best possible for all situations."
|stop|
stop := self size.
(stop > 1) ifTrue:[
- self quickSortFrom:1 to:stop
+ self quickSortFrom:1 to:stop
]
"
@@ -1370,7 +1450,7 @@
stop := self size.
(stop > 1) ifTrue:[
- self quickSortFrom:1 to:stop sortBlock:sortBlock
+ self quickSortFrom:1 to:stop sortBlock:sortBlock
]
"
@@ -1387,7 +1467,7 @@
stop := self size.
(stop > 1) ifTrue:[
- self quickSortFrom:1 to:stop with:aCollection
+ self quickSortFrom:1 to:stop with:aCollection
]
"
@@ -1402,13 +1482,14 @@
sort:sortBlock with:aCollection
"sort the collection inplace using the 2-arg block sortBlock
- for comparison. Also reorder the elements in aCollection"
+ for comparison. Also reorder the elements in aCollection.
+ Use, when you have a key collection to sort some other collection with."
|stop|
stop := self size.
(stop > 1) ifTrue:[
- self quickSortFrom:1 to:stop sortBlock:sortBlock with:aCollection
+ self quickSortFrom:1 to:stop sortBlock:sortBlock with:aCollection
]
"
@@ -1430,7 +1511,7 @@
stop := self size.
1 to:stop do:[:index |
- aBlock value:(self at:index).
+ aBlock value:(self at:index).
]
"
#(one two three four five six) do:[:element | Transcript showCr:element]
@@ -1445,7 +1526,7 @@
stop := self size.
1 to:stop do:[:index |
- aTwoArgBlock value:index value:(self at:index).
+ aTwoArgBlock value:index value:(self at:index).
]
"
#(one two three four five six) keysAndValuesDo:[:key :element | Transcript show:key; space; showCr:element]
@@ -1462,7 +1543,7 @@
stop := self size.
1 to:stop do:[:index |
- aTwoArgBlock value:(self at:index) value:(aSequenceableCollection at:index).
+ aTwoArgBlock value:(self at:index) value:(aSequenceableCollection at:index).
]
"
#(one two three four five six) with:(1 to:10) do:[:el1 :el2 | Transcript show:el1; space; showCr:el2]
@@ -1479,7 +1560,7 @@
start := index1.
stop := index2.
start to:stop do:[:index |
- aBlock value:(self at:index).
+ aBlock value:(self at:index).
]
"
@@ -1497,7 +1578,7 @@
start := index1.
stop := index2.
stop to:start by:-1 do:[:index |
- aBlock value:(self at:index).
+ aBlock value:(self at:index).
]
"
@@ -1513,7 +1594,7 @@
sz := self size.
sz to:1 by:-1 do:[:index |
- aBlock value:(self at:index).
+ aBlock value:(self at:index).
]
"
@@ -1529,9 +1610,9 @@
sz "{ Class:SmallInteger }"|
sz := self size.
- newCollection := (self species new:sz) finalizeCopyFrom:self.
+ newCollection := (self species new:sz) postCopyFrom:self.
1 to:sz do:[:index |
- newCollection at:index put:(aBlock value:(self at:index)).
+ newCollection at:index put:(aBlock value:(self at:index)).
].
^ newCollection
@@ -1542,6 +1623,26 @@
"
!
+from:start to:stop collect:aBlock
+ "evaluate the argument, aBlock for the elements indexed by start
+ to stop in the collection and return a collection of the results"
+
+ |newCollection
+ idx "{ Class:SmallInteger }"|
+
+ newCollection := (self species new:(stop - start + 1)) postCopyFrom:self.
+ idx := 1.
+ start to:stop do:[:index |
+ newCollection at:idx put:(aBlock value:(self at:index)).
+ idx := idx + 1
+ ].
+ ^ newCollection
+
+ "
+ #(one two three four five six) from:2 to:4 collect:[:element | element asUppercase]
+ "
+!
+
select:aBlock
"evaluate the argument, aBlock for every element in the collection
and return a collection of all elements for which the block return
@@ -1553,26 +1654,27 @@
sz := self size.
species := self species.
species growIsCheap ifFalse:[
- newColl := OrderedCollection new:sz.
- needCopy := true
+ newColl := OrderedCollection new:sz.
+ needCopy := true
] ifTrue:[
- newColl := (species new:sz) finalizeCopyFrom:self.
- needCopy := false
+ newColl := (species new:sz) postCopyFrom:self.
+ needCopy := false
].
1 to:sz do:[:index |
- element := self at:index.
- (aBlock value:element) ifTrue:[
- newColl add:element
- ].
+ element := self at:index.
+ (aBlock value:element) ifTrue:[
+ newColl add:element
+ ].
].
needCopy ifTrue:[
- newColl := (species withAll:newColl) finalizeCopyFrom:self
+ newColl := (species withAll:newColl) postCopyFrom:self
].
^ newColl
"
#(one two three four five six) select:[:element | element startsWith:'f']
#(1 2 3 4 5 6 7 8 9) select:[:element | element odd]
+ (#(17 12 1 98 51) asSortedCollection:[:a :b | b < a]) select:[:element | element odd]
(1 to:9) select:[:element | element odd]
(Smalltalk allClasses) select:[:class | class name startsWith:'S']
"
--- a/SequenceableCollection.st Mon Oct 10 01:29:01 1994 +0100
+++ b/SequenceableCollection.st Mon Oct 10 01:29:28 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -19,9 +19,9 @@
SequenceableCollection comment:'
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/SequenceableCollection.st,v 1.14 1994-08-22 12:13:09 claus Exp $
+$Header: /cvs/stx/stx/libbasic/SequenceableCollection.st,v 1.15 1994-10-10 00:28:06 claus Exp $
'!
!SequenceableCollection class methodsFor:'documentation'!
@@ -29,7 +29,7 @@
copyright
"
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/SequenceableCollection.st,v 1.14 1994-08-22 12:13:09 claus Exp $
+$Header: /cvs/stx/stx/libbasic/SequenceableCollection.st,v 1.15 1994-10-10 00:28:06 claus Exp $
"
!
@@ -88,15 +88,15 @@
the exceptionblock."
((index < 1) or:[index > self size]) ifTrue:[
- ^ exceptionBlock value
+ ^ exceptionBlock value
].
^ self at:index
"
#(1 2 3) at:4 ifAbsent:['no such index']
(Dictionary with:(#foo -> #bar)
- with:(#frob -> #baz))
- at:#foobar ifAbsent:['no such index']
+ with:(#frob -> #baz))
+ at:#foobar ifAbsent:['no such index']
"
! !
@@ -134,7 +134,7 @@
sz := self size.
sz == 0 ifTrue:[
- ^ #()
+ ^ #()
].
^ 1 to:sz
! !
@@ -156,8 +156,8 @@
index := 1.
[index <= stop] whileTrue:[
- (self at:index) = (aCollection at:index) ifFalse:[^false].
- index := index + 1
+ (self at:index) = (aCollection at:index) ifFalse:[^false].
+ index := index + 1
].
^ true
@@ -199,8 +199,8 @@
index := 1.
[index <= stop] whileTrue:[
- (self at:index) = (aCollection at:index) ifFalse:[^false].
- index := index + 1
+ (self at:index) = (aCollection at:index) ifFalse:[^false].
+ index := index + 1
].
^ true
@@ -230,9 +230,9 @@
index1 := sz.
index2 := stop.
[index2 > 0] whileTrue:[
- (self at:index1) = (aCollection at:index2) ifFalse:[^ false].
- index1 := index1 - 1.
- index2 := index2 - 1
+ (self at:index1) = (aCollection at:index2) ifFalse:[^ false].
+ index1 := index1 - 1.
+ index2 := index2 - 1
].
^ true
@@ -260,22 +260,21 @@
mySize := self size.
otherSize := aCollection size.
newSize := mySize + otherSize.
-"/ newCollection := self species new:newSize.
- newCollection := (self species new:newSize) finalizeCopyFrom:self.
+ newCollection := (self species new:newSize) postCopyFrom:self.
newCollection replaceFrom:1 to:mySize with:self startingAt:1.
dstIndex := mySize + 1.
(aCollection isSequenceableCollection) ifTrue:[
- "yes, aCollection has indexed elements"
- newCollection replaceFrom:dstIndex to:newSize
- with:aCollection startingAt:1.
- ^ newCollection
+ "yes, aCollection has indexed elements"
+ newCollection replaceFrom:dstIndex to:newSize
+ with:aCollection startingAt:1.
+ ^ newCollection
] ifFalse:[
- "no, enumerate aCollection"
- aCollection do:[:element |
- newCollection at:dstIndex put:element.
- dstIndex := dstIndex + 1
- ]
+ "no, enumerate aCollection"
+ aCollection do:[:element |
+ newCollection at:dstIndex put:element.
+ dstIndex := dstIndex + 1
+ ]
].
^ newCollection
@@ -297,8 +296,7 @@
mySize := self size.
newSize := mySize + 1.
-"/ newCollection := self species new:newSize.
- newCollection := (self species new:newSize) finalizeCopyFrom:self.
+ newCollection := (self species new:newSize) postCopyFrom:self.
newCollection replaceFrom:1 to:mySize with:self startingAt:1.
newCollection at:newSize put:newElement.
^newCollection
@@ -322,8 +320,7 @@
(skipIndex == 0) ifTrue:[^ self copy].
sz := self size.
-"/ copy := self class new:(sz - 1).
- copy := (self species new:(sz - 1)) finalizeCopyFrom:self.
+ copy := (self species new:(sz - 1)) postCopyFrom:self.
copy replaceFrom:1 to:(skipIndex - 1) with:self startingAt:1.
copy replaceFrom:skipIndex to:(sz - 1) with:self startingAt:(skipIndex + 1).
^ copy
@@ -351,25 +348,24 @@
n == 0 ifTrue:[^ self copy].
sz := self size.
-"/ copy := self species new:(sz - n).
- copy := (self species new:(sz - n)) finalizeCopyFrom:self.
+ copy := (self species new:(sz - n)) postCopyFrom:self.
srcIndex := 1.
dstIndex := 1.
n timesRepeat:[
- skipIndex := self indexOf:elementToSkip startingAt:srcIndex.
- l := skipIndex - srcIndex.
- l ~~ 0 ifTrue:[
- copy replaceFrom:dstIndex to:(dstIndex + l - 1)
- with:self startingAt:srcIndex.
- dstIndex := dstIndex + l
- ].
- srcIndex := skipIndex + 1
+ skipIndex := self indexOf:elementToSkip startingAt:srcIndex.
+ l := skipIndex - srcIndex.
+ l ~~ 0 ifTrue:[
+ copy replaceFrom:dstIndex to:(dstIndex + l - 1)
+ with:self startingAt:srcIndex.
+ dstIndex := dstIndex + l
+ ].
+ srcIndex := skipIndex + 1
].
l := sz - srcIndex.
copy replaceFrom:dstIndex to:(dstIndex + l)
- with:self startingAt:srcIndex.
+ with:self startingAt:srcIndex.
^ copy
"
@@ -390,16 +386,15 @@
|copy sz|
sz := self size.
-"/ copy := self species new:(sz - 1).
- copy := (self species new:(sz - 1)) finalizeCopyFrom:self.
+ copy := (self species new:(sz - 1)) postCopyFrom:self.
copy replaceFrom:1
- to:(omitIndex - 1)
- with:self
- startingAt:1.
+ to:(omitIndex - 1)
+ with:self
+ startingAt:1.
copy replaceFrom:omitIndex
- to:sz - 1
- with:self
- startingAt:(omitIndex + 1).
+ to:sz - 1
+ with:self
+ startingAt:(omitIndex + 1).
^ copy
"
@@ -415,8 +410,7 @@
|newCollection newSize|
newSize := stop - start + 1.
-"/ newCollection := self species new:newSize.
- newCollection := (self species new:newSize) finalizeCopyFrom:self.
+ newCollection := (self species new:newSize) postCopyFrom:self.
newCollection replaceFrom:1 to:newSize with:self startingAt:start.
^ newCollection
@@ -485,7 +479,7 @@
idx := self indexOf:element.
idx == 0 ifTrue:[^ nil]. "question: is this ok?"
- idx == 1 ifTrue:[^ self species new finalizeCopyFrom:self].
+ idx == 1 ifTrue:[^ self species new postCopyFrom:self].
^ self copyFrom:1 to:(idx-1)
"
@@ -522,7 +516,7 @@
replSize := aCollection size.
newColl := self species new:(self size - (endIndex - startIndex + 1) + replSize).
- newColl finalizeCopyFrom:self.
+ newColl postCopyFrom:self.
newColl replaceFrom:1 to:(startIndex - 1) with:self.
newColl replaceFrom:startIndex with:aCollection.
newColl replaceFrom:(startIndex + replSize) with:self startingAt:(endIndex + 1).
@@ -548,8 +542,8 @@
index := index1.
end := index2.
[index <= end] whileTrue:[
- self at:index put:anObject.
- index := index + 1
+ self at:index put:anObject.
+ index := index + 1
]
"
@@ -590,9 +584,9 @@
therefore the change may affect all others referencing the receiver."
1 to:self size do:[:index |
- (self at:index) = oldObject ifTrue:[
- self at:index put:newObject
- ]
+ (self at:index) = oldObject ifTrue:[
+ self at:index put:newObject
+ ]
]
"
@@ -607,9 +601,9 @@
therefore the change may affect all others referencing the receiver."
1 to:self size do:[:index |
- (aCollection includes:(self at:index)) ifTrue:[
- self at:index put:newObject
- ]
+ (aCollection includes:(self at:index)) ifTrue:[
+ self at:index put:newObject
+ ]
]
"
@@ -626,9 +620,9 @@
therefore the change may affect all others referencing the receiver."
^ self replaceFrom:start
- to:(start + replacementCollection size - 1)
- with:replacementCollection
- startingAt:1
+ to:(start + replacementCollection size - 1)
+ with:replacementCollection
+ startingAt:1
"
'1234567890' replaceFrom:5 with:'abc'
@@ -644,9 +638,9 @@
therefore the change may affect all others referencing the receiver."
^ self replaceFrom:start
- to:(start + replacementCollection size - offset)
- with:replacementCollection
- startingAt:offset
+ to:(start + replacementCollection size - offset)
+ with:replacementCollection
+ startingAt:offset
"
'1234567890' replaceFrom:5 with:'abcdef' startingAt:3
@@ -661,9 +655,9 @@
therefore the change may affect all others referencing the receiver."
^ self replaceFrom:start
- to:stop
- with:replacementCollection
- startingAt:1
+ to:stop
+ with:replacementCollection
+ startingAt:1
"
'1234567890' replaceFrom:5 to:7 with:'abcdef'
@@ -682,27 +676,27 @@
end "{ Class: SmallInteger }" |
(replacementCollection == self) ifTrue:[
- (repStart < start) ifTrue:[
- " must do reverse copy "
- srcIndex := repStart + (stop - start).
- dstIndex := stop.
- end := start.
- [dstIndex >= end] whileTrue:[
- self at:dstIndex put:(replacementCollection at:srcIndex).
- srcIndex := srcIndex - 1.
- dstIndex := dstIndex - 1
- ].
- ^ self
- ]
+ (repStart < start) ifTrue:[
+ " must do reverse copy "
+ srcIndex := repStart + (stop - start).
+ dstIndex := stop.
+ end := start.
+ [dstIndex >= end] whileTrue:[
+ self at:dstIndex put:(replacementCollection at:srcIndex).
+ srcIndex := srcIndex - 1.
+ dstIndex := dstIndex - 1
+ ].
+ ^ self
+ ]
].
srcIndex := repStart.
dstIndex := start.
end := stop.
[dstIndex <= end] whileTrue:[
- self at:dstIndex put:(replacementCollection at:srcIndex).
- srcIndex := srcIndex + 1.
- dstIndex := dstIndex + 1
+ self at:dstIndex put:(replacementCollection at:srcIndex).
+ srcIndex := srcIndex + 1.
+ dstIndex := dstIndex + 1
]
"
@@ -751,8 +745,9 @@
Return the argument, anObject.
Notice, that this is modifies the receiver NOT a copy.
- Also note, that it may be a slow operation for some collections due to the grow:
- (i.e. for Strings and Arrays it is not recommened)"
+ Also note, that it may be a slow operation for some collections,
+ due to the grow:-message, which is inefficient for fixed size
+ collections (i.e. for Strings and Arrays it is not recommened)."
|newSize|
@@ -766,7 +761,7 @@
|a|
a:= #(1 2 3 4 5 6 7 8).
a addFirst:'hello'.
- a
+ a
"
"
|c|
@@ -781,8 +776,9 @@
Return the argument, anObject.
Notice, that this is modifies the receiver NOT a copy.
- Also note, that it may be a slow operation for some collections due to the grow:
- (i.e. for Strings and Arrays it is not recommened)"
+ Also note, that it may be a slow operation for some collections,
+ due to the grow:-message, which is inefficient for fixed size
+ collections (i.e. for Strings and Arrays it is not recommened)."
|newSize|
@@ -810,8 +806,9 @@
Return the receiver (sigh - ST-80 compatibility).
Notice, that this is modifies the receiver NOT a copy.
- Also note, that it may be a slow operation for some collections due to the grow:
- (i.e. for Strings and Arrays it is not recommened)"
+ Also note, that it may be a slow operation for some collections,
+ due to the grow:-message, which is inefficient for fixed size
+ collections (i.e. for Strings and Arrays it is not recommened)."
|newSize|
@@ -830,8 +827,9 @@
If not present, return the value of evaluating aBlock.
Notice, that this is modifies the receiver NOT a copy.
- Also note, that it may be a slow operation for some collections due to the grow:
- (i.e. for Strings and Arrays it is not recommened)"
+ Also note, that it may be a slow operation for some collections,
+ due to the grow:-message, which is inefficient for fixed size
+ collections (i.e. for Strings and Arrays it is not recommened)."
|any
dstIndex "{ Class: SmallInteger }"
@@ -841,18 +839,18 @@
any := false.
sz := self size.
1 to:sz do:[:srcIndex |
- (anElement = (self at:srcIndex)) ifTrue:[
- any := true
- ] ifFalse:[
- (dstIndex ~~ srcIndex) ifTrue:[
- self at:dstIndex put:(self at:srcIndex)
- ].
- dstIndex := dstIndex + 1
- ]
+ (anElement = (self at:srcIndex)) ifTrue:[
+ any := true
+ ] ifFalse:[
+ (dstIndex ~~ srcIndex) ifTrue:[
+ self at:dstIndex put:(self at:srcIndex)
+ ].
+ dstIndex := dstIndex + 1
+ ]
].
any ifTrue:[
- self grow:dstIndex - 1.
- ^ anElement
+ self grow:dstIndex - 1.
+ ^ anElement
].
^ aBlock value
@@ -867,17 +865,18 @@
Notice, that this is modifies the receiver - NOT a copy;
therefore any other users of the receiver will also see this change.
- Also note, that it may be a slow operation for some collections due to the grow:
- (i.e. for Strings and Arrays it is not recommened)"
+ Also note, that it may be a slow operation for some collections,
+ due to the grow:-message, which is inefficient for fixed size
+ collections (i.e. for Strings and Arrays it is not recommened)."
|newSize|
newSize := self size - endIndex + startIndex - 1.
newSize <= 0 ifTrue:[
- self grow:0
+ self grow:0
] ifFalse:[
- self replaceFrom:startIndex to:newSize with:self startingAt:(endIndex + 1).
- self grow:newSize
+ self replaceFrom:startIndex to:newSize with:self startingAt:(endIndex + 1).
+ self grow:newSize
]
"
@@ -892,8 +891,9 @@
"remove the argument stored at index and return it.
Notice, that this is modifies the receiver NOT a copy.
- Also note, that it may be a slow operation for some collections due to the grow:
- (i.e. for Strings and Arrays it is not recommened)"
+ Also note, that it may be a slow operation for some collections,
+ due to the grow:-message, which is inefficient for fixed size
+ collections (i.e. for Strings and Arrays it is not recommened)."
|element|
@@ -910,8 +910,9 @@
"remove the argument stored at index. Return the receiver.
Notice, that this is modifies the receiver NOT a copy.
- Also note, that it may be a slow operation for some collections due to the grow:
- (i.e. for Strings and Arrays it is not recommened)"
+ Also note, that it may be a slow operation for some collections,
+ due to the grow:-message, which is inefficient for fixed size
+ collections (i.e. for Strings and Arrays it is not recommened)."
self removeFromIndex:index toIndex:index
@@ -924,8 +925,9 @@
"remove the first element of the receiver and return it.
Notice, that this is modifies the receiver NOT a copy.
- Also note, that it may be a slow operation for some collections due to the grow:
- (i.e. for Strings and Arrays it is not recommened)"
+ Also note, that it may be a slow operation for some collections,
+ due to the grow:-message, which is inefficient for fixed size
+ collections (i.e. for Strings and Arrays it is not recommened)."
^ self removeAtIndex:1
@@ -941,8 +943,9 @@
"remove the last element of the receiver and return it.
Notice, that this is modifies the receiver NOT a copy.
- Also note, that it may be a slow operation for some collections due to the grow:
- (i.e. for Strings and Arrays it is not recommened)"
+ Also note, that it may be a slow operation for some collections,
+ due to the grow:-message, which is inefficient for fixed size
+ collections (i.e. for Strings and Arrays it is not recommened)."
^ self removeAtIndex:(self size)
@@ -950,7 +953,7 @@
|a|
a := #(1 2 3 4 5 6).
a removeLast.
- a
+ a
"
! !
@@ -967,12 +970,17 @@
stop := self size.
1 to:stop do:[:index |
- element := self at:index.
- (aBlock value:element) ifTrue:[
- ^ element
- ].
+ element := self at:index.
+ (aBlock value:element) ifTrue:[
+ ^ element
+ ].
].
^ exceptionBlock value
+
+ "
+ #(11 12 13 14) detect:[:n | n odd] ifNone:['sorry']
+ #(12 14 16 18) detect:[:n | n odd] ifNone:['sorry']
+ "
!
indexOf:anElement
@@ -1001,10 +1009,16 @@
index := self indexOf:anElement startingAt:1.
(index == 0) ifTrue:[^ exceptionBlock value].
^ index
+
+ "
+ #(10 20 30 40 10 20 30 40) indexOf:40 ifAbsent:['none']
+ #(10 20 30 40 10 20 30 40) indexOf:40.0 ifAbsent:['none']
+ #(10 20 30 40 10 20 30 40) indexOf:35 ifAbsent:['none']
+ "
!
indexOf:anElement startingAt:start
- "search the collection for anElement staring search at index start;
+ "search the collection for anElement, starting the search at index start;
if found, return the index otherwise return 0.
The comparison is done using =
(i.e. equality test - not identity test)."
@@ -1015,9 +1029,10 @@
startIndex := start.
stop := self size.
startIndex to:stop do:[:index |
- anElement = (self at:index) ifTrue:[^ index].
+ anElement = (self at:index) ifTrue:[^ index].
].
^ 0
+
"
#(10 20 30 40 10 20 30 40) indexOf:40 startingAt:5
#(10 20 30 40 10 20 30 40) indexOf:40.0 startingAt:5
@@ -1025,7 +1040,7 @@
!
indexOf:anElement startingAt:start ifAbsent:exceptionBlock
- "search the collection for anElement starting search at start;
+ "search the collection for anElement starting the search at index start;
if found, return the index otherwise return the value of the
exceptionBlock.
The comparison is done using =
@@ -1036,6 +1051,12 @@
index := self indexOf:anElement startingAt:start.
(index == 0) ifTrue:[^ exceptionBlock value].
^ index
+
+ "
+ #(10 20 30 40 10 20 30 40) indexOf:40 startingAt:5 ifAbsent:['none']
+ #(10 20 30 40 10 20 30 40) indexOf:40.0 startingAt:5 ifAbsent:['none']
+ #(10 20 30 40 10 20 30 40) indexOf:35 startingAt:5 ifAbsent:['none']
+ "
!
identityIndexOf:anElement
@@ -1045,9 +1066,9 @@
^ self identityIndexOf:anElement startingAt:1
"
- #(10 20 30 40 50 60 70) identityIndexOf: 40
- #(10 20 30 40 50 60 70) identityIndexOf: 40.0
- #(10 20 30 40 50 60 70) indexOf: 40.0
+ #(10 20 30 40 50 60 70) identityIndexOf:40
+ #(10 20 30 40 50 60 70) identityIndexOf:40.0
+ #(10 20 30 40 50 60 70) indexOf:40.0
"
!
@@ -1061,10 +1082,17 @@
index := self identityIndexOf:anElement startingAt:1.
(index == 0) ifTrue:[^ exceptionBlock value].
^ index
+
+ "
+ #(10 20 30 40 50 60 70) identityIndexOf:40 ifAbsent:['none']
+ #(10 20 30 40 50 60 70) identityIndexOf:35 ifAbsent:['none']
+ #(10 20 30 40 50 60 70) identityIndexOf:40.0 ifAbsent:['none']
+ #(10 20 30 40 50 60 70) indexOf:40.0 ifAbsent:['none']
+ "
!
identityIndexOf:anElement startingAt:start
- "search the collection for anElement staring search at index start
+ "search the collection for anElement, starting search at index start
using identity compare (i.e. ==);
if found, return the index otherwise return 0."
@@ -1074,19 +1102,19 @@
startIndex := start.
stop := self size.
startIndex to:stop do:[:index |
- anElement == (self at:index) ifTrue:[^ index].
+ anElement == (self at:index) ifTrue:[^ index].
].
^ 0
"
- #(10 20 30 40 10 20 30 40) identityIndexOf: 40 startingAt:5
- #(10 20 30 40 10 20 30 40) identityIndexOf: 40.0 startingAt:5
- #(10 20 30 40 10 20 30 40) indexOf: 40.0 startingAt:5
+ #(10 20 30 40 10 20 30 40) identityIndexOf:40 startingAt:5
+ #(10 20 30 40 10 20 30 40) identityIndexOf:40.0 startingAt:5
+ #(10 20 30 40 10 20 30 40) indexOf:40.0 startingAt:5
"
!
identityIndexOf:anElement startingAt:start ifAbsent:exceptionBlock
- "search the collection for anElement starting search at start;
+ "search the collection for anElement, starting search at index start;
if found, return the index otherwise return the value of the
exceptionBlock.
This one searches for identical objects (i.e. ==)."
@@ -1096,17 +1124,67 @@
index := self identityIndexOf:anElement startingAt:start.
(index == 0) ifTrue:[^ exceptionBlock value].
^ index
+
+ "
+ #(10 20 30 40 10) identityIndexOf:10 startingAt:3 ifAbsent:['none']
+ #(10 20 30 40 10) identityIndexOf:35 startingAt:3 ifAbsent:['none']
+ "
+!
+
+indexOfAny:aCollection
+ "search the collection for an element in aCollection.
+ if found, return the index otherwise return 0.
+ The comparison is done using =
+ (i.e. equality test - not identity test).
+
+ Notice, that for big collections, the runtime of this search
+ grows proportional to size(receiver) * size(aCollection).
+ You may think about using other mechanisms (Sets, Dictionaries etc)."
+
+ ^ self indexOfAny:aCollection startingAt:1
+
+ "
+ #(10 20 30 40 50 60 70) indexOfAny:#(40 30 50)
+ #(10 20 30 40 50 60 70) indexOfAny:#(40.0 30.0 50)
+ "
+!
+
+indexOfAny:aCollection startingAt:start
+ "search the collection for an element in aCollection,
+ starting the search at index start;
+ if found, return the index otherwise return 0.
+ The comparison is done using =
+ (i.e. equality test - not identity test).
+
+ Notice, that for big collections, the runtime of this search
+ grows proportional to size(receiver) * size(aCollection).
+ You may think about using other mechanisms (Sets, Dictionaries etc)."
+
+
+ |startIndex "{ Class: SmallInteger }"
+ stop "{ Class: SmallInteger }" |
+
+ startIndex := start.
+ stop := self size.
+ startIndex to:stop do:[:index |
+ (aCollection includes:(self at:index)) ifTrue:[^ index].
+ ].
+ ^ 0
+ "
+ #(10 20 30 40 10 20 30 40) indexOfAny:#(40 50 30) startingAt:5
+ #(10 20 30 40 10 20 30 40) indexOfAny:#(40.0 50 30.0) startingAt:5
+ "
!
findFirst:aBlock
"find the first element, for which evaluation of the argument, aBlock
- return true; return its index or 0 if none detected."
+ returns true; return its index or 0 if none detected."
|stop "{ Class: SmallInteger }" |
stop := self size.
1 to:stop do:[:index |
- (aBlock value:(self at:index)) ifTrue:[^ index].
+ (aBlock value:(self at:index)) ifTrue:[^ index].
].
^ 0
@@ -1119,13 +1197,13 @@
findLast:aBlock
"find the last element, for which evaluation of the argument, aBlock
- return true; return its index or 0 if none detected."
+ returns true; return its index or 0 if none detected."
|start "{ Class: SmallInteger }"|
start := self size.
start to:1 by:-1 do:[:index |
- (aBlock value:(self at:index)) ifTrue:[^ index].
+ (aBlock value:(self at:index)) ifTrue:[^ index].
].
^ 0
@@ -1162,11 +1240,11 @@
hiIndex := self size.
lowIndex := 1.
[lowIndex < hiIndex] whileTrue:[
- t := self at:lowIndex.
- self at:lowIndex put:(self at:hiIndex).
- self at:hiIndex put:t.
- lowIndex := lowIndex + 1.
- hiIndex := hiIndex - 1
+ t := self at:lowIndex.
+ self at:lowIndex put:(self at:hiIndex).
+ self at:hiIndex put:t.
+ lowIndex := lowIndex + 1.
+ hiIndex := hiIndex - 1
]
"
#(4 5 6 7 7) reverse
@@ -1186,18 +1264,18 @@
middleElement := self at:((b + e) // 2).
[b < e] whileTrue:[
- [b < end and:[(self at:b) < middleElement]] whileTrue:[b := b + 1].
- [e > begin and:[middleElement < (self at:e)]] whileTrue:[e := e - 1].
+ [b < end and:[(self at:b) < middleElement]] whileTrue:[b := b + 1].
+ [e > begin and:[middleElement < (self at:e)]] whileTrue:[e := e - 1].
- (b <= e) ifTrue:[
- (b == e) ifFalse:[
- temp := self at:b.
- self at:b put:(self at:e).
- self at:e put:temp
- ].
- b := b + 1.
- e := e - 1
- ]
+ (b <= e) ifTrue:[
+ (b == e) ifFalse:[
+ temp := self at:b.
+ self at:b put:(self at:e).
+ self at:e put:temp
+ ].
+ b := b + 1.
+ e := e - 1
+ ]
].
(begin < e) ifTrue:[self quickSortFrom:begin to:e].
(b < end) ifTrue:[self quickSortFrom:b to:end]
@@ -1215,21 +1293,21 @@
middleElement := self at:((b + e) // 2).
[b < e] whileTrue:[
- [b < end and:[(self at:b) < middleElement]] whileTrue:[b := b + 1].
- [e > begin and:[middleElement < (self at:e)]] whileTrue:[e := e - 1].
+ [b < end and:[(self at:b) < middleElement]] whileTrue:[b := b + 1].
+ [e > begin and:[middleElement < (self at:e)]] whileTrue:[e := e - 1].
- (b <= e) ifTrue:[
- (b == e) ifFalse:[
- temp := self at:b.
- self at:b put:(self at:e).
- self at:e put:temp.
- temp := aCollection at:b.
- aCollection at:b put:(aCollection at:e).
- aCollection at:e put:temp
- ].
- b := b + 1.
- e := e - 1
- ]
+ (b <= e) ifTrue:[
+ (b == e) ifFalse:[
+ temp := self at:b.
+ self at:b put:(self at:e).
+ self at:e put:temp.
+ temp := aCollection at:b.
+ aCollection at:b put:(aCollection at:e).
+ aCollection at:e put:temp
+ ].
+ b := b + 1.
+ e := e - 1
+ ]
].
(begin < e) ifTrue:[self quickSortFrom:begin to:e with:aCollection].
(b < end) ifTrue:[self quickSortFrom:b to:end with:aCollection]
@@ -1247,18 +1325,18 @@
middleElement := self at:((b + e) // 2).
[b < e] whileTrue:[
- [b < end and:[sortBlock value:(self at:b) value:middleElement]] whileTrue:[b := b + 1].
- [e > begin and:[sortBlock value:middleElement value:(self at:e)]] whileTrue:[e := e - 1].
+ [b < end and:[sortBlock value:(self at:b) value:middleElement]] whileTrue:[b := b + 1].
+ [e > begin and:[sortBlock value:middleElement value:(self at:e)]] whileTrue:[e := e - 1].
- (b <= e) ifTrue:[
- (b == e) ifFalse:[
- temp := self at:b.
- self at:b put:(self at:e).
- self at:e put:temp
- ].
- b := b + 1.
- e := e - 1
- ]
+ (b <= e) ifTrue:[
+ (b == e) ifFalse:[
+ temp := self at:b.
+ self at:b put:(self at:e).
+ self at:e put:temp
+ ].
+ b := b + 1.
+ e := e - 1
+ ]
].
(begin < e) ifTrue:[self quickSortFrom:begin to:e sortBlock:sortBlock].
(b < end) ifTrue:[self quickSortFrom:b to:end sortBlock:sortBlock]
@@ -1276,21 +1354,21 @@
middleElement := self at:((b + e) // 2).
[b < e] whileTrue:[
- [b < end and:[sortBlock value:(self at:b) value:middleElement]] whileTrue:[b := b + 1].
- [e > begin and:[sortBlock value:middleElement value:(self at:e)]] whileTrue:[e := e - 1].
+ [b < end and:[sortBlock value:(self at:b) value:middleElement]] whileTrue:[b := b + 1].
+ [e > begin and:[sortBlock value:middleElement value:(self at:e)]] whileTrue:[e := e - 1].
- (b <= e) ifTrue:[
- (b == e) ifFalse:[
- temp := self at:b.
- self at:b put:(self at:e).
- self at:e put:temp.
- temp := aCollection at:b.
- aCollection at:b put:(aCollection at:e).
- aCollection at:e put:temp
- ].
- b := b + 1.
- e := e - 1
- ]
+ (b <= e) ifTrue:[
+ (b == e) ifFalse:[
+ temp := self at:b.
+ self at:b put:(self at:e).
+ self at:e put:temp.
+ temp := aCollection at:b.
+ aCollection at:b put:(aCollection at:e).
+ aCollection at:e put:temp
+ ].
+ b := b + 1.
+ e := e - 1
+ ]
].
(begin < e) ifTrue:[self quickSortFrom:begin to:e sortBlock:sortBlock with:aCollection].
(b < end) ifTrue:[self quickSortFrom:b to:end sortBlock:sortBlock with:aCollection]
@@ -1298,7 +1376,7 @@
topologicalSort:sortBlock
"sort the collection inplace using a sloooow sort algorithm.
- This algorithm has O-square runtime behavior ad should be used only
+ This algorithm has O-square runtime behavior and should be used only
in special situations.
It compares all elements, thus can be used when a>b, b>c does NOT imply
a>c (for example, to sort classes by inheritance)
@@ -1314,21 +1392,21 @@
end := self size.
1 to:end do:[:index |
- smallest := self at:index.
- smallestIndex := index.
+ smallest := self at:index.
+ smallestIndex := index.
- (index + 1) to:end do:[:index2 |
- thisOne := self at:index2.
- (sortBlock value:thisOne value:smallest) ifTrue:[
- smallestIndex := index2.
- smallest := thisOne
- ].
- ].
- (smallestIndex ~~ index) ifTrue:[
- thisOne := self at:index.
- self at:index put:smallest.
- self at:smallestIndex put:thisOne
- ].
+ (index + 1) to:end do:[:index2 |
+ thisOne := self at:index2.
+ (sortBlock value:thisOne value:smallest) ifTrue:[
+ smallestIndex := index2.
+ smallest := thisOne
+ ].
+ ].
+ (smallestIndex ~~ index) ifTrue:[
+ thisOne := self at:index.
+ self at:index put:smallest.
+ self at:smallestIndex put:thisOne
+ ].
]
"
@@ -1341,13 +1419,15 @@
sort
"sort the collection inplace. The elements are compared using
- > and < i.e. they should offer a magnitude-like protocol."
+ > and < i.e. they should offer a magnitude-like protocol.
+ The implementation uses the quicksort algorithm, which may not be
+ the best possible for all situations."
|stop|
stop := self size.
(stop > 1) ifTrue:[
- self quickSortFrom:1 to:stop
+ self quickSortFrom:1 to:stop
]
"
@@ -1370,7 +1450,7 @@
stop := self size.
(stop > 1) ifTrue:[
- self quickSortFrom:1 to:stop sortBlock:sortBlock
+ self quickSortFrom:1 to:stop sortBlock:sortBlock
]
"
@@ -1387,7 +1467,7 @@
stop := self size.
(stop > 1) ifTrue:[
- self quickSortFrom:1 to:stop with:aCollection
+ self quickSortFrom:1 to:stop with:aCollection
]
"
@@ -1402,13 +1482,14 @@
sort:sortBlock with:aCollection
"sort the collection inplace using the 2-arg block sortBlock
- for comparison. Also reorder the elements in aCollection"
+ for comparison. Also reorder the elements in aCollection.
+ Use, when you have a key collection to sort some other collection with."
|stop|
stop := self size.
(stop > 1) ifTrue:[
- self quickSortFrom:1 to:stop sortBlock:sortBlock with:aCollection
+ self quickSortFrom:1 to:stop sortBlock:sortBlock with:aCollection
]
"
@@ -1430,7 +1511,7 @@
stop := self size.
1 to:stop do:[:index |
- aBlock value:(self at:index).
+ aBlock value:(self at:index).
]
"
#(one two three four five six) do:[:element | Transcript showCr:element]
@@ -1445,7 +1526,7 @@
stop := self size.
1 to:stop do:[:index |
- aTwoArgBlock value:index value:(self at:index).
+ aTwoArgBlock value:index value:(self at:index).
]
"
#(one two three four five six) keysAndValuesDo:[:key :element | Transcript show:key; space; showCr:element]
@@ -1462,7 +1543,7 @@
stop := self size.
1 to:stop do:[:index |
- aTwoArgBlock value:(self at:index) value:(aSequenceableCollection at:index).
+ aTwoArgBlock value:(self at:index) value:(aSequenceableCollection at:index).
]
"
#(one two three four five six) with:(1 to:10) do:[:el1 :el2 | Transcript show:el1; space; showCr:el2]
@@ -1479,7 +1560,7 @@
start := index1.
stop := index2.
start to:stop do:[:index |
- aBlock value:(self at:index).
+ aBlock value:(self at:index).
]
"
@@ -1497,7 +1578,7 @@
start := index1.
stop := index2.
stop to:start by:-1 do:[:index |
- aBlock value:(self at:index).
+ aBlock value:(self at:index).
]
"
@@ -1513,7 +1594,7 @@
sz := self size.
sz to:1 by:-1 do:[:index |
- aBlock value:(self at:index).
+ aBlock value:(self at:index).
]
"
@@ -1529,9 +1610,9 @@
sz "{ Class:SmallInteger }"|
sz := self size.
- newCollection := (self species new:sz) finalizeCopyFrom:self.
+ newCollection := (self species new:sz) postCopyFrom:self.
1 to:sz do:[:index |
- newCollection at:index put:(aBlock value:(self at:index)).
+ newCollection at:index put:(aBlock value:(self at:index)).
].
^ newCollection
@@ -1542,6 +1623,26 @@
"
!
+from:start to:stop collect:aBlock
+ "evaluate the argument, aBlock for the elements indexed by start
+ to stop in the collection and return a collection of the results"
+
+ |newCollection
+ idx "{ Class:SmallInteger }"|
+
+ newCollection := (self species new:(stop - start + 1)) postCopyFrom:self.
+ idx := 1.
+ start to:stop do:[:index |
+ newCollection at:idx put:(aBlock value:(self at:index)).
+ idx := idx + 1
+ ].
+ ^ newCollection
+
+ "
+ #(one two three four five six) from:2 to:4 collect:[:element | element asUppercase]
+ "
+!
+
select:aBlock
"evaluate the argument, aBlock for every element in the collection
and return a collection of all elements for which the block return
@@ -1553,26 +1654,27 @@
sz := self size.
species := self species.
species growIsCheap ifFalse:[
- newColl := OrderedCollection new:sz.
- needCopy := true
+ newColl := OrderedCollection new:sz.
+ needCopy := true
] ifTrue:[
- newColl := (species new:sz) finalizeCopyFrom:self.
- needCopy := false
+ newColl := (species new:sz) postCopyFrom:self.
+ needCopy := false
].
1 to:sz do:[:index |
- element := self at:index.
- (aBlock value:element) ifTrue:[
- newColl add:element
- ].
+ element := self at:index.
+ (aBlock value:element) ifTrue:[
+ newColl add:element
+ ].
].
needCopy ifTrue:[
- newColl := (species withAll:newColl) finalizeCopyFrom:self
+ newColl := (species withAll:newColl) postCopyFrom:self
].
^ newColl
"
#(one two three four five six) select:[:element | element startsWith:'f']
#(1 2 3 4 5 6 7 8 9) select:[:element | element odd]
+ (#(17 12 1 98 51) asSortedCollection:[:a :b | b < a]) select:[:element | element odd]
(1 to:9) select:[:element | element odd]
(Smalltalk allClasses) select:[:class | class name startsWith:'S']
"
--- a/Set.st Mon Oct 10 01:29:01 1994 +0100
+++ b/Set.st Mon Oct 10 01:29:28 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1991 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -19,9 +19,9 @@
Set comment:'
COPYRIGHT (c) 1991 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Set.st,v 1.12 1994-08-22 12:13:25 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Set.st,v 1.13 1994-10-10 00:28:14 claus Exp $
'!
!Set class methodsFor:'documentation'!
@@ -29,7 +29,7 @@
copyright
"
COPYRIGHT (c) 1991 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -42,15 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Set.st,v 1.12 1994-08-22 12:13:25 claus Exp $
-"
-!
-
-history
-"
-written jun 91 by claus
-jan 93 claus: changed to use hashing
-jan 94 claus: recoded to mark empty slots instead of rehashing
+$Header: /cvs/stx/stx/libbasic/Set.st,v 1.13 1994-10-10 00:28:14 claus Exp $
"
!
@@ -68,19 +60,19 @@
Examples:
- |s|
- s := Set new.
- s add:'hello'.
- s add:'world'.
- s add:#foo.
- s add:1.2345678.
- s add:'hello'.
+ |s|
+ s := Set new.
+ s add:'hello'.
+ s add:'world'.
+ s add:#foo.
+ s add:1.2345678.
+ s add:'hello'.
- s printNL.
- 's size -> ' print. s size printNL.
- '(s includes:''hello'') ->' print. (s includes:'hello') printNL.
- '(s includes:#foo) ->' print. (s includes:#foo) printNL.
- '(s includes:#bar) ->' print. (s includes:#bar) printNL.
+ s printNL.
+ 's size -> ' print. s size printNL.
+ '(s includes:''hello'') ->' print. (s includes:'hello') printNL.
+ '(s includes:#foo) ->' print. (s includes:#foo) printNL.
+ '(s includes:#bar) ->' print. (s includes:#bar) printNL.
"
! !
@@ -90,7 +82,7 @@
"initialize the Set class"
DeletedEntry isNil ifTrue:[
- DeletedEntry := Object new
+ DeletedEntry := Object new
].
"Set initialize"
@@ -107,7 +99,19 @@
new:anInteger
"return a new empty Set with space for anInteger elements"
- ^ self basicNew setTally:anInteger
+ "
+ make it somewhat bigger; hashing works better if fill grade is
+ below 10% (make it 75% here ..)
+ "
+ ^ self basicNew setTally:(anInteger * 4 // 3)
+! !
+
+!Set methodsFor:'copying'!
+
+postCopy
+ "have to copy the keyArray too"
+
+ keyArray := keyArray shallowCopy
! !
!Set methodsFor:'private'!
@@ -141,10 +145,10 @@
sz := keyArray basicSize.
sz > 30 ifTrue:[
- tally < (sz // 8) ifTrue:[
- newSize := sz // 7.
- self grow:newSize
- ]
+ tally < (sz // 8) ifTrue:[
+ newSize := sz // 7.
+ self grow:newSize
+ ]
]
!
@@ -159,8 +163,8 @@
500k elements; if you have bigger ones, add some more primes here ...
"
arg <= 524288 ifTrue:[
- "2 4 8 16 32 64 128 256 512 1024 2048 4096 8192 16384 32768 65536 131072 262144 524288"
- ^ #(11 11 11 17 37 67 131 257 521 1031 2053 4099 8209 16411 32771 65537 131101 262147 524309) at:(arg highBit)
+ "2 4 8 16 32 64 128 256 512 1024 2048 4096 8192 16384 32768 65536 131072 262144 524288"
+ ^ #(11 11 11 17 37 67 131 257 521 1031 2053 4099 8209 16411 32771 65537 131101 262147 524309) at:(arg highBit)
].
"
make it odd - at least
@@ -188,25 +192,25 @@
length := keyArray basicSize.
length < 10 ifTrue:[
- "assuming, that for small collections the overhead of hashing
- is large ... maybe that proves wrong (if overhead of comparing
- is high)"
- ^ keyArray indexOf:key ifAbsent:aBlock
+ "assuming, that for small collections the overhead of hashing
+ is large ... maybe that proves wrong (if overhead of comparing
+ is high)"
+ ^ keyArray indexOf:key ifAbsent:aBlock
].
startIndex := key hash \\ length + 1.
index := startIndex.
[true] whileTrue:[
- probe := (keyArray basicAt:index).
- key = probe ifTrue:[^ index].
+ probe := (keyArray basicAt:index).
+ key = probe ifTrue:[^ index].
- index == length ifTrue:[
- index := 1
- ] ifFalse:[
- index := index + 1
- ].
- ((probe isNil) or:[index == startIndex]) ifTrue:[^ aBlock value].
+ index == length ifTrue:[
+ index := 1
+ ] ifFalse:[
+ index := index + 1
+ ].
+ ((probe isNil) or:[index == startIndex]) ifTrue:[^ aBlock value].
]
!
@@ -225,19 +229,19 @@
index := startIndex.
[true] whileTrue:[
- probe := keyArray basicAt:index.
- (probe isNil or: [key = probe]) ifTrue:[^ index].
- probe == DeletedEntry ifTrue:[
- keyArray basicAt:index put:nil.
- ^ index
- ].
+ probe := keyArray basicAt:index.
+ (probe isNil or: [key = probe]) ifTrue:[^ index].
+ probe == DeletedEntry ifTrue:[
+ keyArray basicAt:index put:nil.
+ ^ index
+ ].
- index == length ifTrue:[
- index := 1
- ] ifFalse:[
- index := index + 1
- ].
- index == startIndex ifTrue:[^ self grow findKeyOrNil:key].
+ index == length ifTrue:[
+ index := 1
+ ] ifFalse:[
+ index := index + 1
+ ].
+ index == startIndex ifTrue:[^ self grow findKeyOrNil:key].
]
!
@@ -252,13 +256,13 @@
index := key hash \\ length + 1.
[(keyArray basicAt:index) notNil] whileTrue:[
- index == length ifTrue:[
- index := 1
- ] ifFalse:[
- index := index + 1
- ].
- "notice: no check for no nil found - we must find one since
- this is only called after growing"
+ index == length ifTrue:[
+ index := 1
+ ] ifFalse:[
+ index := index + 1
+ ].
+ "notice: no check for no nil found - we must find one since
+ this is only called after growing"
].
^ index
!
@@ -284,11 +288,11 @@
oldSize := oldKeyArray size.
deletedEntry := DeletedEntry.
1 to:oldSize do:[:srcIndex |
- elem := oldKeyArray basicAt:srcIndex.
- (elem notNil and:[elem ~~ deletedEntry]) ifTrue:[
- "cannot be already there"
- newKeyArray basicAt:(self findNil:elem) put:elem
- ].
+ elem := oldKeyArray basicAt:srcIndex.
+ (elem notNil and:[elem ~~ deletedEntry]) ifTrue:[
+ "cannot be already there"
+ newKeyArray basicAt:(self findNil:elem) put:elem
+ ].
].
!
@@ -304,18 +308,18 @@
keyArray := newKeyArray := self keyContainerOfSize:n.
1 to:n do:[:index |
- element := oldKeyArray at:index.
- (element notNil and:[element ~~ DeletedEntry]) ifTrue:[
- "cannot be already there"
- newKeyArray basicAt:(self findNil:element) put:element
- ].
+ element := oldKeyArray at:index.
+ (element notNil and:[element ~~ DeletedEntry]) ifTrue:[
+ "cannot be already there"
+ newKeyArray basicAt:(self findNil:element) put:element
+ ].
]
!
rehashFrom:startIndex
"rehash elements starting at index - after a remove.
Notice: due to the new implementation of remove,
- this is no longer needed"
+ this is no longer needed"
|element i "{ Class:SmallInteger }"
length
@@ -325,19 +329,19 @@
index := startIndex.
element := keyArray basicAt:index.
[element notNil] whileTrue:[
- i := self findNil:element.
- i == index ifTrue:[
- ^ self
- ].
- keyArray basicAt:i put:element.
- keyArray basicAt:index put:nil.
+ i := self findNil:element.
+ i == index ifTrue:[
+ ^ self
+ ].
+ keyArray basicAt:i put:element.
+ keyArray basicAt:index put:nil.
- index == length ifTrue:[
- index := 1
- ] ifFalse:[
- index := index + 1.
- ].
- element := keyArray basicAt:index.
+ index == length ifTrue:[
+ index := 1
+ ] ifFalse:[
+ index := index + 1.
+ ].
+ element := keyArray basicAt:index.
]
! !
@@ -397,13 +401,13 @@
|index "{ Class: SmallInteger }"|
anObject notNil ifTrue:[
- index := self findKeyOrNil:anObject.
- (keyArray basicAt:index) isNil ifTrue:[
- keyArray basicAt:index put:anObject.
- tally := tally + 1.
+ index := self findKeyOrNil:anObject.
+ (keyArray basicAt:index) isNil ifTrue:[
+ keyArray basicAt:index put:anObject.
+ tally := tally + 1.
- self fullCheck.
- ]
+ self fullCheck.
+ ]
].
^ anObject
!
@@ -427,17 +431,17 @@
keyArray basicAt:index put:nil.
tally := tally - 1.
tally == 0 ifTrue:[
- keyArray := self keyContainerOfSize:(self goodSizeFor:0).
+ keyArray := self keyContainerOfSize:(self goodSizeFor:0).
] ifFalse:[
- index == keyArray basicSize ifTrue:[
- next := 1
- ] ifFalse:[
- next := index + 1.
- ].
- (keyArray basicAt:next) notNil ifTrue:[
- keyArray basicAt:index put:DeletedEntry.
- ].
- self emptyCheck
+ index == keyArray basicSize ifTrue:[
+ next := 1
+ ] ifFalse:[
+ next := index + 1.
+ ].
+ (keyArray basicAt:next) notNil ifTrue:[
+ keyArray basicAt:index put:DeletedEntry.
+ ].
+ self emptyCheck
].
^ oldObject
!
@@ -458,10 +462,10 @@
sz := keyArray size.
1 to:sz do:[:index |
- element := keyArray at:index.
- (element notNil and:[element ~~ DeletedEntry]) ifTrue:[
- aBlock value:element
- ]
+ element := keyArray at:index.
+ (element notNil and:[element ~~ DeletedEntry]) ifTrue:[
+ aBlock value:element
+ ]
]
! !
--- a/Signal.st Mon Oct 10 01:29:01 1994 +0100
+++ b/Signal.st Mon Oct 10 01:29:28 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -11,18 +11,18 @@
"
Object subclass:#Signal
- instanceVariableNames:'mayProceed notifierString nameClass message
- handlerBlock'
- classVariableNames:'NoHandlerSignal'
- poolDictionaries:''
- category:'Kernel-Exceptions'
+ instanceVariableNames:'mayProceed notifierString nameClass message
+ handlerBlock parent'
+ classVariableNames:'NoHandlerSignal RecursiveRaiseSignal'
+ poolDictionaries:''
+ category:'Kernel-Exceptions'
!
Signal comment:'
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Signal.st,v 1.13 1994-08-23 23:11:14 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Signal.st,v 1.14 1994-10-10 00:28:19 claus Exp $
'!
!Signal class methodsFor:'documentation'!
@@ -30,7 +30,7 @@
copyright
"
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -43,7 +43,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Signal.st,v 1.13 1994-08-23 23:11:14 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Signal.st,v 1.14 1994-10-10 00:28:19 claus Exp $
"
!
@@ -98,22 +98,22 @@
Instance variables:
- mayProceed <Boolean> hint for the debugger - program may
- proceed (currently not honored by the
- debugger)
+ mayProceed <Boolean> hint for the debugger - program may
+ proceed (currently not honored by the
+ debugger)
- notifierString <String> eror message to be output
+ notifierString <String> eror message to be output
- nameClass <???> I dont know what this is for
- (included for ST-80 compatibility)
+ nameClass <???> I dont know what this is for
+ (included for ST-80 compatibility)
- message <???> I dont know what this is for
- (included for ST-80 compatibility)
+ message <???> I dont know what this is for
+ (included for ST-80 compatibility)
- handlerBlock <Block> if nonNil, a 1-arg block to be
- evaluated when no handler context is
- found. The block gets the exception
- object as argument.
+ handlerBlock <Block> if nonNil, a 1-arg block to be
+ evaluated when no handler context is
+ found. The block gets the exception
+ object as argument.
Notice:
Part of the implementation is a left-over from old times when the
@@ -125,12 +125,19 @@
!Signal class methodsFor:'initialization'!
-initialize
+initialize
"setup the signal used to handle unhandled signals"
NoHandlerSignal isNil ifTrue:[
- NoHandlerSignal := (Signal new) mayProceed:true.
- NoHandlerSignal notifierString:'unhandled exception'
+ Object initialize.
+
+ NoHandlerSignal := Object errorSignal newSignalMayProceed:true.
+ NoHandlerSignal nameClass:self message:#noHandlerSignal.
+ NoHandlerSignal notifierString:'unhandled exception'.
+
+ RecursiveRaiseSignal := Object errorSignal newSignalMayProceed:false.
+ RecursiveRaiseSignal nameClass:self message:#recursiveRaiseSignal.
+ RecursiveRaiseSignal notifierString:'recursive signal raise'
]
! !
@@ -148,26 +155,49 @@
"return the signal used to handle unhandled signals"
^ NoHandlerSignal
+!
+
+recursiveRaiseSignal
+ "return the signal used to handle recursive signal raises"
+
+ ^ RecursiveRaiseSignal
! !
!Signal methodsFor:'instance creation'!
newSignalMayProceed:aBoolean
- "create a new signal, using the receiver as a prototype"
+ "create a new signal, using the receiver as a prototype and
+ setting the parent of the new signal to the receiver."
- ^ (self copy) mayProceed:aBoolean
+ |newSignal|
+
+ newSignal := (self copy) mayProceed:aBoolean.
+ newSignal parent:self.
+ ^ newSignal
!
newSignal
- "create a new signal, using the receiver as a prototype"
+ "create a new signal, using the receiver as a prototype and
+ setting the parent of the new signal to the receiver."
+
+ ^ (self copy) parent:self
+! !
- ^ (self copy)
+!Signal methodsFor:'copying'!
+
+deepCopy
+ "raise an error - deepCopy is not allowed for signals"
+
+ ^ self deepCopyError
! !
!Signal methodsFor:'accessing'!
nameClass:aClass message:aSelector
- "I dont know what that is used for (yet)"
+ "this sets the class & selector of a method which returns
+ that signal - this is simply for documentation purposes -
+ see Signal>>printOn: implementation.
+ (took me a while to find that one out ;-)"
nameClass := aClass.
message := aSelector
@@ -181,6 +211,18 @@
mayProceed := aBoolean
!
+parent:aSignal
+ "set the parent-signal of the receiver."
+
+ parent := aSignal
+!
+
+parent
+ "return the parent-signal of the receiver"
+
+ ^ parent
+!
+
notifierString:aString
"set the notifier string"
@@ -200,6 +242,20 @@
handlerBlock := aOneArgBlock
! !
+!Signal methodsFor:'printing'!
+
+printOn:aStream
+ "append a printed representation of the receiver on aStream"
+
+ nameClass notNil ifTrue:[
+ aStream nextPutAll:nameClass name.
+ aStream space.
+ aStream nextPutAll:message.
+ ^ self
+ ].
+ ^ super printOn:aStream
+! !
+
!Signal methodsFor:'save evaluation'!
handle:handleBlock do:aBlock
@@ -215,10 +271,10 @@
"
Object messageNotUnderstoodSignal handle:[:ex |
- 'oops' printNL.
- ex return
+ 'oops' printNL.
+ ex return
] do:[
- 123 size open
+ 123 size open
]
"
@@ -227,18 +283,18 @@
num := 0.
Number divisionByZeroSignal handle:[:ex |
- 'oops' printNL.
- ex return
+ 'oops' printNL.
+ ex return
] do:[
- 123 / num
+ 123 / num
]
"
!
catch:aBlock
- "evaluate the argument, aBlock; return false.
+ "evaluate the argument, aBlock.
If the receiver-signal is raised during evaluation, abort
- the evaluation and return true.
+ the evaluation and return true; otherwise return false.
This is the catch & throw mechanism found in other languages,
where the returned value indicates if an exception occured."
@@ -250,13 +306,43 @@
"
Object messageNotUnderstoodSignal catch:[
- 123 size open
+ 123 size open
+ ]
+ "
+!
+
+ignore:aBlock
+ "evaluate the argument, aBlock.
+ Ignore the receiver-signal during evaluation - i.e. simply
+ continue. This makes only sense for some signals, such as UserInterrupt
+ or AbortSignals, because continuing after an exception without any cleanup
+ will often lead to followup-errors."
+
+ ^ self handle:[:ex | ex proceed] do:aBlock.
+
+ "
+ Object messageNotUnderstoodSignal ignore:[
+ 123 size open
]
"
! !
!Signal methodsFor:'queries'!
+accepts:aSignal
+ "return true, if the receiver accepts the argument, aSignal.
+ (i.e. the recevier is aSignal or a parent of it). False otherwise."
+
+ |s|
+
+ s := aSignal.
+ [s notNil] whileTrue:[
+ self == s ifTrue:[^ true].
+ s := s parent
+ ].
+ ^ false
+!
+
isHandled
"return true, if there is a handler for the receiver signal.
Raising an unhandled signal will usually lead into the debugger,
@@ -267,19 +353,18 @@
con := thisContext.
con := con sender.
[con notNil] whileTrue:[
- (con selector == #handle:do:) ifTrue:[
- "
- is this is the Signal>>handle:do: context
- or a SignalSet>>handle:do: context with self in it ?
- "
- ((con receiver == self)
- or:[(con receiver isMemberOf:SignalSet) and:[con receiver includes:self]]) ifTrue:[
- "found it"
+ (con selector == #handle:do:) ifTrue:[
+ "
+ is this is the Signal>>handle:do: context
+ or a SignalSet>>handle:do: context with self in it ?
+ "
+ (con receiver accepts:self) ifTrue:[
+ "found a handler context"
- ^ true
- ].
- ].
- con := con sender
+ ^ true
+ ].
+ ].
+ con := con sender
].
^ false
! !
@@ -298,34 +383,41 @@
|ex block|
ex := Exception new
- signal:self
- parameter:nil
- errorString:notifierString
- suspendedContext:thisContext sender.
+ signal:self
+ parameter:nil
+ errorString:notifierString
+ suspendedContext:thisContext sender.
ex resumeBlock:[:value | ^ value].
self evaluateHandlerWith:ex.
(block := handlerBlock) isNil ifTrue:[
- "
- if I am not the NoHandlerSignal, raise it ...
- passing the exception as parameter.
- "
- self == NoHandlerSignal ifFalse:[
- ^ NoHandlerSignal
- raiseRequestWith:ex
- errorString:('unhandled exception: ' , ex errorString)
- ].
+ "
+ if I am not the NoHandlerSignal, raise it ...
+ passing the exception as parameter.
+ "
+ self == NoHandlerSignal ifFalse:[
+ ^ NoHandlerSignal
+ raiseRequestWith:ex
+ errorString:('unhandled exception: ' , ex errorString)
+ ].
- "
- otherwise,
- take either a per-process emergencyHandlerBlock
- or the global emergencyHandler (from Exception) ...
- "
- block := Processor activeProcess emergencySignalHandler.
- block isNil ifTrue:[
- block := Exception emergencyHandler
- ]
+ "
+ otherwise,
+ take either a per-process emergencyHandlerBlock
+ or the global emergencyHandler (from Exception) ...
+ "
+ Processor notNil ifTrue:[
+ "care for signal during startup (Processor not yet created)"
+ block := Processor activeProcess emergencySignalHandler.
+ ].
+ block isNil ifTrue:[
+ block := Exception emergencyHandler
+ ].
+ block isNil ifTrue:[
+ "care for error during startup (Exception not yet initialized)"
+ ^ MiniDebugger enterWithMessage:ex errorString
+ ]
].
"... and call it"
@@ -344,34 +436,41 @@
|ex block|
ex := Exception new
- signal:self
- parameter:aParameter
- errorString:notifierString
- suspendedContext:thisContext sender.
+ signal:self
+ parameter:aParameter
+ errorString:notifierString
+ suspendedContext:thisContext sender.
ex resumeBlock:[:value | ^ value].
self evaluateHandlerWith:ex.
(block := handlerBlock) isNil ifTrue:[
- "
- if I am not the NoHandlerSignal, raise it ...
- passing the exception as parameter.
- "
- self == NoHandlerSignal ifFalse:[
- ^ NoHandlerSignal
- raiseRequestWith:ex
- errorString:('unhandled exception: ' , ex errorString)
- ].
+ "
+ if I am not the NoHandlerSignal, raise it ...
+ passing the exception as parameter.
+ "
+ self == NoHandlerSignal ifFalse:[
+ ^ NoHandlerSignal
+ raiseRequestWith:ex
+ errorString:('unhandled exception: ' , ex errorString)
+ ].
- "
- otherwise,
- take either a per-process emergencyHandlerBlock
- or the global emergencyHandler (from Exception) ...
- "
- block := Processor activeProcess emergencySignalHandler.
- block isNil ifTrue:[
- block := Exception emergencyHandler
- ]
+ "
+ otherwise,
+ take either a per-process emergencyHandlerBlock
+ or the global emergencyHandler (from Exception) ...
+ "
+ Processor notNil ifTrue:[
+ "care for signal during startup (Processor not yet created)"
+ block := Processor activeProcess emergencySignalHandler.
+ ].
+ block isNil ifTrue:[
+ block := Exception emergencyHandler
+ ].
+ block isNil ifTrue:[
+ "care for error during startup (Exception not yet initialized)"
+ ^ MiniDebugger enterWithMessage:ex errorString
+ ]
].
"... and call it"
@@ -387,34 +486,41 @@
|ex block|
ex := Exception new
- signal:self
- parameter:nil
- errorString:something printString
- suspendedContext:thisContext sender.
+ signal:self
+ parameter:nil
+ errorString:something printString
+ suspendedContext:thisContext sender.
ex resumeBlock:[:value | ^ value].
self evaluateHandlerWith:ex.
(block := handlerBlock) isNil ifTrue:[
- "
- if I am not the NoHandlerSignal, raise it ...
- passing the exception as parameter.
- "
- self == NoHandlerSignal ifFalse:[
- ^ NoHandlerSignal
- raiseRequestWith:ex
- errorString:('unhandled exception: ' , ex errorString)
- ].
+ "
+ if I am not the NoHandlerSignal, raise it ...
+ passing the exception as parameter.
+ "
+ self == NoHandlerSignal ifFalse:[
+ ^ NoHandlerSignal
+ raiseRequestWith:ex
+ errorString:('unhandled exception: ' , ex errorString)
+ ].
- "
- otherwise,
- take either a per-process emergencyHandlerBlock
- or the global emergencyHandler (from Exception) ...
- "
- block := Processor activeProcess emergencySignalHandler.
- block isNil ifTrue:[
- block := Exception emergencyHandler
- ]
+ "
+ otherwise,
+ take either a per-process emergencyHandlerBlock
+ or the global emergencyHandler (from Exception) ...
+ "
+ Processor notNil ifTrue:[
+ "care for signal during startup (Processor not yet created)"
+ block := Processor activeProcess emergencySignalHandler.
+ ].
+ block isNil ifTrue:[
+ block := Exception emergencyHandler
+ ].
+ block isNil ifTrue:[
+ "care for error during startup (Exception not yet initialized)"
+ ^ MiniDebugger enterWithMessage:ex errorString
+ ]
].
"... and call it"
@@ -429,34 +535,41 @@
|ex block|
ex := Exception new
- signal:self
- parameter:aParameter
- errorString:aString
- suspendedContext:thisContext sender.
+ signal:self
+ parameter:aParameter
+ errorString:aString
+ suspendedContext:thisContext sender.
ex resumeBlock:[:value | ^ value].
self evaluateHandlerWith:ex.
(block := handlerBlock) isNil ifTrue:[
- "
- if I am not the NoHandlerSignal, raise it ...
- passing the exception as parameter.
- "
- self == NoHandlerSignal ifFalse:[
- ^ NoHandlerSignal
- raiseRequestWith:ex
- errorString:('unhandled exception: ' , ex errorString)
- ].
+ "
+ if I am not the NoHandlerSignal, raise it ...
+ passing the exception as parameter.
+ "
+ self == NoHandlerSignal ifFalse:[
+ ^ NoHandlerSignal
+ raiseRequestWith:ex
+ errorString:('unhandled exception: ' , ex errorString)
+ ].
- "
- otherwise,
- take either a per-process emergencyHandlerBlock
- or the global emergencyHandler (from Exception) ...
- "
- block := Processor activeProcess emergencySignalHandler.
- block isNil ifTrue:[
- block := Exception emergencyHandler
- ]
+ "
+ otherwise,
+ take either a per-process emergencyHandlerBlock
+ or the global emergencyHandler (from Exception) ...
+ "
+ Processor notNil ifTrue:[
+ "care for signal during startup (Processor not yet created)"
+ block := Processor activeProcess emergencySignalHandler.
+ ].
+ block isNil ifTrue:[
+ block := Exception emergencyHandler
+ ].
+ block isNil ifTrue:[
+ "care for error during startup (Exception not yet initialized)"
+ ^ MiniDebugger enterWithMessage:ex errorString
+ ]
].
"... and call it"
@@ -465,9 +578,10 @@
!Signal methodsFor:'private'!
-evaluateHandlerWith:anException
+evaluateHandlerWith:ex
"search through the context-calling chain for a 'handle:do:'-context
- to the receiver or a SignalSet which includes the receiver.
+ to the receiver or a parent of the receiver or a SignalSet which includes
+ the receiver.
If found, take its 2nd argument (the handler) and evaluate
it with the exception as argument.
If none found, just return."
@@ -477,34 +591,43 @@
con := thisContext.
con := con sender.
con isRecursive ifTrue:[
- "
- mhmh - an error while in a handler
- go immediately into the debugger.
- "
- ^ self enterDebuggerWith:anException
- message:'recursive signal raise'
+ "
+ mhmh - an error while in a handler
+ "
+ ((self == RecursiveRaiseSignal)
+ or:[RecursiveRaiseSignal isNil]) ifTrue:[
+ "
+ ... either while handling RecursiveSignal
+ or at startup when RecursiveSignal is not yet
+ created -
+ - go immediately into the debugger.
+ "
+ ^ self enterDebuggerWith:ex
+ message:'recursive signal raise'
+ ].
+ ^ RecursiveRaiseSignal
+ raiseRequestWith:ex
+ errorString:('recursive signal raise: ' , ex errorString)
].
[con notNil] whileTrue:[
- (con selector == #'handle:do:') ifTrue:[
- "
- if this is the Signal>>handle:do: context
- or a SignalSet>>handle:do: context with self in it,
- call the handler
- "
- ((con receiver == self)
- or:[(con receiver isMemberOf:SignalSet)
- and:[con receiver includes:self]]) ifTrue:[
- "call the handler"
+ (con selector == #'handle:do:') ifTrue:[
+ "
+ if this is the Signal>>handle:do: context
+ or a SignalSet>>handle:do: context with self in it,
+ call the handler
+ "
+ (con receiver accepts:self) ifTrue:[
+ "call the handler"
- anException handlerContext:con.
- self doCallHandler:(con args at:1) with:anException.
+ ex handlerContext:con.
+ self doCallHandler:(con args at:1) with:ex.
- "if the handler rejects or falls through we arrive here"
- "continue search for another handler"
- ].
- ].
- con := con sender
+ "if the handler rejects or falls through we arrive here"
+ "continue search for another handler"
+ ].
+ ].
+ con := con sender
].
"
--- a/SignalSet.st Mon Oct 10 01:29:01 1994 +0100
+++ b/SignalSet.st Mon Oct 10 01:29:28 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -11,17 +11,17 @@
"
IdentitySet subclass:#SignalSet
- instanceVariableNames:''
- classVariableNames:'SetOfAnySignal'
- poolDictionaries:''
- category:'Kernel-Exceptions'
+ instanceVariableNames:''
+ classVariableNames:'SetOfAnySignal'
+ poolDictionaries:''
+ category:'Kernel-Exceptions'
!
SignalSet comment:'
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/SignalSet.st,v 1.8 1994-08-05 01:02:34 claus Exp $
+$Header: /cvs/stx/stx/libbasic/SignalSet.st,v 1.9 1994-10-10 00:28:22 claus Exp $
'!
!SignalSet class methodsFor:'documentation'!
@@ -29,7 +29,7 @@
copyright
"
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/SignalSet.st,v 1.8 1994-08-05 01:02:34 claus Exp $
+$Header: /cvs/stx/stx/libbasic/SignalSet.st,v 1.9 1994-10-10 00:28:22 claus Exp $
"
!
@@ -52,25 +52,29 @@
a number of signals and also implements the #handle:do: and #catch: methods
just as signals do.
However, any signal from the SignalSet will, if signalled, lead into the handler.
+
There is also a special signalSet, which can be used to catch any
- signal in the system.
+ signal in the system - but this should no longer be used, since catching
+ Object>>errorSignal has now the same effect.
For more detail, see comment in Signal and examples in doc/coding.
- Useful SignalSets:
-
- Object anySignal - to catch any error
- Number anyArithmeticSignal - to catch numeric errors
+ Notice: SignalSets are not needed when a group of children of a common signal
+ (such as arithmeticSignal) is to be handled; the parent signal of those will
+ also handle all children.
+ Use signalSets if totally unrelated signals should be handled by one common
+ handler.
"
! !
!SignalSet class methodsFor:'instance creation'!
anySignal
- "return a special signalSet for catching any signal"
+ "return a special signalSet for catching any signal.
+ Obsolete; use Object>>errorSignal for that purpose."
SetOfAnySignal isNil ifTrue:[
- SetOfAnySignal := self basicNew
+ SetOfAnySignal := self basicNew
].
^ SetOfAnySignal
! !
@@ -90,18 +94,18 @@
"
SignalSet anySignal handle:[:ex |
- ex errorString print. ' occured in: ' print. ex suspendedContext printNL.
- ex return
+ ex errorString print. ' occured in: ' print. ex suspendedContext printNL.
+ ex return
] do:[
- (#(1 2 3 4) at:5) / 0.0
+ (#(1 2 3 4) at:5) / 0.0
]
"
!
catch:aBlock
- "evaluate the argument, aBlock; return false.
+ "evaluate the argument, aBlock.
If any of the signals in the receiver is raised during evaluation,
- abort the evaluation and return true.
+ abort the evaluation and return true; otherwise return false.
With the special anySignal, evaluation can be performed totally save
from signals
- but who (beside radical c++ fans) would do that ?"
@@ -114,19 +118,45 @@
"
SignalSet anySignal catch:[
- (#(1 2 3 4) at:5) / 0.0
+ (#(1 2 3 4) at:5) / 0.0
+ ]
+ "
+!
+
+ignore:aBlock
+ "evaluate the argument, aBlock.
+ Ignore the receiver-signal during evaluation - i.e. simply
+ continue. This makes only sense for some signals, such as UserInterrupt
+ or AbortSignals, because continuing after an exception without any cleanup
+ will often lead to followup-errors."
+
+ ^ self handle:[:ex | ex proceed] do:aBlock.
+
+ "
+ SignalSet anySignal ignore:[
+ 123 size open
]
"
! !
!SignalSet methodsFor:'queries'!
+accepts:aSignal
+ "return true, if the receiver accepts the argument, aSignal.
+ (i.e. if any of the receivers elements is aSignal or a parent of it).
+ False otherwise. he special anySet accepts any signal."
+
+ (self == SetOfAnySignal) ifTrue:[^ true].
+ self do:[:sig | (sig accepts:aSignal) ifTrue:[^ true]].
+ ^ false
+!
+
includes:aSignal
"return true, if the receiver contains the argument, aSignal.
The special any-Set includes every signal."
(self == SetOfAnySignal) ifTrue:[
- ^ aSignal isKindOf:Signal
+ ^ aSignal isKindOf:Signal
].
^ super includes:aSignal
! !
--- a/SmallInt.st Mon Oct 10 01:29:01 1994 +0100
+++ b/SmallInt.st Mon Oct 10 01:29:28 1994 +0100
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1988 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Attic/SmallInt.st,v 1.16 1994-08-22 12:14:03 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/SmallInt.st,v 1.17 1994-10-10 00:28:25 claus Exp $
'!
!SmallInteger class methodsFor:'documentation'!
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Attic/SmallInt.st,v 1.16 1994-08-22 12:14:03 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/SmallInt.st,v 1.17 1994-10-10 00:28:25 claus Exp $
"
!
@@ -1407,7 +1407,11 @@
if (_isSmallInteger(stop)) {
tmp = _intVal(self);
final = _intVal(stop);
+#ifdef OLD
if (__isBlock(aBlock)
+#else
+ if (__isBlockLike(aBlock)
+#endif
&& ((code = _BlockInstPtr(aBlock)->b_code) != (OBJFUNC)nil)
&& (_BlockInstPtr(aBlock)->b_nargs == _MKSMALLINT(1))) {
#ifdef NEW_BLOCK_CALL
@@ -1480,7 +1484,11 @@
tmp = _intVal(self);
final = _intVal(stop);
step = _intVal(incr);
+#ifdef OLD
if (__isBlock(aBlock)
+#else
+ if (__isBlockLike(aBlock)
+#endif
&& ((code = _BlockInstPtr(aBlock)->b_code) != (OBJFUNC)nil)
&& (_BlockInstPtr(aBlock)->b_nargs == _MKSMALLINT(1))) {
#ifdef NEW_BLOCK_CALL
--- a/SmallInteger.st Mon Oct 10 01:29:01 1994 +0100
+++ b/SmallInteger.st Mon Oct 10 01:29:28 1994 +0100
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1988 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/SmallInteger.st,v 1.16 1994-08-22 12:14:03 claus Exp $
+$Header: /cvs/stx/stx/libbasic/SmallInteger.st,v 1.17 1994-10-10 00:28:25 claus Exp $
'!
!SmallInteger class methodsFor:'documentation'!
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/SmallInteger.st,v 1.16 1994-08-22 12:14:03 claus Exp $
+$Header: /cvs/stx/stx/libbasic/SmallInteger.st,v 1.17 1994-10-10 00:28:25 claus Exp $
"
!
@@ -1407,7 +1407,11 @@
if (_isSmallInteger(stop)) {
tmp = _intVal(self);
final = _intVal(stop);
+#ifdef OLD
if (__isBlock(aBlock)
+#else
+ if (__isBlockLike(aBlock)
+#endif
&& ((code = _BlockInstPtr(aBlock)->b_code) != (OBJFUNC)nil)
&& (_BlockInstPtr(aBlock)->b_nargs == _MKSMALLINT(1))) {
#ifdef NEW_BLOCK_CALL
@@ -1480,7 +1484,11 @@
tmp = _intVal(self);
final = _intVal(stop);
step = _intVal(incr);
+#ifdef OLD
if (__isBlock(aBlock)
+#else
+ if (__isBlockLike(aBlock)
+#endif
&& ((code = _BlockInstPtr(aBlock)->b_code) != (OBJFUNC)nil)
&& (_BlockInstPtr(aBlock)->b_nargs == _MKSMALLINT(1))) {
#ifdef NEW_BLOCK_CALL
--- a/Smalltalk.st Mon Oct 10 01:29:01 1994 +0100
+++ b/Smalltalk.st Mon Oct 10 01:29:28 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1988 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -13,20 +13,20 @@
Object subclass:#Smalltalk
instanceVariableNames:''
classVariableNames:'ExitBlocks CachedClasses SystemPath
- StartupClass StartupSelector StartupArguments
- CachedAbbreviations
- SilentLoading Initializing
- StandAlone
- LogDoits'
+ StartupClass StartupSelector StartupArguments
+ CachedAbbreviations
+ SilentLoading Initializing
+ StandAlone
+ LogDoits'
poolDictionaries:''
category:'System-Support'
!
Smalltalk comment:'
COPYRIGHT (c) 1988 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Smalltalk.st,v 1.21 1994-08-23 23:11:28 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Smalltalk.st,v 1.22 1994-10-10 00:28:32 claus Exp $
'!
"
@@ -42,7 +42,7 @@
copyright
"
COPYRIGHT (c) 1988 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -55,7 +55,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Smalltalk.st,v 1.21 1994-08-23 23:11:28 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Smalltalk.st,v 1.22 1994-10-10 00:28:32 claus Exp $
"
!
@@ -72,29 +72,29 @@
It may change to become a subclass of collection at some time ...
Instance variables:
- none - all handling is done in the VM
+ none - all handling is done in the VM
Class variables:
- ExitBlocks <Collection> blocks to evaluate before system is
- left. Not currently used.
+ ExitBlocks <Collection> blocks to evaluate before system is
+ left. Not currently used.
- CachedClasses <Collection> known classes (cached for faster enumeration)
+ CachedClasses <Collection> known classes (cached for faster enumeration)
- SystemPath <Collection> path to search for system files (sources, bitmaps etc)
+ SystemPath <Collection> path to search for system files (sources, bitmaps etc)
- StartupClass <Class> class, which gets initial message
- (right after VM initialization)
- StartupSelector <Symbol> message sent to StartupClass
+ StartupClass <Class> class, which gets initial message
+ (right after VM initialization)
+ StartupSelector <Symbol> message sent to StartupClass
- CachedAbbreviations
- <Dictionary> className to filename mappings
+ CachedAbbreviations
+ <Dictionary> className to filename mappings
- SilentLoading <Boolean> suppresses messages during fileIn and in compiler
- (can be set to true from a customized main)
+ SilentLoading <Boolean> suppresses messages during fileIn and in compiler
+ (can be set to true from a customized main)
- LogDoits <Boolean> if true, doits are also logged in the changes
- file. Default is false, since the changes file
- may become huge ...
+ LogDoits <Boolean> if true, doits are also logged in the changes
+ file. Default is false, since the changes file
+ may become huge ...
"
! !
@@ -151,7 +151,7 @@
Smalltalk versionString
"
"
-$Header: /cvs/stx/stx/libbasic/Smalltalk.st,v 1.21 1994-08-23 23:11:28 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Smalltalk.st,v 1.22 1994-10-10 00:28:32 claus Exp $
"
!
@@ -164,7 +164,7 @@
RETURN ( _MKSTRING(VERSIONDATE_STRING COMMA_SND) );
#endif
%}.
- ^ '3-aug-1994'
+ ^ '23-aug-1994'
"
Smalltalk versionDate
@@ -205,12 +205,12 @@
Resource-stuff."
(Language == #german) ifTrue:[
- ^ 'Willkommen bei SmallTalk/X version '
- , self versionString , ' vom ' , self versionDate
+ ^ 'Willkommen bei SmallTalk/X version '
+ , self versionString , ' vom ' , self versionDate
].
(Language == #french) ifTrue:[
- ^ 'Bienvenue a SmallTalk/X version '
- , self versionString , ' de ' , self versionDate
+ ^ 'Bienvenue a SmallTalk/X version '
+ , self versionString , ' de ' , self versionDate
].
^ 'Hello World - here is SmallTalk/X version '
, self versionString , ' of ' , self versionDate
@@ -255,7 +255,7 @@
must init display here - some classes (Color, Form) need it during initialize
"
Workstation notNil ifTrue:[
- Workstation initialize
+ Workstation initialize
].
"
@@ -267,25 +267,28 @@
Debugger := MiniDebugger.
Compiler := ByteCodeCompiler.
Compiler isNil ifTrue:[
- "
- ByteCodeCompiler is not in the system (i.e. has not been linked in)
- this allows at least immediate evaluations for runtime systems without compiler
- NOTICE: a parser is always needed, otherwise we cannot read resource files etc.
- "
- Compiler := Parser
+ "
+ ByteCodeCompiler is not in the system (i.e. has not been linked in)
+ this allows at least immediate evaluations for runtime systems without compiler
+ NOTICE: a parser is always needed, otherwise we cannot read resource files etc.
+ "
+ Compiler := Parser
].
"
- now finally initialize all classes
+ now, finally, initialize all leftover classes
"
+"/ Object allSubclassesInOrderDo:[:aClass |
self allBehaviorsDo:[:aClass |
- "
- avoid never-ending story ...
- "
- (aClass ~~ Smalltalk) ifTrue:[
- aClass initialize
- ]
+ "
+ avoid never-ending story ...
+ "
+ (aClass ~~ Smalltalk) ifTrue:[
+"/ 'init ' print. aClass name printNL.
+ aClass initialize
+ ]
].
+
"
now we can enable the graphical debugger/inspector
"
@@ -310,23 +313,23 @@
extract Language and LanguageTerritory from LANG variable.
the language and territory must not be abbreviated,
valid is for example: english_usa
- english
- german
- german_austria
+ english
+ german
+ german_austria
"
envString := OperatingSystem getEnvironment:'LANG'.
envString notNil ifTrue:[
- i := envString indexOf:$_.
- (i == 0) ifTrue:[
- langString := envString.
- terrString := envString
- ] ifFalse:[
- langString := envString copyTo:(i - 1).
- terrString := envString copyFrom:(i + 1)
- ].
- Language := langString asSymbol.
- LanguageTerritory := terrString asSymbol
+ i := envString indexOf:$_.
+ (i == 0) ifTrue:[
+ langString := envString.
+ terrString := envString
+ ] ifFalse:[
+ langString := envString copyTo:(i - 1).
+ terrString := envString copyFrom:(i + 1)
+ ].
+ Language := langString asSymbol.
+ LanguageTerritory := terrString asSymbol
].
"
@@ -336,12 +339,12 @@
"
envString := OperatingSystem getEnvironment:'VIEW3D'.
envString notNil ifTrue:[
- firstChar := (envString at:1) asLowercase.
- (firstChar == $t) ifTrue:[
- Smalltalk at:#View3D put:true
- ] ifFalse: [
- Smalltalk at:#View3D put:false
- ]
+ firstChar := (envString at:1) asLowercase.
+ (firstChar == $t) ifTrue:[
+ Smalltalk at:#View3D put:true
+ ] ifFalse: [
+ Smalltalk at:#View3D put:false
+ ]
]
"Smalltalk initGlobalsFromEnvironment"
!
@@ -354,13 +357,13 @@
"redefine debug-tools, if view-classes exist"
Display notNil ifTrue:[
- InspectorView notNil ifTrue:[
- Inspector := InspectorView
- ].
- DebugView notNil ifTrue:[
- Debugger := DebugView
- ].
- Display initialize
+ InspectorView notNil ifTrue:[
+ Inspector := InspectorView
+ ].
+ DebugView notNil ifTrue:[
+ Debugger := DebugView
+ ].
+ Display initialize
]
"Smalltalk initStandardTools"
!
@@ -394,19 +397,19 @@
initSystemPath
"setup path where system files are searched for.
the default path is set to:
- .
- ..
- $HOME (if defined)
- $HOME/.smalltalk (if defined & existing)
- $SMALLTALK_LIBDIR (if defined & existing)
- /usr/local/lib/smalltalk (if existing)
- /usr/lib/smalltalk (if existing)
+ .
+ ..
+ $HOME (if defined)
+ $HOME/.smalltalk (if defined & existing)
+ $SMALLTALK_LIBDIR (if defined & existing)
+ /usr/local/lib/smalltalk (if existing)
+ /usr/lib/smalltalk (if existing)
of course, it is possible to add entries from the 'smalltalk.rc'
startup file; add expressions such as:
- Smalltalk systemPath addFirst:'/foo/bar/baz'.
- or:
- Smalltalk systemPath addLast:'/fee/foe/foo'.
+ Smalltalk systemPath addFirst:'/foo/bar/baz'.
+ or:
+ Smalltalk systemPath addLast:'/fee/foe/foo'.
"
|p homePath|
@@ -422,17 +425,17 @@
SystemPath add:'..'.
SystemPath add:homePath.
(OperatingSystem isDirectory:(p := homePath , '/.smalltalk')) ifTrue:[
- SystemPath add:p
+ SystemPath add:p
].
p := OperatingSystem getEnvironment:'SMALLTALK_LIBDIR'.
p notNil ifTrue:[
- SystemPath add:p
+ SystemPath add:p
].
(OperatingSystem isDirectory:'/usr/local/lib/smalltalk') ifTrue:[
- SystemPath add:'/usr/local/lib/smalltalk'
+ SystemPath add:'/usr/local/lib/smalltalk'
].
(OperatingSystem isDirectory:'/usr/lib/smalltalk') ifTrue:[
- SystemPath add:'/usr/lib/smalltalk'
+ SystemPath add:'/usr/lib/smalltalk'
].
"
@@ -448,7 +451,7 @@
|idx|
Initializing := true.
- Processor := ProcessorScheduler new.
+"/ Processor := ProcessorScheduler new.
"
while reading patches- and rc-file, do not add things into change-file
@@ -463,29 +466,31 @@
"
idx := Arguments indexOf:'-e'.
idx ~~ 0 ifTrue:[
- self fileIn:(Arguments at:idx + 1).
- self exit
+ self fileIn:(Arguments at:idx + 1).
+ self exit
].
(self fileIn:((Arguments at:1) , '.rc')) ifFalse:[
- "no .rc file where executable is; try default smalltalk.rc"
- self fileIn:'smalltalk.rc'
+ "no .rc file where executable is; try default smalltalk.rc"
+ (self fileIn:'smalltalk.rc') ifFalse:[
+ Transcript showCr:'no startup rc-file found'
+ ]
].
Class updateChanges:true.
(SilentLoading == true) ifFalse:[ "i.e. undefined counts as false"
- Transcript showCr:(self hello).
- Transcript showCr:(self copyrightString).
- Transcript cr.
+ Transcript showCr:(self hello).
+ Transcript showCr:(self copyrightString).
+ Transcript cr.
- DemoMode ifTrue:[
- Transcript showCr:'*** Restricted use: ***'.
- Transcript showCr:'*** This program may be used for education only. ***'.
- Transcript showCr:'*** Please read the files COPYRIGHT and LICENSE ***'.
- Transcript showCr:'*** for more details. ***'.
- Transcript cr.
- ].
+ DemoMode ifTrue:[
+ Transcript showCr:'*** Restricted use: ***'.
+ Transcript showCr:'*** This program may be used for education only. ***'.
+ Transcript showCr:'*** Please read the files COPYRIGHT and LICENSE ***'.
+ Transcript showCr:'*** for more details. ***'.
+ Transcript cr.
+ ].
].
Initializing := false.
@@ -500,18 +505,18 @@
if there is a display, start its event dispatcher
"
Display notNil ifTrue:[
- Display startDispatch.
+ Display startDispatch.
- "this is a leftover - will vanish"
+ "this is a leftover - will vanish"
" "
- ModalDisplay notNil ifTrue:[
- ModalDisplay startDispatch
- ]
+ ModalDisplay notNil ifTrue:[
+ ModalDisplay startDispatch
+ ]
" "
].
(StartupClass notNil and:[StartupSelector notNil]) ifTrue:[
- StartupClass perform:StartupSelector withArguments:StartupArguments.
+ StartupClass perform:StartupSelector withArguments:StartupArguments.
].
"
@@ -519,9 +524,9 @@
otherwise go into a read-eval-print loop
"
Display notNil ifTrue:[
- Processor dispatchLoop
+ Processor dispatchLoop
] ifFalse:[
- self readEvalPrint
+ self readEvalPrint
].
"done"
@@ -534,18 +539,18 @@
there are three change-notifications made to dependents of ObjectMemory,
which allow a stepwise re-init: #earlyRestart, #restarted and #returnFromSnapshot.
#earlyRestart is send first, nothing has been setup yet.
- (should be used to flush all device dependent entries)
+ (should be used to flush all device dependent entries)
#restarted is send right after.
- (should be used to recreate external resources (fds, bitmaps etc)
+ (should be used to recreate external resources (fds, bitmaps etc)
#returnFromSnapshot is sent last
- (should be used to restart processes, reOpen Streams which cannot
- be automatically be reopened (i.e. Sockets, Pipes) and so on.
+ (should be used to restart processes, reOpen Streams which cannot
+ be automatically be reopened (i.e. Sockets, Pipes) and so on.
"
|deb insp imageName|
Initializing := true.
- Processor reInitialize.
+ Processor reinitialize.
"temporary switch back to dumb interface -
to handle errors while view-stuff is not yet reinitialized"
@@ -564,7 +569,7 @@
"
Workstation notNil ifTrue:[
- Workstation reinitialize.
+ Workstation reinitialize.
].
ObjectMemory changed:#returnFromSnapshot.
@@ -582,45 +587,45 @@
if there is no Transcript, go to stderr
"
Transcript isNil ifTrue:[
- self initStandardStreams.
- Transcript := Stderr
+ self initStandardStreams.
+ Transcript := Stderr
].
(SilentLoading == true) ifFalse:[
- Transcript cr.
- Transcript showCr:('Smalltalk restarted from:' , ObjectMemory imageName).
- Transcript cr.
+ Transcript cr.
+ Transcript showCr:('Smalltalk restarted from:' , ObjectMemory imageName).
+ Transcript cr.
- DemoMode ifTrue:[
- Transcript showCr:'*** Restricted use: ***'.
- Transcript showCr:'*** This program may be used for education only. ***'.
- Transcript showCr:'*** Please read the files COPYRIGHT and LICENSE ***'.
- Transcript showCr:'*** for more details. ***'.
- Transcript cr.
- ].
+ DemoMode ifTrue:[
+ Transcript showCr:'*** Restricted use: ***'.
+ Transcript showCr:'*** This program may be used for education only. ***'.
+ Transcript showCr:'*** Please read the files COPYRIGHT and LICENSE ***'.
+ Transcript showCr:'*** for more details. ***'.
+ Transcript cr.
+ ].
].
"
give user a chance to re-customize things
"
(Arguments includes:'-faststart') ifFalse:[
- Class updateChanges:false.
- (self fileIn:((Arguments at:1) , '_r.rc')) ifFalse:[
- "no _r.rc file where executable is; try default smalltalk_r.rc"
- self fileIn:'smalltalk_r.rc'
- ].
- Class updateChanges:true.
+ Class updateChanges:false.
+ (self fileIn:((Arguments at:1) , '_r.rc')) ifFalse:[
+ "no _r.rc file where executable is; try default smalltalk_r.rc"
+ self fileIn:'smalltalk_r.rc'
+ ].
+ Class updateChanges:true.
].
"
if there is a display, start its event dispatcher
"
Display notNil ifTrue:[
- Display startDispatch.
+ Display startDispatch.
" "
- ModalDisplay notNil ifTrue:[
- ModalDisplay startDispatch
- ]
+ ModalDisplay notNil ifTrue:[
+ ModalDisplay startDispatch
+ ]
" "
].
@@ -629,16 +634,16 @@
these two globals during snapshot ... or in main
"
(StartupClass notNil and:[StartupSelector notNil]) ifTrue:[
- "allow customization by reading an image specific rc-file"
- imageName := ObjectMemory imageName.
- imageName notNil ifTrue:[
- (imageName endsWith:'.img') ifTrue:[
- self fileIn:((imageName copyTo:(imageName size - 4)), '.rc')
- ] ifFalse:[
- self fileIn:(imageName , '.rc')
- ]
- ].
- StartupClass perform:StartupSelector withArguments:StartupArguments.
+ "allow customization by reading an image specific rc-file"
+ imageName := ObjectMemory imageName.
+ imageName notNil ifTrue:[
+ (imageName endsWith:'.img') ifTrue:[
+ self fileIn:((imageName copyTo:(imageName size - 4)), '.rc')
+ ] ifFalse:[
+ self fileIn:(imageName , '.rc')
+ ]
+ ].
+ StartupClass perform:StartupSelector withArguments:StartupArguments.
].
"
@@ -646,9 +651,9 @@
otherwise go into a read-eval-print loop
"
Display notNil ifTrue:[
- Processor dispatchLoop
+ Processor dispatchLoop
] ifFalse:[
- self readEvalPrint
+ self readEvalPrint
].
self exit
@@ -663,9 +668,9 @@
Stdin skipSeparators.
text := Stdin nextChunk.
[text notNil] whileTrue:[
- (Compiler evaluate:text) printNL.
- 'ST- ' print.
- text := Stdin nextChunk
+ (Compiler evaluate:text) printNL.
+ 'ST- ' print.
+ text := Stdin nextChunk
].
'' printNL
! !
@@ -721,7 +726,7 @@
the evaluation of aBlock."
(self includesKey:aKey) ifTrue:[
- ^ self at:aKey
+ ^ self at:aKey
].
^ aBlock value
@@ -768,7 +773,7 @@
"return the symbol under which anObject is stored - or nil"
self allKeysDo:[:aKey |
- (self at:aKey) == anObject ifTrue:[^ aKey]
+ (self at:aKey) == anObject ifTrue:[^ aKey]
]
"Smalltalk keyAtValue:Object"
@@ -817,9 +822,9 @@
(instead of the default InspectorView)."
DictionaryInspectorView isNil ifTrue:[
- super inspect
+ super inspect
] ifFalse:[
- DictionaryInspectorView openOn:self
+ DictionaryInspectorView openOn:self
]
! !
@@ -831,9 +836,9 @@
cleanup in stand alone applications."
ExitBlocks isNil ifTrue:[
- ExitBlocks := OrderedCollection with:aBlock
+ ExitBlocks := OrderedCollection with:aBlock
] ifFalse:[
- ExitBlocks add:aBlock
+ ExitBlocks add:aBlock
]
!
@@ -841,9 +846,9 @@
"finish Smalltalk system"
ExitBlocks notNil ifTrue:[
- ExitBlocks do:[:aBlock |
- aBlock value
- ]
+ ExitBlocks do:[:aBlock |
+ aBlock value
+ ]
].
OperatingSystem exit
@@ -893,7 +898,7 @@
printStackBacktrace
"print a stack backtrace - then continue.
WARNING: this method is for debugging only
- it may be removed without notice"
+ it may be removed without notice"
%{
printStack(__context);
@@ -908,9 +913,9 @@
char *msg;
if (__isString(aMessage))
- msg = (char *) _stringVal(aMessage);
+ msg = (char *) _stringVal(aMessage);
else
- msg = "fatalAbort";
+ msg = "fatalAbort";
fatal0(__context, msg);
/* NEVER RETURNS */
@@ -937,17 +942,17 @@
statistic
"print some statistic data.
WARNING: this method is for debugging only
- it may be removed without notice"
+ it may be removed without notice"
%{ /* NOCONTEXT */
- statistic();
+ __STATISTIC__();
%}
!
debugOn
"turns some tracing on.
WARNING: this method is for debugging only
- it may be removed without notice"
+ it may be removed without notice"
"LookupTrace := true. "
MessageTrace := true.
@@ -958,7 +963,7 @@
debugOff
"turns tracing off.
WARNING: this method is for debugging only
- it may be removed without notice"
+ it may be removed without notice"
LookupTrace := nil.
MessageTrace := nil
@@ -968,7 +973,7 @@
executionDebugOn
"turns tracing of interpreter on.
WARNING: this method is for debugging only
- it may be removed without notice"
+ it may be removed without notice"
ExecutionTrace := true
!
@@ -976,7 +981,7 @@
executionDebugOff
"turns tracing of interpreter off.
WARNING: this method is for debugging only
- it may be removed without notice"
+ it may be removed without notice"
ExecutionTrace := nil
! !
@@ -1002,7 +1007,7 @@
in the Smalltalk dictionary"
self allKeysDo:[:aKey |
- aBlock value:(aKey -> (self at:aKey))
+ aBlock value:(aKey -> (self at:aKey))
]
"Smalltalk associationsDo:[:assoc | assoc printNL]"
@@ -1012,7 +1017,7 @@
"evaluate the two-arg block, aBlock for all keys and values"
self allKeysDo:[:aKey |
- aBlock value:aKey value:(self at:aKey)
+ aBlock value:aKey value:(self at:aKey)
]
!
@@ -1059,7 +1064,7 @@
must be reimplemented since Smalltalk is no real collection."
self do:[:o |
- (o == anObject) ifTrue:[^ true]
+ (o == anObject) ifTrue:[^ true]
].
^ false
!
@@ -1068,14 +1073,14 @@
"return a collection of all classes in the system"
CachedClasses isNil ifTrue:[
- CachedClasses := IdentitySet new:500.
- self do:[:anObject |
- anObject notNil ifTrue:[
- anObject isBehavior ifTrue:[
- CachedClasses add:anObject
- ]
- ]
- ]
+ CachedClasses := IdentitySet new:800.
+ self do:[:anObject |
+ anObject notNil ifTrue:[
+ anObject isBehavior ifTrue:[
+ CachedClasses add:anObject
+ ]
+ ]
+ ]
].
^ CachedClasses
@@ -1088,6 +1093,25 @@
^ self allClasses collect:[:aClass | aClass name]
"Smalltalk classNames"
+!
+
+classNamed:aString
+ "return the class with name aString, or nil if absent"
+
+ |cls|
+
+ "be careful, to not invent new symbols ..."
+ aString knownAsSymbol ifTrue:[
+ cls := self at:(aString asSymbol) ifAbsent:[^ nil].
+ cls isBehavior ifTrue:[^ cls]
+ ].
+ ^ nil
+
+ "
+ Smalltalk classNamed:'Object'
+ Smalltalk classNamed:'fooBar'
+ Smalltalk classNamed:'true'
+ "
! !
!Smalltalk class methodsFor:'class management'!
@@ -1121,12 +1145,12 @@
names := aClass classVariableString asCollectionOfWords.
names do:[:name |
- cSym := (oldSym , ':' , name) asSymbol.
- value := self at:cSym.
- self at:cSym put:nil.
- self removeKey:cSym.
- cSym := (newSym , ':' , name) asSymbol.
- self at:cSym put:value.
+ cSym := (oldSym , ':' , name) asSymbol.
+ value := self at:cSym.
+ self at:cSym put:nil.
+ self removeKey:cSym.
+ cSym := (newSym , ':' , name) asSymbol.
+ self at:cSym put:value.
].
aClass addChangeRecordForClassRename:oldName to:newName
@@ -1141,26 +1165,39 @@
oldName := aClass name.
sym := oldName asSymbol.
- ((self at:sym) == aClass) ifFalse:[ ^ self].
+ ((self at:sym) == aClass) ifFalse:[
+ "check other name ..."
+ (self includes:aClass) ifFalse:[
+ 'no such class' errorPrintNL.
+ ^ self
+ ].
+ "the class has changed its name - without telling me ...
+ what should be done in this case ?"
+ 'class ' errorPrint. oldName errorPrint.
+ ' has changed its name' errorPrintNL.
+ ^ self
+ ].
self at:sym put:nil. "nil it out for compiled accesses"
self removeKey:sym.
+ aClass category:#removed.
+
"remove class variables"
names := aClass classVariableString asCollectionOfWords.
names do:[:name |
- cSym := (sym , ':' , name) asSymbol.
- self at:cSym asSymbol put:nil.
- self removeKey:cSym
+ cSym := (sym , ':' , name) asSymbol.
+ self at:cSym asSymbol put:nil.
+ self removeKey:cSym
].
"
actually could get along with less flushing
(entries for aClass and subclasses only)
aClass allSubclassesDo:[:aSubclass |
- ObjectMemory flushInlineCachesForClass:aSubclass.
- ObjectMemory flushMethodCacheFor:aSubclass
+ ObjectMemory flushInlineCachesForClass:aSubclass.
+ ObjectMemory flushMethodCacheFor:aSubclass
].
ObjectMemory flushInlineCachesForClass:aClass.
ObjectMemory flushMethodCacheFor:aClass
@@ -1168,7 +1205,7 @@
ObjectMemory flushInlineCaches.
ObjectMemory flushMethodCache.
- aClass addChangeRecordForClassRemove:oldName
+ aClass addChangeRecordForClassRemove:oldName.
! !
!Smalltalk class methodsFor:'browsing'!
@@ -1177,9 +1214,9 @@
"startup a changes browser"
ChangesBrowser notNil ifTrue:[
- ChangesBrowser open
+ ChangesBrowser open
] ifFalse:[
- self warn:'no ChangesBrowser built in'
+ self warn:'no ChangesBrowser built in'
]
"
@@ -1265,6 +1302,7 @@
"
Smalltalk systemPath
+ Smalltalk systemPath addLast:'someOtherDirectoryPath'
"
!
@@ -1278,15 +1316,15 @@
|realName|
(aFileName startsWith:'/') ifTrue:[
- "dont use path for absolute file names"
+ "dont use path for absolute file names"
- ^ aFileName
+ ^ aFileName
].
SystemPath do:[:dirName |
- (OperatingSystem isReadable:
- (realName := dirName , '/' , aFileName))
- ifTrue: [^ realName]].
+ (OperatingSystem isReadable:
+ (realName := dirName , '/' , aFileName))
+ ifTrue: [^ realName]].
^ nil
!
@@ -1299,7 +1337,7 @@
aString := self getSystemFileName:aFileName.
aString notNil ifTrue:[
- ^ FileStream readonlyFileNamed:aString
+ ^ FileStream readonlyFileNamed:aString
].
^ nil
!
@@ -1313,25 +1351,25 @@
CachedAbbreviations := Dictionary new.
aStream := self systemFileStreamFor:'abbrev.stc'.
aStream isNil ifTrue:[
- aStream := self systemFileStreamFor:'include/abbrev.stc'.
+ aStream := self systemFileStreamFor:'include/abbrev.stc'.
].
aStream notNil ifTrue:[
- [aStream atEnd] whileFalse:[
- line := aStream nextLine.
- line notNil ifTrue:[
- (line startsWith:'#') ifFalse:[
- (line countWords == 2) ifTrue:[
- index := line indexOfSeparatorStartingAt:1.
- (index ~~ 0) ifTrue:[
- thisName := line copyTo:(index - 1).
- abbrev := (line copyFrom:index) withoutSeparators.
- CachedAbbreviations at:thisName put:abbrev.
- ]
- ]
- ]
- ]
- ].
- aStream close
+ [aStream atEnd] whileFalse:[
+ line := aStream nextLine.
+ line notNil ifTrue:[
+ (line startsWith:'#') ifFalse:[
+ (line countWords == 2) ifTrue:[
+ index := line indexOfSeparatorStartingAt:1.
+ (index ~~ 0) ifTrue:[
+ thisName := line copyTo:(index - 1).
+ abbrev := (line copyFrom:index) withoutSeparators.
+ CachedAbbreviations at:thisName put:abbrev.
+ ]
+ ]
+ ]
+ ]
+ ].
+ aStream close
]
!
@@ -1341,7 +1379,7 @@
to 14 chars)"
CachedAbbreviations isNil ifTrue:[
- self readAbbreviations
+ self readAbbreviations
].
^ CachedAbbreviations
@@ -1363,14 +1401,14 @@
" later ... - compiler should put the source file name into the class
Symbol hasInterned:aClassName ifTrue:[:sym |
- |class|
+ |class|
- (Smalltalk includesKey:sym) ifTrue:[
- class := Smalltalk at:sym.
- class isClass ifTrue:[
- abbrev := class classFileName.
- ]
- ]
+ (Smalltalk includesKey:sym) ifTrue:[
+ class := Smalltalk at:sym.
+ class isClass ifTrue:[
+ abbrev := class classFileName.
+ ]
+ ]
].
"
@@ -1382,8 +1420,8 @@
"no abbreviation found - if its a short name, take it"
OperatingSystem maxFileNameLength < (fileName size + 3) ifTrue:[
- "this will only be triggered on sys5.3 type systems"
- self error:'cant find short for ' , fileName , ' in abbreviation file'
+ "this will only be triggered on sys5.3 type systems"
+ self error:'cant find short for ' , fileName , ' in abbreviation file'
].
^ fileName
!
@@ -1428,7 +1466,7 @@
((aFileName endsWith:'.o')
or:[(aFileName endsWith:'.obj')
or:[aFileName endsWith:'.so']]) ifTrue:[
- ObjectFileLoader isNil ifTrue:[^ false].
+ ObjectFileLoader isNil ifTrue:[^ false].
path := self getSystemFileName:aFileName.
path isNil ifTrue:[^ false].
^ ObjectFileLoader loadObjectFile:aFileName
@@ -1449,7 +1487,7 @@
"read in the last changes file - bringing the system to the state it
had when left the last time.
WARNING: this method is rubbish: it should only read things after the
- last '**snapshot**' - entry."
+ last '**snapshot**' - entry."
|upd|
@@ -1458,9 +1496,9 @@
"
upd := Class updateChanges:false.
[
- self fileIn:'changes'
+ self fileIn:'changes'
] valueNowOrOnUnwindDo:[
- Class updateChanges:upd
+ Class updateChanges:upd
]
"
@@ -1478,58 +1516,72 @@
upd := Class updateChanges:false.
[
- "
- first, look for a loader-driver file (in fileIn/xxx.ld)
- "
- (self fileIn:('fileIn/' , aClassName , '.ld'))
- ifFalse:[
- shortName := self fileNameForClass:aClassName.
- "
- try abbreviated driver-file (in fileIn/xxx.ld)
- "
- (self fileIn:('fileIn/' , shortName , '.ld'))
- ifFalse:[
- "
- then, if dynamic linking is available, look for a shared binary in binary/xxx.o
- "
- ObjectFileLoader notNil ifTrue:[
- nm := 'binary/' , aClassName.
- (self fileInClassObject:aClassName from:(nm , '.so'))
- ifFalse:[
- (self fileInClassObject:aClassName from:(nm , '.o'))
- ifFalse:[
- nm := 'binary/' , shortName.
- (self fileInClassObject:aClassName from:(nm , '.so'))
- ifFalse:[
- ok := self fileInClassObject:aClassName from:(nm , '.o')
- ].
- ].
- ].
- ].
+ "
+ first, look for a loader-driver file (in fileIn/xxx.ld)
+ "
+ (self fileIn:('fileIn/' , aClassName , '.ld'))
+ ifFalse:[
+ shortName := self fileNameForClass:aClassName.
+ "
+ try abbreviated driver-file (in fileIn/xxx.ld)
+ "
+ (self fileIn:('fileIn/' , shortName , '.ld'))
+ ifFalse:[
+ "
+ then, if dynamic linking is available, look for a shared binary in binary/xxx.o
+ "
+ ObjectFileLoader notNil ifTrue:[
+ nm := 'binary/' , aClassName.
+ (self fileInClassObject:aClassName from:(nm , '.so'))
+ ifFalse:[
+ (self fileInClassObject:aClassName from:(nm , '.o'))
+ ifFalse:[
+ nm := 'binary/' , shortName.
+ (self fileInClassObject:aClassName from:(nm , '.so'))
+ ifFalse:[
+ ok := self fileInClassObject:aClassName from:(nm , '.o')
+ ].
+ ].
+ ].
+ ].
- "
- if that did not work, look for an st-source file ...
- "
- ok ifFalse:[
- (self fileIn:(aClassName , '.st'))
- ifFalse:[
- (self fileIn:(shortName , '.st'))
- ifFalse:[
- "
- ... and in the standard source-directory
- "
- (self fileIn:('source/' , aClassName , '.st'))
- ifFalse:[
- ok := self fileIn:('source/' , shortName , '.st')
- ]
- ]
- ]
- ]
- ].
- ]
+ "
+ if that did not work, look for an st-source file ...
+ "
+ ok ifFalse:[
+ (self fileIn:(aClassName , '.st'))
+ ifFalse:[
+ (self fileIn:(shortName , '.st'))
+ ifFalse:[
+ "
+ ... and in the standard source-directory
+ "
+ (self fileIn:('source/' , aClassName , '.st'))
+ ifFalse:[
+ ok := self fileIn:('source/' , shortName , '.st')
+ ]
+ ]
+ ]
+ ]
+ ].
+ ]
] valueNowOrOnUnwindDo:[Class updateChanges:upd].
newClass := self at:(aClassName asSymbol).
newClass notNil ifTrue:[newClass initialize]
+!
+
+silentFileIn:aFilename
+ "same as fileIn:, but do not output 'compiled...'-messages on Transcript.
+ Main use is during startup."
+
+ |wasSilent|
+
+ wasSilent := self silentLoading:true.
+ [
+ self fileIn:aFilename
+ ] valueNowOrOnUnwindDo:[
+ self silentLoading:wasSilent
+ ]
! !
!Smalltalk class methodsFor: 'binary storage'!
@@ -1539,21 +1591,21 @@
pools := Set new.
self associationsDo:[:assoc |
- assoc value == self ifFalse:[
- assoc value isClass ifTrue:[
- assoc value addGlobalsTo:globalDictionary manager:manager.
- pools addAll:assoc value sharedPools
- ] ifFalse:[
- globalDictionary at:assoc put:self
- ].
- assoc value isNil ifFalse:[
- globalDictionary at:assoc value put:self
- ]
- ]
+ assoc value == self ifFalse:[
+ assoc value isClass ifTrue:[
+ assoc value addGlobalsTo:globalDictionary manager:manager.
+ pools addAll:assoc value sharedPools
+ ] ifFalse:[
+ globalDictionary at:assoc put:self
+ ].
+ assoc value isNil ifFalse:[
+ globalDictionary at:assoc value put:self
+ ]
+ ]
].
pools do:[:poolDictionary|
- poolDictionary addGlobalsTo:globalDictionary manager:manager
+ poolDictionary addGlobalsTo:globalDictionary manager:manager
]
!
@@ -1561,9 +1613,9 @@
|string|
anObject class == Association ifTrue:[
- string := 'Smalltalk associationAt: ', anObject key storeString
+ string := 'Smalltalk associationAt: ', anObject key storeString
] ifFalse: [
- string := 'Smalltalk at: ', (self keyAtValue: anObject) storeString
+ string := 'Smalltalk at: ', (self keyAtValue: anObject) storeString
].
stream nextNumber:2 put:string size.
string do:[:char | stream nextPut:char asciiValue]
--- a/SortColl.st Mon Oct 10 01:29:01 1994 +0100
+++ b/SortColl.st Mon Oct 10 01:29:28 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -11,17 +11,17 @@
"
OrderedCollection subclass:#SortedCollection
- instanceVariableNames:'sortBlock'
- classVariableNames:'DefaultSortBlock'
- poolDictionaries:''
- category:'Collections-Ordered'
+ instanceVariableNames:'sortBlock'
+ classVariableNames:'DefaultSortBlock'
+ poolDictionaries:''
+ category:'Collections-Sequenceable'
!
SortedCollection comment:'
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Attic/SortColl.st,v 1.10 1994-08-05 01:02:42 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/SortColl.st,v 1.11 1994-10-10 00:28:38 claus Exp $
'!
!SortedCollection class methodsFor:'documentation'!
@@ -29,7 +29,7 @@
copyright
"
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Attic/SortColl.st,v 1.10 1994-08-05 01:02:42 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/SortColl.st,v 1.11 1994-10-10 00:28:38 claus Exp $
"
!
@@ -136,24 +136,24 @@
mySize := self size.
otherSize := aCollection size.
((mySize == 0) or:[otherSize > 5]) ifTrue:[
- newSize := mySize + otherSize.
- newContents := Array new:newSize.
- newContents replaceFrom:1 to:mySize with:contentsArray startingAt:1.
- aCollection isSequenceableCollection ifTrue:[
- "maybe we can do it in one big move"
- newContents replaceFrom:(mySize + 1) to:newSize with:aCollection startingAt:1.
- ] ifFalse:[
- dstIndex := mySize + 1.
- aCollection do:[:element |
- newContents at:dstIndex put:element.
- dstIndex := dstIndex + 1
- ]
- ].
- firstIndex := 1.
- lastIndex := newSize.
- contentsArray := newContents.
- contentsArray sort:sortBlock.
- ^ self
+ newSize := mySize + otherSize.
+ newContents := Array new:newSize.
+ newContents replaceFrom:1 to:mySize with:contentsArray startingAt:1.
+ aCollection isSequenceableCollection ifTrue:[
+ "maybe we can do it in one big move"
+ newContents replaceFrom:(mySize + 1) to:newSize with:aCollection startingAt:1.
+ ] ifFalse:[
+ dstIndex := mySize + 1.
+ aCollection do:[:element |
+ newContents at:dstIndex put:element.
+ dstIndex := dstIndex + 1
+ ]
+ ].
+ firstIndex := 1.
+ lastIndex := newSize.
+ contentsArray := newContents.
+ contentsArray sort:sortBlock.
+ ^ self
].
super addAll:aCollection
@@ -169,11 +169,11 @@
|index|
lastIndex < firstIndex "i.e. self size == 0" ifTrue:[
- super add:anObject
+ super add:anObject
] ifFalse:[
- index := self indexForInserting:anObject.
- self makeRoomAtIndex:index.
- contentsArray at:index put:anObject
+ index := self indexForInserting:anObject.
+ self makeRoomAtIndex:index.
+ contentsArray at:index put:anObject
].
^ anObject
@@ -186,17 +186,18 @@
!SortedCollection methodsFor:'copying'!
-finalizeCopyFrom:aSortedCollection
- "sent after a deepCopy or when a new collection species has been created.
+postCopyFrom:anOriginal
+ "sent after a copy or when a new collection species has been created.
The new collection should have the same sortBlock as the original."
- sortBlock := aSortedCollection sortBlock
+ sortBlock := anOriginal sortBlock
"
#(4 7 1 99 -1 17) asSortedCollection inspect
- #(4 7 1 99 -1 17) asSortedCollection deepCopy inspect
+ #(4 7 1 99 -1 17) asSortedCollection copy inspect
(#(4 7 1 99 -1 17) asSortedCollection sortBlock:[:a :b | a > b]) inspect
- (#(4 7 1 99 -1 17) asSortedCollection sortBlock:[:a :b | a > b]) deepCopy inspect
+ (#(4 7 1 99 -1 17) asSortedCollection sortBlock:[:a :b | a > b]) copy inspect
+ (#(4 7 1 99 -1 17) asSortedCollection select:[:e| e even]) inspect
"
! !
@@ -207,7 +208,7 @@
"could be an instance of a subclass..."
self class == SortedCollection ifTrue:[
- ^ self
+ ^ self
].
^ super asSortedCollection
! !
@@ -244,8 +245,8 @@
tally := 0.
[(index <= lastIndex) and:[(contentsArray at:index) = anObject]] whileTrue:[
- tally := tally + 1.
- index := index + 1
+ tally := tally + 1.
+ index := index + 1
].
^ tally
@@ -262,7 +263,7 @@
"return the element before the argument, anObject; or nil if there is none.
If the receiver does not contain anObject, report an error"
- ^ self before:anObject ifAbsent:[self error:'no such element']
+ ^ self before:anObject ifAbsent:[self errorNotFound]
"
#(7 3 9 10 99) asSortedCollection before:50
@@ -304,7 +305,7 @@
"return the element after the argument, anObject; or nil if there is none.
If the receiver does not contain anObject, report an error"
- ^ self after:anObject ifAbsent:[self error:'no such element']
+ ^ self after:anObject ifAbsent:[self errorNotFound]
"
#(7 3 9 10 99) asSortedCollection after:50
@@ -331,7 +332,7 @@
"skip multiple occurences of the same ..."
[(index <= lastIndex) and:[(contentsArray at:index) = anObject]] whileTrue:[
- index := index + 1
+ index := index + 1
].
(index > lastIndex) ifTrue:[^ nil].
^ contentsArray at:index
@@ -353,7 +354,7 @@
sortBlock := aSortBlock.
lastIndex > firstIndex ifTrue:[
- contentsArray quickSortFrom:firstIndex to:lastIndex sortBlock:aSortBlock
+ contentsArray quickSortFrom:firstIndex to:lastIndex sortBlock:aSortBlock
]
"
@@ -391,14 +392,14 @@
low := firstIndex.
high := lastIndex.
[low <= high] whileTrue:[
- middle := (low + high) // 2.
- element := contentsArray at:middle.
- (sortBlock value:element value:anObject) ifTrue:[
- "middleelement is smaller than object"
- low := middle + 1
- ] ifFalse:[
- high := middle - 1
- ]
+ middle := (low + high) // 2.
+ element := contentsArray at:middle.
+ (sortBlock value:element value:anObject) ifTrue:[
+ "middleelement is smaller than object"
+ low := middle + 1
+ ] ifFalse:[
+ high := middle - 1
+ ]
].
^ low
--- a/SortedCollection.st Mon Oct 10 01:29:01 1994 +0100
+++ b/SortedCollection.st Mon Oct 10 01:29:28 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -11,17 +11,17 @@
"
OrderedCollection subclass:#SortedCollection
- instanceVariableNames:'sortBlock'
- classVariableNames:'DefaultSortBlock'
- poolDictionaries:''
- category:'Collections-Ordered'
+ instanceVariableNames:'sortBlock'
+ classVariableNames:'DefaultSortBlock'
+ poolDictionaries:''
+ category:'Collections-Sequenceable'
!
SortedCollection comment:'
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/SortedCollection.st,v 1.10 1994-08-05 01:02:42 claus Exp $
+$Header: /cvs/stx/stx/libbasic/SortedCollection.st,v 1.11 1994-10-10 00:28:38 claus Exp $
'!
!SortedCollection class methodsFor:'documentation'!
@@ -29,7 +29,7 @@
copyright
"
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/SortedCollection.st,v 1.10 1994-08-05 01:02:42 claus Exp $
+$Header: /cvs/stx/stx/libbasic/SortedCollection.st,v 1.11 1994-10-10 00:28:38 claus Exp $
"
!
@@ -136,24 +136,24 @@
mySize := self size.
otherSize := aCollection size.
((mySize == 0) or:[otherSize > 5]) ifTrue:[
- newSize := mySize + otherSize.
- newContents := Array new:newSize.
- newContents replaceFrom:1 to:mySize with:contentsArray startingAt:1.
- aCollection isSequenceableCollection ifTrue:[
- "maybe we can do it in one big move"
- newContents replaceFrom:(mySize + 1) to:newSize with:aCollection startingAt:1.
- ] ifFalse:[
- dstIndex := mySize + 1.
- aCollection do:[:element |
- newContents at:dstIndex put:element.
- dstIndex := dstIndex + 1
- ]
- ].
- firstIndex := 1.
- lastIndex := newSize.
- contentsArray := newContents.
- contentsArray sort:sortBlock.
- ^ self
+ newSize := mySize + otherSize.
+ newContents := Array new:newSize.
+ newContents replaceFrom:1 to:mySize with:contentsArray startingAt:1.
+ aCollection isSequenceableCollection ifTrue:[
+ "maybe we can do it in one big move"
+ newContents replaceFrom:(mySize + 1) to:newSize with:aCollection startingAt:1.
+ ] ifFalse:[
+ dstIndex := mySize + 1.
+ aCollection do:[:element |
+ newContents at:dstIndex put:element.
+ dstIndex := dstIndex + 1
+ ]
+ ].
+ firstIndex := 1.
+ lastIndex := newSize.
+ contentsArray := newContents.
+ contentsArray sort:sortBlock.
+ ^ self
].
super addAll:aCollection
@@ -169,11 +169,11 @@
|index|
lastIndex < firstIndex "i.e. self size == 0" ifTrue:[
- super add:anObject
+ super add:anObject
] ifFalse:[
- index := self indexForInserting:anObject.
- self makeRoomAtIndex:index.
- contentsArray at:index put:anObject
+ index := self indexForInserting:anObject.
+ self makeRoomAtIndex:index.
+ contentsArray at:index put:anObject
].
^ anObject
@@ -186,17 +186,18 @@
!SortedCollection methodsFor:'copying'!
-finalizeCopyFrom:aSortedCollection
- "sent after a deepCopy or when a new collection species has been created.
+postCopyFrom:anOriginal
+ "sent after a copy or when a new collection species has been created.
The new collection should have the same sortBlock as the original."
- sortBlock := aSortedCollection sortBlock
+ sortBlock := anOriginal sortBlock
"
#(4 7 1 99 -1 17) asSortedCollection inspect
- #(4 7 1 99 -1 17) asSortedCollection deepCopy inspect
+ #(4 7 1 99 -1 17) asSortedCollection copy inspect
(#(4 7 1 99 -1 17) asSortedCollection sortBlock:[:a :b | a > b]) inspect
- (#(4 7 1 99 -1 17) asSortedCollection sortBlock:[:a :b | a > b]) deepCopy inspect
+ (#(4 7 1 99 -1 17) asSortedCollection sortBlock:[:a :b | a > b]) copy inspect
+ (#(4 7 1 99 -1 17) asSortedCollection select:[:e| e even]) inspect
"
! !
@@ -207,7 +208,7 @@
"could be an instance of a subclass..."
self class == SortedCollection ifTrue:[
- ^ self
+ ^ self
].
^ super asSortedCollection
! !
@@ -244,8 +245,8 @@
tally := 0.
[(index <= lastIndex) and:[(contentsArray at:index) = anObject]] whileTrue:[
- tally := tally + 1.
- index := index + 1
+ tally := tally + 1.
+ index := index + 1
].
^ tally
@@ -262,7 +263,7 @@
"return the element before the argument, anObject; or nil if there is none.
If the receiver does not contain anObject, report an error"
- ^ self before:anObject ifAbsent:[self error:'no such element']
+ ^ self before:anObject ifAbsent:[self errorNotFound]
"
#(7 3 9 10 99) asSortedCollection before:50
@@ -304,7 +305,7 @@
"return the element after the argument, anObject; or nil if there is none.
If the receiver does not contain anObject, report an error"
- ^ self after:anObject ifAbsent:[self error:'no such element']
+ ^ self after:anObject ifAbsent:[self errorNotFound]
"
#(7 3 9 10 99) asSortedCollection after:50
@@ -331,7 +332,7 @@
"skip multiple occurences of the same ..."
[(index <= lastIndex) and:[(contentsArray at:index) = anObject]] whileTrue:[
- index := index + 1
+ index := index + 1
].
(index > lastIndex) ifTrue:[^ nil].
^ contentsArray at:index
@@ -353,7 +354,7 @@
sortBlock := aSortBlock.
lastIndex > firstIndex ifTrue:[
- contentsArray quickSortFrom:firstIndex to:lastIndex sortBlock:aSortBlock
+ contentsArray quickSortFrom:firstIndex to:lastIndex sortBlock:aSortBlock
]
"
@@ -391,14 +392,14 @@
low := firstIndex.
high := lastIndex.
[low <= high] whileTrue:[
- middle := (low + high) // 2.
- element := contentsArray at:middle.
- (sortBlock value:element value:anObject) ifTrue:[
- "middleelement is smaller than object"
- low := middle + 1
- ] ifFalse:[
- high := middle - 1
- ]
+ middle := (low + high) // 2.
+ element := contentsArray at:middle.
+ (sortBlock value:element value:anObject) ifTrue:[
+ "middleelement is smaller than object"
+ low := middle + 1
+ ] ifFalse:[
+ high := middle - 1
+ ]
].
^ low
--- a/String.st Mon Oct 10 01:29:01 1994 +0100
+++ b/String.st Mon Oct 10 01:29:28 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1988 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -19,9 +19,9 @@
String comment:'
COPYRIGHT (c) 1988 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/String.st,v 1.17 1994-08-05 01:02:46 claus Exp $
+$Header: /cvs/stx/stx/libbasic/String.st,v 1.18 1994-10-10 00:28:43 claus Exp $
'!
!String class methodsFor:'documentation'!
@@ -29,7 +29,7 @@
copyright
"
COPYRIGHT (c) 1988 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/String.st,v 1.17 1994-08-05 01:02:46 claus Exp $
+$Header: /cvs/stx/stx/libbasic/String.st,v 1.18 1994-10-10 00:28:43 claus Exp $
"
!
@@ -100,82 +100,82 @@
extern OBJ new();
if (_isSmallInteger(anInteger)) {
- len = _intVal(anInteger);
- if (len >= 0) {
+ len = _intVal(anInteger);
+ if (len >= 0) {
if (self == String) {
instsize = OHDR_SIZE + len + 1;
if (_CanDoQuickNew(instsize)) {
/*
* the most common case
*/
- _qCheckedNew(newString, instsize);
- _InstPtr(newString)->o_class = self;
- cp = _stringVal(newString);
+ _qCheckedNew(newString, instsize);
+ _InstPtr(newString)->o_class = self;
+ cp = _stringVal(newString);
#ifdef FAST_MEMSET
- memset(cp, ' ', len);
- *(cp + len) = '\0';
+ memset(cp, ' ', len);
+ *(cp + len) = '\0';
#else
- while (len >= 8) {
- cp[0] = cp[1] = cp[2] = cp[3] = ' ';
- cp[4] = cp[5] = cp[6] = cp[7] = ' ';
- cp += 8;
+ while (len >= 8) {
+ cp[0] = cp[1] = cp[2] = cp[3] = ' ';
+ cp[4] = cp[5] = cp[6] = cp[7] = ' ';
+ cp += 8;
len -= 8;
- }
- while (len--)
- *cp++ = ' ';
- *cp = '\0';
+ }
+ while (len--)
+ *cp++ = ' ';
+ *cp = '\0';
#endif
- RETURN (newString);
+ RETURN (newString);
}
nInstVars = 0;
} else {
nInstVars = _intVal(_ClassInstPtr(self)->c_ninstvars);
- instsize = OHDR_SIZE + __OBJS2BYTES__(nInstVars) + len + 1;
+ instsize = OHDR_SIZE + __OBJS2BYTES__(nInstVars) + len + 1;
}
- PROTECT_CONTEXT
- _qNew(newString, instsize, SENDER);
- UNPROTECT_CONTEXT
- if (newString == nil) goto fail;
- _InstPtr(newString)->o_class = self;
+ PROTECT_CONTEXT
+ _qNew(newString, instsize, SENDER);
+ UNPROTECT_CONTEXT
+ if (newString == nil) goto fail;
+ _InstPtr(newString)->o_class = self;
if (nInstVars) {
#if defined(memset4)
- memset4(_InstPtr(newString)->i_instvars, nil, nInstVars);
+ memset4(_InstPtr(newString)->i_instvars, nil, nInstVars);
#else
# if defined(FAST_MEMSET) && ! defined(NEGATIVE_ADDRESSES)
- /*
- * knowing that nil is 0
- */
- memset(_InstPtr(newString)->i_instvars, 0, __OBJS2BYTES__(nInstVars));
+ /*
+ * knowing that nil is 0
+ */
+ memset(_InstPtr(newString)->i_instvars, 0, __OBJS2BYTES__(nInstVars));
# else
- op = _InstPtr(newString)->i_instvars;
- do {
- *op++ = nil;
- } while (--nInstVars);
+ op = _InstPtr(newString)->i_instvars;
+ do {
+ *op++ = nil;
+ } while (--nInstVars);
# endif
#endif
- cp = _stringVal(newString) + __OBJS2BYTES__(nInstVars);
- } else {
+ cp = _stringVal(newString) + __OBJS2BYTES__(nInstVars);
+ } else {
cp = _stringVal(newString);
}
#ifdef FAST_MEMSET
- memset(cp, ' ', len);
- *(cp + len) = '\0';
+ memset(cp, ' ', len);
+ *(cp + len) = '\0';
#else
- while (len >= 8) {
- cp[0] = cp[1] = cp[2] = cp[3] = ' ';
- cp[4] = cp[5] = cp[6] = cp[7] = ' ';
- cp += 8;
- len -= 8;
- }
- while (len--)
- *cp++ = ' ';
- *cp = '\0';
+ while (len >= 8) {
+ cp[0] = cp[1] = cp[2] = cp[3] = ' ';
+ cp[4] = cp[5] = cp[6] = cp[7] = ' ';
+ cp += 8;
+ len -= 8;
+ }
+ while (len--)
+ *cp++ = ' ';
+ *cp = '\0';
#endif
- RETURN (newString);
- }
+ RETURN (newString);
+ }
}
fail: ;;
%}
@@ -204,7 +204,7 @@
cls = _qClass(self);
if ((cls == String) || (cls == Symbol)) {
- RETURN ( _MKSMALLINT(_stringSize(self)) );
+ RETURN ( _MKSMALLINT(_stringSize(self)) );
}
%}
.
@@ -222,18 +222,17 @@
OBJ cls;
if (_isSmallInteger(index)) {
- indx = _intVal(index);
- cls = _qClass(self);
- if (cls != String)
- indx += __OBJS2BYTES__(_intVal(_ClassInstPtr(cls)->c_ninstvars));
- len = _stringSize(self);
- if ((indx > 0) && (indx <= len)) {
- RETURN ( _MKCHARACTER(_stringVal(self)[indx-1] & 0xFF) );
- }
+ indx = _intVal(index);
+ cls = _qClass(self);
+ if (cls != String)
+ indx += __OBJS2BYTES__(_intVal(_ClassInstPtr(cls)->c_ninstvars));
+ len = _stringSize(self);
+ if ((indx > 0) && (indx <= len)) {
+ RETURN ( _MKCHARACTER(_stringVal(self)[indx-1] & 0xFF) );
+ }
}
-%}
-.
- self subscriptBoundsError
+%}.
+ ^ self subscriptBoundsError:index
!
basicAt:index put:aCharacter
@@ -247,31 +246,30 @@
OBJ cls;
if (__isCharacter(aCharacter)) {
- value = _intVal(_characterVal(aCharacter));
- if ((value > 0)
- && (value <= 255)
- && _isSmallInteger(index)) {
- indx = _intVal(index);
- cls = _qClass(self);
- if (cls != String)
- indx += __OBJS2BYTES__(_intVal(_ClassInstPtr(cls)->c_ninstvars));
- len = _stringSize(self);
- if ((indx > 0) && (indx <= len)) {
- _stringVal(self)[indx-1] = value;
- RETURN ( aCharacter );
- }
- }
+ value = _intVal(_characterVal(aCharacter));
+ if ((value > 0)
+ && (value <= 255)
+ && _isSmallInteger(index)) {
+ indx = _intVal(index);
+ cls = _qClass(self);
+ if (cls != String)
+ indx += __OBJS2BYTES__(_intVal(_ClassInstPtr(cls)->c_ninstvars));
+ len = _stringSize(self);
+ if ((indx > 0) && (indx <= len)) {
+ _stringVal(self)[indx-1] = value;
+ RETURN ( aCharacter );
+ }
+ }
}
-%}
-.
+%}.
(aCharacter isMemberOf:Character) ifFalse:[
- self elementNotCharacter
+ ^ self elementNotCharacter
] ifTrue:[
- (aCharacter asciiValue between:1 and:255) ifFalse:[
- self elementBoundsError
- ] ifTrue:[
- self subscriptBoundsError
- ]
+ (aCharacter asciiValue between:1 and:255) ifFalse:[
+ ^ self elementBoundsError
+ ] ifTrue:[
+ ^ self subscriptBoundsError:index
+ ]
]
! !
@@ -282,7 +280,7 @@
The argument must be a String, subclass instances are not allowed."
%{
if (_qClass(self) == String) {
- RETURN ( _MKSYMBOL(_stringVal(self), (OBJ *)0, __context) );
+ RETURN ( _MKSYMBOL(_stringVal(self), (OBJ *)0, __context) );
}
%}
.
@@ -312,8 +310,8 @@
%{ /* NOCONTEXT */
if (_qClass(self) == String) {
- printf("%s", _stringVal(self));
- RETURN (self);
+ printf("%s", _stringVal(self));
+ RETURN (self);
}
%}
.
@@ -333,20 +331,20 @@
char *cp;
if (__isString(formatString)) {
- /*
- * actually only needed on sparc: since thisContext is
- * in a global register, which gets destroyed by printf,
- * manually save it here - very stupid ...
- */
- OBJ sav = __thisContext;
+ /*
+ * actually only needed on sparc: since thisContext is
+ * in a global register, which gets destroyed by printf,
+ * manually save it here - very stupid ...
+ */
+ OBJ sav = __thisContext;
- cp = (char *)_stringVal(self);
- if (_qClass(self) != String)
- cp += __OBJS2BYTES__(_intVal(_ClassInstPtr(_qClass(self))->c_ninstvars));
+ cp = (char *)_stringVal(self);
+ if (_qClass(self) != String)
+ cp += __OBJS2BYTES__(_intVal(_ClassInstPtr(_qClass(self))->c_ninstvars));
- sprintf(buffer, (char *)_stringVal(formatString), cp);
- __thisContext = sav;
- RETURN ( _MKSTRING(buffer COMMA_SND) );
+ sprintf(buffer, (char *)_stringVal(formatString), cp);
+ __thisContext = sav;
+ RETURN ( _MKSTRING(buffer COMMA_SND) );
}
%}
.
@@ -364,19 +362,19 @@
n := self occurrencesOf:$'.
n == 0 ifFalse:[
- s := String new:(n + 2 + self size).
- s at:1 put:$'.
- index := 2.
- self do:[:thisChar |
- (thisChar == $') ifTrue:[
- s at:index put:thisChar.
- index := index + 1.
- ].
- s at:index put:thisChar.
- index := index + 1.
- ].
- s at:index put:$'.
- ^ s
+ s := String new:(n + 2 + self size).
+ s at:1 put:$'.
+ index := 2.
+ self do:[:thisChar |
+ (thisChar == $') ifTrue:[
+ s at:index put:thisChar.
+ index := index + 1.
+ ].
+ s at:index put:thisChar.
+ index := index + 1.
+ ].
+ s at:index put:$'.
+ ^ s
].
^ '''' , self , ''''
!
@@ -386,12 +384,12 @@
aStream nextPut: $'.
(self includes:$') ifTrue:[
- self do:[:thisChar |
- (thisChar == $') ifTrue:[aStream nextPut:thisChar].
- aStream nextPut:thisChar
- ]
+ self do:[:thisChar |
+ (thisChar == $') ifTrue:[aStream nextPut:thisChar].
+ aStream nextPut:thisChar
+ ]
] ifFalse:[
- aStream nextPutAll:self
+ aStream nextPutAll:self
].
aStream nextPut:$'
! !
@@ -415,43 +413,43 @@
if (_isNonNilObject(s)
&& (((cls = _qClass(s)) == String) || (cls == Symbol) || (cls == _qClass(self)))) {
- cp1 = (char *) _stringVal(self);
- len1 = _stringSize(self);
+ cp1 = (char *) _stringVal(self);
+ len1 = _stringSize(self);
- /*
- * care for instances of subclasses ...
- */
- if (_qClass(self) != String) {
- int n = __OBJS2BYTES__(_intVal(_ClassInstPtr(_qClass(self))->c_ninstvars));
+ /*
+ * care for instances of subclasses ...
+ */
+ if (_qClass(self) != String) {
+ int n = __OBJS2BYTES__(_intVal(_ClassInstPtr(_qClass(self))->c_ninstvars));
- cp1 += n;
- len1 -= n;
- }
+ cp1 += n;
+ len1 -= n;
+ }
- cp2 = (char *) _stringVal(s);
- len2 = _stringSize(s);
- /*
- * care for instances of subclasses ...
- */
- if (cls != String) {
- int n = __OBJS2BYTES__(_intVal(_ClassInstPtr(cls)->c_ninstvars));
+ cp2 = (char *) _stringVal(s);
+ len2 = _stringSize(s);
+ /*
+ * care for instances of subclasses ...
+ */
+ if (cls != String) {
+ int n = __OBJS2BYTES__(_intVal(_ClassInstPtr(cls)->c_ninstvars));
- cp2 += n;
- len2 -= n;
- }
+ cp2 += n;
+ len2 -= n;
+ }
- if (len1 <= len2)
- cmp = strncmp(cp1, cp2, len1);
- else
- cmp = strncmp(cp1, cp2, len2);
+ if (len1 <= len2)
+ cmp = strncmp(cp1, cp2, len1);
+ else
+ cmp = strncmp(cp1, cp2, len2);
- if (cmp > 0) {
- RETURN ( true );
- }
- if ((cmp == 0) && (len1 > len2)) {
- RETURN ( true );
- }
- RETURN ( false );
+ if (cmp > 0) {
+ RETURN ( true );
+ }
+ if ((cmp == 0) && (len1 > len2)) {
+ RETURN ( true );
+ }
+ RETURN ( false );
}
%}
.
@@ -471,41 +469,41 @@
OBJ cls;
if (s == self) {
- RETURN ( true );
+ RETURN ( true );
}
if (! _isNonNilObject(s)) {
- RETURN ( false );
+ RETURN ( false );
}
if (((cls = _qClass(s)) == String) || (cls == Symbol) || (cls == _qClass(self))) {
- cp1 = (char *) _stringVal(self);
- l1 = _stringSize(self);
- /*
- * care for instances of subclasses ...
- */
- if (_qClass(self) != String) {
- int n = __OBJS2BYTES__(_intVal(_ClassInstPtr(_qClass(self))->c_ninstvars));
+ cp1 = (char *) _stringVal(self);
+ l1 = _stringSize(self);
+ /*
+ * care for instances of subclasses ...
+ */
+ if (_qClass(self) != String) {
+ int n = __OBJS2BYTES__(_intVal(_ClassInstPtr(_qClass(self))->c_ninstvars));
- cp1 += n;
- l1 -= n;
- }
+ cp1 += n;
+ l1 -= n;
+ }
- cp2 = (char *) _stringVal(s);
- l2 = _stringSize(s);
- /*
- * care for instances of subclasses ...
- */
- if (cls != String) {
- int n = __OBJS2BYTES__(_intVal(_ClassInstPtr(cls)->c_ninstvars));
+ cp2 = (char *) _stringVal(s);
+ l2 = _stringSize(s);
+ /*
+ * care for instances of subclasses ...
+ */
+ if (cls != String) {
+ int n = __OBJS2BYTES__(_intVal(_ClassInstPtr(cls)->c_ninstvars));
- cp2 += n;
- l2 -= n;
- }
+ cp2 += n;
+ l2 -= n;
+ }
- if (l1 != l2) {
- RETURN ( false );
- }
- RETURN ( (strncmp(cp1, cp2, l1) == 0) ? true : false );
+ if (l1 != l2) {
+ RETURN ( false );
+ }
+ RETURN ( (strncmp(cp1, cp2, l1) == 0) ? true : false );
}
%}
.
@@ -525,40 +523,40 @@
OBJ cls;
if (s == self) {
- RETURN ( false );
+ RETURN ( false );
}
if (! _isNonNilObject(s)) {
- RETURN ( true );
+ RETURN ( true );
}
if (((cls = _qClass(s)) == String) || (cls == Symbol) || (cls == _qClass(self))) {
- cp1 = (char *) _stringVal(self);
- l1 = _stringSize(self);
- /*
- * care for instances of subclasses ...
- */
- if (_qClass(self) != String) {
- int n = __OBJS2BYTES__(_intVal(_ClassInstPtr(_qClass(self))->c_ninstvars));
+ cp1 = (char *) _stringVal(self);
+ l1 = _stringSize(self);
+ /*
+ * care for instances of subclasses ...
+ */
+ if (_qClass(self) != String) {
+ int n = __OBJS2BYTES__(_intVal(_ClassInstPtr(_qClass(self))->c_ninstvars));
- cp1 += n;
- l1 -= n;
- }
+ cp1 += n;
+ l1 -= n;
+ }
- cp2 = (char *) _stringVal(s);
- l2 = _stringSize(s);
- /*
- * care for instances of subclasses ...
- */
- if (cls != String) {
- int n = __OBJS2BYTES__(_intVal(_ClassInstPtr(cls)->c_ninstvars));
+ cp2 = (char *) _stringVal(s);
+ l2 = _stringSize(s);
+ /*
+ * care for instances of subclasses ...
+ */
+ if (cls != String) {
+ int n = __OBJS2BYTES__(_intVal(_ClassInstPtr(cls)->c_ninstvars));
- cp2 += n;
- l2 -= n;
- }
+ cp2 += n;
+ l2 -= n;
+ }
- if (l1 != l2) {
- RETURN ( true );
- }
- RETURN ( (strncmp(cp1, cp2, l1) == 0) ? false : true );
+ if (l1 != l2) {
+ RETURN ( true );
+ }
+ RETURN ( (strncmp(cp1, cp2, l1) == 0) ? false : true );
}
%}
.
@@ -581,37 +579,37 @@
if (_isNonNilObject(s)
&& (((cls = _qClass(s)) == String) || (cls == Symbol) || (cls == _qClass(self)))) {
- cp1 = (char *) _stringVal(self);
+ cp1 = (char *) _stringVal(self);
- /*
- * care for instances of subclasses ...
- */
- if (_qClass(self) != String) {
- int n = __OBJS2BYTES__(_intVal(_ClassInstPtr(_qClass(self))->c_ninstvars));
+ /*
+ * care for instances of subclasses ...
+ */
+ if (_qClass(self) != String) {
+ int n = __OBJS2BYTES__(_intVal(_ClassInstPtr(_qClass(self))->c_ninstvars));
- cp1 += n;
- }
+ cp1 += n;
+ }
- cp2 = (char *) _stringVal(s);
- /*
- * care for instances of subclasses ...
- */
- if (cls != String) {
- int n = __OBJS2BYTES__(_intVal(_ClassInstPtr(cls)->c_ninstvars));
+ cp2 = (char *) _stringVal(s);
+ /*
+ * care for instances of subclasses ...
+ */
+ if (cls != String) {
+ int n = __OBJS2BYTES__(_intVal(_ClassInstPtr(cls)->c_ninstvars));
- cp2 += n;
- }
+ cp2 += n;
+ }
#ifdef HAS_STRCOLL
- cmp = strcoll(cp1, cp2);
+ cmp = strcoll(cp1, cp2);
#else
- cmp = strcmp(cp1, cp2);
+ cmp = strcmp(cp1, cp2);
#endif
- if (cmp > 0) {
- RETURN ( true );
- }
- RETURN ( false );
+ if (cmp > 0) {
+ RETURN ( true );
+ }
+ RETURN ( false );
}
%}.
"
@@ -635,15 +633,15 @@
OBJ cls;
if (__isCharacter(aCharacter)) {
- count = 0;
- byteValue = _intVal(_characterVal(aCharacter));
- cp = _stringVal(self);
- if ((cls = _qClass(self)) != String)
- cp += __OBJS2BYTES__(_intVal(_ClassInstPtr(cls)->c_ninstvars));
- while (*cp) {
- if (*cp++ == byteValue) count++;
- }
- RETURN ( _MKSMALLINT(count) );
+ count = 0;
+ byteValue = _intVal(_characterVal(aCharacter));
+ cp = _stringVal(self);
+ if ((cls = _qClass(self)) != String)
+ cp += __OBJS2BYTES__(_intVal(_ClassInstPtr(cls)->c_ninstvars));
+ while (*cp) {
+ if (*cp++ == byteValue) count++;
+ }
+ RETURN ( _MKSMALLINT(count) );
}
%}
.
@@ -670,22 +668,22 @@
OBJ cls;
if (__isCharacter(aCharacter)) {
- byteValue = _intVal(_characterVal(aCharacter));
- cp = _stringVal(self);
- if ((cls = _qClass(self)) != String)
- cp += __OBJS2BYTES__(_intVal(_ClassInstPtr(cls)->c_ninstvars));
+ byteValue = _intVal(_characterVal(aCharacter));
+ cp = _stringVal(self);
+ if ((cls = _qClass(self)) != String)
+ cp += __OBJS2BYTES__(_intVal(_ClassInstPtr(cls)->c_ninstvars));
#ifdef FAST_STRCHR
- cp = (unsigned char *) strchr(cp, _intVal(_characterVal(aCharacter)));
- if (cp) {
- RETURN ( true );
- }
+ cp = (unsigned char *) strchr(cp, _intVal(_characterVal(aCharacter)));
+ if (cp) {
+ RETURN ( true );
+ }
#else
- while (*cp) {
- if (*cp == byteValue) {
- RETURN ( true );
- }
- cp++;
- }
+ while (*cp) {
+ if (*cp == byteValue) {
+ RETURN ( true );
+ }
+ cp++;
+ }
#endif
}
%}
@@ -718,18 +716,18 @@
OBJ cls;
if (__isString(aCollection)) {
- matchP = _stringVal(aCollection);
- cp = _stringVal(self);
- if ((cls = _qClass(self)) != String)
- cp += __OBJS2BYTES__(_intVal(_ClassInstPtr(cls)->c_ninstvars));
+ matchP = _stringVal(aCollection);
+ cp = _stringVal(self);
+ if ((cls = _qClass(self)) != String)
+ cp += __OBJS2BYTES__(_intVal(_ClassInstPtr(cls)->c_ninstvars));
- while (*cp) {
- if (INDEX(matchP, *cp)) {
- RETURN ( true );
- }
- cp++;
- }
- RETURN ( false );
+ while (*cp) {
+ if (INDEX(matchP, *cp)) {
+ RETURN ( true );
+ }
+ cp++;
+ }
+ RETURN ( false );
}
%}
.
@@ -760,23 +758,23 @@
OBJ cls;
if (__isCharacter(aCharacter)) {
- cp = _stringVal(self);
- if ((cls = _qClass(self)) != String)
- cp += __OBJS2BYTES__(_intVal(_ClassInstPtr(cls)->c_ninstvars));
+ cp = _stringVal(self);
+ if ((cls = _qClass(self)) != String)
+ cp += __OBJS2BYTES__(_intVal(_ClassInstPtr(cls)->c_ninstvars));
#ifdef FAST_STRCHR
- cp = (unsigned char *) strchr(cp, _intVal(_characterVal(aCharacter)));
- if (cp) {
- RETURN ( _MKSMALLINT(cp - _stringVal(self) + 1) );
- }
+ cp = (unsigned char *) strchr(cp, _intVal(_characterVal(aCharacter)));
+ if (cp) {
+ RETURN ( _MKSMALLINT(cp - _stringVal(self) + 1) );
+ }
#else
- byteValue = _intVal(_characterVal(aCharacter));
- index = 1;
- while (*cp) {
- if (*cp++ == byteValue) {
- RETURN ( _MKSMALLINT(index) );
- }
- index++;
- }
+ byteValue = _intVal(_characterVal(aCharacter));
+ index = 1;
+ while (*cp) {
+ if (*cp++ == byteValue) {
+ RETURN ( _MKSMALLINT(index) );
+ }
+ index++;
+ }
#endif
}
%}
@@ -805,32 +803,32 @@
OBJ cls;
if (_isSmallInteger(start)) {
- if (__isCharacter(aCharacter)) {
- byteValue = _intVal(_characterVal(aCharacter));
- index = _intVal(start);
- if (index <= 0)
- index = 1;
- if ((cls = _qClass(self)) != String)
- index += __OBJS2BYTES__(_intVal(_ClassInstPtr(cls)->c_ninstvars));
- len = _stringSize(self);
- if (index <= len) {
- cp = _stringVal(self) + index - 1;
+ if (__isCharacter(aCharacter)) {
+ byteValue = _intVal(_characterVal(aCharacter));
+ index = _intVal(start);
+ if (index <= 0)
+ index = 1;
+ if ((cls = _qClass(self)) != String)
+ index += __OBJS2BYTES__(_intVal(_ClassInstPtr(cls)->c_ninstvars));
+ len = _stringSize(self);
+ if (index <= len) {
+ cp = _stringVal(self) + index - 1;
#ifdef FAST_STRCHR
- cp = (unsigned char *) strchr(cp, byteValue);
- if (cp) {
- RETURN ( _MKSMALLINT(cp - _stringVal(self) + 1) );
- }
+ cp = (unsigned char *) strchr(cp, byteValue);
+ if (cp) {
+ RETURN ( _MKSMALLINT(cp - _stringVal(self) + 1) );
+ }
#else
- while (*cp) {
- if (*cp++ == byteValue) {
- RETURN ( _MKSMALLINT(index) );
- }
- index++;
- }
+ while (*cp) {
+ if (*cp++ == byteValue) {
+ RETURN ( _MKSMALLINT(index) );
+ }
+ index++;
+ }
#endif
- }
- }
- RETURN ( _MKSMALLINT(0) );
+ }
+ }
+ RETURN ( _MKSMALLINT(0) );
}
%}
.
@@ -854,23 +852,23 @@
index = _intVal(start);
if (index <= 0) {
- index = 1;
+ index = 1;
}
if ((cls = _qClass(self)) != String)
- index += __OBJS2BYTES__(_intVal(_ClassInstPtr(cls)->c_ninstvars));
+ index += __OBJS2BYTES__(_intVal(_ClassInstPtr(cls)->c_ninstvars));
len = _stringSize(self);
if (index > len) {
- RETURN ( _MKSMALLINT(0) );
+ RETURN ( _MKSMALLINT(0) );
}
cp = _stringVal(self) + index - 1;
while (c = *cp++) {
#ifdef ASCII
- if (c <= ' ')
+ if (c <= ' ')
#endif
- if ((c == ' ') || (c == '\t') || (c == '\n')
- || (c == '\r') || (c == '\f')) {
- RETURN ( _MKSMALLINT(cp - _stringVal(self)) );
- }
+ if ((c == ' ') || (c == '\t') || (c == '\n')
+ || (c == '\r') || (c == '\f')) {
+ RETURN ( _MKSMALLINT(cp - _stringVal(self)) );
+ }
}
%}
.
@@ -888,11 +886,11 @@
"return true, if the receiver starts with something, aString."
aString isString ifFalse: [
- (aString isMemberOf:Character) ifTrue:[
- self isEmpty ifTrue:[^ false].
- ^ (self at:1) == aString
- ].
- ^ super startsWith:aString
+ (aString isMemberOf:Character) ifTrue:[
+ self isEmpty ifTrue:[^ false].
+ ^ (self at:1) == aString
+ ].
+ ^ super startsWith:aString
].
%{
int len1, len2;
@@ -903,24 +901,24 @@
len1 = _qSize(self);
src1 = _stringVal(self);
if ((cls = _qClass(self)) != String) {
- int n = __OBJS2BYTES__(_intVal(_ClassInstPtr(cls)->c_ninstvars));
- len1 -= n;
- src1 += n;
+ int n = __OBJS2BYTES__(_intVal(_ClassInstPtr(cls)->c_ninstvars));
+ len1 -= n;
+ src1 += n;
}
len2 = _qSize(s);
src2 = _stringVal(s);
if ((cls = _qClass(s)) != String) {
- int n = __OBJS2BYTES__(_intVal(_ClassInstPtr(cls)->c_ninstvars));
- len2 -= n;
- src2 += n;
+ int n = __OBJS2BYTES__(_intVal(_ClassInstPtr(cls)->c_ninstvars));
+ len2 -= n;
+ src2 += n;
}
if (len1 < len2) {
- RETURN ( false );
+ RETURN ( false );
}
while (*src2)
- if (*src2++ != *src1++) {
- RETURN ( false );
- }
+ if (*src2++ != *src1++) {
+ RETURN ( false );
+ }
%}
.
^ true
@@ -935,11 +933,11 @@
"return true, if the receiver end with something, aString."
aString isString ifFalse: [
- (aString isMemberOf:Character) ifTrue:[
- self isEmpty ifTrue:[^ false].
- ^ (self at:(self size)) == aString
- ].
- ^ super endsWith:aString
+ (aString isMemberOf:Character) ifTrue:[
+ self isEmpty ifTrue:[^ false].
+ ^ (self at:(self size)) == aString
+ ].
+ ^ super endsWith:aString
].
%{
int len1, len2;
@@ -950,26 +948,26 @@
len1 = _qSize(self);
src1 = _stringVal(self);
if ((cls = _qClass(self)) != String) {
- int n = __OBJS2BYTES__(_intVal(_ClassInstPtr(cls)->c_ninstvars));
- len1 -= n;
- src1 += n;
+ int n = __OBJS2BYTES__(_intVal(_ClassInstPtr(cls)->c_ninstvars));
+ len1 -= n;
+ src1 += n;
}
len2 = _qSize(s);
src2 = _stringVal(s);
if ((cls = _qClass(s)) != String) {
- int n = __OBJS2BYTES__(_intVal(_ClassInstPtr(cls)->c_ninstvars));
- len2 -= n;
- src2 += n;
+ int n = __OBJS2BYTES__(_intVal(_ClassInstPtr(cls)->c_ninstvars));
+ len2 -= n;
+ src2 += n;
}
if (len1 < len2) {
- RETURN ( false );
+ RETURN ( false );
}
src1 = _stringVal(self) + len1 - len2;
src2 = _stringVal(aString);
while (*src2)
- if (*src2++ != *src1++) {
- RETURN ( false );
- }
+ if (*src2++ != *src1++) {
+ RETURN ( false );
+ }
%}
.
^ true
@@ -992,12 +990,12 @@
src = _stringVal(self);
if ((cls = _qClass(self)) != String)
- src += __OBJS2BYTES__(_intVal(_ClassInstPtr(cls)->c_ninstvars));
+ src += __OBJS2BYTES__(_intVal(_ClassInstPtr(cls)->c_ninstvars));
while (*src)
- if (*src++ != ' ') {
- RETURN ( false );
- }
+ if (*src++ != ' ') {
+ RETURN ( false );
+ }
%}
.
^ true
@@ -1031,72 +1029,72 @@
&& (__isString(aString) || __isSymbol(aString))
&& _isSmallInteger(insrtWeight) && _isSmallInteger(caseWeight)
&& _isSmallInteger(substWeight) && _isSmallInteger(deleteWeight)) {
- iW = _intVal(insrtWeight);
- cW = _intVal(caseWeight);
- sW = _intVal(substWeight);
- dW = _intVal(deleteWeight);
- s1 = _stringVal(self);
- s2 = _stringVal(aString);
- l1 = strlen(s1);
- l2 = strlen(s2);
+ iW = _intVal(insrtWeight);
+ cW = _intVal(caseWeight);
+ sW = _intVal(substWeight);
+ dW = _intVal(deleteWeight);
+ s1 = _stringVal(self);
+ s2 = _stringVal(aString);
+ l1 = strlen(s1);
+ l2 = strlen(s2);
- sz = (l1 < l2) ? l2 : l1;
- delta = sz + 1;
- if (sz <= FASTSIZE) {
- data = fastData;
- } else {
- /* add ifdef ALLOCA here ... */
- data = (unsigned short *)malloc(delta * delta * sizeof(short));
- }
+ sz = (l1 < l2) ? l2 : l1;
+ delta = sz + 1;
+ if (sz <= FASTSIZE) {
+ data = fastData;
+ } else {
+ /* add ifdef ALLOCA here ... */
+ data = (unsigned short *)malloc(delta * delta * sizeof(short));
+ }
- data[0] = 0;
- dp = data+1;
- for (j=1, dp=data+1; j<=sz; j++, dp++)
- *dp = *(dp-1) + iW;
+ data[0] = 0;
+ dp = data+1;
+ for (j=1, dp=data+1; j<=sz; j++, dp++)
+ *dp = *(dp-1) + iW;
- for (i=1, dp=data+delta; i<=sz; i++, dp+=delta)
- *dp = *(dp-delta) + dW;
+ for (i=1, dp=data+delta; i<=sz; i++, dp+=delta)
+ *dp = *(dp-delta) + dW;
- for (i=1; i<=l1; i++) {
- for (j=1; j<=l2; j++) {
- dp = data + (i*delta) + j;
- if (s1[i] != s2[j]) {
- if (tolower(s1[i]) == tolower(s2[j])) {
- m = cW;
- } else {
- m = sW;
- }
- } else
- m = 0;
+ for (i=1; i<=l1; i++) {
+ for (j=1; j<=l2; j++) {
+ dp = data + (i*delta) + j;
+ if (s1[i] != s2[j]) {
+ if (tolower(s1[i]) == tolower(s2[j])) {
+ m = cW;
+ } else {
+ m = sW;
+ }
+ } else
+ m = 0;
- v2 = *(dp - 1) + iW;
- v3 = *(dp - delta) + dW;
- v1 = *(dp - delta - 1) + m;
- if (v1 < v2)
- if (v1 < v3)
- m = v1;
- else
- m = v3;
- else
- if (v2 < v3)
- m = v2;
- else
- m = v3;
- *dp = m;
- }
- }
- m = data[l1 * delta + l2];
- if (sz > FASTSIZE)
- free(data);
- RETURN ( _MKSMALLINT(m) );
+ v2 = *(dp - 1) + iW;
+ v3 = *(dp - delta) + dW;
+ v1 = *(dp - delta - 1) + m;
+ if (v1 < v2)
+ if (v1 < v3)
+ m = v1;
+ else
+ m = v3;
+ else
+ if (v2 < v3)
+ m = v2;
+ else
+ m = v3;
+ *dp = m;
+ }
+ }
+ m = data[l1 * delta + l2];
+ if (sz > FASTSIZE)
+ free(data);
+ RETURN ( _MKSMALLINT(m) );
}
}
%}
.
^ super levenshteinTo:aString
- s:substWeight c:caseWeight
- i:insrtWeight d:deleteWeight
+ s:substWeight c:caseWeight
+ i:insrtWeight d:deleteWeight
"'ocmprt' levenshteinTo:'computer'
'computer' levenshteinTo:'computer'
@@ -1111,7 +1109,7 @@
"return a copy of the receiver"
(self isMemberOf:String) ifTrue:[
- ^ self copyFrom:1
+ ^ self copyFrom:1
].
^ super shallowCopy
!
@@ -1119,8 +1117,12 @@
deepCopyUsing:aDictionary
"return a copy of the receiver - reimplemented to be a bit faster"
+ "
+ could be an instance of a subclass which needs deepCopy
+ of its named instvars ...
+ "
(self isMemberOf:String) ifTrue:[
- ^ self copyFrom:1
+ ^ self copyFrom:1
].
^ super deepCopy
!
@@ -1128,8 +1130,12 @@
simpleDeepCopy
"return a copy of the receiver"
+ "
+ could be an instance of a subclass which needs deepCopy
+ of its named instvars ...
+ "
(self isMemberOf:String) ifTrue:[
- ^ self copyFrom:1
+ ^ self copyFrom:1
].
^ super deepCopy
!
@@ -1137,8 +1143,12 @@
deepCopy
"return a copy of the receiver"
+ "
+ could be an instance of a subclass which needs deepCopy
+ of its named instvars ...
+ "
(self isMemberOf:String) ifTrue:[
- ^ self copyFrom:1
+ ^ self copyFrom:1
].
^ super deepCopy
!
@@ -1158,59 +1168,59 @@
OBJ new();
if (_isNonNilObject(s)) {
- myClass = _qClass(self);
- argClass = _qClass(s);
+ myClass = _qClass(self);
+ argClass = _qClass(s);
/*
* either same class or both Strings/Symbols:
* can do it here
*/
- if ((myClass == argClass)
- || (((myClass == _String) || (myClass == Symbol))
- && ((argClass == _String) || (argClass == Symbol)))) {
- cp1 = (char *) _stringVal(self);
- l1 = _stringSize(self);
- if (myClass != _String) {
- int n = __OBJS2BYTES__(_intVal(_ClassInstPtr(_qClass(self))->c_ninstvars));
+ if ((myClass == argClass)
+ || (((myClass == _String) || (myClass == Symbol))
+ && ((argClass == _String) || (argClass == Symbol)))) {
+ cp1 = (char *) _stringVal(self);
+ l1 = _stringSize(self);
+ if (myClass != _String) {
+ int n = __OBJS2BYTES__(_intVal(_ClassInstPtr(_qClass(self))->c_ninstvars));
- cp1 += n;
- l1 -= n;
- }
+ cp1 += n;
+ l1 -= n;
+ }
- cp2 = (char *) _stringVal(s);
- l2 = _stringSize(s);
- if (argClass != _String) {
- int n = __OBJS2BYTES__(_intVal(_ClassInstPtr(_qClass(s))->c_ninstvars));
+ cp2 = (char *) _stringVal(s);
+ l2 = _stringSize(s);
+ if (argClass != _String) {
+ int n = __OBJS2BYTES__(_intVal(_ClassInstPtr(_qClass(s))->c_ninstvars));
- cp2 += n;
- l2 -= n;
- }
+ cp2 += n;
+ l2 -= n;
+ }
sz = OHDR_SIZE + l1 + l2 + 1;
- _qNew(newString, sz, __context);
- if (newString != nil) {
- _InstPtr(newString)->o_class = String;
- dstp = _stringVal(newString);
+ _qNew(newString, sz, __context);
+ if (newString != nil) {
+ _InstPtr(newString)->o_class = String;
+ dstp = _stringVal(newString);
/*
* refetch in case of a GC
*/
cp1 = (char *) _stringVal(self);
cp2 = (char *) _stringVal(s);
#ifdef FAST_MEMCPY
- bcopy(cp1, dstp, l1);
- bcopy(cp2, dstp + l1, l2+1);
+ bcopy(cp1, dstp, l1);
+ bcopy(cp2, dstp + l1, l2+1);
#else
# ifdef FAST_STRCPY
- strcpy(dstp, cp1);
- strcpy(dstp + l1, cp2);
+ strcpy(dstp, cp1);
+ strcpy(dstp + l1, cp2);
# else
- while ((*dstp++ = *cp1++) != '\0') ;
- dstp--;
- while ((*dstp++ = *cp2++) != '\0') ;
+ while ((*dstp++ = *cp1++) != '\0') ;
+ dstp--;
+ while ((*dstp++ = *cp2++) != '\0') ;
# endif
#endif
- RETURN ( newString );
- }
- }
+ RETURN ( newString );
+ }
+ }
}
%}
.
@@ -1234,36 +1244,36 @@
if ((__isString(self) || __isSymbol(self))
&& (__isString(string1) || __isSymbol(string1))
&& (__isString(string2) || __isSymbol(string2))) {
- len1 = _stringSize(self);
- len2 = _stringSize(string1);
- len3 = _stringSize(string2);
+ len1 = _stringSize(self);
+ len2 = _stringSize(string1);
+ len3 = _stringSize(string2);
sz = OHDR_SIZE + len1 + len2 + len3 + 1;
- _qNew(newString, sz, __context);
- if (newString != nil) {
- _InstPtr(newString)->o_class = String;
- dstp = _stringVal(newString);
+ _qNew(newString, sz, __context);
+ if (newString != nil) {
+ _InstPtr(newString)->o_class = String;
+ dstp = _stringVal(newString);
#ifdef FAST_MEMCPY
- bcopy(_stringVal(self), dstp, len1);
- bcopy(_stringVal(string1), dstp + len1, len2);
- bcopy(_stringVal(string2), dstp + len1 + len2, len3+1);
+ bcopy(_stringVal(self), dstp, len1);
+ bcopy(_stringVal(string1), dstp + len1, len2);
+ bcopy(_stringVal(string2), dstp + len1 + len2, len3+1);
#else
# ifdef FAST_STRCPY
- strcpy(dstp, _stringVal(self));
- strcpy(dstp + len1, _stringVal(string1));
- strcpy(dstp + len1 + len2, _stringVal(string2));
+ strcpy(dstp, _stringVal(self));
+ strcpy(dstp + len1, _stringVal(string1));
+ strcpy(dstp + len1 + len2, _stringVal(string2));
# else
- srcp = _stringVal(self);
- while ((*dstp++ = *srcp++) != '\0') ;
- dstp--;
- srcp = _stringVal(string1);
- while ((*dstp++ = *srcp++) != '\0') ;
- dstp--;
- srcp = _stringVal(string2);
- while ((*dstp++ = *srcp++) != '\0') ;
+ srcp = _stringVal(self);
+ while ((*dstp++ = *srcp++) != '\0') ;
+ dstp--;
+ srcp = _stringVal(string1);
+ while ((*dstp++ = *srcp++) != '\0') ;
+ dstp--;
+ srcp = _stringVal(string2);
+ while ((*dstp++ = *srcp++) != '\0') ;
# endif
#endif
- RETURN ( newString );
- }
+ RETURN ( newString );
+ }
}
%}
.
@@ -1288,42 +1298,42 @@
&& (__isString(string1) || __isSymbol(string1))
&& (__isString(string2) || __isSymbol(string2))
&& (__isString(string3) || __isSymbol(string3))) {
- len1 = _stringSize(self);
- len2 = _stringSize(string1);
- len3 = _stringSize(string2);
- len4 = _stringSize(string3);
+ len1 = _stringSize(self);
+ len2 = _stringSize(string1);
+ len3 = _stringSize(string2);
+ len4 = _stringSize(string3);
sz = OHDR_SIZE + len1 + len2 + len3 + len4 + 1;
- _qNew(newString, sz, __context);
- if (newString != nil) {
- _InstPtr(newString)->o_class = String;
- dstp = _stringVal(newString);
+ _qNew(newString, sz, __context);
+ if (newString != nil) {
+ _InstPtr(newString)->o_class = String;
+ dstp = _stringVal(newString);
#ifdef FAST_MEMCPY
- bcopy(_stringVal(self), dstp, len1);
- bcopy(_stringVal(string1), dstp + len1, len2);
- bcopy(_stringVal(string2), dstp + len1 + len2, len3);
- bcopy(_stringVal(string3), dstp + len1 + len2 + len3, len4+1);
+ bcopy(_stringVal(self), dstp, len1);
+ bcopy(_stringVal(string1), dstp + len1, len2);
+ bcopy(_stringVal(string2), dstp + len1 + len2, len3);
+ bcopy(_stringVal(string3), dstp + len1 + len2 + len3, len4+1);
#else
# ifdef FAST_STRCPY
- strcpy(dstp, _stringVal(self));
- strcpy(dstp + len1, _stringVal(string1));
- strcpy(dstp + len1 + len2, _stringVal(string2));
- strcpy(dstp + len1 + len2 + len3, _stringVal(string3));
+ strcpy(dstp, _stringVal(self));
+ strcpy(dstp + len1, _stringVal(string1));
+ strcpy(dstp + len1 + len2, _stringVal(string2));
+ strcpy(dstp + len1 + len2 + len3, _stringVal(string3));
# else
- srcp = _stringVal(self);
- while ((*dstp++ = *srcp++) != '\0') ;
- dstp--;
- srcp = _stringVal(string1);
- while ((*dstp++ = *srcp++) != '\0') ;
- dstp--;
- srcp = _stringVal(string2);
- while ((*dstp++ = *srcp++) != '\0') ;
- dstp--;
- srcp = _stringVal(string3);
- while ((*dstp++ = *srcp++) != '\0') ;
+ srcp = _stringVal(self);
+ while ((*dstp++ = *srcp++) != '\0') ;
+ dstp--;
+ srcp = _stringVal(string1);
+ while ((*dstp++ = *srcp++) != '\0') ;
+ dstp--;
+ srcp = _stringVal(string2);
+ while ((*dstp++ = *srcp++) != '\0') ;
+ dstp--;
+ srcp = _stringVal(string3);
+ while ((*dstp++ = *srcp++) != '\0') ;
# endif
#endif
- RETURN ( newString );
- }
+ RETURN ( newString );
+ }
}
%}
.
@@ -1342,41 +1352,41 @@
OBJ cls, newString;
if (__isCharacter(aCharacter)) {
- sz = _qSize(self) + 1;
- if ((cls = _qClass(self)) != String) {
- offs = __OBJS2BYTES__(_intVal(_ClassInstPtr(cls)->c_ninstvars));
- sz -= offs;
- } else
- offs = 0;
+ sz = _qSize(self) + 1;
+ if ((cls = _qClass(self)) != String) {
+ offs = __OBJS2BYTES__(_intVal(_ClassInstPtr(cls)->c_ninstvars));
+ sz -= offs;
+ } else
+ offs = 0;
- PROTECT_CONTEXT
- _qNew(newString, sz, SENDER);
- UNPROTECT_CONTEXT
- if (newString) {
- _InstPtr(newString)->o_class = String;
- dstp = _stringVal(newString);
+ PROTECT_CONTEXT
+ _qNew(newString, sz, SENDER);
+ UNPROTECT_CONTEXT
+ if (newString) {
+ _InstPtr(newString)->o_class = String;
+ dstp = _stringVal(newString);
#ifdef FAST_MEMCPY
- sz = sz - OHDR_SIZE - 1 - 1;
- bcopy(_stringVal(self) + offs, dstp, sz);
- dstp += sz;
+ sz = sz - OHDR_SIZE - 1 - 1;
+ bcopy(_stringVal(self) + offs, dstp, sz);
+ dstp += sz;
#else
# ifdef FAST_STRCPY
- strcpy(dstp, _stringVal(self) + offs);
- dstp += sz - OHDR_SIZE - 1 - 1;
+ strcpy(dstp, _stringVal(self) + offs);
+ dstp += sz - OHDR_SIZE - 1 - 1;
# else
- {
- REGISTER unsigned char *srcp;
+ {
+ REGISTER unsigned char *srcp;
- srcp = _stringVal(self) + offs;
- while ((*dstp = *srcp++) != '\0')
- dstp++;
- }
+ srcp = _stringVal(self) + offs;
+ while ((*dstp = *srcp++) != '\0')
+ dstp++;
+ }
# endif
#endif
- *dstp++ = _intVal(_characterVal(aCharacter));
- *dstp = '\0';
- RETURN (newString );
- }
+ *dstp++ = _intVal(_characterVal(aCharacter));
+ *dstp = '\0';
+ RETURN (newString );
+ }
}
%}.
"fall back in case of non-character arg;
@@ -1402,40 +1412,40 @@
OBJ newString;
if (_isSmallInteger(start) && _isSmallInteger(stop)) {
- len = _stringSize(self);
- index1 = _intVal(start);
- index2 = _intVal(stop);
+ len = _stringSize(self);
+ index1 = _intVal(start);
+ index2 = _intVal(stop);
- if ((index1 <= index2) && (index1 > 0)) {
- if (_qClass(self) != String) {
- int n = __OBJS2BYTES__(_intVal(_ClassInstPtr(_qClass(self))->c_ninstvars));
+ if ((index1 <= index2) && (index1 > 0)) {
+ if (_qClass(self) != String) {
+ int n = __OBJS2BYTES__(_intVal(_ClassInstPtr(_qClass(self))->c_ninstvars));
- index1 += n;
- index2 += n;
- }
- if (index2 <= len) {
- count = index2 - index1 + 1;
- PROTECT_CONTEXT
+ index1 += n;
+ index2 += n;
+ }
+ if (index2 <= len) {
+ count = index2 - index1 + 1;
+ PROTECT_CONTEXT
sz = OHDR_SIZE + count + 1;
- _qNew(newString, sz, SENDER);
- UNPROTECT_CONTEXT
- if (newString != nil) {
- _InstPtr(newString)->o_class = String;
- dstp = _stringVal(newString);
+ _qNew(newString, sz, SENDER);
+ UNPROTECT_CONTEXT
+ if (newString != nil) {
+ _InstPtr(newString)->o_class = String;
+ dstp = _stringVal(newString);
#ifdef FAST_MEMCPY
- bcopy(_stringVal(self) + index1 - 1, dstp, count);
- dstp[count] = '\0';
+ bcopy(_stringVal(self) + index1 - 1, dstp, count);
+ dstp[count] = '\0';
#else
- srcp = _stringVal(self) + index1 - 1;
- while (count--) {
- *dstp++ = *srcp++;
- }
- *dstp = '\0';
+ srcp = _stringVal(self) + index1 - 1;
+ while (count--) {
+ *dstp++ = *srcp++;
+ }
+ *dstp = '\0';
#endif
- RETURN ( newString );
- }
- }
- }
+ RETURN ( newString );
+ }
+ }
+ }
}
%}.
"fall back in case of non-integer index or out-of-bound index;
@@ -1461,37 +1471,37 @@
OBJ newString;
if (_isSmallInteger(start)) {
- len = _stringSize(self);
- index1 = _intVal(start);
- if (index1 > 0) {
- if (_qClass(self) != String) {
- int n = __OBJS2BYTES__(_intVal(_ClassInstPtr(_qClass(self))->c_ninstvars));
+ len = _stringSize(self);
+ index1 = _intVal(start);
+ if (index1 > 0) {
+ if (_qClass(self) != String) {
+ int n = __OBJS2BYTES__(_intVal(_ClassInstPtr(_qClass(self))->c_ninstvars));
- index1 += n;
- }
- if (index1 <= len) {
- count = len - index1 + 1;
- PROTECT_CONTEXT
+ index1 += n;
+ }
+ if (index1 <= len) {
+ count = len - index1 + 1;
+ PROTECT_CONTEXT
sz = OHDR_SIZE + count + 1;
- _qNew(newString, sz, SENDER);
- UNPROTECT_CONTEXT
- if (newString != nil) {
- _InstPtr(newString)->o_class = String;
- dstp = _stringVal(newString);
+ _qNew(newString, sz, SENDER);
+ UNPROTECT_CONTEXT
+ if (newString != nil) {
+ _InstPtr(newString)->o_class = String;
+ dstp = _stringVal(newString);
#ifdef FAST_MEMCPY
- bcopy(_stringVal(self) + index1 - 1, dstp, count);
- dstp[count] = '\0';
+ bcopy(_stringVal(self) + index1 - 1, dstp, count);
+ dstp[count] = '\0';
#else
- srcp = _stringVal(self) + index1 - 1;
- while (count--) {
- *dstp++ = *srcp++;
- }
- *dstp = '\0';
+ srcp = _stringVal(self) + index1 - 1;
+ while (count--) {
+ *dstp++ = *srcp++;
+ }
+ *dstp = '\0';
#endif
- RETURN ( newString );
- }
- }
- }
+ RETURN ( newString );
+ }
+ }
+ }
}
%}.
"fall back in case of non-integer index or out-of-bound index;
@@ -1519,41 +1529,41 @@
&& __isString(self)
&& _isSmallInteger(start)
&& _isSmallInteger(stop)) {
- len = _stringSize(self);
- index1 = _intVal(start);
- index2 = _intVal(stop);
- count = index2 - index1 + 1;
- if (count <= 0) {
- RETURN (self);
- }
- if ((index2 <= len) && (index1 > 0)) {
- repLen = _stringSize(aString);
- repIndex = _intVal(repStart);
- if ((repIndex > 0) && ((repIndex + count - 1) <= repLen)) {
- srcp = _stringVal(aString) + repIndex - 1;
- dstp = _stringVal(self) + index1 - 1;
- if (aString == self) {
- /* take care of overlapping copy */
- if (srcp < dstp) {
- /* must do a reverse copy */
- srcp += count;
- dstp += count;
- while (count-- > 0) {
- *--dstp = *--srcp;
- }
- RETURN (self);
- }
- }
+ len = _stringSize(self);
+ index1 = _intVal(start);
+ index2 = _intVal(stop);
+ count = index2 - index1 + 1;
+ if (count <= 0) {
+ RETURN (self);
+ }
+ if ((index2 <= len) && (index1 > 0)) {
+ repLen = _stringSize(aString);
+ repIndex = _intVal(repStart);
+ if ((repIndex > 0) && ((repIndex + count - 1) <= repLen)) {
+ srcp = _stringVal(aString) + repIndex - 1;
+ dstp = _stringVal(self) + index1 - 1;
+ if (aString == self) {
+ /* take care of overlapping copy */
+ if (srcp < dstp) {
+ /* must do a reverse copy */
+ srcp += count;
+ dstp += count;
+ while (count-- > 0) {
+ *--dstp = *--srcp;
+ }
+ RETURN (self);
+ }
+ }
#ifdef FAST_MEMCPY
- bcopy(srcp, dstp, count);
+ bcopy(srcp, dstp, count);
#else
- while (count-- > 0) {
- *dstp++ = *srcp++;
- }
+ while (count-- > 0) {
+ *dstp++ = *srcp++;
+ }
#endif
- RETURN (self);
- }
- }
+ RETURN (self);
+ }
+ }
}
%}
.
@@ -1571,15 +1581,15 @@
if (__isCharacter(oldCharacter)
&& __isCharacter(newCharacter)
&& __isString(self)) {
- srcp = (unsigned char *)_stringVal(self);
- oldVal = _intVal(_characterVal(oldCharacter));
- newVal = _intVal(_characterVal(newCharacter));
- while (*srcp) {
- if (*srcp == oldVal)
- *srcp = newVal;
- srcp++;
- }
- RETURN ( self );
+ srcp = (unsigned char *)_stringVal(self);
+ oldVal = _intVal(_characterVal(oldCharacter));
+ newVal = _intVal(_characterVal(newCharacter));
+ while (*srcp) {
+ if (*srcp == oldVal)
+ *srcp = newVal;
+ srcp++;
+ }
+ RETURN ( self );
}
%}
.
@@ -1597,16 +1607,16 @@
REGISTER unsigned char *hip, *lowp;
if (__isString(self)) {
- lowp = _stringVal(self);
- hip = lowp + _stringSize(self) - 1;
- while (lowp < hip) {
- c = *lowp;
- *lowp = *hip;
- *hip = c;
- lowp++;
- hip--;
- }
- RETURN ( self );
+ lowp = _stringVal(self);
+ hip = lowp + _stringSize(self) - 1;
+ while (lowp < hip) {
+ c = *lowp;
+ *lowp = *hip;
+ *hip = c;
+ lowp++;
+ hip--;
+ }
+ RETURN ( self );
}
%}
.
@@ -1627,23 +1637,23 @@
len = _qSize(self);
if (_qClass(self) != String) {
- offs = __OBJS2BYTES__(_intVal(_ClassInstPtr(_qClass(self))->c_ninstvars));
- len -= offs;
+ offs = __OBJS2BYTES__(_intVal(_ClassInstPtr(_qClass(self))->c_ninstvars));
+ len -= offs;
} else
- offs = 0;
+ offs = 0;
_qNew(newString, len, __context);
if (newString != nil) {
- _InstPtr(newString)->o_class = String;
- srcp = _stringVal(self) + offs;
- dstp = _stringVal(newString);
- while (c = *srcp++)
- if (c == '\\')
- *dstp++ = '\n';
- else
- *dstp++ = c;
- *dstp++ = '\0';
- RETURN ( newString );
+ _InstPtr(newString)->o_class = String;
+ srcp = _stringVal(self) + offs;
+ dstp = _stringVal(newString);
+ while (c = *srcp++)
+ if (c == '\\')
+ *dstp++ = '\n';
+ else
+ *dstp++ = c;
+ *dstp++ = '\0';
+ RETURN ( newString );
}
%}
.
@@ -1663,22 +1673,22 @@
#endif
if (__isCharacter(aCharacter) && __isString(self)) {
- byteValue = _intVal(_characterVal(aCharacter));
+ byteValue = _intVal(_characterVal(aCharacter));
#ifdef FAST_MEMSET
- memset(_stringVal(self), byteValue, _qSize(self) - OHDR_SIZE - 1);
+ memset(_stringVal(self), byteValue, _qSize(self) - OHDR_SIZE - 1);
#else
- dst = _stringVal(self);
+ dst = _stringVal(self);
l = _qSize(self) - OHDR_SIZE - 1;
while (l >= 8) {
- dst[0] = dst[1] = dst[2] = dst[3] = byteValue;
- dst[4] = dst[5] = dst[6] = dst[7] = byteValue;
+ dst[0] = dst[1] = dst[2] = dst[3] = byteValue;
+ dst[4] = dst[5] = dst[6] = dst[7] = byteValue;
dst += 8;
l -= 8;
}
- while (l--)
- *dst++ = byteValue;
+ while (l--)
+ *dst++ = byteValue;
#endif
- RETURN ( self );
+ RETURN ( self );
}
%}
.
@@ -1705,32 +1715,32 @@
/* ignore instances of subclasses ... */
if (_qClass(self) == String) {
- cp = cp0 = _stringVal(self);
- while (*cp == ' ') cp++;
- startIndex = _MKSMALLINT(cp - cp0 + 1);
- cp = cp + strlen(cp) - 1;
- while ((cp >= cp0) && (*cp == ' ')) cp--;
- endIndex = _MKSMALLINT(cp - cp0 + 1);
+ cp = cp0 = _stringVal(self);
+ while (*cp == ' ') cp++;
+ startIndex = _MKSMALLINT(cp - cp0 + 1);
+ cp = cp + strlen(cp) - 1;
+ while ((cp >= cp0) && (*cp == ' ')) cp--;
+ endIndex = _MKSMALLINT(cp - cp0 + 1);
}
%}
.
sz := self size.
startIndex == 0 ifTrue:[
- startIndex := 1.
- endIndex := sz.
- blank := Character space.
- [(startIndex < endIndex) and:[(self at:startIndex) == blank]] whileTrue:[
- startIndex := startIndex + 1
- ].
- [(endIndex > 1) and:[(self at:endIndex) == blank]] whileTrue:[
- endIndex := endIndex - 1
- ]
+ startIndex := 1.
+ endIndex := sz.
+ blank := Character space.
+ [(startIndex < endIndex) and:[(self at:startIndex) == blank]] whileTrue:[
+ startIndex := startIndex + 1
+ ].
+ [(endIndex > 1) and:[(self at:endIndex) == blank]] whileTrue:[
+ endIndex := endIndex - 1
+ ]
].
startIndex > endIndex ifTrue:[
- ^ ''
+ ^ ''
].
((startIndex == 1) and:[endIndex == sz]) ifTrue:[
- ^ self
+ ^ self
].
^ self copyFrom:startIndex to:endIndex
!
@@ -1751,43 +1761,43 @@
/* ignore instances of subclasses ... */
if (_qClass(self) == String) {
- cp = cp0 = _stringVal(self);
- c = *cp;
- while ((c == ' ') || (c == '\n') || (c == '\t')
- || (c == '\r') || (c == '\f')) {
- cp++;
- c = *cp;
- }
- startIndex = _MKSMALLINT(cp - cp0 + 1);
- cp = cp + strlen(cp) - 1;
- while ((cp >= cp0) && (*cp == ' ')) cp--;
- c = *cp;
- while ((cp >= cp0) &&
- ((c == ' ') || (c == '\n') || (c == '\t')
- || (c == '\r') || (c == '\f'))) {
- cp--;
- c = *cp;
- }
- endIndex = _MKSMALLINT(cp - cp0 + 1);
+ cp = cp0 = _stringVal(self);
+ c = *cp;
+ while ((c == ' ') || (c == '\n') || (c == '\t')
+ || (c == '\r') || (c == '\f')) {
+ cp++;
+ c = *cp;
+ }
+ startIndex = _MKSMALLINT(cp - cp0 + 1);
+ cp = cp + strlen(cp) - 1;
+ while ((cp >= cp0) && (*cp == ' ')) cp--;
+ c = *cp;
+ while ((cp >= cp0) &&
+ ((c == ' ') || (c == '\n') || (c == '\t')
+ || (c == '\r') || (c == '\f'))) {
+ cp--;
+ c = *cp;
+ }
+ endIndex = _MKSMALLINT(cp - cp0 + 1);
}
%}
.
sz := self size.
startIndex == 0 ifTrue:[
- startIndex := 1.
- endIndex := self size.
- [(startIndex < endIndex) and:[(self at:startIndex) isSeparator]] whileTrue:[
- startIndex := startIndex + 1
- ].
- [(endIndex > 1) and:[(self at:endIndex) isSeparator]] whileTrue:[
- endIndex := endIndex - 1
- ].
+ startIndex := 1.
+ endIndex := self size.
+ [(startIndex < endIndex) and:[(self at:startIndex) isSeparator]] whileTrue:[
+ startIndex := startIndex + 1
+ ].
+ [(endIndex > 1) and:[(self at:endIndex) isSeparator]] whileTrue:[
+ endIndex := endIndex - 1
+ ].
].
startIndex > endIndex ifTrue:[
- ^ ''
+ ^ ''
].
((startIndex == 1) and:[endIndex == sz]) ifTrue:[
- ^ self
+ ^ self
].
^ self copyFrom:startIndex to:endIndex
! !
@@ -1820,7 +1830,7 @@
cls = _qClass(self);
if ((cls == String) || (cls == Symbol)) {
- RETURN ( (_stringSize(self) == 0) ? true : false);
+ RETURN ( (_stringSize(self) == 0) ? true : false);
}
%}
.
--- a/Symbol.st Mon Oct 10 01:29:01 1994 +0100
+++ b/Symbol.st Mon Oct 10 01:29:28 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1988 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -19,9 +19,9 @@
Symbol comment:'
COPYRIGHT (c) 1988 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Symbol.st,v 1.11 1994-08-05 01:02:49 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Symbol.st,v 1.12 1994-10-10 00:28:50 claus Exp $
'!
!Symbol class methodsFor:'documentation'!
@@ -29,7 +29,7 @@
copyright
"
COPYRIGHT (c) 1988 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Symbol.st,v 1.11 1994-08-05 01:02:49 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Symbol.st,v 1.12 1994-10-10 00:28:50 claus Exp $
"
!
@@ -79,10 +79,10 @@
%{ /* NOCONTEXT */
if (__isSymbol(aString)) {
- RETURN (aString);
+ RETURN (aString);
}
if (__isString(aString)) {
- RETURN ( _MKSYMBOL(_stringVal(aString), (OBJ *)0, __context) );
+ RETURN ( _MKSYMBOL(_stringVal(aString), (OBJ *)0, __context) );
}
%}
.
@@ -100,7 +100,7 @@
|newSym len|
aString knownAsSymbol ifTrue:[
- ^ aString asSymbol
+ ^ aString asSymbol
].
"
@@ -133,8 +133,8 @@
as argument and return true; otherwise return false"
aString knownAsSymbol ifTrue:[
- trueBlock value:(aString asSymbol).
- ^ true
+ trueBlock value:(aString asSymbol).
+ ^ true
].
^ false
!
@@ -152,8 +152,8 @@
"report an error if interned - interned symbols may not be changed."
self knownAsSymbol ifTrue:[
- self error:'symbols may not be changed'.
- ^ something
+ self error:'symbols may not be changed'.
+ ^ something
].
"
uninterned - allow change
@@ -163,7 +163,14 @@
!Symbol methodsFor:'copying'!
-deepCopyUsing:aDictionary
+copy
+ "return a copy of myself
+ - reimplemented here since symbols are unique"
+
+ ^ self
+!
+
+shallowCopy
"return a copy of myself
- reimplemented here since symbols are unique"
@@ -177,6 +184,13 @@
^ self
!
+deepCopyUsing:aDictionary
+ "return a copy of myself
+ - reimplemented here since symbols are unique"
+
+ ^ self
+!
+
simpleDeepCopy
"return a copy of myself
- reimplemented here since symbols are unique"
@@ -214,15 +228,15 @@
expected.
Notice: because of the danger here, this method may report an error
- in future versions"
+ in future versions"
(Smalltalk includesKey:self) ifTrue:[
- super become:anotherObject.
+ super become:anotherObject.
%{
- __rehashSystemDictionaries();
+ __rehashSystemDictionaries();
%}.
] ifFalse:[
- super become:anotherObject
+ super become:anotherObject
]
!
@@ -233,12 +247,12 @@
This can be a very dangerous operation - be warned.
Notice: because of the danger here, this method may report an error
- in future versions"
+ in future versions"
(Smalltalk includesKey:self) ifTrue:[
- self primitiveFailed
+ self primitiveFailed
] ifFalse:[
- super becomeNil
+ super becomeNil
]
! !
@@ -271,12 +285,12 @@
"return a String for storing the receiver"
(self at:1) isLetter ifTrue:[
- 2 to:self size do:[:index |
- (self at:index) isAlphaNumeric ifFalse:[
- ^ '#''' , self , ''''
- ].
- ].
- ^ '#' , self
+ 2 to:self size do:[:index |
+ (self at:index) isLetterOrDigit ifFalse:[
+ ^ '#''' , self , ''''
+ ].
+ ].
+ ^ '#' , self
].
^ '#''' , self , ''''
!
--- a/Time.st Mon Oct 10 01:29:01 1994 +0100
+++ b/Time.st Mon Oct 10 01:29:28 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -19,9 +19,9 @@
Time comment:'
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Time.st,v 1.10 1994-08-05 01:02:52 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Time.st,v 1.11 1994-10-10 00:28:55 claus Exp $
'!
!Time class methodsFor:'documentation'!
@@ -29,7 +29,7 @@
copyright
"
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Time.st,v 1.10 1994-08-05 01:02:52 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Time.st,v 1.11 1994-10-10 00:28:55 claus Exp $
"
!
@@ -58,7 +58,7 @@
"return an instance of Time representing this moment"
^ self basicNew setSecondsLow:(OperatingSystem getTimeLow)
- and:(OperatingSystem getTimeHi)
+ and:(OperatingSystem getTimeHi)
"
Time now
@@ -96,11 +96,11 @@
"return the number of seconds elapsed since midnight"
OperatingSystem computeTimePartsOf:secondsLow and:secondsHi for:[
- :hours :minutes :seconds |
+ :hours :minutes :seconds |
- ^ ( 3600 * hours )
- + ( 60 * minutes )
- + seconds
+ ^ ( 3600 * hours )
+ + ( 60 * minutes )
+ + seconds
]
"
@@ -143,11 +143,11 @@
> aTime
"return true if the argument, aTime is after the receiver"
- (aTime isMemberOf:Time) ifTrue:[
- (secondsHi > aTime secondsHi) ifTrue:[^ true].
- (secondsHi < aTime secondsHi) ifTrue:[^ false].
- (secondsLow > aTime secondsLow) ifTrue:[^ true].
- ^ false
+ (aTime respondsTo:#secondsLow) ifTrue:[
+ (secondsHi > aTime secondsHi) ifTrue:[^ true].
+ (secondsHi < aTime secondsHi) ifTrue:[^ false].
+ (secondsLow > aTime secondsLow) ifTrue:[^ true].
+ ^ false
].
^ self getSeconds > aTime getSeconds
!
@@ -155,22 +155,13 @@
< aTime
"return true if the argument, aTime is before the receiver"
- (aTime isMemberOf:Time) ifTrue:[
- (secondsHi < aTime secondsHi) ifTrue:[^ true].
- (secondsHi > aTime secondsHi) ifTrue:[^ false].
- (secondsLow < aTime secondsLow) ifTrue:[^ true].
- ^ false
+ (aTime respondsTo:#secondsLow) ifTrue:[
+ (secondsHi < aTime secondsHi) ifTrue:[^ true].
+ (secondsHi > aTime secondsHi) ifTrue:[^ false].
+ (secondsLow < aTime secondsLow) ifTrue:[^ true].
+ ^ false
].
^ self getSeconds < aTime getSeconds
-!
-
-= aTime
- "return true if aTime represents the same time as the receiver"
-
- (aTime isMemberOf:Time) ifTrue:[
- ^ ((secondsLow == aTime secondsLow) and:[secondsHi == aTime secondsHi])
- ].
- ^ self getSeconds = aTime getSeconds
! !
!Time methodsFor:'printing & storing'!
@@ -197,15 +188,15 @@
Format is hh:mm:ss in 24-hour format."
OperatingSystem computeTimePartsOf:secondsLow and:secondsHi for:[
- :hours :minutes :secs |
+ :hours :minutes :secs |
- hours printOn:aStream.
- aStream nextPut:$:.
- (minutes < 10) ifTrue:[aStream nextPut:$0].
- minutes printOn:aStream.
- aStream nextPut:$:.
- (secs < 10) ifTrue:[aStream nextPut:$0].
- secs printOn:aStream
+ hours printOn:aStream.
+ aStream nextPut:$:.
+ (minutes < 10) ifTrue:[aStream nextPut:$0].
+ minutes printOn:aStream.
+ aStream nextPut:$:.
+ (secs < 10) ifTrue:[aStream nextPut:$0].
+ secs printOn:aStream
]
"
@@ -218,7 +209,7 @@
Format is hh:mm:ss am/pm (i.e. 12-hour format)."
OperatingSystem computeTimePartsOf:secondsLow and:secondsHi for:[
- :hours :minutes :secs | |h|
+ :hours :minutes :secs | |h|
h := hours.
h > 12 ifTrue:[
@@ -227,14 +218,14 @@
h < 1 ifTrue:[
h := 12
]
- ].
- h printOn:aStream.
- aStream nextPut:$:.
- (minutes < 10) ifTrue:[aStream nextPut:$0].
- minutes printOn:aStream.
- aStream nextPut:$:.
- (secs < 10) ifTrue:[aStream nextPut:$0].
- secs printOn:aStream.
+ ].
+ h printOn:aStream.
+ aStream nextPut:$:.
+ (minutes < 10) ifTrue:[aStream nextPut:$0].
+ minutes printOn:aStream.
+ aStream nextPut:$:.
+ (secs < 10) ifTrue:[aStream nextPut:$0].
+ secs printOn:aStream.
hours >= 12 ifTrue:[
aStream nextPutAll:' pm'
] ifFalse:[
--- a/UndefObj.st Mon Oct 10 01:29:01 1994 +0100
+++ b/UndefObj.st Mon Oct 10 01:29:28 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1988 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -19,9 +19,9 @@
UndefinedObject comment:'
COPYRIGHT (c) 1988 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Attic/UndefObj.st,v 1.11 1994-08-05 01:02:56 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/UndefObj.st,v 1.12 1994-10-10 00:29:03 claus Exp $
'!
!UndefinedObject class methodsFor:'documentation'!
@@ -29,7 +29,7 @@
copyright
"
COPYRIGHT (c) 1988 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Attic/UndefObj.st,v 1.11 1994-08-05 01:02:56 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/UndefObj.st,v 1.12 1994-10-10 00:29:03 claus Exp $
"
!
@@ -149,6 +149,13 @@
!UndefinedObject methodsFor:'copying'!
+copy
+ "return a shallow copy of myself
+ - since there is only one nil in the system return self"
+
+ ^ self
+!
+
shallowCopy
"return a shallow copy of myself
- since there is only one nil in the system return self"
@@ -156,6 +163,13 @@
^ self
!
+deepCopy
+ "return a deep copy of myself
+ - since there is only one nil in the system return self"
+
+ ^ self
+!
+
simpleDeepCopy
"return a deep copy of myself
- since there is only one nil in the system return self"
@@ -168,13 +182,6 @@
- since there is only one nil in the system return self"
^ self
-!
-
-deepCopy
- "return a deep copy of myself
- - since there is only one nil in the system return self"
-
- ^ self
! !
!UndefinedObject methodsFor:'printing & storing'!
@@ -218,70 +225,73 @@
!UndefinedObject methodsFor:'subclass creation'!
subclass:t instanceVariableNames:f classVariableNames:d poolDictionaries:s category:cat
- "create a new class which has nil as superclass - i.e. traps into doesNotUnderstand: for
- all of its messages."
+ "create a new class which has nil as superclass
+ - i.e. traps into doesNotUnderstand: for all of its messages."
|newClass upd|
upd := Class updateChanges:false.
[
- newClass := Object subclass:t instanceVariableNames:f classVariableNames:d poolDictionaries:s category:cat.
+ newClass := Object subclass:t instanceVariableNames:f classVariableNames:d poolDictionaries:s category:cat.
] valueNowOrOnUnwindDo:[
- Class updateChanges:upd
+ Class updateChanges:upd
].
newClass notNil ifTrue:[
- newClass setSuperclass:nil.
- newClass setMethodArray:(Array with:(Object compiledMethodAt:#class)
- with:(Object compiledMethodAt:#doesNotUnderstand:)).
- newClass setSelectorArray:(Array with:#class
- with:#doesNotUnderstand:).
- Class addChangeRecordForClass:newClass.
+ newClass setSuperclass:nil.
+ newClass
+ setSelectors:(Array with:#class
+ with:#doesNotUnderstand:)
+ methods:(Array with:(Object compiledMethodAt:#class)
+ with:(Object compiledMethodAt:#doesNotUnderstand:)).
+ Class addChangeRecordForClass:newClass.
].
^ newClass
!
variableSubclass:t instanceVariableNames:f classVariableNames:d poolDictionaries:s category:cat
- "create a new class which has nil as superclass - i.e. traps into doesNotUnderstand: for
- all of its messages."
+ "create a new class which has nil as superclass
+ - i.e. traps into doesNotUnderstand: for all of its messages."
|newClass upd|
upd := Class updateChanges:false.
[
- newClass := Object variableSubclass:t instanceVariableNames:f classVariableNames:d poolDictionaries:s category:cat.
+ newClass := Object variableSubclass:t instanceVariableNames:f classVariableNames:d poolDictionaries:s category:cat.
] valueNowOrOnUnwindDo:[
- Class updateChanges:upd
+ Class updateChanges:upd
].
newClass notNil ifTrue:[
- newClass setSuperclass:nil.
- newClass setMethodArray:(Array with:(Object compiledMethodAt:#class)
- with:(Object compiledMethodAt:#doesNotUnderstand:)).
- newClass setSelectorArray:(Array with:#class
- with:#doesNotUnderstand:).
- Class addChangeRecordForClass:newClass.
+ newClass setSuperclass:nil.
+ newClass
+ setSelectors:(Array with:#class
+ with:#doesNotUnderstand:)
+ methods:(Array with:(Object compiledMethodAt:#class)
+ with:(Object compiledMethodAt:#doesNotUnderstand:)).
+ Class addChangeRecordForClass:newClass.
].
^ newClass
!
variableByteSubclass:t instanceVariableNames:f classVariableNames:d poolDictionaries:s category:cat
- "create a new class which has nil as superclass - i.e. traps into doesNotUnderstand: for
- all of its messages."
+ "create a new class which has nil as superclass
+ - i.e. traps into doesNotUnderstand: for all of its messages."
|newClass upd|
upd := Class updateChanges:false.
[
- newClass := Object variableByteSubclass:t instanceVariableNames:f classVariableNames:d poolDictionaries:s category:cat.
+ newClass := Object variableByteSubclass:t instanceVariableNames:f classVariableNames:d poolDictionaries:s category:cat.
] valueNowOrOnUnwindDo:[
- Class updateChanges:upd
+ Class updateChanges:upd
].
newClass notNil ifTrue:[
- newClass setSuperclass:nil.
- newClass setMethodArray:(Array with:(Object compiledMethodAt:#class)
- with:(Object compiledMethodAt:#doesNotUnderstand:)).
- newClass setSelectorArray:(Array with:#class
- with:#doesNotUnderstand:).
- Class addChangeRecordForClass:newClass.
+ newClass setSuperclass:nil.
+ newClass
+ setSelectors:(Array with:#class
+ with:#doesNotUnderstand:)
+ methods:(Array with:(Object compiledMethodAt:#class)
+ with:(Object compiledMethodAt:#doesNotUnderstand:)).
+ Class addChangeRecordForClass:newClass.
].
^ newClass
! !
--- a/UndefinedObject.st Mon Oct 10 01:29:01 1994 +0100
+++ b/UndefinedObject.st Mon Oct 10 01:29:28 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1988 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -19,9 +19,9 @@
UndefinedObject comment:'
COPYRIGHT (c) 1988 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/UndefinedObject.st,v 1.11 1994-08-05 01:02:56 claus Exp $
+$Header: /cvs/stx/stx/libbasic/UndefinedObject.st,v 1.12 1994-10-10 00:29:03 claus Exp $
'!
!UndefinedObject class methodsFor:'documentation'!
@@ -29,7 +29,7 @@
copyright
"
COPYRIGHT (c) 1988 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/UndefinedObject.st,v 1.11 1994-08-05 01:02:56 claus Exp $
+$Header: /cvs/stx/stx/libbasic/UndefinedObject.st,v 1.12 1994-10-10 00:29:03 claus Exp $
"
!
@@ -149,6 +149,13 @@
!UndefinedObject methodsFor:'copying'!
+copy
+ "return a shallow copy of myself
+ - since there is only one nil in the system return self"
+
+ ^ self
+!
+
shallowCopy
"return a shallow copy of myself
- since there is only one nil in the system return self"
@@ -156,6 +163,13 @@
^ self
!
+deepCopy
+ "return a deep copy of myself
+ - since there is only one nil in the system return self"
+
+ ^ self
+!
+
simpleDeepCopy
"return a deep copy of myself
- since there is only one nil in the system return self"
@@ -168,13 +182,6 @@
- since there is only one nil in the system return self"
^ self
-!
-
-deepCopy
- "return a deep copy of myself
- - since there is only one nil in the system return self"
-
- ^ self
! !
!UndefinedObject methodsFor:'printing & storing'!
@@ -218,70 +225,73 @@
!UndefinedObject methodsFor:'subclass creation'!
subclass:t instanceVariableNames:f classVariableNames:d poolDictionaries:s category:cat
- "create a new class which has nil as superclass - i.e. traps into doesNotUnderstand: for
- all of its messages."
+ "create a new class which has nil as superclass
+ - i.e. traps into doesNotUnderstand: for all of its messages."
|newClass upd|
upd := Class updateChanges:false.
[
- newClass := Object subclass:t instanceVariableNames:f classVariableNames:d poolDictionaries:s category:cat.
+ newClass := Object subclass:t instanceVariableNames:f classVariableNames:d poolDictionaries:s category:cat.
] valueNowOrOnUnwindDo:[
- Class updateChanges:upd
+ Class updateChanges:upd
].
newClass notNil ifTrue:[
- newClass setSuperclass:nil.
- newClass setMethodArray:(Array with:(Object compiledMethodAt:#class)
- with:(Object compiledMethodAt:#doesNotUnderstand:)).
- newClass setSelectorArray:(Array with:#class
- with:#doesNotUnderstand:).
- Class addChangeRecordForClass:newClass.
+ newClass setSuperclass:nil.
+ newClass
+ setSelectors:(Array with:#class
+ with:#doesNotUnderstand:)
+ methods:(Array with:(Object compiledMethodAt:#class)
+ with:(Object compiledMethodAt:#doesNotUnderstand:)).
+ Class addChangeRecordForClass:newClass.
].
^ newClass
!
variableSubclass:t instanceVariableNames:f classVariableNames:d poolDictionaries:s category:cat
- "create a new class which has nil as superclass - i.e. traps into doesNotUnderstand: for
- all of its messages."
+ "create a new class which has nil as superclass
+ - i.e. traps into doesNotUnderstand: for all of its messages."
|newClass upd|
upd := Class updateChanges:false.
[
- newClass := Object variableSubclass:t instanceVariableNames:f classVariableNames:d poolDictionaries:s category:cat.
+ newClass := Object variableSubclass:t instanceVariableNames:f classVariableNames:d poolDictionaries:s category:cat.
] valueNowOrOnUnwindDo:[
- Class updateChanges:upd
+ Class updateChanges:upd
].
newClass notNil ifTrue:[
- newClass setSuperclass:nil.
- newClass setMethodArray:(Array with:(Object compiledMethodAt:#class)
- with:(Object compiledMethodAt:#doesNotUnderstand:)).
- newClass setSelectorArray:(Array with:#class
- with:#doesNotUnderstand:).
- Class addChangeRecordForClass:newClass.
+ newClass setSuperclass:nil.
+ newClass
+ setSelectors:(Array with:#class
+ with:#doesNotUnderstand:)
+ methods:(Array with:(Object compiledMethodAt:#class)
+ with:(Object compiledMethodAt:#doesNotUnderstand:)).
+ Class addChangeRecordForClass:newClass.
].
^ newClass
!
variableByteSubclass:t instanceVariableNames:f classVariableNames:d poolDictionaries:s category:cat
- "create a new class which has nil as superclass - i.e. traps into doesNotUnderstand: for
- all of its messages."
+ "create a new class which has nil as superclass
+ - i.e. traps into doesNotUnderstand: for all of its messages."
|newClass upd|
upd := Class updateChanges:false.
[
- newClass := Object variableByteSubclass:t instanceVariableNames:f classVariableNames:d poolDictionaries:s category:cat.
+ newClass := Object variableByteSubclass:t instanceVariableNames:f classVariableNames:d poolDictionaries:s category:cat.
] valueNowOrOnUnwindDo:[
- Class updateChanges:upd
+ Class updateChanges:upd
].
newClass notNil ifTrue:[
- newClass setSuperclass:nil.
- newClass setMethodArray:(Array with:(Object compiledMethodAt:#class)
- with:(Object compiledMethodAt:#doesNotUnderstand:)).
- newClass setSelectorArray:(Array with:#class
- with:#doesNotUnderstand:).
- Class addChangeRecordForClass:newClass.
+ newClass setSuperclass:nil.
+ newClass
+ setSelectors:(Array with:#class
+ with:#doesNotUnderstand:)
+ methods:(Array with:(Object compiledMethodAt:#class)
+ with:(Object compiledMethodAt:#doesNotUnderstand:)).
+ Class addChangeRecordForClass:newClass.
].
^ newClass
! !
--- a/WeakArr.st Mon Oct 10 01:29:01 1994 +0100
+++ b/WeakArr.st Mon Oct 10 01:29:28 1994 +0100
@@ -12,16 +12,16 @@
Array variableSubclass:#WeakArray
instanceVariableNames:'watcher dependents'
- classVariableNames:''
+ classVariableNames:'RegistrationFailedSignal'
poolDictionaries:''
- category:'System-Support'
+ category:'Collections-Arrayed'
!
WeakArray comment:'
COPYRIGHT (c) 1991 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Attic/WeakArr.st,v 1.5 1994-08-05 01:03:04 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/WeakArr.st,v 1.6 1994-10-10 00:29:09 claus Exp $
'!
!WeakArray class methodsFor:'documentation'!
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Attic/WeakArr.st,v 1.5 1994-08-05 01:03:04 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/WeakArr.st,v 1.6 1994-10-10 00:29:09 claus Exp $
"
!
@@ -75,29 +75,50 @@
"
! !
+!WeakArray class methodsFor:'initialization'!
+
+initialize
+ "setup the private signal"
+
+ RegistrationFailedSignal isNil ifTrue:[
+ Object initialize.
+
+ RegistrationFailedSignal := Object errorSignal newSignalMayProceed:true.
+ RegistrationFailedSignal nameClass:self message:#registrationFailedSignal.
+ RegistrationFailedSignal notifierString:'weakArray registration failed'.
+ ]
+! !
+
!WeakArray class methodsFor:'instance creation'!
new:size
"return a new weakArray with size slots"
- |newArray|
-
"This is a kludge: I would like to set WEAK-flag in the classes
- initialize method, but no order of class-init is defined ...
+ initialize method, but no order of class-init is defined (yet) ...
Therefore it could happen, that a WeakArray is used by other
class inits BEFORE this initialize is evaluated. To avoid this,
- the WEAK bit in the class is set when the first WeakArray is
+ the WEAK bit in the class is set here, when the first WeakArray is
created."
self flags:(Behavior flagWeakPointers).
ObjectMemory disposeInterruptHandler:self.
- newArray := self basicNew:size.
+ ^ (self basicNew:size) registerAsWeakArray
+! !
+
+!WeakArray methodsFor:'GC registration'!
+
+registerAsWeakArray
+ "register the receiver in the VM -
+ i.e. tell the VM to nil disposed entries in the receiver
+ and notify the disposeInterruptHandler whenever that happened."
+
+ |ok|
%{
- OBJ ok;
OBJ __addShadowObject();
- ok = __addShadowObject(newArray, 0);
+ ok = __addShadowObject(self, 0);
if (ok == false) {
/*
* this happens when too many shadow objects are
@@ -108,30 +129,30 @@
* that does not help.
*/
nonTenuringScavenge(__context);
- ok = __addShadowObject(newArray, 0);
+ ok = __addShadowObject(self, 0);
if (ok == false) {
/* try more ... */
scavenge(__context);
- ok = __addShadowObject(newArray, 0);
+ ok = __addShadowObject(self, 0);
if (ok == false) {
/* hard stuff - need full collect */
__garbageCollect(__context);
- ok = __addShadowObject(newArray, 0);
+ ok = __addShadowObject(self, 0);
if (ok == false) {
/* mhmh - it seems that there are really many shadow
objects around - force creation */
- ok = __addShadowObject(newArray, 1);
+ ok = __addShadowObject(self, 1);
if (ok == false) {
/* no chance - something must be wrong */
- newArray = nil;
}
}
}
}
}
-%}
-.
- ^ newArray
+%}.
+ ok ifFalse:[
+ ^ RegistrationFailedSignal raiseRequestWith:self
+ ]
! !
!WeakArray class methodsFor:'dispose handling'!
@@ -163,6 +184,17 @@
]
! !
+!WeakArray methodsFor:'copying'!
+
+postCopy
+ "copying alone does not really help - we have to tell
+ the VM, that there is a new WeakArray around ...
+ Q: who copies weakArrays ?"
+
+ self dependents:nil.
+ self registerAsWeakArray.
+! !
+
!WeakArray methodsFor:'accessing'!
dependents
--- a/WeakArray.st Mon Oct 10 01:29:01 1994 +0100
+++ b/WeakArray.st Mon Oct 10 01:29:28 1994 +0100
@@ -12,16 +12,16 @@
Array variableSubclass:#WeakArray
instanceVariableNames:'watcher dependents'
- classVariableNames:''
+ classVariableNames:'RegistrationFailedSignal'
poolDictionaries:''
- category:'System-Support'
+ category:'Collections-Arrayed'
!
WeakArray comment:'
COPYRIGHT (c) 1991 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/WeakArray.st,v 1.5 1994-08-05 01:03:04 claus Exp $
+$Header: /cvs/stx/stx/libbasic/WeakArray.st,v 1.6 1994-10-10 00:29:09 claus Exp $
'!
!WeakArray class methodsFor:'documentation'!
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/WeakArray.st,v 1.5 1994-08-05 01:03:04 claus Exp $
+$Header: /cvs/stx/stx/libbasic/WeakArray.st,v 1.6 1994-10-10 00:29:09 claus Exp $
"
!
@@ -75,29 +75,50 @@
"
! !
+!WeakArray class methodsFor:'initialization'!
+
+initialize
+ "setup the private signal"
+
+ RegistrationFailedSignal isNil ifTrue:[
+ Object initialize.
+
+ RegistrationFailedSignal := Object errorSignal newSignalMayProceed:true.
+ RegistrationFailedSignal nameClass:self message:#registrationFailedSignal.
+ RegistrationFailedSignal notifierString:'weakArray registration failed'.
+ ]
+! !
+
!WeakArray class methodsFor:'instance creation'!
new:size
"return a new weakArray with size slots"
- |newArray|
-
"This is a kludge: I would like to set WEAK-flag in the classes
- initialize method, but no order of class-init is defined ...
+ initialize method, but no order of class-init is defined (yet) ...
Therefore it could happen, that a WeakArray is used by other
class inits BEFORE this initialize is evaluated. To avoid this,
- the WEAK bit in the class is set when the first WeakArray is
+ the WEAK bit in the class is set here, when the first WeakArray is
created."
self flags:(Behavior flagWeakPointers).
ObjectMemory disposeInterruptHandler:self.
- newArray := self basicNew:size.
+ ^ (self basicNew:size) registerAsWeakArray
+! !
+
+!WeakArray methodsFor:'GC registration'!
+
+registerAsWeakArray
+ "register the receiver in the VM -
+ i.e. tell the VM to nil disposed entries in the receiver
+ and notify the disposeInterruptHandler whenever that happened."
+
+ |ok|
%{
- OBJ ok;
OBJ __addShadowObject();
- ok = __addShadowObject(newArray, 0);
+ ok = __addShadowObject(self, 0);
if (ok == false) {
/*
* this happens when too many shadow objects are
@@ -108,30 +129,30 @@
* that does not help.
*/
nonTenuringScavenge(__context);
- ok = __addShadowObject(newArray, 0);
+ ok = __addShadowObject(self, 0);
if (ok == false) {
/* try more ... */
scavenge(__context);
- ok = __addShadowObject(newArray, 0);
+ ok = __addShadowObject(self, 0);
if (ok == false) {
/* hard stuff - need full collect */
__garbageCollect(__context);
- ok = __addShadowObject(newArray, 0);
+ ok = __addShadowObject(self, 0);
if (ok == false) {
/* mhmh - it seems that there are really many shadow
objects around - force creation */
- ok = __addShadowObject(newArray, 1);
+ ok = __addShadowObject(self, 1);
if (ok == false) {
/* no chance - something must be wrong */
- newArray = nil;
}
}
}
}
}
-%}
-.
- ^ newArray
+%}.
+ ok ifFalse:[
+ ^ RegistrationFailedSignal raiseRequestWith:self
+ ]
! !
!WeakArray class methodsFor:'dispose handling'!
@@ -163,6 +184,17 @@
]
! !
+!WeakArray methodsFor:'copying'!
+
+postCopy
+ "copying alone does not really help - we have to tell
+ the VM, that there is a new WeakArray around ...
+ Q: who copies weakArrays ?"
+
+ self dependents:nil.
+ self registerAsWeakArray.
+! !
+
!WeakArray methodsFor:'accessing'!
dependents
--- a/WeakIdDict.st Mon Oct 10 01:29:01 1994 +0100
+++ b/WeakIdDict.st Mon Oct 10 01:29:28 1994 +0100
@@ -14,14 +14,14 @@
instanceVariableNames:''
classVariableNames:''
poolDictionaries:''
- category:'System-Support'
+ category:'Collections-Unordered'
!
WeakIdentityDictionary comment:'
COPYRIGHT (c) 1992 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Attic/WeakIdDict.st,v 1.5 1994-08-05 01:03:06 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/WeakIdDict.st,v 1.6 1994-10-10 00:29:12 claus Exp $
'!
!WeakIdentityDictionary class methodsFor:'documentation'!
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Attic/WeakIdDict.st,v 1.5 1994-08-05 01:03:06 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/WeakIdDict.st,v 1.6 1994-10-10 00:29:12 claus Exp $
"
!
--- a/WeakIdSet.st Mon Oct 10 01:29:01 1994 +0100
+++ b/WeakIdSet.st Mon Oct 10 01:29:28 1994 +0100
@@ -14,14 +14,14 @@
instanceVariableNames:''
classVariableNames:''
poolDictionaries:''
- category:'System-Support'
+ category:'Collections-Unordered'
!
WeakIdentitySet comment:'
COPYRIGHT (c) 1994 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Attic/WeakIdSet.st,v 1.2 1994-08-11 21:38:52 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/WeakIdSet.st,v 1.3 1994-10-10 00:29:15 claus Exp $
'!
!WeakIdentitySet class methodsFor:'documentation'!
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Attic/WeakIdSet.st,v 1.2 1994-08-11 21:38:52 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/WeakIdSet.st,v 1.3 1994-10-10 00:29:15 claus Exp $
"
!
--- a/WeakIdentityDictionary.st Mon Oct 10 01:29:01 1994 +0100
+++ b/WeakIdentityDictionary.st Mon Oct 10 01:29:28 1994 +0100
@@ -14,14 +14,14 @@
instanceVariableNames:''
classVariableNames:''
poolDictionaries:''
- category:'System-Support'
+ category:'Collections-Unordered'
!
WeakIdentityDictionary comment:'
COPYRIGHT (c) 1992 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/WeakIdentityDictionary.st,v 1.5 1994-08-05 01:03:06 claus Exp $
+$Header: /cvs/stx/stx/libbasic/WeakIdentityDictionary.st,v 1.6 1994-10-10 00:29:12 claus Exp $
'!
!WeakIdentityDictionary class methodsFor:'documentation'!
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/WeakIdentityDictionary.st,v 1.5 1994-08-05 01:03:06 claus Exp $
+$Header: /cvs/stx/stx/libbasic/WeakIdentityDictionary.st,v 1.6 1994-10-10 00:29:12 claus Exp $
"
!
--- a/WeakIdentitySet.st Mon Oct 10 01:29:01 1994 +0100
+++ b/WeakIdentitySet.st Mon Oct 10 01:29:28 1994 +0100
@@ -14,14 +14,14 @@
instanceVariableNames:''
classVariableNames:''
poolDictionaries:''
- category:'System-Support'
+ category:'Collections-Unordered'
!
WeakIdentitySet comment:'
COPYRIGHT (c) 1994 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/WeakIdentitySet.st,v 1.2 1994-08-11 21:38:52 claus Exp $
+$Header: /cvs/stx/stx/libbasic/WeakIdentitySet.st,v 1.3 1994-10-10 00:29:15 claus Exp $
'!
!WeakIdentitySet class methodsFor:'documentation'!
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/WeakIdentitySet.st,v 1.2 1994-08-11 21:38:52 claus Exp $
+$Header: /cvs/stx/stx/libbasic/WeakIdentitySet.st,v 1.3 1994-10-10 00:29:15 claus Exp $
"
!