diff --git a/ChangeLog b/ChangeLog index 16d5d82c..e5442066 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,221 @@ +2013-01-21 Gwenael Casaccio + + * kernel/AbstNamespc.st: rename as kernel/AbstractNamespace.st. + * kernel/ArrayColl.st: rename as kernel/ArrayedCollection.st. + * kernel/BindingDict.st: Renamed as kernel/BindingDictionary.st. + * kernel/BlkClosure.st: Renamed as kernel/BlockClosure.st. + * kernel/BlkContext.st: Renamed as kernel/BlockContext.st. + * kernel/CObject.st: Delete. + * kernel/CharArray.st: Renamed as kernel/CharacterArray.st. + * kernel/ClassDesc.st: Renamed as kernel/ClassDescription.st. + * kernel/CompiledBlk.st: Renamed as kernel/CompiledBlock.st. + * kernel/CompildCode.st: Renamed as kernel/CompiledCode.st. + * kernel/CompildMeth.st: Renamed as kernel/CompiledMethod.st. + * kernel/AnsiDates.st: Renamed as kernel/DateTime.st. + * kernel/DeferBinding.st: Renamed as kernel/DeferredVariableBinding.st. + * kernel/DirMessage.st: Renamed as kernel/DirectedMessage.st. + * kernel/Duration.st: New. + * kernel/DynVariable.st: Renamed as kernel/DynamicVariable.st. + * kernel/FileDescr.st: Renamed as kernel/FileDescriptor.st. + * kernel/Getopt.st: Modified. + * kernel/GetoptExtensions.st: New. + * kernel/HashedColl.st: Renamed as kernel/HashedCollection.st. + * kernel/HomedAssoc.st: Renamed as kernel/HomedAssociation.st. + * kernel/IdentDict.st: Renamed as kernel/IdentityDictionary.st. + * kernel/LargeArray.st: New. + * kernel/LargeArraySubpart.st: New. + * kernel/OtherArrays.st: Renamed as kernel/LargeArrayedCollection.st. + * kernel/LargeByteArray.st: New. + * kernel/LargeInt.st: Renamed as kernel/LargeInteger.st. + * kernel/LargeNegativeInteger.st: New. + * kernel/LargePositiveInteger.st: New. + * kernel/LargeWordArray.st: New. + * kernel/LargeZeroInteger.st: New. + * kernel/MappedColl.st: Renamed as kernel/MappedCollection.st. + * kernel/MthContext.st: Renamed as kernel/MethodContext.st. + * kernel/MethodDict.st: Renamed as kernel/MethodDictionary.st. + * kernel/ObjMemory.st: Renamed as kernel/ObjectMemory.st. + * kernel/OrderColl.st: Renamed as kernel/OrderedCollection.st. + * kernel/PkgLoader.st: Delete. + * kernel/PointExtensions.st: New + * kernel/PosStream.st: Renamed as kernel/PositionableStream.st. + * kernel/ProcEnv.st: Renamed as kernel/ProcessEnvironment.st. + * kernel/ProcessVariable.st: New + * kernel/ProcSched.st: Renamed as kernel/ProcessorScheduler.st. + * kernel/RWStream.st: Renamed as kernel/ReadWriteStream.st. + * kernel/Rectangle.st: Modified. + * kernel/RectangleExtensions.st: New. + * kernel/RootNamespc.st: Renamed as kernel/RootNamespace.st. + * kernel/RunArray.st: Modified. + * kernel/RunArrayExtensions.st: New. + * kernel/ScaledDec.st: Renamed as kernel/ScaledDecimal.st. + * kernel/SeqCollect.st: Renamed as kernel/SequenceableCollection.st. + * kernel/SmallInt.st: Renamed as kernel/SmallInteger.st. + * kernel/SortCollect.st: Renamed as kernel/SortedCollection.st. + * kernel/StreamOps.st: Delete. + * kernel/SysDict.st: Renamed as kernel/SystemDictionary.st. + * kernel/Transcript.st: Renamed as kernel/TextCollector.st. + * kernel/Transcript.st: Changed. + * kernel/UndefObject.st: Renamed as kernel/UndefinedObject.st. + * kernel/UniChar.st: Renamed as kernel/UnicodeCharacter.st. + * kernel/UniString.st: Renamed as kernel/UnicodeString.st. + * kernel/VFS.st: Delete. + * kernel/ValueAdapt.st: Delete. + * kernel/VarBinding.st: Renamed as kernel/VariableBinding.st. + * kernel/WeakObjects.st: Delete. + * kernel/WordArray.st: New. + * kernel/autoload/Autoload.st: New. + * kernel/Autoload.st: Renamed as kernel/autoload/AutoloadClass.st. + * kernel/autoload/Extensions.st: New. + * kernel/Builtins.st: Renamed as kernel/bootstrap/Behavior.st. + * kernel/bootstrap/Class.st: New. + * kernel/bootstrap/ClassDescription.st: New. + * kernel/bootstrap/Dictionary.st: New. + * kernel/bootstrap/Object.st: New. + * kernel/bootstrap/UndefinedObject.st: New. + * kernel/collection/weak/WeakArray.st: New. + * kernel/collection/weak/WeakIdentitySet.st: New. + * kernel/collection/weak/WeakKeyDictionary.st: New. + * kernel/collection/weak/WeakKeyIdentityDictionary.st: New. + * kernel/collection/weak/WeakSet.st: New. + * kernel/collection/weak/WeakValueIdentityDictionary.st: New. + * kernel/collection/weak/WeakValueLookupTable.st: New. + * kernel/DLD.st: Renamed as kernel/dld/DLD.st. + * kernel/dld/Extensions.st: New. + * kernel/dld/RoundRobinStream.st: New. + * kernel/exceptions/AlreadyDefined.st: New. + * kernel/exceptions/ArgumentOutOfRange.st: New. + * kernel/exceptions/ArithmeticError.st: New. + * kernel/exceptions/BadReturn.st: New. + * kernel/exceptions/CInterfaceError.st: New. + * kernel/exceptions/EmptyCollection.st: New. + * kernel/exceptions/EndOfStream.st: New. + * kernel/exceptions/Error.st: New. + * kernel/exceptions/Exception.st: New. + * kernel/exceptions/ExceptionSet.st: New. + * kernel/exceptions/Extensions.st: New. + * kernel/exceptions/FileError.st: New. + * kernel/exceptions/Halt.st: New. + * kernel/exceptions/IndexOutOfRange.st: New. + * kernel/exceptions/Initialization.st: New. + * kernel/exceptions/InvalidArgument.st: New. + * kernel/exceptions/InvalidProcessState.st: New. + * kernel/exceptions/InvalidSize.st: New. + * kernel/exceptions/InvalidState.st: New. + * kernel/exceptions/InvalidValue.st: New. + * kernel/exceptions/MessageNotUnderstood.st: New. + * kernel/exceptions/MustBeBoolean.st: New. + * kernel/exceptions/MutationError.st: New. + * kernel/exceptions/NoRunnableProcess.st: New. + * kernel/exceptions/NotEnoughElements.st: New. + * kernel/exceptions/NotFound.st: New. + * kernel/exceptions/NotImplemented.st: New. + * kernel/exceptions/NotIndexable.st: New. + * kernel/exceptions/NotYetImplemented.st: New. + * kernel/exceptions/Notification.st: New. + * kernel/exceptions/PrimitiveFailed.st: New. + * kernel/exceptions/ProcessBeingTerminated.st: New. + * kernel/exceptions/ProcessTerminated.st: New. + * kernel/exceptions/ReadOnlyObject.st: New. + * kernel/exceptions/ShouldNotImplement.st: New. + * kernel/exceptions/SubclassResponsibility.st: New. + * kernel/exceptions/SysExcept.st: New. + * kernel/exceptions/TimeoutNotification.st: New. + * kernel/exceptions/UnhandledException.st: New. + * kernel/exceptions/UserInterrupt.st: New. + * kernel/exceptions/VMError.st: New. + * kernel/exceptions/VerificationError.st: New. + * kernel/exceptions/Warning.st: New. + * kernel/exceptions/WrongArgumentCount.st: New. + * kernel/exceptions/WrongClass.st: New. + * kernel/exceptions/WrongMessageSent.st: New. + * kernel/exceptions/ZeroDivide.st: New. + * kernel/ffi/CAggregate.st: New. + * kernel/ffi/CArray.st: New. + * kernel/ffi/CArrayCType.st: New. + * kernel/ffi/CBoolean.st: New. + * kernel/ffi/CByte.st: New. + * kernel/CCallable.st: Renamed as kernel/ffi/CCallable.st. + * kernel/CCallback.st: Renamed as kernel/ffi/CCallbackDescriptor.st. + * kernel/ffi/CChar.st: New. + * kernel/CStruct.st: Renamed as kernel/ffi/CCompound.st. + * kernel/ffi/CDouble.st: New. + * kernel/ffi/CFloat.st: New. + * kernel/CFuncs.st: Renamed as kernel/ffi/CFunctionDescriptor.st. + * kernel/ffi/CInt.st: New. + * kernel/ffi/CLong.st: New. + * kernel/ffi/CLongDouble.st: New. + * kernel/ffi/CLongLong.st: New. + * kernel/ffi/CObject.st: New. + * kernel/ffi/CObjectExtensions.st: New. + * kernel/ffi/CPtr.st: New. + * kernel/ffi/CPtrCType.st: New. + * kernel/ffi/CScalar.st: New. + * kernel/ffi/CScalarCType.st: New. + * kernel/ffi/CShort.st: New. + * kernel/ffi/CSmalltalk.st: New. + * kernel/ffi/CString.st: New. + * kernel/ffi/CStringCType.st: New. + * kernel/ffi/CStruct.st: New. + * kernel/CType.st: Renamed as kernel/ffi/CType.st. + * kernel/ffi/CTypeInitialization.st: New. + * kernel/ffi/CUChar.st: New. + * kernel/ffi/CUInt.st: New. + * kernel/ffi/CULong.st: New. + * kernel/ffi/CULongLong.st: New. + * kernel/ffi/CUShort.st: New. + * kernel/ffi/CUnion.st: New. + * kernel/ffi/Extensions.st: New. + * kernel/file/Extensions.st: New. + * kernel/File.st: Renamed as kernel/file/File.st. + * kernel/file/Stat.st: New. + * kernel/file/vfs/ArchiveFile.st: New. + * kernel/file/vfs/ArchiveMember.st: New. + * kernel/file/vfs/Extensions.st: New. + * kernel/file/vfs/FileWrapper.st: New. + * kernel/VFSZip.st: Renamed as kernel/file/vfs/LimitedStream.st. + * kernel/file/vfs/RecursiveFileWrapper.st: New. + * kernel/file/vfs/StoredZipMember.st: New. + * kernel/file/vfs/TmpFileArchiveMember.st: New. + * kernel/file/vfs/ZipFile.st: New. + * kernel/package/DisabledPackage.st: New. + * kernel/package/Package.st: New. + * kernel/package/PackageContainer.st: New. + * kernel/package/PackageDirectories.st: New. + * kernel/package/PackageDirectory.st: New. + * kernel/package/PackageGroup.st: New. + * kernel/package/PackageInfo.st: New. + * kernel/package/PackageLoader.st: New. + * kernel/package/PackageNotAvailable.st: New. + * kernel/package/PackageSkip.st: New. + * kernel/package/StarPackage.st: New. + * kernel/package/TestPackage.st: New. + * kernel/Regex.st: Renamed as kernel/regex/Extensions.st. + * kernel/regex/FailedMatchRegexResults.st: New. + * kernel/regex/Initialization.st: New. + * kernel/regex/MatchingRegexResults.st: New. + * kernel/regex/Regex.st: New. + * kernel/regex/RegexResults.st: New. + * kernel/stream/CollectingStream.st: New. + * kernel/stream/ConcatenatedStream.st: New. + * kernel/stream/Extensions.st: New. + * kernel/stream/FilteringStream.st: New. + * kernel/stream/LineStream.st: New. + * kernel/stream/OneOfEachStream.st: New. + * kernel/stream/PeekableStream.st: New. + * kernel/url/Initialization.st: New. + * kernel/url/URIResolver.st: New. + * kernel/URL.st: Renamed as kernel/url/URL.st. + * kernel/value-adaptor/DelayedAdaptor.st: New. + * kernel/value-adaptor/NullValueHolder.st: New. + * kernel/value-adaptor/PluggableAdaptor.st: New. + * kernel/value-adaptor/Promise.st: New. + * kernel/value-adaptor/ValueAdaptor.st: New. + * kernel/value-adaptor/ValueHolder.st: New. + * kernel/value-adaptor/ValueHolderExtensions.st: New. + * libgst/files.c: Changed. + * packages.xml: Changed. + 2013-03-16 Holger Freyther * .travis.yml: Add description for the travis-ci service. diff --git a/kernel/AbstNamespc.st b/kernel/AbstractNamespace.st similarity index 100% rename from kernel/AbstNamespc.st rename to kernel/AbstractNamespace.st diff --git a/kernel/ArrayColl.st b/kernel/ArrayedCollection.st similarity index 100% rename from kernel/ArrayColl.st rename to kernel/ArrayedCollection.st diff --git a/kernel/BindingDict.st b/kernel/BindingDictionary.st similarity index 100% rename from kernel/BindingDict.st rename to kernel/BindingDictionary.st diff --git a/kernel/BlkClosure.st b/kernel/BlockClosure.st similarity index 100% rename from kernel/BlkClosure.st rename to kernel/BlockClosure.st diff --git a/kernel/BlkContext.st b/kernel/BlockContext.st similarity index 100% rename from kernel/BlkContext.st rename to kernel/BlockContext.st diff --git a/kernel/CObject.st b/kernel/CObject.st deleted file mode 100644 index f757699e..00000000 --- a/kernel/CObject.st +++ /dev/null @@ -1,1597 +0,0 @@ -"====================================================================== -| -| C object basic data type definitions. -| -| - ======================================================================" - -"====================================================================== -| -| Copyright 1988,92,94,95,99,2000,2001,2002,2003,2004,2008,2009 -| Free Software Foundation, Inc. -| Written by Steve Byrne. -| -| This file is part of the GNU Smalltalk class library. -| -| The GNU Smalltalk class library is free software; you can redistribute it -| and/or modify it under the terms of the GNU Lesser General Public License -| as published by the Free Software Foundation; either version 2.1, or (at -| your option) any later version. -| -| The GNU Smalltalk class library is distributed in the hope that it will be -| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of -| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser -| General Public License for more details. -| -| You should have received a copy of the GNU Lesser General Public License -| along with the GNU Smalltalk class library; see the file COPYING.LIB. -| If not, write to the Free Software Foundation, 59 Temple Place - Suite -| 330, Boston, MA 02110-1301, USA. -| - ======================================================================" - - - -Object subclass: CObject [ - | type storage | - - - - - - - CObject class [ - | defaultType | - - ] - - CObject class >> inheritShape [ - "Answer whether subclasses will have by default the same shape as - this class. The default is true for the CObject hierarchy." - - ^true - ] - - CObject class >> alloc: nBytes type: cTypeObject [ - "Allocate nBytes bytes and return a CObject of the given type" - - - - nBytes isInteger - ifFalse: [^SystemExceptions.WrongClass signalOn: nBytes mustBe: SmallInteger]. - ^SystemExceptions.WrongClass signalOn: cTypeObject mustBe: CType - ] - - CObject class >> gcAlloc: nBytes type: cTypeObject [ - "Allocate nBytes bytes and return a CObject of the given type" - - - | class | - class := cTypeObject isNil - ifTrue: [ self ] - ifFalse: [ cTypeObject cObjectType ]. - - ^(class address: 0) - type: cTypeObject; - storage: (ByteArray new: nBytes); - yourself - ] - - CObject class >> alloc: nBytes [ - "Allocate nBytes bytes and return an instance of the receiver" - - - ^self alloc: nBytes type: nil - ] - - CObject class >> gcAlloc: nBytes [ - "Allocate nBytes bytes and return an instance of the receiver" - - - ^self gcAlloc: nBytes type: nil - ] - - CObject class >> gcNew: nBytes [ - "Allocate nBytes bytes and return an instance of the receiver" - - - ^self gcAlloc: nBytes type: nil - ] - - CObject class >> new: nBytes [ - "Allocate nBytes bytes and return an instance of the receiver" - - - ^self alloc: nBytes type: nil - ] - - CObject class >> address: anInteger [ - "Answer a new object pointing to the passed address, anInteger" - - - ^(self basicNew: 1) address: anInteger - ] - - CObject class >> new [ - "Answer a new object pointing to NULL." - - - ^self address: 0 - ] - - CObject class >> type [ - "Nothing special in the default case - answer a CType for the receiver" - - - defaultType isNil ifTrue: [defaultType := CType cObjectType: self]. - ^defaultType - ] - - CObject class >> cObjStoredType [ - "Private - Provide a conversion from a CObject to a Smalltalk object - to be stored by #at:put:" - - - ^nil - ] - - = anObject [ - "Return true if the receiver and aCObject are equal." - - - ^self class == anObject class and: [ - self type = anObject type and: [ - self storage == anObject storage and: [ - self address = anObject address ]]] - ] - - hash [ - "Return a hash value for anObject." - - - | addr | - addr := self address bitAnd: SmallInteger largest. - ^self type hash - bitXor: (self storage identityHash * self storage size + addr) - ] - - finalize [ - "To make the VM call this, use #addToBeFinalized. It frees - automatically any memory pointed to by the CObject. It is not - automatically enabled because big trouble hits you if you use - #free and the receiver doesn't point to the base of a malloc-ed - area." - - - self free - ] - - addressAt: anIndex [ - "Return a new CObject of the element type, - corresponding to an object that is anIndex places past - the receiver (remember that CObjects represent pointers - and that C pointers behave like arrays). - anIndex is zero-based, just like with all other C-style accessing." - - - | dereferencedType | - dereferencedType := self dereferencedType. - ^self at: anIndex * dereferencedType sizeof type: dereferencedType - ] - - at: anIndex [ - "Dereference a pointer that is anIndex places past - the receiver (remember that CObjects represent pointers - and that C pointers behave like arrays). anIndex is - zero-based, just like with all other C-style accessing." - - - | dereferencedType offset valueType | - dereferencedType := self dereferencedType. - offset := anIndex * dereferencedType sizeof. - valueType := dereferencedType valueType. - ^valueType isInteger - ifTrue: [self at: offset type: valueType] - ifFalse: [(self at: offset type: dereferencedType) value] - ] - - at: anIndex put: aValue [ - "Store anIndex places past the receiver the passed Smalltalk - object or CObject `aValue'; if it is a CObject is dereferenced: - that is, this method is equivalent either to cobj[anIndex]=aValue - or cobj[anIndex]=*aValue. anIndex is zero-based, just like with - all other C-style accessing. - - In both cases, aValue should be of the element type or of the - corresponding Smalltalk type (that is, a String is ok for an - array of CStrings) to avoid typing problems which however will - not be signaled because C is untyped." - - - | dereferencedType offset valueType | - dereferencedType := self dereferencedType. - offset := anIndex * dereferencedType sizeof. - valueType := dereferencedType valueType. - valueType isInteger - ifTrue: - [self - at: offset - put: aValue - type: valueType] - ifFalse: [(self at: offset type: dereferencedType) value: aValue]. - ^aValue - ] - - isNull [ - "Return true if the receiver points to NULL." - - - ^self address = 0 and: [ self isAbsolute ] - ] - - isCObject [ - - ^true - ] - - incr [ - "Adjust the pointer by sizeof(dereferencedType) bytes up (i.e. ++receiver)" - - - self adjPtrBy: self dereferencedType sizeof - ] - - decr [ - "Adjust the pointer by sizeof(dereferencedType) bytes down (i.e. --receiver)" - - - self adjPtrBy: self dereferencedType sizeof negated - ] - - incrBy: anInteger [ - "Adjust the pointer by anInteger elements up (i.e. receiver += anInteger)" - - - self adjPtrBy: self dereferencedType sizeof * anInteger - ] - - decrBy: anInteger [ - "Adjust the pointer by anInteger elements down (i.e. receiver -= anInteger)" - - - self adjPtrBy: self dereferencedType sizeof * anInteger negated - ] - - + anInteger [ - "Return another instance of the receiver's class which points at - &receiver[anInteger] (or, if you prefer, what `receiver + - anInteger' does in C)." - - - | dereferencedType | - dereferencedType := self dereferencedType. - ^self at: anInteger * dereferencedType sizeof type: self type - ] - - - intOrPtr [ - "If intOrPtr is an integer, return another instance of the receiver's - class pointing at &receiver[-anInteger] (or, if you prefer, what - `receiver - anInteger' does in C). - If it is the same class as the receiver, return the difference in - chars, i.e. in bytes, between the two pointed addresses (or, if - you prefer, what `receiver - anotherCharPtr' does in C)" - - - | dereferencedType | - intOrPtr isInteger ifTrue: [^self + intOrPtr negated]. - dereferencedType := self dereferencedType. - intOrPtr dereferencedType = dereferencedType - ifFalse: - [^SystemExceptions.InvalidArgument signalOn: intOrPtr - reason: 'arithmetic between pointers to different types']. - ^((self addressAt: 0) address - (intOrPtr addressAt: 0) address) - // dereferencedType sizeof - ] - - castTo: aType [ - "Answer another CObject, pointing to the same address as the receiver, - but belonging to the aType CType." - - - ^self at: 0 type: aType - ] - - narrow [ - "This method is called on CObjects returned by a C call-out whose - return type is specified as a CType; it mostly allows one to - change the class of the returned CObject. By default it does - nothing, and that's why it is not called when #cObject is used - to specify the return type." - - - - ] - - type [ - "Answer a CType for the receiver" - - - type isNil ifTrue: [type := self class type]. - ^type - ] - - isAbsolute [ - "Answer whether the object points into a garbage-collected Smalltalk - storage, or it is an absolute address." - - - ^storage isNil - ] - - storage [ - "Answer the storage that the receiver is pointing into, or nil - if the address is absolute." - - - ^storage - ] - - storage: anObject [ - "Change the receiver to point to the storage of anObject." - - - storage := anObject. - ] - - address [ - "Answer the address the receiver is pointing to. The address can - be absolute if the storage is nil, or relative to the Smalltalk - object in #storage. In this case, an address of 0 corresponds to - the first instance variable." - - - - ^self basicAt: self basicSize - ] - - address: anInteger [ - "Set the receiver to point to the passed address, anInteger" - - - - SystemExceptions.WrongClass signalOn: anInteger mustBe: Integer - ] - - printOn: aStream [ - "Print a representation of the receiver" - - - aStream - print: self class; - nextPut: $(. - - self isAbsolute - ifTrue: [ aStream nextPutAll: (self address printStringRadix: 16) ] - ifFalse: [ - self storage do: [ :each | aStream print: each; space ]. - aStream nextPutAll: '@ '; print: self address ]. - - aStream nextPut: $) - ] - - type: aCType [ - "Set the receiver's type to aCType." - - - type := aCType - ] - - adjPtrBy: byteOffset [ - - self address: self address + byteOffset - ] - - dereferencedType [ - - ^self type - ] - - cObjStoredType [ - "Private - Provide a conversion from a CObject to a Smalltalk object - to be stored by #at:put:" - - - ^nil - ] - - cObjStoredValue [ - "Private - Provide a conversion from a CObject to a Smalltalk object - to be stored by #at:put:" - - - ^self value - ] - - at: byteOffset type: aType [ - "Answer some data of the given type from byteOffset bytes after - the pointer stored in the receiver" - - - - byteOffset isInteger - ifFalse: - [^SystemExceptions.WrongClass signalOn: byteOffset mustBe: SmallInteger]. - (self isAbsolute not and: [ aType isInteger ]) ifTrue: [ - ^SystemExceptions.InvalidArgument signalOn: self address + byteOffset - reason: 'offset out of range' ]. - - ^SystemExceptions.WrongClass signalOn: aType - ] - - at: byteOffset put: aValue type: aType [ - "Store aValue as data of the given type from byteOffset bytes after - the pointer stored in the receiver" - - - | type | - - - (self isAbsolute not and: [ aValue isCObject not ]) ifTrue: [ - ^SystemExceptions.InvalidArgument signalOn: self address + byteOffset - reason: 'offset out of range' ]. - - type := aValue cObjStoredType. - - "Attempt to store something meaningful from another CObject" - type isNil ifTrue: [type := aType]. - ^self - at: byteOffset - noCObjectsPut: aValue cObjStoredValue - type: type - ] - - free [ - "Free the receiver's pointer and set it to null. Big trouble hits - you if the receiver doesn't point to the base of a malloc-ed area." - - - - ^self primitiveFailed - ] - - at: byteOffset noCObjectsPut: aValue type: aType [ - "Private - Store aValue as data of the given type from byteOffset bytes - after the pointer stored in the receiver. This version refuses CObjects - for `aValue'." - - - - byteOffset isInteger - ifFalse: - [^SystemExceptions.WrongClass signalOn: byteOffset mustBe: SmallInteger]. - (aType isInteger or: [aType isKindOf: CType]) - ifFalse: - [^SystemExceptions.WrongClass signalOn: byteOffset mustBe: SmallInteger]. - ^SystemExceptions.WrongClass signalOn: aValue - ] - - derefAt: byteOffset type: aType [ - - - byteOffset isInteger - ifFalse: - [^SystemExceptions.WrongClass signalOn: byteOffset mustBe: SmallInteger]. - ^SystemExceptions.WrongClass signalOn: aType - ] -] - - - -CObject subclass: CScalar [ - - - - - CScalar class >> value: anObject [ - "Answer a newly allocated CObject containing the passed value, - anObject. Remember to call #addToBeFinalized if you want the - CObject to be automatically freed" - - - | cObject | - cObject := self type new. - cObject value: anObject. - ^cObject - ] - - CScalar class >> gcValue: anObject [ - "Answer a newly allocated CObject containing the passed value, - anObject, in garbage-collected storage." - - - | cObject | - cObject := self type gcNew. - cObject value: anObject. - ^cObject - ] - - CScalar class >> type [ - "Answer a CType for the receiver---for example, CByteType if - the receiver is CByte." - - - ^self environment at: (self name , 'Type') asGlobalKey - ] - - CScalar class >> cObjStoredType [ - "Private - Provide a conversion from a CObject to a Smalltalk object - to be stored by #at:put:" - - - self subclassResponsibility - ] - - cObjStoredType [ - "Private - Provide a conversion from a CObject to a Smalltalk object - to be stored by #at:put:" - - - self subclassResponsibility - ] - - value [ - "Answer the value the receiver is pointing to. The exact returned - value depends on the receiver's class" - - - ^self at: 0 type: self cObjStoredType - ] - - value: aValue [ - "Set the receiver to point to the value, aValue. The exact meaning - of aValue depends on the receiver's class" - - - self - at: 0 - put: aValue - type: self cObjStoredType - ] -] - - - -CScalar subclass: CSmalltalk [ - - - - - CSmalltalk class >> sizeof [ - "Answer the receiver's instances size" - - - ^CPtrSize - ] - - CSmalltalk class >> alignof [ - "Answer the receiver's instances required aligment" - - - ^CPtrSize - ] - - CSmalltalk class >> cObjStoredType [ - "Private - Answer an index referring to the receiver's instances scalar type" - - - ^9 - ] - - sizeof [ - "Answer the receiver's size" - - - ^CPtrSize - ] - - alignof [ - "Answer the receiver's required aligment" - - - ^CPtrSize - ] - - cObjStoredType [ - "Private - Answer an index referring to the receiver's scalar type" - - - ^9 - ] -] - - -CScalar subclass: CLongLong [ - - - - - CLongLong class >> sizeof [ - "Answer the receiver's instances size" - - - ^8 - ] - - CLongLong class >> alignof [ - "Answer the receiver's instances required aligment" - - - ^CLongLongAlignment - ] - - CLongLong class >> cObjStoredType [ - "Private - Answer an index referring to the receiver's instances scalar type" - - - ^30 - ] - - sizeof [ - "Answer the receiver's size" - - - ^8 - ] - - alignof [ - "Answer the receiver's required aligment" - - - ^CLongLongAlignment - ] - - cObjStoredType [ - "Private - Answer an index referring to the receiver's scalar type" - - - ^30 - ] -] - - -CScalar subclass: CULongLong [ - - - - - CULongLong class >> sizeof [ - "Answer the receiver's instances size" - - - ^8 - ] - - CULongLong class >> alignof [ - "Answer the receiver's instances required aligment" - - - ^CLongLongAlignment - ] - - CULongLong class >> cObjStoredType [ - "Private - Answer an index referring to the receiver's instances scalar type" - - - ^31 - ] - - sizeof [ - "Answer the receiver's size" - - - ^8 - ] - - alignof [ - "Answer the receiver's required aligment" - - - ^CLongLongAlignment - ] - - cObjStoredType [ - "Private - Answer an index referring to the receiver's scalar type" - - - ^31 - ] -] - - -CScalar subclass: CLong [ - - - - CLong class >> sizeof [ - "Answer the receiver's instances size" - - - ^CLongSize - ] - - CLong class >> alignof [ - "Answer the receiver's instances required aligment" - - - ^CLongSize - ] - - CLong class >> cObjStoredType [ - "Private - Answer an index referring to the receiver's instances scalar type" - - - ^4 - ] - - sizeof [ - "Answer the receiver's size" - - - ^CLongSize - ] - - alignof [ - "Answer the receiver's required aligment" - - - ^CLongSize - ] - - cObjStoredType [ - "Private - Answer an index referring to the receiver's scalar type" - - - ^4 - ] -] - - - -CScalar subclass: CULong [ - - - - - CULong class >> sizeof [ - "Answer the receiver's instances size" - - - ^CLongSize - ] - - CULong class >> alignof [ - "Answer the receiver's instances required aligment" - - - ^CLongSize - ] - - CULong class >> cObjStoredType [ - "Private - Answer an index referring to the receiver's instances scalar type" - - - ^5 - ] - - sizeof [ - "Answer the receiver's size" - - - ^CLongSize - ] - - alignof [ - "Answer the receiver's required aligment" - - - ^CLongSize - ] - - cObjStoredType [ - "Private - Answer an index referring to the receiver's scalar type" - - - ^5 - ] -] - - - -CScalar subclass: CInt [ - - - - - CInt class >> sizeof [ - "Answer the receiver's size" - - - ^CIntSize - ] - - CInt class >> alignof [ - "Answer the receiver's required aligment" - - - ^CIntSize - ] - - CInt class >> cObjStoredType [ - "Private - Answer an index referring to the receiver's instances scalar type" - - - ^10 - ] - - sizeof [ - "Answer the receiver's instances size" - - - ^CIntSize - ] - - alignof [ - "Answer the receiver's instances required aligment" - - - ^CIntSize - ] - - cObjStoredType [ - "Private - Answer an index referring to the receiver's scalar type" - - - ^10 - ] -] - - - -CScalar subclass: CUInt [ - - - - - CUInt class >> sizeof [ - "Answer the receiver's instances size" - - - ^CIntSize - ] - - CUInt class >> alignof [ - "Answer the receiver's instances required aligment" - - - ^CIntSize - ] - - CUInt class >> cObjStoredType [ - "Private - Answer an index referring to the receiver's instances scalar type" - - - ^11 - ] - - sizeof [ - "Answer the receiver's size" - - - ^CIntSize - ] - - alignof [ - "Answer the receiver's required aligment" - - - ^CIntSize - ] - - cObjStoredType [ - "Private - Answer an index referring to the receiver's scalar type" - - - ^11 - ] -] - - - -CScalar subclass: CShort [ - - - - - CShort class >> sizeof [ - "Answer the receiver's instances size" - - - ^CShortSize - ] - - CShort class >> alignof [ - "Answer the receiver's instances required aligment" - - - ^CShortSize - ] - - CShort class >> cObjStoredType [ - "Private - Answer an index referring to the receiver's instances scalar type" - - - ^2 - ] - - sizeof [ - "Answer the receiver's size" - - - ^CShortSize - ] - - alignof [ - "Answer the receiver's required aligment" - - - ^CShortSize - ] - - cObjStoredType [ - "Private - Answer an index referring to the receiver's scalar type" - - - ^2 - ] -] - - - -CScalar subclass: CUShort [ - - - - - CUShort class >> sizeof [ - "Answer the receiver's instances size" - - - ^CShortSize - ] - - CUShort class >> alignof [ - "Answer the receiver's instances required aligment" - - - ^CShortSize - ] - - CUShort class >> cObjStoredType [ - "Private - Answer an index referring to the receiver's instances scalar type" - - - ^3 - ] - - sizeof [ - "Answer the receiver's size" - - - ^CShortSize - ] - - alignof [ - "Answer the receiver's required aligment" - - - ^CShortSize - ] - - cObjStoredType [ - "Private - Answer an index referring to the receiver's scalar type" - - - ^3 - ] -] - - - -CScalar subclass: CChar [ - - - - - CChar class >> sizeof [ - "Answer the receiver's instances size" - - - ^1 - ] - - CChar class >> alignof [ - "Answer the receiver's instances required aligment" - - - ^1 - ] - - CChar class >> cObjStoredType [ - "Private - Answer an index referring to the receiver's instances scalar type" - - - ^0 - ] - - asByteArray: size [ - "Convert size bytes pointed to by the receiver to a String" - - - ^ByteArray fromCData: self size: size - ] - - asString [ - "Convert the data pointed to by the receiver, up to the first NULL byte, - to a String" - - - ^String fromCData: self - ] - - asString: size [ - "Convert size bytes pointed to by the receiver to a String" - - - ^String fromCData: self size: size - ] - - sizeof [ - "Answer the receiver's size" - - - ^1 - ] - - alignof [ - "Answer the receiver's required aligment" - - - ^1 - ] - - cObjStoredType [ - "Private - Answer an index referring to the receiver's scalar type" - - - ^0 - ] -] - - - -CScalar subclass: CUChar [ - - - - - CUChar class >> sizeof [ - "Answer the receiver's instances size" - - - ^1 - ] - - CUChar class >> alignof [ - "Answer the receiver's instances required aligment" - - - ^1 - ] - - CUChar class >> cObjStoredType [ - "Private - Answer an index referring to the receiver's instances scalar type" - - - ^1 - ] - - sizeof [ - "Answer the receiver's size" - - - ^1 - ] - - alignof [ - "Answer the receiver's required aligment" - - - ^1 - ] - - cObjStoredType [ - "Private - Answer an index referring to the receiver's scalar type" - - - ^1 - ] -] - - - -CScalar subclass: CFloat [ - - - - - CFloat class >> sizeof [ - "Answer the receiver's instances size" - - - ^CFloatSize - ] - - CFloat class >> alignof [ - "Answer the receiver's instances required aligment" - - - ^CFloatSize - ] - - CFloat class >> cObjStoredType [ - "Private - Answer an index referring to the receiver's instances scalar type" - - - ^6 - ] - - sizeof [ - "Answer the receiver's size" - - - ^CFloatSize - ] - - alignof [ - "Answer the receiver's required aligment" - - - ^CFloatSize - ] - - cObjStoredType [ - "Private - Answer an index referring to the receiver's scalar type" - - - ^6 - ] -] - - - -CScalar subclass: CDouble [ - - - - - CDouble class >> sizeof [ - "Answer the receiver's instances size" - - - ^CDoubleSize - ] - - CDouble class >> alignof [ - "Answer the receiver's instances required aligment" - - - ^CDoubleAlignment - ] - - CDouble class >> cObjStoredType [ - "Private - Answer an index referring to the receiver's instances scalar type" - - - ^7 - ] - - sizeof [ - "Answer the receiver's size" - - - ^CDoubleSize - ] - - alignof [ - "Answer the receiver's required aligment" - - - ^CDoubleAlignment - ] - - cObjStoredType [ - "Private - Answer an index referring to the receiver's scalar type" - - - ^7 - ] -] - - - -CScalar subclass: CLongDouble [ - - - - - CLongDouble class >> sizeof [ - "Answer the receiver's instances size" - - - ^CLongDoubleSize - ] - - CLongDouble class >> alignof [ - "Answer the receiver's instances required aligment" - - - ^CLongDoubleAlignment - ] - - CLongDouble class >> cObjStoredType [ - "Private - Answer an index referring to the receiver's instances scalar type" - - - ^12 - ] - - sizeof [ - "Answer the receiver's size" - - - ^CLongDoubleSize - ] - - alignof [ - "Answer the receiver's required aligment" - - - ^CLongDoubleAlignment - ] - - cObjStoredType [ - "Private - Answer an index referring to the receiver's scalar type" - - - ^12 - ] -] - - - -CObject subclass: CAggregate [ - - - - - CAggregate class >> sizeof [ - "Answer the receiver's instances size" - - "This is the closest possible guess for CArrays" - - - ^CPtrSize - ] - - CAggregate class >> alignof [ - "Answer the receiver's instances required aligment" - - "This is the closest possible guess for CArrays" - - - ^CPtrSize - ] - - elementType [ - "Answer the type over which the receiver is constructed." - - - ^self type elementType - ] -] - - - -CAggregate subclass: CArray [ - - - - - sizeof [ - "Answer the receiver's size" - - - ^self type numberOfElements * self elementType sizeof - ] - - alignof [ - "Answer the receiver's required aligment" - - - ^self elementType alignof - ] - - dereferencedType [ - - ^self type elementType - ] - - cObjStoredType [ - "Private - Provide a conversion from a CObject to a Smalltalk object - to be stored by #at:put:" - - "If they want to store the receiver with #at:put:, they store the - address (of the first character) without dereferencing the pointer." - - - ^CLong cObjStoredType - ] - - cObjStoredValue [ - "Private - Provide a conversion from a CObject to a Smalltalk object - to be stored by #at:put:" - - "If they want to store the receiver with #at:put:, they - store the address without dereferencing the pointer." - - - ^self address - ] -] - - - -CAggregate subclass: CPtr [ - - - - - sizeof [ - "Answer the receiver's size" - - - ^CPtrSize - ] - - alignof [ - "Answer the receiver's required aligment" - - - ^CPtrSize - ] - - value [ - "Answer the address of the location pointed to by the receiver." - - - ^self derefAt: 0 type: self type elementType - ] - - value: anObject [ - "Set the address of the location pointed to by the receiver - to anObject, which can be either an Integer or a CObject. - if anObject is an Integer, it is interpreted as a 32-bit - or 64-bit address. If it is a CObject, its address is - stored." - - - anObject isInteger - ifTrue: - [^self - at: 0 - put: anObject - type: CLong cObjStoredType]. - self - at: 0 - put: anObject address - type: CLong cObjStoredType - ] -] - - - -CPtr subclass: CString [ - - - >#asString. - -In general, I behave like a cross between an array of characters and a pointer -to a character. I provide the protocol for both data types. My #value -method returns a Smalltalk String, as you would expect for a scalar datatype. -'> - - CString class >> value: anObject [ - "Answer a newly allocated CObject containing the passed value, - anObject. Remember to call #addToBeFinalized if you want the - CObject to be automatically freed" - - - | cObject | - cObject := self type new. - cObject value: anObject. - ^cObject - ] - - CString class >> type [ - "Answer a CType for the receiver---for example, CByteType if - the receiver is CByte." - - - ^CStringType - ] - - CString class >> cObjStoredType [ - "Private - Provide a conversion from a CObject to a Smalltalk object - to be stored by #at:put:" - - - ^8 - ] - - cObjStoredType [ - "Private - Provide a conversion from a CObject to a Smalltalk object - to be stored by #at:put:" - - - ^8 - ] - - value [ - "Answer the value the receiver is pointing to. The exact returned - value depends on the receiver's class" - - - ^self at: 0 type: 8 - ] - - value: aValue [ - "Set the receiver to point to the value, aValue. The exact meaning - of aValue depends on the receiver's class" - - - self - at: 0 - put: aValue - type: 8 - ] -] - - - -CUChar subclass: CByte [ - - - - - CByte class >> cObjStoredType [ - "Nothing special in the default case - answer a CType for the receiver" - - - ^self type - ] - - CByte class >> type [ - "Answer a CType for the receiver" - - - ^CByteType - ] - - cObjStoredType [ - "Nothing special in the default case - answer the receiver's CType" - - - ^self type - ] - - value [ - "Answer the value the receiver is pointing to. The returned value - is a SmallInteger" - - - ^(self at: 0 type: super cObjStoredType) value - ] - - value: aValue [ - "Set the receiver to point to the value, aValue (a SmallInteger)." - - - self - at: 0 - put: (Character value: aValue) - type: super cObjStoredType - ] -] - - - -CByte subclass: CBoolean [ - - - - - CBoolean class >> type [ - "Answer a CType for the receiver" - - - ^CBooleanType - ] - - value [ - "Get the receiver's value - answer true if it is != 0, false if it is 0." - - - ^super value > 0 - ] - - value: aBoolean [ - "Set the receiver's value - it's the same as for CBytes, but we - get a Boolean, not a Character" - - - ^super value: aBoolean asCBooleanValue - ] -] - - - -"Forward define CType instances" - - - -Eval [ - Smalltalk at: #CCharType put: nil. - Smalltalk at: #CStringType put: nil -] - - - -UndefinedObject extend [ - - free [ - "Do nothing, a NULL pointer can be safely freed." - - - - ] - - narrow [ - "Return the receiver: a NULL pointer is always nil, whatever its type." - - - ^self - ] - -] - diff --git a/kernel/CharArray.st b/kernel/CharacterArray.st similarity index 100% rename from kernel/CharArray.st rename to kernel/CharacterArray.st diff --git a/kernel/ClassDesc.st b/kernel/ClassDescription.st similarity index 100% rename from kernel/ClassDesc.st rename to kernel/ClassDescription.st diff --git a/kernel/CompiledBlk.st b/kernel/CompiledBlock.st similarity index 100% rename from kernel/CompiledBlk.st rename to kernel/CompiledBlock.st diff --git a/kernel/CompildCode.st b/kernel/CompiledCode.st similarity index 100% rename from kernel/CompildCode.st rename to kernel/CompiledCode.st diff --git a/kernel/CompildMeth.st b/kernel/CompiledMethod.st similarity index 100% rename from kernel/CompildMeth.st rename to kernel/CompiledMethod.st diff --git a/kernel/AnsiDates.st b/kernel/DateTime.st similarity index 71% rename from kernel/AnsiDates.st rename to kernel/DateTime.st index 9c72cdbc..810e9d52 100644 --- a/kernel/AnsiDates.st +++ b/kernel/DateTime.st @@ -1,6 +1,6 @@ "====================================================================== | -| DateTime and Duration Method Definitions +| DateTime Method Definitions | | ======================================================================" @@ -29,8 +29,6 @@ | ======================================================================" - - Date subclass: DateTime [ | seconds offset | @@ -542,235 +540,3 @@ Date subclass: DateTime [ ] ] - - -Time subclass: Duration [ - - - - - Zero := nil. - - Duration class >> fromDays: days seconds: secs offset: unused [ - "Answer a duration of `d' days and `secs' seconds. The last - parameter is unused; this message is available for interoperability - with the DateTime class." - - - ^self fromSeconds: days * 86400 + secs - ] - - Duration class >> milliseconds: msec [ - "Answer a duration of `msec' milliseconds" - - - ^self fromSeconds: msec / 1000 - ] - - Duration class >> weeks: w [ - "Answer a duration of `w' weeks" - - - ^self fromSeconds: w * ##(86400 * 7) - ] - - Duration class >> days: d [ - "Answer a duration of `d' days" - - - ^self fromSeconds: d * 86400 - ] - - Duration class >> days: d hours: h minutes: m seconds: s [ - "Answer a duration of `d' days and the given number of hours, - minutes, and seconds." - - - ^self fromSeconds: ((d * 24 + h) * 60 + m) * 60 + s - ] - - Duration class >> readFrom: aStream [ - "Parse an instance of the receiver (hours/minutes/seconds) from - aStream" - - - | sign sec hms i ch ws | - hms := {0. 0. 0}. - sign := (aStream peekFor: $-) - ifTrue: [-1] - ifFalse: [aStream peekFor: $+. 1]. - i := 1. - ch := $:. - [aStream atEnd not and: [ch isSeparator not and: [ - ch ~= $+ and: [ch ~= $- and: [ - i > 1 ifTrue: [aStream next]. - i <= 4 and: [(ch := aStream peek) isDigit]]]]]] whileTrue: [ - ws := WriteStream on: (String new: 10). - [ws nextPut: aStream next. - aStream atEnd not and: [(ch := aStream peek) isDigit]] whileTrue. - i = 4 - ifTrue: [ - hms := { - (hms at: 1) * 24 + (hms at: 2). - hms at: 3. - ws contents asNumber}] - ifFalse: [ - hms at: i put: ws contents asNumber]. - i := i + 1]. - sec := ((hms at: 1) * 3600 + ((hms at: 2) * 60) + (hms at: 3)) * sign. - ^self fromSeconds: sec - ] - - Duration class >> initialize [ - "Initialize the receiver's instance variables" - - - Zero := self new - ] - - Duration class >> zero [ - "Answer a duration of zero seconds." - - - ^Zero - ] - - * factor [ - "Answer a Duration that is `factor' times longer than the receiver" - - - ^Duration fromSeconds: self asSeconds * factor - ] - - / factorOrDuration [ - "If the parameter is a Duration, answer the ratio between the receiver - and factorOrDuration. Else divide the receiver by factorOrDuration (a - Number) and answer a new Duration that is correspondingly shorter." - - - ^factorOrDuration isNumber - ifFalse: [self asSeconds / factorOrDuration asSeconds] - ifTrue: [Duration fromSeconds: self asSeconds / factorOrDuration] - ] - - + aDuration [ - "Answer a Duration that is the sum of the receiver and aDuration's - lengths." - - - ^Duration fromSeconds: self asSeconds + aDuration asSeconds - ] - - - aDuration [ - "Answer a Duration that is the difference of the receiver and aDuration's - lengths." - - - ^Duration fromSeconds: self asSeconds - aDuration asSeconds - ] - - isZero [ - "Answer whether the receiver correspond to a duration of zero seconds." - - - ^self asSeconds = 0 - ] - - abs [ - "Answer a Duration that is as long as the receiver, but always in - the future." - - - ^Duration fromSeconds: self asSeconds abs - ] - - days [ - "Answer the number of days in the receiver" - - - ^self asSeconds quo: 86400 - ] - - negated [ - "Answer a Duration that is as long as the receiver, but with past and - future exchanged." - - - ^Duration fromSeconds: self asSeconds negated - ] - - storeOn: aStream [ - "Store on aStream Smalltalk code compiling to the receiver" - - - aStream - nextPut: $(; - nextPutAll: self class storeString; - nextPutAll: ' days: '; - store: self days; - nextPutAll: ' hours: '; - store: self hours; - nextPutAll: ' minutes: '; - store: self minutes; - nextPutAll: ' seconds: '; - store: self seconds; - nextPut: $) - ] - - negative [ - "Answer whether the receiver is in the past." - - - ^self asSeconds < 0 - ] - - positive [ - "Answer whether the receiver is a zero-second duration or is - in the future." - - - ^self asSeconds >= 0 - ] - - printOn: aStream [ - "Print a represention of the receiver on aStream." - - - self negative - ifTrue: - [aStream - nextPut: $-; - print: self negated. - ^self]. - aStream - print: self days; - nextPut: $:; - next: (self hours < 10 ifTrue: [1] ifFalse: [0]) put: $0; - print: self hours; - nextPut: $:; - next: (self minutes < 10 ifTrue: [1] ifFalse: [0]) put: $0; - print: self minutes; - nextPut: $:; - next: (self seconds < 10 ifTrue: [1] ifFalse: [0]) put: $0; - print: self seconds - ] - - setSeconds: secs [ - - seconds := secs - ] - - wait [ - "Answer a Delay waiting for the amount of time represented - by the receiver and start waiting on it." - - ^(Delay forMilliseconds: self asSeconds * 1000) wait - ] -] - - - -Eval [ - Duration initialize -] - diff --git a/kernel/DeferBinding.st b/kernel/DeferredVariableBinding.st similarity index 100% rename from kernel/DeferBinding.st rename to kernel/DeferredVariableBinding.st diff --git a/kernel/DirMessage.st b/kernel/DirectedMessage.st similarity index 100% rename from kernel/DirMessage.st rename to kernel/DirectedMessage.st diff --git a/kernel/Duration.st b/kernel/Duration.st new file mode 100644 index 00000000..cdee68f6 --- /dev/null +++ b/kernel/Duration.st @@ -0,0 +1,261 @@ +"====================================================================== +| +| Duration Method Definitions +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2000, 2001, 2002, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + +Time subclass: Duration [ + + + + + Zero := nil. + + Duration class >> fromDays: days seconds: secs offset: unused [ + "Answer a duration of `d' days and `secs' seconds. The last + parameter is unused; this message is available for interoperability + with the DateTime class." + + + ^self fromSeconds: days * 86400 + secs + ] + + Duration class >> milliseconds: msec [ + "Answer a duration of `msec' milliseconds" + + + ^self fromSeconds: msec / 1000 + ] + + Duration class >> weeks: w [ + "Answer a duration of `w' weeks" + + + ^self fromSeconds: w * ##(86400 * 7) + ] + + Duration class >> days: d [ + "Answer a duration of `d' days" + + + ^self fromSeconds: d * 86400 + ] + + Duration class >> days: d hours: h minutes: m seconds: s [ + "Answer a duration of `d' days and the given number of hours, + minutes, and seconds." + + + ^self fromSeconds: ((d * 24 + h) * 60 + m) * 60 + s + ] + + Duration class >> readFrom: aStream [ + "Parse an instance of the receiver (hours/minutes/seconds) from + aStream" + + + | sign sec hms i ch ws | + hms := {0. 0. 0}. + sign := (aStream peekFor: $-) + ifTrue: [-1] + ifFalse: [aStream peekFor: $+. 1]. + i := 1. + ch := $:. + [aStream atEnd not and: [ch isSeparator not and: [ + ch ~= $+ and: [ch ~= $- and: [ + i > 1 ifTrue: [aStream next]. + i <= 4 and: [(ch := aStream peek) isDigit]]]]]] whileTrue: [ + ws := WriteStream on: (String new: 10). + [ws nextPut: aStream next. + aStream atEnd not and: [(ch := aStream peek) isDigit]] whileTrue. + i = 4 + ifTrue: [ + hms := { + (hms at: 1) * 24 + (hms at: 2). + hms at: 3. + ws contents asNumber}] + ifFalse: [ + hms at: i put: ws contents asNumber]. + i := i + 1]. + sec := ((hms at: 1) * 3600 + ((hms at: 2) * 60) + (hms at: 3)) * sign. + ^self fromSeconds: sec + ] + + Duration class >> initialize [ + "Initialize the receiver's instance variables" + + + Zero := self new + ] + + Duration class >> zero [ + "Answer a duration of zero seconds." + + + ^Zero + ] + + * factor [ + "Answer a Duration that is `factor' times longer than the receiver" + + + ^Duration fromSeconds: self asSeconds * factor + ] + + / factorOrDuration [ + "If the parameter is a Duration, answer the ratio between the receiver + and factorOrDuration. Else divide the receiver by factorOrDuration (a + Number) and answer a new Duration that is correspondingly shorter." + + + ^factorOrDuration isNumber + ifFalse: [self asSeconds / factorOrDuration asSeconds] + ifTrue: [Duration fromSeconds: self asSeconds / factorOrDuration] + ] + + + aDuration [ + "Answer a Duration that is the sum of the receiver and aDuration's + lengths." + + + ^Duration fromSeconds: self asSeconds + aDuration asSeconds + ] + + - aDuration [ + "Answer a Duration that is the difference of the receiver and aDuration's + lengths." + + + ^Duration fromSeconds: self asSeconds - aDuration asSeconds + ] + + isZero [ + "Answer whether the receiver correspond to a duration of zero seconds." + + + ^self asSeconds = 0 + ] + + abs [ + "Answer a Duration that is as long as the receiver, but always in + the future." + + + ^Duration fromSeconds: self asSeconds abs + ] + + days [ + "Answer the number of days in the receiver" + + + ^self asSeconds quo: 86400 + ] + + negated [ + "Answer a Duration that is as long as the receiver, but with past and + future exchanged." + + + ^Duration fromSeconds: self asSeconds negated + ] + + storeOn: aStream [ + "Store on aStream Smalltalk code compiling to the receiver" + + + aStream + nextPut: $(; + nextPutAll: self class storeString; + nextPutAll: ' days: '; + store: self days; + nextPutAll: ' hours: '; + store: self hours; + nextPutAll: ' minutes: '; + store: self minutes; + nextPutAll: ' seconds: '; + store: self seconds; + nextPut: $) + ] + + negative [ + "Answer whether the receiver is in the past." + + + ^self asSeconds < 0 + ] + + positive [ + "Answer whether the receiver is a zero-second duration or is + in the future." + + + ^self asSeconds >= 0 + ] + + printOn: aStream [ + "Print a represention of the receiver on aStream." + + + self negative + ifTrue: + [aStream + nextPut: $-; + print: self negated. + ^self]. + aStream + print: self days; + nextPut: $:; + next: (self hours < 10 ifTrue: [1] ifFalse: [0]) put: $0; + print: self hours; + nextPut: $:; + next: (self minutes < 10 ifTrue: [1] ifFalse: [0]) put: $0; + print: self minutes; + nextPut: $:; + next: (self seconds < 10 ifTrue: [1] ifFalse: [0]) put: $0; + print: self seconds + ] + + setSeconds: secs [ + + seconds := secs + ] + + wait [ + "Answer a Delay waiting for the amount of time represented + by the receiver and start waiting on it." + + ^(Delay forMilliseconds: self asSeconds * 1000) wait + ] +] + + + +Eval [ + Duration initialize +] + diff --git a/kernel/DynVariable.st b/kernel/DynamicVariable.st similarity index 100% rename from kernel/DynVariable.st rename to kernel/DynamicVariable.st diff --git a/kernel/FileDescr.st b/kernel/FileDescriptor.st similarity index 100% rename from kernel/FileDescr.st rename to kernel/FileDescriptor.st diff --git a/kernel/Getopt.st b/kernel/Getopt.st index dd6b7aaa..503dcbd7 100644 --- a/kernel/Getopt.st +++ b/kernel/Getopt.st @@ -356,67 +356,3 @@ to parse command lines from Smalltalk.'> ] ] - - -SystemDictionary extend [ - - arguments: pattern do: actionBlock [ - "Parse the command-line arguments according to the syntax specified in - pattern. For every command-line option found, the two-argument block - actionBlock is evaluated passing the option name and the argument. For - file names (or in general, other command-line arguments than options) the - block's first argument will be nil. For options without arguments, or with - unspecified optional arguments, the block's second argument will be nil. - The option name will be passed as a character object for short options, - and as a string for long options. - - If an error is found, nil is returned. For more information on the syntax - of pattern, see #arguments:do:ifError:." - - - Getopt - parse: self arguments - with: pattern - do: actionBlock - ifError: [^nil] - ] - - arguments: pattern do: actionBlock ifError: errorBlock [ - "Parse the command-line arguments according to the syntax specified in - pattern. For every command-line option found, the two-argument block - actionBlock is evaluated passing the option name and the argument. For - file names (or in general, other command-line arguments than options) the - block's first argument will be nil. For options without arguments, or with - unspecified optional arguments, the block's second argument will be nil. - The option name will be passed as a character object for short options, - and as a string for long options. - - If an error is found, the parsing is interrupted, errorBlock is evaluated, - and the returned value is answered. - - Every whitespace-separated part (`word') of pattern specifies a command-line - option. If a word ends with a colon, the option will have a mandatory argument. - If a word ends with two colons, the option will have an optional argument. - Before the colons, multiple option names (either short names like `-l' or - long names like `--long') can be specified. Before passing the option to - actionBlock, the name will be canonicalized to the last one. - - Prefixes of long options are accepted as long as they're unique, and they are - canonicalized to the full name before passing it to actionBlock. Additionally, - the full name of an option is accepted even if it is the prefix of a longer - option. - - Mandatory arguments can appear in the next argument, or in the same argument - (separated by an = for arguments to long options). Optional arguments must - appear in the same argument." - - - Getopt - parse: self arguments - with: pattern - do: actionBlock - ifError: [^errorBlock value] - ] - -] - diff --git a/kernel/GetoptExtensions.st b/kernel/GetoptExtensions.st new file mode 100644 index 00000000..54dcf0b0 --- /dev/null +++ b/kernel/GetoptExtensions.st @@ -0,0 +1,95 @@ +"====================================================================== +| +| Smalltalk command-line parser +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2006 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +SystemDictionary extend [ + + arguments: pattern do: actionBlock [ + "Parse the command-line arguments according to the syntax specified in + pattern. For every command-line option found, the two-argument block + actionBlock is evaluated passing the option name and the argument. For + file names (or in general, other command-line arguments than options) the + block's first argument will be nil. For options without arguments, or with + unspecified optional arguments, the block's second argument will be nil. + The option name will be passed as a character object for short options, + and as a string for long options. + + If an error is found, nil is returned. For more information on the syntax + of pattern, see #arguments:do:ifError:." + + + Getopt + parse: self arguments + with: pattern + do: actionBlock + ifError: [^nil] + ] + + arguments: pattern do: actionBlock ifError: errorBlock [ + "Parse the command-line arguments according to the syntax specified in + pattern. For every command-line option found, the two-argument block + actionBlock is evaluated passing the option name and the argument. For + file names (or in general, other command-line arguments than options) the + block's first argument will be nil. For options without arguments, or with + unspecified optional arguments, the block's second argument will be nil. + The option name will be passed as a character object for short options, + and as a string for long options. + + If an error is found, the parsing is interrupted, errorBlock is evaluated, + and the returned value is answered. + + Every whitespace-separated part (`word') of pattern specifies a command-line + option. If a word ends with a colon, the option will have a mandatory argument. + If a word ends with two colons, the option will have an optional argument. + Before the colons, multiple option names (either short names like `-l' or + long names like `--long') can be specified. Before passing the option to + actionBlock, the name will be canonicalized to the last one. + + Prefixes of long options are accepted as long as they're unique, and they are + canonicalized to the full name before passing it to actionBlock. Additionally, + the full name of an option is accepted even if it is the prefix of a longer + option. + + Mandatory arguments can appear in the next argument, or in the same argument + (separated by an = for arguments to long options). Optional arguments must + appear in the same argument." + + + Getopt + parse: self arguments + with: pattern + do: actionBlock + ifError: [^errorBlock value] + ] + +] + diff --git a/kernel/HashedColl.st b/kernel/HashedCollection.st similarity index 100% rename from kernel/HashedColl.st rename to kernel/HashedCollection.st diff --git a/kernel/HomedAssoc.st b/kernel/HomedAssociation.st similarity index 100% rename from kernel/HomedAssoc.st rename to kernel/HomedAssociation.st diff --git a/kernel/IdentDict.st b/kernel/IdentityDictionary.st similarity index 100% rename from kernel/IdentDict.st rename to kernel/IdentityDictionary.st diff --git a/kernel/LargeArray.st b/kernel/LargeArray.st new file mode 100644 index 00000000..18e25b40 --- /dev/null +++ b/kernel/LargeArray.st @@ -0,0 +1,47 @@ +"===================================================================== +| +| Variations on the Array class +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2001, 2002, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +LargeArrayedCollection subclass: LargeArray [ + + + + + newCollection: size [ + "Create an Array of the given size" + + + ^Array new: size + ] +] diff --git a/kernel/LargeArraySubpart.st b/kernel/LargeArraySubpart.st new file mode 100644 index 00000000..ee9e80c7 --- /dev/null +++ b/kernel/LargeArraySubpart.st @@ -0,0 +1,192 @@ +"===================================================================== +| +| Variations on the Array class +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2001, 2002, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Namespace current: Kernel [ + +Magnitude subclass: LargeArraySubpart [ + | first last index | + + + + + LargeArraySubpart class >> first: first last: last index: index [ + "Answer a LargeArraySubpart which answers first, last, and index + when it is sent (respectively) #first, #last and #firstIndex." + + + ^self new + first: first + last: last + index: index + ] + + < anObject [ + "Answer whether the receiver points to a part of the array that + is before anObject (this makes sense only if the receiver and + anObject are two LargeArraySubparts referring to the same + LargeArrayedCollection)." + + + ^self first < anObject first + ] + + <= anObject [ + "Answer whether the receiver points to a part of the array that + is before anObject or starts at the same point (this makes sense + only if the receiver and anObject are two LargeArraySubparts + referring to the same LargeArrayedCollection)." + + + ^self first <= anObject first + ] + + = anObject [ + "Answer whether the receiver and anObject are equal (assuming that + the receiver and anObject are two LargeArraySubparts + referring to the same LargeArrayedCollection, which the receiver + cannot check for)." + + + ^self first = anObject first + ] + + hash [ + "Answer an hash value for the receiver" + + + ^self first hash + ] + + first: firstIndex last: lastIndex index: storagePosition [ + "Set up the receiver so that it answers first, last, and index + when it is sent (respectively) #first, #last and #firstIndex." + + + first := firstIndex. + last := lastIndex. + index := storagePosition + ] + + first [ + "Answer the index of the first item of the LargeArrayedCollection + that the receiver refers to." + + + ^first + ] + + last [ + "Answer the index of the last item of the LargeArrayedCollection + that the receiver refers to." + + + ^last + ] + + firstIndex [ + "Answer the index in the collection's storage object of the first + item of the LargeArrayedCollection that the receiver refers to." + + + ^index + ] + + lastIndex [ + "Answer the index in the collection's storage object of the last + item of the LargeArrayedCollection that the receiver refers to." + + + ^index + last - first + ] + + cutAt: position [ + "Answer a new LargeArraySubpart whose lastIndex is position - 1, + and apply a #removeFirst: to the receiver so that the firstIndex + becomes position" + + + | newPart newFirst | + newFirst := first + (position - index). + newPart := self class + first: first + last: newFirst - 1 + index: index. + first := newFirst. + index := position. + ^newPart + ] + + grow [ + "Add one to last and lastIndex" + + + last := last + 1 + ] + + growBy: numberOfElements [ + "Add numberOfElements to last and lastIndex" + + + last := last + numberOfElements + ] + + relocateTo: position [ + "Move the firstIndex to position, and the lastIndex accordingly." + + + index := position + ] + + removeFirst: n [ + "Sum n to first and firstIndex, but leave last/lastIndex untouched" + + + first := first + n. + index := index + n + ] + + removeLast: n [ + "Subtract n from last and lastIndex, but leave first/firstIndex untouched" + + + last := last - n + ] +] + +] diff --git a/kernel/OtherArrays.st b/kernel/LargeArrayedCollection.st similarity index 59% rename from kernel/OtherArrays.st rename to kernel/LargeArrayedCollection.st index ee2f718e..1416b33b 100644 --- a/kernel/OtherArrays.st +++ b/kernel/LargeArrayedCollection.st @@ -30,187 +30,6 @@ ======================================================================" - -ArrayedCollection subclass: WordArray [ - - - - - - at: anIndex ifAbsent: aBlock [ - "Answer the index-th indexed instance variable of the receiver" - - - - ^self checkIndexableBounds: anIndex ifAbsent: aBlock - ] - -] - - - -Namespace current: Kernel [ - -Magnitude subclass: LargeArraySubpart [ - | first last index | - - - - - LargeArraySubpart class >> first: first last: last index: index [ - "Answer a LargeArraySubpart which answers first, last, and index - when it is sent (respectively) #first, #last and #firstIndex." - - - ^self new - first: first - last: last - index: index - ] - - < anObject [ - "Answer whether the receiver points to a part of the array that - is before anObject (this makes sense only if the receiver and - anObject are two LargeArraySubparts referring to the same - LargeArrayedCollection)." - - - ^self first < anObject first - ] - - <= anObject [ - "Answer whether the receiver points to a part of the array that - is before anObject or starts at the same point (this makes sense - only if the receiver and anObject are two LargeArraySubparts - referring to the same LargeArrayedCollection)." - - - ^self first <= anObject first - ] - - = anObject [ - "Answer whether the receiver and anObject are equal (assuming that - the receiver and anObject are two LargeArraySubparts - referring to the same LargeArrayedCollection, which the receiver - cannot check for)." - - - ^self first = anObject first - ] - - hash [ - "Answer an hash value for the receiver" - - - ^self first hash - ] - - first: firstIndex last: lastIndex index: storagePosition [ - "Set up the receiver so that it answers first, last, and index - when it is sent (respectively) #first, #last and #firstIndex." - - - first := firstIndex. - last := lastIndex. - index := storagePosition - ] - - first [ - "Answer the index of the first item of the LargeArrayedCollection - that the receiver refers to." - - - ^first - ] - - last [ - "Answer the index of the last item of the LargeArrayedCollection - that the receiver refers to." - - - ^last - ] - - firstIndex [ - "Answer the index in the collection's storage object of the first - item of the LargeArrayedCollection that the receiver refers to." - - - ^index - ] - - lastIndex [ - "Answer the index in the collection's storage object of the last - item of the LargeArrayedCollection that the receiver refers to." - - - ^index + last - first - ] - - cutAt: position [ - "Answer a new LargeArraySubpart whose lastIndex is position - 1, - and apply a #removeFirst: to the receiver so that the firstIndex - becomes position" - - - | newPart newFirst | - newFirst := first + (position - index). - newPart := self class - first: first - last: newFirst - 1 - index: index. - first := newFirst. - index := position. - ^newPart - ] - - grow [ - "Add one to last and lastIndex" - - - last := last + 1 - ] - - growBy: numberOfElements [ - "Add numberOfElements to last and lastIndex" - - - last := last + numberOfElements - ] - - relocateTo: position [ - "Move the firstIndex to position, and the lastIndex accordingly." - - - index := position - ] - - removeFirst: n [ - "Sum n to first and firstIndex, but leave last/lastIndex untouched" - - - first := first + n. - index := index + n - ] - - removeLast: n [ - "Subtract n from last and lastIndex, but leave first/firstIndex untouched" - - - last := last - n - ] -] - -] - - ArrayedCollection subclass: LargeArrayedCollection [ | storage indices position size | @@ -498,79 +317,3 @@ memory when lots of items have the same value.'> position := -1 ] ] - - - -LargeArrayedCollection subclass: LargeArray [ - - - - - newCollection: size [ - "Create an Array of the given size" - - - ^Array new: size - ] -] - - - -LargeArrayedCollection subclass: LargeByteArray [ - - - - - costOfNewIndex [ - "Answer the maximum number of consecutive items set to the defaultElement - that can be present in a compressed array." - - "### Should be 40 on 64-bit machines (super costOfNewIndex * CLong sizeof)" - - - ^20 - ] - - defaultElement [ - "Answer the value which is hoped to be the most common in the array" - - - ^0 - ] - - newCollection: size [ - "Create a ByteArray of the given size" - - - ^ByteArray new: size - ] -] - - - -LargeArrayedCollection subclass: LargeWordArray [ - - - - - defaultElement [ - "Answer the value which is hoped to be the most common in the array" - - - ^0 - ] - - newCollection: size [ - "Create a WordArray of the given size" - - - ^WordArray new: size - ] -] - diff --git a/kernel/LargeByteArray.st b/kernel/LargeByteArray.st new file mode 100644 index 00000000..1e2bbf58 --- /dev/null +++ b/kernel/LargeByteArray.st @@ -0,0 +1,65 @@ +"===================================================================== +| +| Variations on the Array class +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2001, 2002, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +LargeArrayedCollection subclass: LargeByteArray [ + + + + + costOfNewIndex [ + "Answer the maximum number of consecutive items set to the defaultElement + that can be present in a compressed array." + + "### Should be 40 on 64-bit machines (super costOfNewIndex * CLong sizeof)" + + + ^20 + ] + + defaultElement [ + "Answer the value which is hoped to be the most common in the array" + + + ^0 + ] + + newCollection: size [ + "Create a ByteArray of the given size" + + + ^ByteArray new: size + ] +] + diff --git a/kernel/LargeInt.st b/kernel/LargeInteger.st similarity index 51% rename from kernel/LargeInt.st rename to kernel/LargeInteger.st index f8c5296b..3abba31e 100644 --- a/kernel/LargeInt.st +++ b/kernel/LargeInteger.st @@ -762,874 +762,3 @@ to speed them up a bit.'> ] ] - - -LargeInteger subclass: LargeNegativeInteger [ - - - - - - + aNumber [ - "Sum the receiver and aNumber, answer the result" - - "All we have to do is convert the two numbers to two positive - numbers and make LargePositiveInteger do the calculation. - Use #largeNegated to save some coercions." - - - - aNumber sign = 0 ifTrue: [^self]. - aNumber generality = self generality - ifFalse: [^self retrySumCoercing: aNumber]. - ^aNumber sign = -1 - ifTrue: [(self largeNegated + aNumber largeNegated) negated] - ifFalse: [(self largeNegated - aNumber) negated] - ] - - - aNumber [ - "Subtract aNumber from the receiver, answer the result" - - "All we have to do is convert the two numbers to two positive - numbers and make LargePositiveInteger do the calculation. - Use #largeNegated to save some coercions." - - - - aNumber sign = 0 ifTrue: [^self]. - aNumber generality = self generality - ifFalse: [^self retryDifferenceCoercing: aNumber]. - ^aNumber sign = -1 - ifTrue: [(self largeNegated - aNumber largeNegated) negated] - ifFalse: [(self largeNegated + aNumber) negated] - ] - - highBit [ - "Answer the receiver's highest bit's index" - - - ^(self at: self size) = 255 - ifTrue: [^8 * self size - 16 + ((self at: self size - 1) - 256) highBit] - ifFalse: [^8 * self size - 8 + ((self at: self size) - 256) highBit] - ] - - gcd: anInteger [ - "Return the greatest common divisor between the receiver and anInteger" - - - - ^self negated gcd: anInteger abs - ] - - positive [ - "Answer whether the receiver is >= 0" - - - ^false - ] - - strictlyPositive [ - "Answer whether the receiver is > 0" - - - ^false - ] - - negative [ - "Answer whether the receiver is < 0" - - - ^true - ] - - abs [ - "Answer the receiver's absolute value." - - "This is surely a large integer (while `aLargePositiveInteger negated' - might be the smallest small integer)." - - - - ^self largeNegated - ] - - sign [ - "Answer the receiver's sign" - - - ^-1 - ] - - asFloatD [ - "Answer the receiver converted to a FloatD" - - - ^self negated asFloatD negated - ] - - asFloatE [ - "Answer the receiver converted to a FloatE" - - - ^self negated asFloatE negated - ] - - asFloatQ [ - "Answer the receiver converted to a FloatQ" - - - ^self negated asFloatQ negated - ] - - mostSignificantByte [ - "Private - Answer the value of the most significant byte" - - - ^255 - ] -] - - - -LargeInteger subclass: LargePositiveInteger [ - - - - - - + aNumber [ - "Sum the receiver and aNumber, answer the result" - - - | newBytes carry a b result | - - aNumber sign = 0 ifTrue: [^self]. - aNumber sign = -1 ifTrue: [^self - aNumber negated]. - aNumber generality = self generality - ifFalse: [^self retrySumCoercing: aNumber]. - newBytes := ByteArray new: (self size max: aNumber size) + 1. - carry := 0. - 1 to: newBytes size - 1 - do: - [:index | - result := (self at: index) + (aNumber at: index) + carry. - result > 255 - ifTrue: - [carry := 1. - result := result - 256] - ifFalse: [carry := 0]. - newBytes at: index put: result]. - newBytes at: newBytes size put: carry. - ^LargeInteger resultFrom: newBytes - ] - - - aNumber [ - "Subtract aNumber from the receiver, answer the result" - - - | newBytes carry a b result | - - aNumber sign = 0 ifTrue: [^self]. - aNumber sign = -1 ifTrue: [^self + aNumber negated]. - aNumber generality = self generality - ifFalse: [^self retryDifferenceCoercing: aNumber]. - newBytes := ByteArray new: (self size max: aNumber size) + 1. - carry := 0. - 1 to: newBytes size - 1 - do: - [:index | - result := (self at: index) - (aNumber at: index) + carry. - result < 0 - ifTrue: - [carry := -1. - result := result + 256] - ifFalse: [carry := 0]. - newBytes at: index put: result]. - newBytes at: newBytes size put: (carry bitAnd: 255). - ^LargeInteger resultFrom: newBytes - ] - - gcd: anInteger [ - "Calculate the GCD between the receiver and anInteger" - - "Binary GCD - See Knuth `Seminumerical algorithms', Vol 2, 4.5.2 - It was adapted to remove the variable `r' and to only work with - unsigned numbers" - - - | adjust t tmp u v | - - (self sign bitAnd: anInteger sign) = 0 ifTrue: [^self + anInteger]. - u := self bytes. - v := anInteger abs. - v generality = self generality ifFalse: [v := self coerce: v]. - v := v bytes. - - "Divide u and v by 2 as long as they are both even" - adjust := t := self bytesTrailingZeros: u. - self bytesRightShift: u big: t. - adjust := adjust min: (t := self bytesTrailingZeros: v). - self bytesRightShift: v big: t. - u size = v size - ifFalse: - [u size < v size - ifTrue: [u := u copyGrowTo: v size] - ifFalse: [v := v copyGrowTo: u size]]. - - "Well, this is it -- the stuff up to this point was just set up" - - [t := self - bytes: u - from: 1 - compare: v. - t = 0] - whileFalse: - [t < 0 - ifTrue: - [t := v. - v := u. - u := t]. - self - bytes: u - from: 1 - subtract: v. - ((u at: 1) bitAnd: 1) = 0 - ifTrue: - [t := self bytesTrailingZeros: u. - self bytesRightShift: u big: t]]. - self bytesLeftShift: u big: adjust. - ^self species resultFrom: u - ] - - highBit [ - "Answer the receiver's highest bit's index" - - - ^(self at: self size) = 0 - ifTrue: [^8 * self size - 8 - (LeadingZeros at: (self at: self size - 1))] - ifFalse: [^8 * self size - (LeadingZeros at: (self at: self size))] - ] - - positive [ - "Answer whether the receiver is >= 0" - - - ^true - ] - - strictlyPositive [ - "Answer whether the receiver is > 0" - - - ^true - ] - - negative [ - "Answer whether the receiver is < 0" - - - ^false - ] - - abs [ - "Answer the receiver's absolute value" - - - ^self - ] - - sign [ - "Answer the receiver's sign" - - - ^1 - ] - - asFloat: characterization [ - "Answer the receiver converted to a Float" - - - "Check for number bigger than maximum mantissa" - - | nTruncatedBits mantissa exponent mask trailingBits inexact carry | - nTruncatedBits := self highBit - characterization precision. - nTruncatedBits <= 0 ifTrue: [^self fastAsFloat: characterization]. - mantissa := self bitShift: nTruncatedBits negated. - exponent := nTruncatedBits. - - "Apply IEEE 754 round to nearest even default rounding mode" - carry := self bitAt: nTruncatedBits. - (carry = 1 and: [mantissa odd or: [self lowBit < nTruncatedBits]]) - ifTrue: [mantissa := mantissa + 1]. - ^(characterization coerce: mantissa) timesTwoPower: exponent - ] - - fastAsFloat: characterization [ - "Conversion can be exact, construct Float by successive mul add operations" - - - | result byte | - byte := characterization coerce: 256. - result := characterization coerce: 0. - self size to: 1 - by: -1 - do: [:index | result := result * byte + (self at: index)]. - ^result - ] - - mostSignificantByte [ - "Private - Answer the value of the most significant byte" - - - ^0 - ] - - asFloatD [ - "Answer the receiver converted to a FloatD" - - - - ^self asFloat: FloatD - ] - - asFloatE [ - "Answer the receiver converted to a FloatE" - - - - ^self asFloat: FloatE - ] - - asFloatQ [ - "Answer the receiver converted to a FloatQ" - - - - ^self asFloat: FloatQ - ] - - replace: str withStringBase: radix [ - "Return in a String str the base radix representation of the - receiver." - - - | digits source quo t rem where | - source := self. - quo := ByteArray new: self size. - where := str size. - self size to: 1 - by: -1 - do: - [:i | - - [rem := 0. - i to: 1 - by: -1 - do: - [:j | - t := (rem bitShift: 8) + (source at: j). - quo at: j put: t // radix. - rem := t \\ radix]. - str at: where put: (Character digitValue: rem). - where := where - 1. - source := quo. - (source at: i) = 0] - whileFalse]. - ^str - ] - - isSmall [ - "Private - Answer whether the receiver is small enough to employ simple - scalar algorithms for division and multiplication" - - - ^self size <= 2 and: [(self at: 2) = 0] - ] - - divide: aNumber using: aBlock [ - "Private - Divide the receiver by aNumber (unsigned division). Evaluate - aBlock passing the result ByteArray, the remainder ByteArray, and - whether the division had a remainder" - - - | result a b | - aNumber isSmall - ifTrue: - [result := ByteArray new: self size. - b := 0. - self size to: 1 - by: -1 - do: - [:j | - a := (b bitShift: 8) + (self at: j). - result at: j put: a // (aNumber at: 1). - b := a \\ (aNumber at: 1)]. - ^aBlock - value: result - value: (ByteArray with: b with: 0) - value: b ~= 0]. - - "special case: numerator < denominator" - self size < aNumber size - ifTrue: - [^aBlock - value: ZeroBytes - value: self - value: true]. - self size > aNumber size - ifTrue: - [result := self primDivide: aNumber. - ^aBlock - value: result key - value: result value - value: (result value anySatisfy: [:each | each ~= 0])]. - self size to: 1 - by: -1 - do: - [:index | - a := self at: index. - b := aNumber at: index. - b > a - ifTrue: - [^aBlock - value: ZeroBytes - value: self - value: true]. - a > b - ifTrue: - [result := self primDivide: aNumber. - ^aBlock - value: result key - value: result value - value: (result value anySatisfy: [:each | each ~= 0])]]. - "Special case: numerator = denominator" - ^aBlock - value: OneBytes - value: ZeroBytes - value: false - ] - - multiply: aNumber [ - "Private - Multiply the receiver by aNumber (unsigned multiply)" - - - "Special case - other factor < 255" - - | newBytes byte carry index digit start | - aNumber isSmall - ifTrue: - [^self species from: (self bytes: self bytes multiply: (aNumber at: 1))]. - start := 1. - [(aNumber at: start) = 0] whileTrue: [start := start + 1]. - newBytes := ByteArray new: self size + aNumber size + 2. - 1 to: self size - do: - [:indexA | - digit := self at: indexA. - digit = 0 - ifFalse: - [carry := 0. - index := indexA + start - 1. - start to: aNumber size - do: - [:indexB | - byte := digit * (aNumber at: indexB) + carry + (newBytes at: index). - carry := byte bitShift: -8. - newBytes at: index put: (byte bitAnd: 255). - index := index + 1]. - newBytes at: indexA + aNumber size put: carry]]. - "If I multiply two large integers, the result is large, so use #from:..." - ^self species from: newBytes - ] - - bytes: bytes multiply: anInteger [ - "Private - Multiply the bytes in bytes by anInteger, which must be < 255. - Put the result back in bytes." - - - | byte carry | - carry := 0. - 1 to: bytes size - do: - [:index | - byte := (bytes at: index) * anInteger + carry. - carry := byte bitShift: -8. - bytes at: index put: (byte bitAnd: 255)]. - carry > 0 ifTrue: [bytes at: bytes size - 1 put: carry]. - ^bytes - ] - - bytes: byteArray1 from: j compare: byteArray2 [ - "Private - Answer the sign of byteArray2 - byteArray1; the - j-th byte of byteArray1 is compared with the first of byteArray2, - the j+1-th with the second, and so on." - - - | a b i | - i := byteArray2 size. - j + byteArray2 size - 1 to: j - by: -1 - do: - [:index | - b := byteArray2 at: i. - a := byteArray1 at: index. - a < b ifTrue: [^-1]. - a > b ifTrue: [^1]. - i := i - 1]. - ^0 - ] - - bytes: byteArray1 from: j subtract: byteArray2 [ - "Private - Sutract the bytes in byteArray2 from those in byteArray1" - - - | carry a i | - carry := 256. - i := 1. - j to: j + byteArray2 size - 1 - do: - [:index | - a := (byteArray1 at: index) - (byteArray2 at: i) + carry. - a < 256 - ifTrue: [carry := 255] - ifFalse: - [carry := 256. - a := a - 256]. - byteArray1 at: index put: a. - i := i + 1] - ] - - bytesLeftShift: aByteArray [ - "Private - Left shift by 1 place the bytes in aByteArray" - - - | carry a | - carry := 0. - 1 to: aByteArray size - do: - [:index | - a := aByteArray at: index. - a := a + a + carry. - carry := a bitShift: -8. - a := a bitAnd: 255. - aByteArray at: index put: a] - ] - - bytesLeftShift: aByteArray n: shift [ - "Private - Left shift by shift places the bytes in aByteArray - (shift <= 7)" - - - | carry a | - carry := 0. - 1 to: aByteArray size - do: - [:index | - a := aByteArray at: index. - a := (a bitShift: shift) + carry. - carry := a bitShift: -8. - aByteArray at: index put: (a bitAnd: 255)] - ] - - bytesLeftShift: aByteArray big: totalShift [ - "Private - Left shift the bytes in aByteArray by totalShift places" - - - | newBytes byteShift shift a last | - totalShift = 0 ifTrue: [^self]. - byteShift := totalShift // 8. - shift := totalShift bitAnd: 7. - last := 0. - aByteArray size - 1 to: byteShift + 1 - by: -1 - do: - [:index | - a := aByteArray at: index - byteShift. - a := a bitShift: shift. - aByteArray at: index + 1 put: last + (a bitShift: -8). - last := a bitAnd: 255]. - aByteArray at: byteShift + 1 put: last. - 1 to: byteShift do: [:i | aByteArray at: i put: 0] - ] - - bytesRightShift: aByteArray big: totalShift [ - "Private - Right shift the bytes in aByteArray by totalShift places" - - - | shift byteShift carryShift x a | - totalShift = 0 ifTrue: [^self]. - byteShift := totalShift // 8. - shift := (totalShift bitAnd: 7) negated. - carryShift := 8 + shift. - x := (aByteArray at: byteShift + 1) bitShift: shift. - byteShift + 2 to: aByteArray size - do: - [:j | - a := aByteArray at: j. - aByteArray at: j - byteShift - 1 - put: ((a bitShift: carryShift) bitAnd: 255) + x. - x := a bitShift: shift]. - aByteArray at: aByteArray size - byteShift put: x. - aByteArray size - byteShift + 1 to: aByteArray size - do: [:i | aByteArray at: i put: 0] - ] - - bytesRightShift: bytes n: aNumber [ - "Private - Right shift the bytes in `bytes' by 'aNumber' places - (shift <= 7)" - - - | shift carryShift x a | - aNumber = 0 ifTrue: [^self]. - shift := aNumber negated. - carryShift := 8 + shift. - x := (bytes at: 1) bitShift: shift. - 2 to: bytes size - do: - [:j | - a := bytes at: j. - bytes at: j - 1 put: ((a bitShift: carryShift) bitAnd: 255) + x. - x := a bitShift: shift]. - bytes at: bytes size put: x - ] - - bytesTrailingZeros: bytes [ - "Private - Answer the number of trailing zero bits in the receiver" - - - | each | - 1 to: bytes size - do: - [:index | - (each := bytes at: index) = 0 - ifFalse: [^index * 8 - 8 + (TrailingZeros at: each)]]. - ^bytes size * 8 - ] - - primDivide: rhs [ - "Private - Implements Knuth's divide and correct algorithm from - `Seminumerical Algorithms' 3rd Edition, section 4.3.1 (which - is basically an enhanced version of the divide `algorithm' for - two-digit divisors which is taught in primary school!!!)" - - - "Leading zeros in `v'" - - "Cached v at: n, v at: n - 1, j + n, j + n - 1" - - "Cached `u size - v size' and `v size'" - - "High 2 bytes of `u'" - - "guess times the divisor (v)" - - "Quotient" - - "guess at the quotient byte and remainder" - - "The operands" - - "0. Initialize everything" - - | d vn vn1 jn jn1 m n high sub q guess rem u v | - u := self bytes. - v := rhs bytes. - n := v size. - sub := ByteArray new: n. - m := u size - n. - q := ByteArray new: m + 2. - - "1. Normalize the divisor - Knuth's algorithm is based on an initial guess for the quotient. The - guess is guaranteed to be no more than 2 in error, if v[n] >= 128. - If we multiply both vectors by the same value, the result of division - remains the same, so we can always guarantee that v[n] is - sufficiently large. - While the algorithm calls for d to be 255 / v[n], we will set d to a - simple left shift count because this is fast and nicely approximates that" - [(v at: n) = 0] whileTrue: [n := n - 1]. - (v at: n) < 128 - ifFalse: [d := 0] - ifTrue: - ["Multiply each value by the normalizing value" - - d := LeadingZeros at: (v at: n). - self bytesLeftShift: u n: d. - self bytesLeftShift: v n: d]. - vn := v at: n. "Cache common values" - vn1 := v at: n - 1. - m + 1 to: 1 - by: -1 - do: - [:j | - jn := j + n. - jn1 := jn - 1. - - "2. Calculate the quotient `guess'. - Remember that our guess will be generated such that - guess - 2 <= quotient <= guess. Thus, we generate our first - guess at quotient, and keep decrementing by one until we have found - the real quotient." - high := (u at: jn) * 256 + (u at: jn1). - guess := high // vn. - rem := high \\ vn. - "(Array with: u with: high with: guess with: rem) printNl." - - "4. We know now that the quotient guess is most likely ok, but possibly - the real quotient is guess - 1 or guess - 2. Multiply the divisor by the - guess and compare the result with the dividend." - sub - replaceFrom: 1 - to: sub size - with: v - startingAt: 1. - self bytes: sub multiply: guess. - [(self - bytes: u - from: j - compare: sub) >= 0] - whileFalse: - ["Our guess was one off, so we need to readjust it by one and subtract - back the divisor (since we multiplied by one in excess)." - - guess := guess - 1. - self - bytes: sub - from: 1 - subtract: v]. - "(Array with: u with: sub with: guess with: rem) printNl." - - "Got another byte of the quotient" - self - bytes: u - from: j - subtract: sub. - q at: j put: guess]. - "Readjust the remainder" - self bytesRightShift: u n: d. - ^q -> u - ] -] - - - -LargePositiveInteger subclass: LargeZeroInteger [ - - - - - - size [ - - ^0 - ] - - hash [ - - ^0 - ] - - at: anIndex [ - - ^0 - ] - - strictlyPositive [ - "Answer whether the receiver is > 0" - - - ^false - ] - - sign [ - "Answer the receiver's sign" - - - ^0 - ] - - + aNumber [ - "Sum the receiver and aNumber, answer the result" - - - ^aNumber - ] - - - aNumber [ - "Subtract aNumber from the receiver, answer the result" - - - ^aNumber negated - ] - - * aNumber [ - "Multiply aNumber and the receiver, answer the result" - - - ^0 - ] - - / aNumber [ - "Divide aNumber and the receiver, answer the result (an Integer or - Fraction)" - - - ^0 - ] - - // aNumber [ - "Divide aNumber and the receiver, answer the result truncated towards - -infinity" - - - ^0 - ] - - rem: aNumber [ - "Divide aNumber and the receiver, answer the remainder truncated - towards 0" - - - ^0 - ] - - quo: aNumber [ - "Divide aNumber and the receiver, answer the result truncated - towards 0" - - - ^0 - ] - - \\ aNumber [ - "Divide aNumber and the receiver, answer the remainder truncated - towards -infinity" - - - ^0 - ] - - replace: str withStringBase: radix [ - "Return in a string the base radix representation of the receiver." - - - str at: str size put: $0. - ^str - ] -] - diff --git a/kernel/LargeNegativeInteger.st b/kernel/LargeNegativeInteger.st new file mode 100644 index 00000000..1752976c --- /dev/null +++ b/kernel/LargeNegativeInteger.st @@ -0,0 +1,161 @@ +"====================================================================== +| +| LargeInteger hierarchy Method Definitions +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1999, 2000, 2001, 2002, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +LargeInteger subclass: LargeNegativeInteger [ + + + + + + + aNumber [ + "Sum the receiver and aNumber, answer the result" + + "All we have to do is convert the two numbers to two positive + numbers and make LargePositiveInteger do the calculation. + Use #largeNegated to save some coercions." + + + + aNumber sign = 0 ifTrue: [^self]. + aNumber generality = self generality + ifFalse: [^self retrySumCoercing: aNumber]. + ^aNumber sign = -1 + ifTrue: [(self largeNegated + aNumber largeNegated) negated] + ifFalse: [(self largeNegated - aNumber) negated] + ] + + - aNumber [ + "Subtract aNumber from the receiver, answer the result" + + "All we have to do is convert the two numbers to two positive + numbers and make LargePositiveInteger do the calculation. + Use #largeNegated to save some coercions." + + + + aNumber sign = 0 ifTrue: [^self]. + aNumber generality = self generality + ifFalse: [^self retryDifferenceCoercing: aNumber]. + ^aNumber sign = -1 + ifTrue: [(self largeNegated - aNumber largeNegated) negated] + ifFalse: [(self largeNegated + aNumber) negated] + ] + + highBit [ + "Answer the receiver's highest bit's index" + + + ^(self at: self size) = 255 + ifTrue: [^8 * self size - 16 + ((self at: self size - 1) - 256) highBit] + ifFalse: [^8 * self size - 8 + ((self at: self size) - 256) highBit] + ] + + gcd: anInteger [ + "Return the greatest common divisor between the receiver and anInteger" + + + + ^self negated gcd: anInteger abs + ] + + positive [ + "Answer whether the receiver is >= 0" + + + ^false + ] + + strictlyPositive [ + "Answer whether the receiver is > 0" + + + ^false + ] + + negative [ + "Answer whether the receiver is < 0" + + + ^true + ] + + abs [ + "Answer the receiver's absolute value." + + "This is surely a large integer (while `aLargePositiveInteger negated' + might be the smallest small integer)." + + + + ^self largeNegated + ] + + sign [ + "Answer the receiver's sign" + + + ^-1 + ] + + asFloatD [ + "Answer the receiver converted to a FloatD" + + + ^self negated asFloatD negated + ] + + asFloatE [ + "Answer the receiver converted to a FloatE" + + + ^self negated asFloatE negated + ] + + asFloatQ [ + "Answer the receiver converted to a FloatQ" + + + ^self negated asFloatQ negated + ] + + mostSignificantByte [ + "Private - Answer the value of the most significant byte" + + + ^255 + ] +] diff --git a/kernel/LargePositiveInteger.st b/kernel/LargePositiveInteger.st new file mode 100644 index 00000000..af0b97a0 --- /dev/null +++ b/kernel/LargePositiveInteger.st @@ -0,0 +1,658 @@ +"====================================================================== +| +| LargeInteger hierarchy Method Definitions +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1999, 2000, 2001, 2002, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +LargeInteger subclass: LargePositiveInteger [ + + + + + + + aNumber [ + "Sum the receiver and aNumber, answer the result" + + + | newBytes carry a b result | + + aNumber sign = 0 ifTrue: [^self]. + aNumber sign = -1 ifTrue: [^self - aNumber negated]. + aNumber generality = self generality + ifFalse: [^self retrySumCoercing: aNumber]. + newBytes := ByteArray new: (self size max: aNumber size) + 1. + carry := 0. + 1 to: newBytes size - 1 + do: + [:index | + result := (self at: index) + (aNumber at: index) + carry. + result > 255 + ifTrue: + [carry := 1. + result := result - 256] + ifFalse: [carry := 0]. + newBytes at: index put: result]. + newBytes at: newBytes size put: carry. + ^LargeInteger resultFrom: newBytes + ] + + - aNumber [ + "Subtract aNumber from the receiver, answer the result" + + + | newBytes carry a b result | + + aNumber sign = 0 ifTrue: [^self]. + aNumber sign = -1 ifTrue: [^self + aNumber negated]. + aNumber generality = self generality + ifFalse: [^self retryDifferenceCoercing: aNumber]. + newBytes := ByteArray new: (self size max: aNumber size) + 1. + carry := 0. + 1 to: newBytes size - 1 + do: + [:index | + result := (self at: index) - (aNumber at: index) + carry. + result < 0 + ifTrue: + [carry := -1. + result := result + 256] + ifFalse: [carry := 0]. + newBytes at: index put: result]. + newBytes at: newBytes size put: (carry bitAnd: 255). + ^LargeInteger resultFrom: newBytes + ] + + gcd: anInteger [ + "Calculate the GCD between the receiver and anInteger" + + "Binary GCD - See Knuth `Seminumerical algorithms', Vol 2, 4.5.2 + It was adapted to remove the variable `r' and to only work with + unsigned numbers" + + + | adjust t tmp u v | + + (self sign bitAnd: anInteger sign) = 0 ifTrue: [^self + anInteger]. + u := self bytes. + v := anInteger abs. + v generality = self generality ifFalse: [v := self coerce: v]. + v := v bytes. + + "Divide u and v by 2 as long as they are both even" + adjust := t := self bytesTrailingZeros: u. + self bytesRightShift: u big: t. + adjust := adjust min: (t := self bytesTrailingZeros: v). + self bytesRightShift: v big: t. + u size = v size + ifFalse: + [u size < v size + ifTrue: [u := u copyGrowTo: v size] + ifFalse: [v := v copyGrowTo: u size]]. + + "Well, this is it -- the stuff up to this point was just set up" + + [t := self + bytes: u + from: 1 + compare: v. + t = 0] + whileFalse: + [t < 0 + ifTrue: + [t := v. + v := u. + u := t]. + self + bytes: u + from: 1 + subtract: v. + ((u at: 1) bitAnd: 1) = 0 + ifTrue: + [t := self bytesTrailingZeros: u. + self bytesRightShift: u big: t]]. + self bytesLeftShift: u big: adjust. + ^self species resultFrom: u + ] + + highBit [ + "Answer the receiver's highest bit's index" + + + ^(self at: self size) = 0 + ifTrue: [^8 * self size - 8 - (LeadingZeros at: (self at: self size - 1))] + ifFalse: [^8 * self size - (LeadingZeros at: (self at: self size))] + ] + + positive [ + "Answer whether the receiver is >= 0" + + + ^true + ] + + strictlyPositive [ + "Answer whether the receiver is > 0" + + + ^true + ] + + negative [ + "Answer whether the receiver is < 0" + + + ^false + ] + + abs [ + "Answer the receiver's absolute value" + + + ^self + ] + + sign [ + "Answer the receiver's sign" + + + ^1 + ] + + asFloat: characterization [ + "Answer the receiver converted to a Float" + + + "Check for number bigger than maximum mantissa" + + | nTruncatedBits mantissa exponent mask trailingBits inexact carry | + nTruncatedBits := self highBit - characterization precision. + nTruncatedBits <= 0 ifTrue: [^self fastAsFloat: characterization]. + mantissa := self bitShift: nTruncatedBits negated. + exponent := nTruncatedBits. + + "Apply IEEE 754 round to nearest even default rounding mode" + carry := self bitAt: nTruncatedBits. + (carry = 1 and: [mantissa odd or: [self lowBit < nTruncatedBits]]) + ifTrue: [mantissa := mantissa + 1]. + ^(characterization coerce: mantissa) timesTwoPower: exponent + ] + + fastAsFloat: characterization [ + "Conversion can be exact, construct Float by successive mul add operations" + + + | result byte | + byte := characterization coerce: 256. + result := characterization coerce: 0. + self size to: 1 + by: -1 + do: [:index | result := result * byte + (self at: index)]. + ^result + ] + + mostSignificantByte [ + "Private - Answer the value of the most significant byte" + + + ^0 + ] + + asFloatD [ + "Answer the receiver converted to a FloatD" + + + + ^self asFloat: FloatD + ] + + asFloatE [ + "Answer the receiver converted to a FloatE" + + + + ^self asFloat: FloatE + ] + + asFloatQ [ + "Answer the receiver converted to a FloatQ" + + + + ^self asFloat: FloatQ + ] + + replace: str withStringBase: radix [ + "Return in a String str the base radix representation of the + receiver." + + + | digits source quo t rem where | + source := self. + quo := ByteArray new: self size. + where := str size. + self size to: 1 + by: -1 + do: + [:i | + + [rem := 0. + i to: 1 + by: -1 + do: + [:j | + t := (rem bitShift: 8) + (source at: j). + quo at: j put: t // radix. + rem := t \\ radix]. + str at: where put: (Character digitValue: rem). + where := where - 1. + source := quo. + (source at: i) = 0] + whileFalse]. + ^str + ] + + isSmall [ + "Private - Answer whether the receiver is small enough to employ simple + scalar algorithms for division and multiplication" + + + ^self size <= 2 and: [(self at: 2) = 0] + ] + + divide: aNumber using: aBlock [ + "Private - Divide the receiver by aNumber (unsigned division). Evaluate + aBlock passing the result ByteArray, the remainder ByteArray, and + whether the division had a remainder" + + + | result a b | + aNumber isSmall + ifTrue: + [result := ByteArray new: self size. + b := 0. + self size to: 1 + by: -1 + do: + [:j | + a := (b bitShift: 8) + (self at: j). + result at: j put: a // (aNumber at: 1). + b := a \\ (aNumber at: 1)]. + ^aBlock + value: result + value: (ByteArray with: b with: 0) + value: b ~= 0]. + + "special case: numerator < denominator" + self size < aNumber size + ifTrue: + [^aBlock + value: ZeroBytes + value: self + value: true]. + self size > aNumber size + ifTrue: + [result := self primDivide: aNumber. + ^aBlock + value: result key + value: result value + value: (result value anySatisfy: [:each | each ~= 0])]. + self size to: 1 + by: -1 + do: + [:index | + a := self at: index. + b := aNumber at: index. + b > a + ifTrue: + [^aBlock + value: ZeroBytes + value: self + value: true]. + a > b + ifTrue: + [result := self primDivide: aNumber. + ^aBlock + value: result key + value: result value + value: (result value anySatisfy: [:each | each ~= 0])]]. + "Special case: numerator = denominator" + ^aBlock + value: OneBytes + value: ZeroBytes + value: false + ] + + multiply: aNumber [ + "Private - Multiply the receiver by aNumber (unsigned multiply)" + + + "Special case - other factor < 255" + + | newBytes byte carry index digit start | + aNumber isSmall + ifTrue: + [^self species from: (self bytes: self bytes multiply: (aNumber at: 1))]. + start := 1. + [(aNumber at: start) = 0] whileTrue: [start := start + 1]. + newBytes := ByteArray new: self size + aNumber size + 2. + 1 to: self size + do: + [:indexA | + digit := self at: indexA. + digit = 0 + ifFalse: + [carry := 0. + index := indexA + start - 1. + start to: aNumber size + do: + [:indexB | + byte := digit * (aNumber at: indexB) + carry + (newBytes at: index). + carry := byte bitShift: -8. + newBytes at: index put: (byte bitAnd: 255). + index := index + 1]. + newBytes at: indexA + aNumber size put: carry]]. + "If I multiply two large integers, the result is large, so use #from:..." + ^self species from: newBytes + ] + + bytes: bytes multiply: anInteger [ + "Private - Multiply the bytes in bytes by anInteger, which must be < 255. + Put the result back in bytes." + + + | byte carry | + carry := 0. + 1 to: bytes size + do: + [:index | + byte := (bytes at: index) * anInteger + carry. + carry := byte bitShift: -8. + bytes at: index put: (byte bitAnd: 255)]. + carry > 0 ifTrue: [bytes at: bytes size - 1 put: carry]. + ^bytes + ] + + bytes: byteArray1 from: j compare: byteArray2 [ + "Private - Answer the sign of byteArray2 - byteArray1; the + j-th byte of byteArray1 is compared with the first of byteArray2, + the j+1-th with the second, and so on." + + + | a b i | + i := byteArray2 size. + j + byteArray2 size - 1 to: j + by: -1 + do: + [:index | + b := byteArray2 at: i. + a := byteArray1 at: index. + a < b ifTrue: [^-1]. + a > b ifTrue: [^1]. + i := i - 1]. + ^0 + ] + + bytes: byteArray1 from: j subtract: byteArray2 [ + "Private - Sutract the bytes in byteArray2 from those in byteArray1" + + + | carry a i | + carry := 256. + i := 1. + j to: j + byteArray2 size - 1 + do: + [:index | + a := (byteArray1 at: index) - (byteArray2 at: i) + carry. + a < 256 + ifTrue: [carry := 255] + ifFalse: + [carry := 256. + a := a - 256]. + byteArray1 at: index put: a. + i := i + 1] + ] + + bytesLeftShift: aByteArray [ + "Private - Left shift by 1 place the bytes in aByteArray" + + + | carry a | + carry := 0. + 1 to: aByteArray size + do: + [:index | + a := aByteArray at: index. + a := a + a + carry. + carry := a bitShift: -8. + a := a bitAnd: 255. + aByteArray at: index put: a] + ] + + bytesLeftShift: aByteArray n: shift [ + "Private - Left shift by shift places the bytes in aByteArray + (shift <= 7)" + + + | carry a | + carry := 0. + 1 to: aByteArray size + do: + [:index | + a := aByteArray at: index. + a := (a bitShift: shift) + carry. + carry := a bitShift: -8. + aByteArray at: index put: (a bitAnd: 255)] + ] + + bytesLeftShift: aByteArray big: totalShift [ + "Private - Left shift the bytes in aByteArray by totalShift places" + + + | newBytes byteShift shift a last | + totalShift = 0 ifTrue: [^self]. + byteShift := totalShift // 8. + shift := totalShift bitAnd: 7. + last := 0. + aByteArray size - 1 to: byteShift + 1 + by: -1 + do: + [:index | + a := aByteArray at: index - byteShift. + a := a bitShift: shift. + aByteArray at: index + 1 put: last + (a bitShift: -8). + last := a bitAnd: 255]. + aByteArray at: byteShift + 1 put: last. + 1 to: byteShift do: [:i | aByteArray at: i put: 0] + ] + + bytesRightShift: aByteArray big: totalShift [ + "Private - Right shift the bytes in aByteArray by totalShift places" + + + | shift byteShift carryShift x a | + totalShift = 0 ifTrue: [^self]. + byteShift := totalShift // 8. + shift := (totalShift bitAnd: 7) negated. + carryShift := 8 + shift. + x := (aByteArray at: byteShift + 1) bitShift: shift. + byteShift + 2 to: aByteArray size + do: + [:j | + a := aByteArray at: j. + aByteArray at: j - byteShift - 1 + put: ((a bitShift: carryShift) bitAnd: 255) + x. + x := a bitShift: shift]. + aByteArray at: aByteArray size - byteShift put: x. + aByteArray size - byteShift + 1 to: aByteArray size + do: [:i | aByteArray at: i put: 0] + ] + + bytesRightShift: bytes n: aNumber [ + "Private - Right shift the bytes in `bytes' by 'aNumber' places + (shift <= 7)" + + + | shift carryShift x a | + aNumber = 0 ifTrue: [^self]. + shift := aNumber negated. + carryShift := 8 + shift. + x := (bytes at: 1) bitShift: shift. + 2 to: bytes size + do: + [:j | + a := bytes at: j. + bytes at: j - 1 put: ((a bitShift: carryShift) bitAnd: 255) + x. + x := a bitShift: shift]. + bytes at: bytes size put: x + ] + + bytesTrailingZeros: bytes [ + "Private - Answer the number of trailing zero bits in the receiver" + + + | each | + 1 to: bytes size + do: + [:index | + (each := bytes at: index) = 0 + ifFalse: [^index * 8 - 8 + (TrailingZeros at: each)]]. + ^bytes size * 8 + ] + + primDivide: rhs [ + "Private - Implements Knuth's divide and correct algorithm from + `Seminumerical Algorithms' 3rd Edition, section 4.3.1 (which + is basically an enhanced version of the divide `algorithm' for + two-digit divisors which is taught in primary school!!!)" + + + "Leading zeros in `v'" + + "Cached v at: n, v at: n - 1, j + n, j + n - 1" + + "Cached `u size - v size' and `v size'" + + "High 2 bytes of `u'" + + "guess times the divisor (v)" + + "Quotient" + + "guess at the quotient byte and remainder" + + "The operands" + + "0. Initialize everything" + + | d vn vn1 jn jn1 m n high sub q guess rem u v | + u := self bytes. + v := rhs bytes. + n := v size. + sub := ByteArray new: n. + m := u size - n. + q := ByteArray new: m + 2. + + "1. Normalize the divisor + Knuth's algorithm is based on an initial guess for the quotient. The + guess is guaranteed to be no more than 2 in error, if v[n] >= 128. + If we multiply both vectors by the same value, the result of division + remains the same, so we can always guarantee that v[n] is + sufficiently large. + While the algorithm calls for d to be 255 / v[n], we will set d to a + simple left shift count because this is fast and nicely approximates that" + [(v at: n) = 0] whileTrue: [n := n - 1]. + (v at: n) < 128 + ifFalse: [d := 0] + ifTrue: + ["Multiply each value by the normalizing value" + + d := LeadingZeros at: (v at: n). + self bytesLeftShift: u n: d. + self bytesLeftShift: v n: d]. + vn := v at: n. "Cache common values" + vn1 := v at: n - 1. + m + 1 to: 1 + by: -1 + do: + [:j | + jn := j + n. + jn1 := jn - 1. + + "2. Calculate the quotient `guess'. + Remember that our guess will be generated such that + guess - 2 <= quotient <= guess. Thus, we generate our first + guess at quotient, and keep decrementing by one until we have found + the real quotient." + high := (u at: jn) * 256 + (u at: jn1). + guess := high // vn. + rem := high \\ vn. + "(Array with: u with: high with: guess with: rem) printNl." + + "4. We know now that the quotient guess is most likely ok, but possibly + the real quotient is guess - 1 or guess - 2. Multiply the divisor by the + guess and compare the result with the dividend." + sub + replaceFrom: 1 + to: sub size + with: v + startingAt: 1. + self bytes: sub multiply: guess. + [(self + bytes: u + from: j + compare: sub) >= 0] + whileFalse: + ["Our guess was one off, so we need to readjust it by one and subtract + back the divisor (since we multiplied by one in excess)." + + guess := guess - 1. + self + bytes: sub + from: 1 + subtract: v]. + "(Array with: u with: sub with: guess with: rem) printNl." + + "Got another byte of the quotient" + self + bytes: u + from: j + subtract: sub. + q at: j put: guess]. + "Readjust the remainder" + self bytesRightShift: u n: d. + ^q -> u + ] +] + diff --git a/kernel/LargeWordArray.st b/kernel/LargeWordArray.st new file mode 100644 index 00000000..3224aa7b --- /dev/null +++ b/kernel/LargeWordArray.st @@ -0,0 +1,55 @@ +"===================================================================== +| +| Variations on the Array class +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2001, 2002, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +LargeArrayedCollection subclass: LargeWordArray [ + + + + + defaultElement [ + "Answer the value which is hoped to be the most common in the array" + + + ^0 + ] + + newCollection: size [ + "Create a WordArray of the given size" + + + ^WordArray new: size + ] +] + diff --git a/kernel/LargeZeroInteger.st b/kernel/LargeZeroInteger.st new file mode 100644 index 00000000..88f66622 --- /dev/null +++ b/kernel/LargeZeroInteger.st @@ -0,0 +1,144 @@ +"====================================================================== +| +| LargeInteger hierarchy Method Definitions +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1999, 2000, 2001, 2002, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +LargePositiveInteger subclass: LargeZeroInteger [ + + + + + + size [ + + ^0 + ] + + hash [ + + ^0 + ] + + at: anIndex [ + + ^0 + ] + + strictlyPositive [ + "Answer whether the receiver is > 0" + + + ^false + ] + + sign [ + "Answer the receiver's sign" + + + ^0 + ] + + + aNumber [ + "Sum the receiver and aNumber, answer the result" + + + ^aNumber + ] + + - aNumber [ + "Subtract aNumber from the receiver, answer the result" + + + ^aNumber negated + ] + + * aNumber [ + "Multiply aNumber and the receiver, answer the result" + + + ^0 + ] + + / aNumber [ + "Divide aNumber and the receiver, answer the result (an Integer or + Fraction)" + + + ^0 + ] + + // aNumber [ + "Divide aNumber and the receiver, answer the result truncated towards + -infinity" + + + ^0 + ] + + rem: aNumber [ + "Divide aNumber and the receiver, answer the remainder truncated + towards 0" + + + ^0 + ] + + quo: aNumber [ + "Divide aNumber and the receiver, answer the result truncated + towards 0" + + + ^0 + ] + + \\ aNumber [ + "Divide aNumber and the receiver, answer the remainder truncated + towards -infinity" + + + ^0 + ] + + replace: str withStringBase: radix [ + "Return in a string the base radix representation of the receiver." + + + str at: str size put: $0. + ^str + ] +] + diff --git a/kernel/MappedColl.st b/kernel/MappedCollection.st similarity index 100% rename from kernel/MappedColl.st rename to kernel/MappedCollection.st diff --git a/kernel/MthContext.st b/kernel/MethodContext.st similarity index 100% rename from kernel/MthContext.st rename to kernel/MethodContext.st diff --git a/kernel/MethodDict.st b/kernel/MethodDictionary.st similarity index 100% rename from kernel/MethodDict.st rename to kernel/MethodDictionary.st diff --git a/kernel/ObjMemory.st b/kernel/ObjectMemory.st similarity index 100% rename from kernel/ObjMemory.st rename to kernel/ObjectMemory.st diff --git a/kernel/OrderColl.st b/kernel/OrderedCollection.st similarity index 100% rename from kernel/OrderColl.st rename to kernel/OrderedCollection.st diff --git a/kernel/PkgLoader.st b/kernel/PkgLoader.st deleted file mode 100644 index 3464517d..00000000 --- a/kernel/PkgLoader.st +++ /dev/null @@ -1,2026 +0,0 @@ -"====================================================================== -| -| PackageLoader Method Definitions -| -| - ======================================================================" - -"====================================================================== -| -| Copyright 1999,2000,2001,2002,2003,2004,2005,2007,2008,2009 -| Free Software Foundation, Inc. -| Written by Paolo Bonzini. -| -| This file is part of the GNU Smalltalk class library. -| -| The GNU Smalltalk class library is free software; you can redistribute it -| and/or modify it under the terms of the GNU Lesser General Public License -| as published by the Free Software Foundation; either version 2.1, or (at -| your option) any later version. -| -| The GNU Smalltalk class library is distributed in the hope that it will be -| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of -| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser -| General Public License for more details. -| -| You should have received a copy of the GNU Lesser General Public License -| along with the GNU Smalltalk class library; see the file COPYING.LIB. -| If not, write to the Free Software Foundation, 59 Temple Place - Suite -| 330, Boston, MA 02110-1301, USA. -| - ======================================================================" - - - -Namespace current: Kernel [ - -Notification subclass: PackageSkip [ - - - -] - -] - - - -Namespace current: SystemExceptions [ - -NotFound subclass: PackageNotAvailable [ - - - - - PackageNotAvailable class >> signal: aString [ - "Signal an exception saying that the package named aString - can't be found." - ^super signalOn: aString what: 'package' - ] - - PackageNotAvailable class >> signal: package reason: reason [ - "Signal an exception saying that be package named package - can't be found because the reason named reason." - ^super signalOn: package reason: reason - ] - - isResumable [ - "Answer true. Package unavailability is resumable, because the - package files might just lie elsewhere." - - - ^true - ] -] - -] - - - -Namespace current: Kernel [ - -Object subclass: PackageGroup [ - - - - - printOn: aStream [ - "Print the XML source code for the information that the PackageLoader - holds on aStream." - - - aStream - nextPutAll: ''; - nl. - self do: - [:each | - aStream space: 2. - each printOn: aStream indent: 2. - aStream nl] - separatedBy: [aStream nl]. - aStream nextPutAll: '' - ] - - at: aString [ - - ^self at: aString - ifAbsent: [SystemExceptions.PackageNotAvailable signal: aString] - ] - - at: aString ifAbsent: aBlock [ - - self subclassResponsibility - ] - - do: aBlock [ - - self keys do: [:each | aBlock value: (self at: each)] - ] - - do: aBlock separatedBy: sepBlock [ - - self keys do: [:each | aBlock value: (self at: each)] separatedBy: sepBlock - ] - - keys [ - - self subclassResponsibility - ] - - includesKey: aString [ - - self subclassResponsibility - ] - - extractDependenciesFor: packagesList ifMissing: aBlock [ - "Answer an OrderedCollection containing all the packages which you - have to load to enable the packages in packagesList, in an appropriate - order. For example - - PackageLoader extractDependenciesFor: #('BloxTestSuite' 'Blox' 'Browser') - - on a newly built image will evaluate to an OrderedCollection containing - 'Kernel', 'Blox', 'BloxTestSuite' and 'Browser'. Note that - Blox has been moved before BloxTestSuite. - Pass an error message to aBlock if one or more packages need - prerequisites which are not available." - - - | toBeLoaded featuresFound dependencies allPrereq allFeatures | - featuresFound := Set withAll: Smalltalk.Features. - featuresFound := featuresFound collect: [:each | each asString]. - toBeLoaded := packagesList asOrderedCollection. - toBeLoaded := toBeLoaded collect: [:each | each asString]. - toBeLoaded removeAll: featuresFound ifAbsent: [:doesNotMatter | ]. - dependencies := packagesList collect: [:each | each asString]. - - [allPrereq := Set new. - allFeatures := Set new. - dependencies do: - [:name | - | package | - (featuresFound includes: name) - ifFalse: - [package := self at: name ifAbsent: [^aBlock value: name]. - allPrereq addAll: package prerequisites. - allFeatures addAll: package features]]. - - "I don't think there will never be lots of packages in newDep (say - more than 5), so I think it is acceptable to remove duplicates - this naive way. Note that we remove duplicates from toBeLoaded - so that prerequisites are always loaded *before*." - toBeLoaded removeAll: allPrereq ifAbsent: [:doesNotMatter | ]. - toBeLoaded removeAll: allFeatures ifAbsent: [:doesNotMatter | ]. - allPrereq removeAll: allFeatures ifAbsent: [:doesNotMatter | ]. - featuresFound addAll: allFeatures. - toBeLoaded addAllFirst: allPrereq. - - "Proceed recursively with the prerequisites for allPrereq" - dependencies := allPrereq. - dependencies notEmpty] - whileTrue. - ^toBeLoaded - ] - - refresh [ - - self refresh: ##(Date - newDay: 1 - month: #jan - year: 1900) - ] - - refresh: aLoadDate [ - - self subclassResponsibility - ] -] - -] - - - -Namespace current: Kernel [ - -PackageGroup subclass: PackageDirectories [ - | dirs | - - - - - PackageDirectories class >> new [ - - ^super new initialize - ] - - postCopy [ - - dirs := dirs copy - ] - - add: aDirectory [ - - ^dirs add: aDirectory - ] - - at: aString ifAbsent: aBlock [ - - dirs do: - [:each | - | package | - package := each at: aString ifAbsent: [nil]. - package isNil ifFalse: [^package]]. - ^aBlock value - ] - - keys [ - - | keys | - keys := Set new. - dirs do: [:each | keys addAll: each keys]. - ^keys - ] - - includesKey: aString [ - - ^dirs anySatisfy: [:each | each includesKey: aString] - ] - - refresh: aLoadDate [ - - dirs do: [:each | each refresh: aLoadDate] - ] - - initialize [ - - dirs := OrderedCollection new - ] -] - -] - - - -Namespace current: Kernel [ - -PackageGroup subclass: PackageContainer [ - | packages file | - - - - - file [ - - ^file - ] - - fileName [ - - ^self file name - ] - - file: aFile [ - - file := aFile - ] - - packages [ - - packages isNil ifTrue: [packages := LookupTable new]. - ^packages - ] - - packages: aDictionary [ - - packages := aDictionary - ] - - at: aString ifAbsent: aBlock [ - - ^self packages at: aString asString ifAbsent: aBlock - ] - - keys [ - - ^self packages keys - ] - - includesKey: aString [ - - ^self packages includesKey: aString - ] - - baseDirectoriesFor: aPackage [ - - self subclassResponsibility - ] - - refresh: loadDate [ - "Private - Process the XML source in the packages file, creating - Package objects along the way." - - - self subclassResponsibility - ] - - parse: file [ - - | open ch cdata tag package allPackages | - open := false. - allPackages := OrderedCollection new. - - [cdata := cdata isNil - ifTrue: [file upTo: $<] - ifFalse: [cdata , (file upTo: $<)]. - file atEnd] - whileFalse: - [cdata trimSeparators isEmpty - ifFalse: [^self error: 'unexpected character data']. - ch := file peek. - ch == $! ifTrue: [file skipTo: $>]. - ch == $/ - ifTrue: - [file next. - (tag := file upTo: $>) = 'packages' ifTrue: [^self]. - ^self error: 'unmatched end tag ' , tag]. - ch isAlphaNumeric - ifTrue: - [open - ifFalse: - [tag := file upTo: $>. - tag = 'package' - ifTrue: [package := Package new parse: file tag: 'package'] - ifFalse: - [tag = 'packages' ifFalse: [^self error: 'expected packages tag']. - open := true]] - ifTrue: - [file skip: -1. - package := Package parse: file]. - package notNil - ifTrue: - [package name isNil - ifTrue: [^self error: 'missing package name in ' , self fileName]. - - [self testPackageValidity: package. - self packages at: package name put: package. - allPackages add: package] - on: PackageSkip - do: [:ex | ex return]. - open ifFalse: [^allPackages]]. - package := nil]]. - ^allPackages - ] - - testPackageValidity: package [ - package baseDirectories: (self baseDirectoriesFor: package). - ] -] - -] - -Namespace current: Kernel [ - -PackageContainer subclass: PackageDirectory [ - | baseDirectories baseDirCache | - - - - PackageContainer class >> on: aFile baseDirectories: aBlock [ - - ^(super new) - file: aFile; - baseDirectories: aBlock - ] - - baseDirectoriesFor: aPacakge [ - - baseDirCache isNil ifTrue: [self refresh]. - ^baseDirCache - ] - - baseDirectories: aBlock [ - - baseDirectories := aBlock - ] - - refresh: loadDate [ - "Private - Process the XML source in the packages file, creating - Package objects along the way." - - | dir allDirs | - dir := self file parent. - allDirs := Smalltalk imageLocal - ifTrue: [{Directory image} , baseDirectories value] - ifFalse: [baseDirectories value]. - ((self file exists and: [self file lastModifyTime > loadDate]) or: - [(dir exists and: [dir lastModifyTime > loadDate]) - or: [allDirs ~= baseDirCache]]) - ifTrue: - [baseDirCache := allDirs. - self refreshPackageList. - self refreshStarList: dir] - ] - - refreshPackageList [ - - baseDirCache isEmpty ifTrue: [^self]. - self file exists ifFalse: [^self]. - self file withReadStreamDo: [ :fileStream | - [self parse: fileStream] - on: SystemExceptions.PackageNotAvailable - do: [:ex | ex resignalAs: PackageSkip new]]. - - self packages: (self packages reject: [:each | each isDisabled]) - ] - refreshStarList: dir [ - - dir exists ifFalse: [^self]. - dir filesMatching: '*.star' - do: - [:starFile | - | package | - package := Kernel.StarPackage file: starFile. - self packages at: package name put: package] - ] -] - -] - - - -Namespace current: Kernel [ - -Object subclass: PackageInfo [ - | name | - - - - - createNamespace [ - "Create the path of namespaces indicated by our namespace field in - dot notation, and answer the final namespace" - - - | ns | - ns := Smalltalk. - self namespace isNil ifTrue: [^ns]. - (self namespace subStrings: $.) do: - [:each | - | key | - key := each asSymbol. - (ns includesKey: key) ifFalse: [ns addSubspace: key]. - ns := ns at: key]. - ^ns - ] - - fileIn [ - "File in the given package and its dependencies." - - - self name isNil - ifTrue: - ["Other packages cannot be dependent on this one." - - PackageLoader fileInPackages: self prerequisites. - self primFileIn] - ifFalse: [PackageLoader fileInPackage: self name] - ] - - fullPathsOf: aCollection [ - "Resolve the names in aCollection according to the base directories - in baseDirectories, and return the collection with the FilePaths. - Raise a PackageNotAvailable exception if no directory was found for one - or more files in aCollection." - - - ^aCollection collect: - [:fileName | self fullPathOf: fileName] - ] - - / fileName [ - "Resolve the file name according to the base directories in - baseDirectories, and return a FilePath for the full filename. - Raise a PackageNotAvailable exception if no directory was found - for fileName." - - - ^self fullPathOf: fileName - ] - - fullPathOf: fileName [ - - self subclassResponsibility - ] - - isDisabled [ - - ^false - ] - - printXmlOn: aStream collection: aCollection tag: aString indent: indent [ - "Private - Print aCollection on aStream as a sequence of aString - tags." - - - aCollection do: - [:each | - aStream - nextPutAll: ' <'; - nextPutAll: aString; - nextPut: $>; - nextPutAll: each; - nextPutAll: '; - nl; - space: indent] - ] - - printOn: aStream [ - - self printOn: aStream indent: 0 - ] - - printOn: aStream indent: indent [ - - self - printOn: aStream - tag: 'package' - indent: indent - ] - - printOn: aStream tag: tag indent: indent [ - "Print a representation of the receiver on aStream (it happens - to be XML." - - - aStream - nextPut: $<; - nextPutAll: tag; - nextPut: $>; - nl; - space: indent. - self name isNil - ifFalse: - [aStream - nextPutAll: ' '; - nextPutAll: self name; - nextPutAll: ''; - nl; - space: indent]. - self url isNil - ifFalse: - [aStream - nextPutAll: ' '; - nextPutAll: self url; - nextPutAll: ''; - nl; - space: indent]. - self namespace isNil - ifFalse: - [aStream - nextPutAll: ' '; - nextPutAll: self namespace; - nextPutAll: ''; - nl; - space: indent]. - self test isNil - ifFalse: - [aStream space: 2. - self test - printOn: aStream - tag: 'test' - indent: indent + 2. - aStream - nl; - space: indent]. - self - printXmlOn: aStream - collection: self features asSortedCollection - tag: 'provides' - indent: indent. - self - printXmlOn: aStream - collection: self prerequisites asSortedCollection - tag: 'prereq' - indent: indent. - self - printXmlOn: aStream - collection: self sunitScripts - tag: 'sunit' - indent: indent. - self - printXmlOn: aStream - collection: self callouts asSortedCollection - tag: 'callout' - indent: indent. - self - printXmlOn: aStream - collection: self libraries asSortedCollection - tag: 'library' - indent: indent. - self - printXmlOn: aStream - collection: self modules asSortedCollection - tag: 'module' - indent: indent. - self relativeDirectory isNil - ifFalse: - [aStream - nextPutAll: ' '; - nextPutAll: self relativeDirectory; - nextPutAll: ''; - nl; - space: indent]. - self files size + self builtFiles size > 1 - ifTrue: - [aStream - nl; - space: indent]. - self - printXmlOn: aStream - collection: self fileIns - tag: 'filein' - indent: indent. - self - printXmlOn: aStream - collection: (self files copy removeAll: self fileIns ifAbsent: []; yourself) - tag: 'file' - indent: indent. - self - printXmlOn: aStream - collection: self builtFiles - tag: 'built-file' - indent: indent. - self startScript isNil - ifFalse: - [aStream - nextPutAll: ' '; - nextPutAll: self startScript; - nextPutAll: ''; - nl; - space: indent]. - self stopScript isNil - ifFalse: - [aStream - nextPutAll: ' '; - nextPutAll: self stopScript; - nextPutAll: ''; - nl; - space: indent]. - aStream - nextPutAll: ' - ] - - name [ - "Answer the name of the package." - - - ^name - ] - - name: aString [ - "Set to aString the name of the package." - - - name := aString - ] - - url [ - "Answer the URL at which the package repository can be found." - - - self subclassResponsibility - ] - - namespace [ - "Answer the namespace in which the package is loaded." - - - self subclassResponsibility - ] - - features [ - "Answer a (modifiable) Set of features provided by the package." - - - self subclassResponsibility - ] - - prerequisites [ - "Answer a (modifiable) Set of prerequisites." - - - self subclassResponsibility - ] - - builtFiles [ - "Answer a (modifiable) OrderedCollection of files that are part of - the package but are not distributed." - - - self subclassResponsibility - ] - - files [ - "Answer a (modifiable) OrderedCollection of files that are part of - the package." - - - self subclassResponsibility - ] - - allFiles [ - "Answer an OrderedCollection of all the files, both built and - distributed, that are part of the package." - - - | result | - result := self files , self builtFiles. - self test isNil - ifFalse: - [result := result , (self test allFiles: self test relativeDirectory)]. - ^result - ] - - allDistFiles [ - "Answer an OrderedCollection of all the files, both built and - distributed, that are part of the package." - - - | result | - result := self files. - self test isNil - ifFalse: - [result := result , (self test allDistFiles: self test relativeDirectory)]. - ^result - ] - - fileIns [ - "Answer a (modifiable) OrderedCollections of files that are to be - filed-in to load the package. This is usually a subset of - `files' and `builtFiles'." - - - self subclassResponsibility - ] - - libraries [ - "Answer a (modifiable) Set of shared library names - that are required to load the package." - - - self subclassResponsibility - ] - - modules [ - "Answer a (modifiable) Set of modules that are - required to load the package." - - - self subclassResponsibility - ] - - sunitScript [ - "Answer a String containing a SUnit script that - describes the package's test suite." - - - self sunitScripts isEmpty ifTrue: [^'']. - ^self sunitScripts fold: [:a :b | a , ' ' , b] - ] - - sunitScripts [ - "Answer a (modifiable) OrderedCollection of SUnit scripts that - compose the package's test suite." - - - self subclassResponsibility - ] - - startScript [ - "Answer the start script for the package." - - - self subclassResponsibility - ] - - stopScript [ - "Answer the stop script for the package." - - - self subclassResponsibility - ] - - callouts [ - "Answer a (modifiable) Set of call-outs that are required to load - the package. Their presence is checked after the libraries and - modules are loaded so that you can do a kind of versioning." - - - self subclassResponsibility - ] - - relativeDirectory [ - "Answer the directory from which to load the package, relative to the package - file." - - - self subclassResponsibility - ] - - directory [ - "Answer the base directory from which to load the package." - - - self subclassResponsibility - ] - - loaded [ - - ^self name notNil and: [Smalltalk hasFeatures: self name] - ] - - start [ - "File in the receiver and evaluate its start script, passing nil - as the argument." - - - self fileIn. - self startScript isNil ifTrue: [ ^self ]. - ('Eval [', - (self startScript % {'nil'}), - ']') readStream fileIn. - ] - - start: anObject [ - "File in the receiver and evaluate its start script, passing anObject's - displayString as the argument." - - - self fileIn. - self startScript isNil ifTrue: [ ^self ]. - ('Eval [', - (self startScript % { anObject displayString storeString }), - ']') readStream fileIn. - ] - - stop [ - "Evaluate the stop script of the receiver, passing nil as the - argument." - - - self loaded ifFalse: [ ^self ]. - self stopScript isNil ifTrue: [ ^self ]. - ('Eval [', - (self stopScript % {'nil'}), - ']') readStream fileIn. - ] - - stop: anObject [ - "Evaluate the stop script of the receiver, passing anObject's - displayString as the argument." - - - self loaded ifFalse: [ ^self ]. - self stopScript isNil ifTrue: [ ^self ]. - ('Eval [', - (self stopScript % { anObject displayString storeString }), - ']') readStream fileIn. - ] - - allFiles: prefix [ - - prefix isNil ifTrue: [^self allFiles]. - ^self allFiles collect: [:each | File append: each to: prefix] - ] - - allDistFiles: prefix [ - - prefix isNil ifTrue: [^self allDistFiles]. - ^self allDistFiles collect: [:each | File append: each to: prefix] - ] -] - -] - - - -Namespace current: Kernel [ - -PackageInfo subclass: StarPackage [ - | file loadedPackage | - - - - - StarPackage class >> file: file [ - - ^(self new) - file: file; - name: (File stripPathFrom: (File stripExtensionFrom: file name)); - yourself - ] - - fullPathOf: fileName [ - "Try appending 'self directory' and fileName to each of the directory - in baseDirectories, and return the path to the first tried filename that - exists. Raise a PackageNotAvailable exception if no directory is - found that contains the file." - - - ^self loadedPackage fullPathOf: fileName - ] - - test [ - "Answer the test subpackage for this package." - - - ^self loadedPackage test - ] - - url [ - "Answer the URL at which the package repository can be found." - - - ^self loadedPackage url - ] - - namespace [ - "Answer the namespace in which the package is loaded." - - - ^self loadedPackage namespace - ] - - features [ - "Answer a (modifiable) Set of features provided by the package." - - - ^self loadedPackage features - ] - - prerequisites [ - "Answer a (modifiable) Set of prerequisites." - - - ^self loadedPackage prerequisites - ] - - builtFiles [ - "Answer a (modifiable) OrderedCollection of files that are part of - the package but are not distributed." - - - ^self loadedPackage builtFiles - ] - - files [ - "Answer a (modifiable) OrderedCollection of files that are part of - the package." - - - ^self loadedPackage files - ] - - fileIns [ - "Answer a (modifiable) OrderedCollections of files that are to be - filed-in to load the package. This is usually a subset of - `files' and `builtFiles'." - - - ^self loadedPackage fileIns - ] - - libraries [ - "Answer a (modifiable) Set of shared library names - that are required to load the package." - - - ^self loadedPackage libraries - ] - - modules [ - "Answer a (modifiable) Set of modules that are - required to load the package." - - - ^self loadedPackage modules - ] - - startScript [ - "Answer the start script for the package." - - - ^self loadedPackage startScript - ] - - stopScript [ - "Answer the stop script for the package." - - - ^self loadedPackage stopScript - ] - - sunitScripts [ - "Answer a (modifiable) OrderedCollection of SUnit scripts that - compose the package's test suite." - - - ^self loadedPackage sunitScripts - ] - - callouts [ - "Answer a (modifiable) Set of call-outs that are required to load - the package. Their presence is checked after the libraries and - modules are loaded so that you can do a kind of versioning." - - - ^self loadedPackage callouts - ] - - relativeDirectory [ - - ^nil - ] - - directory [ - - ^(File name: self fileName) zip - ] - - file [ - - ^file - ] - - fileName [ - - ^self file name - ] - - file: aFile [ - - file := aFile - ] - - primFileIn [ - - self loadedPackage primFileIn - ] - - loadedPackage [ - - | file package | - loadedPackage isNil ifFalse: [^loadedPackage]. - package := self file zip / 'package.xml' - withReadStreamDo: [ :fileStream | Package parse: fileStream]. - package isNil - ifTrue: [^self error: 'invalid disabled-package tag inside a star file']. - package relativeDirectory: self relativeDirectory. - package baseDirectories: {self directory}. - package name isNil - ifTrue: [package name: self name] - ifFalse: - [package name = self name - ifFalse: [self error: 'invalid package name in package.xml']]. - loadedPackage := package. - ^loadedPackage - ] -] - -] - - - - - - -Namespace current: Kernel [ - -Object subclass: Version [ - | major minor patch | - - - - Version class >> fromString: aString [ - - - | result | - result := aString searchRegex: '^(\d+)\.(\d+)(?:\.(\d+))?' . - result ifNotMatched: [ - self error: 'Bad version format ', aString, ' should be xx.yy(.zz)'. - ^ nil ]. - - ^ self - major: (result at: 1) asInteger - minor: (result at: 2) asInteger - patch: ((result at: 3) ifNil: [ 0 ]) asInteger - ] - - Version class >> major: major minor: minor patch: patch [ - - - ^ self new - major: major minor: minor patch: patch - ] - - major: major minor: minor patch: patch [ - - - self - major: major; - minor: minor; - patch: patch - ] - - major [ - - - ^ major - ] - - major: anInteger [ - - - major := anInteger - ] - - minor [ - - - ^ minor - ] - - minor: anInteger [ - - - minor := anInteger - ] - - patch [ - - - ^ patch - ] - - patch: anInteger [ - - - patch := anInteger - ] -] -] - - -Kernel.PackageInfo subclass: Package [ - | features prerequisites builtFiles files fileIns relativeDirectory - baseDirectories libraries modules callouts url namespace sunitScripts - startScript stopScript test version path | - - - - - Package class [ | Tags | ] - - Package class >> tags [ - - - ^ Tags ifNil: [ Tags := Dictionary from: { - 'file' -> #addFile:. - 'filein' -> #addFileIn:. - 'prereq' -> #addPrerequisite:. - 'provides' -> #addFeature:. - 'module' -> #addModule:. - 'directory' -> #relativeDirectory:. - 'name' -> #name:. - 'url' -> #url:. - 'version' -> #parseVersion:. - 'namespace' -> #namespace:. - 'library' -> #addLibrary:. - 'built-file' -> #addBuiltFile:. - 'sunit' -> #addSunitScript:. - 'start' -> #startScript:. - 'stop' -> #stopScript:. - 'callout' -> #addCallout: } ] - ] - - Package class >> parse: file [ - "Answer a package from the XML description in file." - - | ch tag | - - [(file upTo: $<) trimSeparators isEmpty - ifFalse: [self error: 'unexpected cdata']. - file atEnd ifTrue: [self error: 'expected start tag']. - ch := file peek. - ch == $! ifTrue: [file skipTo: $>]. - ch == $/ ifTrue: [self error: 'unexpected end tag ']. - ch isAlphaNumeric - ifTrue: - [tag := file upTo: $>. - tag = 'package' ifTrue: [^Package new parse: file tag: tag]. - tag = 'disabled-package' - ifTrue: [^DisabledPackage new parse: file tag: tag]]] - repeat - ] - - test [ - "Answer the test sub-package." - - - ^test - ] - - test: aPackage [ - "Set the test sub-package to be aPackage." - - - aPackage test isNil - ifFalse: [self error: 'test packages must not be nested']. - aPackage name isNil - ifFalse: [self error: 'test package must not have names']. - (aPackage prerequisites) - add: 'SUnit'; - add: self name. - aPackage owner: self. - test := aPackage - ] - - startScript [ - "Answer the start script for the package." - - - ^startScript - ] - - startScript: aString [ - "Set the start script for the package to aString." - - - startScript := aString - ] - - stopScript [ - "Answer the start script for the package." - - - ^stopScript - ] - - stopScript: aString [ - "Set the stop script for the package to aString." - - - stopScript := aString - ] - - url [ - "Answer the URL at which the package repository can be found." - - - ^url - ] - - url: aString [ - "Set to aString the URL at which the package repository can be found." - - - url := aString - ] - - namespace [ - "Answer the namespace in which the package is loaded." - - - ^namespace - ] - - namespace: aString [ - "Set to aString the namespace in which the package is loaded." - - - namespace := aString - ] - - addFeature: aString [ - - - self path isEmpty ifFalse: [self error: 'unexpected inside tag']. - self features add: aString - ] - - features [ - "Answer a (modifiable) Set of features provided by the package." - - - features isNil ifTrue: [features := Set new]. - ^features - ] - - addPrerequisite: aString [ - - - self path isEmpty ifFalse: [self error: 'unexpected inside tag']. - self prerequisites add: aString - ] - - prerequisites [ - "Answer a (modifiable) Set of prerequisites." - - - prerequisites isNil ifTrue: [prerequisites := Set new]. - ^prerequisites - ] - - addBuiltFile: aString [ - - - self builtFiles add: self path, aString - ] - - builtFiles [ - "Answer a (modifiable) OrderedCollection of files that are part of - the package but are not distributed." - - builtFiles isNil ifTrue: [builtFiles := OrderedCollection new]. - ^builtFiles - ] - - addFile: aString [ - - - files isNil ifTrue: [files := OrderedCollection new]. - files add: self path, aString - ] - - files [ - "Answer a (modifiable) OrderedCollection of files that are part of - the package." - - | f | - f := self fileIns copy. - f removeAll: self builtFiles ifAbsent: []. - files isNil ifFalse: [ - f removeAll: files ifAbsent: []. - f addAll: files ]. - ^f - ] - - addFileIn: aString [ - - - self fileIns add: self path, aString - ] - - fileIns [ - "Answer a (modifiable) OrderedCollections of files that are to be - filed-in to load the package. This is usually a subset of - `files' and `builtFiles'." - - - fileIns isNil ifTrue: [fileIns := OrderedCollection new]. - ^fileIns - ] - - addLibrary: aString [ - - - self path isEmpty ifFalse: [self error: 'unexpected inside tag']. - self libraries add: aString - ] - - libraries [ - "Answer a (modifiable) Set of shared library names - that are required to load the package." - - libraries isNil ifTrue: [libraries := Set new]. - ^libraries - ] - - addModule: aString [ - - - self path isEmpty ifFalse: [self error: 'unexpected inside tag']. - self modules add: aString - ] - - modules [ - "Answer a (modifiable) Set of modules that are - required to load the package." - - modules isNil ifTrue: [modules := Set new]. - ^modules - ] - - addSunitScript: aString [ - - - self path isEmpty ifFalse: [self error: 'unexpected inside tag']. - self sunitScripts add: aString - ] - - sunitScripts [ - "Answer a (modifiable) OrderedCollection of SUnit scripts that - compose the package's test suite." - - sunitScripts isNil ifTrue: [sunitScripts := OrderedCollection new]. - ^sunitScripts - ] - - addCallout: aString [ - - - self path isEmpty ifFalse: [self error: 'unexpected inside tag']. - self callouts add: aString - ] - - callouts [ - "Answer a (modifiable) Set of call-outs that are required to load - the package. Their presence is checked after the libraries and - modules are loaded so that you can do a kind of versioning." - - - callouts isNil ifTrue: [callouts := Set new]. - ^callouts - ] - - baseDirectories [ - - ^baseDirectories - ] - - baseDirectories: aCollection [ - "Check if it's possible to resolve the names in the package according to - the base directories in baseDirectories, which depend on where - the packages.xml is found: the three possible places are 1) the - system kernel directory's parent directory, 2) the local kernel - directory's parent directory, 3) the local image directory (in - order of decreasing priority). - - For a packages.xml found in the system kernel directory's parent - directory, all three directories are searched. For a packages.xml - found in the local kernel directory's parent directory, only - directories 2 and 3 are searched. For a packages.xml directory in - the local image directory, instead, only directory 3 is searched." - - - baseDirectories := aCollection. - self fullPathsOf: self files. - "self fullPathsOf: self fileIns." - "self fullPathsOf: self builtFiles." - self directory. - self test notNil ifTrue: [self test baseDirectories: aCollection] - ] - - fullPathOf: fileName [ - "Try appending 'self directory' and fileName to each of the directory - in baseDirectories, and return the path to the first tried filename that - exists. Raise a PackageNotAvailable exception if no directory is - found that contains the file." - - - baseDirectories do: - [:baseDir || dir file | - dir := baseDir. - self relativeDirectory isNil - ifFalse: [dir := dir / self relativeDirectory]. - file := dir / fileName. - file exists ifTrue: [^file]]. - - SystemExceptions.PackageNotAvailable signal: self name - reason: (fileName printString , ' does not exist in ' , baseDirectories printString) - ] - - directory [ - "Answer the base directory from which to load the package." - - - self relativeDirectory isNil ifTrue: [^nil]. - self baseDirectories do: - [:baseDir || dir | - dir := baseDir / relativeDirectory. - dir exists ifTrue: [^dir]]. - - SystemExceptions.PackageNotAvailable signal: self name - ] - - relativeDirectory [ - "Answer the directory, relative to the packages file, from which to load - the package." - - - ^relativeDirectory - ] - - relativeDirectory: dir [ - "Set the directory, relative to the packages file, from which to load - the package, to dir." - - - relativeDirectory := dir - ] - - version [ - - - ^ version - ] - - version: aVersion [ - - - version := aVersion - ] - - parseVersion: aString [ - - - self version: (Version fromString: aString) - ] - - primFileIn [ - "Private - File in the given package without paying attention at - dependencies and C callout availability" - - | dir namespace | - self loaded ifTrue: [^self]. - dir := Directory working. - namespace := Namespace current. - - [| loadedFiles | - Namespace current: self createNamespace. - self directory isNil ifFalse: [Directory working: self directory]. - self libraries do: [:each | DLD addLibrary: each]. - self modules do: [:each | DLD addModule: each]. - PackageLoader ignoreCallouts - ifFalse: - [self callouts do: - [:func | - (CFunctionDescriptor isFunction: func) - ifFalse: [^self error: 'C callout not available: ' , func]]]. - loadedFiles := self fullPathsOf: self fileIns. - loadedFiles do: [:each | each fileIn]. - self name isNil ifFalse: [Smalltalk addFeature: self name]. - self features do: [:each | Smalltalk addFeature: each]] - ensure: - [Directory working: dir. - Namespace current: namespace] - ] - - path [ - - ^ path ifNil: [ path := '' ] - ] - - path: aString [ - - path := aString - ] - - isInPath [ - - ^ self path ~= '' - ] - - checkTagIfInPath: aString [ - - self isInPath ifFalse: [ ^ self ]. - (aString = 'file' or: [ aString = 'filein' or: [ aString = 'built-file' ] ]) ifFalse: [ self error: 'invalid tag in a dir tag ', aString ] - ] - - dir: file tag: aDictionary [ - | oldPath newPath | - newPath := aDictionary - at: 'name' - ifAbsent: [ self error: 'name attribute is not present in a dir tag' ]. - newPath isEmpty - ifTrue: [ self error: 'name attribute is empty' ]. - - oldPath := self path. - newPath := oldPath, newPath. - (newPath notEmpty and: [newPath last isPathSeparator not]) - ifTrue: [ newPath := newPath, Directory pathSeparatorString]. - self path: newPath. - self parse: file tag: 'dir'. - self path: oldPath. - ] - - parseAttributes: aString [ - - | attribute args key value terminator ch | - attribute := ReadStream on: aString. - args := LookupTable new. - [ - attribute atEnd ifTrue: [^args]. - attribute peek isSeparator ifFalse: [ - self error: 'expected separator']. - [ - attribute next. - attribute atEnd ifTrue: [^args]. - attribute peek isSeparator ] whileTrue. - attribute peek isAlphaNumeric ifFalse: [ - self error: 'expected attribute']. - - key := String streamContents: [ :s | - [ - attribute atEnd ifTrue: [ - self error: 'expected attribute']. - ch := attribute next. ch = $= ] whileFalse: [ - ch isAlphaNumeric ifFalse: [ - self error: 'invalid attribute name']. - s nextPut: ch ] ]. - - terminator := attribute next. - (terminator = $' or: [terminator = $"]) ifFalse: [ - self error: 'expected single or double quote']. - - value := String streamContents: [ :s | - [ - attribute atEnd ifTrue: [ - self error: 'expected %1' % { terminator }]. - ch := attribute next. ch = terminator ] whileFalse: [ - s nextPut: ch ] ]. - args at: key put: value. - ] repeat - ] - - parse: file tag: openingTag [ - - | stack cdata ch tag testPackage words | - stack := OrderedCollection new. - stack addLast: openingTag. - - [ - [cdata := cdata isNil - ifTrue: [file upTo: $<] - ifFalse: [cdata , (file upTo: $<)]. - file atEnd] - whileFalse: - [ch := file peek. - ch == $! ifTrue: [file skipTo: $>]. - ch == $/ - ifTrue: - [tag := stack removeLast. - file next. - (file upTo: $>) = tag - ifFalse: [^self error: 'error in packages file: unmatched end tag ' , tag ]. - tag = openingTag ifTrue: [ ^ self ]. - self checkTagIfInPath: tag. - self perform: (self class tags at: tag ifAbsent: [ self error: 'invalid tag ', tag ]) with: cdata. - cdata := nil ]. - ch isAlphaNumeric - ifTrue: - [tag := file upTo: $>. - words := tag substrings. - words first = 'dir' ifTrue: [ - self - dir: file - tag: (self parseAttributes: (tag copyFrom: words first size + 1)) ] - ifFalse: [ - words first = 'test' - ifTrue: [self test: (TestPackage new parse: file tag: tag)] - ifFalse: [stack addLast: tag] ]. - cdata trimSeparators isEmpty - ifFalse: [^self error: 'unexpected character data']. - cdata := nil]]] - ensure: - [stack isEmpty - ifFalse: - [self error: 'error in packages file: unmatched start tags' - , stack asArray printString]] - ] -] - - - -Namespace current: Kernel [ - -Package subclass: DisabledPackage [ - - - - - printOn: aStream indent: indent [ - - self - printOn: aStream - tag: 'disabled-package' - indent: indent - ] - - isDisabled [ - - ^true - ] -] - -] - - - -Namespace current: Kernel [ - -Smalltalk.Package subclass: TestPackage [ - | owner | - - - - - owner: aPackage [ - "Set the Package I test." - - - owner := aPackage - ] - - url [ - "Answer the URL at which the package repository can be found." - - - ^super url ifNil: [owner url] - ] - - namespace [ - "Answer the namespace in which the package is loaded." - - - ^super namespace ifNil: [owner namespace] - ] - - baseDirectories [ - "Answer the directories in which package files are sought." - - - ^super baseDirectories ifNil: - [owner baseDirectories - collect: [:each | each / owner relativeDirectory]] - ] -] - -] - - - -Object subclass: PackageLoader [ - - - - - PackageLoader class [ - | root loadDate ignoreCallouts | - - ] - - PackageLoader class >> packageAt: package ifAbsent: aBlock [ - "Answer a Package object for the given package" - - - self refresh. - ^root at: package asString ifAbsent: aBlock - ] - - PackageLoader class >> packageAt: package [ - "Answer a Package object for the given package" - - - self refresh. - ^root at: package asString - ] - - PackageLoader class >> directoryFor: package [ - "Answer a Directory object to the given package's files" - - - ^(self packageAt: package) directory - ] - - PackageLoader class >> builtFilesFor: package [ - "Answer a Set of Strings containing the filenames of the given package's - machine-generated files (relative to the directory answered by - #directoryFor:)" - - - ^(self packageAt: package) builtFiles - ] - - PackageLoader class >> filesFor: package [ - "Answer a Set of Strings containing the filenames of the given package's - files (relative to the directory answered by #directoryFor:)" - - - ^(self packageAt: package) files - ] - - PackageLoader class >> fileInsFor: package [ - "Answer a Set of Strings containing the filenames of the given package's - file-ins (relative to the directory answered by #directoryFor:)" - - - ^(self packageAt: package) fileIns - ] - - PackageLoader class >> sunitScriptFor: package [ - "Answer a Strings containing a SUnit script that describes the package's - test suite." - - - ^(self packageAt: package) sunitScript - ] - - PackageLoader class >> calloutsFor: package [ - "Answer a Set of Strings containing the filenames of the given package's - required callouts (relative to the directory answered by #directoryFor:)" - - - ^(self packageAt: package) callouts - ] - - PackageLoader class >> librariesFor: package [ - "Answer a Set of Strings containing the filenames of the given package's - libraries (relative to the directory answered by #directoryFor:)" - - - ^(self packageAt: package) libraries - ] - - PackageLoader class >> modulesFor: package [ - "Answer a Set of Strings containing the filenames of the given package's - modules (relative to the directory answered by #directoryFor:)" - - - ^(self packageAt: package) modules - ] - - PackageLoader class >> featuresFor: package [ - "Answer a Set of Strings containing the features provided by the given - package." - - - ^(self packageAt: package) features - ] - - PackageLoader class >> prerequisitesFor: package [ - "Answer a Set of Strings containing the prerequisites for the given package" - - - ^(self packageAt: package) prerequisites - ] - - PackageLoader class >> ignoreCallouts [ - "Answer whether unavailable C callouts must generate errors or not." - - - ignoreCallouts isNil ifTrue: [ignoreCallouts := false]. - ^ignoreCallouts - ] - - PackageLoader class >> ignoreCallouts: aBoolean [ - "Set whether unavailable C callouts must generate errors or not." - - - ignoreCallouts := aBoolean - ] - - PackageLoader class >> flush [ - "Set to reload the `packages.xml' file the next time it is needed." - - - root := nil. - loadDate := ##(Date - newDay: 1 - month: #jan - year: 1900) - ] - - PackageLoader class >> refresh [ - "Reload the `packages.xml' file in the image and kernel directories. - The three possible places are 1) the kernel directory's parent - directory, 2) the `.st' subdirectory of the user's home directory, 3) the - local image directory (in order of decreasing priority). - - For a packages.xml found in the kernel directory's parent - directory, all three directories are searched. For a packages.xml - found in the `.st' subdirectory, only directories 2 and 3 are - searched. For a packages.xml directory in the local image directory, - finally, only directory 3 is searched." - - - | state | - root isNil - ifTrue: - [self flush. - root := Kernel.PackageDirectories new. - root add: (Kernel.PackageDirectory on: self packageFile - baseDirectories: [ - {Directory userBase. - Directory kernel / '..'}]). - root add: (Kernel.PackageDirectory on: self sitePackageFile - baseDirectories: [ - {Directory userBase. - Directory kernel / '../site-packages'}]). - root add: (Kernel.PackageDirectory on: self userPackageFile - baseDirectories: [{Directory userBase}]). - root add: (Kernel.PackageDirectory on: self localPackageFile - baseDirectories: [#()])]. - root refresh: loadDate. - loadDate := Date dateAndTimeNow - ] - - PackageLoader class >> fileInPackage: package [ - "File in the given package into GNU Smalltalk." - - - self fileInPackages: {package} - ] - - PackageLoader class >> fileInPackages: packagesList [ - "File in all the packages in packagesList into GNU Smalltalk." - - - | toBeLoaded | - packagesList isEmpty ifTrue: [^self]. - self refresh. - toBeLoaded := root extractDependenciesFor: packagesList - ifMissing: [:name | SystemExceptions.PackageNotAvailable signal: name]. - toBeLoaded do: - [:each | - OutputVerbosity > 0 - ifTrue: - [Transcript - nextPutAll: 'Loading package ' , each; - nl]. - (self packageAt: each) primFileIn] - ] - - PackageLoader class >> canLoad: package [ - "Answer whether all the needed pre-requisites for package are available." - - - self extractDependenciesFor: {package} ifMissing: [:name | ^false]. - ^true - ] - - PackageLoader class >> isLoadable: feature [ - "Private - Answer whether the packages file includes an entry for `feature'" - - - self refresh. - ^root includesKey: feature asString - ] - - PackageLoader class >> packageFile [ - - ^Directory kernel / '../packages.xml' - ] - - PackageLoader class >> sitePackageFile [ - - ^Directory kernel / '../site-packages/packages.xml' - ] - - PackageLoader class >> userPackageFile [ - - ^Directory userBase / 'packages.xml' - ] - - PackageLoader class >> localPackageFile [ - - ^Directory image / 'packages.xml' - ] - - PackageLoader class >> rebuildPackageFile [ - "Recreate the XML file from the information that the PackageLoader - holds. This is a dangerous method, also because the PackageLoader - does not know about disabled packages." - - - | file | - self refresh. - Directory image / 'packages.xml' withWriteStreamDo: [ :file | - file nextPutAll: ''. - file nl; nl. - root printOn: file] - ] -] - diff --git a/kernel/PointExtensions.st b/kernel/PointExtensions.st new file mode 100644 index 00000000..df28383e --- /dev/null +++ b/kernel/PointExtensions.st @@ -0,0 +1,53 @@ +"===================================================================== +| +| Point Class Definitions +| +| + =====================================================================" + +"====================================================================== +| +| Copyright 1992,94,95,99,2000,2001,2002,2006 +| Free Software Foundation, Inc. +| Written by Doug McCallum. +| Additions by Steve Byrne and Paolo Bonzini +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Number extend [ + + @ y [ + "Answer a new point whose x is the receiver and whose y is y" + + + ^Point x: self y: y + ] + + asPoint [ + "Answer a new point, self @ self" + + + ^Point x: self y: self + ] + +] + diff --git a/kernel/PosStream.st b/kernel/PositionableStream.st similarity index 100% rename from kernel/PosStream.st rename to kernel/PositionableStream.st diff --git a/kernel/ProcEnv.st b/kernel/ProcessEnvironment.st similarity index 71% rename from kernel/ProcEnv.st rename to kernel/ProcessEnvironment.st index d3780748..820a2b01 100644 --- a/kernel/ProcEnv.st +++ b/kernel/ProcessEnvironment.st @@ -30,71 +30,6 @@ ======================================================================" - -LookupKey subclass: ProcessVariable [ - - - - ProcessVariable class >> key: anObject [ - "Return a new ProcessVariable with the given key. Not that the key - need not be a symbol or string, for example you could use an - array #(#{class name} 'name'). Setting the variable's value will - automatically create it in the current process, while removal must - be done by hand through the ProcessEnvironment singleton object." - - ^self basicNew key: anObject - ] - - ProcessVariable class >> new [ - "Return a new ProcessVariable with a new anonymous but unique key. - It is suggested to use a descriptive name instead to ease debugging. - Setting the variable's value will automatically create it in - the current process, while removal must be done by hand through - the ProcessEnvironment singleton object." - - ^self basicNew key: Object new - ] - - environment [ - "Return the environment in which this ProcessVariable lives. This - is the singleton instance of ProcessEnvironment for all variables." - - ^ProcessEnvironment uniqueInstance - ] - - use: anObject during: aBlock [ - "Set the value of this variable to anObject during the execution - of aBlock, then restore it." - - | oldValue | - oldValue := self value. - self value: anObject. - ^aBlock ensure: [self value: oldValue] - ] - - valueIfAbsent: aBlock [ - "Return the value of this variable in the current process." - - ^Processor activeProcess environment at: self key ifAbsent: [ nil ] - ] - - value [ - "Return the value of this variable in the current process." - - ^Processor activeProcess environment at: self key ifAbsent: [ nil ] - ] - - value: anObject [ - "Set the value of the current process's copy of the variable to be - anObject." - - Processor activeProcess environment at: self key put: anObject - ] -] - - Object subclass: ProcessEnvironment [ diff --git a/kernel/ProcessVariable.st b/kernel/ProcessVariable.st new file mode 100644 index 00000000..7da36c9b --- /dev/null +++ b/kernel/ProcessVariable.st @@ -0,0 +1,96 @@ +"====================================================================== +| +| ProcessEnvironment Method Definitions +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +LookupKey subclass: ProcessVariable [ + + + + ProcessVariable class >> key: anObject [ + "Return a new ProcessVariable with the given key. Not that the key + need not be a symbol or string, for example you could use an + array #(#{class name} 'name'). Setting the variable's value will + automatically create it in the current process, while removal must + be done by hand through the ProcessEnvironment singleton object." + + ^self basicNew key: anObject + ] + + ProcessVariable class >> new [ + "Return a new ProcessVariable with a new anonymous but unique key. + It is suggested to use a descriptive name instead to ease debugging. + Setting the variable's value will automatically create it in + the current process, while removal must be done by hand through + the ProcessEnvironment singleton object." + + ^self basicNew key: Object new + ] + + environment [ + "Return the environment in which this ProcessVariable lives. This + is the singleton instance of ProcessEnvironment for all variables." + + ^ProcessEnvironment uniqueInstance + ] + + use: anObject during: aBlock [ + "Set the value of this variable to anObject during the execution + of aBlock, then restore it." + + | oldValue | + oldValue := self value. + self value: anObject. + ^aBlock ensure: [self value: oldValue] + ] + + valueIfAbsent: aBlock [ + "Return the value of this variable in the current process." + + ^Processor activeProcess environment at: self key ifAbsent: [ nil ] + ] + + value [ + "Return the value of this variable in the current process." + + ^Processor activeProcess environment at: self key ifAbsent: [ nil ] + ] + + value: anObject [ + "Set the value of the current process's copy of the variable to be + anObject." + + Processor activeProcess environment at: self key put: anObject + ] +] + diff --git a/kernel/ProcSched.st b/kernel/ProcessorScheduler.st similarity index 100% rename from kernel/ProcSched.st rename to kernel/ProcessorScheduler.st diff --git a/kernel/RWStream.st b/kernel/ReadWriteStream.st similarity index 100% rename from kernel/RWStream.st rename to kernel/ReadWriteStream.st diff --git a/kernel/Rectangle.st b/kernel/Rectangle.st index 6d316f05..f2701b90 100644 --- a/kernel/Rectangle.st +++ b/kernel/Rectangle.st @@ -623,49 +623,3 @@ Object subclass: Rectangle [ ] ] - - -Number extend [ - - asRectangle [ - "Answer an empty rectangle whose origin is (self asPoint)" - - - ^Rectangle - left: self - top: self - right: self - bottom: self - ] - -] - - - -Point extend [ - - asRectangle [ - "Answer an empty rectangle whose origin is self" - - - ^Rectangle origin: self corner: self copy - ] - - corner: aPoint [ - "Answer a Rectangle whose origin is the receiver and whose corner - is aPoint" - - - ^Rectangle origin: self corner: aPoint - ] - - extent: aPoint [ - "Answer a Rectangle whose origin is the receiver and whose extent - is aPoint" - - - ^Rectangle origin: self extent: aPoint - ] - -] - diff --git a/kernel/RectangleExtensions.st b/kernel/RectangleExtensions.st new file mode 100644 index 00000000..31e7e510 --- /dev/null +++ b/kernel/RectangleExtensions.st @@ -0,0 +1,78 @@ +"======================================================================== +| +| Rectangle Class +| +| + ========================================================================" + +"====================================================================== +| +| Copyright 1988,92,94,95,99,2000,2001,2002,2006,2008 +| Free Software Foundation, Inc. +| Written by Doug McCallum. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Number extend [ + + asRectangle [ + "Answer an empty rectangle whose origin is (self asPoint)" + + + ^Rectangle + left: self + top: self + right: self + bottom: self + ] + +] + + + +Point extend [ + + asRectangle [ + "Answer an empty rectangle whose origin is self" + + + ^Rectangle origin: self corner: self copy + ] + + corner: aPoint [ + "Answer a Rectangle whose origin is the receiver and whose corner + is aPoint" + + + ^Rectangle origin: self corner: aPoint + ] + + extent: aPoint [ + "Answer a Rectangle whose origin is the receiver and whose extent + is aPoint" + + + ^Rectangle origin: self extent: aPoint + ] + +] + diff --git a/kernel/RootNamespc.st b/kernel/RootNamespace.st similarity index 100% rename from kernel/RootNamespc.st rename to kernel/RootNamespace.st diff --git a/kernel/RunArray.st b/kernel/RunArray.st index 897ab35c..efee0b60 100644 --- a/kernel/RunArray.st +++ b/kernel/RunArray.st @@ -395,81 +395,3 @@ behave like an ArrayedCollection.'> ] ] - - -Collection extend [ - - asRunArray [ - "Answer the receiver converted to a RunArray. If the receiver is not - ordered the order of the elements in the RunArray might not be the #do: - order." - - - ^(RunArray basicNew) - map: self asRunArrayMap; - initialize - ] - - asRunArrayMap [ - "Private - Answer the receiver converted to an OrderedCollection of - Associations whose keys are the actual objects and whose values are - the number of consecutive copies of them" - - "Bags can be easily packed, because they are made of runs of unordered - elements like RunArrays. As the #do: order of non-sequenceable collections - is undefined, we choose the ordering which yields the best map." - - - ^self asBag asRunArrayMap - ] - -] - - - -Bag extend [ - - asRunArrayMap [ - "Private - Answer the receiver converted to an OrderedCollection of - Associations whose keys are the actual objects and whose values are - the number of consecutive copies of them" - - - | map | - map := OrderedCollection new: contents size. - contents associationsDo: [:assoc | map addLast: assoc]. - ^map - ] - -] - - - -SequenceableCollection extend [ - - asRunArrayMap [ - "Private - Answer the receiver converted to an OrderedCollection of - Associations whose keys are the actual objects and whose values are - the number of consecutive copies of them" - - - | map prev startIndex | - map := OrderedCollection new. - prev := self at: 1. - startIndex := 1. - self - from: 2 - to: self size - keysAndValuesDo: - [:currIndex :each | - each = prev - ifFalse: - [map addLast: (Association key: prev value: currIndex - startIndex). - prev := each. - startIndex := currIndex]]. - map addLast: (Association key: prev value: self size + 1 - startIndex). - ^map - ] - -] - diff --git a/kernel/RunArrayExtensions.st b/kernel/RunArrayExtensions.st new file mode 100644 index 00000000..29386d21 --- /dev/null +++ b/kernel/RunArrayExtensions.st @@ -0,0 +1,113 @@ +"====================================================================== +| +| RunArray Method Definitions +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1999, 2000, 2001, 2002, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + +"Some of the methods I define (first, last, indexOf:startingAt:ifAbsent:, + shallowCopy, deepCopy, =, hash) are here only for performance purposes (their + inherited implementation works, but it is slow)" + + + +Collection extend [ + + asRunArray [ + "Answer the receiver converted to a RunArray. If the receiver is not + ordered the order of the elements in the RunArray might not be the #do: + order." + + + ^(RunArray basicNew) + map: self asRunArrayMap; + initialize + ] + + asRunArrayMap [ + "Private - Answer the receiver converted to an OrderedCollection of + Associations whose keys are the actual objects and whose values are + the number of consecutive copies of them" + + "Bags can be easily packed, because they are made of runs of unordered + elements like RunArrays. As the #do: order of non-sequenceable collections + is undefined, we choose the ordering which yields the best map." + + + ^self asBag asRunArrayMap + ] + +] + + + +Bag extend [ + + asRunArrayMap [ + "Private - Answer the receiver converted to an OrderedCollection of + Associations whose keys are the actual objects and whose values are + the number of consecutive copies of them" + + + | map | + map := OrderedCollection new: contents size. + contents associationsDo: [:assoc | map addLast: assoc]. + ^map + ] + +] + + + +SequenceableCollection extend [ + + asRunArrayMap [ + "Private - Answer the receiver converted to an OrderedCollection of + Associations whose keys are the actual objects and whose values are + the number of consecutive copies of them" + + + | map prev startIndex | + map := OrderedCollection new. + prev := self at: 1. + startIndex := 1. + self + from: 2 + to: self size + keysAndValuesDo: + [:currIndex :each | + each = prev + ifFalse: + [map addLast: (Association key: prev value: currIndex - startIndex). + prev := each. + startIndex := currIndex]]. + map addLast: (Association key: prev value: self size + 1 - startIndex). + ^map + ] + +] + diff --git a/kernel/ScaledDec.st b/kernel/ScaledDecimal.st similarity index 100% rename from kernel/ScaledDec.st rename to kernel/ScaledDecimal.st diff --git a/kernel/SeqCollect.st b/kernel/SequenceableCollection.st similarity index 100% rename from kernel/SeqCollect.st rename to kernel/SequenceableCollection.st diff --git a/kernel/SmallInt.st b/kernel/SmallInteger.st similarity index 100% rename from kernel/SmallInt.st rename to kernel/SmallInteger.st diff --git a/kernel/SortCollect.st b/kernel/SortedCollection.st similarity index 100% rename from kernel/SortCollect.st rename to kernel/SortedCollection.st diff --git a/kernel/StreamOps.st b/kernel/StreamOps.st deleted file mode 100644 index 70481538..00000000 --- a/kernel/StreamOps.st +++ /dev/null @@ -1,744 +0,0 @@ -"====================================================================== -| -| Adds collection-like operations to GNU Smalltalk streams -| -| - ======================================================================" - -"====================================================================== -| -| Copyright 2001, 2002, 2007, 2008, 2009 Free Software Foundation, Inc. -| Written by Paolo Bonzini. -| -| This file is part of GNU Smalltalk. -| -| GNU Smalltalk is free software; you can redistribute it and/or modify it -| under the terms of the GNU General Public License as published by the Free -| Software Foundation; either version 2, or (at your option) any later version. -| -| GNU Smalltalk is distributed in the hope that it will be useful, but WITHOUT -| ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS -| FOR A PARTICULAR PURPOSE. See the GNU General Public License for more -| details. -| -| You should have received a copy of the GNU General Public License along with -| GNU Smalltalk; see the file COPYING. If not, write to the Free Software -| Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. -| - ======================================================================" - - - -Namespace current: Kernel [ - -Stream subclass: ConcatenatedStream [ - | streams startPos curPos last lastStart | - - - - - ConcatenatedStream class >> new [ - - ^#() readStream - ] - - ConcatenatedStream class >> with: stream1 [ - - ^(self basicNew) - streams: {stream1}; - yourself - ] - - ConcatenatedStream class >> with: stream1 with: stream2 [ - - ^(self basicNew) - streams: {stream1. stream2}; - yourself - ] - - ConcatenatedStream class >> withAll: array [ - - ^(self basicNew) - streams: array; - yourself - ] - - , aStream [ - - ^(self copy) - addStream: aStream; - yourself - ] - - postCopy [ - - streams := streams copy - ] - - stream [ - - | s | - "This is somewhat performance-sensitive, so avoid testing for an - empty collection." - [(s := streams at: 1) atEnd] whileTrue: - [curPos > 0 ifTrue: [ - lastStart := startPos. - startPos := startPos + curPos. - curPos := 0]. - streams size = 1 ifTrue: [last := streams first. ^nil]. - last := streams removeFirst]. - ^s - ] - - atEnd [ - - ^self stream isNil - ] - - file [ - - self atEnd ifTrue: [^nil]. - ^streams first file - ] - - name [ - - self atEnd ifTrue: [^nil]. - ^streams first name - ] - - next [ - - | s | - ^(s := self stream) isNil - ifTrue: [self pastEnd] - ifFalse: [curPos := curPos + 1. s next] - ] - - pastEnd [ - - ^streams last pastEnd - ] - - peekFor: aCharacter [ - - | s result | - (s := self stream) isNil - ifTrue: - [self pastEnd. - ^false]. - result := s peekFor: aCharacter. - result ifTrue: [curPos := curPos + 1]. - ^result - ] - - peek [ - - | s | - (s := self stream) isNil ifTrue: [^self pastEnd]. - ^s peek - ] - - position [ - - self stream. - ^startPos + curPos - ] - - position: anInteger [ - - | s | - (s := self stream) isNil - ifTrue: - [self pastEnd. - ^self]. - s position: anInteger - startPos. - curPos := anInteger - startPos - ] - - copyFrom: start to: end [ - "needed to do the documentation" - - - | adjust stream | - stream := self stream. - end + 1 = start ifTrue: [^'']. - adjust := end <= startPos - ifTrue: [stream := last. lastStart] - ifFalse: [startPos]. - ^stream copyFrom: (start - adjust max: 0) to: end - adjust - ] - - addStream: stream [ - - streams addLast: stream - ] - - streams: arrayOfStreams [ - - streams := arrayOfStreams asOrderedCollection. - startPos := curPos := 0 - ] -] - -] - - - -Namespace current: Kernel [ - -Stream subclass: FilteringStream [ - | stream block result next atEnd | - - - - - FilteringStream class >> on: aStream select: selectBlock [ - - ^self new - initStream: aStream - block: selectBlock - result: true - ] - - FilteringStream class >> on: aStream reject: selectBlock [ - - ^self new - initStream: aStream - block: selectBlock - result: false - ] - - initStream: aStream block: selectBlock result: aBoolean [ - - stream := aStream. - block := selectBlock. - result := aBoolean. - atEnd := false. - self lookahead - ] - - atEnd [ - - ^atEnd - ] - - next [ - - | result | - atEnd - ifTrue: - [self pastEnd. - ^nil]. - result := next. - self lookahead. - ^result - ] - - pastEnd [ - - ^stream pastEnd - ] - - peek [ - - atEnd ifTrue: [^nil]. - ^next - ] - - peekFor: aCharacter [ - - atEnd - ifTrue: - [self pastEnd. - ^false]. - next == aCharacter - ifTrue: - [self lookahead. - ^true]. - ^false - ] - - species [ - - ^stream species - ] - - lookahead [ - - - [stream atEnd - ifTrue: - [atEnd := true. - ^self]. - next := stream next. - (block value: next) == result] - whileFalse - ] -] - -] - - - -Namespace current: Kernel [ - -Stream subclass: CollectingStream [ - | stream block | - - - - - CollectingStream class >> on: aStream collect: collectBlock [ - - ^self new initStream: aStream block: collectBlock - ] - - initStream: aStream block: collectBlock [ - - stream := aStream. - block := collectBlock - ] - - atEnd [ - - ^stream atEnd - ] - - next [ - - stream atEnd ifTrue: [^stream pastEnd]. - ^block value: stream next - ] - - pastEnd [ - - ^stream pastEnd - ] - - peek [ - - stream atEnd ifTrue: [^nil]. - ^block value: stream peek - ] - - peekFor: anObject [ - - | result | - stream atEnd - ifTrue: - [stream pastEnd. - ^false]. - result := (block value: stream peek) = anObject result - ifTrue: [stream next]. - ^result - ] - - position [ - - ^stream position - ] - - position: anInteger [ - - stream position: anInteger - ] - - species [ - - ^stream species - ] -] - -] - - - -Namespace current: Kernel [ - -Stream subclass: PeekableStream [ - | stream haveLookahead lookahead | - - - - - PeekableStream class >> on: aStream [ - - ^self new initStream: aStream - ] - - species [ - - ^stream species - ] - - file [ - - ^stream file - ] - - name [ - - ^stream name - ] - - next [ - - | char | - ^haveLookahead - ifTrue: - [haveLookahead := false. - char := lookahead. - lookahead := nil. - char] - ifFalse: [stream next] - ] - - atEnd [ - "Answer whether the input stream has no more tokens." - - - ^haveLookahead not and: [stream atEnd] - ] - - pastEnd [ - - ^stream pastEnd - ] - - peek [ - "Returns the next element of the stream without moving the pointer. - Returns nil when at end of stream." - - - haveLookahead - ifFalse: - [stream atEnd ifTrue: [^nil]. - haveLookahead := true. - lookahead := stream next]. - ^lookahead - ] - - peekFor: anObject [ - "Answer a new whitespace-separated token from the input stream" - - - | result | - haveLookahead - ifFalse: - [stream atEnd - ifTrue: - [self pastEnd. - ^false]. - lookahead := stream next]. - result := lookahead = anObject. - result ifTrue: [lookahead := nil]. - haveLookahead := result not. - ^result - ] - - initStream: aStream [ - - stream := aStream. - haveLookahead := false - ] -] - -] - - - -Namespace current: Kernel [ - -Stream subclass: LineStream [ - | charStream | - - - - - LineStream class >> on: aStream [ - "Answer a LineStream working on aStream" - - - ^self new initStream: aStream - ] - - file [ - - ^charStream file - ] - - name [ - - ^charStream name - ] - - next [ - - ^charStream nextLine - ] - - atEnd [ - - ^charStream atEnd - ] - - pastEnd [ - - ^charStream pastEnd - ] - - initStream: aStream [ - - charStream := aStream - ] -] - -] - - - -Namespace current: Kernel [ - -Stream subclass: OneOfEachStream [ - | streams delta | - - - - - OneOfEachStream class >> new [ - - ^#() readStream - ] - - OneOfEachStream class >> with: stream1 [ - - ^(self basicNew) - streams: {stream1} - ] - - OneOfEachStream class >> with: stream1 with: stream2 [ - - ^(self basicNew) - streams: - {stream1. - stream2} - ] - - OneOfEachStream class >> with: stream1 with: stream2 with: stream3 [ - - ^(self basicNew) - streams: - {stream1. - stream2. - stream3} - ] - - OneOfEachStream class >> with: stream1 with: stream2 with: stream3 with: stream4 [ - - ^(self basicNew) - streams: - {stream1. - stream2. - stream3. - stream4} - ] - - OneOfEachStream class >> withAll: array [ - - ^(self basicNew) - streams: array - ] - - atEnd [ - - ^streams anySatisfy: [ :each | each atEnd] - ] - - do: aBlock [ - - [ - aBlock value: - (streams collect: [:each | - each atEnd ifTrue: [ ^self ]. - each next ]) - ] repeat - ] - - next [ - - ^streams collect: [:each | - each atEnd ifTrue: [ ^self pastEnd ] ifFalse: [ each next ]] - ] - - pastEnd [ - - ^streams first pastEnd - ] - - peekFor: anObject [ - - ^self peek = anObject - ifTrue: [ streams do: [ :each | streams next ] ]; - yourself - ] - - peek [ - - ^streams collect: [:each | - each atEnd ifTrue: [ ^self pastEnd ] ifFalse: [ each peek ]] - ] - - position [ - - ^streams first position - delta - ] - - position: anInteger [ - - ^self skip: anInteger - self position - ] - - reset [ - - self position: 0 - ] - - skip: anInteger [ - - streams do: [ :each | each skip: anInteger ] - ] - - streams: arrayOfStreams [ - - streams := arrayOfStreams. - delta := arrayOfStreams first position. - ] -] - -] - - - - -Stream extend [ - - , anIterable [ - "Answer a new stream that concatenates the data in the receiver with the - data in aStream. Both the receiver and aStream should be readable." - - - ^Kernel.ConcatenatedStream with: self with: anIterable readStream - ] - - lines [ - "Answer a new stream that answers lines from the receiver." - - - ^Kernel.LineStream on: self - ] - - peek [ - "Returns the next element of the stream without moving the pointer. - Returns nil when at end of stream. Lookahead is implemented automatically - for streams that are not positionable but can be copied." - - - | copy | - copy := self copy. - copy == self ifTrue: [^self shouldNotImplement]. - self become: (Kernel.PeekableStream on: copy). - ^self peek - ] - - skipSeparators [ - "Advance the receiver until we find a character that is not a - separator. Answer false if we reach the end of the stream, - else answer true; in this case, sending #next will return the - first non-separator character (possibly the same to which the - stream pointed before #skipSeparators was sent)." - - - | ch | - - [(ch := self peek) isNil ifTrue: [^false]. - ch isSeparator] - whileTrue: [self next]. - ^true - ] - - peekFor: aCharacter [ - "Returns true and gobbles the next element from the stream of it is - equal to anObject, returns false and doesn't gobble the next element - if the next element is not equal to anObject. Lookahead is implemented - automatically for streams that are not positionable but can be copied." - - - | copy | - copy := self copy. - copy == self ifTrue: [^self shouldNotImplement]. - self become: (Kernel.PeekableStream on: copy). - ^self peekFor: aCharacter - ] - - select: aBlock [ - "Answer a new stream that only returns those objects for which aBlock - returns true. Note that the returned stream will not be positionable." - - "Example: Sieve of Erathostenes. - GNU Smalltalk does not detect that i escapes, so we need to avoid - optimizations of #to:do:. - - s := (2 to: 100) readStream. - (2 to: 10) do: [ :i | - s := s reject: [ :n | n > i and: [ n \\ i = 0 ] ] ]. - s contents printNl" - - - ^Kernel.FilteringStream on: self select: aBlock - ] - - reject: aBlock [ - "Answer a new stream that only returns those objects for which aBlock - returns false. Note that the returned stream will not be positionable." - - - ^Kernel.FilteringStream on: self reject: aBlock - ] - - collect: aBlock [ - "Answer a new stream that will pass the returned objects through aBlock, - and return whatever object is returned by aBlock instead. Note that when - peeking in the returned stream, the block will be invoked multiple times, - with possibly surprising results." - - - ^Kernel.CollectingStream on: self collect: aBlock - ] - - with: aStream [ - "Return a new Stream whose elements are 2-element - Arrays, including one element from the receiver and one from - aStream." - - ^Kernel.OneOfEachStream with: self with: aStream - ] - - with: stream1 with: stream2 [ - "Return a new Stream whose elements are 3-element - Arrays, including one element from the receiver and one from - each argument." - - ^Kernel.OneOfEachStream with: self with: stream1 with: stream2 - ] - - with: stream1 with: stream2 with: stream3 [ - "Return a new Stream whose elements are 3-element - Arrays, including one element from the receiver and one from - each argument." - - ^Kernel.OneOfEachStream - with: self with: stream1 with: stream2 with: stream3 - ] -] - diff --git a/kernel/SysDict.st b/kernel/SystemDictionary.st similarity index 100% rename from kernel/SysDict.st rename to kernel/SystemDictionary.st diff --git a/kernel/TextCollector.st b/kernel/TextCollector.st new file mode 100644 index 00000000..572e85e1 --- /dev/null +++ b/kernel/TextCollector.st @@ -0,0 +1,206 @@ +"====================================================================== +| +| Smalltalk Transcript object (TextCollector class) +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1988,92,94,95,99,2000,2001,2008,2009 +| Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Stream subclass: TextCollector [ + | semaphore receiver selector | + + + + + TextCollector class >> new [ + + self shouldNotImplement + ] + + TextCollector class >> message: receiverToSelectorAssociation [ + "Answer a new instance of the receiver, that uses the message identified + by anAssociation to perform write operations. anAssociation's + key is the receiver, while its value is the selector." + + + ^(self basicNew) + initialize; + message: receiverToSelectorAssociation + ] + + message [ + "Answer an association representing the message to be sent + to perform write operations. The key is the receiver, the value is the + selector" + + + ^receiver -> selector + ] + + message: receiverToSelectorAssociation [ + "Set the message to be sent to perform write operations + to the one represented by anAssociation. anAssociation's key is the + receiver, while its value is the selector" + + + receiver := receiverToSelectorAssociation key. + selector := receiverToSelectorAssociation value + ] + + cr [ + "Emit a new-line (carriage return) to the Transcript" + + + self nl + ] + + endEntry [ + "Emit two new-lines. This method is present for compatibility with + VisualWorks." + + + self + nl; + nl + ] + + nextPut: aCharacter [ + "Emit aCharacter to the Transcript" + + + self nextPutAll: (String with: aCharacter) + ] + + next: anInteger put: anObject [ + "Write anInteger copies of anObject to the Transcript" + + + self nextPutAll: (String new: anInteger withAll: anObject) + ] + + critical: aBlock [ + "Evaluate aBlock while holding the Transcript lock" + + + semaphore critical: aBlock + ] + + next: n putAll: aString startingAt: pos [ + "Write aString to the Transcript" + + + semaphore critical: + [self primNextPutAll: (aString copyFrom: pos to: pos + n - 1). + Processor idle] + ] + + show: aString [ + "Write aString to the Transcript" + + + semaphore critical: + [self primNextPutAll: aString. + Processor idle] + ] + + showCr: aString [ + "Write aString to the Transcript, followed by a new-line character" + + + semaphore critical: + [self primNextPutAll: aString. + self primNextPutAll: Character nl asString. + Processor idle] + ] + + showOnNewLine: aString [ + "Write aString to the Transcript, preceded by a new-line character" + + + semaphore critical: + [self primNextPutAll: Character nl asString. + self primNextPutAll: aString. + Processor idle] + ] + + print: anObject [ + "Print anObject's representation to the Transcript" + + + semaphore critical: + [self primNextPutAll: anObject printString. + Processor idle] + ] + + printOn: aStream [ + "Print a representation of the receiver onto aStream" + + + self == Transcript + ifTrue: [aStream nextPutAll: 'Transcript'] + ifFalse: [super printOn: aStream] + ] + + store: anObject [ + "Print Smalltalk code which evaluates to anObject on the Transcript" + + + semaphore critical: + [self primNextPutAll: anObject storeString. + Processor idle] + ] + + storeOn: aStream [ + "Print Smalltalk code which evaluates to the receiver onto aStream" + + + self == Transcript + ifTrue: [aStream nextPutAll: 'Transcript'] + ifFalse: [super storeOn: aStream] + ] + + primNextPutAll: aString [ + "Private - Forward the writing request to the actual object" + + + [receiver perform: selector with: aString] + on: Error do: [:ex | stderr nextPutAll: aString; flush. ex return] + ] + + initialize [ + "Private - Initialize the receiver's instance variables" + + + semaphore := RecursionLock new + ] +] + diff --git a/kernel/Transcript.st b/kernel/Transcript.st index 62028dab..e619b99e 100644 --- a/kernel/Transcript.st +++ b/kernel/Transcript.st @@ -31,180 +31,6 @@ ======================================================================" - -Stream subclass: TextCollector [ - | semaphore receiver selector | - - - - - TextCollector class >> new [ - - self shouldNotImplement - ] - - TextCollector class >> message: receiverToSelectorAssociation [ - "Answer a new instance of the receiver, that uses the message identified - by anAssociation to perform write operations. anAssociation's - key is the receiver, while its value is the selector." - - - ^(self basicNew) - initialize; - message: receiverToSelectorAssociation - ] - - message [ - "Answer an association representing the message to be sent - to perform write operations. The key is the receiver, the value is the - selector" - - - ^receiver -> selector - ] - - message: receiverToSelectorAssociation [ - "Set the message to be sent to perform write operations - to the one represented by anAssociation. anAssociation's key is the - receiver, while its value is the selector" - - - receiver := receiverToSelectorAssociation key. - selector := receiverToSelectorAssociation value - ] - - cr [ - "Emit a new-line (carriage return) to the Transcript" - - - self nl - ] - - endEntry [ - "Emit two new-lines. This method is present for compatibility with - VisualWorks." - - - self - nl; - nl - ] - - nextPut: aCharacter [ - "Emit aCharacter to the Transcript" - - - self nextPutAll: (String with: aCharacter) - ] - - next: anInteger put: anObject [ - "Write anInteger copies of anObject to the Transcript" - - - self nextPutAll: (String new: anInteger withAll: anObject) - ] - - critical: aBlock [ - "Evaluate aBlock while holding the Transcript lock" - - - semaphore critical: aBlock - ] - - next: n putAll: aString startingAt: pos [ - "Write aString to the Transcript" - - - semaphore critical: - [self primNextPutAll: (aString copyFrom: pos to: pos + n - 1). - Processor idle] - ] - - show: aString [ - "Write aString to the Transcript" - - - semaphore critical: - [self primNextPutAll: aString. - Processor idle] - ] - - showCr: aString [ - "Write aString to the Transcript, followed by a new-line character" - - - semaphore critical: - [self primNextPutAll: aString. - self primNextPutAll: Character nl asString. - Processor idle] - ] - - showOnNewLine: aString [ - "Write aString to the Transcript, preceded by a new-line character" - - - semaphore critical: - [self primNextPutAll: Character nl asString. - self primNextPutAll: aString. - Processor idle] - ] - - print: anObject [ - "Print anObject's representation to the Transcript" - - - semaphore critical: - [self primNextPutAll: anObject printString. - Processor idle] - ] - - printOn: aStream [ - "Print a representation of the receiver onto aStream" - - - self == Transcript - ifTrue: [aStream nextPutAll: 'Transcript'] - ifFalse: [super printOn: aStream] - ] - - store: anObject [ - "Print Smalltalk code which evaluates to anObject on the Transcript" - - - semaphore critical: - [self primNextPutAll: anObject storeString. - Processor idle] - ] - - storeOn: aStream [ - "Print Smalltalk code which evaluates to the receiver onto aStream" - - - self == Transcript - ifTrue: [aStream nextPutAll: 'Transcript'] - ifFalse: [super storeOn: aStream] - ] - - primNextPutAll: aString [ - "Private - Forward the writing request to the actual object" - - - [receiver perform: selector with: aString] - on: Error do: [:ex | stderr nextPutAll: aString; flush. ex return] - ] - - initialize [ - "Private - Initialize the receiver's instance variables" - - - semaphore := RecursionLock new - ] -] - - Eval [ Smalltalk at: #Transcript diff --git a/kernel/UndefObject.st b/kernel/UndefinedObject.st similarity index 100% rename from kernel/UndefObject.st rename to kernel/UndefinedObject.st diff --git a/kernel/UniChar.st b/kernel/UnicodeCharacter.st similarity index 100% rename from kernel/UniChar.st rename to kernel/UnicodeCharacter.st diff --git a/kernel/UniString.st b/kernel/UnicodeString.st similarity index 100% rename from kernel/UniString.st rename to kernel/UnicodeString.st diff --git a/kernel/VFS.st b/kernel/VFS.st deleted file mode 100644 index 75e214dd..00000000 --- a/kernel/VFS.st +++ /dev/null @@ -1,1110 +0,0 @@ -"====================================================================== -| -| Virtual File System layer definitions -| -| - ======================================================================" - -"====================================================================== -| -| Copyright 2002, 2005, 2007, 2008, 2009 Free Software Foundation, Inc. -| Written by Paolo Bonzini. -| -| This file is part of the GNU Smalltalk class library. -| -| The GNU Smalltalk class library is free software; you can redistribute it -| and/or modify it under the terms of the GNU Lesser General Public License -| as published by the Free Software Foundation; either version 2.1, or (at -| your option) any later version. -| -| The GNU Smalltalk class library is distributed in the hope that it will be -| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of -| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser -| General Public License for more details. -| -| You should have received a copy of the GNU Lesser General Public License -| along with the GNU Smalltalk class library; see the file COPYING.LIB. -| If not, write to the Free Software Foundation, 59 Temple Place - Suite -| 330, Boston, MA 02110-1301, USA. -| - ======================================================================" - -Namespace current: VFS [ - -FilePath subclass: FileWrapper [ - | file | - - - - - FileWrapper class >> initialize [ - "Register the receiver with ObjectMemory" - - - ObjectMemory addDependent: self. - ] - - FileWrapper class >> update: aspect [ - "Private - Remove the files before quitting, and register the virtual - filesystems specified by the subclasses upon image load." - - - aspect == #aboutToQuit ifTrue: [self broadcast: #release] - ] - - FileWrapper class >> on: file [ - "Create an instance of this class representing the contents of the given - file, under the virtual filesystem fsName." - - - ^self new file: file - ] - - = aFile [ - "Answer whether the receiver represents the same file as the receiver." - - - ^self class == aFile class and: [ self file = aFile file ] - ] - - hash [ - "Answer a hash value for the receiver." - - - ^self file hash - ] - - asString [ - "Answer the string representation of the receiver's path." - - ^self file asString - ] - - name [ - "Answer the full path to the receiver." - - ^self file name - ] - - isAbsolute [ - "Answer whether the receiver identifies an absolute path." - - ^self file isAbsolute - ] - - full [ - "Answer the size of the file identified by the receiver" - - - self isAbsolute ifTrue: [ ^self ]. - ^self class on: self file full - ] - - mode [ - "Answer the permission bits for the file identified by the receiver" - - - ^self file mode - ] - - mode: anInteger [ - "Answer the permission bits for the file identified by the receiver" - - - self file mode: anInteger - ] - - size [ - "Answer the size of the file identified by the receiver" - - - ^self file size - ] - - lastAccessTime [ - "Answer the last access time of the file identified by the receiver" - - - ^self file lastAccessTime - ] - - exists [ - "Answer whether a file with the name contained in the receiver - does exist." - - - ^self file exists - ] - - isAbsolute [ - "Answer whether the receiver identifies an absolute path." - - - ^self file isAbsolute - ] - - isReadable [ - "Answer whether a file with the name contained in the receiver does exist - and is readable" - - - ^self file isReadable - ] - - isWriteable [ - "Answer whether a file with the name contained in the receiver does exist - and is writeable" - - - ^self file isWriteable - ] - - isExecutable [ - "Answer whether a file with the name contained in the receiver does exist - and is executable" - - - ^self file isExecutable - ] - - isAccessible [ - "Answer whether a directory with the name contained in the receiver does - exist and can be accessed" - - - ^self file isAccessible - ] - - isDirectory [ - "Answer whether a file with the name contained in the receiver - does exist identifies a directory." - - - ^self file isDirectory - ] - - isSymbolicLink [ - "Answer whether a file with the name contained in the receiver - does exist and identifies a symbolic link." - - - ^self file isSymbolicLink - ] - - owner: ownerString group: groupString [ - "Set the receiver's owner and group to be ownerString and groupString." - - - self file owner: ownerString group: groupString - ] - - lastAccessTime: accessDateTime lastModifyTime: modifyDateTime [ - "Update the timestamps of the file corresponding to the receiver, to be - accessDateTime and modifyDateTime." - - - self file lastAccessTime: accessDateTime lastModifyTime: modifyDateTime - ] - - lastChangeTime [ - "Answer the last change time of the file identified by the receiver - (the `last change time' has to do with permissions, ownership and the - like). On some operating systems, this could actually be the - file creation time." - - - ^self file lastChangeTime - ] - - creationTime [ - "Answer the creation time of the file identified by the receiver. - On some operating systems, this could actually be the last change time - (the `last change time' has to do with permissions, ownership and the - like)." - - - ^self file creationTime - ] - - lastModifyTime [ - "Answer the last modify time of the file identified by the receiver - (the `last modify time' has to do with the actual file contents)." - - - ^self file lastModifyTime - ] - - isReadable [ - "Answer whether a file with the name contained in the receiver does exist - and is readable" - - - ^self file isReadable - ] - - isWriteable [ - "Answer whether a file with the name contained in the receiver does exist - and is writeable" - - - ^self file isWritable - ] - - isExecutable [ - "Answer whether a file with the name contained in the receiver does exist - and is executable" - - - ^self file isExecutable - ] - - open: class mode: mode ifFail: aBlock [ - "Open the receiver in the given mode (as answered by FileStream's - class constant methods)" - - - ^self file - open: class - mode: mode - ifFail: aBlock - ] - - remove [ - "Remove the file with the given path name" - - - self file remove - ] - - symlinkAs: destName [ - "Create destName as a symbolic link of the receiver. The appropriate - relative path is computed automatically." - - - ^self file symlinkAs: destName - ] - - pathFrom: dirName [ - "Compute the relative path from the directory dirName to the receiver" - - - ^self file pathFrom: dirName - ] - - symlinkFrom: srcName [ - "Create the receiver as a symbolic link from srcName (relative to the - path of the receiver)." - - - ^self file symlinkFrom: srcName - ] - - renameTo: newName [ - "Rename the file identified by the receiver to newName" - - - ^self file renameTo: newName - ] - - pathTo: destName [ - "Compute the relative path from the receiver to destName." - - - ^self file pathTo: destName - ] - - at: aName [ - "Answer a File or Directory object as appropriate for a file named - 'aName' in the directory represented by the receiver." - - - ^self class on: (self file at: aName) - ] - - namesDo: aBlock [ - "Evaluate aBlock once for each file in the directory represented by the - receiver, passing its name." - - - self file namesDo: aBlock - ] - - file [ - - ^file - ] - - file: aFilePath [ - - file := aFilePath. - ] -] - -] - - -Namespace current: Kernel [ - -VFS.FileWrapper subclass: RecursiveFileWrapper [ - - - do: aBlock [ - "Same as the wrapped #do:, but reuses the file object for efficiency." - - - aBlock value: self file. - self file namesDo: - [:name | - | f | - (#('.' '..') includes: name) ifFalse: [ - f := self at: name. - aBlock value: f file. - (f isDirectory and: [f isSymbolicLink not]) - ifTrue: [f do: aBlock]]] - ] - - namesDo: aBlock prefixLength: anInteger [ - "Same as the wrapped #namesDo:, but navigates the entire directory - tree recursively. Since the objects created by #at: also contain the - path to the receiver, anInteger is used to trim it." - - - self file namesDo: - [:name | - | f | - (#('.' '..') includes: name) ifFalse: [ - f := self at: name. - aBlock value: (f asString copyFrom: anInteger). - (f isDirectory and: [f isSymbolicLink not]) - ifTrue: [f - namesDo: aBlock - prefixLength: anInteger ]]] - ] - - namesDo: aBlock [ - "Same as the wrapped #namesDo:, but navigates the entire directory - tree recursively." - - - | n base | - aBlock value: '.'. - base := self asString. - n := base last = Directory pathSeparator - ifTrue: [ base size + 1 ] - ifFalse: [ base size + 2 ]. - self namesDo: aBlock prefixLength: n - ] - - remove [ - "Removes the entire directory tree recursively." - - - self isDirectory ifTrue: [ - self file namesDo: - [:name | - | f | - f := self at: name. - f isDirectory - ifTrue: - [((#('.' '..') includes: name) or: [f isSymbolicLink]) - ifFalse: [f all remove]] - ifFalse: [f remove]]]. - super remove - ] - - isFileSystemPath [ - "Answer whether the receiver corresponds to a real filesystem path." - - - ^self file isFileSystemPath - ] - - lastAccessTime: accessDateTime lastModifyTime: modifyDateTime [ - "Update the timestamps of all files in the tree to be - accessDateTime and modifyDateTime." - - - self isDirectory ifFalse: [ - ^super lastAccessTime: accessDateTime lastModifyTime: modifyDateTime ]. - self do: [ :each | - each lastAccessTime: accessDateTime lastModifyTime: modifyDateTime ] - ] - - owner: ownerString group: groupString [ - "Set the owner and group for all files and directories in the tree." - - - self isDirectory ifFalse: [ - ^super owner: ownerString group: groupString ]. - "These special calls cache the uid and gid to avoid repeated lookups." - [ - File setOwnerFor: nil owner: ownerString group: groupString. - self do: [ :each | each owner: ownerString group: groupString ] - ] ensure: [ File setOwnerFor: nil owner: nil group: nil ] - ] - - mode: anInteger [ - "Set the mode to be anInteger for all files in the tree. Directory - modes are left unchanged." - - - self isDirectory ifFalse: [ ^super mode: anInteger ]. - - self do: [ :each | each isDirectory ifFalse: [ each mode: anInteger ] ] - ] - - fileMode: fMode directoryMode: dMode [ - "Set the mode to be fMode for all files in the tree, and dMode for - all directories in the tree." - - - self isDirectory ifFalse: [ ^super mode: fMode ]. - - super mode: dMode. - self isDirectory ifTrue: [ - self do: [ :each | - each mode: (each isDirectory - ifTrue: [ dMode ] - ifFalse: [ fMode ]) ] ] - ] -] - -] - -Namespace current: VFS [ - -FileWrapper subclass: ArchiveFile [ - | tmpFiles topLevelFiles allFiles extractedFiles | - - - - - displayOn: aStream [ - "Print a representation of the file identified by the receiver." - super displayOn: aStream. - aStream nextPut: $#. - self class printOn: aStream - ] - - isDirectory [ - "Answer true. The archive can always be considered as a directory." - - - ^true - ] - - isAccessible [ - "Answer whether a directory with the name contained in the receiver does - exist and can be accessed" - - - ^self isReadable - ] - - at: aName [ - "Answer a FilePath for a file named `aName' residing in the directory - represented by the receiver." - - - | handler data | - allFiles isNil ifTrue: [self refresh]. - data := allFiles at: aName ifAbsent: [^nil]. - handler := data at: 5 ifAbsent: [nil]. - handler isNil ifFalse: [^handler]. - tmpFiles isNil - ifTrue: - [tmpFiles := LookupTable new. - FileWrapper addDependent: self. - self addToBeFinalized]. - ^tmpFiles at: aName - ifAbsentPut: - [(TmpFileArchiveMember new) - name: aName; - archive: self] - ] - - nameAt: aString [ - "Answer a FilePath for a file named `aName' residing in the directory - represented by the receiver." - - - ^aString - ] - - namesDo: aBlock [ - "Evaluate aBlock once for each file in the directory represented by the - receiver, passing its name." - - - topLevelFiles isNil ifTrue: [self refresh]. - topLevelFiles do: aBlock - ] - - release [ - "Release the resources used by the receiver that don't survive when - reloading a snapshot." - - - tmpFiles isNil - ifFalse: - [tmpFiles do: [:each | each release]. - tmpFiles := nil]. - extractedFiles isNil - ifFalse: - [extractedFiles do: [:each | self primUnlink: each]. - extractedFiles := nil]. - super release - ] - - fillMember: anArchiveMember [ - "Extract the information on anArchiveMember. Answer - false if it actually does not exist in the archive; otherwise, - answer true after having told anArchiveMember about them - by sending #size:stCtime:stMtime:stAtime:isDirectory: to it." - - - | data | - allFiles isNil ifTrue: [self refresh]. - data := allFiles at: anArchiveMember name ifAbsent: [nil]. - data isNil ifTrue: [^false]. - anArchiveMember fillFrom: data. - ^true - ] - - member: anArchiveMember do: aBlock [ - "Evaluate aBlock once for each file in the directory represented by - anArchiveMember, passing its name." - - - | data | - allFiles isNil ifTrue: [self refresh]. - data := allFiles at: anArchiveMember name ifAbsent: [nil]. - data isNil ifTrue: [^SystemExceptions.FileError signal: 'File not found']. - (data at: 1) isNil - ifTrue: [^SystemExceptions.FileError signal: 'Not a directory']. - (data at: 1) do: aBlock - ] - - refresh [ - "Extract the directory listing from the archive" - - - | pipe line parentPath name current currentPath directoryTree directory | - super refresh. - current := currentPath := nil. - allFiles := LookupTable new. - directoryTree := LookupTable new. - self fileData do: - [:data | - | path size date mode member | - mode := self convertMode: (data at: 4). - data at: 4 put: mode. - path := data at: 1. - path last = $/ ifTrue: [path := path copyFrom: 1 to: path size - 1]. - - "Look up the tree for the directory in which the file resides. - We keep a simple 1-element cache." - parentPath := File pathFor: path. - name := File stripPathFrom: path. - parentPath = currentPath - ifFalse: - [currentPath := parentPath. - current := self findDirectory: path into: directoryTree]. - - "Create an item in the tree for directories, and - add an association to the allFiles SortedCollection" - directory := (mode bitAnd: 8r170000) = 8r40000 - ifTrue: [current at: name put: LookupTable new] - ifFalse: [current at: name put: nil]. - data at: 1 put: directory. - allFiles at: path put: data. - member := data at: 5 ifAbsent: [nil]. - member notNil ifTrue: [member fillFrom: data]]. - - "Leave the LookupTables to be garbage collected, we are now interested - in the file names only." - topLevelFiles := directoryTree keys asArray. - allFiles - do: [:data | (data at: 1) isNil ifFalse: [data at: 1 put: (data at: 1) keys asArray]] - ] - - member: anArchiveMember mode: bits [ - "Set the permission bits for the file in anArchiveMember." - - - self subclassResponsibility - ] - - removeMember: anArchiveMember [ - "Remove the member represented by anArchiveMember." - - - self subclassResponsibility - ] - - updateMember: anArchiveMember [ - "Update the member represented by anArchiveMember by - copying the file into which it was extracted back to the - archive." - - - self subclassResponsibility - ] - - extractMember: anArchiveMember [ - "Extract the contents of anArchiveMember into a file - that resides on disk, and answer the name of the file." - - - extractedFiles isNil ifTrue: [extractedFiles := IdentityDictionary new]. - ^extractedFiles at: anArchiveMember - ifAbsentPut: - [| temp | - temp := FileStream openTemporaryFile: Directory temporary , '/vfs'. - self extractMember: anArchiveMember into: temp. - File name: temp name] - ] - - extractMember: anArchiveMember into: file [ - "Extract the contents of anArchiveMember into a file - that resides on disk, and answer the name of the file." - - - self subclassResponsibility - ] - - convertMode: mode [ - "Convert the mode from a string, character or boolean to an octal number." - - - mode isNumber ifTrue: [^mode]. - mode isString ifTrue: [^self convertModeString: mode]. - mode isCharacter ifTrue: [^self convertMode: mode == $d]. - ^mode ifTrue: [8r40755] ifFalse: [8r644] - ] - - convertModeString: modeString [ - "Convert the mode from a string to an octal number." - - - | mode | - mode := 0. - (modeString at: 1) = $l ifTrue: [mode := 8r120000]. - (modeString at: 1) = $d ifTrue: [mode := 8r40000]. - (modeString at: 4) asLowercase = $s ifTrue: [mode := mode + 8r4000]. - (modeString at: 7) asLowercase = $s ifTrue: [mode := mode + 8r2000]. - (modeString at: 10) asLowercase = $t ifTrue: [mode := mode + 8r1000]. - modeString - from: 2 - to: 10 - keysAndValuesDo: [:i :ch | ch isLowercase ifTrue: [mode := mode setBit: 11 - i]]. - ^mode - ] - - findDirectory: path into: tree [ - "Look up into tree (which is a tree of Dictionaries) the directory - that is the parent of the file named `path'." - - - | current last | - current := tree. - last := 1. - path keysAndValuesDo: - [:i :each | - | element | - each = $/ - ifTrue: - [last = i - ifFalse: - [element := path copyFrom: last to: i - 1. - current := current at: element - ifAbsentPut: - ["The list command might output files but not - directories. No problem, we create them along - the way." - - | directory | - directory := LookupTable new. - allFiles at: (path copyFrom: 1 to: i - 1) - put: - {directory. 0. - self creationTime. - self mode bitOr: 8r40111}. - directory]]. - last := i + 1]]. - ^current - ] -] - -] - - - -Namespace current: VFS [ - -FilePath subclass: ArchiveMember [ - | archive name mode size stCtime stMtime stAtime | - - - - - = aFile [ - "Answer whether the receiver represents the same file as the receiver." - - - ^self class == aFile class and: [ self archive = aFile archive - and: [ self name = aFile name ] ] - ] - - hash [ - "Answer a hash value for the receiver." - - - ^self archive hash bitXor: self name hash - ] - - archive: anArchiveFile [ - "Set the archive of which the receiver is a member." - - - archive := anArchiveFile - ] - - full [ - "Answer the size of the file identified by the receiver" - - - ^self archive full at: self name - ] - - fillFrom: data [ - "Called back by the receiver's archive when the ArchiveMember - asks for file information." - - - self - size: (data at: 2) - stMtime: (data at: 3) - mode: (data at: 4) - ] - - size: bytes stMtime: mtime mode: modeBits [ - "Set the file information for the receiver." - - - size := bytes. - stCtime := self archive lastModifyTime. - stMtime := mtime. - stAtime := self archive lastAccessTime. - mode := modeBits - ] - - size: bytes stCtime: ctime stMtime: mtime stAtime: atime mode: modeBits [ - "Set the file information for the receiver." - - - size := bytes. - stCtime := ctime. - stMtime := mtime. - stAtime := atime. - mode := modeBits - ] - - asString [ - "Answer the name of the file identified by the receiver as answered by - File>>#name." - - - ^self name - ] - - displayOn: aStream [ - "Print a representation of the file identified by the receiver." - self archive displayOn: aStream. - aStream nextPut: $/. - super displayOn: aStream - ] - - isAbsolute [ - "Answer whether the receiver identifies an absolute path." - - ^self archive isAbsolute - ] - - name [ - "Answer the receiver's file name." - - - ^name - ] - - name: aName [ - "Set the receiver's file name to aName." - - - name := aName - ] - - archive [ - "Answer the archive of which the receiver is a member." - - - ^archive - ] - - size [ - "Answer the size of the file identified by the receiver" - - - size isNil ifTrue: [self refresh]. - ^size - ] - - lastAccessTime [ - "Answer the last access time of the file identified by the receiver" - - - stAtime isNil ifTrue: [self refresh]. - ^stAtime - ] - - lastChangeTime [ - "Answer the last change time of the file identified by the receiver - (the `last change time' has to do with permissions, ownership and the - like). On some operating systems, this could actually be the - file creation time." - - - stCtime isNil ifTrue: [self refresh]. - ^stCtime - ] - - creationTime [ - "Answer the creation time of the file identified by the receiver. - On some operating systems, this could actually be the last change time - (the `last change time' has to do with permissions, ownership and the - like)." - - - stCtime isNil ifTrue: [self refresh]. - ^stCtime - ] - - lastModifyTime [ - "Answer the last modify time of the file identified by the receiver - (the `last modify time' has to do with the actual file contents)." - - - stMtime isNil ifTrue: [self refresh]. - ^stMtime - ] - - refresh [ - "Refresh the statistics for the receiver" - - - self archive fillMember: self - ] - - exists [ - "Answer whether a file with the name contained in the receiver does exist." - - - ^self archive fillMember: self - ] - - mode [ - "Answer the octal permissions for the file." - - - size isNil ifTrue: [self refresh]. - ^mode bitAnd: 4095 - ] - - mode: mode [ - "Set the octal permissions for the file to be `mode'." - - - self archive member: self mode: (mode bitAnd: 4095) - ] - - isSymbolicLink [ - "Answer whether a file with the name contained in the receiver does exist - and identifies a symbolic link." - - - size isNil ifTrue: [self refresh]. - ^(mode bitAnd: 8r170000) = 8r120000 - ] - - isDirectory [ - "Answer whether a file with the name contained in the receiver does exist - and identifies a directory." - - - size isNil ifTrue: [self refresh]. - ^(mode bitAnd: 8r170000) = 8r40000 - ] - - isReadable [ - "Answer whether a file with the name contained in the receiver does exist - and is readable" - - - ^true - ] - - isWriteable [ - "Answer whether a file with the name contained in the receiver does exist - and is writeable" - - - ^true - ] - - isExecutable [ - "Answer whether a file with the name contained in the receiver does exist - and is executable" - - - ^false - ] - - isAccessible [ - "Answer whether a directory with the name contained in the receiver does exist - and is accessible" - - - ^true - ] - - open: class mode: mode ifFail: aBlock [ - "Open the receiver in the given mode (as answered by FileStream's - class constant methods)" - - - self subclassResponsibility - ] - - update: aspect [ - "Private - Update the in-archive version of the file before closing." - - - aspect == #beforeClosing - ifTrue: [self archive updateMember: self] aspect == #afterClosing - ifTrue: - [self archive refresh. - self refresh] - ] - - remove [ - "Remove the file with the given path name" - - - self archive removeMember: self. - File checkError - ] - - renameTo: newFileName [ - "Rename the file with the given path name oldFileName to newFileName" - - - self notYetImplemented - ] - - at: aName [ - "Answer a FilePath for a file named `aName' residing in the directory - represented by the receiver." - - - ^self archive at: (File append: aName to: self name) - ] - - , aName [ - "Answer an object of the same kind as the receiver, whose name - is suffixed with aName." - - ^self archive at: (self name, aName) - ] - - createDirectory: dirName [ - "Create a subdirectory of the receiver, naming it dirName." - - - self archive createDirectory: (File append: dirName to: self name) - ] - - namesDo: aBlock [ - "Evaluate aBlock once for each file in the directory represented by the - receiver, passing its name." - - - self archive member: self do: aBlock - ] -] - -] - - - -Namespace current: VFS [ - -ArchiveMember subclass: TmpFileArchiveMember [ - | file | - - - - - release [ - "Release the resources used by the receiver that don't survive when - reloading a snapshot." - - "Remove the file that was temporarily holding the file contents" - - - self extracted ifTrue: [ file remove. file := nil ]. - super release - ] - - open: class mode: mode ifFail: aBlock [ - "Open the receiver in the given mode (as answered by FileStream's - class constant methods)" - - - | fileStream | - self file isNil ifTrue: [^aBlock value]. - fileStream := file open: class mode: mode ifFail: [^aBlock value]. - mode == FileStream read ifFalse: [fileStream addDependent: self]. - fileStream setFile: self. - ^fileStream - ] - - extracted [ - "Answer whether the file has already been extracted to disk." - ^file notNil - ] - - file [ - "Answer the real file name which holds the file contents, - or nil if it does not apply." - - - file isNil ifFalse: [^file]. - self exists ifFalse: [^nil]. - file := self archive extractMember: self. - ^file - ] -] - -] - - diff --git a/kernel/ValueAdapt.st b/kernel/ValueAdapt.st deleted file mode 100644 index d2957fd3..00000000 --- a/kernel/ValueAdapt.st +++ /dev/null @@ -1,406 +0,0 @@ -"====================================================================== -| -| ValueAdaptor hierarchy Method Definitions -| -| - ======================================================================" - -"====================================================================== -| -| Copyright 1999, 2000, 2001, 2002, 2008, 2009 Free Software Foundation, Inc. -| Written by Paolo Bonzini. -| -| This file is part of the GNU Smalltalk class library. -| -| The GNU Smalltalk class library is free software; you can redistribute it -| and/or modify it under the terms of the GNU Lesser General Public License -| as published by the Free Software Foundation; either version 2.1, or (at -| your option) any later version. -| -| The GNU Smalltalk class library is distributed in the hope that it will be -| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of -| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser -| General Public License for more details. -| -| You should have received a copy of the GNU Lesser General Public License -| along with the GNU Smalltalk class library; see the file COPYING.LIB. -| If not, write to the Free Software Foundation, 59 Temple Place - Suite -| 330, Boston, MA 02110-1301, USA. -| - ======================================================================" - - - -Object subclass: ValueAdaptor [ - - - - - ValueAdaptor class >> new [ - "We don't know enough of subclasses to have a shared implementation of new" - - - self shouldNotImplement - ] - - printOn: aStream [ - "Print a representation of the receiver" - - - aStream - print: self class; - nextPut: $(; - print: self value; - nextPut: $) - ] - - value: anObject [ - "Set the value of the receiver. Must be implemented by ValueAdaptor's - subclasses" - - - self subclassResponsibility - ] - - value [ - "Retrive the value of the receiver. Must be implemented by ValueAdaptor's - subclasses" - - - self subclassResponsibility - ] -] - - - -ValueAdaptor subclass: NullValueHolder [ - - - - - NullValueHolder class [ - | uniqueInstance | - - ] - - NullValueHolder class >> new [ - "Not used -- use `ValueHolder null' instead" - - - ^self shouldNotImplement - ] - - NullValueHolder class >> uniqueInstance [ - "Answer the sole instance of NullValueHolder" - - - ^uniqueInstance isNil - ifTrue: [uniqueInstance := self basicNew] - ifFalse: [uniqueInstance] - ] - - value: anObject [ - "Set the value of the receiver. Do nothing, discard the value" - - - - ] - - value [ - "Retrive the value of the receiver. Always answer nil" - - - ^nil - ] -] - - - -ValueAdaptor subclass: ValueHolder [ - | value | - - - - - ValueHolder class >> new [ - "Create a ValueHolder whose starting value is nil" - - - ^self basicNew initialize - ] - - ValueHolder class >> null [ - "Answer the sole instance of NullValueHolder" - - - ^NullValueHolder uniqueInstance - ] - - ValueHolder class >> with: anObject [ - "Create a ValueHolder whose starting value is anObject" - - - ^self new value: anObject - ] - - value: anObject [ - "Set the value of the receiver." - - - value := anObject - ] - - value [ - "Get the value of the receiver." - - - ^value - ] - - initialize [ - "Private - set the initial value of the receiver" - - - value := nil - ] -] - - - -Object extend [ - - asValue [ - "Answer a ValueHolder whose initial value is the receiver." - - - ^ValueHolder with: self - ] - -] - - - -ValueHolder subclass: Promise [ - | sema error | - - - - - Promise class >> for: aBlock [ - "Invoke aBlock at an indeterminate time in an indeterminate - process before answering its value from #value sent to my - result." - - | p | - p := Promise new. - [[ p value: aBlock value ] - on: Error - do: [ :ex | p errorValue: ex. ex return ]] fork. - ^p - ] - - Promise class >> null [ - - self shouldNotImplement - ] - - hasError [ - "Answer whether calling #value will raise an exception." - - - ^error notNil - ] - - hasValue [ - "Answer whether we already have a value (or calling #value will - raise an error)." - - - ^sema isNil - ] - - value: anObject [ - "Set the value of the receiver." - - - - super value: anObject. - [sema notifyAll. sema := nil] valueWithoutPreemption - ] - - errorValue: anException [ - "Private - Raise anException whenever #value is called." - - error := anException. - [sema notifyAll. sema := nil] valueWithoutPreemption - ] - - value [ - "Get the value of the receiver." - - - - "This is guaranteed to execute atomically by the VM!" - sema == nil ifFalse: [sema wait]. - - ^error isNil - ifTrue: [ super value ] - ifFalse: [ error copy signal ] - ] - - printOn: aStream [ - "Print a representation of the receiver" - - - aStream print: self class. - self hasValue ifFalse: [ aStream nextPutAll: '(???)' ]. - self hasError ifTrue: [ aStream nextPutAll: '(Error!)' ]. - - aStream - nextPut: $(; - print: self value; - nextPut: $) - ] - - initialize [ - "Private - set the initial state of the receiver" - - - super initialize. - sema := Semaphore new - ] -] - - - -ValueAdaptor subclass: PluggableAdaptor [ - | getBlock putBlock | - - - - - PluggableAdaptor class >> getBlock: getBlock putBlock: putBlock [ - "Answer a PluggableAdaptor using the given blocks to implement - #value and #value:" - - - ^self basicNew getBlock: getBlock putBlock: putBlock - ] - - PluggableAdaptor class >> on: anObject getSelector: getSelector putSelector: putSelector [ - "Answer a PluggableAdaptor using anObject's getSelector message to - implement #value, and anObject's putSelector message to implement - #value:" - - - ^self basicNew getBlock: [anObject perform: getSelector] - putBlock: [:value | anObject perform: putSelector with: value] - ] - - PluggableAdaptor class >> on: anObject aspect: aSymbol [ - "Answer a PluggableAdaptor using anObject's aSymbol message to - implement #value, and anObject's aSymbol: message (aSymbol - followed by a colon) to implement #value:" - - - ^self - on: anObject - getSelector: aSymbol - putSelector: (aSymbol , ':') asSymbol - ] - - PluggableAdaptor class >> on: anObject index: anIndex [ - "Answer a PluggableAdaptor using anObject's #at: and #at:put: - message to implement #value and #value:; the first parameter - of #at: and #at:put: is anIndex" - - - ^self getBlock: [anObject at: anIndex] - putBlock: [:value | anObject at: anIndex put: value] - ] - - PluggableAdaptor class >> on: aDictionary key: aKey [ - "Same as #on:index:. Provided for clarity and completeness." - - - ^self on: aDictionary index: aKey - ] - - value: anObject [ - "Set the value of the receiver." - - - putBlock value: anObject - ] - - value [ - "Get the value of the receiver." - - - ^getBlock value - ] - - getBlock: get putBlock: put [ - - getBlock := get. - putBlock := put. - ^self - ] -] - - - -PluggableAdaptor subclass: DelayedAdaptor [ - | value delayed | - - - - - trigger [ - "Really set the value of the receiver." - - - delayed - ifTrue: - [delayed := false. - super value: value] - ] - - value: anObject [ - "Set the value of the receiver - actually, the value is cached and - is not set until the #trigger method is sent." - - - value := anObject. - delayed := true - ] - - value [ - "Get the value of the receiver." - - - ^delayed ifTrue: [value] ifFalse: [getBlock value] - ] - - getBlock: get putBlock: put [ - - delayed := false. - ^super getBlock: get putBlock: put - ] -] - diff --git a/kernel/VarBinding.st b/kernel/VariableBinding.st similarity index 100% rename from kernel/VarBinding.st rename to kernel/VariableBinding.st diff --git a/kernel/WeakObjects.st b/kernel/WeakObjects.st deleted file mode 100644 index 83429141..00000000 --- a/kernel/WeakObjects.st +++ /dev/null @@ -1,673 +0,0 @@ -"===================================================================== -| -| Weak collections -| -| - ======================================================================" - -"====================================================================== -| -| Copyright 1999,2000,2001,2002,2007,2008,2009 Free Software Foundation, Inc. -| Written by Paolo Bonzini. -| -| This file is part of the GNU Smalltalk class library. -| -| The GNU Smalltalk class library is free software; you can redistribute it -| and/or modify it under the terms of the GNU Lesser General Public License -| as published by the Free Software Foundation; either version 2.1, or (at -| your option) any later version. -| -| The GNU Smalltalk class library is distributed in the hope that it will be -| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of -| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser -| General Public License for more details. -| -| You should have received a copy of the GNU Lesser General Public License -| along with the GNU Smalltalk class library; see the file COPYING.LIB. -| If not, write to the Free Software Foundation, 59 Temple Place - Suite -| 330, Boston, MA 02110-1301, USA. -| - ======================================================================" - - - -Array subclass: WeakArray [ - | values nilValues | - - - - - WeakArray class >> new [ - "Create a new WeakArray of size 0." - - - ^self new: 0 - ] - - WeakArray class >> new: size [ - "Create a new WeakArray of the given size." - - - ^self basicNew initialize: size - ] - - postLoad [ - "Called after loading an object; must restore it to the state before - `preStore' was called. Make it weak again" - - - values makeWeak - ] - - initialize: size [ - "Private - Initialize the values array; plus, make it weak and create - the ByteArray used to track garbage collected values" - - - values := Array new: size. - values makeWeak. - nilValues := ByteArray new: size withAll: 1 - ] - - values: anArray whichAreNil: nilArray [ - "Private - Initialize the values array to anArray and make it weak; - plus, set to a copy of nilArray the ByteArray used to track garbage - collected values" - - - values := anArray. - values makeWeak. - nilValues := ByteArray new: anArray size. - nilValues - replaceFrom: 1 - to: anArray size - with: nilArray - startingAt: 1 - ] - - at: index [ - "Answer the index-th item of the receiver, or nil if it has been - garbage collected." - - - ^values at: index - ] - - atAll: indices put: object [ - "Put object at every index contained in the indices collection" - - - nilValues atAll: indices put: (object isNil ifTrue: [1] ifFalse: [0]). - ^values atAll: indices put: object - ] - - atAllPut: object [ - "Put object at every index in the receiver" - - - nilValues atAllPut: (object isNil ifTrue: [1] ifFalse: [0]). - ^values atAllPut: object - ] - - at: index put: object [ - "Store the value associated to the given index; plus, - store in nilValues whether the object is nil. nil objects whose - associated item of nilValues is 1 were touched by the garbage - collector." - - - nilValues at: index put: (object isNil ifTrue: [1] ifFalse: [0]). - ^values at: index put: object - ] - - clearGCFlag: index [ - "Clear the `object has been garbage collected' flag for the item - at the given index" - - - | object | - object := values at: index. - nilValues at: index put: (object isNil ifTrue: [1] ifFalse: [0]) - ] - - do: aBlock [ - "Evaluate aBlock for all the elements in the array, including the - garbage collected ones (pass nil for those)." - - - values do: aBlock - ] - - aliveObjectsDo: aBlock [ - "Evaluate aBlock for all the elements in the array, excluding the - garbage collected ones. Note: a finalized object stays alive until - the next collection (the collector has no means to see whether it was - resuscitated by the finalizer), so an object being alive does not mean - that it is usable." - - - | value | - 1 to: self size - do: - [:i | - (value := values at: i) isNil - ifFalse: [aBlock value: value] - ifTrue: [(nilValues at: i) = 0 ifFalse: [aBlock value: value]]] - ] - - isAlive: index [ - "Answer whether the item at the given index is still alive or has been - garbage collected. Note: a finalized object stays alive until the next - collection (the collector has no means to see whether it was resuscitated - by the finalizer), so an object being alive does not mean that it is - usable." - - - ^(values at: index) notNil or: [(nilValues at: index) = 1] - ] - - size [ - "Answer the number of items in the receiver" - - - ^values size - ] - - asArray [ - "Answer a non-weak version of the receiver" - - - ^values copy - ] - - deepCopy [ - "Returns a deep copy of the receiver (the instance variables are - copies of the receiver's instance variables)" - - - ^self class basicNew values: values deepCopy whichAreNil: nilValues - ] - - shallowCopy [ - "Returns a shallow copy of the receiver (the instance variables are - not copied)" - - - ^self class basicNew values: values shallowCopy whichAreNil: nilValues - ] - - species [ - "Answer Array; this method is used in the #copyEmpty: message, which in - turn is used by all collection-returning methods (collect:, select:, - reject:, etc.)." - - - ^Array - ] -] - - - -Set subclass: WeakSet [ - - - - - - add: newObject [ - "Add newObject to the set, if and only if the set doesn't already contain - an occurrence of it. Don't fail if a duplicate is found. Answer newObject" - - - | index | - index := self findIndex: newObject. - (self primAt: index) isNil ifTrue: [ - self incrementTally ifTrue: [index := self findIndex: newObject]. - self primAt: index put: (self newAssociation: newObject)]. - ^newObject - ] - - do: aBlock [ - "Enumerate all the non-nil members of the set" - - - 1 to: self primSize - do: [:i | (self primAt: i) notNil ifTrue: [aBlock value: (self primAt: i) key]] - ] - - postLoad [ - "Called after loading an object; must restore it to the state before - `preStore' was called. Make it weak again" - - - 1 to: self primSize - do: [:i | (self primAt: i) notNil ifTrue: [(self primAt: i) makeEphemeron]] - ] - - shallowCopy [ - "Returns a shallow copy of the receiver (the instance variables are - not copied)" - - - | copy | - copy := self copyEmpty: self capacity. - self do: [:each | copy addWhileGrowing: (copy newAssociation: each)]. - ^copy - ] - - deepCopy [ - "Returns a deep copy of the receiver (the instance variables are - copies of the receiver's instance variables)" - - - | copy | - copy := self copyEmpty: self capacity. - self do: [:each | copy addWhileGrowing: (copy newAssociation: each copy)]. - ^copy - ] - - newAssociation: key [ - - ^(HomedAssociation - key: key - value: nil - environment: self) - makeEphemeron; - yourself - ] - - mourn: anObject [ - "Private - anObject has been found to have a weak key, remove it." - - "What has to be passed to #remove: is the key, not the whole object." - - - super mourn: anObject key - ] - - findElementIndex: anObject [ - "Tries to see if anObject exists as an indexed variable. As soon as nil - is found, the index of that slot is answered" - - - | index size element | - "Sorry for the lack of readability, but I want speed... :-)" - index := (anObject key hash scramble bitAnd: (size := self primSize) - 1) + 1. - - [(element := self primAt: index) isNil - ifTrue: [^index]. - index == size ifTrue: [index := 1] ifFalse: [index := index + 1]] - repeat - ] - - findIndex: anObject [ - "Tries to see if anObject exists as an indexed variable. As soon as nil - or anObject is found, the index of that slot is answered" - - - | index size element | - "Sorry for the lack of readability, but I want speed... :-)" - index := (anObject identityHash scramble - bitAnd: (size := self primSize) - 1) + 1. - - [((element := self primAt: index) isNil or: [element key = anObject]) - ifTrue: [^index]. - index == size ifTrue: [index := 1] ifFalse: [index := index + 1]] - repeat - ] -] - - - -Dictionary subclass: WeakKeyDictionary [ - | keys | - - - - - - WeakKeyDictionary class >> postLoad [ - "Called after loading an object; must restore it to the state before - `preStore' was called. Make it weak again" - - - 1 to: self primSize - do: [:i | (self primAt: i) notNil ifTrue: [(self primAt: i) makeEphemeron]] - ] - - add: anAssociation [ - "Store value as associated to the given key." - - - | assoc | - assoc := anAssociation. - ((assoc isKindOf: HomedAssociation) and: [assoc environment == self]) - ifFalse: - [assoc := HomedAssociation - key: assoc key - value: assoc value - environment: self]. - assoc makeEphemeron. - ^super add: assoc - ] - - at: key put: value [ - "Store value as associated to the given key." - - - | assoc | - assoc := HomedAssociation - key: key - value: value - environment: self. - assoc makeEphemeron. - self add: assoc. - ^value - ] -] - - - -LookupTable subclass: WeakValueLookupTable [ - | values | - - - - - - WeakValueLookupTable class >> primNew: realSize [ - "Answer a new, uninitialized instance of the receiver with the given size" - - - ^self basicNew: realSize - ] - - at: key ifAbsent: aBlock [ - "Answer the value associated to the given key, or the result of evaluating - aBlock if the key is not found" - - - | result | - result := super at: key ifAbsent: [^aBlock value]. - result isNil ifFalse: [^result]. - self beConsistent. - ^super at: key ifAbsent: aBlock - ] - - at: key ifPresent: aBlock [ - "If aKey is absent, answer nil. Else, evaluate aBlock passing the - associated value and answer the result of the invocation" - - - ^aBlock value: (self at: key ifAbsent: [^nil]) - ] - - includesKey: key [ - "Answer whether the receiver contains the given key." - - - self at: key ifAbsent: [^false]. - ^true - ] - - keysDo: aBlock [ - "Pass each key in the LookupTable to aBlock." - - - self beConsistent. - super keysDo: aBlock - ] - - do: aBlock [ - "Pass each value in the LookupTable to aBlock." - - - self beConsistent. - super do: aBlock - ] - - beConsistent [ - "Private - Clean the dictionary of key->(finalized value) pairs" - - - | keys key | - keys := WriteStream on: (Array new: self size // 3 + 1). - 1 to: self primSize - do: - [:index | - "Find values that are nil and should not be" - - (values isAlive: index) - ifFalse: - [keys nextPut: (self primAt: index). - values clearGCFlag: index]]. - self removeAllKeys: keys contents ifAbsent: [:key | ] - ] - - initialize: anInteger [ - "Private - Initialize the values array; plus, make it weak and create - the ByteArray used to track garbage collected values" - - - super initialize: anInteger. - values := WeakArray new: self primSize - ] - - primSize [ - - ^self basicSize - ] - - primAt: index [ - - ^self basicAt: index - ] - - primAt: index put: object [ - - ^self basicAt: index put: object - ] - - valueAt: index [ - - ^values at: index - ] - - valueAt: index put: object [ - - ^values at: index put: object - ] - - rehash [ - "Rehash the receiver" - - - | key val | - key := Array new: self primSize. - val := Array new: values size. - self resetTally. - 1 to: self primSize - do: - [:i | - "Find values that are nil and should not be" - - (key := self primAt: i) notNil - ifTrue: - [(values isAlive: i) - ifTrue: - [key at: i put: (self primAt: i). - val at: i put: (self valueAt: i)]]. - self primAt: i put: nil. - self valueAt: i put: nil]. - 1 to: self primSize - do: - [:i | - (key at: i) isNil - ifFalse: [self whileGrowingAt: (key at: i) put: (val at: i)]] - ] - - findElementIndex: anObject [ - "Tries to see where anObject can be placed as an indexed variable. - As soon as nil is found, the index of that slot is answered. - anObject also comes from an indexed variable." - - - self beConsistent. - ^ super findElementIndex: anObject - ] - - findIndex: anObject [ - "Tries to see if anObject exists as an indexed variable. As soon as nil - or anObject is found, the index of that slot is answered" - - - self beConsistent. - ^ super findIndex: anObject - ] - - examineOn: aStream [ - "Print all the instance variables and objects in the receiver on aStream" - - - self beConsistent. - super examineOn: aStream - ] -] - - - -WeakSet subclass: WeakIdentitySet [ - - - - - - identityIncludes: anObject [ - "Answer whether I include anObject exactly. As I am an - identity-set, this is the same as #includes:." - - - ^self includes: anObject - ] - - findIndex: anObject [ - "Tries to see if anObject exists as an indexed variable. As soon as nil - or anObject is found, the index of that slot is answered" - - - | index size element | - "Sorry for the lack of readability, but I want speed... :-)" - index := (anObject identityHash scramble - bitAnd: (size := self primSize) - 1) + 1. - - [((element := self primAt: index) isNil or: [element key == anObject]) - ifTrue: [^index]. - index == size ifTrue: [index := 1] ifFalse: [index := index + 1]] - repeat - ] -] - - - -WeakKeyDictionary subclass: WeakKeyIdentityDictionary [ - - - - - - keysClass [ - "Answer the class answered by #keys" - - - ^IdentitySet - ] - - hashFor: anObject [ - "Return an hash value for the item, anObject" - - - ^anObject identityHash - ] - - findIndex: anObject [ - "Tries to see if anObject exists as an indexed variable. As soon as nil - or anObject is found, the index of that slot is answered" - - - | index size element | - "Sorry for the lack of readability, but I want speed... :-)" - index := (anObject identityHash scramble - bitAnd: (size := self primSize) - 1) + 1. - - [((element := self primAt: index) isNil or: [element key == anObject]) - ifTrue: [^index]. - index == size ifTrue: [index := 1] ifFalse: [index := index + 1]] - repeat - ] -] - - - -WeakValueLookupTable subclass: WeakValueIdentityDictionary [ - - - - - - keysClass [ - "Answer the class answered by #keys" - - - ^IdentitySet - ] - - hashFor: anObject [ - "Return an hash value for the item, anObject" - - - ^anObject identityHash - ] - - findIndex: anObject [ - "Tries to see if anObject exists as an indexed variable. As soon as nil - or anObject is found, the index of that slot is answered" - - - | index size element | - self beConsistent. - - "Sorry for the lack of readability, but I want speed... :-)" - index := (anObject identityHash scramble - bitAnd: (size := self primSize) - 1) + 1. - - [((element := self primAt: index) isNil or: [element == anObject]) - ifTrue: [^index]. - index == size ifTrue: [index := 1] ifFalse: [index := index + 1]] - repeat - ] -] - diff --git a/kernel/WordArray.st b/kernel/WordArray.st new file mode 100644 index 00000000..71440234 --- /dev/null +++ b/kernel/WordArray.st @@ -0,0 +1,49 @@ +"===================================================================== +| +| Variations on the Array class +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2001, 2002, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +ArrayedCollection subclass: WordArray [ + + + + + + at: anIndex ifAbsent: aBlock [ + "Answer the index-th indexed instance variable of the receiver" + + + + ^self checkIndexableBounds: anIndex ifAbsent: aBlock + ] + +] diff --git a/kernel/autoload/Autoload.st b/kernel/autoload/Autoload.st new file mode 100644 index 00000000..2d490978 --- /dev/null +++ b/kernel/autoload/Autoload.st @@ -0,0 +1,109 @@ +"====================================================================== +| +| File autoloading mechanism +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1991,1992,94,95,99,2000,2001,2002,2008 +| Free Software Foundation, Inc. +| Written by Steve Byrne. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +nil subclass: Autoload [ + + + + + Autoload class >> class: nameSymbol from: fileNameString [ + "Make Smalltalk automatically load the class named nameSymbol + from fileNameString when needed" + + + ^self + class: nameSymbol + in: Namespace current + from: fileNameString + ] + + Autoload class >> class: nameSymbol loader: anObject [ + "Make Smalltalk automatically load the class named nameSymbol. + When the class is needed, anObject will be sent #autoload. + By default, instances of FilePath and Package can be used." + + + ^self + class: nameSymbol + in: Namespace current + loader: anObject + ] + + Autoload class >> class: nameSymbol in: aNamespace from: fileNameString [ + "Make Smalltalk automatically load the class named nameSymbol + and residing in aNamespace from fileNameString when needed" + + + | file | + "Check if the file exists." + file := fileNameString asFile. + file withReadStreamDo: [ :rs | ]. + + "Turn the metaclass into an instance of AutoloadClass. To do + this we create a `prototype' in the form of an array and then..." + ^self class: nameSymbol in: aNamespace loader: file + ] + + Autoload class >> class: nameSymbol in: aNamespace loader: anObject [ + "Make Smalltalk automatically load the class named nameSymbol + and residing in aNamespace. When the class is needed, anObject + will be sent #autoload. By default, instances of FilePath and + Package can be used." + + + | autoload | + autoload := Kernel.AutoloadClass class: nameSymbol in: aNamespace loader: anObject. + ^aNamespace at: nameSymbol put: autoload + ] + + class [ + "We need it to access the metaclass instance, because that's what + will load the file." + + + + ] + + doesNotUnderstand: aMessage [ + "Load the class and resend the message to it" + + + ^aMessage reinvokeFor: self class loadedClass_ + ] +] + diff --git a/kernel/Autoload.st b/kernel/autoload/AutoloadClass.st similarity index 58% rename from kernel/Autoload.st rename to kernel/autoload/AutoloadClass.st index 0de18e9f..f4f05209 100644 --- a/kernel/Autoload.st +++ b/kernel/autoload/AutoloadClass.st @@ -32,22 +32,6 @@ -Kernel.PackageInfo extend [ - autoload [ - - - self fileIn - ] -] - -FilePath extend [ - autoload [ - - - self withReadStreamDo: [:rs | rs fileIn ] - ] -] - Namespace current: Kernel [ nil subclass: AutoloadClass [ @@ -138,80 +122,3 @@ and have the class autoloaded.'> ] - - -nil subclass: Autoload [ - - - - - Autoload class >> class: nameSymbol from: fileNameString [ - "Make Smalltalk automatically load the class named nameSymbol - from fileNameString when needed" - - - ^self - class: nameSymbol - in: Namespace current - from: fileNameString - ] - - Autoload class >> class: nameSymbol loader: anObject [ - "Make Smalltalk automatically load the class named nameSymbol. - When the class is needed, anObject will be sent #autoload. - By default, instances of FilePath and Package can be used." - - - ^self - class: nameSymbol - in: Namespace current - loader: anObject - ] - - Autoload class >> class: nameSymbol in: aNamespace from: fileNameString [ - "Make Smalltalk automatically load the class named nameSymbol - and residing in aNamespace from fileNameString when needed" - - - | file | - "Check if the file exists." - file := fileNameString asFile. - file withReadStreamDo: [ :rs | ]. - - "Turn the metaclass into an instance of AutoloadClass. To do - this we create a `prototype' in the form of an array and then..." - ^self class: nameSymbol in: aNamespace loader: file - ] - - Autoload class >> class: nameSymbol in: aNamespace loader: anObject [ - "Make Smalltalk automatically load the class named nameSymbol - and residing in aNamespace. When the class is needed, anObject - will be sent #autoload. By default, instances of FilePath and - Package can be used." - - - | autoload | - autoload := Kernel.AutoloadClass class: nameSymbol in: aNamespace loader: anObject. - ^aNamespace at: nameSymbol put: autoload - ] - - class [ - "We need it to access the metaclass instance, because that's what - will load the file." - - - - ] - - doesNotUnderstand: aMessage [ - "Load the class and resend the message to it" - - - ^aMessage reinvokeFor: self class loadedClass_ - ] -] - diff --git a/kernel/autoload/Extensions.st b/kernel/autoload/Extensions.st new file mode 100644 index 00000000..bf8a1321 --- /dev/null +++ b/kernel/autoload/Extensions.st @@ -0,0 +1,48 @@ +"====================================================================== +| +| File autoloading mechanism +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1991,1992,94,95,99,2000,2001,2002,2008 +| Free Software Foundation, Inc. +| Written by Steve Byrne. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + +Kernel.PackageInfo extend [ + autoload [ + + + self fileIn + ] +] + +FilePath extend [ + autoload [ + + + self withReadStreamDo: [:rs | rs fileIn ] + ] +] + diff --git a/kernel/Builtins.st b/kernel/bootstrap/Behavior.st similarity index 67% rename from kernel/Builtins.st rename to kernel/bootstrap/Behavior.st index 666db545..a6ded2d8 100644 --- a/kernel/Builtins.st +++ b/kernel/bootstrap/Behavior.st @@ -40,20 +40,7 @@ Behavior extend [ ] -] -Object extend [ - class [ - "Answer the class to which the receiver belongs" - - - self primitiveFailed - ] -] - - -Behavior extend [ - new [ "Create a new instance of a class with no indexed instance variables" @@ -61,7 +48,7 @@ Behavior extend [ self isFixed ifFalse: [ ^self new: 0 ]. ^self primitiveFailed ] - + basicNew [ "Create a new instance of a class with no indexed instance variables; this method must not be overridden." @@ -70,20 +57,20 @@ Behavior extend [ self isFixed ifFalse: [ ^self basicNew: 0 ]. ^self primitiveFailed ] - + new: numInstanceVariables [ "Create a new instance of a class with indexed instance variables. The instance has numInstanceVariables indexed instance variables." self isFixed ifTrue: [ - SystemExceptions.WrongMessageSent signalOn: #new: useInstead: #new + SystemExceptions.WrongMessageSent signalOn: #new: useInstead: #new ]. numInstanceVariables isSmallInteger ifTrue: [ ^self primitiveFailed ]. - + ^SystemExceptions.WrongClass signalOn: numInstanceVariables mustBe: SmallInteger ] - + basicNew: numInstanceVariables [ "Create a new instance of a class with indexed instance variables. The instance has numInstanceVariables indexed instance variables; @@ -91,72 +78,17 @@ Behavior extend [ self isFixed ifTrue: [ - SystemExceptions.WrongMessageSent signalOn: #basicNew: useInstead: #basicNew + SystemExceptions.WrongMessageSent signalOn: #basicNew: useInstead: #basicNew ]. numInstanceVariables isSmallInteger ifTrue: [ ^self primitiveFailed ]. - + ^SystemExceptions.WrongClass signalOn: numInstanceVariables mustBe: SmallInteger ] -] - - -Dictionary extend [ - - Dictionary class >> new [ - "Answer a new Dictionary. This method, actually, won't last long - - until LookupTbl.st is loaded" - - - ^self primitiveFailed - ] - - at: key [ - "Answer the value associated with the given key in the receiver. - This method, actually, won't last long - until LookupTbl.st is loaded" - - - ^self primitiveFailed - ] -] - - - -Class extend [ - - subclass: classNameString environment: aNamespace [ - - ^(aNamespace at: classNameString) - ] - - category: aString [ - "Define a category for the receiver" - - category := aString - ] - - comment: aString [ - "Define a comment for the receiver" - - comment := aString - ] -] - -ClassDescription extend [ - import: aString [ - ] -] - -Behavior extend [ + instanceVariableNames: ivn [ ] shape: aSymbol [ ] ] - -UndefinedObject extend [ - subclass: classNameString environment: aNamespace [ - - ^(aNamespace at: classNameString) - ] -] + diff --git a/kernel/bootstrap/Class.st b/kernel/bootstrap/Class.st new file mode 100644 index 00000000..b3826e21 --- /dev/null +++ b/kernel/bootstrap/Class.st @@ -0,0 +1,54 @@ +"===================================================================== +| +| Smalltalk built in methods. These are read in by the system +| initially, to prepare the execution environment. +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1988,89,90,91,92,94,95,99,2000,2001,2002,2006,2007 +| Free Software Foundation, Inc. +| Written by Steve Byrne. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + +Class extend [ + + subclass: classNameString environment: aNamespace [ + + ^(aNamespace at: classNameString) + ] + + category: aString [ + "Define a category for the receiver" + + category := aString + ] + + comment: aString [ + "Define a comment for the receiver" + + comment := aString + ] +] + diff --git a/kernel/bootstrap/ClassDescription.st b/kernel/bootstrap/ClassDescription.st new file mode 100644 index 00000000..596a8656 --- /dev/null +++ b/kernel/bootstrap/ClassDescription.st @@ -0,0 +1,39 @@ +"===================================================================== +| +| Smalltalk built in methods. These are read in by the system +| initially, to prepare the execution environment. +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1988,89,90,91,92,94,95,99,2000,2001,2002,2006,2007 +| Free Software Foundation, Inc. +| Written by Steve Byrne. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + +ClassDescription extend [ + import: aString [ + ] +] + diff --git a/kernel/bootstrap/Dictionary.st b/kernel/bootstrap/Dictionary.st new file mode 100644 index 00000000..8e4b84c5 --- /dev/null +++ b/kernel/bootstrap/Dictionary.st @@ -0,0 +1,53 @@ +"===================================================================== +| +| Smalltalk built in methods. These are read in by the system +| initially, to prepare the execution environment. +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1988,89,90,91,92,94,95,99,2000,2001,2002,2006,2007 +| Free Software Foundation, Inc. +| Written by Steve Byrne. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + +Dictionary extend [ + + Dictionary class >> new [ + "Answer a new Dictionary. This method, actually, won't last long - + until LookupTbl.st is loaded" + + + ^self primitiveFailed + ] + + at: key [ + "Answer the value associated with the given key in the receiver. + This method, actually, won't last long - until LookupTbl.st is loaded" + + + ^self primitiveFailed + ] +] + diff --git a/kernel/bootstrap/Object.st b/kernel/bootstrap/Object.st new file mode 100644 index 00000000..fb301a0f --- /dev/null +++ b/kernel/bootstrap/Object.st @@ -0,0 +1,43 @@ +"===================================================================== +| +| Smalltalk built in methods. These are read in by the system +| initially, to prepare the execution environment. +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1988,89,90,91,92,94,95,99,2000,2001,2002,2006,2007 +| Free Software Foundation, Inc. +| Written by Steve Byrne. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + +Object extend [ + class [ + "Answer the class to which the receiver belongs" + + + self primitiveFailed + ] +] + diff --git a/kernel/bootstrap/UndefinedObject.st b/kernel/bootstrap/UndefinedObject.st new file mode 100644 index 00000000..fc7ad9a6 --- /dev/null +++ b/kernel/bootstrap/UndefinedObject.st @@ -0,0 +1,41 @@ +"===================================================================== +| +| Smalltalk built in methods. These are read in by the system +| initially, to prepare the execution environment. +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1988,89,90,91,92,94,95,99,2000,2001,2002,2006,2007 +| Free Software Foundation, Inc. +| Written by Steve Byrne. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + +UndefinedObject extend [ + subclass: classNameString environment: aNamespace [ + + ^(aNamespace at: classNameString) + ] +] + diff --git a/kernel/collection/weak/WeakArray.st b/kernel/collection/weak/WeakArray.st new file mode 100644 index 00000000..213cf70c --- /dev/null +++ b/kernel/collection/weak/WeakArray.st @@ -0,0 +1,209 @@ +"===================================================================== +| +| Weak collections +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1999,2000,2001,2002,2007,2008,2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Array subclass: WeakArray [ + | values nilValues | + + + + + WeakArray class >> new [ + "Create a new WeakArray of size 0." + + + ^self new: 0 + ] + + WeakArray class >> new: size [ + "Create a new WeakArray of the given size." + + + ^self basicNew initialize: size + ] + + postLoad [ + "Called after loading an object; must restore it to the state before + `preStore' was called. Make it weak again" + + + values makeWeak + ] + + initialize: size [ + "Private - Initialize the values array; plus, make it weak and create + the ByteArray used to track garbage collected values" + + + values := Array new: size. + values makeWeak. + nilValues := ByteArray new: size withAll: 1 + ] + + values: anArray whichAreNil: nilArray [ + "Private - Initialize the values array to anArray and make it weak; + plus, set to a copy of nilArray the ByteArray used to track garbage + collected values" + + + values := anArray. + values makeWeak. + nilValues := ByteArray new: anArray size. + nilValues + replaceFrom: 1 + to: anArray size + with: nilArray + startingAt: 1 + ] + + at: index [ + "Answer the index-th item of the receiver, or nil if it has been + garbage collected." + + + ^values at: index + ] + + atAll: indices put: object [ + "Put object at every index contained in the indices collection" + + + nilValues atAll: indices put: (object isNil ifTrue: [1] ifFalse: [0]). + ^values atAll: indices put: object + ] + + atAllPut: object [ + "Put object at every index in the receiver" + + + nilValues atAllPut: (object isNil ifTrue: [1] ifFalse: [0]). + ^values atAllPut: object + ] + + at: index put: object [ + "Store the value associated to the given index; plus, + store in nilValues whether the object is nil. nil objects whose + associated item of nilValues is 1 were touched by the garbage + collector." + + + nilValues at: index put: (object isNil ifTrue: [1] ifFalse: [0]). + ^values at: index put: object + ] + + clearGCFlag: index [ + "Clear the `object has been garbage collected' flag for the item + at the given index" + + + | object | + object := values at: index. + nilValues at: index put: (object isNil ifTrue: [1] ifFalse: [0]) + ] + + do: aBlock [ + "Evaluate aBlock for all the elements in the array, including the + garbage collected ones (pass nil for those)." + + + values do: aBlock + ] + + aliveObjectsDo: aBlock [ + "Evaluate aBlock for all the elements in the array, excluding the + garbage collected ones. Note: a finalized object stays alive until + the next collection (the collector has no means to see whether it was + resuscitated by the finalizer), so an object being alive does not mean + that it is usable." + + + | value | + 1 to: self size + do: + [:i | + (value := values at: i) isNil + ifFalse: [aBlock value: value] + ifTrue: [(nilValues at: i) = 0 ifFalse: [aBlock value: value]]] + ] + + isAlive: index [ + "Answer whether the item at the given index is still alive or has been + garbage collected. Note: a finalized object stays alive until the next + collection (the collector has no means to see whether it was resuscitated + by the finalizer), so an object being alive does not mean that it is + usable." + + + ^(values at: index) notNil or: [(nilValues at: index) = 1] + ] + + size [ + "Answer the number of items in the receiver" + + + ^values size + ] + + asArray [ + "Answer a non-weak version of the receiver" + + + ^values copy + ] + + deepCopy [ + "Returns a deep copy of the receiver (the instance variables are + copies of the receiver's instance variables)" + + + ^self class basicNew values: values deepCopy whichAreNil: nilValues + ] + + shallowCopy [ + "Returns a shallow copy of the receiver (the instance variables are + not copied)" + + + ^self class basicNew values: values shallowCopy whichAreNil: nilValues + ] + + species [ + "Answer Array; this method is used in the #copyEmpty: message, which in + turn is used by all collection-returning methods (collect:, select:, + reject:, etc.)." + + + ^Array + ] +] diff --git a/kernel/collection/weak/WeakIdentitySet.st b/kernel/collection/weak/WeakIdentitySet.st new file mode 100644 index 00000000..9e737d11 --- /dev/null +++ b/kernel/collection/weak/WeakIdentitySet.st @@ -0,0 +1,66 @@ +"===================================================================== +| +| Weak collections +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1999,2000,2001,2002,2007,2008,2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +WeakSet subclass: WeakIdentitySet [ + + + + + + identityIncludes: anObject [ + "Answer whether I include anObject exactly. As I am an + identity-set, this is the same as #includes:." + + + ^self includes: anObject + ] + + findIndex: anObject [ + "Tries to see if anObject exists as an indexed variable. As soon as nil + or anObject is found, the index of that slot is answered" + + + | index size element | + "Sorry for the lack of readability, but I want speed... :-)" + index := (anObject identityHash scramble + bitAnd: (size := self primSize) - 1) + 1. + + [((element := self primAt: index) isNil or: [element key == anObject]) + ifTrue: [^index]. + index == size ifTrue: [index := 1] ifFalse: [index := index + 1]] + repeat + ] +] diff --git a/kernel/collection/weak/WeakKeyDictionary.st b/kernel/collection/weak/WeakKeyDictionary.st new file mode 100644 index 00000000..8c60dfdd --- /dev/null +++ b/kernel/collection/weak/WeakKeyDictionary.st @@ -0,0 +1,83 @@ +"===================================================================== +| +| Weak collections +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1999,2000,2001,2002,2007,2008,2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Dictionary subclass: WeakKeyDictionary [ + | keys | + + + + + + WeakKeyDictionary class >> postLoad [ + "Called after loading an object; must restore it to the state before + `preStore' was called. Make it weak again" + + + 1 to: self primSize + do: [:i | (self primAt: i) notNil ifTrue: [(self primAt: i) makeEphemeron]] + ] + + add: anAssociation [ + "Store value as associated to the given key." + + + | assoc | + assoc := anAssociation. + ((assoc isKindOf: HomedAssociation) and: [assoc environment == self]) + ifFalse: + [assoc := HomedAssociation + key: assoc key + value: assoc value + environment: self]. + assoc makeEphemeron. + ^super add: assoc + ] + + at: key put: value [ + "Store value as associated to the given key." + + + | assoc | + assoc := HomedAssociation + key: key + value: value + environment: self. + assoc makeEphemeron. + self add: assoc. + ^value + ] +] diff --git a/kernel/collection/weak/WeakKeyIdentityDictionary.st b/kernel/collection/weak/WeakKeyIdentityDictionary.st new file mode 100644 index 00000000..89a8234f --- /dev/null +++ b/kernel/collection/weak/WeakKeyIdentityDictionary.st @@ -0,0 +1,74 @@ +"===================================================================== +| +| Weak collections +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1999,2000,2001,2002,2007,2008,2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +WeakKeyDictionary subclass: WeakKeyIdentityDictionary [ + + + + + + keysClass [ + "Answer the class answered by #keys" + + + ^IdentitySet + ] + + hashFor: anObject [ + "Return an hash value for the item, anObject" + + + ^anObject identityHash + ] + + findIndex: anObject [ + "Tries to see if anObject exists as an indexed variable. As soon as nil + or anObject is found, the index of that slot is answered" + + + | index size element | + "Sorry for the lack of readability, but I want speed... :-)" + index := (anObject identityHash scramble + bitAnd: (size := self primSize) - 1) + 1. + + [((element := self primAt: index) isNil or: [element key == anObject]) + ifTrue: [^index]. + index == size ifTrue: [index := 1] ifFalse: [index := index + 1]] + repeat + ] +] + diff --git a/kernel/collection/weak/WeakSet.st b/kernel/collection/weak/WeakSet.st new file mode 100644 index 00000000..2887e184 --- /dev/null +++ b/kernel/collection/weak/WeakSet.st @@ -0,0 +1,144 @@ +"===================================================================== +| +| Weak collections +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1999,2000,2001,2002,2007,2008,2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Set subclass: WeakSet [ + + + + + + add: newObject [ + "Add newObject to the set, if and only if the set doesn't already contain + an occurrence of it. Don't fail if a duplicate is found. Answer newObject" + + + | index | + index := self findIndex: newObject. + (self primAt: index) isNil ifTrue: [ + self incrementTally ifTrue: [index := self findIndex: newObject]. + self primAt: index put: (self newAssociation: newObject)]. + ^newObject + ] + + do: aBlock [ + "Enumerate all the non-nil members of the set" + + + 1 to: self primSize + do: [:i | (self primAt: i) notNil ifTrue: [aBlock value: (self primAt: i) key]] + ] + + postLoad [ + "Called after loading an object; must restore it to the state before + `preStore' was called. Make it weak again" + + + 1 to: self primSize + do: [:i | (self primAt: i) notNil ifTrue: [(self primAt: i) makeEphemeron]] + ] + + shallowCopy [ + "Returns a shallow copy of the receiver (the instance variables are + not copied)" + + + | copy | + copy := self copyEmpty: self capacity. + self do: [:each | copy addWhileGrowing: (copy newAssociation: each)]. + ^copy + ] + + deepCopy [ + "Returns a deep copy of the receiver (the instance variables are + copies of the receiver's instance variables)" + + + | copy | + copy := self copyEmpty: self capacity. + self do: [:each | copy addWhileGrowing: (copy newAssociation: each copy)]. + ^copy + ] + + newAssociation: key [ + + ^(HomedAssociation + key: key + value: nil + environment: self) + makeEphemeron; + yourself + ] + + mourn: anObject [ + "Private - anObject has been found to have a weak key, remove it." + + "What has to be passed to #remove: is the key, not the whole object." + + + super mourn: anObject key + ] + + findElementIndex: anObject [ + "Tries to see if anObject exists as an indexed variable. As soon as nil + is found, the index of that slot is answered" + + + | index size element | + "Sorry for the lack of readability, but I want speed... :-)" + index := (anObject key hash scramble bitAnd: (size := self primSize) - 1) + 1. + + [(element := self primAt: index) isNil + ifTrue: [^index]. + index == size ifTrue: [index := 1] ifFalse: [index := index + 1]] + repeat + ] + + findIndex: anObject [ + "Tries to see if anObject exists as an indexed variable. As soon as nil + or anObject is found, the index of that slot is answered" + + + | index size element | + "Sorry for the lack of readability, but I want speed... :-)" + index := (anObject identityHash scramble + bitAnd: (size := self primSize) - 1) + 1. + + [((element := self primAt: index) isNil or: [element key = anObject]) + ifTrue: [^index]. + index == size ifTrue: [index := 1] ifFalse: [index := index + 1]] + repeat + ] +] diff --git a/kernel/collection/weak/WeakValueIdentityDictionary.st b/kernel/collection/weak/WeakValueIdentityDictionary.st new file mode 100644 index 00000000..bdbaa074 --- /dev/null +++ b/kernel/collection/weak/WeakValueIdentityDictionary.st @@ -0,0 +1,76 @@ +"===================================================================== +| +| Weak collections +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1999,2000,2001,2002,2007,2008,2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +WeakValueLookupTable subclass: WeakValueIdentityDictionary [ + + + + + + keysClass [ + "Answer the class answered by #keys" + + + ^IdentitySet + ] + + hashFor: anObject [ + "Return an hash value for the item, anObject" + + + ^anObject identityHash + ] + + findIndex: anObject [ + "Tries to see if anObject exists as an indexed variable. As soon as nil + or anObject is found, the index of that slot is answered" + + + | index size element | + self beConsistent. + + "Sorry for the lack of readability, but I want speed... :-)" + index := (anObject identityHash scramble + bitAnd: (size := self primSize) - 1) + 1. + + [((element := self primAt: index) isNil or: [element == anObject]) + ifTrue: [^index]. + index == size ifTrue: [index := 1] ifFalse: [index := index + 1]] + repeat + ] +] + diff --git a/kernel/collection/weak/WeakValueLookupTable.st b/kernel/collection/weak/WeakValueLookupTable.st new file mode 100644 index 00000000..2ef572bc --- /dev/null +++ b/kernel/collection/weak/WeakValueLookupTable.st @@ -0,0 +1,202 @@ +"===================================================================== +| +| Weak collections +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1999,2000,2001,2002,2007,2008,2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +LookupTable subclass: WeakValueLookupTable [ + | values | + + + + + + WeakValueLookupTable class >> primNew: realSize [ + "Answer a new, uninitialized instance of the receiver with the given size" + + + ^self basicNew: realSize + ] + + at: key ifAbsent: aBlock [ + "Answer the value associated to the given key, or the result of evaluating + aBlock if the key is not found" + + + | result | + result := super at: key ifAbsent: [^aBlock value]. + result isNil ifFalse: [^result]. + self beConsistent. + ^super at: key ifAbsent: aBlock + ] + + at: key ifPresent: aBlock [ + "If aKey is absent, answer nil. Else, evaluate aBlock passing the + associated value and answer the result of the invocation" + + + ^aBlock value: (self at: key ifAbsent: [^nil]) + ] + + includesKey: key [ + "Answer whether the receiver contains the given key." + + + self at: key ifAbsent: [^false]. + ^true + ] + + keysDo: aBlock [ + "Pass each key in the LookupTable to aBlock." + + + self beConsistent. + super keysDo: aBlock + ] + + do: aBlock [ + "Pass each value in the LookupTable to aBlock." + + + self beConsistent. + super do: aBlock + ] + + beConsistent [ + "Private - Clean the dictionary of key->(finalized value) pairs" + + + | keys key | + keys := WriteStream on: (Array new: self size // 3 + 1). + 1 to: self primSize + do: + [:index | + "Find values that are nil and should not be" + + (values isAlive: index) + ifFalse: + [keys nextPut: (self primAt: index). + values clearGCFlag: index]]. + self removeAllKeys: keys contents ifAbsent: [:key | ] + ] + + initialize: anInteger [ + "Private - Initialize the values array; plus, make it weak and create + the ByteArray used to track garbage collected values" + + + super initialize: anInteger. + values := WeakArray new: self primSize + ] + + primSize [ + + ^self basicSize + ] + + primAt: index [ + + ^self basicAt: index + ] + + primAt: index put: object [ + + ^self basicAt: index put: object + ] + + valueAt: index [ + + ^values at: index + ] + + valueAt: index put: object [ + + ^values at: index put: object + ] + + rehash [ + "Rehash the receiver" + + + | key val | + key := Array new: self primSize. + val := Array new: values size. + self resetTally. + 1 to: self primSize + do: + [:i | + "Find values that are nil and should not be" + + (key := self primAt: i) notNil + ifTrue: + [(values isAlive: i) + ifTrue: + [key at: i put: (self primAt: i). + val at: i put: (self valueAt: i)]]. + self primAt: i put: nil. + self valueAt: i put: nil]. + 1 to: self primSize + do: + [:i | + (key at: i) isNil + ifFalse: [self whileGrowingAt: (key at: i) put: (val at: i)]] + ] + + findElementIndex: anObject [ + "Tries to see where anObject can be placed as an indexed variable. + As soon as nil is found, the index of that slot is answered. + anObject also comes from an indexed variable." + + + self beConsistent. + ^ super findElementIndex: anObject + ] + + findIndex: anObject [ + "Tries to see if anObject exists as an indexed variable. As soon as nil + or anObject is found, the index of that slot is answered" + + + self beConsistent. + ^ super findIndex: anObject + ] + + examineOn: aStream [ + "Print all the instance variables and objects in the receiver on aStream" + + + self beConsistent. + super examineOn: aStream + ] +] diff --git a/kernel/DLD.st b/kernel/dld/DLD.st similarity index 66% rename from kernel/DLD.st rename to kernel/dld/DLD.st index 1deb3615..5c55644e 100644 --- a/kernel/DLD.st +++ b/kernel/dld/DLD.st @@ -31,127 +31,6 @@ ======================================================================" - -Namespace current: Kernel [ - -Stream subclass: RoundRobinStream [ - | stream first last | - - - - - RoundRobinStream class >> test: s get: n [ - - n timesRepeat: [s next print]. - Transcript nl - ] - - RoundRobinStream class >> test: s leaveAfter: n [ - - | i | - i := 0. - s do: - [:each | - each print. - (i := i + 1) = n - ifTrue: - [Transcript nl. - ^nil]]. - Transcript nl - ] - - RoundRobinStream class >> testOn: anArray [ - "RoundRobinStream testOn: #(1 2 3 4 5 6)" - - - | s | - s := RoundRobinStream on: anArray readStream. - self test: s get: anArray size + 1. - self test: s get: anArray size + 1. - self test: s get: (anArray size + 1) * 2. - self test: s get: 2. - self test: s leaveAfter: anArray size + 1. - self test: s leaveAfter: anArray size + 1. - self test: s leaveAfter: 1. - self test: s leaveAfter: 1. - self test: s leaveAfter: 2. - self test: s leaveAfter: 2. - self test: s leaveAfter: anArray size + 1. - self test: s leaveAfter: anArray size + 1. - Transcript nl - ] - - RoundRobinStream class >> on: aStream [ - - ^self new stream: aStream - ] - - stream [ - - ^stream - ] - - stream: aStream [ - - stream := aStream - ] - - atEnd [ - - stream atEnd - ifTrue: - [stream reset. - "If there is no established first, we started iterating from the - first element in the stream." - first isNil ifTrue: [^true]]. - ^(last := stream peek) == first - ] - - next [ - - ^self atEnd - ifTrue: [SystemExceptions.EndOfStream signalOn: self] - ifFalse: [stream next] - ] - - do: aBlock [ - "Iterate on all the items in the Stream. If it is not the first iteration, - and the last item was retrieved with #next or passed to a #do: block *that - did a global return*, return from there." - - - stream atEnd - ifTrue: - [stream reset. - stream atEnd ifTrue: [^self]]. - - "Establish the item at which we'll stop iterating. Start from that one." - last isNil ifTrue: [last := stream next]. - first := last. - aBlock value: last. - super do: aBlock. - - "Make sure we will not restart from the last item we passed to aBlock, - because aBlock did not return." - last := nil - ] -] - -] - - Object subclass: DLD [ diff --git a/kernel/dld/Extensions.st b/kernel/dld/Extensions.st new file mode 100644 index 00000000..f4f16caa --- /dev/null +++ b/kernel/dld/Extensions.st @@ -0,0 +1,49 @@ +"====================================================================== +| +| Dynamic Loader Method Definitions +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1992,94,95,99,2000,2001,2002,2003,2005,2008,2009 +| Free Software Foundation, Inc. +| Written by Steve Byrne. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +CFunctionDescriptor class extend [ + + addressOf: function [ + "Answer whether a function is registered (on the C side) with the + given name or is dynamically loadable." + + + + ^(DLD defineExternFunc: function) + ifTrue: [self addressOf: function] "Try again." + ifFalse: [CObject new] + ] + +] + diff --git a/kernel/dld/RoundRobinStream.st b/kernel/dld/RoundRobinStream.st new file mode 100644 index 00000000..5ebe6947 --- /dev/null +++ b/kernel/dld/RoundRobinStream.st @@ -0,0 +1,153 @@ +"====================================================================== +| +| Dynamic Loader Method Definitions +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1992,94,95,99,2000,2001,2002,2003,2005,2008,2009 +| Free Software Foundation, Inc. +| Written by Steve Byrne. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Namespace current: Kernel [ + +Stream subclass: RoundRobinStream [ + | stream first last | + + + + + RoundRobinStream class >> test: s get: n [ + + n timesRepeat: [s next print]. + Transcript nl + ] + + RoundRobinStream class >> test: s leaveAfter: n [ + + | i | + i := 0. + s do: + [:each | + each print. + (i := i + 1) = n + ifTrue: + [Transcript nl. + ^nil]]. + Transcript nl + ] + + RoundRobinStream class >> testOn: anArray [ + "RoundRobinStream testOn: #(1 2 3 4 5 6)" + + + | s | + s := RoundRobinStream on: anArray readStream. + self test: s get: anArray size + 1. + self test: s get: anArray size + 1. + self test: s get: (anArray size + 1) * 2. + self test: s get: 2. + self test: s leaveAfter: anArray size + 1. + self test: s leaveAfter: anArray size + 1. + self test: s leaveAfter: 1. + self test: s leaveAfter: 1. + self test: s leaveAfter: 2. + self test: s leaveAfter: 2. + self test: s leaveAfter: anArray size + 1. + self test: s leaveAfter: anArray size + 1. + Transcript nl + ] + + RoundRobinStream class >> on: aStream [ + + ^self new stream: aStream + ] + + stream [ + + ^stream + ] + + stream: aStream [ + + stream := aStream + ] + + atEnd [ + + stream atEnd + ifTrue: + [stream reset. + "If there is no established first, we started iterating from the + first element in the stream." + first isNil ifTrue: [^true]]. + ^(last := stream peek) == first + ] + + next [ + + ^self atEnd + ifTrue: [SystemExceptions.EndOfStream signalOn: self] + ifFalse: [stream next] + ] + + do: aBlock [ + "Iterate on all the items in the Stream. If it is not the first iteration, + and the last item was retrieved with #next or passed to a #do: block *that + did a global return*, return from there." + + + stream atEnd + ifTrue: + [stream reset. + stream atEnd ifTrue: [^self]]. + + "Establish the item at which we'll stop iterating. Start from that one." + last isNil ifTrue: [last := stream next]. + first := last. + aBlock value: last. + super do: aBlock. + + "Make sure we will not restart from the last item we passed to aBlock, + because aBlock did not return." + last := nil + ] +] + +] + diff --git a/kernel/exceptions/AlreadyDefined.st b/kernel/exceptions/AlreadyDefined.st new file mode 100644 index 00000000..ef98b4df --- /dev/null +++ b/kernel/exceptions/AlreadyDefined.st @@ -0,0 +1,51 @@ +"====================================================================== +| +| ANSI exception handling classes +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2000, 2001, 2002, 2007, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Namespace current: SystemExceptions [ + +InvalidArgument subclass: AlreadyDefined [ + + + + + description [ + "Answer a description for the error" + + + ^'symbol already defined' + ] +] + +] + diff --git a/kernel/exceptions/ArgumentOutOfRange.st b/kernel/exceptions/ArgumentOutOfRange.st new file mode 100644 index 00000000..9187c407 --- /dev/null +++ b/kernel/exceptions/ArgumentOutOfRange.st @@ -0,0 +1,95 @@ +"====================================================================== +| +| ANSI exception handling classes +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2000, 2001, 2002, 2007, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Namespace current: SystemExceptions [ + +InvalidArgument subclass: ArgumentOutOfRange [ + | low high | + + + + + ArgumentOutOfRange class >> signalOn: value mustBeBetween: low and: high [ + "Raise the exception. The given value was not between low and high." + + + | errorString | + errorString := RegressionTesting + ifTrue: ['argument out of range'] + ifFalse: + ['argument must be between ' , low printString , ' and ' , high printString]. + ^(self new) + value: value; + low: low; + high: high; + signal: errorString + ] + + description [ + "Answer a textual description of the exception." + + + ^'argument out of range' + ] + + low [ + "Answer the lowest value that was permitted." + + + ^low + ] + + low: aMagnitude [ + "Set the lowest value that was permitted." + + + low := aMagnitude + ] + + high [ + "Answer the highest value that was permitted." + + + ^high + ] + + high: aMagnitude [ + "Set the highest value that was permitted." + + + high := aMagnitude + ] +] + +] diff --git a/kernel/exceptions/ArithmeticError.st b/kernel/exceptions/ArithmeticError.st new file mode 100644 index 00000000..5c6b7d93 --- /dev/null +++ b/kernel/exceptions/ArithmeticError.st @@ -0,0 +1,54 @@ +"====================================================================== +| +| ANSI exception handling classes +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2000, 2001, 2002, 2007, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Error subclass: ArithmeticError [ + + + + + description [ + "Answer a textual description of the exception." + + + ^'The program attempted to do an impossible arithmetic operation' + ] + + isResumable [ + "Answer true. Arithmetic exceptions are by default resumable." + + + ^true + ] +] diff --git a/kernel/exceptions/BadReturn.st b/kernel/exceptions/BadReturn.st new file mode 100644 index 00000000..099329f4 --- /dev/null +++ b/kernel/exceptions/BadReturn.st @@ -0,0 +1,49 @@ +"====================================================================== +| +| ANSI exception handling classes +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2000, 2001, 2002, 2007, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Namespace current: SystemExceptions [ + +VMError subclass: BadReturn [ + + + + + description [ + "Answer a textual description of the exception." + + + ^'return from a dead method context' + ] +] + +] diff --git a/kernel/exceptions/CInterfaceError.st b/kernel/exceptions/CInterfaceError.st new file mode 100644 index 00000000..cc3bf2db --- /dev/null +++ b/kernel/exceptions/CInterfaceError.st @@ -0,0 +1,49 @@ +"====================================================================== +| +| ANSI exception handling classes +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2000, 2001, 2002, 2007, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Namespace current: SystemExceptions [ + +PrimitiveFailed subclass: CInterfaceError [ + + + + + description [ + "Answer a textual description of the exception." + + + ^'error in the C-language interface' + ] +] + +] diff --git a/kernel/exceptions/EmptyCollection.st b/kernel/exceptions/EmptyCollection.st new file mode 100644 index 00000000..49bd8fc2 --- /dev/null +++ b/kernel/exceptions/EmptyCollection.st @@ -0,0 +1,49 @@ +"====================================================================== +| +| ANSI exception handling classes +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2000, 2001, 2002, 2007, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Namespace current: SystemExceptions [ + +InvalidValue subclass: EmptyCollection [ + + + + + description [ + "Answer a textual description of the exception." + + + ^'the collection is empty' + ] +] + +] diff --git a/kernel/exceptions/EndOfStream.st b/kernel/exceptions/EndOfStream.st new file mode 100644 index 00000000..794ded0e --- /dev/null +++ b/kernel/exceptions/EndOfStream.st @@ -0,0 +1,74 @@ +"====================================================================== +| +| ANSI exception handling classes +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2000, 2001, 2002, 2007, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Namespace current: SystemExceptions [ + +Notification subclass: EndOfStream [ + | stream | + + + + + EndOfStream class >> signalOn: stream [ + "Answer an exception reporting the parameter has reached its end." + + + ^(self new) + stream: stream; + signal + ] + + description [ + "Answer a textual description of the exception." + + + ^'end of stream reached' + ] + + stream [ + "Answer the stream whose end was reached." + + + ^stream + ] + + stream: anObject [ + "Set the stream whose end was reached." + + + stream := anObject + ] +] + +] + diff --git a/kernel/exceptions/Error.st b/kernel/exceptions/Error.st new file mode 100644 index 00000000..159b4e9d --- /dev/null +++ b/kernel/exceptions/Error.st @@ -0,0 +1,55 @@ +"====================================================================== +| +| ANSI exception handling classes +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2000, 2001, 2002, 2007, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Exception subclass: Error [ + + + + + description [ + "Answer a textual description of the exception." + + + ^'An exceptional condition has occurred, and has prevented normal +continuation of processing.' + ] + + isResumable [ + "Answer false. Error exceptions are by default unresumable; subclasses + can override this method if desired." + + + ^false + ] +] + diff --git a/kernel/exceptions/Exception.st b/kernel/exceptions/Exception.st new file mode 100644 index 00000000..55ea54b9 --- /dev/null +++ b/kernel/exceptions/Exception.st @@ -0,0 +1,481 @@ +"====================================================================== +| +| Core (instance-based) exception handling classes +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1999, 2000, 2001, 2002, 2003, 2008, 2009 +| Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + +"Create these symbols. AnsiExcept.st will assign values to them; Also create + some classes" + + + +Object subclass: Exception [ + | creator tag messageText resumeBlock onDoBlock handlerBlock context isNested previousState | + + + + + NoTag := nil. + + Exception class >> resetAllHandlers [ + "Private, class - Reset the handlers for all the exceptions; that is, the + next handlers used will be the first to be declared" + + + thisContext scanBacktraceForAttribute: #exceptionHandlerSearch:reset: + do: [:context :attr | (attr arguments at: 2) value: context] + ] + + Exception class >> new [ + "Create an instance of the receiver, which you will be able to + signal later." + + + | ctx creator | + ctx := thisContext parentContext. + [(creator := ctx receiver) == self] whileTrue: [ctx := ctx parentContext]. + ^self basicNew initialize: creator + ] + + Exception class >> signal [ + "Create an instance of the receiver, give it default attributes, + and signal it immediately." + + + ^self new signal + ] + + Exception class >> signal: messageText [ + "Create an instance of the receiver, set its message text, + and signal it immediately." + + + ^(self new) + messageText: messageText; + signal + ] + + Exception class >> , aTrappableEvent [ + "Answer an ExceptionCollection containing all the exceptions in the + receiver and all the exceptions in aTrappableEvent" + + + ^(ExceptionSet new) + add: self; + add: aTrappableEvent; + yourself + ] + + Exception class >> allExceptionsDo: aBlock [ + "Private - Pass ourselves to aBlock" + + + aBlock value: self + ] + + Exception class >> goodness: anExceptionClass [ + "Answer how good the receiver is at handling the given exception. A + negative value indicates that the receiver is not able to handle + the exception." + + + | depth found c target | + depth := -100000. + target := self. + c := anExceptionClass. + [c == target ifTrue: [ depth := 0 ]. + c == Exception] whileFalse: [c := c superclass. depth := depth + 1]. + + "In general, the deeper is the exception, the more fine-grained the + control is and the higher is the goodness (as long as the receiver + can handle the exception)." + ^depth + ] + + Exception class >> handles: anException [ + "Answer whether the receiver handles `anException'." + + + | target | + target := anException class asClass. + self == target ifTrue: [^true]. + ^target inheritsFrom: self + ] + + = anObject [ + "Answer whether the receiver is equal to anObject. This is true if + either the receiver or its class are the same object as anObject." + + + ^self == anObject + ] + + initialize: anObject [ + "Initialize the receiver's instance variables." + + + creator := anObject. + tag := self noTag. + self messageText: self description + ] + + description [ + "Answer a textual description of the exception." + + + ^'An exception has occurred' + ] + + isResumable [ + "Answer true. Exceptions are by default resumable." + + + ^true + ] + + defaultAction [ + "Execute the default action that is attached to the receiver." + + + self resignalAsUnhandled: self messageText + ] + + signal [ + "Raise the exceptional event represented by the receiver" + + + self instantiateNextHandlerFrom: thisContext. + ^self activateHandler: (onDoBlock isNil and: [ self isResumable ]) + ] + + signal: messageText [ + "Raise the exceptional event represented by the receiver, setting + its message text to messageText." + + + ^self + messageText: messageText; + signal + ] + + creator [ + + ^creator + ] + + basicMessageText [ + "Answer an exception's message text. Do not override this method." + + + ^messageText + ] + + messageText [ + "Answer an exception's message text." + + + ^messageText + ] + + messageText: aString [ + "Set an exception's message text." + + + messageText := aString + ] + + tag [ + "Answer an exception's tag value. If not specified, it + is the same as the message text." + + + ^tag == self noTag ifTrue: [self messageText] ifFalse: [tag] + ] + + tag: anObject [ + "Set an exception's tag value. If nil, the tag value will + be the same as the message text." + + + tag := anObject + ] + + postCopy [ + "Modify the receiver so that it does not refer to any instantiated + exception handler." + + + onDoBlock := nil. + handlerBlock := nil. + context := nil. + isNested := nil. + previousState := nil + ] + + isNested [ + "Answer whether the current exception handler is within the scope of + another handler for the same exception." + + + isNested isNil ifTrue: [isNested := false]. + ^isNested + ] + + instantiateNextHandlerFrom: aContext [ + "Private - Fill the receiver with information on the next handler for + it, possibly a handler for a parent or the default handler." + + + aContext parentContext scanBacktraceForAttribute: #exceptionHandlerSearch:reset: + do: + [:context :attr | + | status | + status := (attr arguments at: 1) value: context value: self. + status == #found ifTrue: [^self]]. + + self instantiateDefaultHandler. + ] + + instantiateDefaultHandler [ + "Private - Fill the receiver with information on its default handler." + + + self + onDoBlock: nil + handlerBlock: [ :ex | ex defaultAction ] + onDoContext: nil + previousState: nil + ] + + outer [ + "Raise the exception that instantiated the receiver, passing the same + parameters. + If the receiver is resumable and the evaluated exception action resumes + then the result returned from #outer will be the resumption value of the + evaluated exception action. If the receiver is not resumable or if the + exception action does not resume then this message will not return, and + #outer will be equivalent to #pass." + + + + | signal | + signal := self copy. + signal isNested: true. + signal instantiateNextHandlerFrom: self context. + ^signal activateHandler: true + ] + + pass [ + "Yield control to the enclosing exception action for the receiver. + Similar to #outer, but control does not return to the currently active exception + handler." + + + + | signal | + signal := self copy. + signal isNested: true. + signal instantiateNextHandlerFrom: self context. + ^self return: (signal activateHandler: true) + ] + + resignalAsUnhandled: message [ + "This might start the debugger... Note that we use #basicPrint + 'cause #printOn: might invoke an error." + + + | exc | + exc := SystemExceptions.UnhandledException new + originalException: self; + messageText: message; yourself. + thisContext parentContext + scanBacktraceFor: #(#resignalAsUnhandled:) + do: [ :ctx | ^exc defaultAction ]. + + self resignalAs: exc + ] + + resume [ + "If the exception is resumable, resume the execution of the block that + raised the exception; the method that was used to signal the exception + will answer the receiver. + Use this method IF AND ONLY IF you know who caused the exception and if + it is possible to resume it in that particular case" + + + self isResumable + ifFalse: [self resignalAsUnhandled: 'Exception not resumable - #resume failed']. + self resetHandler. + resumeBlock value: self + ] + + resume: anObject [ + "If the exception is resumable, resume the execution of the block that + raised the exception; the method that was used to signal the exception + will answer anObject. + Use this method IF AND ONLY IF you know who caused the exception and if + it is possible to resume it in that particular case" + + + self isResumable + ifFalse: [self resignalAsUnhandled: 'Exception not resumable - #resume: failed']. + self resetHandler. + resumeBlock value: anObject + ] + + resignalAs: replacementException [ + "Reinstate all handlers and execute the handler for `replacementException'; + control does not return to the currently active exception handler. The + new Signal object that is created has the same contents as the receiver + (this might or not be correct -- if it isn't you can use an idiom such + as `sig retryUsing: [ replacementException signal ])" + + + self class resetAllHandlers. + replacementException instantiateNextHandlerFrom: thisContext. + ^replacementException return: (replacementException activateHandler: true) + ] + + retry [ + "Re-execute the receiver of the #on:do: message. All handlers are + reinstated: watch out, this can easily cause an infinite loop." + + + onDoBlock isNil + ifTrue: [self resignalAsUnhandled: 'No exception handler effective - #retry failed']. + self class resetAllHandlers. + self return: onDoBlock value + ] + + retryUsing: aBlock [ + "Execute aBlock reinstating all handlers, and return its result from + the #signal method." + + + self class resetAllHandlers. + self return: aBlock value + ] + + signalingContext [ + "Return the execution context for the place that signaled the + exception, or nil if it is not available anymore (for example + if the exception handler has returned." + | context | + context := resumeBlock outerContext home. + [context notNil and: [context isInternalExceptionHandlingContext]] + whileTrue: [context := context parentContext]. + ^context + ] + + context [ + "Return the execution context for the #on:do: snippet" + + + ^context + ] + + return [ + "Exit the #on:do: snippet, answering nil to its caller." + + + context isNil + ifTrue: [self resignalAsUnhandled: 'No exception handler effective - #return failed']. + self class resetAllHandlers. + context parentContext continue: nil + ] + + return: anObject [ + "Exit the #on:do: snippet, answering anObject to its caller." + + + context isNil + ifTrue: [self resignalAsUnhandled: 'No exception handler effective - #return: failed']. + self class resetAllHandlers. + context parentContext continue: anObject + ] + + activateHandler: resumeBoolean [ + "Run the handler, passing to it aSignal, an instance of Signal. aBoolean + indicates the action (either resuming the receiver of #on:do:... or + exiting it) to be taken upon leaving from the handler block." + + + | result | + + resumeBlock := + [:object | + self resetHandler. + ^object]. + result := handlerBlock cull: self. + resumeBoolean + ifTrue: + [self resetHandler. + ^result]. + context parentContext continue: result + ] + + isNested: aBoolean [ + "Set the receiver's isNested instance variable." + + + isNested := aBoolean + ] + + onDoBlock: wdBlock handlerBlock: hBlock onDoContext: ctx previousState: anInteger [ + "Initialize the receiver's instance variables." + + + previousState := anInteger. + context := ctx. + onDoBlock := wdBlock. + handlerBlock := hBlock. + ^self + ] + + resetHandler [ + "Mark the handler that the receiver is using as not active." + + + onDoBlock isNil + ifFalse: [context at: context numArgs + 1 put: previousState] + ] + + noTag [ + + NoTag isNil ifTrue: [NoTag := Object new]. + ^NoTag + ] +] diff --git a/kernel/exceptions/ExceptionSet.st b/kernel/exceptions/ExceptionSet.st new file mode 100644 index 00000000..2ee5dde5 --- /dev/null +++ b/kernel/exceptions/ExceptionSet.st @@ -0,0 +1,108 @@ +"====================================================================== +| +| Core (instance-based) exception handling classes +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1999, 2000, 2001, 2002, 2003, 2008, 2009 +| Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + +"Create these symbols. AnsiExcept.st will assign values to them; Also create + some classes" + + + +Object subclass: ExceptionSet [ + | collection | + + + + + ExceptionSet class >> new [ + "Private - Answer a new, empty ExceptionSet" + + + ^self basicNew collection: Set new + ] + + , aTrappableEvent [ + "Answer an ExceptionSet containing all the exceptions in the + receiver and all the exceptions in aTrappableEvent" + + + ^(ExceptionSet new) + add: self; + add: aTrappableEvent; + yourself + ] + + allExceptionsDo: aBlock [ + "Private - Evaluate aBlock for every exception in the receiver. Answer the + receiver" + + + collection do: aBlock + ] + + goodness: exception [ + "Answer how good the receiver is at handling the given exception. A + negative value indicates that the receiver is not able to handle + the exception." + + + ^collection inject: -1 + into: [:old :each | old max: (each goodness: exception)] + ] + + handles: exception [ + "Answer whether the receiver handles `exception'." + + + ^collection anySatisfy: [:someItem | someItem handles: exception] + ] + + add: aTrappableEvent [ + "Private - Add aTrappableEvent to the receiver and answer aTrappableEvent" + + + aTrappableEvent allExceptionsDo: [:exc | collection add: exc]. + ^aTrappableEvent + ] + + collection: aSet [ + "Private - Set the collection of exception included in the receiver to + aSet" + + + collection := aSet. + ^self + ] +] + diff --git a/kernel/exceptions/Extensions.st b/kernel/exceptions/Extensions.st new file mode 100644 index 00000000..7ef01934 --- /dev/null +++ b/kernel/exceptions/Extensions.st @@ -0,0 +1,90 @@ +"====================================================================== +| +| ANSI exception handling classes +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2000, 2001, 2002, 2007, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Number extend [ + + arithmeticError: msg [ + "Raise an ArithmeticError exception having msg as its message text." + + + ^ArithmeticError new signal: msg + ] + + zeroDivide [ + "Raise a division-by-zero (ZeroDivide) exception whose dividend + is the receiver." + + + ^(ZeroDivide dividend: self) signal + ] + +] + + + +Object extend [ + + doesNotUnderstand: aMessage [ + "Called by the system when a selector was not found. message is a + Message containing information on the receiver" + + "aMessage inspect." + + "thisContext parentContext method inspect." + + "ObjectMemory abort." + + + ^(MessageNotUnderstood new) + message: aMessage receiver: self; + signal + ] + + error: message [ + "Display a walkback for the receiver, with the given error message. + Signal an `Error' exception." + + + ^Error new signal: message + ] + + halt: message [ + "Display a walkback for the receiver, with the given error message. + Signal an `Halt' exception." + + + ^Halt new signal: message + ] + +] + diff --git a/kernel/exceptions/FileError.st b/kernel/exceptions/FileError.st new file mode 100644 index 00000000..2d77b78d --- /dev/null +++ b/kernel/exceptions/FileError.st @@ -0,0 +1,49 @@ +"====================================================================== +| +| ANSI exception handling classes +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2000, 2001, 2002, 2007, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Namespace current: SystemExceptions [ + +PrimitiveFailed subclass: FileError [ + + + + + description [ + "Answer a textual description of the exception." + + + ^'file system error' + ] +] + +] diff --git a/kernel/exceptions/Halt.st b/kernel/exceptions/Halt.st new file mode 100644 index 00000000..8b87d2db --- /dev/null +++ b/kernel/exceptions/Halt.st @@ -0,0 +1,52 @@ +"====================================================================== +| +| ANSI exception handling classes +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2000, 2001, 2002, 2007, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Exception subclass: Halt [ + + + + + description [ + "Answer a textual description of the exception." + + + ^'#halt was sent.' + ] + + isResumable [ + "Answer true. #halt exceptions are by default resumable." + + + ^true + ] +] diff --git a/kernel/exceptions/IndexOutOfRange.st b/kernel/exceptions/IndexOutOfRange.st new file mode 100644 index 00000000..dff5ef5d --- /dev/null +++ b/kernel/exceptions/IndexOutOfRange.st @@ -0,0 +1,84 @@ +"====================================================================== +| +| ANSI exception handling classes +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2000, 2001, 2002, 2007, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Namespace current: SystemExceptions [ + +ArgumentOutOfRange subclass: IndexOutOfRange [ + | collection | + + + + + IndexOutOfRange class >> signalOn: aCollection withIndex: value [ + "The given index was out of range in aCollection." + + + ^(self new) + collection: aCollection; + value: value; + signal + ] + + description [ + "Answer a textual description of the exception." + + + ^'index out of range' + ] + + messageText [ + "Answer an exception's message text." + + + ^'Invalid index %1: %2' % + {self value. + self basicMessageText} + ] + + collection [ + "Answer the collection that triggered the error" + + + ^collection + ] + + collection: anObject [ + "Set the collection that triggered the error" + + + collection := anObject + ] +] + +] diff --git a/kernel/exceptions/Initialization.st b/kernel/exceptions/Initialization.st new file mode 100644 index 00000000..4da48640 --- /dev/null +++ b/kernel/exceptions/Initialization.st @@ -0,0 +1,37 @@ +"====================================================================== +| +| ANSI exception handling classes +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2000, 2001, 2002, 2007, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Eval [ + SystemExceptions.ProcessBeingTerminated initialize +] + diff --git a/kernel/exceptions/InvalidArgument.st b/kernel/exceptions/InvalidArgument.st new file mode 100644 index 00000000..88879fa0 --- /dev/null +++ b/kernel/exceptions/InvalidArgument.st @@ -0,0 +1,51 @@ +"====================================================================== +| +| ANSI exception handling classes +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2000, 2001, 2002, 2007, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Namespace current: SystemExceptions [ + +InvalidValue subclass: InvalidArgument [ + + + + + messageText [ + "Answer an exception's message text." + + + ^'Invalid argument %1: %2' % + {self value. + self basicMessageText} + ] +] + +] diff --git a/kernel/exceptions/InvalidProcessState.st b/kernel/exceptions/InvalidProcessState.st new file mode 100644 index 00000000..26e6b7b6 --- /dev/null +++ b/kernel/exceptions/InvalidProcessState.st @@ -0,0 +1,50 @@ +"====================================================================== +| +| ANSI exception handling classes +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2000, 2001, 2002, 2007, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Namespace current: SystemExceptions [ + +InvalidValue subclass: InvalidProcessState [ + + + + + description [ + "Answer a textual description of the exception." + + + ^'invalid operation for this process' + ] +] + +] diff --git a/kernel/exceptions/InvalidSize.st b/kernel/exceptions/InvalidSize.st new file mode 100644 index 00000000..ea917a17 --- /dev/null +++ b/kernel/exceptions/InvalidSize.st @@ -0,0 +1,49 @@ +"====================================================================== +| +| ANSI exception handling classes +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2000, 2001, 2002, 2007, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Namespace current: SystemExceptions [ + +InvalidArgument subclass: InvalidSize [ + + + + + description [ + "Answer a textual description of the exception." + + + ^'invalid size' + ] +] + +] diff --git a/kernel/exceptions/InvalidState.st b/kernel/exceptions/InvalidState.st new file mode 100644 index 00000000..dea96df7 --- /dev/null +++ b/kernel/exceptions/InvalidState.st @@ -0,0 +1,52 @@ +"====================================================================== +| +| ANSI exception handling classes +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2000, 2001, 2002, 2007, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Namespace current: SystemExceptions [ + +InvalidValue subclass: InvalidState [ + + + + + messageText [ + "Answer an exception's message text." + + + ^'%1 is in an invalid state: %2' % + {self value. + self basicMessageText} + ] +] + +] diff --git a/kernel/exceptions/InvalidValue.st b/kernel/exceptions/InvalidValue.st new file mode 100644 index 00000000..511d68bb --- /dev/null +++ b/kernel/exceptions/InvalidValue.st @@ -0,0 +1,93 @@ +"====================================================================== +| +| ANSI exception handling classes +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2000, 2001, 2002, 2007, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Namespace current: SystemExceptions [ + +Error subclass: InvalidValue [ + | value | + + + + + InvalidValue class >> signalOn: value [ + "Answer an exception reporting the parameter as invalid." + + + ^(self new) + value: value; + signal + ] + + InvalidValue class >> signalOn: value reason: reason [ + "Answer an exception reporting `value' as invalid, for the given + reason." + + + ^(self new) + value: value; + signal: reason + ] + + description [ + "Answer a textual description of the exception." + + + ^'unknown error' + ] + + messageText [ + "Answer an exception's message text." + + + ^'Invalid value %1: %2' % + {self value. + self basicMessageText} + ] + + value [ + "Answer the object that was found to be invalid." + + + ^value + ] + + value: anObject [ + "Set the object that was found to be invalid." + + + value := anObject + ] +] + +] + diff --git a/kernel/exceptions/MessageNotUnderstood.st b/kernel/exceptions/MessageNotUnderstood.st new file mode 100644 index 00000000..acc9e36e --- /dev/null +++ b/kernel/exceptions/MessageNotUnderstood.st @@ -0,0 +1,75 @@ +"====================================================================== +| +| ANSI exception handling classes +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2000, 2001, 2002, 2007, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Error subclass: MessageNotUnderstood [ + | message receiver | + + + + + message [ + "Answer the message that wasn't understood" + + + ^message + ] + + receiver [ + "Answer the object to whom the message send was directed" + + + ^receiver + ] + + message: aMessage receiver: anObject [ + + message := aMessage. + receiver := anObject. + self messageText: 'did not understand ' , message selector printString + ] + + description [ + "Answer a textual description of the exception." + + + ^'The program sent a message which was not understood by the receiver.' + ] + + isResumable [ + "Answer true. #doesNotUnderstand: exceptions are by default resumable." + + + ^true + ] +] diff --git a/kernel/exceptions/MustBeBoolean.st b/kernel/exceptions/MustBeBoolean.st new file mode 100644 index 00000000..a12c1040 --- /dev/null +++ b/kernel/exceptions/MustBeBoolean.st @@ -0,0 +1,49 @@ +"====================================================================== +| +| ANSI exception handling classes +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2000, 2001, 2002, 2007, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Namespace current: SystemExceptions [ + +WrongClass subclass: MustBeBoolean [ + + + + + MustBeBoolean class >> signalOn: anObject [ + "Signal a new exception, with the bad value in question being + anObject." + + ^self signalOn: anObject mustBe: #(#{Boolean}) + ] +] + +] diff --git a/kernel/exceptions/MutationError.st b/kernel/exceptions/MutationError.st new file mode 100644 index 00000000..238a4b46 --- /dev/null +++ b/kernel/exceptions/MutationError.st @@ -0,0 +1,57 @@ +"====================================================================== +| +| ANSI exception handling classes +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2000, 2001, 2002, 2007, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Namespace current: SystemExceptions [ + +Error subclass: MutationError [ + + + + + MutationError class >> new [ + "Create an instance of the receiver, which you will be able to + signal later." + + + ^self basicNew initialize: nil + ] + + description [ + "Answer a textual description of the exception." + + + ^'cannot mutate the class this way' + ] +] + +] diff --git a/kernel/exceptions/NoRunnableProcess.st b/kernel/exceptions/NoRunnableProcess.st new file mode 100644 index 00000000..219e50ff --- /dev/null +++ b/kernel/exceptions/NoRunnableProcess.st @@ -0,0 +1,49 @@ +"====================================================================== +| +| ANSI exception handling classes +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2000, 2001, 2002, 2007, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Namespace current: SystemExceptions [ + +VMError subclass: NoRunnableProcess [ + + + + + description [ + "Answer a textual description of the exception." + + + ^'no runnable process' + ] +] + +] diff --git a/kernel/exceptions/NotEnoughElements.st b/kernel/exceptions/NotEnoughElements.st new file mode 100644 index 00000000..a8f39b39 --- /dev/null +++ b/kernel/exceptions/NotEnoughElements.st @@ -0,0 +1,83 @@ +"====================================================================== +| +| ANSI exception handling classes +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2000, 2001, 2002, 2007, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Namespace current: SystemExceptions [ + +Error subclass: NotEnoughElements [ + | remainingCount | + + + + + NotEnoughElements class >> signalOn: remainingCount [ + "Answer an exception reporting the parameter as invalid." + + + ^(self new) + remainingCount: remainingCount; + signal + ] + + description [ + "Answer a textual description of the exception." + + + ^'premature end of stream' + ] + + messageText [ + "Answer an exception's message text." + + + ^'%1: %2 element(s) missing' % + {self basicMessageText. + self remainingCount} + ] + + remainingCount [ + "Answer the number of items that were to be read." + + + ^remainingCount + ] + + remainingCount: anObject [ + "Set the number of items that were to be read." + + + remainingCount := anObject + ] +] + +] diff --git a/kernel/exceptions/NotFound.st b/kernel/exceptions/NotFound.st new file mode 100644 index 00000000..91b1e6cd --- /dev/null +++ b/kernel/exceptions/NotFound.st @@ -0,0 +1,68 @@ +"====================================================================== +| +| ANSI exception handling classes +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2000, 2001, 2002, 2007, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Namespace current: SystemExceptions [ + +InvalidArgument subclass: NotFound [ + + + + + NotFound class >> signalOn: value what: aString [ + "Raise an exception; aString specifies what was not found (a key, + an object, a class, and so on)." + + + ^(self new) + value: value; + signal: aString , ' not found' + ] + + NotFound class >> signalOn: value reason: aString [ + "Raise an exception: reason specifies the reason of the exception." + + + ^(self new) + value: value; + signal: aString + ] + + description [ + "Answer a textual description of the exception." + + + ^'not found' + ] +] + +] diff --git a/kernel/exceptions/NotImplemented.st b/kernel/exceptions/NotImplemented.st new file mode 100644 index 00000000..b2c35d66 --- /dev/null +++ b/kernel/exceptions/NotImplemented.st @@ -0,0 +1,49 @@ +"====================================================================== +| +| ANSI exception handling classes +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2000, 2001, 2002, 2007, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Namespace current: SystemExceptions [ + +Error subclass: NotImplemented [ + + + + + description [ + "Answer a textual description of the exception." + + + ^'method is not implemented' + ] +] + +] diff --git a/kernel/exceptions/NotIndexable.st b/kernel/exceptions/NotIndexable.st new file mode 100644 index 00000000..acdbaf4b --- /dev/null +++ b/kernel/exceptions/NotIndexable.st @@ -0,0 +1,50 @@ +"====================================================================== +| +| ANSI exception handling classes +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2000, 2001, 2002, 2007, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Namespace current: SystemExceptions [ + +InvalidValue subclass: NotIndexable [ + + + + + description [ + "Answer a textual description of the exception." + + + ^'object not indexable' + ] +] + +] + diff --git a/kernel/exceptions/NotYetImplemented.st b/kernel/exceptions/NotYetImplemented.st new file mode 100644 index 00000000..1b6e9013 --- /dev/null +++ b/kernel/exceptions/NotYetImplemented.st @@ -0,0 +1,49 @@ +"====================================================================== +| +| ANSI exception handling classes +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2000, 2001, 2002, 2007, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Namespace current: SystemExceptions [ + +NotImplemented subclass: NotYetImplemented [ + + + + + description [ + "Answer a textual description of the exception." + + + ^'not yet implemented' + ] +] + +] diff --git a/kernel/exceptions/Notification.st b/kernel/exceptions/Notification.st new file mode 100644 index 00000000..66a688c8 --- /dev/null +++ b/kernel/exceptions/Notification.st @@ -0,0 +1,63 @@ +"====================================================================== +| +| ANSI exception handling classes +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2000, 2001, 2002, 2007, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Exception subclass: Notification [ + + + + + description [ + "Answer a textual description of the exception." + + + ^'An exceptional condition has occurred, but it is not to be considered +an error.' + ] + + isResumable [ + "Answer true. Notification exceptions are by default resumable." + + + ^true + ] + + defaultAction [ + "Do the default action for notifications, which is to resume execution + of the context which signaled the exception." + + + self resume: nil + ] +] diff --git a/kernel/exceptions/PrimitiveFailed.st b/kernel/exceptions/PrimitiveFailed.st new file mode 100644 index 00000000..097d737a --- /dev/null +++ b/kernel/exceptions/PrimitiveFailed.st @@ -0,0 +1,49 @@ +"====================================================================== +| +| ANSI exception handling classes +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2000, 2001, 2002, 2007, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Namespace current: SystemExceptions [ + +VMError subclass: PrimitiveFailed [ + + + + + description [ + "Answer a textual description of the exception." + + + ^'primitive operation failed' + ] +] + +] diff --git a/kernel/exceptions/ProcessBeingTerminated.st b/kernel/exceptions/ProcessBeingTerminated.st new file mode 100644 index 00000000..fe83f2ab --- /dev/null +++ b/kernel/exceptions/ProcessBeingTerminated.st @@ -0,0 +1,89 @@ +"====================================================================== +| +| ANSI exception handling classes +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2000, 2001, 2002, 2007, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Namespace current: SystemExceptions [ + +Notification subclass: ProcessBeingTerminated [ + + + + + | semaphore | + + ProcessBeingTerminated class >> initialize [ + (UndefinedObject>>#'__terminate') + makeReadOnly: false; + descriptor: ((MethodInfo new: 1) + methodClass: UndefinedObject; + selector: #'__terminate'; + at: 1 put: (Message + selector: #exceptionHandlerSearch:reset: + arguments: { + [ :context :signal | + (self handles: signal) + ifTrue: [ + signal + onDoBlock: nil + handlerBlock: [ :sig | thisContext environment continue: nil ] + onDoContext: nil + previousState: nil. + #found ] + ifFalse: [nil] ]. + [ :context | ] }); + yourself); + makeReadOnly: true + ] + + description [ + "Answer a textual description of the exception." + + + ^'the current process is being terminated' + ] + + semaphore [ + "If the process was waiting on a semaphore, answer it." + + + ^semaphore + ] + + semaphore: aSemaphore [ + "If the process was waiting on a semaphore, answer it." + + + semaphore := aSemaphore + ] +] + +] diff --git a/kernel/exceptions/ProcessTerminated.st b/kernel/exceptions/ProcessTerminated.st new file mode 100644 index 00000000..2c046598 --- /dev/null +++ b/kernel/exceptions/ProcessTerminated.st @@ -0,0 +1,49 @@ +"====================================================================== +| +| ANSI exception handling classes +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2000, 2001, 2002, 2007, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Namespace current: SystemExceptions [ + +InvalidValue subclass: ProcessTerminated [ + + + + + description [ + "Answer a textual description of the exception." + + + ^'process has/was already terminated' + ] +] + +] diff --git a/kernel/exceptions/ReadOnlyObject.st b/kernel/exceptions/ReadOnlyObject.st new file mode 100644 index 00000000..5c837408 --- /dev/null +++ b/kernel/exceptions/ReadOnlyObject.st @@ -0,0 +1,49 @@ +"====================================================================== +| +| ANSI exception handling classes +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2000, 2001, 2002, 2007, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Namespace current: SystemExceptions [ + +InvalidValue subclass: ReadOnlyObject [ + + + + + description [ + "Answer a textual description of the exception." + + + ^'object is read-only' + ] +] + +] diff --git a/kernel/exceptions/ShouldNotImplement.st b/kernel/exceptions/ShouldNotImplement.st new file mode 100644 index 00000000..16cd3e55 --- /dev/null +++ b/kernel/exceptions/ShouldNotImplement.st @@ -0,0 +1,50 @@ +"====================================================================== +| +| ANSI exception handling classes +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2000, 2001, 2002, 2007, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Namespace current: SystemExceptions [ + +NotImplemented subclass: ShouldNotImplement [ + + + + + description [ + "Answer a textual description of the exception." + + + ^'should not be implemented in this class' + ] +] + +] diff --git a/kernel/exceptions/SubclassResponsibility.st b/kernel/exceptions/SubclassResponsibility.st new file mode 100644 index 00000000..ab681da9 --- /dev/null +++ b/kernel/exceptions/SubclassResponsibility.st @@ -0,0 +1,50 @@ +"====================================================================== +| +| ANSI exception handling classes +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2000, 2001, 2002, 2007, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Namespace current: SystemExceptions [ + +ShouldNotImplement subclass: SubclassResponsibility [ + + + + + description [ + "Answer a textual description of the exception." + + + ^'method is responsibility of a subclass' + ] +] + +] diff --git a/kernel/exceptions/SysExcept.st b/kernel/exceptions/SysExcept.st new file mode 100644 index 00000000..4da48640 --- /dev/null +++ b/kernel/exceptions/SysExcept.st @@ -0,0 +1,37 @@ +"====================================================================== +| +| ANSI exception handling classes +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2000, 2001, 2002, 2007, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Eval [ + SystemExceptions.ProcessBeingTerminated initialize +] + diff --git a/kernel/exceptions/TimeoutNotification.st b/kernel/exceptions/TimeoutNotification.st new file mode 100644 index 00000000..c60690bc --- /dev/null +++ b/kernel/exceptions/TimeoutNotification.st @@ -0,0 +1,72 @@ +"====================================================================== +| +| ANSI exception handling classes +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2000, 2001, 2002, 2007, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Namespace current: Kernel [ + +Notification subclass: TimeoutNotification [ + | delay | + + + + TimeoutNotification class >> on: aDelay [ + + ^ self new + delay: aDelay; yourself + ] + + delay: aDelay [ + + delay := aDelay + ] + + delay [ + + ^ delay + ] + + isResumable [ + + ^ false + ] + + defaultAction [ + "We are not resumable, so do nothing. This should really never happen." + + + ] +] + +] + diff --git a/kernel/exceptions/UnhandledException.st b/kernel/exceptions/UnhandledException.st new file mode 100644 index 00000000..bba1fbce --- /dev/null +++ b/kernel/exceptions/UnhandledException.st @@ -0,0 +1,117 @@ +"====================================================================== +| +| ANSI exception handling classes +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2000, 2001, 2002, 2007, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Namespace current: SystemExceptions [ + +Exception subclass: UnhandledException [ + + | originalException | + + + + + description [ + "Answer a textual description of the exception." + + + ^'an unhandled exception occurred in the current process' + ] + + defaultAction [ + "Terminate the current process." + + + | debugger debuggerClass context | + Transcript flush. + debugger := Processor activeDebugger. + debugger isNil ifFalse: [^debugger stopInferior: self messageText ]. + debuggerClass := thisContext debuggerClass. + debuggerClass isNil + ifFalse: [^debuggerClass open: self originalException creator printString , ' error: ' , self messageText ]. + + "Default behavior - print backtrace" + RegressionTesting ifFalse: [self originalException creator basicPrint]. + Transcript + nextPutAll: ' error: '; + display: self messageText; + nl. + RegressionTesting + ifFalse: + [context := thisContext. + [context isInternalExceptionHandlingContext] + whileTrue: [context := context parentContext]. + context backtraceOn: Transcript]. + + thisContext environment continue: nil + ] + + instantiateDefaultHandler [ + "Private - Fill the receiver with information on its default handler." + + + | signalingContext resumeContext | + + "This exception is kind of special, as we forcedly have to find + a place to resume---even if the exception was not resumable! + This typically will happens when the user steps out of the + exception handling gobbledegook in the debugger." + signalingContext := thisContext. + [resumeContext := signalingContext parentContext. + resumeContext isEnvironment not + and: [resumeContext isInternalExceptionHandlingContext]] + whileTrue: [signalingContext := resumeContext]. + + self + onDoBlock: nil + handlerBlock: [ :ex | ex defaultAction ] + onDoContext: signalingContext + previousState: nil + ] + + originalException [ + "Answer the uncaught exception." + + + ^originalException + ] + + originalException: anObject [ + "Set the uncaught exception to anObject." + + + originalException := anObject + ] +] + +] diff --git a/kernel/exceptions/UserInterrupt.st b/kernel/exceptions/UserInterrupt.st new file mode 100644 index 00000000..0627ef52 --- /dev/null +++ b/kernel/exceptions/UserInterrupt.st @@ -0,0 +1,49 @@ +"====================================================================== +| +| ANSI exception handling classes +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2000, 2001, 2002, 2007, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Namespace current: SystemExceptions [ + +VMError subclass: UserInterrupt [ + + + + + description [ + "Answer a textual description of the exception." + + + ^'interrupted!!!' + ] +] + +] diff --git a/kernel/exceptions/VMError.st b/kernel/exceptions/VMError.st new file mode 100644 index 00000000..ba2c43bb --- /dev/null +++ b/kernel/exceptions/VMError.st @@ -0,0 +1,49 @@ +"====================================================================== +| +| ANSI exception handling classes +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2000, 2001, 2002, 2007, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Namespace current: SystemExceptions [ + +Error subclass: VMError [ + + + + + description [ + "Answer a textual description of the exception." + + + ^'virtual machine error' + ] +] + +] diff --git a/kernel/exceptions/VerificationError.st b/kernel/exceptions/VerificationError.st new file mode 100644 index 00000000..9ed2f2fb --- /dev/null +++ b/kernel/exceptions/VerificationError.st @@ -0,0 +1,49 @@ +"====================================================================== +| +| ANSI exception handling classes +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2000, 2001, 2002, 2007, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Namespace current: SystemExceptions [ + +VMError subclass: VerificationError [ + + + + + description [ + "Answer a textual description of the exception." + + + ^'a method did not pass the bytecode verification process' + ] +] + +] diff --git a/kernel/exceptions/Warning.st b/kernel/exceptions/Warning.st new file mode 100644 index 00000000..70d0d7bd --- /dev/null +++ b/kernel/exceptions/Warning.st @@ -0,0 +1,47 @@ +"====================================================================== +| +| ANSI exception handling classes +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2000, 2001, 2002, 2007, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Notification subclass: Warning [ + + + + + description [ + "Answer a textual description of the exception." + + + ^'An exceptional condition has occurred. It is reported to the user +even though it is not to be considered an error.' + ] +] + diff --git a/kernel/exceptions/WrongArgumentCount.st b/kernel/exceptions/WrongArgumentCount.st new file mode 100644 index 00000000..7878c5aa --- /dev/null +++ b/kernel/exceptions/WrongArgumentCount.st @@ -0,0 +1,50 @@ +"====================================================================== +| +| ANSI exception handling classes +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2000, 2001, 2002, 2007, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Namespace current: SystemExceptions [ + +PrimitiveFailed subclass: WrongArgumentCount [ + + + + + description [ + "Answer a textual description of the exception." + + + ^'wrong number of arguments' + ] +] + +] diff --git a/kernel/exceptions/WrongClass.st b/kernel/exceptions/WrongClass.st new file mode 100644 index 00000000..50c4f78e --- /dev/null +++ b/kernel/exceptions/WrongClass.st @@ -0,0 +1,119 @@ +"====================================================================== +| +| ANSI exception handling classes +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2000, 2001, 2002, 2007, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Namespace current: SystemExceptions [ + +InvalidValue subclass: WrongClass [ + | validClasses | + + + + + WrongClass class >> signalOn: anObject mustBe: aClassOrArray [ + "Raise an exception. The given object should have been an instance + of one of the classes indicated by aClassOrArray (which should be + a single class or an array of classes). Whether instances of + subclasses are allowed should be clear from the context, though + in general (i.e. with the exception of a few system messages) + they should be." + + + (aClassOrArray isKindOf: Collection) + ifFalse: [^self signalOn: anObject mustBe: {aClassOrArray binding}]. + ^(self new) + validClasses: aClassOrArray; + value: anObject; + signal + ] + + description [ + "Answer a textual description of the exception." + + + ^'wrong argument type' + ] + + messageText [ + "Answer an exception's message text." + + + self validClasses isNil + ifTrue: [^'Invalid argument ' , self value printString]. + ^'Invalid argument %1: must be %2' % + {self value. + self validClassesString} + ] + + validClasses [ + "Answer the list of classes whose instances would have been valid." + + + ^validClasses + ] + + validClassesString [ + "Answer the list of classes whose instances would have been valid, + formatted as a string." + + + ^String streamContents: + [:str | + validClasses keysAndValuesDo: + [:idx :classOrBinding | + | name class | + idx > 1 + ifTrue: + [idx = validClasses size + ifFalse: [str nextPutAll: ', '] + ifTrue: [str nextPutAll: ' or ']]. + class := classOrBinding isClass + ifTrue: [classOrBinding] + ifFalse: [classOrBinding value]. + name := class nameIn: Namespace current. + name first isVowel + ifTrue: [str nextPutAll: 'an '] + ifFalse: [str nextPutAll: 'a ']. + str nextPutAll: name]] + ] + + validClasses: aCollection [ + "Set the list of classes whose instances would have been valid." + + + validClasses := aCollection + ] +] + +] + diff --git a/kernel/exceptions/WrongMessageSent.st b/kernel/exceptions/WrongMessageSent.st new file mode 100644 index 00000000..69419315 --- /dev/null +++ b/kernel/exceptions/WrongMessageSent.st @@ -0,0 +1,93 @@ +"====================================================================== +| +| ANSI exception handling classes +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2000, 2001, 2002, 2007, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Namespace current: SystemExceptions [ + +ShouldNotImplement subclass: WrongMessageSent [ + | selector suggestedSelector | + + + + + WrongMessageSent class >> signalOn: selector useInstead: aSymbol [ + "Raise an exception, signaling which selector was sent and suggesting + a valid alternative." + + + ^(self new) + selector: selector; + suggestedSelector: aSymbol; + signal + ] + + messageText [ + "Answer an exception's message text." + + + ^'%1, use %2 instead' % + {self basicMessageText. + self suggestedSelector storeString} + ] + + selector [ + "Answer which selector was sent." + + + ^selector + ] + + selector: aSymbol [ + "Set which selector was sent." + + + selector := aSymbol + ] + + suggestedSelector [ + "Answer a valid alternative to the selector that was used." + + + ^suggestedSelector + ] + + suggestedSelector: aSymbol [ + "Set a valid alternative to the selector that was used." + + + suggestedSelector := aSymbol + ] +] + +] diff --git a/kernel/exceptions/ZeroDivide.st b/kernel/exceptions/ZeroDivide.st new file mode 100644 index 00000000..8f497ab7 --- /dev/null +++ b/kernel/exceptions/ZeroDivide.st @@ -0,0 +1,76 @@ +"====================================================================== +| +| ANSI exception handling classes +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2000, 2001, 2002, 2007, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +ArithmeticError subclass: ZeroDivide [ + | dividend | + + + + + ZeroDivide class >> dividend: aNumber [ + "Create a new ZeroDivide object remembering that the dividend was + aNumber." + + + ^super new dividend: aNumber + ] + + ZeroDivide class >> new [ + "Create a new ZeroDivide object; the dividend is conventionally + set to zero." + + + ^super new dividend: 0 + ] + + dividend [ + "Answer the number that was being divided by zero" + + + ^dividend + ] + + dividend: aNumber [ + + dividend := aNumber + ] + + description [ + "Answer a textual description of the exception." + + + ^'The program attempted to divide a number by zero' + ] +] diff --git a/kernel/ffi/CAggregate.st b/kernel/ffi/CAggregate.st new file mode 100644 index 00000000..52ebf979 --- /dev/null +++ b/kernel/ffi/CAggregate.st @@ -0,0 +1,65 @@ +"====================================================================== +| +| C object basic data type definitions. +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1988,92,94,95,99,2000,2001,2002,2003,2004,2008,2009 +| Free Software Foundation, Inc. +| Written by Steve Byrne. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +CObject subclass: CAggregate [ + + + + + CAggregate class >> sizeof [ + "Answer the receiver's instances size" + + "This is the closest possible guess for CArrays" + + + ^CPtrSize + ] + + CAggregate class >> alignof [ + "Answer the receiver's instances required aligment" + + "This is the closest possible guess for CArrays" + + + ^CPtrSize + ] + + elementType [ + "Answer the type over which the receiver is constructed." + + + ^self type elementType + ] +] + diff --git a/kernel/ffi/CArray.st b/kernel/ffi/CArray.st new file mode 100644 index 00000000..56116ac4 --- /dev/null +++ b/kernel/ffi/CArray.st @@ -0,0 +1,81 @@ +"====================================================================== +| +| C object basic data type definitions. +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1988,92,94,95,99,2000,2001,2002,2003,2004,2008,2009 +| Free Software Foundation, Inc. +| Written by Steve Byrne. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +CAggregate subclass: CArray [ + + + + + sizeof [ + "Answer the receiver's size" + + + ^self type numberOfElements * self elementType sizeof + ] + + alignof [ + "Answer the receiver's required aligment" + + + ^self elementType alignof + ] + + dereferencedType [ + + ^self type elementType + ] + + cObjStoredType [ + "Private - Provide a conversion from a CObject to a Smalltalk object + to be stored by #at:put:" + + "If they want to store the receiver with #at:put:, they store the + address (of the first character) without dereferencing the pointer." + + + ^CLong cObjStoredType + ] + + cObjStoredValue [ + "Private - Provide a conversion from a CObject to a Smalltalk object + to be stored by #at:put:" + + "If they want to store the receiver with #at:put:, they + store the address without dereferencing the pointer." + + + ^self address + ] +] + diff --git a/kernel/ffi/CArrayCType.st b/kernel/ffi/CArrayCType.st new file mode 100644 index 00000000..796c3113 --- /dev/null +++ b/kernel/ffi/CArrayCType.st @@ -0,0 +1,122 @@ +"====================================================================== +| +| Base class definition for C data type description objects. +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1990,91,92,94,95,99,2000,2001,2007,2008 +| Free Software Foundation, Inc. +| Written by Steve Byrne. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +CPtrCType subclass: CArrayCType [ + | numElements | + + + + + CArrayCType class >> from: type [ + "Private - Called by CType>>from: for arrays" + + + | numElts elementType typeInfo | + elementType := type at: 2. + numElts := type at: 3. + typeInfo := CType from: elementType. + ^self elementType: typeInfo numberOfElements: numElts + ] + + CArrayCType class >> elementType: aCType [ + + self shouldNotImplement + ] + + CArrayCType class >> elementType: aCType numberOfElements: anInteger [ + "Answer a new instance of CPtrCType that maps an array whose elements + are of the given CType, and whose size is exactly anInteger elements + (of course, anInteger only matters for allocation, not for access, since + no out-of-bounds protection is provided for C objects)." + + + ^(self cObjectType: CArray) + elementType: aCType; + numberOfElements: anInteger; + yourself + ] + + = anObject [ + "Return whether the receiver and anObject are equal." + + ^super = anObject and: [ + self numberOfElements = anObject numberOfElements] + ] + + hash [ + "Return a hash code for the receiver." + + ^super hash bitXor: self numberOfElements hash + ] + + storeOn: aStream [ + "As with super." + + aStream + nextPutAll: '(CArrayCType elementType: '; + store: self elementType; + nextPutAll: ' numberOfElements: '; + store: numElements asInteger; + nextPut: $) + ] + + sizeof [ + "Answer the size of the receiver's instances" + + + ^elementType sizeof * numElements + ] + + alignof [ + "Answer the alignment of the receiver's instances" + + + ^elementType alignof + ] + + numberOfElements [ + "Answer the number of elements in the receiver's instances" + + + ^numElements + ] + + numberOfElements: anInteger [ + "Initialize the receiver's instance variables" + + + numElements := anInteger + ] +] + diff --git a/kernel/ffi/CBoolean.st b/kernel/ffi/CBoolean.st new file mode 100644 index 00000000..8a5ee2db --- /dev/null +++ b/kernel/ffi/CBoolean.st @@ -0,0 +1,62 @@ +"====================================================================== +| +| C object basic data type definitions. +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1988,92,94,95,99,2000,2001,2002,2003,2004,2008,2009 +| Free Software Foundation, Inc. +| Written by Steve Byrne. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +CByte subclass: CBoolean [ + + + + + CBoolean class >> type [ + "Answer a CType for the receiver" + + + ^CBooleanType + ] + + value [ + "Get the receiver's value - answer true if it is != 0, false if it is 0." + + + ^super value > 0 + ] + + value: aBoolean [ + "Set the receiver's value - it's the same as for CBytes, but we + get a Boolean, not a Character" + + + ^super value: aBoolean asCBooleanValue + ] +] + diff --git a/kernel/ffi/CByte.st b/kernel/ffi/CByte.st new file mode 100644 index 00000000..217c4175 --- /dev/null +++ b/kernel/ffi/CByte.st @@ -0,0 +1,79 @@ +"====================================================================== +| +| C object basic data type definitions. +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1988,92,94,95,99,2000,2001,2002,2003,2004,2008,2009 +| Free Software Foundation, Inc. +| Written by Steve Byrne. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +CUChar subclass: CByte [ + + + + + CByte class >> cObjStoredType [ + "Nothing special in the default case - answer a CType for the receiver" + + + ^self type + ] + + CByte class >> type [ + "Answer a CType for the receiver" + + + ^CByteType + ] + + cObjStoredType [ + "Nothing special in the default case - answer the receiver's CType" + + + ^self type + ] + + value [ + "Answer the value the receiver is pointing to. The returned value + is a SmallInteger" + + + ^(self at: 0 type: super cObjStoredType) value + ] + + value: aValue [ + "Set the receiver to point to the value, aValue (a SmallInteger)." + + + self + at: 0 + put: (Character value: aValue) + type: super cObjStoredType + ] +] + diff --git a/kernel/CCallable.st b/kernel/ffi/CCallable.st similarity index 100% rename from kernel/CCallable.st rename to kernel/ffi/CCallable.st diff --git a/kernel/CCallback.st b/kernel/ffi/CCallbackDescriptor.st similarity index 100% rename from kernel/CCallback.st rename to kernel/ffi/CCallbackDescriptor.st diff --git a/kernel/ffi/CChar.st b/kernel/ffi/CChar.st new file mode 100644 index 00000000..d65d8baf --- /dev/null +++ b/kernel/ffi/CChar.st @@ -0,0 +1,104 @@ +"====================================================================== +| +| C object basic data type definitions. +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1988,92,94,95,99,2000,2001,2002,2003,2004,2008,2009 +| Free Software Foundation, Inc. +| Written by Steve Byrne. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +CScalar subclass: CChar [ + + + + + CChar class >> sizeof [ + "Answer the receiver's instances size" + + + ^1 + ] + + CChar class >> alignof [ + "Answer the receiver's instances required aligment" + + + ^1 + ] + + CChar class >> cObjStoredType [ + "Private - Answer an index referring to the receiver's instances scalar type" + + + ^0 + ] + + asByteArray: size [ + "Convert size bytes pointed to by the receiver to a String" + + + ^ByteArray fromCData: self size: size + ] + + asString [ + "Convert the data pointed to by the receiver, up to the first NULL byte, + to a String" + + + ^String fromCData: self + ] + + asString: size [ + "Convert size bytes pointed to by the receiver to a String" + + + ^String fromCData: self size: size + ] + + sizeof [ + "Answer the receiver's size" + + + ^1 + ] + + alignof [ + "Answer the receiver's required aligment" + + + ^1 + ] + + cObjStoredType [ + "Private - Answer an index referring to the receiver's scalar type" + + + ^0 + ] +] + diff --git a/kernel/CStruct.st b/kernel/ffi/CCompound.st similarity index 87% rename from kernel/CStruct.st rename to kernel/ffi/CCompound.st index 262ee997..e2a7bd8d 100644 --- a/kernel/CStruct.st +++ b/kernel/ffi/CCompound.st @@ -232,60 +232,6 @@ CObject subclass: CCompound [ ] ] - - -CCompound subclass: CStruct [ - - - - - - CStruct class >> declaration: array [ - "Compile methods that implement the declaration in array." - - - self - declaration: array - inject: self superclass sizeof - into: [:oldOffset :alignment | oldOffset alignTo: alignment] - ] -] - - - -CCompound subclass: CUnion [ - - - - - - CUnion class >> declaration: array [ - "Compile methods that implement the declaration in array." - - - self - declaration: array - inject: 0 - into: [:oldOffset :alignment | 0] - ] -] - - - -Integer extend [ - - alignTo: anInteger [ - "Answer the receiver, truncated to the first higher or equal - multiple of anInteger (which must be a power of two)" - - - ^self + anInteger - 1 bitClear: anInteger - 1 - ] - -] - - - Eval [ CCompound initialize ] diff --git a/kernel/ffi/CDouble.st b/kernel/ffi/CDouble.st new file mode 100644 index 00000000..d42387a1 --- /dev/null +++ b/kernel/ffi/CDouble.st @@ -0,0 +1,82 @@ +"====================================================================== +| +| C object basic data type definitions. +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1988,92,94,95,99,2000,2001,2002,2003,2004,2008,2009 +| Free Software Foundation, Inc. +| Written by Steve Byrne. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +CScalar subclass: CDouble [ + + + + + CDouble class >> sizeof [ + "Answer the receiver's instances size" + + + ^CDoubleSize + ] + + CDouble class >> alignof [ + "Answer the receiver's instances required aligment" + + + ^CDoubleAlignment + ] + + CDouble class >> cObjStoredType [ + "Private - Answer an index referring to the receiver's instances scalar type" + + + ^7 + ] + + sizeof [ + "Answer the receiver's size" + + + ^CDoubleSize + ] + + alignof [ + "Answer the receiver's required aligment" + + + ^CDoubleAlignment + ] + + cObjStoredType [ + "Private - Answer an index referring to the receiver's scalar type" + + + ^7 + ] +] + diff --git a/kernel/ffi/CFloat.st b/kernel/ffi/CFloat.st new file mode 100644 index 00000000..7f6a936b --- /dev/null +++ b/kernel/ffi/CFloat.st @@ -0,0 +1,82 @@ +"====================================================================== +| +| C object basic data type definitions. +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1988,92,94,95,99,2000,2001,2002,2003,2004,2008,2009 +| Free Software Foundation, Inc. +| Written by Steve Byrne. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +CScalar subclass: CFloat [ + + + + + CFloat class >> sizeof [ + "Answer the receiver's instances size" + + + ^CFloatSize + ] + + CFloat class >> alignof [ + "Answer the receiver's instances required aligment" + + + ^CFloatSize + ] + + CFloat class >> cObjStoredType [ + "Private - Answer an index referring to the receiver's instances scalar type" + + + ^6 + ] + + sizeof [ + "Answer the receiver's size" + + + ^CFloatSize + ] + + alignof [ + "Answer the receiver's required aligment" + + + ^CFloatSize + ] + + cObjStoredType [ + "Private - Answer an index referring to the receiver's scalar type" + + + ^6 + ] +] + diff --git a/kernel/CFuncs.st b/kernel/ffi/CFunctionDescriptor.st similarity index 80% rename from kernel/CFuncs.st rename to kernel/ffi/CFunctionDescriptor.st index dc4da1a7..90d031dc 100644 --- a/kernel/CFuncs.st +++ b/kernel/ffi/CFunctionDescriptor.st @@ -111,51 +111,3 @@ to perform the actual call-out to C routines.'> ] ] - - -SystemDictionary extend [ - - system: aString withArguments: args [ - - ^self system: aString % (args collect: [ :string | string withShellEscapes ]) - - ] - - system: aString [ - - - - ] - - getenv: aString [ - - - - ] - - environ [ - - - - ] - - putenv: aString [ - - - - ] - - getArgc [ - - - - ] - - getArgv: index [ - - - - ] - -] - diff --git a/kernel/ffi/CInt.st b/kernel/ffi/CInt.st new file mode 100644 index 00000000..8a154443 --- /dev/null +++ b/kernel/ffi/CInt.st @@ -0,0 +1,82 @@ +"====================================================================== +| +| C object basic data type definitions. +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1988,92,94,95,99,2000,2001,2002,2003,2004,2008,2009 +| Free Software Foundation, Inc. +| Written by Steve Byrne. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +CScalar subclass: CInt [ + + + + + CInt class >> sizeof [ + "Answer the receiver's size" + + + ^CIntSize + ] + + CInt class >> alignof [ + "Answer the receiver's required aligment" + + + ^CIntSize + ] + + CInt class >> cObjStoredType [ + "Private - Answer an index referring to the receiver's instances scalar type" + + + ^10 + ] + + sizeof [ + "Answer the receiver's instances size" + + + ^CIntSize + ] + + alignof [ + "Answer the receiver's instances required aligment" + + + ^CIntSize + ] + + cObjStoredType [ + "Private - Answer an index referring to the receiver's scalar type" + + + ^10 + ] +] + diff --git a/kernel/ffi/CLong.st b/kernel/ffi/CLong.st new file mode 100644 index 00000000..677d420a --- /dev/null +++ b/kernel/ffi/CLong.st @@ -0,0 +1,82 @@ +"====================================================================== +| +| C object basic data type definitions. +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1988,92,94,95,99,2000,2001,2002,2003,2004,2008,2009 +| Free Software Foundation, Inc. +| Written by Steve Byrne. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + + +CScalar subclass: CLong [ + + + + CLong class >> sizeof [ + "Answer the receiver's instances size" + + + ^CLongSize + ] + + CLong class >> alignof [ + "Answer the receiver's instances required aligment" + + + ^CLongSize + ] + + CLong class >> cObjStoredType [ + "Private - Answer an index referring to the receiver's instances scalar type" + + + ^4 + ] + + sizeof [ + "Answer the receiver's size" + + + ^CLongSize + ] + + alignof [ + "Answer the receiver's required aligment" + + + ^CLongSize + ] + + cObjStoredType [ + "Private - Answer an index referring to the receiver's scalar type" + + + ^4 + ] +] + diff --git a/kernel/ffi/CLongDouble.st b/kernel/ffi/CLongDouble.st new file mode 100644 index 00000000..64147b85 --- /dev/null +++ b/kernel/ffi/CLongDouble.st @@ -0,0 +1,82 @@ +"====================================================================== +| +| C object basic data type definitions. +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1988,92,94,95,99,2000,2001,2002,2003,2004,2008,2009 +| Free Software Foundation, Inc. +| Written by Steve Byrne. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +CScalar subclass: CLongDouble [ + + + + + CLongDouble class >> sizeof [ + "Answer the receiver's instances size" + + + ^CLongDoubleSize + ] + + CLongDouble class >> alignof [ + "Answer the receiver's instances required aligment" + + + ^CLongDoubleAlignment + ] + + CLongDouble class >> cObjStoredType [ + "Private - Answer an index referring to the receiver's instances scalar type" + + + ^12 + ] + + sizeof [ + "Answer the receiver's size" + + + ^CLongDoubleSize + ] + + alignof [ + "Answer the receiver's required aligment" + + + ^CLongDoubleAlignment + ] + + cObjStoredType [ + "Private - Answer an index referring to the receiver's scalar type" + + + ^12 + ] +] + diff --git a/kernel/ffi/CLongLong.st b/kernel/ffi/CLongLong.st new file mode 100644 index 00000000..063463e9 --- /dev/null +++ b/kernel/ffi/CLongLong.st @@ -0,0 +1,83 @@ +"====================================================================== +| +| C object basic data type definitions. +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1988,92,94,95,99,2000,2001,2002,2003,2004,2008,2009 +| Free Software Foundation, Inc. +| Written by Steve Byrne. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + + +CScalar subclass: CLongLong [ + + + + + CLongLong class >> sizeof [ + "Answer the receiver's instances size" + + + ^8 + ] + + CLongLong class >> alignof [ + "Answer the receiver's instances required aligment" + + + ^CLongLongAlignment + ] + + CLongLong class >> cObjStoredType [ + "Private - Answer an index referring to the receiver's instances scalar type" + + + ^30 + ] + + sizeof [ + "Answer the receiver's size" + + + ^8 + ] + + alignof [ + "Answer the receiver's required aligment" + + + ^CLongLongAlignment + ] + + cObjStoredType [ + "Private - Answer an index referring to the receiver's scalar type" + + + ^30 + ] +] + diff --git a/kernel/ffi/CObject.st b/kernel/ffi/CObject.st new file mode 100644 index 00000000..f9765c3d --- /dev/null +++ b/kernel/ffi/CObject.st @@ -0,0 +1,491 @@ +"====================================================================== +| +| C object basic data type definitions. +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1988,92,94,95,99,2000,2001,2002,2003,2004,2008,2009 +| Free Software Foundation, Inc. +| Written by Steve Byrne. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Object subclass: CObject [ + | type storage | + + + + + + + CObject class [ + | defaultType | + + ] + + CObject class >> inheritShape [ + "Answer whether subclasses will have by default the same shape as + this class. The default is true for the CObject hierarchy." + + ^true + ] + + CObject class >> alloc: nBytes type: cTypeObject [ + "Allocate nBytes bytes and return a CObject of the given type" + + + + nBytes isInteger + ifFalse: [^SystemExceptions.WrongClass signalOn: nBytes mustBe: SmallInteger]. + ^SystemExceptions.WrongClass signalOn: cTypeObject mustBe: CType + ] + + CObject class >> gcAlloc: nBytes type: cTypeObject [ + "Allocate nBytes bytes and return a CObject of the given type" + + + | class | + class := cTypeObject isNil + ifTrue: [ self ] + ifFalse: [ cTypeObject cObjectType ]. + + ^(class address: 0) + type: cTypeObject; + storage: (ByteArray new: nBytes); + yourself + ] + + CObject class >> alloc: nBytes [ + "Allocate nBytes bytes and return an instance of the receiver" + + + ^self alloc: nBytes type: nil + ] + + CObject class >> gcAlloc: nBytes [ + "Allocate nBytes bytes and return an instance of the receiver" + + + ^self gcAlloc: nBytes type: nil + ] + + CObject class >> gcNew: nBytes [ + "Allocate nBytes bytes and return an instance of the receiver" + + + ^self gcAlloc: nBytes type: nil + ] + + CObject class >> new: nBytes [ + "Allocate nBytes bytes and return an instance of the receiver" + + + ^self alloc: nBytes type: nil + ] + + CObject class >> address: anInteger [ + "Answer a new object pointing to the passed address, anInteger" + + + ^(self basicNew: 1) address: anInteger + ] + + CObject class >> new [ + "Answer a new object pointing to NULL." + + + ^self address: 0 + ] + + CObject class >> type [ + "Nothing special in the default case - answer a CType for the receiver" + + + defaultType isNil ifTrue: [defaultType := CType cObjectType: self]. + ^defaultType + ] + + CObject class >> cObjStoredType [ + "Private - Provide a conversion from a CObject to a Smalltalk object + to be stored by #at:put:" + + + ^nil + ] + + = anObject [ + "Return true if the receiver and aCObject are equal." + + + ^self class == anObject class and: [ + self type = anObject type and: [ + self storage == anObject storage and: [ + self address = anObject address ]]] + ] + + hash [ + "Return a hash value for anObject." + + + | addr | + addr := self address bitAnd: SmallInteger largest. + ^self type hash + bitXor: (self storage identityHash * self storage size + addr) + ] + + finalize [ + "To make the VM call this, use #addToBeFinalized. It frees + automatically any memory pointed to by the CObject. It is not + automatically enabled because big trouble hits you if you use + #free and the receiver doesn't point to the base of a malloc-ed + area." + + + self free + ] + + addressAt: anIndex [ + "Return a new CObject of the element type, + corresponding to an object that is anIndex places past + the receiver (remember that CObjects represent pointers + and that C pointers behave like arrays). + anIndex is zero-based, just like with all other C-style accessing." + + + | dereferencedType | + dereferencedType := self dereferencedType. + ^self at: anIndex * dereferencedType sizeof type: dereferencedType + ] + + at: anIndex [ + "Dereference a pointer that is anIndex places past + the receiver (remember that CObjects represent pointers + and that C pointers behave like arrays). anIndex is + zero-based, just like with all other C-style accessing." + + + | dereferencedType offset valueType | + dereferencedType := self dereferencedType. + offset := anIndex * dereferencedType sizeof. + valueType := dereferencedType valueType. + ^valueType isInteger + ifTrue: [self at: offset type: valueType] + ifFalse: [(self at: offset type: dereferencedType) value] + ] + + at: anIndex put: aValue [ + "Store anIndex places past the receiver the passed Smalltalk + object or CObject `aValue'; if it is a CObject is dereferenced: + that is, this method is equivalent either to cobj[anIndex]=aValue + or cobj[anIndex]=*aValue. anIndex is zero-based, just like with + all other C-style accessing. + + In both cases, aValue should be of the element type or of the + corresponding Smalltalk type (that is, a String is ok for an + array of CStrings) to avoid typing problems which however will + not be signaled because C is untyped." + + + | dereferencedType offset valueType | + dereferencedType := self dereferencedType. + offset := anIndex * dereferencedType sizeof. + valueType := dereferencedType valueType. + valueType isInteger + ifTrue: + [self + at: offset + put: aValue + type: valueType] + ifFalse: [(self at: offset type: dereferencedType) value: aValue]. + ^aValue + ] + + isNull [ + "Return true if the receiver points to NULL." + + + ^self address = 0 and: [ self isAbsolute ] + ] + + isCObject [ + + ^true + ] + + incr [ + "Adjust the pointer by sizeof(dereferencedType) bytes up (i.e. ++receiver)" + + + self adjPtrBy: self dereferencedType sizeof + ] + + decr [ + "Adjust the pointer by sizeof(dereferencedType) bytes down (i.e. --receiver)" + + + self adjPtrBy: self dereferencedType sizeof negated + ] + + incrBy: anInteger [ + "Adjust the pointer by anInteger elements up (i.e. receiver += anInteger)" + + + self adjPtrBy: self dereferencedType sizeof * anInteger + ] + + decrBy: anInteger [ + "Adjust the pointer by anInteger elements down (i.e. receiver -= anInteger)" + + + self adjPtrBy: self dereferencedType sizeof * anInteger negated + ] + + + anInteger [ + "Return another instance of the receiver's class which points at + &receiver[anInteger] (or, if you prefer, what `receiver + + anInteger' does in C)." + + + | dereferencedType | + dereferencedType := self dereferencedType. + ^self at: anInteger * dereferencedType sizeof type: self type + ] + + - intOrPtr [ + "If intOrPtr is an integer, return another instance of the receiver's + class pointing at &receiver[-anInteger] (or, if you prefer, what + `receiver - anInteger' does in C). + If it is the same class as the receiver, return the difference in + chars, i.e. in bytes, between the two pointed addresses (or, if + you prefer, what `receiver - anotherCharPtr' does in C)" + + + | dereferencedType | + intOrPtr isInteger ifTrue: [^self + intOrPtr negated]. + dereferencedType := self dereferencedType. + intOrPtr dereferencedType = dereferencedType + ifFalse: + [^SystemExceptions.InvalidArgument signalOn: intOrPtr + reason: 'arithmetic between pointers to different types']. + ^((self addressAt: 0) address - (intOrPtr addressAt: 0) address) + // dereferencedType sizeof + ] + + castTo: aType [ + "Answer another CObject, pointing to the same address as the receiver, + but belonging to the aType CType." + + + ^self at: 0 type: aType + ] + + narrow [ + "This method is called on CObjects returned by a C call-out whose + return type is specified as a CType; it mostly allows one to + change the class of the returned CObject. By default it does + nothing, and that's why it is not called when #cObject is used + to specify the return type." + + + + ] + + type [ + "Answer a CType for the receiver" + + + type isNil ifTrue: [type := self class type]. + ^type + ] + + isAbsolute [ + "Answer whether the object points into a garbage-collected Smalltalk + storage, or it is an absolute address." + + + ^storage isNil + ] + + storage [ + "Answer the storage that the receiver is pointing into, or nil + if the address is absolute." + + + ^storage + ] + + storage: anObject [ + "Change the receiver to point to the storage of anObject." + + + storage := anObject. + ] + + address [ + "Answer the address the receiver is pointing to. The address can + be absolute if the storage is nil, or relative to the Smalltalk + object in #storage. In this case, an address of 0 corresponds to + the first instance variable." + + + + ^self basicAt: self basicSize + ] + + address: anInteger [ + "Set the receiver to point to the passed address, anInteger" + + + + SystemExceptions.WrongClass signalOn: anInteger mustBe: Integer + ] + + printOn: aStream [ + "Print a representation of the receiver" + + + aStream + print: self class; + nextPut: $(. + + self isAbsolute + ifTrue: [ aStream nextPutAll: (self address printStringRadix: 16) ] + ifFalse: [ + self storage do: [ :each | aStream print: each; space ]. + aStream nextPutAll: '@ '; print: self address ]. + + aStream nextPut: $) + ] + + type: aCType [ + "Set the receiver's type to aCType." + + + type := aCType + ] + + adjPtrBy: byteOffset [ + + self address: self address + byteOffset + ] + + dereferencedType [ + + ^self type + ] + + cObjStoredType [ + "Private - Provide a conversion from a CObject to a Smalltalk object + to be stored by #at:put:" + + + ^nil + ] + + cObjStoredValue [ + "Private - Provide a conversion from a CObject to a Smalltalk object + to be stored by #at:put:" + + + ^self value + ] + + at: byteOffset type: aType [ + "Answer some data of the given type from byteOffset bytes after + the pointer stored in the receiver" + + + + byteOffset isInteger + ifFalse: + [^SystemExceptions.WrongClass signalOn: byteOffset mustBe: SmallInteger]. + (self isAbsolute not and: [ aType isInteger ]) ifTrue: [ + ^SystemExceptions.InvalidArgument signalOn: self address + byteOffset + reason: 'offset out of range' ]. + + ^SystemExceptions.WrongClass signalOn: aType + ] + + at: byteOffset put: aValue type: aType [ + "Store aValue as data of the given type from byteOffset bytes after + the pointer stored in the receiver" + + + | type | + + + (self isAbsolute not and: [ aValue isCObject not ]) ifTrue: [ + ^SystemExceptions.InvalidArgument signalOn: self address + byteOffset + reason: 'offset out of range' ]. + + type := aValue cObjStoredType. + + "Attempt to store something meaningful from another CObject" + type isNil ifTrue: [type := aType]. + ^self + at: byteOffset + noCObjectsPut: aValue cObjStoredValue + type: type + ] + + free [ + "Free the receiver's pointer and set it to null. Big trouble hits + you if the receiver doesn't point to the base of a malloc-ed area." + + + + ^self primitiveFailed + ] + + at: byteOffset noCObjectsPut: aValue type: aType [ + "Private - Store aValue as data of the given type from byteOffset bytes + after the pointer stored in the receiver. This version refuses CObjects + for `aValue'." + + + + byteOffset isInteger + ifFalse: + [^SystemExceptions.WrongClass signalOn: byteOffset mustBe: SmallInteger]. + (aType isInteger or: [aType isKindOf: CType]) + ifFalse: + [^SystemExceptions.WrongClass signalOn: byteOffset mustBe: SmallInteger]. + ^SystemExceptions.WrongClass signalOn: aValue + ] + + derefAt: byteOffset type: aType [ + + + byteOffset isInteger + ifFalse: + [^SystemExceptions.WrongClass signalOn: byteOffset mustBe: SmallInteger]. + ^SystemExceptions.WrongClass signalOn: aType + ] +] + diff --git a/kernel/ffi/CObjectExtensions.st b/kernel/ffi/CObjectExtensions.st new file mode 100644 index 00000000..515afe1b --- /dev/null +++ b/kernel/ffi/CObjectExtensions.st @@ -0,0 +1,58 @@ +"====================================================================== +| +| CFunctionDescriptor Method Definitions +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1988,92,94,95,99,2000,2001,2002,2003,2005,2008 +| Free Software Foundation, Inc. +| Written by Steve Byrne. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + +"Forward define CType instances" + +Eval [ + Smalltalk at: #CCharType put: nil. + Smalltalk at: #CStringType put: nil +] + +UndefinedObject extend [ + + free [ + "Do nothing, a NULL pointer can be safely freed." + + + + ] + + narrow [ + "Return the receiver: a NULL pointer is always nil, whatever its type." + + + ^self + ] + +] + diff --git a/kernel/ffi/CPtr.st b/kernel/ffi/CPtr.st new file mode 100644 index 00000000..c50fbaa1 --- /dev/null +++ b/kernel/ffi/CPtr.st @@ -0,0 +1,81 @@ +"====================================================================== +| +| C object basic data type definitions. +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1988,92,94,95,99,2000,2001,2002,2003,2004,2008,2009 +| Free Software Foundation, Inc. +| Written by Steve Byrne. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +CAggregate subclass: CPtr [ + + + + + sizeof [ + "Answer the receiver's size" + + + ^CPtrSize + ] + + alignof [ + "Answer the receiver's required aligment" + + + ^CPtrSize + ] + + value [ + "Answer the address of the location pointed to by the receiver." + + + ^self derefAt: 0 type: self type elementType + ] + + value: anObject [ + "Set the address of the location pointed to by the receiver + to anObject, which can be either an Integer or a CObject. + if anObject is an Integer, it is interpreted as a 32-bit + or 64-bit address. If it is a CObject, its address is + stored." + + + anObject isInteger + ifTrue: + [^self + at: 0 + put: anObject + type: CLong cObjStoredType]. + self + at: 0 + put: anObject address + type: CLong cObjStoredType + ] +] + diff --git a/kernel/ffi/CPtrCType.st b/kernel/ffi/CPtrCType.st new file mode 100644 index 00000000..ef224198 --- /dev/null +++ b/kernel/ffi/CPtrCType.st @@ -0,0 +1,94 @@ +"====================================================================== +| +| Base class definition for C data type description objects. +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1990,91,92,94,95,99,2000,2001,2007,2008 +| Free Software Foundation, Inc. +| Written by Steve Byrne. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +CType subclass: CPtrCType [ + | elementType | + + + + + CPtrCType class >> from: type [ + "Private - Called by computeAggregateType: for pointers" + + + | subType typeInfo | + subType := type at: 2. + typeInfo := CType from: subType. + ^self elementType: typeInfo + ] + + CPtrCType class >> elementType: aCType [ + "Answer a new instance of CPtrCType that maps pointers to the given CType" + + + ^(self cObjectType: CPtr) + elementType: aCType; + yourself + ] + + = anObject [ + "Return whether the receiver and anObject are equal." + + ^super = anObject and: [self elementType = anObject elementType] + ] + + hash [ + "Return a hash code for the receiver." + + ^super hash bitXor: self elementType hash + ] + + elementType [ + "Answer the type of the elements in the receiver's instances" + + + ^elementType + ] + + storeOn: aStream [ + + aStream + nextPutAll: '(CPtrCType elementType: '; + store: self elementType; + nextPut: $) + ] + + elementType: aCType [ + "Initialize the receiver's instance variables" + + + elementType := aCType + ] +] + diff --git a/kernel/ffi/CScalar.st b/kernel/ffi/CScalar.st new file mode 100644 index 00000000..164e4b18 --- /dev/null +++ b/kernel/ffi/CScalar.st @@ -0,0 +1,106 @@ +"====================================================================== +| +| C object basic data type definitions. +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1988,92,94,95,99,2000,2001,2002,2003,2004,2008,2009 +| Free Software Foundation, Inc. +| Written by Steve Byrne. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +CObject subclass: CScalar [ + + + + + CScalar class >> value: anObject [ + "Answer a newly allocated CObject containing the passed value, + anObject. Remember to call #addToBeFinalized if you want the + CObject to be automatically freed" + + + | cObject | + cObject := self type new. + cObject value: anObject. + ^cObject + ] + + CScalar class >> gcValue: anObject [ + "Answer a newly allocated CObject containing the passed value, + anObject, in garbage-collected storage." + + + | cObject | + cObject := self type gcNew. + cObject value: anObject. + ^cObject + ] + + CScalar class >> type [ + "Answer a CType for the receiver---for example, CByteType if + the receiver is CByte." + + + ^self environment at: (self name , 'Type') asGlobalKey + ] + + CScalar class >> cObjStoredType [ + "Private - Provide a conversion from a CObject to a Smalltalk object + to be stored by #at:put:" + + + self subclassResponsibility + ] + + cObjStoredType [ + "Private - Provide a conversion from a CObject to a Smalltalk object + to be stored by #at:put:" + + + self subclassResponsibility + ] + + value [ + "Answer the value the receiver is pointing to. The exact returned + value depends on the receiver's class" + + + ^self at: 0 type: self cObjStoredType + ] + + value: aValue [ + "Set the receiver to point to the value, aValue. The exact meaning + of aValue depends on the receiver's class" + + + self + at: 0 + put: aValue + type: self cObjStoredType + ] +] + diff --git a/kernel/ffi/CScalarCType.st b/kernel/ffi/CScalarCType.st new file mode 100644 index 00000000..efe236d6 --- /dev/null +++ b/kernel/ffi/CScalarCType.st @@ -0,0 +1,58 @@ +"====================================================================== +| +| Base class definition for C data type description objects. +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1990,91,92,94,95,99,2000,2001,2007,2008 +| Free Software Foundation, Inc. +| Written by Steve Byrne. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +CType subclass: CScalarCType [ + + + + + storeOn: aStream [ + "Store Smalltalk code that compiles to the receiver" + + + aStream + print: self cObjectType; + nextPutAll: 'Type' + ] + + valueType [ + "valueType is used as a means to communicate to the interpreter the + underlying type of the data. For scalars, it is supplied by the + CObject subclass." + + + ^self cObjectType cObjStoredType + ] +] + diff --git a/kernel/ffi/CShort.st b/kernel/ffi/CShort.st new file mode 100644 index 00000000..46e14bd1 --- /dev/null +++ b/kernel/ffi/CShort.st @@ -0,0 +1,82 @@ +"====================================================================== +| +| C object basic data type definitions. +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1988,92,94,95,99,2000,2001,2002,2003,2004,2008,2009 +| Free Software Foundation, Inc. +| Written by Steve Byrne. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +CScalar subclass: CShort [ + + + + + CShort class >> sizeof [ + "Answer the receiver's instances size" + + + ^CShortSize + ] + + CShort class >> alignof [ + "Answer the receiver's instances required aligment" + + + ^CShortSize + ] + + CShort class >> cObjStoredType [ + "Private - Answer an index referring to the receiver's instances scalar type" + + + ^2 + ] + + sizeof [ + "Answer the receiver's size" + + + ^CShortSize + ] + + alignof [ + "Answer the receiver's required aligment" + + + ^CShortSize + ] + + cObjStoredType [ + "Private - Answer an index referring to the receiver's scalar type" + + + ^2 + ] +] + diff --git a/kernel/ffi/CSmalltalk.st b/kernel/ffi/CSmalltalk.st new file mode 100644 index 00000000..2b305322 --- /dev/null +++ b/kernel/ffi/CSmalltalk.st @@ -0,0 +1,82 @@ +"====================================================================== +| +| C object basic data type definitions. +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1988,92,94,95,99,2000,2001,2002,2003,2004,2008,2009 +| Free Software Foundation, Inc. +| Written by Steve Byrne. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +CScalar subclass: CSmalltalk [ + + + + + CSmalltalk class >> sizeof [ + "Answer the receiver's instances size" + + + ^CPtrSize + ] + + CSmalltalk class >> alignof [ + "Answer the receiver's instances required aligment" + + + ^CPtrSize + ] + + CSmalltalk class >> cObjStoredType [ + "Private - Answer an index referring to the receiver's instances scalar type" + + + ^9 + ] + + sizeof [ + "Answer the receiver's size" + + + ^CPtrSize + ] + + alignof [ + "Answer the receiver's required aligment" + + + ^CPtrSize + ] + + cObjStoredType [ + "Private - Answer an index referring to the receiver's scalar type" + + + ^9 + ] +] + diff --git a/kernel/ffi/CString.st b/kernel/ffi/CString.st new file mode 100644 index 00000000..51ae077f --- /dev/null +++ b/kernel/ffi/CString.st @@ -0,0 +1,107 @@ +"====================================================================== +| +| C object basic data type definitions. +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1988,92,94,95,99,2000,2001,2002,2003,2004,2008,2009 +| Free Software Foundation, Inc. +| Written by Steve Byrne. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +CPtr subclass: CString [ + + + >#asString. + +In general, I behave like a cross between an array of characters and a pointer +to a character. I provide the protocol for both data types. My #value +method returns a Smalltalk String, as you would expect for a scalar datatype. +'> + + CString class >> value: anObject [ + "Answer a newly allocated CObject containing the passed value, + anObject. Remember to call #addToBeFinalized if you want the + CObject to be automatically freed" + + + | cObject | + cObject := self type new. + cObject value: anObject. + ^cObject + ] + + CString class >> type [ + "Answer a CType for the receiver---for example, CByteType if + the receiver is CByte." + + + ^CStringType + ] + + CString class >> cObjStoredType [ + "Private - Provide a conversion from a CObject to a Smalltalk object + to be stored by #at:put:" + + + ^8 + ] + + cObjStoredType [ + "Private - Provide a conversion from a CObject to a Smalltalk object + to be stored by #at:put:" + + + ^8 + ] + + value [ + "Answer the value the receiver is pointing to. The exact returned + value depends on the receiver's class" + + + ^self at: 0 type: 8 + ] + + value: aValue [ + "Set the receiver to point to the value, aValue. The exact meaning + of aValue depends on the receiver's class" + + + self + at: 0 + put: aValue + type: 8 + ] +] + diff --git a/kernel/ffi/CStringCType.st b/kernel/ffi/CStringCType.st new file mode 100644 index 00000000..e8f7deed --- /dev/null +++ b/kernel/ffi/CStringCType.st @@ -0,0 +1,47 @@ +"====================================================================== +| +| Base class definition for C data type description objects. +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1990,91,92,94,95,99,2000,2001,2007,2008 +| Free Software Foundation, Inc. +| Written by Steve Byrne. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +CScalarCType subclass: CStringCType [ + + + + + elementType [ + "Answer the type of the elements in the receiver's instances" + + + ^CCharType + ] +] + diff --git a/kernel/ffi/CStruct.st b/kernel/ffi/CStruct.st new file mode 100644 index 00000000..0fec1f25 --- /dev/null +++ b/kernel/ffi/CStruct.st @@ -0,0 +1,51 @@ +"====================================================================== +| +| C struct definition support classes. +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1992,94,95,99,2000,2001,2002,2008,2009 +| Free Software Foundation, Inc. +| Written by Steve Byrne. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +CCompound subclass: CStruct [ + + + + + + CStruct class >> declaration: array [ + "Compile methods that implement the declaration in array." + + + self + declaration: array + inject: self superclass sizeof + into: [:oldOffset :alignment | oldOffset alignTo: alignment] + ] +] + diff --git a/kernel/CType.st b/kernel/ffi/CType.st similarity index 60% rename from kernel/CType.st rename to kernel/ffi/CType.st index 8fbedd05..bf676905 100644 --- a/kernel/CType.st +++ b/kernel/ffi/CType.st @@ -61,28 +61,28 @@ elements.'> Smalltalk at: #CCharType put: (CScalarCType cObjectType: CChar). Smalltalk at: #CUCharType put: (CScalarCType cObjectType: CUChar). Smalltalk at: #CShortType put: (CScalarCType cObjectType: CShort). - Smalltalk at: #CUShortType put: (CScalarCType cObjectType: CUShort). - Smalltalk at: #CLongType put: (CScalarCType cObjectType: CLong). - Smalltalk at: #CULongType put: (CScalarCType cObjectType: CULong). - Smalltalk at: #CLongLongType put: (CScalarCType cObjectType: CLongLong). - Smalltalk at: #CULongLongType put: (CScalarCType cObjectType: CULongLong). - Smalltalk at: #CIntType put: (CScalarCType cObjectType: CInt). - Smalltalk at: #CUIntType put: (CScalarCType cObjectType: CUInt). - Smalltalk at: #CSmalltalkType put: (CScalarCType cObjectType: CSmalltalk). + Smalltalk at: #CUShortType put: (CScalarCType cObjectType: CUShort). + Smalltalk at: #CLongType put: (CScalarCType cObjectType: CLong). + Smalltalk at: #CULongType put: (CScalarCType cObjectType: CULong). + Smalltalk at: #CLongLongType put: (CScalarCType cObjectType: CLongLong). + Smalltalk at: #CULongLongType put: (CScalarCType cObjectType: CULongLong). + Smalltalk at: #CIntType put: (CScalarCType cObjectType: CInt). + Smalltalk at: #CUIntType put: (CScalarCType cObjectType: CUInt). + Smalltalk at: #CSmalltalkType put: (CScalarCType cObjectType: CSmalltalk). Smalltalk at: #CFloatType put: (CScalarCType cObjectType: CFloat). Smalltalk at: #CDoubleType put: (CScalarCType cObjectType: CDouble). Smalltalk at: #CLongDoubleType put: (CScalarCType cObjectType: CLongDouble). Smalltalk at: #CStringType put: (CStringCType cObjectType: CString). Smalltalk at: #CByteType put: (CScalarCType cObjectType: CByte). Smalltalk at: #CBooleanType put: (CScalarCType cObjectType: CBoolean). - TypeMap := (IdentityDictionary new) - at: #long put: CLongType; - at: #uLong put: CULongType; - at: #longLong put: CLongLongType; - at: #uLongLong put: CULongLongType; - at: #byte put: CByteType; - at: #char put: CCharType; - at: #uChar put: CUCharType; + TypeMap := (IdentityDictionary new) + at: #long put: CLongType; + at: #uLong put: CULongType; + at: #longLong put: CLongLongType; + at: #uLongLong put: CULongLongType; + at: #byte put: CByteType; + at: #char put: CCharType; + at: #uChar put: CUCharType; at: #uchar put: CUCharType; at: #short put: CShortType; at: #uShort put: CUShortType; @@ -95,7 +95,7 @@ elements.'> at: #longDouble put: CLongDoubleType; at: #string put: CStringType; at: #smalltalk put: CSmalltalkType; - yourself + yourself. ] CType class >> cObjectBinding: aCObjectSubclassBinding [ @@ -269,202 +269,3 @@ elements.'> ] ] - - -CType subclass: CScalarCType [ - - - - - storeOn: aStream [ - "Store Smalltalk code that compiles to the receiver" - - - aStream - print: self cObjectType; - nextPutAll: 'Type' - ] - - valueType [ - "valueType is used as a means to communicate to the interpreter the - underlying type of the data. For scalars, it is supplied by the - CObject subclass." - - - ^self cObjectType cObjStoredType - ] -] - - - -CScalarCType subclass: CStringCType [ - - - - - elementType [ - "Answer the type of the elements in the receiver's instances" - - - ^CCharType - ] -] - - - -CType subclass: CPtrCType [ - | elementType | - - - - - CPtrCType class >> from: type [ - "Private - Called by computeAggregateType: for pointers" - - - | subType typeInfo | - subType := type at: 2. - typeInfo := CType from: subType. - ^self elementType: typeInfo - ] - - CPtrCType class >> elementType: aCType [ - "Answer a new instance of CPtrCType that maps pointers to the given CType" - - - ^(self cObjectType: CPtr) - elementType: aCType; - yourself - ] - - = anObject [ - "Return whether the receiver and anObject are equal." - - ^super = anObject and: [self elementType = anObject elementType] - ] - - hash [ - "Return a hash code for the receiver." - - ^super hash bitXor: self elementType hash - ] - - elementType [ - "Answer the type of the elements in the receiver's instances" - - - ^elementType - ] - - storeOn: aStream [ - - aStream - nextPutAll: '(CPtrCType elementType: '; - store: self elementType; - nextPut: $) - ] - - elementType: aCType [ - "Initialize the receiver's instance variables" - - - elementType := aCType - ] -] - - - -CPtrCType subclass: CArrayCType [ - | numElements | - - - - - CArrayCType class >> from: type [ - "Private - Called by CType>>from: for arrays" - - - | numElts elementType typeInfo | - elementType := type at: 2. - numElts := type at: 3. - typeInfo := CType from: elementType. - ^self elementType: typeInfo numberOfElements: numElts - ] - - CArrayCType class >> elementType: aCType [ - - self shouldNotImplement - ] - - CArrayCType class >> elementType: aCType numberOfElements: anInteger [ - "Answer a new instance of CPtrCType that maps an array whose elements - are of the given CType, and whose size is exactly anInteger elements - (of course, anInteger only matters for allocation, not for access, since - no out-of-bounds protection is provided for C objects)." - - - ^(self cObjectType: CArray) - elementType: aCType; - numberOfElements: anInteger; - yourself - ] - - = anObject [ - "Return whether the receiver and anObject are equal." - - ^super = anObject and: [ - self numberOfElements = anObject numberOfElements] - ] - - hash [ - "Return a hash code for the receiver." - - ^super hash bitXor: self numberOfElements hash - ] - - storeOn: aStream [ - "As with super." - - aStream - nextPutAll: '(CArrayCType elementType: '; - store: self elementType; - nextPutAll: ' numberOfElements: '; - store: numElements asInteger; - nextPut: $) - ] - - sizeof [ - "Answer the size of the receiver's instances" - - - ^elementType sizeof * numElements - ] - - alignof [ - "Answer the alignment of the receiver's instances" - - - ^elementType alignof - ] - - numberOfElements [ - "Answer the number of elements in the receiver's instances" - - - ^numElements - ] - - numberOfElements: anInteger [ - "Initialize the receiver's instance variables" - - - numElements := anInteger - ] -] - - - -Eval [ - CType initialize -] - diff --git a/kernel/ffi/CTypeInitialization.st b/kernel/ffi/CTypeInitialization.st new file mode 100644 index 00000000..fd12c4ca --- /dev/null +++ b/kernel/ffi/CTypeInitialization.st @@ -0,0 +1,36 @@ +"====================================================================== +| +| Base class definition for C data type description objects. +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1990,91,92,94,95,99,2000,2001,2007,2008 +| Free Software Foundation, Inc. +| Written by Steve Byrne. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + +Eval [ + CType initialize. +] + diff --git a/kernel/ffi/CUChar.st b/kernel/ffi/CUChar.st new file mode 100644 index 00000000..7a3e7b46 --- /dev/null +++ b/kernel/ffi/CUChar.st @@ -0,0 +1,82 @@ +"====================================================================== +| +| C object basic data type definitions. +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1988,92,94,95,99,2000,2001,2002,2003,2004,2008,2009 +| Free Software Foundation, Inc. +| Written by Steve Byrne. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +CScalar subclass: CUChar [ + + + + + CUChar class >> sizeof [ + "Answer the receiver's instances size" + + + ^1 + ] + + CUChar class >> alignof [ + "Answer the receiver's instances required aligment" + + + ^1 + ] + + CUChar class >> cObjStoredType [ + "Private - Answer an index referring to the receiver's instances scalar type" + + + ^1 + ] + + sizeof [ + "Answer the receiver's size" + + + ^1 + ] + + alignof [ + "Answer the receiver's required aligment" + + + ^1 + ] + + cObjStoredType [ + "Private - Answer an index referring to the receiver's scalar type" + + + ^1 + ] +] + diff --git a/kernel/ffi/CUInt.st b/kernel/ffi/CUInt.st new file mode 100644 index 00000000..aded8523 --- /dev/null +++ b/kernel/ffi/CUInt.st @@ -0,0 +1,82 @@ +"====================================================================== +| +| C object basic data type definitions. +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1988,92,94,95,99,2000,2001,2002,2003,2004,2008,2009 +| Free Software Foundation, Inc. +| Written by Steve Byrne. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +CScalar subclass: CUInt [ + + + + + CUInt class >> sizeof [ + "Answer the receiver's instances size" + + + ^CIntSize + ] + + CUInt class >> alignof [ + "Answer the receiver's instances required aligment" + + + ^CIntSize + ] + + CUInt class >> cObjStoredType [ + "Private - Answer an index referring to the receiver's instances scalar type" + + + ^11 + ] + + sizeof [ + "Answer the receiver's size" + + + ^CIntSize + ] + + alignof [ + "Answer the receiver's required aligment" + + + ^CIntSize + ] + + cObjStoredType [ + "Private - Answer an index referring to the receiver's scalar type" + + + ^11 + ] +] + diff --git a/kernel/ffi/CULong.st b/kernel/ffi/CULong.st new file mode 100644 index 00000000..675117df --- /dev/null +++ b/kernel/ffi/CULong.st @@ -0,0 +1,82 @@ +"====================================================================== +| +| C object basic data type definitions. +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1988,92,94,95,99,2000,2001,2002,2003,2004,2008,2009 +| Free Software Foundation, Inc. +| Written by Steve Byrne. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +CScalar subclass: CULong [ + + + + + CULong class >> sizeof [ + "Answer the receiver's instances size" + + + ^CLongSize + ] + + CULong class >> alignof [ + "Answer the receiver's instances required aligment" + + + ^CLongSize + ] + + CULong class >> cObjStoredType [ + "Private - Answer an index referring to the receiver's instances scalar type" + + + ^5 + ] + + sizeof [ + "Answer the receiver's size" + + + ^CLongSize + ] + + alignof [ + "Answer the receiver's required aligment" + + + ^CLongSize + ] + + cObjStoredType [ + "Private - Answer an index referring to the receiver's scalar type" + + + ^5 + ] +] + diff --git a/kernel/ffi/CULongLong.st b/kernel/ffi/CULongLong.st new file mode 100644 index 00000000..2b5e8c21 --- /dev/null +++ b/kernel/ffi/CULongLong.st @@ -0,0 +1,83 @@ +"====================================================================== +| +| C object basic data type definitions. +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1988,92,94,95,99,2000,2001,2002,2003,2004,2008,2009 +| Free Software Foundation, Inc. +| Written by Steve Byrne. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + + +CScalar subclass: CULongLong [ + + + + + CULongLong class >> sizeof [ + "Answer the receiver's instances size" + + + ^8 + ] + + CULongLong class >> alignof [ + "Answer the receiver's instances required aligment" + + + ^CLongLongAlignment + ] + + CULongLong class >> cObjStoredType [ + "Private - Answer an index referring to the receiver's instances scalar type" + + + ^31 + ] + + sizeof [ + "Answer the receiver's size" + + + ^8 + ] + + alignof [ + "Answer the receiver's required aligment" + + + ^CLongLongAlignment + ] + + cObjStoredType [ + "Private - Answer an index referring to the receiver's scalar type" + + + ^31 + ] +] + diff --git a/kernel/ffi/CUShort.st b/kernel/ffi/CUShort.st new file mode 100644 index 00000000..57f55d76 --- /dev/null +++ b/kernel/ffi/CUShort.st @@ -0,0 +1,82 @@ +"====================================================================== +| +| C object basic data type definitions. +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1988,92,94,95,99,2000,2001,2002,2003,2004,2008,2009 +| Free Software Foundation, Inc. +| Written by Steve Byrne. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +CScalar subclass: CUShort [ + + + + + CUShort class >> sizeof [ + "Answer the receiver's instances size" + + + ^CShortSize + ] + + CUShort class >> alignof [ + "Answer the receiver's instances required aligment" + + + ^CShortSize + ] + + CUShort class >> cObjStoredType [ + "Private - Answer an index referring to the receiver's instances scalar type" + + + ^3 + ] + + sizeof [ + "Answer the receiver's size" + + + ^CShortSize + ] + + alignof [ + "Answer the receiver's required aligment" + + + ^CShortSize + ] + + cObjStoredType [ + "Private - Answer an index referring to the receiver's scalar type" + + + ^3 + ] +] + diff --git a/kernel/ffi/CUnion.st b/kernel/ffi/CUnion.st new file mode 100644 index 00000000..cc47cd93 --- /dev/null +++ b/kernel/ffi/CUnion.st @@ -0,0 +1,51 @@ +"====================================================================== +| +| C struct definition support classes. +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1992,94,95,99,2000,2001,2002,2008,2009 +| Free Software Foundation, Inc. +| Written by Steve Byrne. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +CCompound subclass: CUnion [ + + + + + + CUnion class >> declaration: array [ + "Compile methods that implement the declaration in array." + + + self + declaration: array + inject: 0 + into: [:oldOffset :alignment | 0] + ] +] + diff --git a/kernel/ffi/Extensions.st b/kernel/ffi/Extensions.st new file mode 100644 index 00000000..8265bb0c --- /dev/null +++ b/kernel/ffi/Extensions.st @@ -0,0 +1,91 @@ +"====================================================================== +| +| CFunctionDescriptor Method Definitions +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1988,92,94,95,99,2000,2001,2002,2003,2005,2008 +| Free Software Foundation, Inc. +| Written by Steve Byrne. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + +SystemDictionary extend [ + + system: aString withArguments: args [ + + ^self system: aString % (args collect: [ :string | string withShellEscapes ]) + + ] + + system: aString [ + + + + ] + + getenv: aString [ + + + + ] + + environ [ + + + + ] + + putenv: aString [ + + + + ] + + getArgc [ + + + + ] + + getArgv: index [ + + + + ] + +] + +Integer extend [ + + alignTo: anInteger [ + "Answer the receiver, truncated to the first higher or equal + multiple of anInteger (which must be a power of two)" + + + ^self + anInteger - 1 bitClear: anInteger - 1 + ] + +] + diff --git a/kernel/file/Extensions.st b/kernel/file/Extensions.st new file mode 100644 index 00000000..35e965e5 --- /dev/null +++ b/kernel/file/Extensions.st @@ -0,0 +1,51 @@ +"====================================================================== +| +| File Method Definitions +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1988,92,94,95,99,2000,2001,2002,2005,2006,2007,2008,2009 +| Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +String extend [ + / aName [ + "Answer a File object as appropriate for a file named + 'aName' in the directory represented by the receiver." + + + ^(File path: self) at: aName + ] + + asFile [ + "Answer a File object for the file whose name is in the receiver." + + + ^(File path: self) + ] +] + diff --git a/kernel/File.st b/kernel/file/File.st similarity index 96% rename from kernel/File.st rename to kernel/file/File.st index 426a415c..3326881f 100644 --- a/kernel/File.st +++ b/kernel/file/File.st @@ -642,41 +642,7 @@ FilePath subclass: File [ ] ] - -Namespace current: Kernel [ - -Object subclass: Stat [ - - - | stMode stSize stAtime stMtime stCtime | - stMode [ ^stMode ] - stSize [ ^stSize ] - stAtime [ ^stAtime ] - stMtime [ ^stMtime ] - stCtime [ ^stCtime ] -] - -] - - - -String extend [ - / aName [ - "Answer a File object as appropriate for a file named - 'aName' in the directory represented by the receiver." - - - ^(File path: self) at: aName - ] - - asFile [ - "Answer a File object for the file whose name is in the receiver." - - - ^(File path: self) - ] -] - Eval [ File initialize ] + diff --git a/kernel/file/Stat.st b/kernel/file/Stat.st new file mode 100644 index 00000000..f47b2ea9 --- /dev/null +++ b/kernel/file/Stat.st @@ -0,0 +1,49 @@ +"====================================================================== +| +| File Method Definitions +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1988,92,94,95,99,2000,2001,2002,2005,2006,2007,2008,2009 +| Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Namespace current: Kernel [ + +Object subclass: Stat [ + + + | stMode stSize stAtime stMtime stCtime | + stMode [ ^stMode ] + stSize [ ^stSize ] + stAtime [ ^stAtime ] + stMtime [ ^stMtime ] + stCtime [ ^stCtime ] +] + +] + diff --git a/kernel/file/vfs/ArchiveFile.st b/kernel/file/vfs/ArchiveFile.st new file mode 100644 index 00000000..beec5b7f --- /dev/null +++ b/kernel/file/vfs/ArchiveFile.st @@ -0,0 +1,305 @@ +"====================================================================== +| +| Virtual File System layer definitions +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2002, 2005, 2007, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Namespace current: VFS [ + +FileWrapper subclass: ArchiveFile [ + | tmpFiles topLevelFiles allFiles extractedFiles | + + + + + displayOn: aStream [ + "Print a representation of the file identified by the receiver." + super displayOn: aStream. + aStream nextPut: $#. + self class printOn: aStream + ] + + isDirectory [ + "Answer true. The archive can always be considered as a directory." + + + ^true + ] + + isAccessible [ + "Answer whether a directory with the name contained in the receiver does + exist and can be accessed" + + + ^self isReadable + ] + + at: aName [ + "Answer a FilePath for a file named `aName' residing in the directory + represented by the receiver." + + + | handler data | + allFiles isNil ifTrue: [self refresh]. + data := allFiles at: aName ifAbsent: [^nil]. + handler := data at: 5 ifAbsent: [nil]. + handler isNil ifFalse: [^handler]. + tmpFiles isNil + ifTrue: + [tmpFiles := LookupTable new. + FileWrapper addDependent: self. + self addToBeFinalized]. + ^tmpFiles at: aName + ifAbsentPut: + [(TmpFileArchiveMember new) + name: aName; + archive: self] + ] + + nameAt: aString [ + "Answer a FilePath for a file named `aName' residing in the directory + represented by the receiver." + + + ^aString + ] + + namesDo: aBlock [ + "Evaluate aBlock once for each file in the directory represented by the + receiver, passing its name." + + + topLevelFiles isNil ifTrue: [self refresh]. + topLevelFiles do: aBlock + ] + + release [ + "Release the resources used by the receiver that don't survive when + reloading a snapshot." + + + tmpFiles isNil + ifFalse: + [tmpFiles do: [:each | each release]. + tmpFiles := nil]. + extractedFiles isNil + ifFalse: + [extractedFiles do: [:each | self primUnlink: each]. + extractedFiles := nil]. + super release + ] + + fillMember: anArchiveMember [ + "Extract the information on anArchiveMember. Answer + false if it actually does not exist in the archive; otherwise, + answer true after having told anArchiveMember about them + by sending #size:stCtime:stMtime:stAtime:isDirectory: to it." + + + | data | + allFiles isNil ifTrue: [self refresh]. + data := allFiles at: anArchiveMember name ifAbsent: [nil]. + data isNil ifTrue: [^false]. + anArchiveMember fillFrom: data. + ^true + ] + + member: anArchiveMember do: aBlock [ + "Evaluate aBlock once for each file in the directory represented by + anArchiveMember, passing its name." + + + | data | + allFiles isNil ifTrue: [self refresh]. + data := allFiles at: anArchiveMember name ifAbsent: [nil]. + data isNil ifTrue: [^SystemExceptions.FileError signal: 'File not found']. + (data at: 1) isNil + ifTrue: [^SystemExceptions.FileError signal: 'Not a directory']. + (data at: 1) do: aBlock + ] + + refresh [ + "Extract the directory listing from the archive" + + + | pipe line parentPath name current currentPath directoryTree directory | + super refresh. + current := currentPath := nil. + allFiles := LookupTable new. + directoryTree := LookupTable new. + self fileData do: + [:data | + | path size date mode member | + mode := self convertMode: (data at: 4). + data at: 4 put: mode. + path := data at: 1. + path last = $/ ifTrue: [path := path copyFrom: 1 to: path size - 1]. + + "Look up the tree for the directory in which the file resides. + We keep a simple 1-element cache." + parentPath := File pathFor: path. + name := File stripPathFrom: path. + parentPath = currentPath + ifFalse: + [currentPath := parentPath. + current := self findDirectory: path into: directoryTree]. + + "Create an item in the tree for directories, and + add an association to the allFiles SortedCollection" + directory := (mode bitAnd: 8r170000) = 8r40000 + ifTrue: [current at: name put: LookupTable new] + ifFalse: [current at: name put: nil]. + data at: 1 put: directory. + allFiles at: path put: data. + member := data at: 5 ifAbsent: [nil]. + member notNil ifTrue: [member fillFrom: data]]. + + "Leave the LookupTables to be garbage collected, we are now interested + in the file names only." + topLevelFiles := directoryTree keys asArray. + allFiles + do: [:data | (data at: 1) isNil ifFalse: [data at: 1 put: (data at: 1) keys asArray]] + ] + + member: anArchiveMember mode: bits [ + "Set the permission bits for the file in anArchiveMember." + + + self subclassResponsibility + ] + + removeMember: anArchiveMember [ + "Remove the member represented by anArchiveMember." + + + self subclassResponsibility + ] + + updateMember: anArchiveMember [ + "Update the member represented by anArchiveMember by + copying the file into which it was extracted back to the + archive." + + + self subclassResponsibility + ] + + extractMember: anArchiveMember [ + "Extract the contents of anArchiveMember into a file + that resides on disk, and answer the name of the file." + + + extractedFiles isNil ifTrue: [extractedFiles := IdentityDictionary new]. + ^extractedFiles at: anArchiveMember + ifAbsentPut: + [| temp | + temp := FileStream openTemporaryFile: Directory temporary , '/vfs'. + self extractMember: anArchiveMember into: temp. + File name: temp name] + ] + + extractMember: anArchiveMember into: file [ + "Extract the contents of anArchiveMember into a file + that resides on disk, and answer the name of the file." + + + self subclassResponsibility + ] + + convertMode: mode [ + "Convert the mode from a string, character or boolean to an octal number." + + + mode isNumber ifTrue: [^mode]. + mode isString ifTrue: [^self convertModeString: mode]. + mode isCharacter ifTrue: [^self convertMode: mode == $d]. + ^mode ifTrue: [8r40755] ifFalse: [8r644] + ] + + convertModeString: modeString [ + "Convert the mode from a string to an octal number." + + + | mode | + mode := 0. + (modeString at: 1) = $l ifTrue: [mode := 8r120000]. + (modeString at: 1) = $d ifTrue: [mode := 8r40000]. + (modeString at: 4) asLowercase = $s ifTrue: [mode := mode + 8r4000]. + (modeString at: 7) asLowercase = $s ifTrue: [mode := mode + 8r2000]. + (modeString at: 10) asLowercase = $t ifTrue: [mode := mode + 8r1000]. + modeString + from: 2 + to: 10 + keysAndValuesDo: [:i :ch | ch isLowercase ifTrue: [mode := mode setBit: 11 - i]]. + ^mode + ] + + findDirectory: path into: tree [ + "Look up into tree (which is a tree of Dictionaries) the directory + that is the parent of the file named `path'." + + + | current last | + current := tree. + last := 1. + path keysAndValuesDo: + [:i :each | + | element | + each = $/ + ifTrue: + [last = i + ifFalse: + [element := path copyFrom: last to: i - 1. + current := current at: element + ifAbsentPut: + ["The list command might output files but not + directories. No problem, we create them along + the way." + + | directory | + directory := LookupTable new. + allFiles at: (path copyFrom: 1 to: i - 1) + put: + {directory. 0. + self creationTime. + self mode bitOr: 8r40111}. + directory]]. + last := i + 1]]. + ^current + ] +] + +] diff --git a/kernel/file/vfs/ArchiveMember.st b/kernel/file/vfs/ArchiveMember.st new file mode 100644 index 00000000..41ecc677 --- /dev/null +++ b/kernel/file/vfs/ArchiveMember.st @@ -0,0 +1,340 @@ +"====================================================================== +| +| Virtual File System layer definitions +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2002, 2005, 2007, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Namespace current: VFS [ + +FilePath subclass: ArchiveMember [ + | archive name mode size stCtime stMtime stAtime | + + + + + = aFile [ + "Answer whether the receiver represents the same file as the receiver." + + + ^self class == aFile class and: [ self archive = aFile archive + and: [ self name = aFile name ] ] + ] + + hash [ + "Answer a hash value for the receiver." + + + ^self archive hash bitXor: self name hash + ] + + archive: anArchiveFile [ + "Set the archive of which the receiver is a member." + + + archive := anArchiveFile + ] + + full [ + "Answer the size of the file identified by the receiver" + + + ^self archive full at: self name + ] + + fillFrom: data [ + "Called back by the receiver's archive when the ArchiveMember + asks for file information." + + + self + size: (data at: 2) + stMtime: (data at: 3) + mode: (data at: 4) + ] + + size: bytes stMtime: mtime mode: modeBits [ + "Set the file information for the receiver." + + + size := bytes. + stCtime := self archive lastModifyTime. + stMtime := mtime. + stAtime := self archive lastAccessTime. + mode := modeBits + ] + + size: bytes stCtime: ctime stMtime: mtime stAtime: atime mode: modeBits [ + "Set the file information for the receiver." + + + size := bytes. + stCtime := ctime. + stMtime := mtime. + stAtime := atime. + mode := modeBits + ] + + asString [ + "Answer the name of the file identified by the receiver as answered by + File>>#name." + + + ^self name + ] + + displayOn: aStream [ + "Print a representation of the file identified by the receiver." + self archive displayOn: aStream. + aStream nextPut: $/. + super displayOn: aStream + ] + + isAbsolute [ + "Answer whether the receiver identifies an absolute path." + + ^self archive isAbsolute + ] + + name [ + "Answer the receiver's file name." + + + ^name + ] + + name: aName [ + "Set the receiver's file name to aName." + + + name := aName + ] + + archive [ + "Answer the archive of which the receiver is a member." + + + ^archive + ] + + size [ + "Answer the size of the file identified by the receiver" + + + size isNil ifTrue: [self refresh]. + ^size + ] + + lastAccessTime [ + "Answer the last access time of the file identified by the receiver" + + + stAtime isNil ifTrue: [self refresh]. + ^stAtime + ] + + lastChangeTime [ + "Answer the last change time of the file identified by the receiver + (the `last change time' has to do with permissions, ownership and the + like). On some operating systems, this could actually be the + file creation time." + + + stCtime isNil ifTrue: [self refresh]. + ^stCtime + ] + + creationTime [ + "Answer the creation time of the file identified by the receiver. + On some operating systems, this could actually be the last change time + (the `last change time' has to do with permissions, ownership and the + like)." + + + stCtime isNil ifTrue: [self refresh]. + ^stCtime + ] + + lastModifyTime [ + "Answer the last modify time of the file identified by the receiver + (the `last modify time' has to do with the actual file contents)." + + + stMtime isNil ifTrue: [self refresh]. + ^stMtime + ] + + refresh [ + "Refresh the statistics for the receiver" + + + self archive fillMember: self + ] + + exists [ + "Answer whether a file with the name contained in the receiver does exist." + + + ^self archive fillMember: self + ] + + mode [ + "Answer the octal permissions for the file." + + + size isNil ifTrue: [self refresh]. + ^mode bitAnd: 4095 + ] + + mode: mode [ + "Set the octal permissions for the file to be `mode'." + + + self archive member: self mode: (mode bitAnd: 4095) + ] + + isSymbolicLink [ + "Answer whether a file with the name contained in the receiver does exist + and identifies a symbolic link." + + + size isNil ifTrue: [self refresh]. + ^(mode bitAnd: 8r170000) = 8r120000 + ] + + isDirectory [ + "Answer whether a file with the name contained in the receiver does exist + and identifies a directory." + + + size isNil ifTrue: [self refresh]. + ^(mode bitAnd: 8r170000) = 8r40000 + ] + + isReadable [ + "Answer whether a file with the name contained in the receiver does exist + and is readable" + + + ^true + ] + + isWriteable [ + "Answer whether a file with the name contained in the receiver does exist + and is writeable" + + + ^true + ] + + isExecutable [ + "Answer whether a file with the name contained in the receiver does exist + and is executable" + + + ^false + ] + + isAccessible [ + "Answer whether a directory with the name contained in the receiver does exist + and is accessible" + + + ^true + ] + + open: class mode: mode ifFail: aBlock [ + "Open the receiver in the given mode (as answered by FileStream's + class constant methods)" + + + self subclassResponsibility + ] + + update: aspect [ + "Private - Update the in-archive version of the file before closing." + + + aspect == #beforeClosing + ifTrue: [self archive updateMember: self] aspect == #afterClosing + ifTrue: + [self archive refresh. + self refresh] + ] + + remove [ + "Remove the file with the given path name" + + + self archive removeMember: self. + File checkError + ] + + renameTo: newFileName [ + "Rename the file with the given path name oldFileName to newFileName" + + + self notYetImplemented + ] + + at: aName [ + "Answer a FilePath for a file named `aName' residing in the directory + represented by the receiver." + + + ^self archive at: (File append: aName to: self name) + ] + + , aName [ + "Answer an object of the same kind as the receiver, whose name + is suffixed with aName." + + ^self archive at: (self name, aName) + ] + + createDirectory: dirName [ + "Create a subdirectory of the receiver, naming it dirName." + + + self archive createDirectory: (File append: dirName to: self name) + ] + + namesDo: aBlock [ + "Evaluate aBlock once for each file in the directory represented by the + receiver, passing its name." + + + self archive member: self do: aBlock + ] +] + +] + diff --git a/kernel/file/vfs/Extensions.st b/kernel/file/vfs/Extensions.st new file mode 100644 index 00000000..86a3cc27 --- /dev/null +++ b/kernel/file/vfs/Extensions.st @@ -0,0 +1,38 @@ +"====================================================================== +| +| Virtual File System (new classes) +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2007, 2008 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + +FilePath extend [ + zip [ + + ^VFS.ZipFile on: self + ] +] diff --git a/kernel/file/vfs/FileWrapper.st b/kernel/file/vfs/FileWrapper.st new file mode 100644 index 00000000..a7a3506f --- /dev/null +++ b/kernel/file/vfs/FileWrapper.st @@ -0,0 +1,344 @@ +"====================================================================== +| +| Virtual File System layer definitions +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2002, 2005, 2007, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + +Namespace current: VFS [ + +FilePath subclass: FileWrapper [ + | file | + + + + + FileWrapper class >> initialize [ + "Register the receiver with ObjectMemory" + + + ObjectMemory addDependent: self. + ] + + FileWrapper class >> update: aspect [ + "Private - Remove the files before quitting, and register the virtual + filesystems specified by the subclasses upon image load." + + + aspect == #aboutToQuit ifTrue: [self broadcast: #release] + ] + + FileWrapper class >> on: file [ + "Create an instance of this class representing the contents of the given + file, under the virtual filesystem fsName." + + + ^self new file: file + ] + + = aFile [ + "Answer whether the receiver represents the same file as the receiver." + + + ^self class == aFile class and: [ self file = aFile file ] + ] + + hash [ + "Answer a hash value for the receiver." + + + ^self file hash + ] + + asString [ + "Answer the string representation of the receiver's path." + + ^self file asString + ] + + name [ + "Answer the full path to the receiver." + + ^self file name + ] + + isAbsolute [ + "Answer whether the receiver identifies an absolute path." + + ^self file isAbsolute + ] + + full [ + "Answer the size of the file identified by the receiver" + + + self isAbsolute ifTrue: [ ^self ]. + ^self class on: self file full + ] + + mode [ + "Answer the permission bits for the file identified by the receiver" + + + ^self file mode + ] + + mode: anInteger [ + "Answer the permission bits for the file identified by the receiver" + + + self file mode: anInteger + ] + + size [ + "Answer the size of the file identified by the receiver" + + + ^self file size + ] + + lastAccessTime [ + "Answer the last access time of the file identified by the receiver" + + + ^self file lastAccessTime + ] + + exists [ + "Answer whether a file with the name contained in the receiver + does exist." + + + ^self file exists + ] + + isAbsolute [ + "Answer whether the receiver identifies an absolute path." + + + ^self file isAbsolute + ] + + isReadable [ + "Answer whether a file with the name contained in the receiver does exist + and is readable" + + + ^self file isReadable + ] + + isWriteable [ + "Answer whether a file with the name contained in the receiver does exist + and is writeable" + + + ^self file isWriteable + ] + + isExecutable [ + "Answer whether a file with the name contained in the receiver does exist + and is executable" + + + ^self file isExecutable + ] + + isAccessible [ + "Answer whether a directory with the name contained in the receiver does + exist and can be accessed" + + + ^self file isAccessible + ] + + isDirectory [ + "Answer whether a file with the name contained in the receiver + does exist identifies a directory." + + + ^self file isDirectory + ] + + isSymbolicLink [ + "Answer whether a file with the name contained in the receiver + does exist and identifies a symbolic link." + + + ^self file isSymbolicLink + ] + + owner: ownerString group: groupString [ + "Set the receiver's owner and group to be ownerString and groupString." + + + self file owner: ownerString group: groupString + ] + + lastAccessTime: accessDateTime lastModifyTime: modifyDateTime [ + "Update the timestamps of the file corresponding to the receiver, to be + accessDateTime and modifyDateTime." + + + self file lastAccessTime: accessDateTime lastModifyTime: modifyDateTime + ] + + lastChangeTime [ + "Answer the last change time of the file identified by the receiver + (the `last change time' has to do with permissions, ownership and the + like). On some operating systems, this could actually be the + file creation time." + + + ^self file lastChangeTime + ] + + creationTime [ + "Answer the creation time of the file identified by the receiver. + On some operating systems, this could actually be the last change time + (the `last change time' has to do with permissions, ownership and the + like)." + + + ^self file creationTime + ] + + lastModifyTime [ + "Answer the last modify time of the file identified by the receiver + (the `last modify time' has to do with the actual file contents)." + + + ^self file lastModifyTime + ] + + isReadable [ + "Answer whether a file with the name contained in the receiver does exist + and is readable" + + + ^self file isReadable + ] + + isWriteable [ + "Answer whether a file with the name contained in the receiver does exist + and is writeable" + + + ^self file isWritable + ] + + isExecutable [ + "Answer whether a file with the name contained in the receiver does exist + and is executable" + + + ^self file isExecutable + ] + + open: class mode: mode ifFail: aBlock [ + "Open the receiver in the given mode (as answered by FileStream's + class constant methods)" + + + ^self file + open: class + mode: mode + ifFail: aBlock + ] + + remove [ + "Remove the file with the given path name" + + + self file remove + ] + + symlinkAs: destName [ + "Create destName as a symbolic link of the receiver. The appropriate + relative path is computed automatically." + + + ^self file symlinkAs: destName + ] + + pathFrom: dirName [ + "Compute the relative path from the directory dirName to the receiver" + + + ^self file pathFrom: dirName + ] + + symlinkFrom: srcName [ + "Create the receiver as a symbolic link from srcName (relative to the + path of the receiver)." + + + ^self file symlinkFrom: srcName + ] + + renameTo: newName [ + "Rename the file identified by the receiver to newName" + + + ^self file renameTo: newName + ] + + pathTo: destName [ + "Compute the relative path from the receiver to destName." + + + ^self file pathTo: destName + ] + + at: aName [ + "Answer a File or Directory object as appropriate for a file named + 'aName' in the directory represented by the receiver." + + + ^self class on: (self file at: aName) + ] + + namesDo: aBlock [ + "Evaluate aBlock once for each file in the directory represented by the + receiver, passing its name." + + + self file namesDo: aBlock + ] + + file [ + + ^file + ] + + file: aFilePath [ + + file := aFilePath. + ] +] + +] diff --git a/kernel/VFSZip.st b/kernel/file/vfs/LimitedStream.st similarity index 53% rename from kernel/VFSZip.st rename to kernel/file/vfs/LimitedStream.st index 0347c932..1e4d653c 100644 --- a/kernel/VFSZip.st +++ b/kernel/file/vfs/LimitedStream.st @@ -29,176 +29,6 @@ | ======================================================================" -Namespace current: VFS [ - -ArchiveFile subclass: ZipFile [ - - - - - createDirectory: dirName [ - "Create a subdirectory of the receiver, naming it dirName." - - - self notYetImplemented - ] - - member: anArchiveMember mode: bits [ - "Set the permission bits for the file in anArchiveMember." - - - self notYetImplemented - ] - - extractMember: anArchiveMember into: temp [ - "Extract the contents of anArchiveMember into a file - that resides on disk, and answer the name of the file." - - - Smalltalk - system: 'unzip -p %1 %2 > %3' - withArguments: {self file name. - anArchiveMember name. - temp name} - ] - - removeMember: anArchiveMember [ - "Remove the member represented by anArchiveMember." - - - Smalltalk - system: 'zip -d %1 %2' - withArguments: {self file name. - anArchiveMember name} - ] - - updateMember: anArchiveMember [ - "Update the member represented by anArchiveMember by - copying the file into which it was extracted back to the - archive." - - - self notYetImplemented - ] - - centralDirectoryRangeIn: f [ - - | r beginCD size comLen buf ofsCD | - size := f size. - r := 21. - - "Great idea, that of putting a variable-length item at the end. Luckily, - we can make a sanity check of the data and find the correct spot of the - central directory's final record." - size - 22 to: size - 65535 - 22 - by: -257 - do: - [:pos | - buf := (f copyFrom: pos to: pos + r) asByteArray. - beginCD := buf indexOfSubCollection: #[80 75 5 6] ifAbsent: [0]. - beginCD = 0 - ifFalse: - [comLen := (buf at: beginCD + 21) * 256 + (buf at: beginCD + 20). - pos + beginCD + 21 + comLen = size - ifTrue: - [ofsCD := (buf at: beginCD + 19) * 16777216 - + ((buf at: beginCD + 18) * 65536) - + ((buf at: beginCD + 17) * 256) - + (buf at: beginCD + 16). - ^ofsCD to: pos + beginCD - 2]]. - r := 278]. - self error: 'invalid data in ZIP file' - ] - - fileData [ - "Extract the directory listing from the archive" - - - ^Generator on: - [:gen | - | f cd cdEnd data path date method dataSize fileSize fnsize - extra comment attr ofs | - f := self readStream. - cd := self centralDirectoryRangeIn: f. - f position: cd first. - cdEnd := cd last. - - date := DateTime now. - [f position <= cdEnd ] whileTrue: - [f skip: 10. - method := f nextUshort. - data := method = 0 ifTrue: [Array new: 5] ifFalse: [Array new: 4]. - data at: 3 put: date. - f skip: 12. - data at: 2 put: f nextUlong. - fnsize := f nextUshort. - extra := f nextUshort. - comment := f nextUshort. - f skip: 4. - attr := f nextUlong. - ofs := f nextUlong. - data at: 1 put: (f next: fnsize). - f skip: extra + comment. - data at: 4 put: (attr bitAnd: 16) = 16. - method = 0 - ifTrue: - [data at: 5 - put: ((StoredZipMember new) - name: (data at: 1); - archive: self; - offset: ofs; - yourself)]. - gen yield: data]. - f close] - ] -] - -] - - - -Namespace current: VFS [ - -TmpFileArchiveMember subclass: StoredZipMember [ - | offset | - - - - - offset [ - - ^offset - ] - - offset: anInteger [ - - offset := anInteger - ] - - open: class mode: mode ifFail: aBlock [ - - | fileStream | - (mode = FileStream read or: [ self extracted ]) - ifFalse: [^super open: class mode: mode ifFail: aBlock]. - - fileStream := self archive - open: class - mode: mode - ifFail: [^aBlock value]. - fileStream skip: self offset + 26. - fileStream skip: fileStream nextUshort + fileStream nextUshort. - fileStream setFile: self. - ^LimitedStream - on: fileStream - from: fileStream position - to: fileStream position + self size - 1 - ] -] - -] - Namespace current: Kernel [ @@ -365,10 +195,3 @@ Stream subclass: LimitedStream [ ] - -FilePath extend [ - zip [ - - ^VFS.ZipFile on: self - ] -] diff --git a/kernel/file/vfs/RecursiveFileWrapper.st b/kernel/file/vfs/RecursiveFileWrapper.st new file mode 100644 index 00000000..b801da01 --- /dev/null +++ b/kernel/file/vfs/RecursiveFileWrapper.st @@ -0,0 +1,160 @@ +"====================================================================== +| +| Virtual File System layer definitions +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2002, 2005, 2007, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Namespace current: Kernel [ + +VFS.FileWrapper subclass: RecursiveFileWrapper [ + + + do: aBlock [ + "Same as the wrapped #do:, but reuses the file object for efficiency." + + + aBlock value: self file. + self file namesDo: + [:name | + | f | + (#('.' '..') includes: name) ifFalse: [ + f := self at: name. + aBlock value: f file. + (f isDirectory and: [f isSymbolicLink not]) + ifTrue: [f do: aBlock]]] + ] + + namesDo: aBlock prefixLength: anInteger [ + "Same as the wrapped #namesDo:, but navigates the entire directory + tree recursively. Since the objects created by #at: also contain the + path to the receiver, anInteger is used to trim it." + + + self file namesDo: + [:name | + | f | + (#('.' '..') includes: name) ifFalse: [ + f := self at: name. + aBlock value: (f asString copyFrom: anInteger). + (f isDirectory and: [f isSymbolicLink not]) + ifTrue: [f + namesDo: aBlock + prefixLength: anInteger ]]] + ] + + namesDo: aBlock [ + "Same as the wrapped #namesDo:, but navigates the entire directory + tree recursively." + + + | n base | + aBlock value: '.'. + base := self asString. + n := base last = Directory pathSeparator + ifTrue: [ base size + 1 ] + ifFalse: [ base size + 2 ]. + self namesDo: aBlock prefixLength: n + ] + + remove [ + "Removes the entire directory tree recursively." + + + self isDirectory ifTrue: [ + self file namesDo: + [:name | + | f | + f := self at: name. + f isDirectory + ifTrue: + [((#('.' '..') includes: name) or: [f isSymbolicLink]) + ifFalse: [f all remove]] + ifFalse: [f remove]]]. + super remove + ] + + isFileSystemPath [ + "Answer whether the receiver corresponds to a real filesystem path." + + + ^self file isFileSystemPath + ] + + lastAccessTime: accessDateTime lastModifyTime: modifyDateTime [ + "Update the timestamps of all files in the tree to be + accessDateTime and modifyDateTime." + + + self isDirectory ifFalse: [ + ^super lastAccessTime: accessDateTime lastModifyTime: modifyDateTime ]. + self do: [ :each | + each lastAccessTime: accessDateTime lastModifyTime: modifyDateTime ] + ] + + owner: ownerString group: groupString [ + "Set the owner and group for all files and directories in the tree." + + + self isDirectory ifFalse: [ + ^super owner: ownerString group: groupString ]. + "These special calls cache the uid and gid to avoid repeated lookups." + [ + File setOwnerFor: nil owner: ownerString group: groupString. + self do: [ :each | each owner: ownerString group: groupString ] + ] ensure: [ File setOwnerFor: nil owner: nil group: nil ] + ] + + mode: anInteger [ + "Set the mode to be anInteger for all files in the tree. Directory + modes are left unchanged." + + + self isDirectory ifFalse: [ ^super mode: anInteger ]. + + self do: [ :each | each isDirectory ifFalse: [ each mode: anInteger ] ] + ] + + fileMode: fMode directoryMode: dMode [ + "Set the mode to be fMode for all files in the tree, and dMode for + all directories in the tree." + + + self isDirectory ifFalse: [ ^super mode: fMode ]. + + super mode: dMode. + self isDirectory ifTrue: [ + self do: [ :each | + each mode: (each isDirectory + ifTrue: [ dMode ] + ifFalse: [ fMode ]) ] ] + ] +] + +] diff --git a/kernel/file/vfs/StoredZipMember.st b/kernel/file/vfs/StoredZipMember.st new file mode 100644 index 00000000..4e5ee7b3 --- /dev/null +++ b/kernel/file/vfs/StoredZipMember.st @@ -0,0 +1,73 @@ +"====================================================================== +| +| Virtual File System (new classes) +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2007, 2008 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + +Namespace current: VFS [ + +TmpFileArchiveMember subclass: StoredZipMember [ + | offset | + + + + + offset [ + + ^offset + ] + + offset: anInteger [ + + offset := anInteger + ] + + open: class mode: mode ifFail: aBlock [ + + | fileStream | + (mode = FileStream read or: [ self extracted ]) + ifFalse: [^super open: class mode: mode ifFail: aBlock]. + + fileStream := self archive + open: class + mode: mode + ifFail: [^aBlock value]. + fileStream skip: self offset + 26. + fileStream skip: fileStream nextUshort + fileStream nextUshort. + fileStream setFile: self. + ^LimitedStream + on: fileStream + from: fileStream position + to: fileStream position + self size - 1 + ] +] + +] + diff --git a/kernel/file/vfs/TmpFileArchiveMember.st b/kernel/file/vfs/TmpFileArchiveMember.st new file mode 100644 index 00000000..8f50133d --- /dev/null +++ b/kernel/file/vfs/TmpFileArchiveMember.st @@ -0,0 +1,84 @@ +"====================================================================== +| +| Virtual File System layer definitions +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2002, 2005, 2007, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Namespace current: VFS [ + +ArchiveMember subclass: TmpFileArchiveMember [ + | file | + + + + + release [ + "Release the resources used by the receiver that don't survive when + reloading a snapshot." + + "Remove the file that was temporarily holding the file contents" + + + self extracted ifTrue: [ file remove. file := nil ]. + super release + ] + + open: class mode: mode ifFail: aBlock [ + "Open the receiver in the given mode (as answered by FileStream's + class constant methods)" + + + | fileStream | + self file isNil ifTrue: [^aBlock value]. + fileStream := file open: class mode: mode ifFail: [^aBlock value]. + mode == FileStream read ifFalse: [fileStream addDependent: self]. + fileStream setFile: self. + ^fileStream + ] + + extracted [ + "Answer whether the file has already been extracted to disk." + ^file notNil + ] + + file [ + "Answer the real file name which holds the file contents, + or nil if it does not apply." + + + file isNil ifFalse: [^file]. + self exists ifFalse: [^nil]. + file := self archive extractMember: self. + ^file + ] +] + +] + diff --git a/kernel/file/vfs/ZipFile.st b/kernel/file/vfs/ZipFile.st new file mode 100644 index 00000000..4291340e --- /dev/null +++ b/kernel/file/vfs/ZipFile.st @@ -0,0 +1,157 @@ +"====================================================================== +| +| Virtual File System (new classes) +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2007, 2008 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + +Namespace current: VFS [ + +ArchiveFile subclass: ZipFile [ + + + + + createDirectory: dirName [ + "Create a subdirectory of the receiver, naming it dirName." + + + self notYetImplemented + ] + + member: anArchiveMember mode: bits [ + "Set the permission bits for the file in anArchiveMember." + + + self notYetImplemented + ] + + extractMember: anArchiveMember into: temp [ + "Extract the contents of anArchiveMember into a file + that resides on disk, and answer the name of the file." + + + Smalltalk + system: 'unzip -p %1 %2 > %3' + withArguments: {self file name. + anArchiveMember name. + temp name} + ] + + removeMember: anArchiveMember [ + "Remove the member represented by anArchiveMember." + + + Smalltalk + system: 'zip -d %1 %2' + withArguments: {self file name. + anArchiveMember name} + ] + + updateMember: anArchiveMember [ + "Update the member represented by anArchiveMember by + copying the file into which it was extracted back to the + archive." + + + self notYetImplemented + ] + + centralDirectoryRangeIn: f [ + + | r beginCD size comLen buf ofsCD | + size := f size. + r := 21. + + "Great idea, that of putting a variable-length item at the end. Luckily, + we can make a sanity check of the data and find the correct spot of the + central directory's final record." + size - 22 to: size - 65535 - 22 + by: -257 + do: + [:pos | + buf := (f copyFrom: pos to: pos + r) asByteArray. + beginCD := buf indexOfSubCollection: #[80 75 5 6] ifAbsent: [0]. + beginCD = 0 + ifFalse: + [comLen := (buf at: beginCD + 21) * 256 + (buf at: beginCD + 20). + pos + beginCD + 21 + comLen = size + ifTrue: + [ofsCD := (buf at: beginCD + 19) * 16777216 + + ((buf at: beginCD + 18) * 65536) + + ((buf at: beginCD + 17) * 256) + + (buf at: beginCD + 16). + ^ofsCD to: pos + beginCD - 2]]. + r := 278]. + self error: 'invalid data in ZIP file' + ] + + fileData [ + "Extract the directory listing from the archive" + + + ^Generator on: + [:gen | + | f cd cdEnd data path date method dataSize fileSize fnsize + extra comment attr ofs | + f := self readStream. + cd := self centralDirectoryRangeIn: f. + f position: cd first. + cdEnd := cd last. + + date := DateTime now. + [f position <= cdEnd ] whileTrue: + [f skip: 10. + method := f nextUshort. + data := method = 0 ifTrue: [Array new: 5] ifFalse: [Array new: 4]. + data at: 3 put: date. + f skip: 12. + data at: 2 put: f nextUlong. + fnsize := f nextUshort. + extra := f nextUshort. + comment := f nextUshort. + f skip: 4. + attr := f nextUlong. + ofs := f nextUlong. + data at: 1 put: (f next: fnsize). + f skip: extra + comment. + data at: 4 put: (attr bitAnd: 16) = 16. + method = 0 + ifTrue: + [data at: 5 + put: ((StoredZipMember new) + name: (data at: 1); + archive: self; + offset: ofs; + yourself)]. + gen yield: data]. + f close] + ] +] + +] diff --git a/kernel/package/DisabledPackage.st b/kernel/package/DisabledPackage.st new file mode 100644 index 00000000..78f3f678 --- /dev/null +++ b/kernel/package/DisabledPackage.st @@ -0,0 +1,59 @@ +"====================================================================== +| +| PackageLoader Method Definitions +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1999,2000,2001,2002,2003,2004,2005,2007,2008,2009 +| Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Namespace current: Kernel [ + +Package subclass: DisabledPackage [ + + + + + printOn: aStream indent: indent [ + + self + printOn: aStream + tag: 'disabled-package' + indent: indent + ] + + isDisabled [ + + ^true + ] +] + +] + diff --git a/kernel/package/Package.st b/kernel/package/Package.st new file mode 100644 index 00000000..8a89bb64 --- /dev/null +++ b/kernel/package/Package.st @@ -0,0 +1,554 @@ +"====================================================================== +| +| PackageLoader Method Definitions +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1999,2000,2001,2002,2003,2004,2005,2007,2008,2009 +| Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + +Kernel.PackageInfo subclass: Package [ + | features prerequisites builtFiles files fileIns relativeDirectory + baseDirectories libraries modules callouts url namespace sunitScripts + startScript stopScript test version path | + + + + + Package class [ | Tags | ] + + Package class >> tags [ + + + ^ Tags ifNil: [ Tags := Dictionary from: { + 'file' -> #addFile:. + 'filein' -> #addFileIn:. + 'prereq' -> #addPrerequisite:. + 'provides' -> #addFeature:. + 'module' -> #addModule:. + 'directory' -> #relativeDirectory:. + 'name' -> #name:. + 'url' -> #url:. + 'version' -> #parseVersion:. + 'namespace' -> #namespace:. + 'library' -> #addLibrary:. + 'built-file' -> #addBuiltFile:. + 'sunit' -> #addSunitScript:. + 'start' -> #startScript:. + 'stop' -> #stopScript:. + 'callout' -> #addCallout: } ] + ] + + Package class >> parse: file [ + "Answer a package from the XML description in file." + + | ch tag | + + [(file upTo: $<) trimSeparators isEmpty + ifFalse: [self error: 'unexpected cdata']. + file atEnd ifTrue: [self error: 'expected start tag']. + ch := file peek. + ch == $! ifTrue: [file skipTo: $>]. + ch == $/ ifTrue: [self error: 'unexpected end tag ']. + ch isAlphaNumeric + ifTrue: + [tag := file upTo: $>. + tag = 'package' ifTrue: [^Package new parse: file tag: tag]. + tag = 'disabled-package' + ifTrue: [^DisabledPackage new parse: file tag: tag]]] + repeat + ] + + test [ + "Answer the test sub-package." + + + ^test + ] + + test: aPackage [ + "Set the test sub-package to be aPackage." + + + aPackage test isNil + ifFalse: [self error: 'test packages must not be nested']. + aPackage name isNil + ifFalse: [self error: 'test package must not have names']. + (aPackage prerequisites) + add: 'SUnit'; + add: self name. + aPackage owner: self. + test := aPackage + ] + + startScript [ + "Answer the start script for the package." + + + ^startScript + ] + + startScript: aString [ + "Set the start script for the package to aString." + + + startScript := aString + ] + + stopScript [ + "Answer the start script for the package." + + + ^stopScript + ] + + stopScript: aString [ + "Set the stop script for the package to aString." + + + stopScript := aString + ] + + url [ + "Answer the URL at which the package repository can be found." + + + ^url + ] + + url: aString [ + "Set to aString the URL at which the package repository can be found." + + + url := aString + ] + + namespace [ + "Answer the namespace in which the package is loaded." + + + ^namespace + ] + + namespace: aString [ + "Set to aString the namespace in which the package is loaded." + + + namespace := aString + ] + + addFeature: aString [ + + + self path isEmpty ifFalse: [self error: 'unexpected inside tag']. + self features add: aString + ] + + features [ + "Answer a (modifiable) Set of features provided by the package." + + + features isNil ifTrue: [features := Set new]. + ^features + ] + + addPrerequisite: aString [ + + + self path isEmpty ifFalse: [self error: 'unexpected inside tag']. + self prerequisites add: aString + ] + + prerequisites [ + "Answer a (modifiable) Set of prerequisites." + + + prerequisites isNil ifTrue: [prerequisites := Set new]. + ^prerequisites + ] + + addBuiltFile: aString [ + + + self builtFiles add: self path, aString + ] + + builtFiles [ + "Answer a (modifiable) OrderedCollection of files that are part of + the package but are not distributed." + + builtFiles isNil ifTrue: [builtFiles := OrderedCollection new]. + ^builtFiles + ] + + addFile: aString [ + + + files isNil ifTrue: [files := OrderedCollection new]. + files add: self path, aString + ] + + files [ + "Answer a (modifiable) OrderedCollection of files that are part of + the package." + + | f | + f := self fileIns copy. + f removeAll: self builtFiles ifAbsent: []. + files isNil ifFalse: [ + f removeAll: files ifAbsent: []. + f addAll: files ]. + ^f + ] + + addFileIn: aString [ + + + self fileIns add: self path, aString + ] + + fileIns [ + "Answer a (modifiable) OrderedCollections of files that are to be + filed-in to load the package. This is usually a subset of + `files' and `builtFiles'." + + + fileIns isNil ifTrue: [fileIns := OrderedCollection new]. + ^fileIns + ] + + addLibrary: aString [ + + + self path isEmpty ifFalse: [self error: 'unexpected inside tag']. + self libraries add: aString + ] + + libraries [ + "Answer a (modifiable) Set of shared library names + that are required to load the package." + + libraries isNil ifTrue: [libraries := Set new]. + ^libraries + ] + + addModule: aString [ + + + self path isEmpty ifFalse: [self error: 'unexpected inside tag']. + self modules add: aString + ] + + modules [ + "Answer a (modifiable) Set of modules that are + required to load the package." + + modules isNil ifTrue: [modules := Set new]. + ^modules + ] + + addSunitScript: aString [ + + + self path isEmpty ifFalse: [self error: 'unexpected inside tag']. + self sunitScripts add: aString + ] + + sunitScripts [ + "Answer a (modifiable) OrderedCollection of SUnit scripts that + compose the package's test suite." + + sunitScripts isNil ifTrue: [sunitScripts := OrderedCollection new]. + ^sunitScripts + ] + + addCallout: aString [ + + + self path isEmpty ifFalse: [self error: 'unexpected inside tag']. + self callouts add: aString + ] + + callouts [ + "Answer a (modifiable) Set of call-outs that are required to load + the package. Their presence is checked after the libraries and + modules are loaded so that you can do a kind of versioning." + + + callouts isNil ifTrue: [callouts := Set new]. + ^callouts + ] + + baseDirectories [ + + ^baseDirectories + ] + + baseDirectories: aCollection [ + "Check if it's possible to resolve the names in the package according to + the base directories in baseDirectories, which depend on where + the packages.xml is found: the three possible places are 1) the + system kernel directory's parent directory, 2) the local kernel + directory's parent directory, 3) the local image directory (in + order of decreasing priority). + + For a packages.xml found in the system kernel directory's parent + directory, all three directories are searched. For a packages.xml + found in the local kernel directory's parent directory, only + directories 2 and 3 are searched. For a packages.xml directory in + the local image directory, instead, only directory 3 is searched." + + + baseDirectories := aCollection. + self fullPathsOf: self files. + "self fullPathsOf: self fileIns." + "self fullPathsOf: self builtFiles." + self directory. + self test notNil ifTrue: [self test baseDirectories: aCollection] + ] + + fullPathOf: fileName [ + "Try appending 'self directory' and fileName to each of the directory + in baseDirectories, and return the path to the first tried filename that + exists. Raise a PackageNotAvailable exception if no directory is + found that contains the file." + + + baseDirectories do: + [:baseDir || dir file | + dir := baseDir. + self relativeDirectory isNil + ifFalse: [dir := dir / self relativeDirectory]. + file := dir / fileName. + file exists ifTrue: [^file]]. + + SystemExceptions.PackageNotAvailable signal: self name + reason: (fileName printString , ' does not exist in ' , baseDirectories printString) + ] + + directory [ + "Answer the base directory from which to load the package." + + + self relativeDirectory isNil ifTrue: [^nil]. + self baseDirectories do: + [:baseDir || dir | + dir := baseDir / relativeDirectory. + dir exists ifTrue: [^dir]]. + + SystemExceptions.PackageNotAvailable signal: self name + ] + + relativeDirectory [ + "Answer the directory, relative to the packages file, from which to load + the package." + + + ^relativeDirectory + ] + + relativeDirectory: dir [ + "Set the directory, relative to the packages file, from which to load + the package, to dir." + + + relativeDirectory := dir + ] + + version [ + + + ^ version + ] + + version: aVersion [ + + + version := aVersion + ] + + parseVersion: aString [ + + + self version: (Version fromString: aString) + ] + + primFileIn [ + "Private - File in the given package without paying attention at + dependencies and C callout availability" + + | dir namespace | + self loaded ifTrue: [^self]. + dir := Directory working. + namespace := Namespace current. + + [| loadedFiles | + Namespace current: self createNamespace. + self directory isNil ifFalse: [Directory working: self directory]. + self libraries do: [:each | DLD addLibrary: each]. + self modules do: [:each | DLD addModule: each]. + PackageLoader ignoreCallouts + ifFalse: + [self callouts do: + [:func | + (CFunctionDescriptor isFunction: func) + ifFalse: [^self error: 'C callout not available: ' , func]]]. + loadedFiles := self fullPathsOf: self fileIns. + loadedFiles do: [:each | each fileIn]. + self name isNil ifFalse: [Smalltalk addFeature: self name]. + self features do: [:each | Smalltalk addFeature: each]] + ensure: + [Directory working: dir. + Namespace current: namespace] + ] + + path [ + + ^ path ifNil: [ path := '' ] + ] + + path: aString [ + + path := aString + ] + + isInPath [ + + ^ self path ~= '' + ] + + checkTagIfInPath: aString [ + + self isInPath ifFalse: [ ^ self ]. + (aString = 'file' or: [ aString = 'filein' or: [ aString = 'built-file' ] ]) ifFalse: [ self error: 'invalid tag in a dir tag ', aString ] + ] + + dir: file tag: aDictionary [ + | oldPath newPath | + newPath := aDictionary + at: 'name' + ifAbsent: [ self error: 'name attribute is not present in a dir tag' ]. + newPath isEmpty + ifTrue: [ self error: 'name attribute is empty' ]. + + oldPath := self path. + newPath := oldPath, newPath. + (newPath notEmpty and: [newPath last isPathSeparator not]) + ifTrue: [ newPath := newPath, Directory pathSeparatorString]. + self path: newPath. + self parse: file tag: 'dir'. + self path: oldPath. + ] + + parseAttributes: aString [ + + | attribute args key value terminator ch | + attribute := ReadStream on: aString. + args := LookupTable new. + [ + attribute atEnd ifTrue: [^args]. + attribute peek isSeparator ifFalse: [ + self error: 'expected separator']. + [ + attribute next. + attribute atEnd ifTrue: [^args]. + attribute peek isSeparator ] whileTrue. + attribute peek isAlphaNumeric ifFalse: [ + self error: 'expected attribute']. + + key := String streamContents: [ :s | + [ + attribute atEnd ifTrue: [ + self error: 'expected attribute']. + ch := attribute next. ch = $= ] whileFalse: [ + ch isAlphaNumeric ifFalse: [ + self error: 'invalid attribute name']. + s nextPut: ch ] ]. + + terminator := attribute next. + (terminator = $' or: [terminator = $"]) ifFalse: [ + self error: 'expected single or double quote']. + + value := String streamContents: [ :s | + [ + attribute atEnd ifTrue: [ + self error: 'expected %1' % { terminator }]. + ch := attribute next. ch = terminator ] whileFalse: [ + s nextPut: ch ] ]. + args at: key put: value. + ] repeat + ] + + parse: file tag: openingTag [ + + | stack cdata ch tag testPackage words | + stack := OrderedCollection new. + stack addLast: openingTag. + + [ + [cdata := cdata isNil + ifTrue: [file upTo: $<] + ifFalse: [cdata , (file upTo: $<)]. + file atEnd] + whileFalse: + [ch := file peek. + ch == $! ifTrue: [file skipTo: $>]. + ch == $/ + ifTrue: + [tag := stack removeLast. + file next. + (file upTo: $>) = tag + ifFalse: [^self error: 'error in packages file: unmatched end tag ' , tag ]. + tag = openingTag ifTrue: [ ^ self ]. + self checkTagIfInPath: tag. + self perform: (self class tags at: tag ifAbsent: [ self error: 'invalid tag ', tag ]) with: cdata. + cdata := nil ]. + ch isAlphaNumeric + ifTrue: + [tag := file upTo: $>. + words := tag substrings. + words first = 'dir' ifTrue: [ + self + dir: file + tag: (self parseAttributes: (tag copyFrom: words first size + 1)) ] + ifFalse: [ + words first = 'test' + ifTrue: [self test: (TestPackage new parse: file tag: tag)] + ifFalse: [stack addLast: tag] ]. + cdata trimSeparators isEmpty + ifFalse: [^self error: 'unexpected character data']. + cdata := nil]]] + ensure: + [stack isEmpty + ifFalse: + [self error: 'error in packages file: unmatched start tags' + , stack asArray printString]] + ] +] + diff --git a/kernel/package/PackageContainer.st b/kernel/package/PackageContainer.st new file mode 100644 index 00000000..59cf15eb --- /dev/null +++ b/kernel/package/PackageContainer.st @@ -0,0 +1,153 @@ +"====================================================================== +| +| PackageLoader Method Definitions +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1999,2000,2001,2002,2003,2004,2005,2007,2008,2009 +| Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Namespace current: Kernel [ + +PackageGroup subclass: PackageContainer [ + | packages file | + + + + + file [ + + ^file + ] + + fileName [ + + ^self file name + ] + + file: aFile [ + + file := aFile + ] + + packages [ + + packages isNil ifTrue: [packages := LookupTable new]. + ^packages + ] + + packages: aDictionary [ + + packages := aDictionary + ] + + at: aString ifAbsent: aBlock [ + + ^self packages at: aString asString ifAbsent: aBlock + ] + + keys [ + + ^self packages keys + ] + + includesKey: aString [ + + ^self packages includesKey: aString + ] + + baseDirectoriesFor: aPackage [ + + self subclassResponsibility + ] + + refresh: loadDate [ + "Private - Process the XML source in the packages file, creating + Package objects along the way." + + + self subclassResponsibility + ] + + parse: file [ + + | open ch cdata tag package allPackages | + open := false. + allPackages := OrderedCollection new. + + [cdata := cdata isNil + ifTrue: [file upTo: $<] + ifFalse: [cdata , (file upTo: $<)]. + file atEnd] + whileFalse: + [cdata trimSeparators isEmpty + ifFalse: [^self error: 'unexpected character data']. + ch := file peek. + ch == $! ifTrue: [file skipTo: $>]. + ch == $/ + ifTrue: + [file next. + (tag := file upTo: $>) = 'packages' ifTrue: [^self]. + ^self error: 'unmatched end tag ' , tag]. + ch isAlphaNumeric + ifTrue: + [open + ifFalse: + [tag := file upTo: $>. + tag = 'package' + ifTrue: [package := Package new parse: file tag: 'package'] + ifFalse: + [tag = 'packages' ifFalse: [^self error: 'expected packages tag']. + open := true]] + ifTrue: + [file skip: -1. + package := Package parse: file]. + package notNil + ifTrue: + [package name isNil + ifTrue: [^self error: 'missing package name in ' , self fileName]. + + [self testPackageValidity: package. + self packages at: package name put: package. + allPackages add: package] + on: PackageSkip + do: [:ex | ex return]. + open ifFalse: [^allPackages]]. + package := nil]]. + ^allPackages + ] + + testPackageValidity: package [ + package baseDirectories: (self baseDirectoriesFor: package). + ] +] + +] + diff --git a/kernel/package/PackageDirectories.st b/kernel/package/PackageDirectories.st new file mode 100644 index 00000000..bd73f5f7 --- /dev/null +++ b/kernel/package/PackageDirectories.st @@ -0,0 +1,95 @@ +"====================================================================== +| +| PackageLoader Method Definitions +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1999,2000,2001,2002,2003,2004,2005,2007,2008,2009 +| Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Namespace current: Kernel [ + +PackageGroup subclass: PackageDirectories [ + | dirs | + + + + + PackageDirectories class >> new [ + + ^super new initialize + ] + + postCopy [ + + dirs := dirs copy + ] + + add: aDirectory [ + + ^dirs add: aDirectory + ] + + at: aString ifAbsent: aBlock [ + + dirs do: + [:each | + | package | + package := each at: aString ifAbsent: [nil]. + package isNil ifFalse: [^package]]. + ^aBlock value + ] + + keys [ + + | keys | + keys := Set new. + dirs do: [:each | keys addAll: each keys]. + ^keys + ] + + includesKey: aString [ + + ^dirs anySatisfy: [:each | each includesKey: aString] + ] + + refresh: aLoadDate [ + + dirs do: [:each | each refresh: aLoadDate] + ] + + initialize [ + + dirs := OrderedCollection new + ] +] + +] + diff --git a/kernel/package/PackageDirectory.st b/kernel/package/PackageDirectory.st new file mode 100644 index 00000000..15dd4f05 --- /dev/null +++ b/kernel/package/PackageDirectory.st @@ -0,0 +1,101 @@ +"====================================================================== +| +| PackageLoader Method Definitions +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1999,2000,2001,2002,2003,2004,2005,2007,2008,2009 +| Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + +Namespace current: Kernel [ + +PackageContainer subclass: PackageDirectory [ + | baseDirectories baseDirCache | + + + + PackageContainer class >> on: aFile baseDirectories: aBlock [ + + ^(super new) + file: aFile; + baseDirectories: aBlock + ] + + baseDirectoriesFor: aPacakge [ + + baseDirCache isNil ifTrue: [self refresh]. + ^baseDirCache + ] + + baseDirectories: aBlock [ + + baseDirectories := aBlock + ] + + refresh: loadDate [ + "Private - Process the XML source in the packages file, creating + Package objects along the way." + + | dir allDirs | + dir := self file parent. + allDirs := Smalltalk imageLocal + ifTrue: [{Directory image} , baseDirectories value] + ifFalse: [baseDirectories value]. + ((self file exists and: [self file lastModifyTime > loadDate]) or: + [(dir exists and: [dir lastModifyTime > loadDate]) + or: [allDirs ~= baseDirCache]]) + ifTrue: + [baseDirCache := allDirs. + self refreshPackageList. + self refreshStarList: dir] + ] + + refreshPackageList [ + + baseDirCache isEmpty ifTrue: [^self]. + self file exists ifFalse: [^self]. + self file withReadStreamDo: [ :fileStream | + [self parse: fileStream] + on: SystemExceptions.PackageNotAvailable + do: [:ex | ex resignalAs: PackageSkip new]]. + + self packages: (self packages reject: [:each | each isDisabled]) + ] + refreshStarList: dir [ + + dir exists ifFalse: [^self]. + dir filesMatching: '*.star' + do: + [:starFile | + | package | + package := Kernel.StarPackage file: starFile. + self packages at: package name put: package] + ] +] + +] + diff --git a/kernel/package/PackageGroup.st b/kernel/package/PackageGroup.st new file mode 100644 index 00000000..f8e20435 --- /dev/null +++ b/kernel/package/PackageGroup.st @@ -0,0 +1,157 @@ +"====================================================================== +| +| PackageLoader Method Definitions +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1999,2000,2001,2002,2003,2004,2005,2007,2008,2009 +| Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Namespace current: Kernel [ + +Object subclass: PackageGroup [ + + + + + printOn: aStream [ + "Print the XML source code for the information that the PackageLoader + holds on aStream." + + + aStream + nextPutAll: ''; + nl. + self do: + [:each | + aStream space: 2. + each printOn: aStream indent: 2. + aStream nl] + separatedBy: [aStream nl]. + aStream nextPutAll: '' + ] + + at: aString [ + + ^self at: aString + ifAbsent: [SystemExceptions.PackageNotAvailable signal: aString] + ] + + at: aString ifAbsent: aBlock [ + + self subclassResponsibility + ] + + do: aBlock [ + + self keys do: [:each | aBlock value: (self at: each)] + ] + + do: aBlock separatedBy: sepBlock [ + + self keys do: [:each | aBlock value: (self at: each)] separatedBy: sepBlock + ] + + keys [ + + self subclassResponsibility + ] + + includesKey: aString [ + + self subclassResponsibility + ] + + extractDependenciesFor: packagesList ifMissing: aBlock [ + "Answer an OrderedCollection containing all the packages which you + have to load to enable the packages in packagesList, in an appropriate + order. For example + + PackageLoader extractDependenciesFor: #('BloxTestSuite' 'Blox' 'Browser') + + on a newly built image will evaluate to an OrderedCollection containing + 'Kernel', 'Blox', 'BloxTestSuite' and 'Browser'. Note that + Blox has been moved before BloxTestSuite. + Pass an error message to aBlock if one or more packages need + prerequisites which are not available." + + + | toBeLoaded featuresFound dependencies allPrereq allFeatures | + featuresFound := Set withAll: Smalltalk.Features. + featuresFound := featuresFound collect: [:each | each asString]. + toBeLoaded := packagesList asOrderedCollection. + toBeLoaded := toBeLoaded collect: [:each | each asString]. + toBeLoaded removeAll: featuresFound ifAbsent: [:doesNotMatter | ]. + dependencies := packagesList collect: [:each | each asString]. + + [allPrereq := Set new. + allFeatures := Set new. + dependencies do: + [:name | + | package | + (featuresFound includes: name) + ifFalse: + [package := self at: name ifAbsent: [^aBlock value: name]. + allPrereq addAll: package prerequisites. + allFeatures addAll: package features]]. + + "I don't think there will never be lots of packages in newDep (say + more than 5), so I think it is acceptable to remove duplicates + this naive way. Note that we remove duplicates from toBeLoaded + so that prerequisites are always loaded *before*." + toBeLoaded removeAll: allPrereq ifAbsent: [:doesNotMatter | ]. + toBeLoaded removeAll: allFeatures ifAbsent: [:doesNotMatter | ]. + allPrereq removeAll: allFeatures ifAbsent: [:doesNotMatter | ]. + featuresFound addAll: allFeatures. + toBeLoaded addAllFirst: allPrereq. + + "Proceed recursively with the prerequisites for allPrereq" + dependencies := allPrereq. + dependencies notEmpty] + whileTrue. + ^toBeLoaded + ] + + refresh [ + + self refresh: ##(Date + newDay: 1 + month: #jan + year: 1900) + ] + + refresh: aLoadDate [ + + self subclassResponsibility + ] +] + +] + diff --git a/kernel/package/PackageInfo.st b/kernel/package/PackageInfo.st new file mode 100644 index 00000000..e3bd0f27 --- /dev/null +++ b/kernel/package/PackageInfo.st @@ -0,0 +1,494 @@ +"====================================================================== +| +| PackageLoader Method Definitions +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1999,2000,2001,2002,2003,2004,2005,2007,2008,2009 +| Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Namespace current: Kernel [ + +Object subclass: PackageInfo [ + | name | + + + + + createNamespace [ + "Create the path of namespaces indicated by our namespace field in + dot notation, and answer the final namespace" + + + | ns | + ns := Smalltalk. + self namespace isNil ifTrue: [^ns]. + (self namespace subStrings: $.) do: + [:each | + | key | + key := each asSymbol. + (ns includesKey: key) ifFalse: [ns addSubspace: key]. + ns := ns at: key]. + ^ns + ] + + fileIn [ + "File in the given package and its dependencies." + + + self name isNil + ifTrue: + ["Other packages cannot be dependent on this one." + + PackageLoader fileInPackages: self prerequisites. + self primFileIn] + ifFalse: [PackageLoader fileInPackage: self name] + ] + + fullPathsOf: aCollection [ + "Resolve the names in aCollection according to the base directories + in baseDirectories, and return the collection with the FilePaths. + Raise a PackageNotAvailable exception if no directory was found for one + or more files in aCollection." + + + ^aCollection collect: + [:fileName | self fullPathOf: fileName] + ] + + / fileName [ + "Resolve the file name according to the base directories in + baseDirectories, and return a FilePath for the full filename. + Raise a PackageNotAvailable exception if no directory was found + for fileName." + + + ^self fullPathOf: fileName + ] + + fullPathOf: fileName [ + + self subclassResponsibility + ] + + isDisabled [ + + ^false + ] + + printXmlOn: aStream collection: aCollection tag: aString indent: indent [ + "Private - Print aCollection on aStream as a sequence of aString + tags." + + + aCollection do: + [:each | + aStream + nextPutAll: ' <'; + nextPutAll: aString; + nextPut: $>; + nextPutAll: each; + nextPutAll: '; + nl; + space: indent] + ] + + printOn: aStream [ + + self printOn: aStream indent: 0 + ] + + printOn: aStream indent: indent [ + + self + printOn: aStream + tag: 'package' + indent: indent + ] + + printOn: aStream tag: tag indent: indent [ + "Print a representation of the receiver on aStream (it happens + to be XML." + + + aStream + nextPut: $<; + nextPutAll: tag; + nextPut: $>; + nl; + space: indent. + self name isNil + ifFalse: + [aStream + nextPutAll: ' '; + nextPutAll: self name; + nextPutAll: ''; + nl; + space: indent]. + self url isNil + ifFalse: + [aStream + nextPutAll: ' '; + nextPutAll: self url; + nextPutAll: ''; + nl; + space: indent]. + self namespace isNil + ifFalse: + [aStream + nextPutAll: ' '; + nextPutAll: self namespace; + nextPutAll: ''; + nl; + space: indent]. + self test isNil + ifFalse: + [aStream space: 2. + self test + printOn: aStream + tag: 'test' + indent: indent + 2. + aStream + nl; + space: indent]. + self + printXmlOn: aStream + collection: self features asSortedCollection + tag: 'provides' + indent: indent. + self + printXmlOn: aStream + collection: self prerequisites asSortedCollection + tag: 'prereq' + indent: indent. + self + printXmlOn: aStream + collection: self sunitScripts + tag: 'sunit' + indent: indent. + self + printXmlOn: aStream + collection: self callouts asSortedCollection + tag: 'callout' + indent: indent. + self + printXmlOn: aStream + collection: self libraries asSortedCollection + tag: 'library' + indent: indent. + self + printXmlOn: aStream + collection: self modules asSortedCollection + tag: 'module' + indent: indent. + self relativeDirectory isNil + ifFalse: + [aStream + nextPutAll: ' '; + nextPutAll: self relativeDirectory; + nextPutAll: ''; + nl; + space: indent]. + self files size + self builtFiles size > 1 + ifTrue: + [aStream + nl; + space: indent]. + self + printXmlOn: aStream + collection: self fileIns + tag: 'filein' + indent: indent. + self + printXmlOn: aStream + collection: (self files copy removeAll: self fileIns ifAbsent: []; yourself) + tag: 'file' + indent: indent. + self + printXmlOn: aStream + collection: self builtFiles + tag: 'built-file' + indent: indent. + self startScript isNil + ifFalse: + [aStream + nextPutAll: ' '; + nextPutAll: self startScript; + nextPutAll: ''; + nl; + space: indent]. + self stopScript isNil + ifFalse: + [aStream + nextPutAll: ' '; + nextPutAll: self stopScript; + nextPutAll: ''; + nl; + space: indent]. + aStream + nextPutAll: ' + ] + + name [ + "Answer the name of the package." + + + ^name + ] + + name: aString [ + "Set to aString the name of the package." + + + name := aString + ] + + url [ + "Answer the URL at which the package repository can be found." + + + self subclassResponsibility + ] + + namespace [ + "Answer the namespace in which the package is loaded." + + + self subclassResponsibility + ] + + features [ + "Answer a (modifiable) Set of features provided by the package." + + + self subclassResponsibility + ] + + prerequisites [ + "Answer a (modifiable) Set of prerequisites." + + + self subclassResponsibility + ] + + builtFiles [ + "Answer a (modifiable) OrderedCollection of files that are part of + the package but are not distributed." + + + self subclassResponsibility + ] + + files [ + "Answer a (modifiable) OrderedCollection of files that are part of + the package." + + + self subclassResponsibility + ] + + allFiles [ + "Answer an OrderedCollection of all the files, both built and + distributed, that are part of the package." + + + | result | + result := self files , self builtFiles. + self test isNil + ifFalse: + [result := result , (self test allFiles: self test relativeDirectory)]. + ^result + ] + + allDistFiles [ + "Answer an OrderedCollection of all the files, both built and + distributed, that are part of the package." + + + | result | + result := self files. + self test isNil + ifFalse: + [result := result , (self test allDistFiles: self test relativeDirectory)]. + ^result + ] + + fileIns [ + "Answer a (modifiable) OrderedCollections of files that are to be + filed-in to load the package. This is usually a subset of + `files' and `builtFiles'." + + + self subclassResponsibility + ] + + libraries [ + "Answer a (modifiable) Set of shared library names + that are required to load the package." + + + self subclassResponsibility + ] + + modules [ + "Answer a (modifiable) Set of modules that are + required to load the package." + + + self subclassResponsibility + ] + + sunitScript [ + "Answer a String containing a SUnit script that + describes the package's test suite." + + + self sunitScripts isEmpty ifTrue: [^'']. + ^self sunitScripts fold: [:a :b | a , ' ' , b] + ] + + sunitScripts [ + "Answer a (modifiable) OrderedCollection of SUnit scripts that + compose the package's test suite." + + + self subclassResponsibility + ] + + startScript [ + "Answer the start script for the package." + + + self subclassResponsibility + ] + + stopScript [ + "Answer the stop script for the package." + + + self subclassResponsibility + ] + + callouts [ + "Answer a (modifiable) Set of call-outs that are required to load + the package. Their presence is checked after the libraries and + modules are loaded so that you can do a kind of versioning." + + + self subclassResponsibility + ] + + relativeDirectory [ + "Answer the directory from which to load the package, relative to the package + file." + + + self subclassResponsibility + ] + + directory [ + "Answer the base directory from which to load the package." + + + self subclassResponsibility + ] + + loaded [ + + ^self name notNil and: [Smalltalk hasFeatures: self name] + ] + + start [ + "File in the receiver and evaluate its start script, passing nil + as the argument." + + + self fileIn. + self startScript isNil ifTrue: [ ^self ]. + ('Eval [', + (self startScript % {'nil'}), + ']') readStream fileIn. + ] + + start: anObject [ + "File in the receiver and evaluate its start script, passing anObject's + displayString as the argument." + + + self fileIn. + self startScript isNil ifTrue: [ ^self ]. + ('Eval [', + (self startScript % { anObject displayString storeString }), + ']') readStream fileIn. + ] + + stop [ + "Evaluate the stop script of the receiver, passing nil as the + argument." + + + self loaded ifFalse: [ ^self ]. + self stopScript isNil ifTrue: [ ^self ]. + ('Eval [', + (self stopScript % {'nil'}), + ']') readStream fileIn. + ] + + stop: anObject [ + "Evaluate the stop script of the receiver, passing anObject's + displayString as the argument." + + + self loaded ifFalse: [ ^self ]. + self stopScript isNil ifTrue: [ ^self ]. + ('Eval [', + (self stopScript % { anObject displayString storeString }), + ']') readStream fileIn. + ] + + allFiles: prefix [ + + prefix isNil ifTrue: [^self allFiles]. + ^self allFiles collect: [:each | File append: each to: prefix] + ] + + allDistFiles: prefix [ + + prefix isNil ifTrue: [^self allDistFiles]. + ^self allDistFiles collect: [:each | File append: each to: prefix] + ] +] + +] + diff --git a/kernel/package/PackageLoader.st b/kernel/package/PackageLoader.st new file mode 100644 index 00000000..ebe05fc4 --- /dev/null +++ b/kernel/package/PackageLoader.st @@ -0,0 +1,277 @@ +"====================================================================== +| +| PackageLoader Method Definitions +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1999,2000,2001,2002,2003,2004,2005,2007,2008,2009 +| Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + +Object subclass: PackageLoader [ + + + + + PackageLoader class [ + | root loadDate ignoreCallouts | + + ] + + PackageLoader class >> packageAt: package ifAbsent: aBlock [ + "Answer a Package object for the given package" + + + self refresh. + ^root at: package asString ifAbsent: aBlock + ] + + PackageLoader class >> packageAt: package [ + "Answer a Package object for the given package" + + + self refresh. + ^root at: package asString + ] + + PackageLoader class >> directoryFor: package [ + "Answer a Directory object to the given package's files" + + + ^(self packageAt: package) directory + ] + + PackageLoader class >> builtFilesFor: package [ + "Answer a Set of Strings containing the filenames of the given package's + machine-generated files (relative to the directory answered by + #directoryFor:)" + + + ^(self packageAt: package) builtFiles + ] + + PackageLoader class >> filesFor: package [ + "Answer a Set of Strings containing the filenames of the given package's + files (relative to the directory answered by #directoryFor:)" + + + ^(self packageAt: package) files + ] + + PackageLoader class >> fileInsFor: package [ + "Answer a Set of Strings containing the filenames of the given package's + file-ins (relative to the directory answered by #directoryFor:)" + + + ^(self packageAt: package) fileIns + ] + + PackageLoader class >> sunitScriptFor: package [ + "Answer a Strings containing a SUnit script that describes the package's + test suite." + + + ^(self packageAt: package) sunitScript + ] + + PackageLoader class >> calloutsFor: package [ + "Answer a Set of Strings containing the filenames of the given package's + required callouts (relative to the directory answered by #directoryFor:)" + + + ^(self packageAt: package) callouts + ] + + PackageLoader class >> librariesFor: package [ + "Answer a Set of Strings containing the filenames of the given package's + libraries (relative to the directory answered by #directoryFor:)" + + + ^(self packageAt: package) libraries + ] + + PackageLoader class >> modulesFor: package [ + "Answer a Set of Strings containing the filenames of the given package's + modules (relative to the directory answered by #directoryFor:)" + + + ^(self packageAt: package) modules + ] + + PackageLoader class >> featuresFor: package [ + "Answer a Set of Strings containing the features provided by the given + package." + + + ^(self packageAt: package) features + ] + + PackageLoader class >> prerequisitesFor: package [ + "Answer a Set of Strings containing the prerequisites for the given package" + + + ^(self packageAt: package) prerequisites + ] + + PackageLoader class >> ignoreCallouts [ + "Answer whether unavailable C callouts must generate errors or not." + + + ignoreCallouts isNil ifTrue: [ignoreCallouts := false]. + ^ignoreCallouts + ] + + PackageLoader class >> ignoreCallouts: aBoolean [ + "Set whether unavailable C callouts must generate errors or not." + + + ignoreCallouts := aBoolean + ] + + PackageLoader class >> flush [ + "Set to reload the `packages.xml' file the next time it is needed." + + + root := nil. + loadDate := ##(Date + newDay: 1 + month: #jan + year: 1900) + ] + + PackageLoader class >> refresh [ + "Reload the `packages.xml' file in the image and kernel directories. + The three possible places are 1) the kernel directory's parent + directory, 2) the `.st' subdirectory of the user's home directory, 3) the + local image directory (in order of decreasing priority). + + For a packages.xml found in the kernel directory's parent + directory, all three directories are searched. For a packages.xml + found in the `.st' subdirectory, only directories 2 and 3 are + searched. For a packages.xml directory in the local image directory, + finally, only directory 3 is searched." + + + | state | + root isNil + ifTrue: + [self flush. + root := Kernel.PackageDirectories new. + root add: (Kernel.PackageDirectory on: self packageFile + baseDirectories: [ + {Directory userBase. + Directory kernel / '..'}]). + root add: (Kernel.PackageDirectory on: self sitePackageFile + baseDirectories: [ + {Directory userBase. + Directory kernel / '../site-packages'}]). + root add: (Kernel.PackageDirectory on: self userPackageFile + baseDirectories: [{Directory userBase}]). + root add: (Kernel.PackageDirectory on: self localPackageFile + baseDirectories: [#()])]. + root refresh: loadDate. + loadDate := Date dateAndTimeNow + ] + + PackageLoader class >> fileInPackage: package [ + "File in the given package into GNU Smalltalk." + + + self fileInPackages: {package} + ] + + PackageLoader class >> fileInPackages: packagesList [ + "File in all the packages in packagesList into GNU Smalltalk." + + + | toBeLoaded | + packagesList isEmpty ifTrue: [^self]. + self refresh. + toBeLoaded := root extractDependenciesFor: packagesList + ifMissing: [:name | SystemExceptions.PackageNotAvailable signal: name]. + toBeLoaded do: + [:each | + OutputVerbosity > 0 + ifTrue: + [Transcript + nextPutAll: 'Loading package ' , each; + nl]. + (self packageAt: each) primFileIn] + ] + + PackageLoader class >> canLoad: package [ + "Answer whether all the needed pre-requisites for package are available." + + + self extractDependenciesFor: {package} ifMissing: [:name | ^false]. + ^true + ] + + PackageLoader class >> isLoadable: feature [ + "Private - Answer whether the packages file includes an entry for `feature'" + + + self refresh. + ^root includesKey: feature asString + ] + + PackageLoader class >> packageFile [ + + ^Directory kernel / '../packages.xml' + ] + + PackageLoader class >> sitePackageFile [ + + ^Directory kernel / '../site-packages/packages.xml' + ] + + PackageLoader class >> userPackageFile [ + + ^Directory userBase / 'packages.xml' + ] + + PackageLoader class >> localPackageFile [ + + ^Directory image / 'packages.xml' + ] + + PackageLoader class >> rebuildPackageFile [ + "Recreate the XML file from the information that the PackageLoader + holds. This is a dangerous method, also because the PackageLoader + does not know about disabled packages." + + + | file | + self refresh. + Directory image / 'packages.xml' withWriteStreamDo: [ :file | + file nextPutAll: ''. + file nl; nl. + root printOn: file] + ] +] + diff --git a/kernel/package/PackageNotAvailable.st b/kernel/package/PackageNotAvailable.st new file mode 100644 index 00000000..0345ab11 --- /dev/null +++ b/kernel/package/PackageNotAvailable.st @@ -0,0 +1,64 @@ +"====================================================================== +| +| PackageLoader Method Definitions +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1999,2000,2001,2002,2003,2004,2005,2007,2008,2009 +| Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Namespace current: SystemExceptions [ + +NotFound subclass: PackageNotAvailable [ + + + + + PackageNotAvailable class >> signal: aString [ + "Signal an exception saying that the package named aString + can't be found." + ^super signalOn: aString what: 'package' + ] + + PackageNotAvailable class >> signal: package reason: reason [ + "Signal an exception saying that be package named package + can't be found because the reason named reason." + ^super signalOn: package reason: reason + ] + + isResumable [ + "Answer true. Package unavailability is resumable, because the + package files might just lie elsewhere." + + + ^true + ] +] + +] + diff --git a/kernel/package/PackageSkip.st b/kernel/package/PackageSkip.st new file mode 100644 index 00000000..52b82879 --- /dev/null +++ b/kernel/package/PackageSkip.st @@ -0,0 +1,44 @@ +"====================================================================== +| +| PackageLoader Method Definitions +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1999,2000,2001,2002,2003,2004,2005,2007,2008,2009 +| Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Namespace current: Kernel [ + +Notification subclass: PackageSkip [ + + + +] + +] + diff --git a/kernel/package/StarPackage.st b/kernel/package/StarPackage.st new file mode 100644 index 00000000..14343904 --- /dev/null +++ b/kernel/package/StarPackage.st @@ -0,0 +1,219 @@ +"====================================================================== +| +| PackageLoader Method Definitions +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1999,2000,2001,2002,2003,2004,2005,2007,2008,2009 +| Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Namespace current: Kernel [ + +PackageInfo subclass: StarPackage [ + | file loadedPackage | + + + + + StarPackage class >> file: file [ + + ^(self new) + file: file; + name: (File stripPathFrom: (File stripExtensionFrom: file name)); + yourself + ] + + fullPathOf: fileName [ + "Try appending 'self directory' and fileName to each of the directory + in baseDirectories, and return the path to the first tried filename that + exists. Raise a PackageNotAvailable exception if no directory is + found that contains the file." + + + ^self loadedPackage fullPathOf: fileName + ] + + test [ + "Answer the test subpackage for this package." + + + ^self loadedPackage test + ] + + url [ + "Answer the URL at which the package repository can be found." + + + ^self loadedPackage url + ] + + namespace [ + "Answer the namespace in which the package is loaded." + + + ^self loadedPackage namespace + ] + + features [ + "Answer a (modifiable) Set of features provided by the package." + + + ^self loadedPackage features + ] + + prerequisites [ + "Answer a (modifiable) Set of prerequisites." + + + ^self loadedPackage prerequisites + ] + + builtFiles [ + "Answer a (modifiable) OrderedCollection of files that are part of + the package but are not distributed." + + + ^self loadedPackage builtFiles + ] + + files [ + "Answer a (modifiable) OrderedCollection of files that are part of + the package." + + + ^self loadedPackage files + ] + + fileIns [ + "Answer a (modifiable) OrderedCollections of files that are to be + filed-in to load the package. This is usually a subset of + `files' and `builtFiles'." + + + ^self loadedPackage fileIns + ] + + libraries [ + "Answer a (modifiable) Set of shared library names + that are required to load the package." + + + ^self loadedPackage libraries + ] + + modules [ + "Answer a (modifiable) Set of modules that are + required to load the package." + + + ^self loadedPackage modules + ] + + startScript [ + "Answer the start script for the package." + + + ^self loadedPackage startScript + ] + + stopScript [ + "Answer the stop script for the package." + + + ^self loadedPackage stopScript + ] + + sunitScripts [ + "Answer a (modifiable) OrderedCollection of SUnit scripts that + compose the package's test suite." + + + ^self loadedPackage sunitScripts + ] + + callouts [ + "Answer a (modifiable) Set of call-outs that are required to load + the package. Their presence is checked after the libraries and + modules are loaded so that you can do a kind of versioning." + + + ^self loadedPackage callouts + ] + + relativeDirectory [ + + ^nil + ] + + directory [ + + ^(File name: self fileName) zip + ] + + file [ + + ^file + ] + + fileName [ + + ^self file name + ] + + file: aFile [ + + file := aFile + ] + + primFileIn [ + + self loadedPackage primFileIn + ] + + loadedPackage [ + + | file package | + loadedPackage isNil ifFalse: [^loadedPackage]. + package := self file zip / 'package.xml' + withReadStreamDo: [ :fileStream | Package parse: fileStream]. + package isNil + ifTrue: [^self error: 'invalid disabled-package tag inside a star file']. + package relativeDirectory: self relativeDirectory. + package baseDirectories: {self directory}. + package name isNil + ifTrue: [package name: self name] + ifFalse: + [package name = self name + ifFalse: [self error: 'invalid package name in package.xml']]. + loadedPackage := package. + ^loadedPackage + ] +] + +] + diff --git a/kernel/package/TestPackage.st b/kernel/package/TestPackage.st new file mode 100644 index 00000000..cb2d285b --- /dev/null +++ b/kernel/package/TestPackage.st @@ -0,0 +1,79 @@ +"====================================================================== +| +| PackageLoader Method Definitions +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1999,2000,2001,2002,2003,2004,2005,2007,2008,2009 +| Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + +Namespace current: Kernel [ + +Smalltalk.Package subclass: TestPackage [ + | owner | + + + + + owner: aPackage [ + "Set the Package I test." + + + owner := aPackage + ] + + url [ + "Answer the URL at which the package repository can be found." + + + ^super url ifNil: [owner url] + ] + + namespace [ + "Answer the namespace in which the package is loaded." + + + ^super namespace ifNil: [owner namespace] + ] + + baseDirectories [ + "Answer the directories in which package files are sought." + + + ^super baseDirectories ifNil: + [owner baseDirectories + collect: [:each | each / owner relativeDirectory]] + ] +] + +] + diff --git a/kernel/Regex.st b/kernel/regex/Extensions.st similarity index 64% rename from kernel/Regex.st rename to kernel/regex/Extensions.st index 91a4ab37..91c3f03b 100644 --- a/kernel/Regex.st +++ b/kernel/regex/Extensions.st @@ -31,457 +31,6 @@ ======================================================================" - -Object subclass: Regex [ - - - - - - Regex class >> fromString: aString [ - "Like `aString asRegex'." - - - - ] - - Regex class >> new [ - "Do not send this message." - - self error: 'please use #fromString: to create instances' - ] - - at: anIndex put: anObject [ - "Fail. Regex objects are read-only." - - - self shouldNotImplement - ] - - copy [ - "Answer the receiver; instances of Regex are identity objects because - their only purpose is to ease caching, and we obtain better caching - if we avoid copying Regex objects" - - - ^self - ] - - asRegex [ - "Answer the receiver, which *is* a Regex!" - - - ^self - ] - - asString [ - "Answer the receiver, converted back to a String" - - - ^(String new: self size) - replaceFrom: 1 - to: self size - with: self - startingAt: 1; - yourself - ] - - species [ - - ^String - ] - - displayString [ - "Answer a String representing the receiver. For most objects - this is simply its #printString, but for strings and characters, - superfluous dollars or extra pair of quotes are stripped." - - - | stream | - stream := WriteStream on: (String new: 0). - self displayOn: stream. - ^stream contents - ] - - displayOn: aStream [ - "Print a represention of the receiver on aStream. For most objects - this is simply its #printOn: representation, but for strings and - characters, superfluous dollars or extra pairs of quotes are stripped." - - - self printOn: aStream - ] - - printOn: aStream [ - "Print a represention of the receiver on aStream." - - - aStream nextPut: $/. - self asString do: - [:each | - each = $/ ifTrue: [ aStream nextPut: $\ ]. - aStream nextPut: each]. - aStream nextPut: $/ - ] -] - - - -Object subclass: RegexResults [ - - - - - matched [ - "Answer whether the regular expression was matched" - - - self subclassResponsibility - ] - - ifMatched: oneArgBlock ifNotMatched: zeroArgBlock [ - "If the regular expression was matched, evaluate oneArgBlock with the - receiver as the argument. If it was not, evaluate zeroArgBlock. - Answer the result of the block's evaluation." - - - self subclassResponsibility - ] - - ifNotMatched: zeroArgBlock ifMatched: oneArgBlock [ - "If the regular expression was matched, evaluate oneArgBlock with the - receiver as the argument. If it was not, evaluate zeroArgBlock. - Answer the result of the block's evaluation." - - - self subclassResponsibility - ] - - ifNotMatched: zeroArgBlock [ - "If the regular expression was matched, return the receiver. If it was - not, evaluate zeroArgBlock and return its result." - - - ^self ifNotMatched: zeroArgBlock ifMatched: [] - ] - - ifMatched: oneArgBlock [ - "If the regular expression was matched, pass the receiver to - oneArgBlock and return its result. Otherwise, return nil." - - - ^self ifNotMatched: [] ifMatched: oneArgBlock - ] - - size [ - "If the regular expression was matched, return the number - of subexpressions that were present in the regular expression." - - - self subclassResponsibility - ] - - asArray [ - "If the regular expression was matched, return an Array with - the subexpressions that were present in the regular expression." - - - ^1 to: self size collect: [ :each | self at: each ] - ] - - subject [ - "If the regular expression was matched, return the text - that was matched against it." - - - self subclassResponsibility - ] - - from [ - "If the regular expression was matched, return the index - of the first character in the successful match." - - - self subclassResponsibility - ] - - fromAt: anIndex [ - "If the regular expression was matched, return the index of the first - character of the anIndex-th subexpression in the successful match." - - - self subclassResponsibility - ] - - to [ - "If the regular expression was matched, return the index - of the last character in the successful match." - - - self subclassResponsibility - ] - - toAt: anIndex [ - "If the regular expression was matched, return the index of the last - character of the anIndex-th subexpression in the successful match." - - - self subclassResponsibility - ] - - match [ - "If the regular expression was matched, return the text of the - successful match." - - - self subclassResponsibility - ] - - matchInterval [ - "If the regular expression was matched, return an Interval for the - range of indices of the successful match." - - - self subclassResponsibility - ] - - at: anIndex [ - "If the regular expression was matched, return the text of the - anIndex-th subexpression in the successful match." - - - self subclassResponsibility - ] - - intervalAt: anIndex [ - "If the regular expression was matched, return an Interval for the range - of indices in the anIndex-th subexpression of the successful match." - - - self subclassResponsibility - ] -] - - - -Namespace current: Kernel [ - -RegexResults subclass: MatchingRegexResults [ - | subject from to registers match cache | - - - - - printOn: aStream [ - "Print a represention of the receiver on aStream." - - - | ch | - aStream - nextPutAll: self class name; - nextPut: $:; - print: self match. - ch := $(. - 1 to: self size - do: - [:each | - aStream - nextPut: ch; - print: (self at: each). - ch := $,]. - self size > 0 ifTrue: [aStream nextPut: $)] - ] - - matched [ - - ^true - ] - - ifMatched: oneArgBlock ifNotMatched: zeroArgBlock [ - - ^oneArgBlock cull: self - ] - - ifNotMatched: zeroArgBlock ifMatched: oneArgBlock [ - - ^oneArgBlock cull: self - ] - - size [ - - ^registers size - ] - - subject [ - - ^subject - ] - - from [ - - ^from - ] - - fromAt: anIndex [ - - | reg | - anIndex = 0 ifTrue: [^from]. - reg := registers at: anIndex. - ^reg isNil ifTrue: [nil] ifFalse: [reg first] - ] - - to [ - - ^to - ] - - toAt: anIndex [ - - | reg | - anIndex = 0 ifTrue: [^from]. - reg := registers at: anIndex. - ^reg isNil ifTrue: [nil] ifFalse: [reg last] - ] - - match [ - - match isNil ifTrue: [match := self subject copyFrom: from to: to]. - ^match - ] - - matchInterval [ - - ^from to: to - ] - - at: anIndex [ - - | reg text | - anIndex = 0 ifTrue: [^self match]. - cache isNil ifTrue: [cache := Array new: registers size]. - (cache at: anIndex) isNil - ifTrue: - [reg := registers at: anIndex. - text := reg isNil - ifTrue: [nil] - ifFalse: [self subject copyFrom: reg first to: reg last]. - cache at: anIndex put: text]. - ^cache at: anIndex - ] - - intervalAt: anIndex [ - - ^anIndex = 0 ifTrue: [from to: to] ifFalse: [registers at: anIndex] - ] -] - -] - - - -Namespace current: Kernel [ - -RegexResults subclass: FailedMatchRegexResults [ - - - - - FailedMatchRegexResults class [ - | uniqueInstance | - - ] - - FailedMatchRegexResults class >> uniqueInstance [ - - ^uniqueInstance isNil - ifTrue: [uniqueInstance := self new] - ifFalse: [uniqueInstance] - ] - - matched [ - - ^false - ] - - ifMatched: oneArgBlock ifNotMatched: zeroArgBlock [ - - ^zeroArgBlock cull: self - ] - - ifNotMatched: zeroArgBlock ifMatched: oneArgBlock [ - - ^zeroArgBlock cull: self - ] - - size [ - - self shouldNotImplement - ] - - subject [ - - self shouldNotImplement - ] - - from [ - - self shouldNotImplement - ] - - fromAt: anIndex [ - - self shouldNotImplement - ] - - to [ - - self shouldNotImplement - ] - - toAt: anIndex [ - - self shouldNotImplement - ] - - match [ - - self shouldNotImplement - ] - - matchInterval [ - - self shouldNotImplement - ] - - at: anIndex [ - - self shouldNotImplement - ] - - intervalAt: anIndex [ - - self shouldNotImplement - ] -] - -] - - String extend [ @@ -1089,9 +638,3 @@ String extend [ ] ] - - -Eval [ - Kernel.FailedMatchRegexResults initialize -] - diff --git a/kernel/regex/FailedMatchRegexResults.st b/kernel/regex/FailedMatchRegexResults.st new file mode 100644 index 00000000..6b6cb56a --- /dev/null +++ b/kernel/regex/FailedMatchRegexResults.st @@ -0,0 +1,120 @@ +"====================================================================== +| +| String manipulation and regular expression resolver +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2001, 2003, 2005, 2006, 2007, 2008, 2009 +| Free Software Foundation, Inc. +| Written by Dragomir Milevojevic, Paolo Bonzini, Mike Anderson. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LESSER. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Namespace current: Kernel [ + +RegexResults subclass: FailedMatchRegexResults [ + + + + + FailedMatchRegexResults class [ + | uniqueInstance | + + ] + + FailedMatchRegexResults class >> uniqueInstance [ + + ^uniqueInstance isNil + ifTrue: [uniqueInstance := self new] + ifFalse: [uniqueInstance] + ] + + matched [ + + ^false + ] + + ifMatched: oneArgBlock ifNotMatched: zeroArgBlock [ + + ^zeroArgBlock cull: self + ] + + ifNotMatched: zeroArgBlock ifMatched: oneArgBlock [ + + ^zeroArgBlock cull: self + ] + + size [ + + self shouldNotImplement + ] + + subject [ + + self shouldNotImplement + ] + + from [ + + self shouldNotImplement + ] + + fromAt: anIndex [ + + self shouldNotImplement + ] + + to [ + + self shouldNotImplement + ] + + toAt: anIndex [ + + self shouldNotImplement + ] + + match [ + + self shouldNotImplement + ] + + matchInterval [ + + self shouldNotImplement + ] + + at: anIndex [ + + self shouldNotImplement + ] + + intervalAt: anIndex [ + + self shouldNotImplement + ] +] + +] diff --git a/kernel/regex/Initialization.st b/kernel/regex/Initialization.st new file mode 100644 index 00000000..203471a8 --- /dev/null +++ b/kernel/regex/Initialization.st @@ -0,0 +1,38 @@ +"====================================================================== +| +| String manipulation and regular expression resolver +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2001, 2003, 2005, 2006, 2007, 2008, 2009 +| Free Software Foundation, Inc. +| Written by Dragomir Milevojevic, Paolo Bonzini, Mike Anderson. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LESSER. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Eval [ + Kernel.FailedMatchRegexResults initialize +] + diff --git a/kernel/regex/MatchingRegexResults.st b/kernel/regex/MatchingRegexResults.st new file mode 100644 index 00000000..2fe55a7b --- /dev/null +++ b/kernel/regex/MatchingRegexResults.st @@ -0,0 +1,146 @@ +"====================================================================== +| +| String manipulation and regular expression resolver +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2001, 2003, 2005, 2006, 2007, 2008, 2009 +| Free Software Foundation, Inc. +| Written by Dragomir Milevojevic, Paolo Bonzini, Mike Anderson. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LESSER. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Namespace current: Kernel [ + +RegexResults subclass: MatchingRegexResults [ + | subject from to registers match cache | + + + + + printOn: aStream [ + "Print a represention of the receiver on aStream." + + + | ch | + aStream + nextPutAll: self class name; + nextPut: $:; + print: self match. + ch := $(. + 1 to: self size + do: + [:each | + aStream + nextPut: ch; + print: (self at: each). + ch := $,]. + self size > 0 ifTrue: [aStream nextPut: $)] + ] + + matched [ + + ^true + ] + + ifMatched: oneArgBlock ifNotMatched: zeroArgBlock [ + + ^oneArgBlock cull: self + ] + + ifNotMatched: zeroArgBlock ifMatched: oneArgBlock [ + + ^oneArgBlock cull: self + ] + + size [ + + ^registers size + ] + + subject [ + + ^subject + ] + + from [ + + ^from + ] + + fromAt: anIndex [ + + | reg | + anIndex = 0 ifTrue: [^from]. + reg := registers at: anIndex. + ^reg isNil ifTrue: [nil] ifFalse: [reg first] + ] + + to [ + + ^to + ] + + toAt: anIndex [ + + | reg | + anIndex = 0 ifTrue: [^from]. + reg := registers at: anIndex. + ^reg isNil ifTrue: [nil] ifFalse: [reg last] + ] + + match [ + + match isNil ifTrue: [match := self subject copyFrom: from to: to]. + ^match + ] + + matchInterval [ + + ^from to: to + ] + + at: anIndex [ + + | reg text | + anIndex = 0 ifTrue: [^self match]. + cache isNil ifTrue: [cache := Array new: registers size]. + (cache at: anIndex) isNil + ifTrue: + [reg := registers at: anIndex. + text := reg isNil + ifTrue: [nil] + ifFalse: [self subject copyFrom: reg first to: reg last]. + cache at: anIndex put: text]. + ^cache at: anIndex + ] + + intervalAt: anIndex [ + + ^anIndex = 0 ifTrue: [from to: to] ifFalse: [registers at: anIndex] + ] +] + +] diff --git a/kernel/regex/Regex.st b/kernel/regex/Regex.st new file mode 100644 index 00000000..c080ed3e --- /dev/null +++ b/kernel/regex/Regex.st @@ -0,0 +1,137 @@ +"====================================================================== +| +| String manipulation and regular expression resolver +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2001, 2003, 2005, 2006, 2007, 2008, 2009 +| Free Software Foundation, Inc. +| Written by Dragomir Milevojevic, Paolo Bonzini, Mike Anderson. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LESSER. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Object subclass: Regex [ + + + + + + Regex class >> fromString: aString [ + "Like `aString asRegex'." + + + + ] + + Regex class >> new [ + "Do not send this message." + + self error: 'please use #fromString: to create instances' + ] + + at: anIndex put: anObject [ + "Fail. Regex objects are read-only." + + + self shouldNotImplement + ] + + copy [ + "Answer the receiver; instances of Regex are identity objects because + their only purpose is to ease caching, and we obtain better caching + if we avoid copying Regex objects" + + + ^self + ] + + asRegex [ + "Answer the receiver, which *is* a Regex!" + + + ^self + ] + + asString [ + "Answer the receiver, converted back to a String" + + + ^(String new: self size) + replaceFrom: 1 + to: self size + with: self + startingAt: 1; + yourself + ] + + species [ + + ^String + ] + + displayString [ + "Answer a String representing the receiver. For most objects + this is simply its #printString, but for strings and characters, + superfluous dollars or extra pair of quotes are stripped." + + + | stream | + stream := WriteStream on: (String new: 0). + self displayOn: stream. + ^stream contents + ] + + displayOn: aStream [ + "Print a represention of the receiver on aStream. For most objects + this is simply its #printOn: representation, but for strings and + characters, superfluous dollars or extra pairs of quotes are stripped." + + + self printOn: aStream + ] + + printOn: aStream [ + "Print a represention of the receiver on aStream." + + + aStream nextPut: $/. + self asString do: + [:each | + each = $/ ifTrue: [ aStream nextPut: $\ ]. + aStream nextPut: each]. + aStream nextPut: $/ + ] +] + diff --git a/kernel/regex/RegexResults.st b/kernel/regex/RegexResults.st new file mode 100644 index 00000000..45646ae4 --- /dev/null +++ b/kernel/regex/RegexResults.st @@ -0,0 +1,173 @@ +"====================================================================== +| +| String manipulation and regular expression resolver +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2001, 2003, 2005, 2006, 2007, 2008, 2009 +| Free Software Foundation, Inc. +| Written by Dragomir Milevojevic, Paolo Bonzini, Mike Anderson. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LESSER. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Object subclass: RegexResults [ + + + + + matched [ + "Answer whether the regular expression was matched" + + + self subclassResponsibility + ] + + ifMatched: oneArgBlock ifNotMatched: zeroArgBlock [ + "If the regular expression was matched, evaluate oneArgBlock with the + receiver as the argument. If it was not, evaluate zeroArgBlock. + Answer the result of the block's evaluation." + + + self subclassResponsibility + ] + + ifNotMatched: zeroArgBlock ifMatched: oneArgBlock [ + "If the regular expression was matched, evaluate oneArgBlock with the + receiver as the argument. If it was not, evaluate zeroArgBlock. + Answer the result of the block's evaluation." + + + self subclassResponsibility + ] + + ifNotMatched: zeroArgBlock [ + "If the regular expression was matched, return the receiver. If it was + not, evaluate zeroArgBlock and return its result." + + + ^self ifNotMatched: zeroArgBlock ifMatched: [] + ] + + ifMatched: oneArgBlock [ + "If the regular expression was matched, pass the receiver to + oneArgBlock and return its result. Otherwise, return nil." + + + ^self ifNotMatched: [] ifMatched: oneArgBlock + ] + + size [ + "If the regular expression was matched, return the number + of subexpressions that were present in the regular expression." + + + self subclassResponsibility + ] + + asArray [ + "If the regular expression was matched, return an Array with + the subexpressions that were present in the regular expression." + + + ^1 to: self size collect: [ :each | self at: each ] + ] + + subject [ + "If the regular expression was matched, return the text + that was matched against it." + + + self subclassResponsibility + ] + + from [ + "If the regular expression was matched, return the index + of the first character in the successful match." + + + self subclassResponsibility + ] + + fromAt: anIndex [ + "If the regular expression was matched, return the index of the first + character of the anIndex-th subexpression in the successful match." + + + self subclassResponsibility + ] + + to [ + "If the regular expression was matched, return the index + of the last character in the successful match." + + + self subclassResponsibility + ] + + toAt: anIndex [ + "If the regular expression was matched, return the index of the last + character of the anIndex-th subexpression in the successful match." + + + self subclassResponsibility + ] + + match [ + "If the regular expression was matched, return the text of the + successful match." + + + self subclassResponsibility + ] + + matchInterval [ + "If the regular expression was matched, return an Interval for the + range of indices of the successful match." + + + self subclassResponsibility + ] + + at: anIndex [ + "If the regular expression was matched, return the text of the + anIndex-th subexpression in the successful match." + + + self subclassResponsibility + ] + + intervalAt: anIndex [ + "If the regular expression was matched, return an Interval for the range + of indices in the anIndex-th subexpression of the successful match." + + + self subclassResponsibility + ] +] diff --git a/kernel/stream/CollectingStream.st b/kernel/stream/CollectingStream.st new file mode 100644 index 00000000..dd01a79d --- /dev/null +++ b/kernel/stream/CollectingStream.st @@ -0,0 +1,101 @@ +"====================================================================== +| +| Adds collection-like operations to GNU Smalltalk streams +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2001, 2002, 2007, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of GNU Smalltalk. +| +| GNU Smalltalk is free software; you can redistribute it and/or modify it +| under the terms of the GNU General Public License as published by the Free +| Software Foundation; either version 2, or (at your option) any later version. +| +| GNU Smalltalk is distributed in the hope that it will be useful, but WITHOUT +| ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +| FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +| details. +| +| You should have received a copy of the GNU General Public License along with +| GNU Smalltalk; see the file COPYING. If not, write to the Free Software +| Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Namespace current: Kernel [ + +Stream subclass: CollectingStream [ + | stream block | + + + + + CollectingStream class >> on: aStream collect: collectBlock [ + + ^self new initStream: aStream block: collectBlock + ] + + initStream: aStream block: collectBlock [ + + stream := aStream. + block := collectBlock + ] + + atEnd [ + + ^stream atEnd + ] + + next [ + + stream atEnd ifTrue: [^stream pastEnd]. + ^block value: stream next + ] + + pastEnd [ + + ^stream pastEnd + ] + + peek [ + + stream atEnd ifTrue: [^nil]. + ^block value: stream peek + ] + + peekFor: anObject [ + + | result | + stream atEnd + ifTrue: + [stream pastEnd. + ^false]. + result := (block value: stream peek) = anObject result + ifTrue: [stream next]. + ^result + ] + + position [ + + ^stream position + ] + + position: anInteger [ + + stream position: anInteger + ] + + species [ + + ^stream species + ] +] + +] diff --git a/kernel/stream/ConcatenatedStream.st b/kernel/stream/ConcatenatedStream.st new file mode 100644 index 00000000..42aa2a29 --- /dev/null +++ b/kernel/stream/ConcatenatedStream.st @@ -0,0 +1,184 @@ +"====================================================================== +| +| Adds collection-like operations to GNU Smalltalk streams +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2001, 2002, 2007, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of GNU Smalltalk. +| +| GNU Smalltalk is free software; you can redistribute it and/or modify it +| under the terms of the GNU General Public License as published by the Free +| Software Foundation; either version 2, or (at your option) any later version. +| +| GNU Smalltalk is distributed in the hope that it will be useful, but WITHOUT +| ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +| FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +| details. +| +| You should have received a copy of the GNU General Public License along with +| GNU Smalltalk; see the file COPYING. If not, write to the Free Software +| Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Namespace current: Kernel [ + +Stream subclass: ConcatenatedStream [ + | streams startPos curPos last lastStart | + + + + + ConcatenatedStream class >> new [ + + ^#() readStream + ] + + ConcatenatedStream class >> with: stream1 [ + + ^(self basicNew) + streams: {stream1}; + yourself + ] + + ConcatenatedStream class >> with: stream1 with: stream2 [ + + ^(self basicNew) + streams: {stream1. stream2}; + yourself + ] + + ConcatenatedStream class >> withAll: array [ + + ^(self basicNew) + streams: array; + yourself + ] + + , aStream [ + + ^(self copy) + addStream: aStream; + yourself + ] + + postCopy [ + + streams := streams copy + ] + + stream [ + + | s | + "This is somewhat performance-sensitive, so avoid testing for an + empty collection." + [(s := streams at: 1) atEnd] whileTrue: + [curPos > 0 ifTrue: [ + lastStart := startPos. + startPos := startPos + curPos. + curPos := 0]. + streams size = 1 ifTrue: [last := streams first. ^nil]. + last := streams removeFirst]. + ^s + ] + + atEnd [ + + ^self stream isNil + ] + + file [ + + self atEnd ifTrue: [^nil]. + ^streams first file + ] + + name [ + + self atEnd ifTrue: [^nil]. + ^streams first name + ] + + next [ + + | s | + ^(s := self stream) isNil + ifTrue: [self pastEnd] + ifFalse: [curPos := curPos + 1. s next] + ] + + pastEnd [ + + ^streams last pastEnd + ] + + peekFor: aCharacter [ + + | s result | + (s := self stream) isNil + ifTrue: + [self pastEnd. + ^false]. + result := s peekFor: aCharacter. + result ifTrue: [curPos := curPos + 1]. + ^result + ] + + peek [ + + | s | + (s := self stream) isNil ifTrue: [^self pastEnd]. + ^s peek + ] + + position [ + + self stream. + ^startPos + curPos + ] + + position: anInteger [ + + | s | + (s := self stream) isNil + ifTrue: + [self pastEnd. + ^self]. + s position: anInteger - startPos. + curPos := anInteger - startPos + ] + + copyFrom: start to: end [ + "needed to do the documentation" + + + | adjust stream | + stream := self stream. + end + 1 = start ifTrue: [^'']. + adjust := end <= startPos + ifTrue: [stream := last. lastStart] + ifFalse: [startPos]. + ^stream copyFrom: (start - adjust max: 0) to: end - adjust + ] + + addStream: stream [ + + streams addLast: stream + ] + + streams: arrayOfStreams [ + + streams := arrayOfStreams asOrderedCollection. + startPos := curPos := 0 + ] +] + +] diff --git a/kernel/stream/Extensions.st b/kernel/stream/Extensions.st new file mode 100644 index 00000000..5ab483a3 --- /dev/null +++ b/kernel/stream/Extensions.st @@ -0,0 +1,152 @@ +"====================================================================== +| +| Adds collection-like operations to GNU Smalltalk streams +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2001, 2002, 2007, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of GNU Smalltalk. +| +| GNU Smalltalk is free software; you can redistribute it and/or modify it +| under the terms of the GNU General Public License as published by the Free +| Software Foundation; either version 2, or (at your option) any later version. +| +| GNU Smalltalk is distributed in the hope that it will be useful, but WITHOUT +| ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +| FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +| details. +| +| You should have received a copy of the GNU General Public License along with +| GNU Smalltalk; see the file COPYING. If not, write to the Free Software +| Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Stream extend [ + + , anIterable [ + "Answer a new stream that concatenates the data in the receiver with the + data in aStream. Both the receiver and aStream should be readable." + + + ^Kernel.ConcatenatedStream with: self with: anIterable readStream + ] + + lines [ + "Answer a new stream that answers lines from the receiver." + + + ^Kernel.LineStream on: self + ] + + peek [ + "Returns the next element of the stream without moving the pointer. + Returns nil when at end of stream. Lookahead is implemented automatically + for streams that are not positionable but can be copied." + + + | copy | + copy := self copy. + copy == self ifTrue: [^self shouldNotImplement]. + self become: (Kernel.PeekableStream on: copy). + ^self peek + ] + + skipSeparators [ + "Advance the receiver until we find a character that is not a + separator. Answer false if we reach the end of the stream, + else answer true; in this case, sending #next will return the + first non-separator character (possibly the same to which the + stream pointed before #skipSeparators was sent)." + + + | ch | + + [(ch := self peek) isNil ifTrue: [^false]. + ch isSeparator] + whileTrue: [self next]. + ^true + ] + + peekFor: aCharacter [ + "Returns true and gobbles the next element from the stream of it is + equal to anObject, returns false and doesn't gobble the next element + if the next element is not equal to anObject. Lookahead is implemented + automatically for streams that are not positionable but can be copied." + + + | copy | + copy := self copy. + copy == self ifTrue: [^self shouldNotImplement]. + self become: (Kernel.PeekableStream on: copy). + ^self peekFor: aCharacter + ] + + select: aBlock [ + "Answer a new stream that only returns those objects for which aBlock + returns true. Note that the returned stream will not be positionable." + + "Example: Sieve of Erathostenes. + GNU Smalltalk does not detect that i escapes, so we need to avoid + optimizations of #to:do:. + + s := (2 to: 100) readStream. + (2 to: 10) do: [ :i | + s := s reject: [ :n | n > i and: [ n \\ i = 0 ] ] ]. + s contents printNl" + + + ^Kernel.FilteringStream on: self select: aBlock + ] + + reject: aBlock [ + "Answer a new stream that only returns those objects for which aBlock + returns false. Note that the returned stream will not be positionable." + + + ^Kernel.FilteringStream on: self reject: aBlock + ] + + collect: aBlock [ + "Answer a new stream that will pass the returned objects through aBlock, + and return whatever object is returned by aBlock instead. Note that when + peeking in the returned stream, the block will be invoked multiple times, + with possibly surprising results." + + + ^Kernel.CollectingStream on: self collect: aBlock + ] + + with: aStream [ + "Return a new Stream whose elements are 2-element + Arrays, including one element from the receiver and one from + aStream." + + ^Kernel.OneOfEachStream with: self with: aStream + ] + + with: stream1 with: stream2 [ + "Return a new Stream whose elements are 3-element + Arrays, including one element from the receiver and one from + each argument." + + ^Kernel.OneOfEachStream with: self with: stream1 with: stream2 + ] + + with: stream1 with: stream2 with: stream3 [ + "Return a new Stream whose elements are 3-element + Arrays, including one element from the receiver and one from + each argument." + + ^Kernel.OneOfEachStream + with: self with: stream1 with: stream2 with: stream3 + ] +] + diff --git a/kernel/stream/FilteringStream.st b/kernel/stream/FilteringStream.st new file mode 100644 index 00000000..bbe3a49e --- /dev/null +++ b/kernel/stream/FilteringStream.st @@ -0,0 +1,124 @@ +"====================================================================== +| +| Adds collection-like operations to GNU Smalltalk streams +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2001, 2002, 2007, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of GNU Smalltalk. +| +| GNU Smalltalk is free software; you can redistribute it and/or modify it +| under the terms of the GNU General Public License as published by the Free +| Software Foundation; either version 2, or (at your option) any later version. +| +| GNU Smalltalk is distributed in the hope that it will be useful, but WITHOUT +| ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +| FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +| details. +| +| You should have received a copy of the GNU General Public License along with +| GNU Smalltalk; see the file COPYING. If not, write to the Free Software +| Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Namespace current: Kernel [ + +Stream subclass: FilteringStream [ + | stream block result next atEnd | + + + + + FilteringStream class >> on: aStream select: selectBlock [ + + ^self new + initStream: aStream + block: selectBlock + result: true + ] + + FilteringStream class >> on: aStream reject: selectBlock [ + + ^self new + initStream: aStream + block: selectBlock + result: false + ] + + initStream: aStream block: selectBlock result: aBoolean [ + + stream := aStream. + block := selectBlock. + result := aBoolean. + atEnd := false. + self lookahead + ] + + atEnd [ + + ^atEnd + ] + + next [ + + | result | + atEnd + ifTrue: + [self pastEnd. + ^nil]. + result := next. + self lookahead. + ^result + ] + + pastEnd [ + + ^stream pastEnd + ] + + peek [ + + atEnd ifTrue: [^nil]. + ^next + ] + + peekFor: aCharacter [ + + atEnd + ifTrue: + [self pastEnd. + ^false]. + next == aCharacter + ifTrue: + [self lookahead. + ^true]. + ^false + ] + + species [ + + ^stream species + ] + + lookahead [ + + + [stream atEnd + ifTrue: + [atEnd := true. + ^self]. + next := stream next. + (block value: next) == result] + whileFalse + ] +] + +] diff --git a/kernel/stream/LineStream.st b/kernel/stream/LineStream.st new file mode 100644 index 00000000..2bd8291f --- /dev/null +++ b/kernel/stream/LineStream.st @@ -0,0 +1,78 @@ +"====================================================================== +| +| Adds collection-like operations to GNU Smalltalk streams +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2001, 2002, 2007, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of GNU Smalltalk. +| +| GNU Smalltalk is free software; you can redistribute it and/or modify it +| under the terms of the GNU General Public License as published by the Free +| Software Foundation; either version 2, or (at your option) any later version. +| +| GNU Smalltalk is distributed in the hope that it will be useful, but WITHOUT +| ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +| FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +| details. +| +| You should have received a copy of the GNU General Public License along with +| GNU Smalltalk; see the file COPYING. If not, write to the Free Software +| Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Namespace current: Kernel [ + +Stream subclass: LineStream [ + | charStream | + + + + + LineStream class >> on: aStream [ + "Answer a LineStream working on aStream" + + + ^self new initStream: aStream + ] + + file [ + + ^charStream file + ] + + name [ + + ^charStream name + ] + + next [ + + ^charStream nextLine + ] + + atEnd [ + + ^charStream atEnd + ] + + pastEnd [ + + ^charStream pastEnd + ] + + initStream: aStream [ + + charStream := aStream + ] +] + +] diff --git a/kernel/stream/OneOfEachStream.st b/kernel/stream/OneOfEachStream.st new file mode 100644 index 00000000..0244bebe --- /dev/null +++ b/kernel/stream/OneOfEachStream.st @@ -0,0 +1,150 @@ +"====================================================================== +| +| Adds collection-like operations to GNU Smalltalk streams +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2001, 2002, 2007, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of GNU Smalltalk. +| +| GNU Smalltalk is free software; you can redistribute it and/or modify it +| under the terms of the GNU General Public License as published by the Free +| Software Foundation; either version 2, or (at your option) any later version. +| +| GNU Smalltalk is distributed in the hope that it will be useful, but WITHOUT +| ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +| FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +| details. +| +| You should have received a copy of the GNU General Public License along with +| GNU Smalltalk; see the file COPYING. If not, write to the Free Software +| Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Namespace current: Kernel [ + +Stream subclass: OneOfEachStream [ + | streams delta | + + + + + OneOfEachStream class >> new [ + + ^#() readStream + ] + + OneOfEachStream class >> with: stream1 [ + + ^(self basicNew) + streams: {stream1} + ] + + OneOfEachStream class >> with: stream1 with: stream2 [ + + ^(self basicNew) + streams: + {stream1. + stream2} + ] + + OneOfEachStream class >> with: stream1 with: stream2 with: stream3 [ + + ^(self basicNew) + streams: + {stream1. + stream2. + stream3} + ] + + OneOfEachStream class >> with: stream1 with: stream2 with: stream3 with: stream4 [ + + ^(self basicNew) + streams: + {stream1. + stream2. + stream3. + stream4} + ] + + OneOfEachStream class >> withAll: array [ + + ^(self basicNew) + streams: array + ] + + atEnd [ + + ^streams anySatisfy: [ :each | each atEnd] + ] + + do: aBlock [ + + [ + aBlock value: + (streams collect: [:each | + each atEnd ifTrue: [ ^self ]. + each next ]) + ] repeat + ] + + next [ + + ^streams collect: [:each | + each atEnd ifTrue: [ ^self pastEnd ] ifFalse: [ each next ]] + ] + + pastEnd [ + + ^streams first pastEnd + ] + + peekFor: anObject [ + + ^self peek = anObject + ifTrue: [ streams do: [ :each | streams next ] ]; + yourself + ] + + peek [ + + ^streams collect: [:each | + each atEnd ifTrue: [ ^self pastEnd ] ifFalse: [ each peek ]] + ] + + position [ + + ^streams first position - delta + ] + + position: anInteger [ + + ^self skip: anInteger - self position + ] + + reset [ + + self position: 0 + ] + + skip: anInteger [ + + streams do: [ :each | each skip: anInteger ] + ] + + streams: arrayOfStreams [ + + streams := arrayOfStreams. + delta := arrayOfStreams first position. + ] +] + +] diff --git a/kernel/stream/PeekableStream.st b/kernel/stream/PeekableStream.st new file mode 100644 index 00000000..aa5aff3a --- /dev/null +++ b/kernel/stream/PeekableStream.st @@ -0,0 +1,122 @@ +"====================================================================== +| +| Adds collection-like operations to GNU Smalltalk streams +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2001, 2002, 2007, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of GNU Smalltalk. +| +| GNU Smalltalk is free software; you can redistribute it and/or modify it +| under the terms of the GNU General Public License as published by the Free +| Software Foundation; either version 2, or (at your option) any later version. +| +| GNU Smalltalk is distributed in the hope that it will be useful, but WITHOUT +| ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +| FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +| details. +| +| You should have received a copy of the GNU General Public License along with +| GNU Smalltalk; see the file COPYING. If not, write to the Free Software +| Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Namespace current: Kernel [ + +Stream subclass: PeekableStream [ + | stream haveLookahead lookahead | + + + + + PeekableStream class >> on: aStream [ + + ^self new initStream: aStream + ] + + species [ + + ^stream species + ] + + file [ + + ^stream file + ] + + name [ + + ^stream name + ] + + next [ + + | char | + ^haveLookahead + ifTrue: + [haveLookahead := false. + char := lookahead. + lookahead := nil. + char] + ifFalse: [stream next] + ] + + atEnd [ + "Answer whether the input stream has no more tokens." + + + ^haveLookahead not and: [stream atEnd] + ] + + pastEnd [ + + ^stream pastEnd + ] + + peek [ + "Returns the next element of the stream without moving the pointer. + Returns nil when at end of stream." + + + haveLookahead + ifFalse: + [stream atEnd ifTrue: [^nil]. + haveLookahead := true. + lookahead := stream next]. + ^lookahead + ] + + peekFor: anObject [ + "Answer a new whitespace-separated token from the input stream" + + + | result | + haveLookahead + ifFalse: + [stream atEnd + ifTrue: + [self pastEnd. + ^false]. + lookahead := stream next]. + result := lookahead = anObject. + result ifTrue: [lookahead := nil]. + haveLookahead := result not. + ^result + ] + + initStream: aStream [ + + stream := aStream. + haveLookahead := false + ] +] + +] diff --git a/kernel/url/Initialization.st b/kernel/url/Initialization.st new file mode 100644 index 00000000..3b2803bf --- /dev/null +++ b/kernel/url/Initialization.st @@ -0,0 +1,38 @@ +"====================================================================== +| +| URL class and basic support for resolving URLs +| +| + ======================================================================" + +"====================================================================== +| +| Based on code copyright (c) Kazuki Yasumatsu, in the public domain +| Copyright (c) 2002, 2003, 2008, 2008, 2009 Free Software Foundation, Inc. +| Adapted by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Namespace current: NetClients [ + URL initialize +] + diff --git a/kernel/url/URIResolver.st b/kernel/url/URIResolver.st new file mode 100644 index 00000000..87b939cf --- /dev/null +++ b/kernel/url/URIResolver.st @@ -0,0 +1,115 @@ +"====================================================================== +| +| URL class and basic support for resolving URLs +| +| + ======================================================================" + +"====================================================================== +| +| Based on code copyright (c) Kazuki Yasumatsu, in the public domain +| Copyright (c) 2002, 2003, 2008, 2008, 2009 Free Software Foundation, Inc. +| Adapted by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Namespace current: NetClients [ + +Object subclass: URIResolver [ + + + + + URIResolver class >> on: anURL [ + "Answer a new URIResolver that will do its best to fetch the data for + anURL from the Internet." + + + ^self new on: anURL + ] + + URIResolver class >> openStreamOn: aURI ifFail: aBlock [ + "Check if aURI can be fetched from the Internet or from the local system, + and if so return a Stream with its contents. If this is not possible, + instead, evaluate the zero-argument block aBlock and answer the result + of the evaluation." + + + | url name body | + url := aURI. + (url respondsTo: #key) ifTrue: [url := url key , ':/' , url value]. + url isString ifTrue: [url := URL fromString: url]. + url scheme = 'file' ifFalse: [^aBlock value]. + name := url path copy. + name replaceAll: $/ with: Directory pathSeparator. + ^FileStream + fopen: name + mode: FileStream read + ifFail: aBlock + ] + + URIResolver class >> openOn: aURI ifFail: aBlock [ + "Always evaluate aBlock and answer the result if the additional NetClients + package is not loaded. If it is, instead, return a WebEntity with the + contents of the resource specified by anURI, and only evaluate the block + if loading the resource fails." + + + ^aBlock value + ] + + URIResolver class >> openStreamOn: aURI [ + "Check if aURI can be fetched from the Internet or from the local system, + and if so return a Stream with its contents. If this is not possible, + raise an exception." + + + ^self openStreamOn: aURI + ifFail: + [SystemExceptions.FileError signal: 'could not open ' , aURI printString] + ] + + URIResolver class >> openOn: aURI [ + "Always raise an error, as this method is not supported + without loading the additional NetClients package." + + + ^self openOn: aURI + ifFail: + [SystemExceptions.FileError signal: 'could not open ' , aURI printString] + ] + + URIResolver class >> resolve: newName from: oldURI [ + + | url newURI | + url := oldURI. + (url respondsTo: #key) ifTrue: [url := url key , ':/' , url value]. + url isString ifTrue: [url := URL fromString: url]. + url := url construct: (URL fromString: newName). + newURI := url printString. + ^url + ] +] + +] + diff --git a/kernel/URL.st b/kernel/url/URL.st similarity index 89% rename from kernel/URL.st rename to kernel/url/URL.st index 2ad93a16..efd60995 100644 --- a/kernel/URL.st +++ b/kernel/url/URL.st @@ -830,92 +830,3 @@ Copyright (c) Kazuki Yasumatsu, 1995. All rights reserved. ] - - -Namespace current: NetClients [ - -Object subclass: URIResolver [ - - - - - URIResolver class >> on: anURL [ - "Answer a new URIResolver that will do its best to fetch the data for - anURL from the Internet." - - - ^self new on: anURL - ] - - URIResolver class >> openStreamOn: aURI ifFail: aBlock [ - "Check if aURI can be fetched from the Internet or from the local system, - and if so return a Stream with its contents. If this is not possible, - instead, evaluate the zero-argument block aBlock and answer the result - of the evaluation." - - - | url name body | - url := aURI. - (url respondsTo: #key) ifTrue: [url := url key , ':/' , url value]. - url isString ifTrue: [url := URL fromString: url]. - url scheme = 'file' ifFalse: [^aBlock value]. - name := url path copy. - name replaceAll: $/ with: Directory pathSeparator. - ^FileStream - fopen: name - mode: FileStream read - ifFail: aBlock - ] - - URIResolver class >> openOn: aURI ifFail: aBlock [ - "Always evaluate aBlock and answer the result if the additional NetClients - package is not loaded. If it is, instead, return a WebEntity with the - contents of the resource specified by anURI, and only evaluate the block - if loading the resource fails." - - - ^aBlock value - ] - - URIResolver class >> openStreamOn: aURI [ - "Check if aURI can be fetched from the Internet or from the local system, - and if so return a Stream with its contents. If this is not possible, - raise an exception." - - - ^self openStreamOn: aURI - ifFail: - [SystemExceptions.FileError signal: 'could not open ' , aURI printString] - ] - - URIResolver class >> openOn: aURI [ - "Always raise an error, as this method is not supported - without loading the additional NetClients package." - - - ^self openOn: aURI - ifFail: - [SystemExceptions.FileError signal: 'could not open ' , aURI printString] - ] - - URIResolver class >> resolve: newName from: oldURI [ - - | url newURI | - url := oldURI. - (url respondsTo: #key) ifTrue: [url := url key , ':/' , url value]. - url isString ifTrue: [url := URL fromString: url]. - url := url construct: (URL fromString: newName). - newURI := url printString. - ^url - ] -] - -] - - - -Namespace current: NetClients [ - URL initialize -] - diff --git a/kernel/value-adaptor/DelayedAdaptor.st b/kernel/value-adaptor/DelayedAdaptor.st new file mode 100644 index 00000000..d76d8b00 --- /dev/null +++ b/kernel/value-adaptor/DelayedAdaptor.st @@ -0,0 +1,75 @@ +"====================================================================== +| +| ValueAdaptor hierarchy Method Definitions +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1999, 2000, 2001, 2002, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +PluggableAdaptor subclass: DelayedAdaptor [ + | value delayed | + + + + + trigger [ + "Really set the value of the receiver." + + + delayed + ifTrue: + [delayed := false. + super value: value] + ] + + value: anObject [ + "Set the value of the receiver - actually, the value is cached and + is not set until the #trigger method is sent." + + + value := anObject. + delayed := true + ] + + value [ + "Get the value of the receiver." + + + ^delayed ifTrue: [value] ifFalse: [getBlock value] + ] + + getBlock: get putBlock: put [ + + delayed := false. + ^super getBlock: get putBlock: put + ] +] + diff --git a/kernel/value-adaptor/NullValueHolder.st b/kernel/value-adaptor/NullValueHolder.st new file mode 100644 index 00000000..0b2e23ea --- /dev/null +++ b/kernel/value-adaptor/NullValueHolder.st @@ -0,0 +1,76 @@ +"====================================================================== +| +| ValueAdaptor hierarchy Method Definitions +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1999, 2000, 2001, 2002, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +ValueAdaptor subclass: NullValueHolder [ + + + + + NullValueHolder class [ + | uniqueInstance | + + ] + + NullValueHolder class >> new [ + "Not used -- use `ValueHolder null' instead" + + + ^self shouldNotImplement + ] + + NullValueHolder class >> uniqueInstance [ + "Answer the sole instance of NullValueHolder" + + + ^uniqueInstance isNil + ifTrue: [uniqueInstance := self basicNew] + ifFalse: [uniqueInstance] + ] + + value: anObject [ + "Set the value of the receiver. Do nothing, discard the value" + + + + ] + + value [ + "Retrive the value of the receiver. Always answer nil" + + + ^nil + ] +] diff --git a/kernel/value-adaptor/PluggableAdaptor.st b/kernel/value-adaptor/PluggableAdaptor.st new file mode 100644 index 00000000..c51dc0c7 --- /dev/null +++ b/kernel/value-adaptor/PluggableAdaptor.st @@ -0,0 +1,110 @@ +"====================================================================== +| +| ValueAdaptor hierarchy Method Definitions +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1999, 2000, 2001, 2002, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +ValueAdaptor subclass: PluggableAdaptor [ + | getBlock putBlock | + + + + + PluggableAdaptor class >> getBlock: getBlock putBlock: putBlock [ + "Answer a PluggableAdaptor using the given blocks to implement + #value and #value:" + + + ^self basicNew getBlock: getBlock putBlock: putBlock + ] + + PluggableAdaptor class >> on: anObject getSelector: getSelector putSelector: putSelector [ + "Answer a PluggableAdaptor using anObject's getSelector message to + implement #value, and anObject's putSelector message to implement + #value:" + + + ^self basicNew getBlock: [anObject perform: getSelector] + putBlock: [:value | anObject perform: putSelector with: value] + ] + + PluggableAdaptor class >> on: anObject aspect: aSymbol [ + "Answer a PluggableAdaptor using anObject's aSymbol message to + implement #value, and anObject's aSymbol: message (aSymbol + followed by a colon) to implement #value:" + + + ^self + on: anObject + getSelector: aSymbol + putSelector: (aSymbol , ':') asSymbol + ] + + PluggableAdaptor class >> on: anObject index: anIndex [ + "Answer a PluggableAdaptor using anObject's #at: and #at:put: + message to implement #value and #value:; the first parameter + of #at: and #at:put: is anIndex" + + + ^self getBlock: [anObject at: anIndex] + putBlock: [:value | anObject at: anIndex put: value] + ] + + PluggableAdaptor class >> on: aDictionary key: aKey [ + "Same as #on:index:. Provided for clarity and completeness." + + + ^self on: aDictionary index: aKey + ] + + value: anObject [ + "Set the value of the receiver." + + + putBlock value: anObject + ] + + value [ + "Get the value of the receiver." + + + ^getBlock value + ] + + getBlock: get putBlock: put [ + + getBlock := get. + putBlock := put. + ^self + ] +] diff --git a/kernel/value-adaptor/Promise.st b/kernel/value-adaptor/Promise.st new file mode 100644 index 00000000..f7cbaae9 --- /dev/null +++ b/kernel/value-adaptor/Promise.st @@ -0,0 +1,125 @@ +"====================================================================== +| +| ValueAdaptor hierarchy Method Definitions +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1999, 2000, 2001, 2002, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +ValueHolder subclass: Promise [ + | sema error | + + + + + Promise class >> for: aBlock [ + "Invoke aBlock at an indeterminate time in an indeterminate + process before answering its value from #value sent to my + result." + + | p | + p := Promise new. + [[ p value: aBlock value ] + on: Error + do: [ :ex | p errorValue: ex. ex return ]] fork. + ^p + ] + + Promise class >> null [ + + self shouldNotImplement + ] + + hasError [ + "Answer whether calling #value will raise an exception." + + + ^error notNil + ] + + hasValue [ + "Answer whether we already have a value (or calling #value will + raise an error)." + + + ^sema isNil + ] + + value: anObject [ + "Set the value of the receiver." + + + + super value: anObject. + [sema notifyAll. sema := nil] valueWithoutPreemption + ] + + errorValue: anException [ + "Private - Raise anException whenever #value is called." + + error := anException. + [sema notifyAll. sema := nil] valueWithoutPreemption + ] + + value [ + "Get the value of the receiver." + + + + "This is guaranteed to execute atomically by the VM!" + sema == nil ifFalse: [sema wait]. + + ^error isNil + ifTrue: [ super value ] + ifFalse: [ error copy signal ] + ] + + printOn: aStream [ + "Print a representation of the receiver" + + + aStream print: self class. + self hasValue ifFalse: [ aStream nextPutAll: '(???)' ]. + self hasError ifTrue: [ aStream nextPutAll: '(Error!)' ]. + + aStream + nextPut: $(; + print: self value; + nextPut: $) + ] + + initialize [ + "Private - set the initial state of the receiver" + + + super initialize. + sema := Semaphore new + ] +] diff --git a/kernel/value-adaptor/ValueAdaptor.st b/kernel/value-adaptor/ValueAdaptor.st new file mode 100644 index 00000000..a1545aa2 --- /dev/null +++ b/kernel/value-adaptor/ValueAdaptor.st @@ -0,0 +1,73 @@ +"====================================================================== +| +| ValueAdaptor hierarchy Method Definitions +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1999, 2000, 2001, 2002, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Object subclass: ValueAdaptor [ + + + + + ValueAdaptor class >> new [ + "We don't know enough of subclasses to have a shared implementation of new" + + + self shouldNotImplement + ] + + printOn: aStream [ + "Print a representation of the receiver" + + + aStream + print: self class; + nextPut: $(; + print: self value; + nextPut: $) + ] + + value: anObject [ + "Set the value of the receiver. Must be implemented by ValueAdaptor's + subclasses" + + + self subclassResponsibility + ] + + value [ + "Retrive the value of the receiver. Must be implemented by ValueAdaptor's + subclasses" + + + self subclassResponsibility + ] +] diff --git a/kernel/value-adaptor/ValueHolder.st b/kernel/value-adaptor/ValueHolder.st new file mode 100644 index 00000000..850d5e21 --- /dev/null +++ b/kernel/value-adaptor/ValueHolder.st @@ -0,0 +1,85 @@ +"====================================================================== +| +| ValueAdaptor hierarchy Method Definitions +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1999, 2000, 2001, 2002, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +ValueAdaptor subclass: ValueHolder [ + | value | + + + + + ValueHolder class >> new [ + "Create a ValueHolder whose starting value is nil" + + + ^self basicNew initialize + ] + + ValueHolder class >> null [ + "Answer the sole instance of NullValueHolder" + + + ^NullValueHolder uniqueInstance + ] + + ValueHolder class >> with: anObject [ + "Create a ValueHolder whose starting value is anObject" + + + ^self new value: anObject + ] + + value: anObject [ + "Set the value of the receiver." + + + value := anObject + ] + + value [ + "Get the value of the receiver." + + + ^value + ] + + initialize [ + "Private - set the initial value of the receiver" + + + value := nil + ] +] + diff --git a/kernel/value-adaptor/ValueHolderExtensions.st b/kernel/value-adaptor/ValueHolderExtensions.st new file mode 100644 index 00000000..4d32e13c --- /dev/null +++ b/kernel/value-adaptor/ValueHolderExtensions.st @@ -0,0 +1,43 @@ +"====================================================================== +| +| ValueAdaptor hierarchy Method Definitions +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 1999, 2000, 2001, 2002, 2008, 2009 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + + + +Object extend [ + + asValue [ + "Answer a ValueHolder whose initial value is the receiver." + + + ^ValueHolder with: self + ] + +] diff --git a/libgst/files.c b/libgst/files.c index 724d66ad..c612624d 100644 --- a/libgst/files.c +++ b/libgst/files.c @@ -158,21 +158,26 @@ static const char *site_pre_image_file = NULL; As a provision for when we'll switch to a shared library, this is not an array but a list of consecutive file names. */ static const char standard_files[] = { - "Builtins.st\0" - "SysDict.st\0" + "bootstrap/Behavior.st\0" + "bootstrap/Object.st\0" + "bootstrap/Dictionary.st\0" + "bootstrap/Class.st\0" + "bootstrap/ClassDescription.st\0" + "bootstrap/UndefinedObject.st\0" + "SystemDictionary.st\0" "Object.st\0" "Message.st\0" "MessageLookup.st\0" - "DirMessage.st\0" + "DirectedMessage.st\0" "Boolean.st\0" "False.st\0" "True.st\0" "Magnitude.st\0" "LookupKey.st\0" - "DeferBinding.st\0" + "DeferredVariableBinding.st\0" "Association.st\0" - "HomedAssoc.st\0" - "VarBinding.st\0" + "HomedAssociation.st\0" + "VariableBinding.st\0" "Integer.st\0" "Date.st\0" "Time.st\0" @@ -182,114 +187,252 @@ static const char standard_files[] = { "FloatE.st\0" "FloatQ.st\0" "Fraction.st\0" - "LargeInt.st\0" - "SmallInt.st\0" + "LargeInteger.st\0" + "LargeNegativeInteger.st\0" + "LargePositiveInteger.st\0" + "LargeZeroInteger.st\0" + "SmallInteger.st\0" "Character.st\0" - "UniChar.st\0" + "UnicodeCharacter.st\0" "Link.st\0" "Process.st\0" "CallinProcess.st\0" "Iterable.st\0" "Collection.st\0" - "SeqCollect.st\0" + "SequenceableCollection.st\0" "LinkedList.st\0" "Semaphore.st\0" - "ArrayColl.st\0" - "CompildCode.st\0" - "CompildMeth.st\0" - "CompiledBlk.st\0" + "ArrayedCollection.st\0" + "CompiledCode.st\0" + "CompiledMethod.st\0" + "CompiledBlock.st\0" "Array.st\0" "ByteArray.st\0" - "CharArray.st\0" + "CharacterArray.st\0" "String.st\0" "Symbol.st\0" - "UniString.st\0" + "UnicodeString.st\0" "Interval.st\0" - "OrderColl.st\0" - "SortCollect.st\0" - "HashedColl.st\0" + "OrderedCollection.st\0" + "SortedCollection.st\0" + "HashedCollection.st\0" "Set.st\0" "IdentitySet.st\0" "Dictionary.st\0" "LookupTable.st\0" - "IdentDict.st\0" - "MethodDict.st\0" - "BindingDict.st\0" - "AbstNamespc.st\0" - "RootNamespc.st\0" + "IdentityDictionary.st\0" + "MethodDictionary.st\0" + "BindingDictionary.st\0" + "AbstractNamespace.st\0" + "RootNamespace.st\0" "Namespace.st\0" "Stream.st\0" - "PosStream.st\0" + "PositionableStream.st\0" "ReadStream.st\0" "WriteStream.st\0" - "RWStream.st\0" - "UndefObject.st\0" - "ProcSched.st\0" + "ReadWriteStream.st\0" + "UndefinedObject.st\0" + "ProcessorScheduler.st\0" "ContextPart.st\0" - "MthContext.st\0" - "BlkContext.st\0" - "BlkClosure.st\0" + "MethodContext.st\0" + "BlockContext.st\0" + "BlockClosure.st\0" "Behavior.st\0" - "ClassDesc.st\0" + "ClassDescription.st\0" "Class.st\0" "Metaclass.st\0" "Continuation.st\0" "Memory.st\0" "MethodInfo.st\0" "FileSegment.st\0" - "FileDescr.st\0" + "FileDescriptor.st\0" "SymLink.st\0" "Security.st\0" - "WeakObjects.st\0" - "ObjMemory.st\0" + "collection/weak/WeakArray.st\0" + "collection/weak/WeakSet.st\0" + "collection/weak/WeakKeyDictionary.st\0" + "collection/weak/WeakValueLookupTable.st\0" + "collection/weak/WeakIdentitySet.st\0" + "collection/weak/WeakKeyIdentityDictionary.st\0" + "collection/weak/WeakValueIdentityDictionary.st\0" + "ObjectMemory.st\0" /* More core classes */ "Bag.st\0" - "MappedColl.st\0" + "MappedCollection.st\0" "Delay.st\0" "SharedQueue.st\0" "Random.st\0" "RecursionLock.st\0" + "TextCollector.st\0" "Transcript.st\0" "Point.st\0" + "PointExtensions.st\0" "Rectangle.st\0" + "RectangleExtensions.st\0" "RunArray.st\0" - "AnsiDates.st\0" - "ScaledDec.st\0" - "ValueAdapt.st\0" - "OtherArrays.st\0" + "RunArrayExtensions.st\0" + "DateTime.st\0" + "Duration.st\0" + "ScaledDecimal.st\0" + "value-adaptor/ValueAdaptor.st\0" + "value-adaptor/NullValueHolder.st\0" + "value-adaptor/ValueHolder.st\0" + "value-adaptor/ValueHolderExtensions.st\0" + "value-adaptor/Promise.st\0" + "value-adaptor/PluggableAdaptor.st\0" + "value-adaptor/DelayedAdaptor.st\0" + "WordArray.st\0" + "LargeArraySubpart.st\0" + "LargeArrayedCollection.st\0" + "LargeArray.st\0" + "LargeByteArray.st\0" + "LargeWordArray.st\0" /* C call-out facilities */ - "CObject.st\0" - "CType.st\0" - "CCallable.st\0" - "CFuncs.st\0" - "CCallback.st\0" - "CStruct.st\0" + "ffi/CObject.st\0" + "ffi/CScalar.st\0" + "ffi/CSmalltalk.st\0" + "ffi/CLongLong.st\0" + "ffi/CULongLong.st\0" + "ffi/CLong.st\0" + "ffi/CULong.st\0" + "ffi/CInt.st\0" + "ffi/CUInt.st\0" + "ffi/CShort.st\0" + "ffi/CUShort.st\0" + "ffi/CChar.st\0" + "ffi/CUChar.st\0" + "ffi/CFloat.st\0" + "ffi/CDouble.st\0" + "ffi/CLongDouble.st\0" + "ffi/CAggregate.st\0" + "ffi/CArray.st\0" + "ffi/CPtr.st\0" + "ffi/CString.st\0" + "ffi/CByte.st\0" + "ffi/CBoolean.st\0" + "ffi/CObjectExtensions.st\0" + "ffi/CType.st\0" + "ffi/CScalarCType.st\0" + "ffi/CStringCType.st\0" + "ffi/CPtrCType.st\0" + "ffi/CArrayCType.st\0" + "ffi/CTypeInitialization.st\0" + "ffi/CCallable.st\0" + "ffi/CFunctionDescriptor.st\0" + "ffi/Extensions.st\0" + "ffi/CCallbackDescriptor.st\0" + "ffi/CCompound.st\0" + "ffi/CStruct.st\0" + "ffi/CUnion.st\0" /* Exception handling and ProcessEnvironment */ - "ProcEnv.st\0" - "ExcHandling.st\0" - "SysExcept.st\0" + "ProcessEnvironment.st\0" + "ProcessVariable.st\0" + "exceptions/ExceptionSet.st\0" + "exceptions/Exception.st\0" + "exceptions/Error.st\0" + "exceptions/Notification.st\0" + "exceptions/Warning.st\0" + "exceptions/Halt.st\0" + "exceptions/ArithmeticError.st\0" + "exceptions/MessageNotUnderstood.st\0" + "exceptions/ZeroDivide.st\0" + "exceptions/ProcessBeingTerminated.st\0" + "exceptions/EndOfStream.st\0" + "exceptions/NotEnoughElements.st\0" + "exceptions/InvalidValue.st\0" + "exceptions/InvalidState.st\0" + "exceptions/NotIndexable.st\0" + "exceptions/ReadOnlyObject.st\0" + "exceptions/EmptyCollection.st\0" + "exceptions/InvalidArgument.st\0" + "exceptions/AlreadyDefined.st\0" + "exceptions/ArgumentOutOfRange.st\0" + "exceptions/IndexOutOfRange.st\0" + "exceptions/InvalidSize.st\0" + "exceptions/NotFound.st\0" + "exceptions/WrongClass.st\0" + "exceptions/MustBeBoolean.st\0" + "exceptions/ProcessTerminated.st\0" + "exceptions/InvalidProcessState.st\0" + "exceptions/MutationError.st\0" + "exceptions/VMError.st\0" + "exceptions/VerificationError.st\0" + "exceptions/BadReturn.st\0" + "exceptions/UserInterrupt.st\0" + "exceptions/NoRunnableProcess.st\0" + "exceptions/PrimitiveFailed.st\0" + "exceptions/WrongArgumentCount.st\0" + "exceptions/CInterfaceError.st\0" + "exceptions/FileError.st\0" + "exceptions/NotImplemented.st\0" + "exceptions/NotYetImplemented.st\0" + "exceptions/ShouldNotImplement.st\0" + "exceptions/WrongMessageSent.st\0" + "exceptions/SubclassResponsibility.st\0" + "exceptions/UnhandledException.st\0" + "exceptions/TimeoutNotification.st\0" + "exceptions/Extensions.st\0" + "exceptions/Initialization.st\0" /* Virtual filesystem layer */ "FilePath.st\0" - "File.st\0" + "file/Extensions.st\0" + "file/Stat.st\0" + "file/File.st\0" "Directory.st\0" - "VFS.st\0" - "VFSZip.st\0" - "URL.st\0" + "file/vfs/FileWrapper.st\0" + "file/vfs/RecursiveFileWrapper.st\0" + "file/vfs/ArchiveFile.st\0" + "file/vfs/ArchiveMember.st\0" + "file/vfs/TmpFileArchiveMember.st\0" + "file/vfs/ZipFile.st\0" + "file/vfs/StoredZipMember.st\0" + "file/vfs/LimitedStream.st\0" + "file/vfs/Extensions.st\0" + "url/URL.st\0" + "url/URIResolver.st\0" + "url/Initialization.st\0" "FileStream.st\0" /* Goodies */ - "DynVariable.st\0" - "DLD.st\0" + "DynamicVariable.st\0" + "dld/Extensions.st\0" + "dld/RoundRobinStream.st\0" + "dld/DLD.st\0" "Getopt.st\0" + "GetoptExtensions.st\0" "Generator.st\0" - "StreamOps.st\0" - "Regex.st\0" - "PkgLoader.st\0" - "Autoload.st\0" + "stream/ConcatenatedStream.st\0" + "stream/FilteringStream.st\0" + "stream/CollectingStream.st\0" + "stream/PeekableStream.st\0" + "stream/LineStream.st\0" + "stream/OneOfEachStream.st\0" + "stream/Extensions.st\0" + "regex/Regex.st\0" + "regex/RegexResults.st\0" + "regex/MatchingRegexResults.st\0" + "regex/FailedMatchRegexResults.st\0" + "regex/Extensions.st\0" + "regex/Initialization.st\0" + "package/PackageSkip.st\0" + "package/PackageNotAvailable.st\0" + "package/PackageGroup.st\0" + "package/PackageDirectories.st\0" + "package/PackageContainer.st\0" + "package/PackageDirectory.st\0" + "package/PackageInfo.st\0" + "package/StarPackage.st\0" + "package/Package.st\0" + "package/DisabledPackage.st\0" + "package/TestPackage.st\0" + "package/PackageLoader.st\0" + "autoload/Extensions.st\0" + "autoload/AutoloadClass.st\0" + "autoload/Autoload.st\0" }; /* The argc and argv that are passed to libgst via gst_smalltalk_args. diff --git a/packages.xml b/packages.xml index 2c780643..1ed1c7f9 100644 --- a/packages.xml +++ b/packages.xml @@ -86,22 +86,27 @@ kernel Array.st - CompildMeth.st + CompiledMethod.st LookupTable.st RunArray.st + RunArrayExtensions.st Iterable.st - ArrayColl.st - CompiledBlk.st + ArrayedCollection.st + CompiledBlock.st Magnitude.st Semaphore.st - DeferBinding.st + DeferredVariableBinding.st Association.st - HomedAssoc.st + HomedAssociation.st ContextPart.st - MappedColl.st - SeqCollect.st - Autoload.st - DLD.st + MappedCollection.st + SequenceableCollection.st + autoload/Extensions.st + autoload/AutoloadClass.st + autoload/Autoload.st + dld/Extensions.st + dld/RoundRobinStream.st + dld/DLD.st Memory.st Set.st Bag.st @@ -112,101 +117,239 @@ Behavior.st Delay.st Metaclass.st - SmallInt.st - BlkClosure.st + SmallInteger.st + BlockClosure.st Continuation.st Generator.st Dictionary.st - MethodDict.st - SortCollect.st - BlkContext.st - DirMessage.st + MethodDictionary.st + SortedCollection.st + BlockContext.st + DirectedMessage.st MethodInfo.st Stream.st Boolean.st Directory.st - MthContext.st + MethodContext.st String.st - UniString.st - ExcHandling.st + UnicodeString.st + exceptions/ExceptionSet.st + exceptions/Exception.st Namespace.st SymLink.st - VFS.st - VFSZip.st - Builtins.st + file/vfs/FileWrapper.st + file/vfs/RecursiveFileWrapper.st + file/vfs/ArchiveFile.st + file/vfs/ArchiveMember.st + file/vfs/TmpFileArchiveMember.st + file/vfs/ZipFile.st + file/vfs/StoredZipMember.st + file/vfs/LimitedStream.st + file/vfs/Extensions.st + bootstrap/Behavior.st + bootstrap/Object.st + bootstrap/Dictionary.st + bootstrap/Class.st + bootstrap/ClassDescription.st + bootstrap/UndefinedObject.st False.st Number.st Symbol.st ByteArray.st FilePath.st - File.st - SysDict.st - ScaledDec.st + file/Extensions.st + file/Stat.st + file/File.st + SystemDictionary.st + ScaledDecimal.st FileSegment.st Object.st Time.st FileStream.st Security.st - OrderColl.st - CCallable.st - CCallback.st - CFuncs.st + OrderedCollection.st + ffi/CCallable.st + ffi/CCallbackDescriptor.st + ffi/CFunctionDescriptor.st + ffi/Extensions.st Float.st - PkgLoader.st + package/PackageSkip.st + package/PackageNotAvailable.st + package/PackageGroup.st + package/PackageDirectories.st + package/PackageContainer.st + package/PackageDirectory.st + package/PackageInfo.st + package/StarPackage.st + package/Package.st + package/DisabledPackage.st + package/TestPackage.st + package/PackageLoader.st + TextCollector.st Transcript.st - CObject.st + ffi/CObject.st + ffi/CScalar.st + ffi/CSmalltalk.st + ffi/CLongLong.st + ffi/CULongLong.st + ffi/CLong.st + ffi/CULong.st + ffi/CInt.st + ffi/CUInt.st + ffi/CShort.st + ffi/CUShort.st + ffi/CChar.st + ffi/CUChar.st + ffi/CFloat.st + ffi/CDouble.st + ffi/CLongDouble.st + ffi/CAggregate.st + ffi/CArray.st + ffi/CPtr.st + ffi/CString.st + ffi/CByte.st + ffi/CBoolean.st + ffi/CObjectExtensions.st Fraction.st Point.st + PointExtensions.st True.st - CStruct.st - IdentDict.st - PosStream.st - UndefObject.st - CType.st + ffi/CCompound.st + ffi/CStruct.st + ffi/CUnion.st + IdentityDictionary.st + PositionableStream.st + UndefinedObject.st + ffi/CType.st + ffi/CScalarCType.st + ffi/CStringCType.st + ffi/CPtrCType.st + ffi/CArrayCType.st + ffi/CTypeInitialization.st IdentitySet.st - ProcSched.st - ProcEnv.st - ValueAdapt.st - CharArray.st + ProcessorScheduler.st + ProcessEnvironment.st + ProcessVariable.st + value-adaptor/ValueAdaptor.st + value-adaptor/NullValueHolder.st + value-adaptor/ValueHolder.st + value-adaptor/ValueHolderExtensions.st + value-adaptor/Promise.st + value-adaptor/PluggableAdaptor.st + value-adaptor/DelayedAdaptor.st + CharacterArray.st Integer.st Process.st CallinProcess.st - WeakObjects.st + collection/weak/WeakArray.st + collection/weak/WeakSet.st + collection/weak/WeakKeyDictionary.st + collection/weak/WeakValueLookupTable.st + collection/weak/WeakIdentitySet.st + collection/weak/WeakKeyIdentityDictionary.st + collection/weak/WeakValueIdentityDictionary.st Character.st - UniChar.st + UnicodeCharacter.st Interval.st - RWStream.st - OtherArrays.st + ReadWriteStream.st + WordArray.st + LargeArraySubpart.st + LargeArrayedCollection.st + LargeArray.st + LargeByteArray.st + LargeWordArray.st Class.st - LargeInt.st + LargeIntegeger.st + LargeNegativeInteger.st + LargePositiveInteger.st + LargeZeroInteger.st Random.st WriteStream.st - ClassDesc.st + ClassDescription.st Link.st ReadStream.st - ObjMemory.st + ObjectMemory.st Collection.st LinkedList.st Rectangle.st - AnsiDates.st - CompildCode.st + RectangleExtensions.st + DateTime.st + Duration.st + CompiledCode.st LookupKey.st - BindingDict.st - AbstNamespc.st - RootNamespc.st - SysExcept.st - DynVariable.st - HashedColl.st - FileDescr.st + BindingDictionary.st + AbstractNamespace.st + RootNamespace.st + exceptions/Error.st + exceptions/Notification.st + exceptions/Warning.st + exceptions/Halt.st + exceptions/ArithmeticError.st + exceptions/MessageNotUnderstood.st + exceptions/ZeroDivide.st + exceptions/ProcessBeingTerminated.st + exceptions/EndOfStream.st + exceptions/NotEnoughElements.st + exceptions/InvalidValue.st + exceptions/InvalidState.st + exceptions/NotIndexable.st + exceptions/ReadOnlyObject.st + exceptions/EmptyCollection.st + exceptions/InvalidArgument.st + exceptions/AlreadyDefined.st + exceptions/ArgumentOutOfRange.st + exceptions/IndexOutOfRange.st + exceptions/InvalidSize.st + exceptions/NotFound.st + exceptions/WrongClass.st + exceptions/MustBeBoolean.st + exceptions/ProcessTerminated.st + exceptions/InvalidProcessState.st + exceptions/MutationError.st + exceptions/VMError.st + exceptions/VerificationError.st + exceptions/BadReturn.st + exceptions/UserInterrupt.st + exceptions/NoRunnableProcess.st + exceptions/PrimitiveFailed.st + exceptions/WrongArgumentCount.st + exceptions/CInterfaceError.st + exceptions/FileError.st + exceptions/NotImplemented.st + exceptions/NotYetImplemented.st + exceptions/ShouldNotImplement.st + exceptions/WrongMessageSent.st + exceptions/SubclassResponsibility.st + exceptions/UnhandledException.st + exceptions/TimeoutNotification.st + exceptions/Extensions.st + exceptions/Initialization.st + DynamicVariable.st + HashedCollection.st + FileDescriptor.st FloatD.st FloatE.st FloatQ.st - URL.st - VarBinding.st + url/URL.st + url/URIResolver.st + url/Initialization.st + VariableBinding.st RecursionLock.st Getopt.st - Regex.st - StreamOps.st + GetoptExtensions.st + regex/Regex.st + regex/RegexResults.st + regex/MatchingRegexResults.st + regex/FailedMatchRegexResults.st + regex/Extensions.st + regex/Initialization.st + stream/ConcatenatedStream.st + stream/FilteringStream.st + stream/CollectingStream.st + stream/PeekableStream.st + stream/LineStream.st + stream/OneOfEachStream.st + stream/Extensions.st