Mercurial Mercurial > hg > stx-libbasic / diff
summary | shortlog | changelog | graph | tags | bookmarks | branches | files | changeset | file | latest | revisions | annotate | diff | comparison | raw | help
Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Metaclass.st
changeset 328 7b542c0bf1dd
parent 326 d2902942491d
child 356 6c5ce0e1e7a8 
--- a/Metaclass.st	Thu Apr 20 20:04:43 1995 +0200
+++ b/Metaclass.st	Mon May 01 23:30:32 1995 +0200
@@ -21,7 +21,7 @@
 COPYRIGHT (c) 1988 by Claus Gittinger
 	      All Rights Reserved
 
-$Header: /cvs/stx/stx/libbasic/Metaclass.st,v 1.23 1995-04-11 14:49:45 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Metaclass.st,v 1.24 1995-05-01 21:30:19 claus Exp $
 '!
 
 !Metaclass class methodsFor:'documentation'!
@@ -42,13 +42,14 @@
 
 version
 "
-$Header: /cvs/stx/stx/libbasic/Metaclass.st,v 1.23 1995-04-11 14:49:45 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Metaclass.st,v 1.24 1995-05-01 21:30:19 claus Exp $
 "
 !
 
 documentation
 "
     every classes class is a subclass of Metaclass.
+    (i.e. every class is the sole instance of its Metaclass)
     Metaclass provides support for creating new (sub)classes and/or 
     changing the definition of an already existing class.
 "
@@ -81,14 +82,19 @@
      classVarChange instVarChange superClassChange newComment
      changeSet1 changeSet2 addedNames
      anyChange oldInstVars newInstVars oldClassVars newClassVars superFlags newFlags
-     currentProject|
+     project currentProject|
 
     "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 ;-)
+     (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 ...
     "
 
+    project := Project. "/ have to fetch this before, in case its autoloaded
+
     newName = aClass name ifTrue:[
 	self error:'trying to create circular class definition'.
 	^ nil
@@ -110,46 +116,51 @@
     oldClass isBehavior ifFalse:[
 	oldClass := nil.
     ] ifTrue:[
-	oldClass superclass notNil ifTrue:[
-	    oldClass allSuperclasses do:[:cls |
-		cls name = nameString ifTrue:[
-		    self error:'trying to create circular class definition'.
-		    ^ nil
-		]
-	    ]
-	].
-
-	aClass superclass notNil ifTrue:[
-	    aClass allSuperclasses do:[:cls |
-		cls name = nameString ifTrue:[
-		    self error:'trying to create circular class definition'.
-		    ^ nil
+	oldClass name ~~ classSymbol ifTrue:[
+	    (self confirm:(classSymbol , ' is an alias for ' , oldClass name , '\\continue ?') withCRs)
+	    ifFalse:[^ self].
+	    oldClass := nil
+	] ifFalse:[
+		oldClass superclass notNil ifTrue:[
+		oldClass allSuperclasses do:[:cls |
+		    cls name = nameString ifTrue:[
+			self error:'trying to create circular class definition'.
+			^ nil
+		    ]
 		]
 	    ].
-	].
 
-	newComment isNil ifTrue:[
-	    newComment := oldClass comment
-	].
+	    aClass superclass notNil ifTrue:[
+		aClass allSuperclasses do:[:cls |
+		    cls name = nameString ifTrue:[
+			self error:'trying to create circular class definition'.
+			^ nil
+		    ]
+		].
+	    ].
+
+	    newComment isNil ifTrue:[
+		newComment := oldClass comment
+	    ].
 
-	"
-	 warn, if it exists with different category and different instvars,
-	 and the existing is not an autoload class.
-	 Usually, this indicates that someone wants to create a new class with
-	 a name, which already exists (it happened a few times to myself, while 
-	 I wanted to create a new class called ReturnNode ...).
-	 This will be much less of a problem, once multiple name spaces are
-	 implemented and classes can be put into separate packages.
-	"
-	oldClass isLoaded ifTrue:[
-	    oldClass category ~= categoryString ifTrue:[
-		oldClass instanceVariableString asCollectionOfWords 
-		~= stringOfInstVarNames asCollectionOfWords ifTrue:[
-		    (self confirm:'a class named ' , oldClass name , ' already exists -
-
-create (i.e. change) anyway ?' withCRs)
-		    ifFalse:[
-			^ nil
+	    "
+	     warn, if it exists with different category and different instvars,
+	     and the existing is not an autoload class.
+	     Usually, this indicates that someone wants to create a new class with
+	     a name, which already exists (it happened a few times to myself, while 
+	     I wanted to create a new class called ReturnNode ...).
+	     This will be much less of a problem, once multiple name spaces are
+	     implemented and classes can be put into separate packages.
+	    "
+	    oldClass isLoaded ifTrue:[
+		oldClass category ~= categoryString ifTrue:[
+		    oldClass instanceVariableString asCollectionOfWords 
+		    ~= stringOfInstVarNames asCollectionOfWords ifTrue:[
+			(self confirm:'a class named ' , oldClass name , 
+				      ' already exists -\\create (i.e. change) anyway ?' withCRs)
+			ifFalse:[
+			    ^ nil
+			]
 		    ]
 		]
 	    ]
@@ -182,9 +193,9 @@
     newMetaclass classVariableString:'' "stringOfClassVarNames".
 "/    newMetaclass setComment:newComment category:categoryString.
 
-    Project notNil ifTrue:[
-	currentProject := Project current.
-        currentProject notNil ifTrue:[
+    project notNil ifTrue:[
+	currentProject := project current.
+	currentProject notNil ifTrue:[
 	    newMetaclass package:(currentProject packageName)
 	]
     ].
@@ -266,9 +277,9 @@
 	aSystemDictionary at:classSymbol put:newClass.
 
 	oldClass isNil ifTrue:[
-	    Project notNil ifTrue:[
-	        currentProject := Project current.
-	        currentProject notNil ifTrue:[
+	    project notNil ifTrue:[
+		currentProject := project current.
+		currentProject notNil ifTrue:[
 		    "
 		     new classes get the package assigned
 		    "
@@ -455,7 +466,7 @@
 				    for:newMetaclass 
 			   accessingAny:changeSet1
 				orSuper:true.
-	newMetaclass recompileInvalidatedMethods:(Metaclass compiledMethodAt:#invalidMethod).
+	newMetaclass recompileInvalidatedMethods:(Metaclass compiledMethodAt:#invalidCodeObject).
     ] ifFalse:[
 	"
 	 same superclass, find out which classvars have changed
@@ -483,7 +494,7 @@
 	    Transcript endEntry.
 " "
 	    self copyInvalidatedMethodsFrom:(oldClass class) for:newMetaclass accessingAny:changeSet1.
-	    newMetaclass recompileInvalidatedMethods:(Metaclass compiledMethodAt:#invalidMethod).
+	    newMetaclass recompileInvalidatedMethods:(Metaclass compiledMethodAt:#invalidCodeObject).
 	] ifFalse:[
 	    "
 	     class methods still work
@@ -523,7 +534,7 @@
 				    for:newClass 
 			   accessingAny:changeSet2
 				orSuper:true.
-	newClass recompileInvalidatedMethods:(Metaclass compiledMethodAt:#invalidMethod).
+	newClass recompileInvalidatedMethods:(Metaclass compiledMethodAt:#invalidCodeObject).
 
     ] ifFalse:[
 	"
@@ -542,7 +553,7 @@
 		Transcript endEntry.
 " "
 		self copyInvalidatedMethodsFrom:oldClass for:newClass accessingAny:changeSet1.
-		newClass recompileInvalidatedMethods:(Metaclass compiledMethodAt:#invalidMethod).
+		newClass recompileInvalidatedMethods:(Metaclass compiledMethodAt:#invalidCodeObject).
 	    ]
 	] ifTrue:[
 	    "
@@ -593,7 +604,7 @@
 		Transcript endEntry.
 " "
 		self copyInvalidatedMethodsFrom:oldClass for:newClass accessingAny:changeSet2.
-		newClass recompileInvalidatedMethods:(Metaclass compiledMethodAt:#invalidMethod).
+		newClass recompileInvalidatedMethods:(Metaclass compiledMethodAt:#invalidCodeObject).
 	    ].
 	].
     ].
@@ -660,10 +671,10 @@
 
     newClass := self basicNew.
     newClass setSuperclass:(Object class)
-		 selectors:(Array new:0)
-		   methods:(Array new:0)
-		  instSize:0
-		     flags:(Behavior flagNotIndexed).
+	       selectors:(Array new:0)
+		 methods:(Array new:0)
+		instSize:0
+		   flags:(Behavior flagNotIndexed).
 "/    newClass setComment:(self comment) category:(self category).
     ^ newClass
 ! !
@@ -846,7 +857,7 @@
 	 recompile class-methods
 	"
 	self copyInvalidatedMethodsFrom:self for:newMetaclass accessingAny:changeSet.
-	newMetaclass recompileInvalidatedMethods:(Metaclass compiledMethodAt:#invalidMethod).
+	newMetaclass recompileInvalidatedMethods:(Metaclass compiledMethodAt:#invalidCodeObject).
 
 	self copyMethodsFrom:oldClass for:newClass.
     ].
@@ -983,7 +994,7 @@
 
 !Metaclass methodsFor:'private'!
 
-invalidMethod
+invalidCodeObject
     "When recompiling classes after a definition-change, all
      uncompilable methods will be bound to this method here,
      so that evaluating such an uncompilable method will trigger an error.
@@ -1064,7 +1075,7 @@
 
     |trap trapCode trapByteCode oldMethod newMethod oldMethodArray newMethodArray|
 
-    trap := Metaclass compiledMethodAt:#invalidMethod.
+    trap := Metaclass compiledMethodAt:#invalidCodeObject.
     trapCode := trap code.
     trapByteCode := trap byteCode.
 
@@ -1107,7 +1118,7 @@
     |trap trapCode trapByteCode p source mustInvalidate
      oldMethod newMethod oldMethodArray newMethodArray|
 
-    trap := Metaclass compiledMethodAt:#invalidMethod.
+    trap := Metaclass compiledMethodAt:#invalidCodeObject.
     trapCode := trap code.
     trapByteCode := trap byteCode.
 
@@ -1163,7 +1174,7 @@
 
     |trap trapCode trapByteCode|
 
-    trap := Metaclass compiledMethodAt:#invalidMethod.
+    trap := Metaclass compiledMethodAt:#invalidCodeObject.
     trapCode := trap code.
     trapByteCode := trap byteCode.
hg/stx-libbasic