[Help-smalltalk] [PATCH] first round of scripting changes

[Paolo Bonzini]

Actually, the second (I had added <category: 'foo'> last week
but I forgot to send the patch to the list).

This adds #shape:, #subclass: and #instanceVariableNames: to Class.
These methods will be called when parsing the new syntax, but may
also be useful for those who want to stick with message-sending.

Unlike Mike's version of #subclass:, this one does not eliminate
the instance variables of the class if it is already defined.
That is, after this:

    Object subclass: #A!
    A instanceVariableNames: 'a'!
    Number subclass: #A!

class `A' will still have one instance variable named `a'.

Paolo

2007-03-28  Palo Bonzini  <address@hidden>

        * kernel/AnsiExcept.st: Force MutationError's creator to be nil.
        * kernel/Builtins.st: Add #subclass:, always return class from
        class creation stubs.
        * kernel/Class.st: Add #shape: and #subclass:.
        * kernel/ClassDescription.st: Add #instanceVariableNames:.
        * kernel/Metaclass.st: Remove #instanceVariableNames:, add
        #name:environment:subclassOf: (used by Class>>#subclass:).
        * kernel/UndefObject.st: Add #subclass:.

        * tests/mutate.st: Add tests for #subclass:.



--- orig/kernel/AnsiExcept.st
+++ mod/kernel/AnsiExcept.st
@@ -1172,6 +1172,15 @@ description
     "Answer a textual description of the exception."
     ^'file system error'! !
 
+!SystemExceptions.MutationError class methodsFor: 'instance creation'!
+
+new
+    "Create an instance of the receiver, which you will be able to
+     signal later."
+
+    ^self basicNew
+       initialize: nil! !
+
 !SystemExceptions.MutationError methodsFor: 'accessing'!
 
 description


--- orig/kernel/Builtins.st
+++ mod/kernel/Builtins.st
@@ -2628,11 +2628,15 @@ the system, and the C definition of the 
 !Class methodsFor: 'builtins'!
 
 subclass: classNameString
+    ^(Smalltalk at: classNameString)
+!
+
+subclass: classNameString
   instanceVariableNames: stringInstVarNames
   classVariableNames: stringOfClassVarNames
   poolDictionaries: stringOfPoolNames
   category: categoryNameString
-    (Smalltalk at: classNameString) category: categoryNameString
+    ^(Smalltalk at: classNameString) category: categoryNameString
 !
 
 variable: shape subclass: classNameString
@@ -2640,7 +2644,7 @@ variable: shape subclass: classNameStrin
   classVariableNames: stringOfClassVarNames
   poolDictionaries: stringOfPoolNames
   category: categoryNameString
-    (Smalltalk at: classNameString) category: categoryNameString
+    ^(Smalltalk at: classNameString) category: categoryNameString
 !
 
 variableSubclass: classNameString
@@ -2648,7 +2652,7 @@ variableSubclass: classNameString
   classVariableNames: stringOfClassVarNames
   poolDictionaries: stringOfPoolNames
   category: categoryNameString
-    (Smalltalk at: classNameString) category: categoryNameString
+    ^(Smalltalk at: classNameString) category: categoryNameString
 !
 
 variableWordSubclass: classNameString
@@ -2656,7 +2660,7 @@ variableWordSubclass: classNameString
   classVariableNames: stringOfClassVarNames
   poolDictionaries: stringOfPoolNames
   category: categoryNameString
-    (Smalltalk at: classNameString) category: categoryNameString
+    ^(Smalltalk at: classNameString) category: categoryNameString
 !
 
 variableByteSubclass: classNameString
@@ -2664,7 +2668,7 @@ variableByteSubclass: classNameString
   classVariableNames: stringOfClassVarNames
   poolDictionaries: stringOfPoolNames
   category: categoryNameString
-    (Smalltalk at: classNameString) category: categoryNameString
+    ^(Smalltalk at: classNameString) category: categoryNameString
 ! !
 
 
@@ -2672,11 +2676,15 @@ variableByteSubclass: classNameString
 !UndefinedObject methodsFor: 'builtins'!
 
 subclass: classNameString
+    ^(Smalltalk at: classNameString)
+!
+
+subclass: classNameString
   instanceVariableNames: stringInstVarNames
   classVariableNames: stringOfClassVarNames
   poolDictionaries: stringOfPoolNames
   category: categoryNameString
-    (Smalltalk at: classNameString) category: categoryNameString
+    ^(Smalltalk at: classNameString) category: categoryNameString
 !
 
 variable: shape subclass: classNameString
@@ -2684,7 +2692,7 @@ variable: shape subclass: classNameStrin
   classVariableNames: stringOfClassVarNames
   poolDictionaries: stringOfPoolNames
   category: categoryNameString
-    (Smalltalk at: classNameString) category: categoryNameString
+    ^(Smalltalk at: classNameString) category: categoryNameString
 !
 
 variableSubclass: classNameString
@@ -2692,7 +2700,7 @@ variableSubclass: classNameString
   classVariableNames: stringOfClassVarNames
   poolDictionaries: stringOfPoolNames
   category: categoryNameString
-    (Smalltalk at: classNameString) category: categoryNameString
+    ^(Smalltalk at: classNameString) category: categoryNameString
 !
 
 variableWordSubclass: classNameString
@@ -2700,7 +2708,7 @@ variableWordSubclass: classNameString
   classVariableNames: stringOfClassVarNames
   poolDictionaries: stringOfPoolNames
   category: categoryNameString
-    (Smalltalk at: classNameString) category: categoryNameString
+    ^(Smalltalk at: classNameString) category: categoryNameString
 !
 
 variableByteSubclass: classNameString
@@ -2708,7 +2716,7 @@ variableByteSubclass: classNameString
   classVariableNames: stringOfClassVarNames
   poolDictionaries: stringOfPoolNames
   category: categoryNameString
-    (Smalltalk at: classNameString) category: categoryNameString
+    ^(Smalltalk at: classNameString) category: categoryNameString
 ! !
 
 


--- orig/kernel/Class.st
+++ mod/kernel/Class.st
@@ -323,6 +323,35 @@ extend
         withArguments: {self name asSymbol. ''. ''. ''. 'Extensions'}
 !
 
+shape: shape
+    "Give the provided shape to the receiver's instances.
+     The shape can be nil, or one of #byte #int8 #character #short
+     #ushort #int #uint #int64 #uint64 #utf32 #float #double or #pointer."
+
+    self shape == shape ifTrue: [ ^false ].
+    shape isNil
+       ifTrue: [ ^self updateInstanceVars: self allInstVarNames shape: nil ].
+
+    self isVariable
+       ifTrue: [
+            SystemExceptions.MutationError
+                signal: 'Cannot change shape of variable class' ].
+
+    "Changing from fixed to variable.  No need to mutate the instances."
+    self setInstanceSpec: shape instVars: self allInstVarNames size!
+
+subclass: classNameString
+    "Define a subclass of the receiver with the given name.  If the class
+     is already defined, don't modify its instance or class variables
+     but still, if necessary, recompile everything needed."
+
+    | meta |
+    KernelInitialized ifFalse: [ ^(Smalltalk at: classNameString) ].
+    meta := self metaclassFor: classNameString.
+    ^meta name: classNameString
+         environment: Namespace current
+         subclassOf: self!
+
 subclass: classNameString
     instanceVariableNames: stringInstVarNames
     classVariableNames: stringOfClassVarNames
@@ -377,8 +406,8 @@ variable: shape subclass: classNameStrin
     classVariableNames: stringOfClassVarNames
     poolDictionaries: stringOfPoolNames
     category: categoryNameString
-    "Define a variable pointer subclass of the receiver with the given
-     name, instance variables, class variables, pool dictionaries and
+    "Define a variable subclass of the receiver with the given name,
+     shape, instance variables, class variables, pool dictionaries and
      category. If the class is already defined, if necessary, recompile
      everything needed.  The shape can be one of #byte #int8 #character
      #short #ushort #int #uint #int64 #uint64 #utf32 #float #double or


--- orig/kernel/ClassDesc.st
+++ mod/kernel/ClassDesc.st
@@ -401,3 +401,49 @@ asMetaclass
     "Answer the metaclass associated to the receiver"
     ^self asClass class
 ! !
+
+
+!ClassDescription methodsFor: 'parsing class declarations'!
+
+instanceVariableNames: instVarNames
+
+    "Set the instance variables for the receiver to be those
+     in instVarNames"
+
+    | variableArray variableString oldInstVarNames |
+    variableArray := self parseInstanceVariableString: instVarNames.
+    variableArray := self subclassInstVarNames, variableArray.
+    oldInstVarNames := self allInstVarNames.
+
+    "If instance variables change, update  instance variables and
+     instance spec of the class and all its subclasses "
+
+    variableArray = oldInstVarNames ifTrue: [ ^self ].
+
+    self
+        updateInstanceVars: variableArray
+        shape: self shape.
+
+    "If no variable has been removed, no need to recompile"
+    (oldInstVarNames allSatisfy: [ :each | variableArray includes: each ])
+        ifTrue: [ ^self ].
+
+    Transcript nextPutAll: 'Recompiling classes...'; nl.
+    self compileAll.
+    self compileAllSubclasses
+!
+
+parseInstanceVariableString: variableString
+    | variableArray |
+    variableArray := self parseVariableString: variableString.
+    variableArray := variableArray collect: [ :each | each asSymbol ]
+!
+
+parseVariableString: aString
+    | stream tokens |
+    stream := TokenStream on: aString.
+    tokens := stream contents.
+    tokens do: [ :token | self validateIdentifier: token ].
+    ^tokens
+! !
+


--- orig/kernel/Metaclass.st
+++ mod/kernel/Metaclass.st
@@ -155,32 +155,37 @@ pragmaHandlerFor: aSymbol
 
 !Metaclass methodsFor: 'basic'!
 
-instanceVariableNames: classInstVarNames
+name: className
+    environment: aNamespace
+    subclassOf: superclass
+
+    "Private - create a full featured class and install it, or change the
+     superclass or shape of an existing one; instance variable names,
+     class variable names and pool dictionaries are left untouched."
 
-    "Set the class-instance variables for the receiver to be those
-     in classInstVarNames"
+    | aClass |
 
-    | variableArray variableString |
-    variableString := self superclass instanceVariableString,
-       classInstVarNames.
-    variableArray := self parseInstanceVariableString: variableString.
-
-    "If instance variables change, update  instance variables and
-     instance spec of the class and all its subclasses "
-
-    variableArray = self allInstVarNames ifTrue: [ ^self ].
-
-    self
-       updateInstanceVars: variableArray 
-       shape: nil.
-
-    "If no variable has been removed, no need to recompile"
-    (self allInstVarNames allSatisfy: [ :each | variableArray includes: each ])
-       ifTrue: [ ^self ].
-       
-    Transcript nextPutAll: 'Recompiling classes...'; nl.
-    self compileAll.
-    self compileAllSubclasses
+    "Look for an existing metaclass"
+    aClass := aNamespace hereAt: className ifAbsent: [ nil ].
+    aClass isNil ifTrue: [
+       ^self newMeta: className
+           environment: aNamespace
+           subclassOf: superclass
+           instanceVariableArray: superclass allInstVarNames
+           shape: nil
+           classPool: BindingDictionary new
+           poolDictionaries: #()
+           category: nil
+    ].
+
+    ^self name: className
+       environment: aNamespace
+       subclassOf: superclass
+       instanceVariableArray: superclass allInstVarNames, aClass instVarNames
+       shape: aClass shape
+       classPool: aClass classPool
+       poolDictionaries: aClass sharedPoolDictionaries
+       category: aClass category
 !
 
 name: newName


--- orig/kernel/UndefObject.st
+++ mod/kernel/UndefObject.st
@@ -259,8 +259,8 @@ variable: shape subclass: classNameStrin
     classVariableNames: stringOfClassVarNames
     poolDictionaries: stringOfPoolNames
     category: categoryNameString
-    "Define a variable pointer subclass of the receiver with the given
-     name, instance variables, class variables, pool dictionaries and
+    "Define a variable subclass of the receiver with the given name,
+     shape, instance variables, class variables, pool dictionaries and
      category. If the class is already defined, if necessary, recompile
      everything needed.  The shape can be one of #byte #int8 #character
      #short #ushort #int #uint #int64 #uint64 #utf32 #float #double or
@@ -282,6 +282,19 @@ variable: shape subclass: classNameStrin
            category: categoryNameString
 !
 
+subclass: classNameString
+    "Define a subclass of the receiver with the given name.  If the class
+     is already defined, don't modify its instance or class variables
+     but still, if necessary, recompile everything needed."
+
+    | meta |
+    KernelInitialized ifFalse: [ ^(Smalltalk at: classNameString) ].
+    meta := self metaclassFor: classNameString.
+    ^meta name: classNameString
+          environment: Namespace current
+          subclassOf: self
+          shape: nil!
+
 variableSubclass: classNameString
     instanceVariableNames: stringInstVarNames
     classVariableNames: stringOfClassVarNames


--- orig/tests/mutate.ok
+++ mod/tests/mutate.ok
@@ -30,3 +30,90 @@ B(var1:0 var2:2 )
 nil
 B(var1:0 var2:nil )
 returned value is B new "<0>"
+
+Execution begins...
+returned value is C
+
+Execution begins...
+returned value is true
+
+Execution begins...
+(#key #value )->Set ()
+returned value is Association new "<0>"
+
+Execution begins...
+Recompiling classes...
+returned value is C
+
+Execution begins...
+returned value is true
+
+Execution begins...
+(#a )->Set (#SystemExceptions )
+returned value is Association new "<0>"
+
+Execution begins...
+Recompiling classes...
+returned value is C
+
+Execution begins...
+returned value is true
+
+Execution begins...
+(#a )->Set (#SystemExceptions )
+returned value is Association new "<0>"
+
+Execution begins...
+Recompiling classes...
+returned value is C
+
+Execution begins...
+returned value is true
+
+Execution begins...
+(#key #value #a )->Set (#SystemExceptions )
+returned value is Association new "<0>"
+
+Execution begins...
+Recompiling classes...
+returned value is C
+
+Execution begins...
+returned value is true
+
+Execution begins...
+(#Foo )->()->Set (#SystemExceptions )
+returned value is Association new "<0>"
+
+Execution begins...
+Recompiling classes...
+returned value is C
+
+Execution begins...
+(#Foo )->(#key #value )->Set (#SystemExceptions )
+returned value is Association new "<0>"
+
+Execution begins...
+Recompiling classes...
+returned value is C
+
+Execution begins...
+returned value is true
+
+Execution begins...
+#pointer->(#Foo )->()->Set (#SystemExceptions )
+returned value is Association new "<0>"
+
+Execution begins...
+Recompiling classes...
+returned value is C
+
+Execution begins...
+#pointer->(#Foo )->(#key #value )->Set (#SystemExceptions )
+returned value is Association new "<0>"
+
+Execution begins...
+returned value is CompiledMethod new: 2 "<0>"
+
+Execution begins...
+returned value is true


--- orig/tests/mutate.st
+++ mod/tests/mutate.st
@@ -101,3 +101,39 @@ A addInstVarName: #var2.
 B removeInstVarName: #var2.
 B instance var2 printNl.
 B instance printNl!
+
+
+"Now, test using #subclass: to create classes."
+
+Association subclass: #C!
+C instSize = C allInstVarNames size!
+(C allInstVarNames -> C sharedPools) printNl!
+
+Object subclass: #C instanceVariableNames: 'a' classVariableNames: '' 
poolDictionaries: 'SystemExceptions' category: 'foo'!
+C instSize = C allInstVarNames size!
+(C allInstVarNames -> C sharedPools) printNl!
+
+Array subclass: #C!
+C instSize = C allInstVarNames size!
+(C allInstVarNames -> C sharedPools) printNl!
+
+Association subclass: #C!
+C instSize = C allInstVarNames size!
+(C allInstVarNames -> C sharedPools) printNl!
+
+Object subclass: #C instanceVariableNames: '' classVariableNames: 'Foo' 
poolDictionaries: 'SystemExceptions' category: 'foo'!
+C instSize = C allInstVarNames size!
+(C classPool keys asArray -> C allInstVarNames -> C sharedPools) printNl!
+
+Association subclass: #C!
+(C classPool keys asArray -> C allInstVarNames -> C sharedPools) printNl!
+
+Object variableSubclass: #C instanceVariableNames: '' classVariableNames: 
'Foo' poolDictionaries: 'SystemExceptions' category: 'foo'!
+C instSize = C allInstVarNames size!
+(C shape -> C classPool keys asArray -> C allInstVarNames -> C sharedPools) 
printNl!
+
+Association subclass: #C!
+(C shape -> C classPool keys asArray -> C allInstVarNames -> C sharedPools) 
printNl!
+
+C class compile: 'foo ^MutationError'!
+^C foo == SystemExceptions.MutationError!