.
--- a/ArrColl.st Fri May 19 15:33:11 1995 +0200
+++ b/ArrColl.st Wed May 24 14:44:58 1995 +0200
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Attic/ArrColl.st,v 1.17 1995-05-02 23:55:26 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/ArrColl.st,v 1.18 1995-05-24 12:41:13 claus Exp $
'!
!ArrayedCollection class methodsFor:'documentation'!
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Attic/ArrColl.st,v 1.17 1995-05-02 23:55:26 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/ArrColl.st,v 1.18 1995-05-24 12:41:13 claus Exp $
"
!
@@ -200,8 +200,10 @@
"special case for Array, which has no named instance vars"
- self class instSize == 0 ifTrue:[
- ^ self class new:size
+ |cls|
+
+ (cls := self class) instSize == 0 ifTrue:[
+ ^ cls new:size
].
^ super copyEmptyAndGrow:size
! !
--- a/Array.st Fri May 19 15:33:11 1995 +0200
+++ b/Array.st Wed May 24 14:44:58 1995 +0200
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Array.st,v 1.26 1995-05-19 03:55:37 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Array.st,v 1.27 1995-05-24 12:41:18 claus Exp $
'!
!Array class methodsFor:'documentation'!
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Array.st,v 1.26 1995-05-19 03:55:37 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Array.st,v 1.27 1995-05-24 12:41:18 claus Exp $
"
!
@@ -697,8 +697,7 @@
}
}
}
-%}
-.
+%}.
^ false
!
@@ -741,8 +740,7 @@
}
}
}
-%}
-.
+%}.
^ 0
!
@@ -774,9 +772,57 @@
RETURN ( __MKSMALLINT(0) );
}
}
+%}.
+ ^ super identityIndexOf:anElement startingAt:start
+!
+
+identityIndexOf:anElement or:alternative
+ "search the array for anElement or alternative;
+ return the index of anElement if found, or the index of anAlternative,
+ if not found. If anAlternative is also not found, return 0.
+ This is a special interface for high-speed searching in an array
+ and at the same time searching for an empty slot.
+ Do not use this method for your application classes, since it is
+ not portable (i.e. other smalltalks do not offer this)"
+
+%{ /* NOCONTEXT */
+
+ REGISTER int index;
+ REGISTER OBJ o, el1, el2;
+ REGISTER OBJ *op;
+ REGISTER unsigned int nIndex;
+ int altIndex = 0;
+ int nInsts;
+
+ index = 0;
+ nInsts = _intVal(_ClassInstPtr(__qClass(self))->c_ninstvars);
+ index += nInsts;
+ nIndex = __BYTES2OBJS__(__qSize(self) - OHDR_SIZE);
+ el1 = anElement; el2 = alternative;
+ op = & (_InstPtr(self)->i_instvars[index]);
+ while (index++ < nIndex) {
+ if ((o = *op++) == el1) {
+ RETURN ( __MKSMALLINT(index - nInsts) );
+ }
+ if (o == el2) {
+ if (altIndex == 0) {
+ altIndex = index;
+ }
+ }
+ }
+ RETURN ( __MKSMALLINT(altIndex) );
%}
-.
- ^ super identityIndexOf:anElement startingAt:start
+
+ "
+ #(1 2 3 4 5 6 7 8 9) identityIndexOf:3 or:5
+ #(1 2 0 4 5 6 7 8 9) identityIndexOf:3 or:5
+ #(1 2 0 4 5 6 7 3 9) identityIndexOf:3 or:5
+ #(1 2 3 4 5 nil 7 3 9) identityIndexOf:3 or:nil
+ #(1 2 nil 4 5 6 7 3 9) identityIndexOf:3 or:nil
+ #(1 2 nil 4 5 6 7 8 9) identityIndexOf:3 or:nil
+ #() identityIndexOf:3 or:nil
+ #(1 2) identityIndexOf:3 or:nil
+ "
! !
!Array methodsFor:'printing & storing'!
--- a/ArrayedCollection.st Fri May 19 15:33:11 1995 +0200
+++ b/ArrayedCollection.st Wed May 24 14:44:58 1995 +0200
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/ArrayedCollection.st,v 1.17 1995-05-02 23:55:26 claus Exp $
+$Header: /cvs/stx/stx/libbasic/ArrayedCollection.st,v 1.18 1995-05-24 12:41:13 claus Exp $
'!
!ArrayedCollection class methodsFor:'documentation'!
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/ArrayedCollection.st,v 1.17 1995-05-02 23:55:26 claus Exp $
+$Header: /cvs/stx/stx/libbasic/ArrayedCollection.st,v 1.18 1995-05-24 12:41:13 claus Exp $
"
!
@@ -200,8 +200,10 @@
"special case for Array, which has no named instance vars"
- self class instSize == 0 ifTrue:[
- ^ self class new:size
+ |cls|
+
+ (cls := self class) instSize == 0 ifTrue:[
+ ^ cls new:size
].
^ super copyEmptyAndGrow:size
! !
--- a/Autoload.st Fri May 19 15:33:11 1995 +0200
+++ b/Autoload.st Wed May 24 14:44:58 1995 +0200
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1991 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Autoload.st,v 1.21 1995-05-16 17:05:32 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Autoload.st,v 1.22 1995-05-24 12:41:24 claus Exp $
'!
!Autoload class methodsFor:'documentation'!
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Autoload.st,v 1.21 1995-05-16 17:05:32 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Autoload.st,v 1.22 1995-05-24 12:41:24 claus Exp $
"
!
@@ -289,12 +289,55 @@
fileOutDefinitionOn:aStream
"print an expression to define myself on aStream.
Since autoloaded classes dont know their real definition, simply
- output some comment string making things clear."
+ output some comment string making things clear in the browser."
+
+ |myName fileName nm|
(self == Autoload) ifTrue:[^ super fileOutDefinitionOn:aStream].
- aStream nextPutAll:'''' , self name , ' is not yet loaded.'; cr.
- aStream nextPutAll:' to load, execute: '.
- aStream cr; cr; spaces:4; nextPutAll:self name , ' autoload'; cr.
- aStream nextPutAll:''''.
+ myName := self name.
+ aStream nextPutAll:'''' ; nextPutAll:'Notice from Autoload:'; cr; cr;
+ spaces:4; nextPutAll:myName , ' is not yet loaded.'; cr; cr.
+ aStream nextPutAll:'to load, execute: '.
+ aStream cr; cr; spaces:4; nextPutAll:myName , ' autoload'; cr.
+
+ "
+ the following is simply informative ...
+ actually, its a hack & kludge - there ought to be a method for this
+ in Smalltalk
+ (knowing the details of loading here is no good coding style)
+ "
+ fileName := Smalltalk fileNameForClass:myName.
+ ObjectFileLoader notNil ifTrue:[
+ (nm := Smalltalk libraryFileNameOfClass:myName) notNil ifTrue:[
+ nm := nm , ' (a classLibrary, possibly including more classes)'
+ ] ifFalse:[
+ nm := Smalltalk getBinaryFileName:(fileName , '.so').
+ nm isNil ifTrue:[
+ nm := Smalltalk getBinaryFileName:(fileName , '.o')
+ ].
+ nm notNil ifTrue:[
+ nm := nm , ' (a classBinary)'
+ ]
+ ].
+ ].
+ nm isNil ifTrue:[
+ nm := Smalltalk getFileInFileName:(fileName , '.st').
+ nm isNil ifTrue:[
+ nm := Smalltalk getSourceFileName:(fileName , '.st').
+ ].
+ ].
+ nm notNil ifTrue:[
+ aStream cr; nextPutAll:'When accessed, ' , myName , ' will automatically be loaded'; cr.
+ aStream nextPutAll:'from: '; cr; spaces:4; nextPutAll:nm.
+ nm asFilename isSymbolicLink ifTrue:[
+ aStream cr; cr.
+ aStream nextPutAll:'which is a link to: '; cr; spaces:4;
+ nextPutAll:(nm asFilename linkInfo at:#path).
+ ]
+ ] ifFalse:[
+ aStream cr; nextPutAll:'there is currently no file to load ' , myName , ' from.'.
+ aStream cr; nextPutAll:'When accessed, an error will be reported.'.
+ ].
+ aStream cr; nextPutAll:''''.
! !
--- a/Behavior.st Fri May 19 15:33:11 1995 +0200
+++ b/Behavior.st Wed May 24 14:44:58 1995 +0200
@@ -23,7 +23,7 @@
COPYRIGHT (c) 1988 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Behavior.st,v 1.38 1995-05-16 17:05:43 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Behavior.st,v 1.39 1995-05-24 12:41:30 claus Exp $
'!
!Behavior class methodsFor:'documentation'!
@@ -44,7 +44,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Behavior.st,v 1.38 1995-05-16 17:05:43 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Behavior.st,v 1.39 1995-05-24 12:41:30 claus Exp $
"
!
@@ -54,7 +54,7 @@
so here is where most of the class messages end up being implemented.
(to answer a FAQ: 'Point basicNew' will be done here :-)
- Beginners should keep in mind, that all classes are instances of subclasses
+ Beginners should keep in mind, that all classes are instances (of subclasses)
of Behavior, therefore you will find the above mentioned 'basicNew:' method
under the 'instance'-methods of Behavior - NOT under the class methods
('Behavior new' will create and return a new class, while sending 'new' to
@@ -70,21 +70,96 @@
from the selectors (there is no Dictionary, but two separate Arrays)
- this avoids the need for knowledge about Dictionaries in the runtime library (VM)
(lookup and search in these is seldom anyway, so the added benefit from using a
- hashed dictionary is almost void).
+ hashed dictionary is almost void).
+ For ST-80 compatibility, this will be replaced by a single instance of
+ MethodDIctionary (which will NOT be a true dictionary, but an Array with
+ alternating selector/method entries).
+ To be prepared for this change, please do NOT directly use the methodArray
+ and selectorArray instVars.
Instance variables:
superclass <Class> the receivers superclass
+
otherSuperclasses <Array of Class> experimental: other superclasses
+ a hook for experimental multiple inheritance
+ implementations
+
selectorArray <Array of Symbol> the selectors for which inst-methods are defined here
+
methodArray <Array of Method> the inst-methods corresponding to the selectors
+
instSize <SmallInteger> the number of instance variables
+
flags <SmallInteger> special flag bits coded in a number
+ not for application use
flag bits (see stc.h):
NOTICE: layout known by compiler and runtime system; be careful when changing
"
+!
+
+virtualMachineRelationship
+"
+ Instances of Behavior and subclasses (i.e. in sloppy words: classes)
+ play a special role w.r.t. the VM. Only objects whose class-slot is marked
+ as being behaviorLike (in the flag-instvar) are considered to be classLike
+ and a message lookup will be done for it in the well known way.
+ Thus, if an object has a class for which its class does NOT have
+ this flag bit set, will trigger an error on a message send.
+
+ Why is this so:
+
+ the above lets every object play the role of a class,
+ which has been flagged as behaviorLike in its class's flag.
+ Thus, you can create arbitrary new classLike objects and have the VM
+ play with them.
+ This may offer the flexibility to create a totally different object scheme
+ on top of ST/X (for example: Self like objects).
+
+ However, the VM trusts the isbehaviorLike flag - if it is set for some
+ object, it expects the object selector and methodDictionaries to be at
+ the position as defined here.
+ The VM (and the system) may crash badly, if this is not the case.
+ Since every class in the system derives from Behavior, the flag setting
+ (and instance variable layout) is correct for this class hierarchy.
+ You normally do not have to care about the above details.
+
+ Examples (only of theoretical interrest):
+ take away the behaviorLike-flag from a class.
+ -> The instances will not understand any messages, since the VM will
+ not recognize its class as being a class ...
+
+ |newMeta notRecognizedAsClass someInstance|
+
+ newMeta := Metaclass new.
+ newMeta flags:0.
+
+ notRecognizedAsClass := newMeta new.
+
+ someInstance := notRecognizedAsClass new.
+ someInstance perform:#isNil
+
+ Example:
+ creating totally anonymous classes:
+
+ |newClass someInstance|
+
+ newClass := Class new.
+ someInstance := newClass new.
+ someInstance inspect
+
+ Example:
+ creating totally anonymouse metaclasses:
+
+ |newMeta newClass someInstance|
+
+ newMeta := Metaclass new.
+ newClass := newMeta new.
+ someInstance := newClass new.
+ someInstance inspect
+"
! !
!Behavior class methodsFor:'queries'!
@@ -98,7 +173,14 @@
!Behavior class methodsFor:'creating new classes'!
new
- "creates and return a new class"
+ "creates and return a new behavior (which is like a class,
+ but without the symbolic & name information).
+ Not for normal applications.
+ Sending the returned behavior the #new message gives you
+ an instance if it.
+
+ Notice: the returned class is given a superclass of Object;
+ this allows for its new instances to be inspected and the like."
|newClass|
@@ -109,6 +191,18 @@
instSize:0
flags:(self flagBehavior).
^ newClass
+
+ "
+ Behavior new <- a new behavior
+ Behavior new new <- an instance of it
+ ClassDescription new <- a new classDescription
+ ClassDescription new new <- an instance of it
+ Class new <- a new class
+ Class new new <- an instance of it
+ Metaclass new <- a new metaclass
+ Metaclass new new <- an instance (i.e. a class) of it
+ Metaclass new new new <- an instance of this new class
+ "
! !
!Behavior class methodsFor:'private '!
@@ -928,13 +1022,17 @@
!Behavior class methodsFor:'flag bit constants'!
flagNotIndexed
- "return the flag code for non-indexed instances"
+ "return the flag code for non-indexed instances.
+ You have to mask the flag value with indexMask when comparing
+ it with flagNotIndexed."
^ 0
!
flagBytes
- "return the flag code for byte-valued indexed instances"
+ "return the flag code for byte-valued indexed instances.
+ You have to mask the flag value with indexMask when comparing
+ it with flagBytes."
%{ /* NOCONTEXT */
/* this is defined as a primitive to get defines from stc.h */
@@ -947,7 +1045,9 @@
!
flagWords
- "return the flag code for word-valued indexed instances (i.e. 2-byte)"
+ "return the flag code for word-valued indexed instances (i.e. 2-byte).
+ You have to mask the flag value with indexMask when comparing
+ it with flagWords."
%{ /* NOCONTEXT */
/* this is defined as a primitive to get defines from stc.h */
@@ -960,7 +1060,9 @@
!
flagLongs
- "return the flag code for long-valued indexed instances (i.e. 4-byte)"
+ "return the flag code for long-valued indexed instances (i.e. 4-byte).
+ You have to mask the flag value with indexMask when comparing
+ it with flagLongs."
%{ /* NOCONTEXT */
/* this is defined as a primitive to get defines from stc.h */
@@ -973,7 +1075,9 @@
!
flagFloats
- "return the flag code for float-valued indexed instances (i.e. 4-byte reals)"
+ "return the flag code for float-valued indexed instances (i.e. 4-byte reals).
+ You have to mask the flag value with indexMask when comparing
+ it with flagFloats."
%{ /* NOCONTEXT */
/* this is defined as a primitive to get defines from stc.h */
@@ -986,7 +1090,9 @@
!
flagDoubles
- "return the flag code for double-valued indexed instances (i.e. 8-byte reals)"
+ "return the flag code for double-valued indexed instances (i.e. 8-byte reals).
+ You have to mask the flag value with indexMask when comparing
+ it with flagDoubles."
%{ /* NOCONTEXT */
/* this is defined as a primitive to get defines from stc.h */
@@ -999,7 +1105,9 @@
!
flagPointers
- "return the flag code for pointer indexed instances (i.e. Array of object)"
+ "return the flag code for pointer indexed instances (i.e. Array of object).
+ You have to mask the flag value with indexMask when comparing
+ it with flagPointers."
%{ /* NOCONTEXT */
/* this is defined as a primitive to get defines from stc.h */
@@ -1012,7 +1120,9 @@
!
flagWeakPointers
- "return the flag code for weak pointer indexed instances (i.e. WeakArray)"
+ "return the flag code for weak pointer indexed instances (i.e. WeakArray).
+ You have to mask the flag value with indexMask when comparing
+ it with flagWeakPointers."
%{ /* NOCONTEXT */
/* this is defined as a primitive to get defines from stc.h */
@@ -1032,17 +1142,50 @@
!
flagBehavior
- "return the flag code which marks Behavior-like instances"
+ "return the flag code which marks Behavior-like instances.
+ You have to check this single bit in the flag value when
+ checking for behaviors."
%{ /* NOCONTEXT */
/* this is defined as a primitive to get defines from stc.h */
RETURN ( _MKSMALLINT(BEHAVIOR_INSTS) );
%}
+
+ "consistency check:
+ all class-entries must be behaviors;
+ all behaviors must be flagged so (in its class's flags)
+ (otherwise, VM will bark)
+ all non-behaviors may not be flagged
+
+ |bit|
+ bit := Class flagBehavior.
+
+ ObjectMemory allObjectsDo:[:o|
+ o isBehavior ifTrue:[
+ (o class flags bitTest:bit) ifFalse:[
+ self halt
+ ].
+ ] ifFalse:[
+ (o class flags bitTest:bit) ifTrue:[
+ self halt
+ ].
+ ].
+ o class isBehavior ifFalse:[
+ self halt
+ ] ifTrue:[
+ (o class class flags bitTest:bit) ifFalse:[
+ self halt
+ ]
+ ]
+ ]
+ "
!
flagBlock
- "return the flag code which marks Block-like instances"
+ "return the flag code which marks Block-like instances.
+ You have to check this single bit in the flag value when
+ checking for blocks."
%{ /* NOCONTEXT */
/* this is defined as a primitive to get defines from stc.h */
@@ -1052,7 +1195,9 @@
!
flagMethod
- "return the flag code which marks Method-like instances"
+ "return the flag code which marks Method-like instances.
+ You have to check this single bit in the flag value when
+ checking for methods."
%{ /* NOCONTEXT */
/* this is defined as a primitive to get defines from stc.h */
@@ -1062,7 +1207,9 @@
!
flagContext
- "return the flag code which marks Context-like instances"
+ "return the flag code which marks Context-like instances.
+ You have to check this single bit in the flag value when
+ checking for contexts."
%{ /* NOCONTEXT */
/* this is defined as a primitive to get defines from stc.h */
@@ -1072,7 +1219,9 @@
!
flagBlockContext
- "return the flag code which marks BlockContext-like instances"
+ "return the flag code which marks BlockContext-like instances.
+ You have to check this single bit in the flag value when
+ checking for blockContexts."
%{ /* NOCONTEXT */
/* this is defined as a primitive to get defines from stc.h */
@@ -1082,7 +1231,9 @@
!
flagFloat
- "return the flag code which marks Float-like instances"
+ "return the flag code which marks Float-like instances.
+ You have to check this single bit in the flag value when
+ checking for floats."
%{ /* NOCONTEXT */
/* this is defined as a primitive to get defines from stc.h */
@@ -1092,7 +1243,9 @@
!
flagSymbol
- "return the flag code which marks Symbol-like instances"
+ "return the flag code which marks Symbol-like instances.
+ You have to check this single bit in the flag value when
+ checking for symbols."
%{ /* NOCONTEXT */
/* this is defined as a primitive to get defines from stc.h */
@@ -1113,6 +1266,29 @@
^ 'someBehavior'
!
+displayString
+ "although behaviors have no name, we return something
+ useful here - there are many places (inspectors) where
+ a classes name is asked for.
+ Implementing this message here allows instances of anonymous classes
+ to show a reasonable name."
+
+ ^ 'someBehavior'
+!
+
+category
+ "return the category of the class.
+ Returning nil here, since Behavior does not define a category
+ (only ClassDescriptions do)."
+
+ ^ nil
+
+ "
+ Point category
+ Behavior new category
+ "
+!
+
superclass
"return the receivers superclass"
--- a/CharArray.st Fri May 19 15:33:11 1995 +0200
+++ b/CharArray.st Wed May 24 14:44:58 1995 +0200
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1994 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Attic/CharArray.st,v 1.22 1995-05-18 22:49:21 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/CharArray.st,v 1.23 1995-05-24 12:41:42 claus Exp $
'!
!CharacterArray class methodsFor:'documentation'!
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Attic/CharArray.st,v 1.22 1995-05-18 22:49:21 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/CharArray.st,v 1.23 1995-05-24 12:41:42 claus Exp $
"
!
@@ -1473,7 +1473,7 @@
] ifFalse:[
matchScanArray := self class matchScanArrayFrom:self.
matchScanArray isNil ifTrue:[
- 'CHARARRAY: invalid matchpattern:' errorPrint. self errorPrintNL.
+ 'CHARARRAY: invalid matchpattern:' infoPrint. self infoPrintNL.
^ false
].
PreviousMatch := self -> matchScanArray.
--- a/CharacterArray.st Fri May 19 15:33:11 1995 +0200
+++ b/CharacterArray.st Wed May 24 14:44:58 1995 +0200
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1994 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/CharacterArray.st,v 1.22 1995-05-18 22:49:21 claus Exp $
+$Header: /cvs/stx/stx/libbasic/CharacterArray.st,v 1.23 1995-05-24 12:41:42 claus Exp $
'!
!CharacterArray class methodsFor:'documentation'!
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/CharacterArray.st,v 1.22 1995-05-18 22:49:21 claus Exp $
+$Header: /cvs/stx/stx/libbasic/CharacterArray.st,v 1.23 1995-05-24 12:41:42 claus Exp $
"
!
@@ -1473,7 +1473,7 @@
] ifFalse:[
matchScanArray := self class matchScanArrayFrom:self.
matchScanArray isNil ifTrue:[
- 'CHARARRAY: invalid matchpattern:' errorPrint. self errorPrintNL.
+ 'CHARARRAY: invalid matchpattern:' infoPrint. self infoPrintNL.
^ false
].
PreviousMatch := self -> matchScanArray.
--- a/Class.st Fri May 19 15:33:11 1995 +0200
+++ b/Class.st Wed May 24 14:44:58 1995 +0200
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Class.st,v 1.43 1995-05-19 13:33:11 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Class.st,v 1.44 1995-05-24 12:41:53 claus Exp $
'!
!Class class methodsFor:'documentation'!
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Class.st,v 1.43 1995-05-19 13:33:11 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Class.st,v 1.44 1995-05-24 12:41:53 claus Exp $
"
!
@@ -114,18 +114,6 @@
^ FileOutErrorSignal
! !
-!Class class methodsFor:'creating new classes'!
-
-new
- "creates and returs a new class"
-
- |newClass|
-
- newClass := super new.
-"/ newClass setComment:(self comment) category:(self category).
- ^ newClass
-! !
-
!Class class methodsFor:'enumeration '!
allClassesInCategory:aCategory do:aBlock
@@ -1819,7 +1807,7 @@
fileOutOn:aStream
"file out my definition and all methods onto aStream"
- |collectionOfCategories copyrightText sep comment|
+ |collectionOfCategories copyrightText sep comment cls|
"
if there is a copyright method, add a copyright comment
@@ -1830,12 +1818,12 @@
copyright string at the beginning be preserved .... even if the
code was edited in the browser and filedOut.
"
- (self class selectorArray includes:#copyright) ifTrue:[
+ ((cls := self class) selectorArray includes:#copyright) ifTrue:[
"
get the copyright methods source,
and insert at beginning.
"
- copyrightText := (self class compiledMethodAt:#copyright) source.
+ copyrightText := (cls compiledMethodAt:#copyright) source.
copyrightText isNil ifTrue:[
"
no source available - trigger an error
@@ -1966,8 +1954,9 @@
].
aStream := FileStream newFileNamed:fileName.
aStream isNil ifTrue:[
- ^ FileOutErrorSignal raiseRequestWith:fileName
- errorString:('cannot create file:', fileName)
+ ^ FileOutErrorSignal
+ raiseRequestWith:fileName
+ errorString:('cannot create file:', fileName)
].
self fileOutCategory:aCategory on:aStream.
aStream close
@@ -1999,8 +1988,9 @@
].
aStream := FileStream newFileNamed:fileName.
aStream isNil ifTrue:[
- ^ FileOutErrorSignal raiseRequestWith:fileName
- errorString:('cannot create file:', fileName)
+ ^ FileOutErrorSignal
+ raiseRequestWith:fileName
+ errorString:('cannot create file:', fileName)
].
self fileOutMethod:aMethod on:aStream.
aStream close
@@ -2011,14 +2001,16 @@
"create a file 'class.st' consisting of all methods in myself.
If the current project is not nil, create the file in the projects
directory. Care is taken, to not clobber any existing file in
- case of errors (for example: disk full). Also, since the classes
- methods need a valid sourcefile, the current sourceFile cannot be rewritten,
- but must be kept around until the fileOut is finished."
-
- |aStream baseName dirName fileName newFileName needRename|
+ case of errors (for example: disk full).
+ Also, since the classes methods need a valid sourcefile, the current
+ sourceFile may not be rewritten."
+
+ |aStream baseName dirName fileName newFileName needRename
+ mySourceFileName sameFile|
baseName := (Smalltalk fileNameForClass:self name).
fileName := baseName , '.st'.
+
"
this test allows a smalltalk to be built without Projects/ChangeSets
"
@@ -2028,12 +2020,31 @@
dirName := ''
].
fileName := dirName , fileName.
+
"
if file exists, copy the existing to a .sav-file,
create the new file as XXX.new-file,
and, if that worked rename afterwards ...
"
fileName asFilename exists ifTrue:[
+ "
+ check for overwriting my current source file
+ this is not allowed, since it would clobber my methods source
+ file ... you have to save it to some other place.
+ This happens if you ask for a fileOut into the source-directory
+ (from which my methods get their source)
+ "
+ mySourceFileName := Smalltalk getSourceFileName:classFilename.
+ sameFile := (fileName = mySourceFileName).
+ sameFile ifFalse:[
+ sameFile := (fileName asFilename info at:#id) == (mySourceFileName asFilename info at:#id)
+ ].
+ sameFile ifTrue:[
+ ^ FileOutErrorSignal
+ raiseRequestWith:fileName
+ errorString:('may not overwrite sourcefile:', fileName)
+ ].
+
fileName asFilename copyTo:('/tmp/' , baseName , '.sav').
newFileName := dirName , baseName , '.new'.
needRename := true
@@ -2044,8 +2055,9 @@
aStream := FileStream newFileNamed:newFileName.
aStream isNil ifTrue:[
- ^ FileOutErrorSignal raiseRequestWith:newFileName
- errorString:('cannot create file:', newFileName)
+ ^ FileOutErrorSignal
+ raiseRequestWith:newFileName
+ errorString:('cannot create file:', newFileName)
].
self fileOutOn:aStream.
aStream close.
@@ -2080,7 +2092,9 @@
fileName := (Smalltalk fileNameForClass:self name) , '.st'.
aStream := FileStream newFileNamed:fileName in:aFileDirectory.
aStream isNil ifTrue:[
- ^ self error:('cannot create source file:', fileName)
+ ^ FileOutErrorSignal
+ raiseRequestWith:fileName
+ errorString:('cannot create file:', fileName)
].
self fileOutOn:aStream.
aStream close
--- a/ClassDescr.st Fri May 19 15:33:11 1995 +0200
+++ b/ClassDescr.st Wed May 24 14:44:58 1995 +0200
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1993 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Attic/ClassDescr.st,v 1.15 1995-05-01 21:28:53 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/ClassDescr.st,v 1.16 1995-05-24 12:42:00 claus Exp $
'!
!ClassDescription class methodsFor:'documentation'!
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Attic/ClassDescr.st,v 1.15 1995-05-01 21:28:53 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/ClassDescr.st,v 1.16 1995-05-24 12:42:00 claus Exp $
"
!
@@ -50,7 +50,8 @@
"
this class has been added for ST-80 compatibility only.
All class stuff used to be in Behavior and Class - but, to be
- able to file in some PD code, it became nescessary to add it.
+ able to file in some PD code, it became nescessary to add C'Description
+ in between it.
ClassDescription adds some descriptive information to the basic
Behavior class.
@@ -65,6 +66,19 @@
"
! !
+!ClassDescription class methodsFor:'instance creation'!
+
+new
+ "creates and returns a new class.
+ Redefined to give the new class at least some name info"
+
+ |newClass|
+
+ newClass := super new.
+ newClass setName:('some' , self name).
+ ^ newClass
+! !
+
!ClassDescription methodsFor:'special accessing'!
setName:aString
--- a/ClassDescription.st Fri May 19 15:33:11 1995 +0200
+++ b/ClassDescription.st Wed May 24 14:44:58 1995 +0200
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1993 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/ClassDescription.st,v 1.15 1995-05-01 21:28:53 claus Exp $
+$Header: /cvs/stx/stx/libbasic/ClassDescription.st,v 1.16 1995-05-24 12:42:00 claus Exp $
'!
!ClassDescription class methodsFor:'documentation'!
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/ClassDescription.st,v 1.15 1995-05-01 21:28:53 claus Exp $
+$Header: /cvs/stx/stx/libbasic/ClassDescription.st,v 1.16 1995-05-24 12:42:00 claus Exp $
"
!
@@ -50,7 +50,8 @@
"
this class has been added for ST-80 compatibility only.
All class stuff used to be in Behavior and Class - but, to be
- able to file in some PD code, it became nescessary to add it.
+ able to file in some PD code, it became nescessary to add C'Description
+ in between it.
ClassDescription adds some descriptive information to the basic
Behavior class.
@@ -65,6 +66,19 @@
"
! !
+!ClassDescription class methodsFor:'instance creation'!
+
+new
+ "creates and returns a new class.
+ Redefined to give the new class at least some name info"
+
+ |newClass|
+
+ newClass := super new.
+ newClass setName:('some' , self name).
+ ^ newClass
+! !
+
!ClassDescription methodsFor:'special accessing'!
setName:aString
--- a/Filename.st Fri May 19 15:33:11 1995 +0200
+++ b/Filename.st Wed May 24 14:44:58 1995 +0200
@@ -20,7 +20,7 @@
COPYRIGHT (c) 1992 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Filename.st,v 1.25 1995-05-01 21:29:49 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Filename.st,v 1.26 1995-05-24 12:42:19 claus Exp $
'!
!Filename class methodsFor:'documentation'!
@@ -41,7 +41,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Filename.st,v 1.25 1995-05-01 21:29:49 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Filename.st,v 1.26 1995-05-24 12:42:19 claus Exp $
"
!
@@ -200,7 +200,7 @@
"ST-80 compatibility.
what does this do ? (used in FileNavigator-goody)"
- ^ '/'
+ ^ #('/')
! !
!Filename methodsFor:'instance creation'!
@@ -538,6 +538,19 @@
"
!
+isSymbolicLink
+ "return true, if the file represented by the receiver is a symbolic
+ link. Notice that not all OS's support symbolic links; those that do
+ not will always return false."
+
+ ^ OperatingSystem isSymbolicLink:nameString
+
+ "
+ 'Make.proto' asFilename isSymbolicLink
+ 'Makefile' asFilename isSymbolicLink
+ "
+!
+
filesMatching:aPattern
^ self directoryContents select:[:name | aPattern match:name]
@@ -663,19 +676,73 @@
info
"return the files info; that is a collection of file attributes,
(actually a dictionary) where the keys are #type, #uid, #gid, #size etc.
- The actual amount and detail returned may depend on the OS used."
+ The actual amount and detail returned may depend on the OS used.
+ On unix, if you ask for the info of a symbolic link, the target
+ files info is returned.
+
+ On unix, the contents is:
+ id -> the inode number (integer)
+ uid -> the numeric user id of the files owner
+ gid -> the numeric group id of the files owner
+ statusChanged -> the absoluteTime when the files status changed last
+ (i.e. protection change, owner change etc.)
+ accessed -> the absoluteTime when the file was last accessed
+ modified -> the absoluteTime when the file was last modified
+ size -> the size (in bytes) of the file
+ type -> the files type (#regular, #directory, #characterSpecial)
+ mode -> the files access protection bits (rwxrwxrwx mask).
+
+ The minimum returned info (i.e. on all OS's) will consist of at least:
+ modified
+ size
+ type
+
+ Some OS's (VMS) may return more info.
+
+ Dont expect things like uid/gid/mode to be there; write your application
+ to either handle the cases where info-entries are not present,
+ or (better) use one of isXXXX query methods.
+ "
^ OperatingSystem infoOf:nameString
"
Filename currentDirectory info
+ '/dev/null' asFilename info
'Make.proto' asFilename info
+ 'source/Point.st' asFilename info
+ '../../libbasic/Point.st' asFilename info
+ "
+!
+
+linkInfo
+ "return the files info if its a symbolic link; nil otherwise.
+ On OS's which do not support symbolic links, nil is always returned.
+ The information is the same as returned by #info, except that
+ information for the symbolic link is returned (while #info returns
+ the info of the target file, accesed via the symbolic link).
+
+ In addition to the normal entries, Unix returns an additional entry:
+ path -> the target files pathname
+
+ See the comment in #info for more details."
+
+ ^ OperatingSystem linkInfoOf:nameString
+
+ "
+ Filename currentDirectory linkInfo
+ '/dev/null' asFilename linkInfo
+ 'Make.proto' asFilename linkInfo
+ 'Make.proto' asFilename linkInfo at:#path
+ 'source/Point.st' asFilename linkInfo
+ '../../libbasic/Point.st' asFilename linkInfo
"
!
dates
"return the files modification and access times as an object (currently a dictionary)
- that responds to the at: message with arguments #modified, #accessed or #statusChanged."
+ that responds to the at: message with arguments
+ #modified, #accessed or #statusChanged."
|info dates|
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/Geometric.st Wed May 24 14:44:58 1995 +0200
@@ -0,0 +1,96 @@
+"
+ COPYRIGHT (c) 1995 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+Object subclass:#Geometric
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Graphics-Geometry'
+!
+
+Geometric comment:'
+COPYRIGHT (c) 1995 by Claus Gittinger
+ All Rights Reserved
+
+$Header: /cvs/stx/stx/libbasic/Geometric.st,v 1.1 1995-05-24 12:42:27 claus Exp $
+'!
+
+!Geometric class methodsFor:'documentation'!
+
+copyright
+"
+ COPYRIGHT (c) 1995 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+!
+
+version
+"
+$Header: /cvs/stx/stx/libbasic/Geometric.st,v 1.1 1995-05-24 12:42:27 claus Exp $
+"
+!
+
+documentation
+"
+ Abstract superclass for geometric figures.
+ Concrete classes are (currently) Rectangle, Polygon and the classes
+ found in goodies/shape.
+
+ These are not graphical objects, but pure mathematical ones.
+ I.e. instances do not carry graphics attributes such as color, lineWidth etc.
+ Use instances of (subclasses) of DisplayObject or (the soon to be
+ implemented GraphicsAttributesWrapper.
+
+ Notice: ST/X does not use Geometric instances for drawing (yet).
+ This class exists mainly to provide have a superclass around,
+ when ST-80 geometry classes are to be filed in.
+"
+! !
+
+!Geometric methodsFor:'displaying'!
+
+displayOn:aGC
+ "display myself on a graphicsContext; the current graphics
+ attributes are used. The default here is to display the outline."
+
+ ^ self displayStrokedOn:aGC
+!
+
+displayStrokedOn:aGC
+ "display my outline on a graphicsContext; the current graphics
+ attributes are usedSince we do not know how to do it, nothing is
+ drawn here."
+
+"/ could be:
+"/ ^ self subclassResponsibility
+
+ ^ self
+!
+
+displayFilledOn:aGC
+ "display myself filled on a graphicsContext; the current graphics
+ attributes are used. Since we do not know how to do it, nothing is
+ drawn here."
+
+"/ could be:
+"/ ^ self subclassResponsibility
+
+ ^ self
+! !
+
--- a/Integer.st Fri May 19 15:33:11 1995 +0200
+++ b/Integer.st Wed May 24 14:44:58 1995 +0200
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1988 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Integer.st,v 1.25 1995-05-16 17:07:20 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Integer.st,v 1.26 1995-05-24 12:42:45 claus Exp $
'!
!Integer class methodsFor:'documentation'!
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Integer.st,v 1.25 1995-05-16 17:07:20 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Integer.st,v 1.26 1995-05-24 12:42:45 claus Exp $
"
!
@@ -508,10 +508,10 @@
factorial
"return 1*2*3...*self"
- (self > 2) ifTrue:[
+ (self >= 2) ifTrue:[
^ self * (self - 1) factorial
].
- ^ self
+ ^ 1
"
10 factorial
--- a/Make.proto Fri May 19 15:33:11 1995 +0200
+++ b/Make.proto Wed May 24 14:44:58 1995 +0200
@@ -1,4 +1,4 @@
-# $Header: /cvs/stx/stx/libbasic/Make.proto,v 1.29 1995-05-16 17:09:45 claus Exp $
+# $Header: /cvs/stx/stx/libbasic/Make.proto,v 1.30 1995-05-24 12:44:58 claus Exp $
#
# -------------- no need to change anything below ----------
@@ -8,7 +8,7 @@
LIBNAME=libbasic
STCOPT=$(LIBBASIC_STCOPT)
-STCLOCALOPT=-Pbasic-classes -warnGlobalAssign +optinline2 $(COMMONSYMBOLS)
+STCLOCALOPT='-Pbasic-classes-(libbasic)' -warnGlobalAssign +optinline2 $(COMMONSYMBOLS) +sharedLibCode
UNCRITICALOPT=+optspace
@@ -23,6 +23,7 @@
ClassDescr.$(O) \
Class.$(O) \
Metaclass.$(O) \
+ Project.$(O) \
Boolean.$(O) \
True.$(O) \
False.$(O) \
@@ -88,7 +89,8 @@
MiniIns.$(O) \
ObjMem.$(O) \
ProcSched.$(O) \
- Rectangle.$(O) \
+ Geometric.$(O) \
+ Rectangle.$(O) \
Registry.$(O) \
Signal.$(O) \
Smalltalk.$(O) \
@@ -184,7 +186,8 @@
Signal.$(O): Signal.st $(OBJECT)
Exception.$(O): Exception.st $(OBJECT)
-Rectangle.$(O): Rectangle.st $(OBJECT)
+Geometric.$(O): Geometric.st $(OBJECT)
+Rectangle.$(O): Rectangle.st $(I)/Geometric.H $(OBJECT)
Boolean.$(O): Boolean.st $(OBJECT)
True.$(O): True.st $(BOOLEAN)
@@ -288,3 +291,5 @@
PipeStr.$(O): PipeStr.st $(NPEXTSTREAM)
FileStr.$(O): FileStr.st $(EXTSTREAM)
DirStr.$(O): DirStr.st $(I)/FileStr.H $(EXTSTREAM)
+
+Project.$(O): Project.st $(OBJECT)
--- a/Metaclass.st Fri May 19 15:33:11 1995 +0200
+++ b/Metaclass.st Wed May 24 14:44:58 1995 +0200
@@ -11,7 +11,7 @@
"
Class subclass:#Metaclass
- instanceVariableNames:''
+ instanceVariableNames:'myClass'
classVariableNames:''
poolDictionaries:''
category:'Kernel-Classes'
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1988 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Metaclass.st,v 1.24 1995-05-01 21:30:19 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Metaclass.st,v 1.25 1995-05-24 12:42:59 claus Exp $
'!
!Metaclass class methodsFor:'documentation'!
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Metaclass.st,v 1.24 1995-05-01 21:30:19 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Metaclass.st,v 1.25 1995-05-24 12:42:59 claus Exp $
"
!
@@ -55,6 +55,29 @@
"
! !
+!Metaclass class methodsFor:'creating metaclasses'!
+
+new
+ "creating a new metaclass - have to set the new classes
+ flags correctly to have it behave like a metaclass ...
+ Not for normal applications - creating new metaclasses is a very
+ tricky thing; should be left to the gurus ;-)"
+
+ |newMetaclass|
+
+ newMetaclass := super new.
+ newMetaclass instSize:(Class instSize).
+ newMetaclass setSuperclass:Class.
+
+ ^ newMetaclass
+
+ "
+ Metaclass new <- new metaclass
+ Metaclass new new <- new class
+ Metaclass new new new <- new instance
+ "
+! !
+
!Metaclass methodsFor:'creating classes'!
name:newName inEnvironment:aSystemDictionary
@@ -87,10 +110,12 @@
"NOTICE:
this method is too complex and should be splitted into managable pieces ...
I dont like it anymore :-)
- (However, its a good test for the compilers ability to handle big,
- complex methods ;-)
- ST-80 uses a ClasBuilder object to collect the work and perform all updates;
- this may be changed to do something similar in the future ...
+ (well, at least, its a good test for the compilers ability
+ to handle big, complex methods ;-)
+ take it as an example of bad coding style ...
+
+ ST-80 uses a ClassBuilder object to collect the work and perform all updates;
+ this method may be changed to do something similar in the future ...
"
project := Project. "/ have to fetch this before, in case its autoloaded
@@ -665,17 +690,25 @@
!
new
- "create & return a new metaclass (a classes class)"
+ "create & return a new metaclass (a classes class).
+ Since metaclasses only have one instance (the class),
+ complain if there is already one.
+ You get a new class by sending #new to the returned metaclass
+ (confusing - isn't it ?)"
|newClass|
+ myClass notNil ifTrue:[
+ ^ self error:'Each metaclass may only have one instance'.
+ ].
newClass := self basicNew.
- newClass setSuperclass:(Object class)
+ newClass setSuperclass:Object
selectors:(Array new:0)
methods:(Array new:0)
- instSize:0
- flags:(Behavior flagNotIndexed).
-"/ newClass setComment:(self comment) category:(self category).
+ instSize:0
+ flags:(Behavior flagBehavior).
+ newClass setName:'someClass'.
+ myClass := newClass.
^ newClass
! !
@@ -762,7 +795,7 @@
(nClassInstVars ~~ 0) ifTrue:[
newMetaclass setInstanceVariableString:aString
].
- newMetaclass flags:(Behavior flagNotIndexed).
+"/ newMetaclass flags:(Behavior flagBehavior "flagNotIndexed").
newMetaclass setName:name.
newMetaclass classVariableString:classvars.
newMetaclass category:category.
@@ -983,6 +1016,20 @@
^ newMetaclass
! !
+!Metaclass methodsFor:'accessing'!
+
+name
+ "return my name - that is the name of my sole class, with 'class'
+ appended. Currently, this is incompatible to ST-80 (which appends ' class')
+ and will be changed (have to check for side effects first ...)"
+
+ myClass isNil ifTrue:[
+ ^ 'someMetaclass'
+ ].
+"/ ^ myClass name , ' class'
+ ^ myClass name , 'class'
+! !
+
!Metaclass methodsFor:'queries'!
isMeta
@@ -990,6 +1037,12 @@
true is returned here. Redefines isMeta in Object"
^ true
+!
+
+soleInstance
+ "return my sole class."
+
+ ^ myClass
! !
!Metaclass methodsFor:'private'!
--- a/ObjMem.st Fri May 19 15:33:11 1995 +0200
+++ b/ObjMem.st Wed May 24 14:44:58 1995 +0200
@@ -34,7 +34,7 @@
COPYRIGHT (c) 1992 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Attic/ObjMem.st,v 1.41 1995-05-16 17:07:55 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/ObjMem.st,v 1.42 1995-05-24 12:43:11 claus Exp $
'!
!ObjectMemory class methodsFor:'documentation'!
@@ -55,7 +55,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Attic/ObjMem.st,v 1.41 1995-05-16 17:07:55 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/ObjMem.st,v 1.42 1995-05-24 12:43:11 claus Exp $
"
!
@@ -1000,6 +1000,8 @@
2 is idle, 3..11 are various mark phases,
12 is the sweep phase. 0 and 1 are cleanup phases when the
incr. GC gets interrupted by a full GC).
+ Do not depend on the values - there may be additional phases in
+ future versions (incremental compact ;-).
This is for debugging and monitoring only - and may change or vanish"
%{ /* NOCONTEXT */
@@ -1417,6 +1419,7 @@
"
ObjectMemory incrementalGC
+ [ObjectMemory incrementalGC] forkAt:3
"
!
@@ -2265,9 +2268,9 @@
OBJ funny = @symbol(funnySnapshotSymbol);
if (__isString(aFileName)) {
- BLOCKINTERRUPTS();
+ __BLOCKINTERRUPTS();
ok = __snapShotOn(__context, _stringVal(aFileName), funny);
- UNBLOCKINTERRUPTS();
+ __UNBLOCKINTERRUPTS();
}
%}.
^ ok
--- a/Object.st Fri May 19 15:33:11 1995 +0200
+++ b/Object.st Wed May 24 14:44:58 1995 +0200
@@ -20,7 +20,8 @@
InformationSignal PrimitiveFailureSignal
DeepCopyErrorSignal
AbortSignal
- ErrorRecursion Dependencies'
+ ErrorRecursion Dependencies
+ InfoPrinting'
poolDictionaries:''
category:'Kernel-Objects'
!
@@ -29,7 +30,7 @@
COPYRIGHT (c) 1988 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Object.st,v 1.49 1995-05-18 15:09:41 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Object.st,v 1.50 1995-05-24 12:43:25 claus Exp $
'!
!Object class methodsFor:'documentation'!
@@ -50,7 +51,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Object.st,v 1.49 1995-05-18 15:09:41 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Object.st,v 1.50 1995-05-24 12:43:25 claus Exp $
"
!
@@ -172,7 +173,8 @@
Dependencies isNil ifTrue:[
Dependencies := WeakIdentityDictionary new.
]
- ]
+ ].
+ InfoPrinting := true
"Object initialize"
! !
@@ -284,6 +286,16 @@
^ AbortSignal
! !
+!Object class methodsFor:'info messages'!
+
+infoPrinting:aBoolean
+ "turn on/off printing of information messages.
+ If the argument, aBoolean is false, infoPrint will not output
+ messages. The default is true."
+
+ InfoPrinting := aBoolean
+! !
+
!Object class methodsFor:'queries'!
isBuiltInClass
@@ -1306,7 +1318,7 @@
RETURN ( _MKSMALLINT(hash << 8) );
}
%}.
- ^ 0 "must be defined in UndefinedObject and SmallInteger"
+ ^ 0 "never reached, since redefined in UndefinedObject and SmallInteger"
! !
!Object methodsFor:'interrupt handling'!
@@ -1690,6 +1702,9 @@
] ifFalse:[
sel := aMessage selector
].
+ Smalltalk isInitialized ifFalse:[
+ sel printNL
+ ].
"the new errorString gives more information ..."
"/ errorString := 'Message not understood: ' , sel.
@@ -3457,6 +3472,28 @@
^ self printNewline
!
+infoPrint
+ "print the receiver on the standard error stream.
+ This is meant for information messages which are not warnings
+ or fatal messages.
+ These messages can be turned on/off by 'Object infoPrinting:true/false'"
+
+ InfoPrinting ifTrue:[
+ self printOn:Stderr
+ ]
+!
+
+infoPrintNL
+ "print the receiver followed by a cr on the standard error stream.
+ This is meant for information messages which are not warnings
+ or fatal messages.
+ These messages can be turned on/off by 'Object infoPrinting:true/false'"
+
+ InfoPrinting ifTrue:[
+ self errorPrintNewline
+ ]
+!
+
errorPrint
"print the receiver on the standard error stream."
--- a/ObjectMemory.st Fri May 19 15:33:11 1995 +0200
+++ b/ObjectMemory.st Wed May 24 14:44:58 1995 +0200
@@ -34,7 +34,7 @@
COPYRIGHT (c) 1992 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/ObjectMemory.st,v 1.41 1995-05-16 17:07:55 claus Exp $
+$Header: /cvs/stx/stx/libbasic/ObjectMemory.st,v 1.42 1995-05-24 12:43:11 claus Exp $
'!
!ObjectMemory class methodsFor:'documentation'!
@@ -55,7 +55,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/ObjectMemory.st,v 1.41 1995-05-16 17:07:55 claus Exp $
+$Header: /cvs/stx/stx/libbasic/ObjectMemory.st,v 1.42 1995-05-24 12:43:11 claus Exp $
"
!
@@ -1000,6 +1000,8 @@
2 is idle, 3..11 are various mark phases,
12 is the sweep phase. 0 and 1 are cleanup phases when the
incr. GC gets interrupted by a full GC).
+ Do not depend on the values - there may be additional phases in
+ future versions (incremental compact ;-).
This is for debugging and monitoring only - and may change or vanish"
%{ /* NOCONTEXT */
@@ -1417,6 +1419,7 @@
"
ObjectMemory incrementalGC
+ [ObjectMemory incrementalGC] forkAt:3
"
!
@@ -2265,9 +2268,9 @@
OBJ funny = @symbol(funnySnapshotSymbol);
if (__isString(aFileName)) {
- BLOCKINTERRUPTS();
+ __BLOCKINTERRUPTS();
ok = __snapShotOn(__context, _stringVal(aFileName), funny);
- UNBLOCKINTERRUPTS();
+ __UNBLOCKINTERRUPTS();
}
%}.
^ ok
--- a/Point.st Fri May 19 15:33:11 1995 +0200
+++ b/Point.st Wed May 24 14:44:58 1995 +0200
@@ -10,18 +10,20 @@
hereby transferred.
"
+'From Smalltalk/X, Version:2.10.5 on 23-may-1995 at 7:19:52 am'!
+
ArithmeticValue subclass:#Point
- instanceVariableNames:'x y'
- classVariableNames:'PointZero PointOne'
- poolDictionaries:''
- category:'Graphics-Geometry'
+ instanceVariableNames:'x y'
+ classVariableNames:'PointZero PointOne'
+ poolDictionaries:''
+ category:'Graphics-Geometry'
!
Point comment:'
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Point.st,v 1.22 1995-05-16 17:08:22 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Point.st,v 1.23 1995-05-24 12:43:40 claus Exp $
'!
!Point class methodsFor:'documentation'!
@@ -42,7 +44,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Point.st,v 1.22 1995-05-16 17:08:22 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Point.st,v 1.23 1995-05-24 12:43:40 claus Exp $
"
!
@@ -70,28 +72,6 @@
]
! !
-!Point class methodsFor:'constants'!
-
-zero
- "return the neutral element for addition"
-
- ^ PointZero
-!
-
-unity
- "return the neutral element for multiplication"
-
- ^ PointOne
-! !
-
-!Point class methodsFor:'queries'!
-
-isBuiltInClass
- "this class is known by the run-time-system"
-
- ^ self == Point
-! !
-
!Point class methodsFor:'instance creation'!
x:newX y:newY
@@ -151,50 +131,356 @@
"
! !
-!Point methodsFor:'accessing'!
+!Point class methodsFor:'constants'!
+
+zero
+ "return the neutral element for addition"
+
+ ^ PointZero
+!
+
+unity
+ "return the neutral element for multiplication"
+
+ ^ PointOne
+! !
+
+!Point class methodsFor:'queries'!
+
+isBuiltInClass
+ "this class is known by the run-time-system"
+
+ ^ self == Point
+! !
+
+!Point methodsFor:'misc'!
+
+rounded
+ "return a new point with my coordinates rounded to the next integer
+ coordinated (use for gridding) or the receiver of already rounded."
+
+ (x isInteger and:[y isInteger]) ifTrue:[^ self].
+ ^ (x rounded) @ (y rounded)
+!
+
+abs
+ "return a new point with my coordinates taken from the absolute values."
-x
- "return the x coordinate"
+ ^ (x abs) @ (y abs)
+!
+
+truncated
+ "return a new point with my coordinates truncated as integer or the
+ receiver, if already truncated."
+
+ (x isInteger and:[y isInteger]) ifTrue:[^ self].
+ ^ (x truncated) @ (y truncated)
+!
- ^ x
+quadrantContaining:aPoint
+ "return the number of the quadrant containing aPoint placing
+ the receiver at the origin, where the quadrants are numbered as
+ follows:
+ ^ 2 | 3
+ Y ------
+ 1 | 0
+
+ X >
+ This can be used for polygon operations (see Foley for examples).
+ "
+
+ aPoint x > x ifTrue:[
+ aPoint y >= y ifTrue:[^ 3].
+ ^ 0
+ ].
+ aPoint y >= y ifTrue: [^ 2].
+ ^ 1
+
+ "
+ (10 @ 10) quadrantContaining:(15 @ 15)
+ (10 @ 10) quadrantContaining:(5 @ 5)
+ (10 @ 10) quadrantContaining:(5 @ 15)
+ (10 @ 10) quadrantContaining:(15 @ 5)
+ "
!
-y
- "return the y coordinate"
+quadrant
+ "return the number of the quadrant containing the receiver.
+ quadrants are named as follows:
+
+ ^ 2 | 3
+ Y ------
+ 1 | 0
+
+ X >
+
+ Q: what is to be returned if any coordinate is 0 ?
+ "
+
+ ^ 0@0 quadrantContaining:self
+
+ "
+ (0@0) quadrant
+ (1@1) quadrant
+ (-1@1) quadrant
+ (-1@-1) quadrant
+ (1@-1) quadrant
+ "
+! !
+
+!Point methodsFor:'converting'!
+
+extent:aPoint
+ "return a rectangle whose origin is self and extent is aPoint"
+
+ ^ Rectangle origin:self extent:aPoint
+!
+
+asPoint
+ "return the receiver as Point - this is the receiver"
+
+ ^ self
+!
- ^ y
+asLayout
+ "return a LayoutOrigin from the receiver.
+ If the receiver coordinates are between 0 and 1, take
+ them as fractional parts (relative to superview).
+ Otherwise, treat them as absolute offsets.
+ Notice: in 10.5.x LayoutOrigin is not yet released."
+
+ ^ LayoutOrigin fromPoint:self
+
+ "
+ (0@0.5) asFractionalLayout
+ (0@0.5) asLayout
+ (0@10) asLayout
+ (0@10) asOffsetLayout
+ "
+
+!
+
+asFractionalLayout
+ "return a LayoutOrigin from the receiver,
+ treating the receiver coordinates as fractional parts
+ (i.e. relative to superview).
+ Notice: in 10.5.x LayoutOrigin is not yet officially released."
+
+ ^ LayoutOrigin fractionalFromPoint:self
+
+ "
+ (0@0.5) asFractionalLayout
+ (0@0.5) asLayout
+ (0@10) asLayout
+ (0@10) asOffsetLayout
+ "
+
+!
+
+asOffsetLayout
+ "return a LayoutOrigin from the receiver,
+ treating the receiver coordinates as absolute offsets.
+ Notice: in 10.5.x LayoutOrigin is not yet released."
+
+ ^ LayoutOrigin offsetFromPoint:self
+
+ "
+ (0@0.5) asFractionalLayout
+ (0@0.5) asLayout
+ (0@10) asLayout
+ (0@10) asOffsetLayout
+ "
+
!
-x:newX
- "set the x coordinate to be the argument, aNumber.
- This is destructive (modifies the receiver, not a copy) and
- should only be used if you know, that you are the exclusive owner
- of the receiver."
+corner:aPoint
+ "return a rectangle whose origin is self and corner is aPoint"
+
+ ^ Rectangle origin:self corner:aPoint
+!
+
+asRectangle
+ "return a zero-width rectangle consisting of origin
+ and corner being the receiver"
+
+ ^ self corner:self
+
+ "
+ (0@10) asRectangle
+ "
+!
+
+rectangleRelativeTo:aRectangle preferred:prefRect
+ "compute a displayRectangle, treating the receiver like a
+ layoutorigin. This allows point to be used interchangable with
+ LayoutOrigins."
+
+ ^ (self asLayout) rectangleRelativeTo:aRectangle preferred:prefRect
+
+ "
+ consider the case, where a view has a preferred extent of 50@50
+ and is to be positioned in its superview which has size 100@100.
+ For absolute origin:
+ (10@20) rectangleRelativeTo:(0@0 corner:100@100) preferred:(0@0 corner:50@50)
- x := newX
+ for relative origin:
+ (0.5@0.5) rectangleRelativeTo:(0@0 corner:100@100) preferred:(0@0 corner:50@50)
+ "
+! !
+
+!Point methodsFor:'transformations'!
+
+* scale
+ "Return a new Point that is the product of the
+ receiver and scale (which is a Point or Number)."
+
+ |scalePoint|
+
+ "speedup for common cases ..."
+
+ (scale isMemberOf:Point) ifTrue:[
+ ^ (x * scale x) @ (y * scale y)
+ ].
+ (scale isMemberOf:SmallInteger) ifTrue:[
+ ^ (x * scale) @ (y * scale)
+ ].
+ scale isNumber ifTrue:[
+ ^ (x * scale) @ (y * scale)
+ ].
+
+ "this is the general (& clean) code ..."
+
+ scalePoint := scale asPoint.
+ ^ (x * scalePoint x) @ (y * scalePoint y)
!
-y:newY
- "set the y coordinate to be the argument, aNumber.
- This is destructive (modifies the receiver, not a copy) and
- should only be used if you know, that you are the exclusive owner
- of the receiver."
++ scale
+ "Return a new Point that is the sum of the
+ receiver and scale (which is a Point or Number)."
+
+ |scalePoint|
+
+ "speedup for common cases ..."
- y := newY
+ (scale isMemberOf:Point) ifTrue:[
+ ^ (x + scale x) @ (y + scale y)
+ ].
+ (scale isMemberOf:SmallInteger) ifTrue:[
+ ^ (x + scale) @ (y + scale)
+ ].
+ scale isNumber ifTrue:[
+ ^ (x + scale) @ (y + scale)
+ ].
+
+ "this is the general (& clean) code ..."
+
+ scalePoint := scale asPoint.
+ ^ (x + scalePoint x) @ (y + scalePoint y)
+!
+
+// scale
+ "Return a new Point that is the quotient of the
+ receiver and scale (which is a Point or Number)."
+
+ |scalePoint|
+
+ scalePoint := scale asPoint.
+ ^ (x // scalePoint x) @ (y // scalePoint y)
!
-x:newX y:newY
- "set both the x and y coordinates.
- This is destructive (modifies the receiver, not a copy) and
- should only be used if you know, that you are the exclusive owner
- of the receiver."
+- scale
+ "Return a new Point that is the difference of the
+ receiver and scale (which is a Point or Number)."
+
+ |scalePoint|
+
+ "speedup for common cases ..."
+
+ (scale isMemberOf:Point) ifTrue:[
+ ^ (x - scale x) @ (y - scale y)
+ ].
+ (scale isMemberOf:SmallInteger) ifTrue:[
+ ^ (x - scale) @ (y - scale)
+ ].
+ scale isNumber ifTrue:[
+ ^ (x - scale) @ (y - scale)
+ ].
+
+ "this is the general (& clean) code ..."
+
+ scalePoint := scale asPoint.
+ ^ (x - scalePoint x) @ (y - scalePoint y)
+!
+
+/ scale
+ "Return a new Point that is the integer quotient of the
+ receiver and scale (which is a Point or Number)."
+
+ |scalePoint|
+
+ "speedup for common cases ..."
- x := newX.
- y := newY
+ (scale isMemberOf:Point) ifTrue:[
+ ^ (x / scale x) @ (y / scale y)
+ ].
+ scale isNumber ifTrue:[
+ ^ (x / scale) @ (y / scale)
+ ].
+
+ "this is the general (& clean) code ..."
+
+ scalePoint := scale asPoint.
+ ^ (x / scalePoint x) @ (y / scalePoint y)
+!
+
+negated
+ "return a new point with my coordinates negated
+ i.e. the receiver mirrored at the origin"
+
+ ^ (x negated) @ (y negated)
+!
+
+reciprocal
+ "return a new point where the coordinates are
+ the reciproce of mine"
+
+ ^ (1 / x) @ (1 / y)
+!
+
+scaledBy:aScale
+ "return a new Point that is the product of the
+ receiver and scale (which is a Point or Number)."
+
+ ^ self * aScale
+!
+
+translatedBy:anOffset
+ "return a new Point that is the sum of the
+ receiver and scale (which is a Point or Number)."
+
+ ^ self + anOffset
! !
!Point methodsFor:'comparing'!
+= aPoint
+ "return true if the receiver represents the same point as
+ the argument, aPoint"
+
+ |p|
+
+ (aPoint isMemberOf:Point) ifTrue:[ "this is a hint to STC"
+ x ~= (aPoint x) ifTrue:[^ false].
+ y ~= (aPoint y) ifTrue:[^ false].
+ ^ true
+ ].
+ aPoint respondsToArithmetic ifFalse:[ ^ false].
+ p := aPoint asPoint.
+ x ~= (p x) ifTrue:[^ false].
+ y ~= (p y) ifTrue:[^ false].
+ ^ true
+!
+
hash
"return a number for hashing"
@@ -231,24 +517,6 @@
^ true
!
-= aPoint
- "return true if the receiver represents the same point as
- the argument, aPoint"
-
- |p|
-
- (aPoint isMemberOf:Point) ifTrue:[ "this is a hint to STC"
- x ~= (aPoint x) ifTrue:[^ false].
- y ~= (aPoint y) ifTrue:[^ false].
- ^ true
- ].
- aPoint respondsToArithmetic ifFalse:[ ^ false].
- p := aPoint asPoint.
- x ~= (p x) ifTrue:[^ false].
- y ~= (p y) ifTrue:[^ false].
- ^ true
-!
-
max:aPoint
"return the lower right corner of the rectangle uniquely defined by
the receiver and the argument, aPoint"
@@ -273,7 +541,49 @@
^ minX @ minY
! !
-!Point methodsFor:'coercing & converting'!
+!Point methodsFor:'accessing'!
+
+x
+ "return the x coordinate"
+
+ ^ x
+!
+
+y
+ "return the y coordinate"
+
+ ^ y
+!
+
+y:newY
+ "set the y coordinate to be the argument, aNumber.
+ This is destructive (modifies the receiver, not a copy) and
+ should only be used if you know, that you are the exclusive owner
+ of the receiver."
+
+ y := newY
+!
+
+x:newX
+ "set the x coordinate to be the argument, aNumber.
+ This is destructive (modifies the receiver, not a copy) and
+ should only be used if you know, that you are the exclusive owner
+ of the receiver."
+
+ x := newX
+!
+
+x:newX y:newY
+ "set both the x and y coordinates.
+ This is destructive (modifies the receiver, not a copy) and
+ should only be used if you know, that you are the exclusive owner
+ of the receiver."
+
+ x := newX.
+ y := newY
+! !
+
+!Point methodsFor:'coercing'!
generality
"return the generality value - see ArithmeticValue>>retry:coercing:"
@@ -285,193 +595,14 @@
"return aNumber converted into receivers type"
^ anObject asPoint
-!
-
-asPoint
- "return the receiver as Point - this is the receiver"
-
- ^ self
-!
-
-asRectangle
- "return a zero-width rectangle consisting of origin
- and corner being the receiver"
-
- ^ self corner:self
-!
-
-asLayout
- "return a LayoutOrigin from the receiver.
- If the receiver coordinates are between 0 and 1, take
- them as fractional parts (relative to superview).
- Otherwise, treat them as absolute offsets.
- Notice: in 10.5.x LayoutOrigin is not yet released."
-
- ^ LayoutOrigin fromPoint:self
-!
-
-asFractionalLayout
- "return a LayoutOrigin from the receiver,
- treating the receiver coordinates as fractional parts
- (i.e. relative to superview).
- Notice: in 10.5.x LayoutOrigin is not yet released."
-
- ^ LayoutOrigin fractionalFromPoint:self
-!
-
-asOffsetLayout
- "return a LayoutOrigin from the receiver,
- treating the receiver coordinates as absolute offsets.
- Notice: in 10.5.x LayoutOrigin is not yet released."
-
- ^ LayoutOrigin offsetFromPoint:self
-! !
-
-!Point methodsFor:'creating rectangles'!
-
-corner:aPoint
- "return a rectangle whose origin is self and corner is aPoint"
-
- ^ Rectangle origin:self corner:aPoint
-!
-
-extent:aPoint
- "return a rectangle whose origin is self and extent is aPoint"
-
- ^ Rectangle origin:self extent:aPoint
! !
-!Point methodsFor:'transformations'!
-
-+ scale
- "Return a new Point that is the sum of the
- receiver and scale (which is a Point or Number)."
-
- |scalePoint|
-
- "speedup for common cases ..."
-
- (scale isMemberOf:Point) ifTrue:[
- ^ (x + scale x) @ (y + scale y)
- ].
- (scale isMemberOf:SmallInteger) ifTrue:[
- ^ (x + scale) @ (y + scale)
- ].
- scale isNumber ifTrue:[
- ^ (x + scale) @ (y + scale)
- ].
-
- "this is the general (& clean) code ..."
-
- scalePoint := scale asPoint.
- ^ (x + scalePoint x) @ (y + scalePoint y)
-!
-
-- scale
- "Return a new Point that is the difference of the
- receiver and scale (which is a Point or Number)."
-
- |scalePoint|
-
- "speedup for common cases ..."
-
- (scale isMemberOf:Point) ifTrue:[
- ^ (x - scale x) @ (y - scale y)
- ].
- (scale isMemberOf:SmallInteger) ifTrue:[
- ^ (x - scale) @ (y - scale)
- ].
- scale isNumber ifTrue:[
- ^ (x - scale) @ (y - scale)
- ].
-
- "this is the general (& clean) code ..."
-
- scalePoint := scale asPoint.
- ^ (x - scalePoint x) @ (y - scalePoint y)
-!
-
-* scale
- "Return a new Point that is the product of the
- receiver and scale (which is a Point or Number)."
-
- |scalePoint|
-
- "speedup for common cases ..."
+!Point methodsFor:'queries'!
- (scale isMemberOf:Point) ifTrue:[
- ^ (x * scale x) @ (y * scale y)
- ].
- (scale isMemberOf:SmallInteger) ifTrue:[
- ^ (x * scale) @ (y * scale)
- ].
- scale isNumber ifTrue:[
- ^ (x * scale) @ (y * scale)
- ].
-
- "this is the general (& clean) code ..."
-
- scalePoint := scale asPoint.
- ^ (x * scalePoint x) @ (y * scalePoint y)
-!
-
-/ scale
- "Return a new Point that is the integer quotient of the
- receiver and scale (which is a Point or Number)."
-
- |scalePoint|
-
- "speedup for common cases ..."
-
- (scale isMemberOf:Point) ifTrue:[
- ^ (x / scale x) @ (y / scale y)
- ].
- scale isNumber ifTrue:[
- ^ (x / scale) @ (y / scale)
- ].
-
- "this is the general (& clean) code ..."
-
- scalePoint := scale asPoint.
- ^ (x / scalePoint x) @ (y / scalePoint y)
-!
+isPoint
+ "return true, if the receiver is some kind of point"
-// scale
- "Return a new Point that is the quotient of the
- receiver and scale (which is a Point or Number)."
-
- |scalePoint|
-
- scalePoint := scale asPoint.
- ^ (x // scalePoint x) @ (y // scalePoint y)
-!
-
-reciprocal
- "return a new point where the coordinates are
- the reciproce of mine"
-
- ^ (1 / x) @ (1 / y)
-!
-
-negated
- "return a new point with my coordinates negated
- i.e. the receiver mirrored at the origin"
-
- ^ (x negated) @ (y negated)
-!
-
-scaledBy:aScale
- "return a new Point that is the product of the
- receiver and scale (which is a Point or Number)."
-
- ^ self * aScale
-!
-
-translatedBy:anOffset
- "return a new Point that is the sum of the
- receiver and scale (which is a Point or Number)."
-
- ^ self + anOffset
+ ^ true
! !
!Point methodsFor:'destructive transformations'!
@@ -530,15 +661,27 @@
y := y + anOffset y
! !
-!Point methodsFor:'queries'!
+!Point methodsFor:'printing & storing'!
+
+printOn:aStream
+ "append a printed representation of the receiver to aStream"
-isPoint
- "return true, if the receiver is some kind of point"
+ x printOn:aStream.
+ aStream nextPut:$@.
+ y printOn:aStream
+!
- ^ true
+storeOn:aStream
+ "append my storeString to aStream"
+
+ aStream nextPut:$(.
+ x storeOn:aStream.
+ aStream nextPut:$@.
+ y storeOn:aStream.
+ aStream nextPut:$)
! !
-!Point methodsFor:'misc'!
+!Point methodsFor:'point functions'!
dist:aPoint
"return the distance between aPoint and the receiver."
@@ -557,68 +700,6 @@
^ temp x abs + temp y abs
!
-r
- "return the receiver's radius in a polar coordinate system.
- (i.e. the length of a vector from 0@0 to the receiver)"
-
- ^ (self dotProduct:self) sqrt
-
- "
- (1@1) r
- (2@1) r
- (2@0) r
- "
-!
-
-angle
- "return the receiver's angle in a polar coordinate system.
- (i.e. the angle of a vector from 0@0 to the receiver)"
-
- y < 0 ifTrue:[
- x < 0 ifTrue:[
- ^ 270 degreesToRadians - (y / x) arcTan
- ].
- x = 0 ifTrue:[
- ^ 180
- ].
- ^ 360 degreesToRadians - (y abs / x) arcTan
- ].
- x < 0 ifTrue:[
- ^ 180 degreesToRadians - (y / x abs) arcTan
- ].
- x = 0 ifTrue:[
- ^ 0
- ].
- ^ (y / x) arcTan
-
- "
- (1@1) angle radiansToDegrees
- (2@1) angle radiansToDegrees
- "
-!
-
-abs
- "return a new point with my coordinates taken from the absolute values."
-
- ^ (x abs) @ (y abs)
-!
-
-truncated
- "return a new point with my coordinates truncated as integer or the
- receiver, if already truncated."
-
- (x isInteger and:[y isInteger]) ifTrue:[^ self].
- ^ (x truncated) @ (y truncated)
-!
-
-rounded
- "return a new point with my coordinates rounded to the next integer
- coordinated (use for gridding) or the receiver of already rounded."
-
- (x isInteger and:[y isInteger]) ifTrue:[^ self].
- ^ (x rounded) @ (y rounded)
-!
-
grid:gridPoint
"return a new point with coordinates grided (i.e. rounded to the
nearest point on the grid)"
@@ -640,47 +721,6 @@
^ newX @ newY
!
-quadrantContaining:aPoint
- "return the number of the quadrant containing aPoint placing
- the receiver at the origin, where the quadrants are numbered as
- follows:
- ^ 2 | 3
- Y ------
- 1 | 0
-
- X >
- This can be used for polygon operations (see Foley for examples).
- "
-
- aPoint x > x ifTrue:[
- aPoint y >= y ifTrue:[^ 3].
- ^ 0
- ].
- aPoint y >= y ifTrue: [^ 2].
- ^ 1
-
- "
- (10 @ 10) quadrantContaining:(15 @ 15)
- (10 @ 10) quadrantContaining:(5 @ 5)
- (10 @ 10) quadrantContaining:(5 @ 15)
- (10 @ 10) quadrantContaining:(15 @ 5)
- "
-!
-
-quadrant
- "return the number of the quadrant containing the receiver.
- quadrants are named as follows:
-
- ^ 2 | 3
- Y ------
- 1 | 0
-
- X >
- "
-
- ^ 0@0 quadrantContaining:self
-!
-
nearestIntegerPointOnLineFrom: point1 to: point2
"return the closest integer point to the receiver on the line
determined by (point1, point2)--much faster than the more
@@ -734,22 +774,62 @@
"
! !
-!Point methodsFor:'printing & storing'!
+!Point methodsFor:'polar coordinates'!
+
+r
+ "return the receiver's radius in a polar coordinate system.
+ (i.e. the length of a vector from 0@0 to the receiver)"
+
+ ^ (self dotProduct:self) sqrt
-printOn:aStream
- "append a printed representation of the receiver to aStream"
-
- x printOn:aStream.
- aStream nextPut:$@.
- y printOn:aStream
+ "
+ (1@1) r
+ (2@1) r
+ (2@0) r
+ (0@2) r
+ (-2@-2) r
+ (2@2) r
+ "
!
-storeOn:aStream
- "append my storeString to aStream"
+angle
+ "return the receiver's angle (in radians) in a polar coordinate system.
+ (i.e. the angle of a vector from 0@0 to the receiver).
+ OBSOLETE ST/X interface; use theta for ST-80 compatibility."
+
+ ^ self theta
+
+ "
+ (1@1) angle radiansToDegrees
+ (2@1) angle radiansToDegrees
+ "
+!
+
+theta
+ "return the receiver's angle (in radians) in a polar coordinate system.
+ (i.e. the angle of a vector from 0@0 to the receiver)"
- aStream nextPut:$(.
- x storeOn:aStream.
- aStream nextPut:$@.
- y storeOn:aStream.
- aStream nextPut:$)
+ y < 0 ifTrue:[
+ x < 0 ifTrue:[
+ ^ 270 degreesToRadians - (y / x) arcTan
+ ].
+ x = 0 ifTrue:[
+ ^ 180
+ ].
+ ^ 360 degreesToRadians - (y abs / x) arcTan
+ ].
+ x < 0 ifTrue:[
+ ^ 180 degreesToRadians - (y / x abs) arcTan
+ ].
+ x = 0 ifTrue:[
+ ^ 0
+ ].
+ ^ (y / x) arcTan
+
+ "
+ (1@1) theta radiansToDegrees
+ (2@1) theta radiansToDegrees
+ "
! !
+
+Point initialize!
--- a/ProcSched.st Fri May 19 15:33:11 1995 +0200
+++ b/ProcSched.st Wed May 24 14:44:58 1995 +0200
@@ -34,7 +34,7 @@
COPYRIGHT (c) 1993 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Attic/ProcSched.st,v 1.38 1995-05-08 03:30:32 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/ProcSched.st,v 1.39 1995-05-24 12:43:46 claus Exp $
'!
Smalltalk at:#Processor put:nil!
@@ -57,7 +57,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Attic/ProcSched.st,v 1.38 1995-05-08 03:30:32 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/ProcSched.st,v 1.39 1995-05-24 12:43:46 claus Exp $
"
!
@@ -1417,7 +1417,8 @@
!
signal:aSemaphore atMilliseconds:aMillisecondTime
- "arrange for a semaphore to be triggered at a specific millisecond time"
+ "arrange for a semaphore to be triggered at a specific millisecond time.
+ If there is already a pending trigger time, the time is changed."
|index "{ Class: SmallInteger }"
wasBlocked|
@@ -1440,6 +1441,7 @@
timeoutProcessArray := timeoutProcessArray copyWith:nil
].
].
+
anyTimeouts := true.
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
!
@@ -1626,12 +1628,16 @@
addTimedBlock:aBlock for:aProcess atMilliseconds:aMillisecondTime
"add the argument, aBlock to the list of time-scheduled-blocks; to be
evaluated by aProcess when the millisecondClock value passes
- aMillisecondTime. The process specified by the argument,
- aProcess will be interrupted for execution of the block. If
- aProcess is nil, the block will be evaluated by the scheduler itself
+ aMillisecondTime.
+ If that block is already in the timeout list,
+ its trigger-time is changed.
+ The process specified by the argument, aProcess will be interrupted
+ for execution of the block.
+ If aProcess is nil, the block will be evaluated by the scheduler itself
(which is dangerous - the block should not raise any error conditions).
- (if it is running, the interrupt will occur in whatever method it is
- executing; if it is suspended, it will be resumed).
+ If the process is active at trigger time, the interrupt will occur in
+ whatever method it is executing; if suspended at trigger time, it will be
+ resumed.
The block will be removed from the timed-block list after evaluation
(i.e. it will trigger only once)."
@@ -1656,6 +1662,7 @@
timeoutProcessArray := timeoutProcessArray copyWith:aProcess.
].
].
+
anyTimeouts := true.
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
!
--- a/ProcessorScheduler.st Fri May 19 15:33:11 1995 +0200
+++ b/ProcessorScheduler.st Wed May 24 14:44:58 1995 +0200
@@ -34,7 +34,7 @@
COPYRIGHT (c) 1993 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/ProcessorScheduler.st,v 1.38 1995-05-08 03:30:32 claus Exp $
+$Header: /cvs/stx/stx/libbasic/ProcessorScheduler.st,v 1.39 1995-05-24 12:43:46 claus Exp $
'!
Smalltalk at:#Processor put:nil!
@@ -57,7 +57,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/ProcessorScheduler.st,v 1.38 1995-05-08 03:30:32 claus Exp $
+$Header: /cvs/stx/stx/libbasic/ProcessorScheduler.st,v 1.39 1995-05-24 12:43:46 claus Exp $
"
!
@@ -1417,7 +1417,8 @@
!
signal:aSemaphore atMilliseconds:aMillisecondTime
- "arrange for a semaphore to be triggered at a specific millisecond time"
+ "arrange for a semaphore to be triggered at a specific millisecond time.
+ If there is already a pending trigger time, the time is changed."
|index "{ Class: SmallInteger }"
wasBlocked|
@@ -1440,6 +1441,7 @@
timeoutProcessArray := timeoutProcessArray copyWith:nil
].
].
+
anyTimeouts := true.
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
!
@@ -1626,12 +1628,16 @@
addTimedBlock:aBlock for:aProcess atMilliseconds:aMillisecondTime
"add the argument, aBlock to the list of time-scheduled-blocks; to be
evaluated by aProcess when the millisecondClock value passes
- aMillisecondTime. The process specified by the argument,
- aProcess will be interrupted for execution of the block. If
- aProcess is nil, the block will be evaluated by the scheduler itself
+ aMillisecondTime.
+ If that block is already in the timeout list,
+ its trigger-time is changed.
+ The process specified by the argument, aProcess will be interrupted
+ for execution of the block.
+ If aProcess is nil, the block will be evaluated by the scheduler itself
(which is dangerous - the block should not raise any error conditions).
- (if it is running, the interrupt will occur in whatever method it is
- executing; if it is suspended, it will be resumed).
+ If the process is active at trigger time, the interrupt will occur in
+ whatever method it is executing; if suspended at trigger time, it will be
+ resumed.
The block will be removed from the timed-block list after evaluation
(i.e. it will trigger only once)."
@@ -1656,6 +1662,7 @@
timeoutProcessArray := timeoutProcessArray copyWith:aProcess.
].
].
+
anyTimeouts := true.
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
!
--- a/Project.st Fri May 19 15:33:11 1995 +0200
+++ b/Project.st Wed May 24 14:44:58 1995 +0200
@@ -23,7 +23,7 @@
COPYRIGHT (c) 1993 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Project.st,v 1.19 1995-05-06 04:26:35 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Project.st,v 1.20 1995-05-24 12:43:54 claus Exp $
'!
!Project class methodsFor:'documentation'!
@@ -44,7 +44,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Project.st,v 1.19 1995-05-06 04:26:35 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Project.st,v 1.20 1995-05-24 12:43:54 claus Exp $
"
!
@@ -178,21 +178,6 @@
^ views asArray
!
-classes
- "return a collection of classes belonging to that project"
-
- |classes|
-
- properties notNil ifTrue:[classes := properties at:#classes ifAbsent:nil].
- classes isNil ifTrue:[
- classes := OrderedCollection new.
- Smalltalk allClassesDo:[:aClass | aClass package = packageName ifTrue:[classes add:aClass]].
- classes isEmpty ifTrue:[^ nil].
- ].
- ^ classes
-
-!
-
name:aString
name := aString.
self == CurrentProject ifTrue:[
@@ -227,6 +212,55 @@
]
! !
+!Project methodsFor:'queries'!
+
+classes
+ "return a collection of classes belonging to that project"
+
+ |classes|
+
+ properties notNil ifTrue:[classes := properties at:#classes ifAbsent:nil].
+ classes isNil ifTrue:[
+ classes := OrderedCollection new.
+ Smalltalk allClassesDo:[:aClass | aClass package = packageName ifTrue:[classes add:aClass]].
+ classes isEmpty ifTrue:[^ nil].
+ ].
+ ^ classes
+
+!
+
+individualMethods
+ "return a collection of individual methods belonging to that project,
+ only methods are returned which are not contained in the
+ projects class set."
+
+ |classes methods|
+
+ classes := self classes.
+
+ methods := IdentitySet new.
+ Smalltalk allBehaviorsDo:[:cls |
+ (classes isNil or:[(classes includes:cls) not]) ifTrue:[
+ cls methodArray do:[:m |
+ m package = packageName ifTrue:[
+ methods add:m
+ ]
+ ].
+ cls class methodArray do:[:m |
+ m package = packageName ifTrue:[
+ methods add:m
+ ]
+ ].
+ ]
+ ].
+ ^ methods asArray
+
+ "
+ Project current classes
+ Project current individualMethods
+ "
+! !
+
!Project methodsFor:'views'!
addView:aView
@@ -276,7 +310,7 @@
name := 'new Project-' , numString.
packageName := 'private-' , numString.
- changeSet := ChangeSet new.
+ "/ changeSet := ChangeSet new.
self directory:'.'
! !
@@ -315,12 +349,10 @@
createProjectFiles
"actually, creates all files to do a make in the project directory"
- |dirName|
-
- dirName := properties at:#directoryName.
- dirName asFilename exists ifFalse:[
- (self confirm:'create new projectDirectory: ' , dirName) ifFalse:[^ self].
- OperatingSystem recursiveCreateDirectory:dirName.
+ directoryName asFilename exists ifFalse:[
+ (self confirm:'create new projectDirectory: ' , directoryName)
+ ifFalse:[^ self].
+ OperatingSystem recursiveCreateDirectory:directoryName.
].
self createMakefile.
self createSourcefiles.
@@ -330,7 +362,7 @@
createSourcefiles
"creates all Smalltalk-source files in the project directory"
- |classes dir|
+ |classes methods methodClasses dir stream|
dir := FileDirectory directoryNamed:self directory.
Transcript showCr:'creating sources in ' , dir pathName , ' ...'; endEntry.
@@ -345,6 +377,44 @@
aClass fileOutIn:dir
]
].
+
+ methods := self individualMethods.
+ methods notNil ifTrue:[
+ methods := methods asIdentitySet.
+ "
+ get classes ...
+ "
+ methodClasses := IdentitySet new.
+ methods do:[:m |
+ |mCls|
+
+ mCls := m who at:1.
+ mCls isMeta ifTrue:[
+ mCls := mCls soleInstance.
+ ].
+ methodClasses add:mCls].
+ "
+ fileOut by class
+ "
+ methodClasses do:[:cls |
+ stream := self directory asFilename construct:(cls name , '.chg') writeStream.
+
+ methods do:[:m |
+ |mCls|
+
+ mCls := m who at:1.
+ (mCls == cls or:[mCls == cls class]) ifTrue:[
+ m fileOutOn:stream.
+ ]
+ ].
+ stream close.
+ ].
+
+ methods do:[:aClass |
+ Transcript show:' ... '; showCr:aClass name; endEntry.
+ aClass fileOutIn:dir
+ ]
+ ].
!
createMakefile
@@ -355,7 +425,7 @@
Transcript showCr:'creating Makefile'.
- d := (properties at:#directoryName) asFilename.
+ d := directoryName asFilename.
f := d construct:'Makefile'.
f exists ifTrue:[
f renameTo:(d construct:'Makefile.bak')
@@ -387,12 +457,12 @@
createProtoMakefile
"creates a Make.proto file"
- |d f s type appName|
+ |d f s type appName libName startUpClass startUpSelector|
Transcript showCr:'creating Make.proto'.
- d := (properties at:#directoryName) asFilename.
+ d := directoryName asFilename.
f := d construct:'Make.proto'.
f exists ifTrue:[
f renameTo:(d construct:'Make.proto.bak')
@@ -413,17 +483,27 @@
'.
- type := properties at:#projectType ifAbsent:[#executable].
+ type := #library.
+ appName := 'app'.
+ libName := 'lib'.
+ startUpClass := 'Smalltalk'.
+ startUpSelector := 'start'.
- appName := properties at:#applicationName ifAbsent:['app'].
+ properties notNil ifTrue:[
+ type := properties at:#projectType ifAbsent:type.
+ appName := properties at:#applicationName ifAbsent:appName.
+ startUpClass := properties at:#startupClass ifAbsent:startUpClass.
+ startUpSelector := properties at:#startupSelector ifAbsent:startUpSelector.
+ ].
+
s nextPutAll:'LIBNAME=lib' , appName; cr.
type == #executable ifTrue:[
s nextPutAll:'PROGS = ' , appName; cr
].
- s nextPutAll:'STARTUP_CLASS=' , (properties at:#startupClass ifAbsent:['Smalltalk']).
+ s nextPutAll:'STARTUP_CLASS=' , startUpClass.
s cr.
- s nextPutAll:'STARTUP_SELECTOR="' , (properties at:#startupSelector ifAbsent:['start']).
+ s nextPutAll:'STARTUP_SELECTOR="' , startUpSelector.
s nextPutAll:'"'; cr.
s nextPutAll:'OBJS='.
--- a/Rectangle.st Fri May 19 15:33:11 1995 +0200
+++ b/Rectangle.st Wed May 24 14:44:58 1995 +0200
@@ -10,7 +10,7 @@
hereby transferred.
"
-Object subclass:#Rectangle
+Geometric subclass:#Rectangle
instanceVariableNames:'left top width height'
classVariableNames:''
poolDictionaries:''
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Rectangle.st,v 1.19 1995-05-01 21:38:45 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Rectangle.st,v 1.20 1995-05-24 12:44:01 claus Exp $
'!
!Rectangle class methodsFor:'documentation'!
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Rectangle.st,v 1.19 1995-05-01 21:38:45 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Rectangle.st,v 1.20 1995-05-24 12:44:01 claus Exp $
"
!
@@ -173,7 +173,9 @@
^ Display rectangleFromUser
- "Rectangle fromUser"
+ "
+ Rectangle fromUser
+ "
! !
!Rectangle methodsFor:'accessing'!
@@ -460,6 +462,130 @@
+ ((width hash) bitXor:(height hash))
! !
+!Rectangle methodsFor:'converting'!
+
+asFractionalLayout
+ "return a layoutFrame in which fractions (top, left, bottom, right)
+ are taken from corresponding edges of the receiver.
+ You have to make certain that those are in 0..1."
+
+ |l|
+
+ l := LayoutFrame new.
+ l
+ leftFraction:(self left);
+ rightFraction:(self right);
+ topFraction:(self top);
+ bottomFraction:(self bottom).
+ ^ l
+
+ "
+ (0.5@0.5 corner:0.75@0.75) asFractionalLayout
+ (0.5@0.5 corner:0.75@0.75) asOffsetLayout
+ (0.5@0.5 corner:0.75@0.75) asLayout
+ "
+!
+
+asOffsetLayout
+ "return a layoutFrame in which offsets (top, left, bottom, right)
+ are taken from corresponding edges of the receiver.
+ You have to make certain that those are in 0..1."
+
+ |l|
+
+ l := LayoutFrame new.
+ l
+ leftOffset:(self left);
+ rightFraction:0 offset:(self right);
+ topOffset:(self top);
+ bottomFraction:0 offset:(self bottom).
+ ^ l
+
+ "
+ (0.5@0.5 corner:0.75@0.75) asFractionalLayout
+ (0.5@0.5 corner:0.75@0.75) asOffsetLayout
+ (0.5@0.5 corner:0.75@0.75) asLayout
+
+ (10@10 corner:20@20) asFractionalLayout
+ (10@10 corner:20@20) asOffsetLayout
+ (10@10 corner:20@20) asLayout
+ "
+
+!
+
+asLayout
+ "return a layoutFrame in which offsets (top, left, bottom, right)
+ are taken from corresponding edges of the receiver.
+ If all values are between 0..1, a fractionalLayout is created,
+ otherwise, an offsetLayout"
+
+ |l left right top bot|
+
+ l := LayoutFrame new.
+ left := (self left).
+ right := (self right).
+ top := (self top).
+ bot := (self bottom).
+ ((left between:0 and:1)
+ and:[(right between:0 and:1)
+ and:[(top between:0 and:1)
+ and:[(bot between:0 and:1)]]]) ifTrue:[
+ l
+ leftFraction:left;
+ rightFraction:right;
+ topFraction:top;
+ bottomFraction:bot.
+ ] ifFalse:[
+ l
+ leftOffset:left;
+ rightFraction:0 offset:right;
+ topOffset:top;
+ bottomFraction:0 offset:bot.
+ ].
+ ^ l
+
+ "
+ (0.5@0.5 corner:0.75@0.75) asFractionalLayout
+ (0.5@0.5 corner:0.75@0.75) asOffsetLayout
+ (0.5@0.5 corner:0.75@0.75) asLayout
+ (0@0 corner:1@1) asLayout
+ (0@0 corner:1@1) asFractionalLayout
+ (0@0 corner:1@1) asOffsetLayout
+ "
+!
+
+asPointArray
+ "return an array containing my corners (clockwise) and
+ the origin again as 5th element. Can be used to convert
+ a rectangle into a polygon."
+
+ |org|
+
+ ^ Array with:(org := self origin)
+ with:self topRight
+ with:self corner
+ with:self bottomLeft
+ with:org
+
+ "
+ (10@10 corner:100@100) asPointArray
+ "
+!
+
+rectangleRelativeTo:aRectangle preferred:prefRect
+ "compute a displayRectangle, treating the receiver like a
+ layoutorigin. This allows point to be used interchangable with
+ LayoutOrigins."
+
+ ^ (self asLayout) rectangleRelativeTo:aRectangle preferred:prefRect
+
+ "
+ (10@20 corner:20@30) rectangleRelativeTo:(0@0 corner:100@100) preferred:(0@0 corner:50@50)
+
+ (0.5@0.5) rectangleRelativeTo:(0@0 corner:100@100) preferred:(0@0 corner:50@50)
+ "
+! !
+
!Rectangle methodsFor:'queries'!
isRectangle
@@ -628,6 +754,54 @@
left := left + aPoint x.
top := top + aPoint y
+!
+
+expandBy:delta
+ "destructively expanded the receiver in all directions
+ by amount, a Point, Rectangle or Number.
+ Warning: this is a destructive operation, modifying the receiver
+ NOT returning a copy. You have to be certain to be the exclusive
+ owner of the receiver to avoid side effects. See also: #expandedBy:"
+
+ |amountPoint deltaLeft deltaTop deltaWidth deltaHeight|
+
+ delta isNumber ifTrue:[
+ deltaLeft := deltaTop := delta.
+ deltaWidth := deltaHeight := delta * 2.
+ ] ifFalse:[
+ delta isRectangle ifTrue:[
+ deltaLeft := delta left.
+ deltaTop := delta top.
+ deltaWidth := deltaLeft + delta right.
+ deltaHeight := deltaTop + delta bottom
+ ] ifFalse:[
+ amountPoint := delta asPoint.
+ deltaLeft := amountPoint x.
+ deltaTop := amountPoint y.
+ deltaWidth := deltaLeft * 2.
+ deltaHeight := deltaTop * 2.
+ ]
+ ].
+
+ left := (left - deltaLeft).
+ top := (top - deltaTop).
+ width := (width + deltaWidth).
+ height := (height + deltaHeight).
+
+ "
+ |r|
+ r := Rectangle origin:10@10 corner:100@100.
+ r expandBy:5.
+
+ r := Rectangle origin:10@10 corner:100@100.
+ r expandBy:(5 @ 0).
+
+ r := Rectangle origin:10@10 corner:100@100.
+ r expandBy:(10 @ 10).
+
+ r := Rectangle origin:10@10 corner:100@100.
+ r expandBy:( 10@10 corner:20@20 )
+ "
! !
!Rectangle methodsFor:'rectangle operations'!
@@ -662,7 +836,7 @@
!
+ aPoint
- "return a Rectangle with same extent as receiver but
+ "return a new rectangle with same extent as receiver but
origin translated by the argument, aPoint"
|amountPoint|
@@ -672,53 +846,30 @@
top:(top + amountPoint y)
width:width
height:height
-
-"/ ^ Rectangle origin:(self origin + aPoint) extent:(self extent)
!
rounded
+ "return a copy of the receiver with rounded coordinates"
+
^ Rectangle left:(left rounded)
top:(top rounded)
width:(width rounded)
height:(height rounded)
!
-expandBy:delta
+expandedBy:delta
"return a new rectangle which is expanded in all directions
by amount, a Point, Rectangle or Number"
- |amountPoint deltaLeft deltaTop deltaWidth deltaHeight|
-
- delta isNumber ifTrue:[
- deltaLeft := deltaTop := delta.
- deltaWidth := deltaHeight := delta * 2.
- ] ifFalse:[
- delta isRectangle ifTrue:[
- deltaLeft := delta left.
- deltaTop := delta top.
- deltaWidth := deltaLeft + delta right.
- deltaHeight := deltaTop + delta bottom
- ] ifFalse:[
- amountPoint := delta asPoint.
- deltaLeft := amountPoint x.
- deltaTop := amountPoint y.
- deltaWidth := deltaLeft * 2.
- deltaHeight := deltaTop * 2.
- ]
- ].
-
- ^ Rectangle left:(left - deltaLeft)
- top:(top - deltaTop)
- width:(width + deltaWidth)
- height:(height + deltaHeight)
+ ^ self copy expandBy:delta
"
|r|
r := Rectangle origin:10@10 corner:100@100.
- r expandBy:5.
- r expandBy:(5 @ 0).
- r expandBy:(10 @ 10).
- r expandBy:( 10@10 corner:20@20 )
+ r expandedBy:5.
+ r expandedBy:(5 @ 0).
+ r expandedBy:(10 @ 10).
+ r expandedBy:( 10@10 corner:20@20 )
"
!
@@ -898,6 +1049,34 @@
^ self areasOutside:aRectangle
! !
+!Rectangle methodsFor:'displaying'!
+
+displayStrokedOn:aGC
+ aGC displayRectangleX:left y:top width:width height:height
+
+ "
+ |v|
+
+ v := View new open.
+ [v shown] whileFalse:[Processor yield].
+
+ (Rectangle origin:10@10 corner:50@50) displayStrokedOn:v
+ "
+!
+
+displayFilledOn:aGC
+ aGC fillRectangleX:left y:top width:width height:height
+
+ "
+ |v|
+
+ v := View new open.
+ [v shown] whileFalse:[Processor yield].
+
+ (Rectangle origin:10@10 corner:50@50) displayFilledOn:v
+ "
+! !
+
!Rectangle methodsFor:'printing & storing'!
printOn:aStream
--- a/SeqColl.st Fri May 19 15:33:11 1995 +0200
+++ b/SeqColl.st Wed May 24 14:44:58 1995 +0200
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Attic/SeqColl.st,v 1.28 1995-05-18 15:10:08 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/SeqColl.st,v 1.29 1995-05-24 12:44:09 claus Exp $
'!
!SequenceableCollection class methodsFor:'documentation'!
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Attic/SeqColl.st,v 1.28 1995-05-18 15:10:08 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/SeqColl.st,v 1.29 1995-05-24 12:44:09 claus Exp $
"
!
@@ -1771,6 +1771,28 @@
"
!
+pairWiseDo:aBlock
+ "evaluate the argument, aBlock for every pair of elements in the collection.
+ The block is called with 2 arguments for each 2 elements in the receiver.
+ An error will be reported, if the number of elements in the receiver
+ is not a multiple of 2."
+
+ |stop "{ Class:SmallInteger }"|
+
+ stop := self size.
+ 1 to:stop by:2 do:[:index |
+ aBlock value:(self at:index) value:(self at:index+1).
+ ]
+ "
+ #(1 one 2 two 3 three 4 four 5 five 6 six)
+ pairWiseDo:[:num :sym | Transcript show:num; show:' is: '; showCr:sym]
+
+
+ #(1 1 1 2 1 3 1 4 1 5)
+ pairWiseDo:[:x :y | Transcript showCr:x@y]
+ "
+!
+
keysAndValuesDo:aTwoArgBlock
"evaluate the argument, aBlock for every element in the collection,
passing both index and element as arguments."
@@ -1876,6 +1898,34 @@
"
!
+pairWiseCollect:aBlock
+ "evaluate the argument, aBlock for every pair of elements in the collection.
+ The block is called with 2 arguments for each 2 elements in the receiver.
+ An error will be reported, if the number of elements in the receiver
+ is not a multiple of 2.
+ Collect the results and return a new collection containing those."
+
+ |stop newCollection dstIdx "{ Class:SmallInteger }"|
+
+ stop := self size.
+ newCollection := self copyEmptyAndGrow:stop // 2.
+ dstIdx := 1.
+ 1 to:stop by:2 do:[:index |
+ newCollection at:dstIdx put:(aBlock value:(self at:index) value:(self at:index+1)).
+ dstIdx := dstIdx + 1
+ ].
+ ^ newCollection
+
+ "
+ #(1 one 2 two 3 three 4 four 5 five 6 six)
+ pairWiseCollect:[:num :sym | sym->num]
+
+
+ #(1 1 1 2 1 3 1 4 1 5)
+ pairWiseCollect:[:x :y | x@y]
+ "
+!
+
from:start to:stop collect:aBlock
"evaluate the argument, aBlock for the elements indexed by start
to stop in the collection and return a collection of the results"
--- a/SequenceableCollection.st Fri May 19 15:33:11 1995 +0200
+++ b/SequenceableCollection.st Wed May 24 14:44:58 1995 +0200
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/SequenceableCollection.st,v 1.28 1995-05-18 15:10:08 claus Exp $
+$Header: /cvs/stx/stx/libbasic/SequenceableCollection.st,v 1.29 1995-05-24 12:44:09 claus Exp $
'!
!SequenceableCollection class methodsFor:'documentation'!
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/SequenceableCollection.st,v 1.28 1995-05-18 15:10:08 claus Exp $
+$Header: /cvs/stx/stx/libbasic/SequenceableCollection.st,v 1.29 1995-05-24 12:44:09 claus Exp $
"
!
@@ -1771,6 +1771,28 @@
"
!
+pairWiseDo:aBlock
+ "evaluate the argument, aBlock for every pair of elements in the collection.
+ The block is called with 2 arguments for each 2 elements in the receiver.
+ An error will be reported, if the number of elements in the receiver
+ is not a multiple of 2."
+
+ |stop "{ Class:SmallInteger }"|
+
+ stop := self size.
+ 1 to:stop by:2 do:[:index |
+ aBlock value:(self at:index) value:(self at:index+1).
+ ]
+ "
+ #(1 one 2 two 3 three 4 four 5 five 6 six)
+ pairWiseDo:[:num :sym | Transcript show:num; show:' is: '; showCr:sym]
+
+
+ #(1 1 1 2 1 3 1 4 1 5)
+ pairWiseDo:[:x :y | Transcript showCr:x@y]
+ "
+!
+
keysAndValuesDo:aTwoArgBlock
"evaluate the argument, aBlock for every element in the collection,
passing both index and element as arguments."
@@ -1876,6 +1898,34 @@
"
!
+pairWiseCollect:aBlock
+ "evaluate the argument, aBlock for every pair of elements in the collection.
+ The block is called with 2 arguments for each 2 elements in the receiver.
+ An error will be reported, if the number of elements in the receiver
+ is not a multiple of 2.
+ Collect the results and return a new collection containing those."
+
+ |stop newCollection dstIdx "{ Class:SmallInteger }"|
+
+ stop := self size.
+ newCollection := self copyEmptyAndGrow:stop // 2.
+ dstIdx := 1.
+ 1 to:stop by:2 do:[:index |
+ newCollection at:dstIdx put:(aBlock value:(self at:index) value:(self at:index+1)).
+ dstIdx := dstIdx + 1
+ ].
+ ^ newCollection
+
+ "
+ #(1 one 2 two 3 three 4 four 5 five 6 six)
+ pairWiseCollect:[:num :sym | sym->num]
+
+
+ #(1 1 1 2 1 3 1 4 1 5)
+ pairWiseCollect:[:x :y | x@y]
+ "
+!
+
from:start to:stop collect:aBlock
"evaluate the argument, aBlock for the elements indexed by start
to stop in the collection and return a collection of the results"
--- a/Smalltalk.st Fri May 19 15:33:11 1995 +0200
+++ b/Smalltalk.st Wed May 24 14:44:58 1995 +0200
@@ -27,7 +27,7 @@
COPYRIGHT (c) 1988 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Smalltalk.st,v 1.49 1995-05-19 03:56:55 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Smalltalk.st,v 1.50 1995-05-24 12:44:21 claus Exp $
'!
"
@@ -56,7 +56,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Smalltalk.st,v 1.49 1995-05-19 03:56:55 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Smalltalk.st,v 1.50 1995-05-24 12:44:21 claus Exp $
"
!
@@ -1294,14 +1294,14 @@
((self at:sym) == aClass) ifFalse:[
"check other name ..."
(self includes:aClass) ifFalse:[
- 'no such class' errorPrintNL.
+ 'SMALLTALK: no such class: ' errorPrint. oldName errorPrintNL.
^ self
].
"
the class has changed its name - without telling me ...
what should be done in this case ?
"
- 'class ' errorPrint. oldName errorPrint.
+ 'SMALLTALK: class ' errorPrint. oldName errorPrint.
' has changed its name' errorPrintNL.
^ self
].
@@ -1837,7 +1837,7 @@
- look for it in some standard places;
return true if ok, false if failed."
- |path|
+ |path ok|
"
check if the dynamic loader class is in
@@ -1845,7 +1845,11 @@
ObjectFileLoader isNil ifTrue:[^ false].
(path := self getBinaryFileName:aFileName) isNil ifTrue:[^ false].
- ^ (ObjectFileLoader loadClass:aClassName fromObjectFile:path) notNil
+ ok := (ObjectFileLoader loadClass:aClassName fromObjectFile:path) notNil.
+ ok ifTrue:[
+ Transcript show:' loaded ' , aClassName , ' from ' ; showCr:aFileName.
+ ].
+ ^ ok
"
Smalltalk fileInClass:'AbstractPath' fromObject:'../../goodies/Paths/AbstrPath.so'
--- a/Symbol.st Fri May 19 15:33:11 1995 +0200
+++ b/Symbol.st Wed May 24 14:44:58 1995 +0200
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1988 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Symbol.st,v 1.23 1995-05-16 17:09:21 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Symbol.st,v 1.24 1995-05-24 12:44:31 claus Exp $
'!
!Symbol class methodsFor:'documentation'!
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Symbol.st,v 1.23 1995-05-16 17:09:21 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Symbol.st,v 1.24 1995-05-24 12:44:31 claus Exp $
"
!
@@ -285,6 +285,58 @@
^ true
! !
+!Symbol methodsFor:'comparing'!
+
+identityHash
+ "interned symbols can return a better hash key"
+
+%{ /* NOCONTEXT */
+
+ REGISTER int g, val;
+ REGISTER unsigned char *cp, *cp0;
+ int l;
+
+ if (__Class(self) == Symbol) {
+ val = _GET_HASH(self);
+ /*
+ * only do it, if I have no standard hash key
+ * assigned.
+ */
+ if (val == 0) {
+ cp = _stringVal(self);
+ l = _stringSize(self);
+
+ /*
+ * this is the dragon-book algorithm
+ *
+ * the algorithm hashes pretty good:
+ * with (currently) 9963 symbols in the system,
+ * there are only about 200 hash key collisions.
+ * where the maximum collision count in these 200
+ * is 3. This means, that in most situations,
+ * a single probe will find the right element in
+ * a symbol-hashed collection.
+ */
+ val = 0;
+ for (cp0 = cp, cp += l - 1; cp >= cp0; cp--) {
+ val = (val << 5) + (*cp & 0x1F);
+ if (g = (val & 0x3E000000))
+ val ^= g >> 25 /* 23 */ /* 25 */;
+ val &= 0x3FFFFFFF;
+ }
+
+ if (l) {
+ l |= 1;
+ val = (val * l) & 0x3FFFFFFF;
+ }
+
+ RETURN ( _MKSMALLINT(val) );
+ }
+ }
+%}.
+ ^ super identityHash
+! !
+
!Symbol methodsFor:'system primitives'!
become:anotherObject
--- a/UndefObj.st Fri May 19 15:33:11 1995 +0200
+++ b/UndefObj.st Wed May 24 14:44:58 1995 +0200
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1988 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Attic/UndefObj.st,v 1.14 1995-03-06 19:18:09 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/UndefObj.st,v 1.15 1995-05-24 12:44:40 claus Exp $
'!
!UndefinedObject class methodsFor:'documentation'!
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Attic/UndefObj.st,v 1.14 1995-03-06 19:18:09 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/UndefObj.st,v 1.15 1995-05-24 12:44:40 claus Exp $
"
!
@@ -215,9 +215,16 @@
!UndefinedObject methodsFor:'subclass creation'!
nilSubclass:selector args:args
- "common helper for subclass creation."
+ "common helper for subclass creation.
+ Creates a nil-superclass class with entries for the minimum
+ required protocol (#class, #isBehavior and #doesNotUnderstand:).
+ These are required to avoid getting into deep trouble when
+ inspecting or debugging instances of this new class.
- |newClass|
+ The methods get a modified source code to remind you that these
+ methods were automatically generated."
+
+ |newClass mA|
Class withoutUpdatingChangesDo:
[
@@ -225,11 +232,37 @@
].
newClass notNil ifTrue:[
newClass setSuperclass:nil.
+
+ "
+ copy over method objects from Object
+ "
newClass
- setSelectors:(Array with:#class
- with:#doesNotUnderstand:)
- methods:(Array with:(Object compiledMethodAt:#class)
- with:(Object compiledMethodAt:#doesNotUnderstand:)).
+ setSelectors:(Array
+ with:#class
+ with:#isBehavior
+ with:#doesNotUnderstand:)
+ methods:(mA := Array
+ with:(Object compiledMethodAt:#class) copy
+ with:(Object compiledMethodAt:#isBehavior) copy
+ with:(Object compiledMethodAt:#doesNotUnderstand:) copy).
+
+ "
+ and modify the source code
+ "
+ mA do:[:m |
+ m source:m source , '
+"
+*** WARNING
+***
+*** this method has been automatically created,
+*** since all nil-subclasses should respond to some minimum required
+*** protocol.
+***
+*** Inspection and/or debugging of instances may not be possible,
+*** if you remove/change this method.
+"
+'.
+ ].
Class addChangeRecordForClass:newClass.
].
^ newClass
--- a/UndefinedObject.st Fri May 19 15:33:11 1995 +0200
+++ b/UndefinedObject.st Wed May 24 14:44:58 1995 +0200
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1988 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/UndefinedObject.st,v 1.14 1995-03-06 19:18:09 claus Exp $
+$Header: /cvs/stx/stx/libbasic/UndefinedObject.st,v 1.15 1995-05-24 12:44:40 claus Exp $
'!
!UndefinedObject class methodsFor:'documentation'!
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/UndefinedObject.st,v 1.14 1995-03-06 19:18:09 claus Exp $
+$Header: /cvs/stx/stx/libbasic/UndefinedObject.st,v 1.15 1995-05-24 12:44:40 claus Exp $
"
!
@@ -215,9 +215,16 @@
!UndefinedObject methodsFor:'subclass creation'!
nilSubclass:selector args:args
- "common helper for subclass creation."
+ "common helper for subclass creation.
+ Creates a nil-superclass class with entries for the minimum
+ required protocol (#class, #isBehavior and #doesNotUnderstand:).
+ These are required to avoid getting into deep trouble when
+ inspecting or debugging instances of this new class.
- |newClass|
+ The methods get a modified source code to remind you that these
+ methods were automatically generated."
+
+ |newClass mA|
Class withoutUpdatingChangesDo:
[
@@ -225,11 +232,37 @@
].
newClass notNil ifTrue:[
newClass setSuperclass:nil.
+
+ "
+ copy over method objects from Object
+ "
newClass
- setSelectors:(Array with:#class
- with:#doesNotUnderstand:)
- methods:(Array with:(Object compiledMethodAt:#class)
- with:(Object compiledMethodAt:#doesNotUnderstand:)).
+ setSelectors:(Array
+ with:#class
+ with:#isBehavior
+ with:#doesNotUnderstand:)
+ methods:(mA := Array
+ with:(Object compiledMethodAt:#class) copy
+ with:(Object compiledMethodAt:#isBehavior) copy
+ with:(Object compiledMethodAt:#doesNotUnderstand:) copy).
+
+ "
+ and modify the source code
+ "
+ mA do:[:m |
+ m source:m source , '
+"
+*** WARNING
+***
+*** this method has been automatically created,
+*** since all nil-subclasses should respond to some minimum required
+*** protocol.
+***
+*** Inspection and/or debugging of instances may not be possible,
+*** if you remove/change this method.
+"
+'.
+ ].
Class addChangeRecordForClass:newClass.
].
^ newClass
--- a/Unix.st Fri May 19 15:33:11 1995 +0200
+++ b/Unix.st Wed May 24 14:44:58 1995 +0200
@@ -22,7 +22,7 @@
COPYRIGHT (c) 1988 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Attic/Unix.st,v 1.36 1995-05-19 03:57:12 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/Unix.st,v 1.37 1995-05-24 12:44:46 claus Exp $
'!
!OperatingSystem primitiveDefinitions!
@@ -156,7 +156,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Attic/Unix.st,v 1.36 1995-05-19 03:57:12 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/Unix.st,v 1.37 1995-05-24 12:44:46 claus Exp $
"
!
@@ -1630,9 +1630,9 @@
unblocking, in case of nested block/unblock calls."
%{ /* NOCONTEXT */
- extern OBJ BLOCKINTERRUPTS();
-
- return ( BLOCKINTERRUPTS() );
+ extern OBJ __BLOCKINTERRUPTS();
+
+ return ( __BLOCKINTERRUPTS() );
%}
!
@@ -1643,9 +1643,9 @@
calls - you must only unblock after a blockcall if they where
really not blocked before. See OperatingSystemclass>>blockInterrupts."
%{
- extern void UNBLOCKINTERRUPTS();
-
- UNBLOCKINTERRUPTS(SENDER);
+ extern void __UNBLOCKINTERRUPTS();
+
+ __UNBLOCKINTERRUPTS();
%}
!
@@ -3236,6 +3236,11 @@
"return true, if the given file is a symbolic link"
^ (self linkInfoOf:aPathName) notNil
+
+ "
+ OperatingSystem isSymbolicLink:'Make.proto'
+ OperatingSystem isSymbolicLink:'Makefile'
+ "
!
linkInfoOf:aPathName
@@ -3281,10 +3286,11 @@
mtimeHi = _MKSMALLINT((buf.st_mtime >> 16) & 0xFFFF);
ctimeLow = _MKSMALLINT(buf.st_ctime & 0xFFFF);
ctimeHi = _MKSMALLINT((buf.st_ctime >> 16) & 0xFFFF);
- if (readlink((char *) _stringVal(aPathName), pathBuffer, sizeof(pathBuffer)) < 0) {
+ if ((ret = readlink((char *) _stringVal(aPathName), pathBuffer, sizeof(pathBuffer))) < 0) {
OperatingSystem_LastErrorNumber = _MKSMALLINT(errno);
RETURN ( nil );
}
+ pathBuffer[ret] = '\0'; /* readlink does not 0-terminate */
path = _MKSTRING(pathBuffer COMMA_CON);
}
%}.