[PATCH] Convert CStructs

In order to convert CStruct, a class needs to tell the exporter what to
write out apart from <comment: ...> and <category: ...>.  This is done
with a #classPragmas method.

Paolo

* looking for [hidden email]--2004b/smalltalk--devo--2.2--patch-507 to compare with
* comparing to [hidden email]--2004b/smalltalk--devo--2.2--patch-507
M  packages/stinst/parser/Exporter.st
M  doc/gst.texi
M  ChangeLog
M  packages/stinst/parser/ChangeLog
M  packages/stinst/parser/RBFormatter.st
M  packages/stinst/parser/STLoader.st
M  packages/stinst/parser/STLoaderObjs.st
M  kernel/Array.st
M  kernel/Boolean.st
M  kernel/ByteArray.st
M  kernel/CObject.st
M  kernel/CStruct.st
M  kernel/Character.st
M  kernel/Class.st
M  kernel/Float.st
M  kernel/Integer.st
M  kernel/Object.st
M  kernel/ScaledDec.st
M  kernel/String.st
M  kernel/Symbol.st
M  kernel/UndefObject.st
M  kernel/VarBinding.st

* modified files

--- orig/ChangeLog
+++ mod/ChangeLog
@@ -1,3 +1,22 @@
+2007-08-12  Paolo Bonzini  <[hidden email]>
+
+ * kernel/Array.st: Add #storeLiteralOn:.
+ * kernel/Boolean.st: Add #storeLiteralOn:.
+ * kernel/ByteArray.st: Add #storeLiteralOn:.
+ * kernel/Character.st: Add #storeLiteralOn:.
+ * kernel/Float.st: Add #storeLiteralOn:.
+ * kernel/Integer.st: Add #storeLiteralOn:.
+ * kernel/Object.st: Add #storeLiteralOn:.
+ * kernel/ScaledDec.st: Add #storeLiteralOn:.
+ * kernel/String.st: Add #storeLiteralOn:.
+ * kernel/Symbol.st: Add #storeLiteralOn:.
+ * kernel/UndefObject.st: Add #storeLiteralOn:.
+ * kernel/VarBinding.st: Add #storeLiteralOn:.
+
+ * kernel/Class.st: Add #classPragmas.
+ * kernel/CObject.st: Set shape on subclasses.
+ * kernel/CStruct.st: Add #classPragmas, #declaration, #declaration:.
+
 2007-08-10  Paolo Bonzini  <[hidden email]>
 
  * kernel/Number.st: Fix #= vs. #~= blunder.


--- orig/doc/gst.texi
+++ mod/doc/gst.texi
@@ -3305,44 +3305,40 @@ struct audio_info @{
 
 And here is a Smalltalk equivalent decision:
 @example
-CStruct subclass: #AudioPrinfo
-        declaration: #( (#sampleRate #uLong)
-                        (#channels #uLong)
-                        (#precision #uLong)
-                        (#encoding #uLong)
-                        (#gain #uLong)
-                        (#port #uLong)
-                        (#xxx (#array #uLong 4))
-                        (#samples #uLong)
-                        (#eof #uLong)
-                        (#pause #uChar)
-                        (#error #uChar)
-                        (#waiting #uChar)
-                        (#ccc (#array #uChar 3))
-                        (#open #uChar)
-                        (#active #uChar))
-        classVariableNames: ''
-        poolDictionaries: ''
-        category: 'C interface-Audio'
-!
-
-CStruct subclass: #AudioInfo
-        declaration: #( (#play #@{AudioPrinfo@} )
-                        (#record #@{AudioPrinfo@} )
-                        (#monitorGain #uLong)
-                        (#yyy (#array #uLong 4)))
-        classVariableNames: ''
-        poolDictionaries: ''
-        category: 'C interface-Audio'
-!
+CStruct subclass: AudioPrinfo [
+    <declaration: #( (#sampleRate #uLong)
+                     (#channels #uLong)
+                     (#precision #uLong)
+                     (#encoding #uLong)
+                     (#gain #uLong)
+                     (#port #uLong)
+                     (#xxx (#array #uLong 4))
+                     (#samples #uLong)
+                     (#eof #uLong)
+                     (#pause #uChar)
+                     (#error #uChar)
+                     (#waiting #uChar)
+                     (#ccc (#array #uChar 3))
+                     (#open #uChar)
+                     (#active #uChar))>
+
+    <category: 'C interface-Audio'>
+]
+
+CStruct subclass: AudioInfo [
+    <declaration: #( (#play #@{AudioPrinfo@} )
+                     (#record #@{AudioPrinfo@} )
+                     (#monitorGain #uLong)
+                     (#yyy (#array #uLong 4)))>
+
+    <category: 'C interface-Audio'>
+]
 @end example
 
 This creates two new subclasses of @code{CStruct} called
 @code{AudioPrinfo} and @code{AudioInfo}, with the given fields.  The
 syntax is the same as for creating standard subclasses, with the
-@code{instanceVariableNames} replaced by @code{declaration}@footnote{The
-old @code{#newStruct:declaration:} method for creating CStructs is
-deprecated because it does not allow one to set the category.}.  You can
+additional metadata @code{declaration:}.  You can
 make C functions return @code{CObject}s that are instances of these
 classes by passing @code{AudioPrinfo type} as the parameter to the
 @code{returning:} keyword.


--- orig/kernel/Array.st
+++ mod/kernel/Array.st
@@ -63,6 +63,33 @@ printOn: aStream
  [ :elt | elt printOn: aStream.
  aStream space ].
     aStream nextPut: $)
+!
+
+isLiteralObject
+    "Answer whether the receiver is expressible as a Smalltalk literal."
+    ^self isReadOnly not
+!
+
+storeLiteralOn: aStream
+    "Store a Smalltalk literal compiling to the receiver on aStream"
+    aStream nextPut: $#.
+    aStream nextPut: $(.
+    self do: [ :elt | elt storeLiteralOn: aStream. aStream space ].
+    aStream nextPut: $).
+!
+
+storeOn: aStream
+    "Store Smalltalk code compiling to the receiver on aStream"
+    aStream nextPut: $#.
+    aStream nextPut: $(.
+    self do: [ :elt |
+ elt isLiteralObject
+    ifTrue: [ elt storeLiteralOn: aStream ]
+    ifFalse: [ aStream nextPutAll: '##('; store: elt; nextPut: $) ].
+ aStream space ].
+
+    aStream nextPut: $).
+    self isReadOnly ifFalse: [ aStream nextPutAll: ' copy' ]
 ! !
 
 


--- orig/kernel/Boolean.st
+++ mod/kernel/Boolean.st
@@ -74,11 +74,19 @@ deepCopy
 
 !Boolean methodsFor: 'storing'!
 
-storeOn: aStream
+isLiteralObject
+    "Answer whether the receiver is expressible as a Smalltalk literal."
+    ^true
+!
+
+storeLiteralOn: aStream
     "Store on aStream some Smalltalk code which compiles to the receiver"
+    self storeOn: aStream
+!
 
+storeOn: aStream
+    "Store on aStream some Smalltalk code which compiles to the receiver"
     self printOn: aStream "representation is the same"
-
 ! !
 
 


--- orig/kernel/ByteArray.st
+++ mod/kernel/ByteArray.st
@@ -65,6 +65,28 @@ asUnicodeString
 
 
 
+!ByteArray methodsFor: 'storing'!
+
+isLiteralObject
+    "Answer whether the receiver is expressible as a Smalltalk literal."
+    ^self isReadOnly not
+!
+
+storeLiteralOn: aStream
+    "Put a Smalltalk literal evaluating to the receiver on aStream."
+    aStream nextPut: $#.
+    aStream nextPut: $[.
+    self do: [ :elt | elt printOn: aStream; space ].
+    
+    aStream nextPut: $]
+!
+
+storeOn: aStream
+    "Put Smalltalk code evaluating to the receiver on aStream."
+    self storeLiteralOn: aStream.
+    self isReadOnly ifFalse: [ aStream nextPutAll: ' copy' ]  
+! !
+
 !ByteArray methodsFor: 'more advanced accessing'!
 
 "Note that the types could be given symbolic names and installed in a


--- orig/kernel/CObject.st
+++ mod/kernel/CObject.st
@@ -172,16 +172,21 @@ to a character.  I provide the protocol
 method returns a Smalltalk String, as you would expect for a scalar datatype.
 '!
 
-CByte comment: 'You''re a marine.
-You adapt -- you improvise -- you overcome
-
-             - Gunnery Sgt. Thomas Highway
-              Heartbreak Ridge'!
+CByte comment: 'You know what a byte is, don''t you?!?'!
 
 CBoolean comment: 'I return true if a byte is not zero, false otherwise.'!
 
 
 
+!CObject class methodsFor: 'subclassing'!
+
+subclass: aSymbol
+    "Create a subclass with the given name."
+    ^(super subclass: aSymbol)
+ shape: #word;
+ yourself
+! !
+
 !CObject class methodsFor: 'instance creation'!
 
 alloc: nBytes


--- orig/kernel/CStruct.st
+++ mod/kernel/CStruct.st
@@ -39,6 +39,8 @@ CObject variableWordSubclass: #CCompound
       category: 'Language-C interface'
 !
 
+CCompound class instanceVariableNames: 'declaration'!
+
 CCompound variableWordSubclass: #CStruct
       instanceVariableNames: ''
       classVariableNames: ''
@@ -112,6 +114,11 @@ alignof
     ^1
 !
 
+classPragmas
+    "Return the pragmas that are written in the file-out of this class."
+    ^super classPragmas copyWith: #declaration
+!
+
 newStruct: structName declaration: array
     "The old way to create a CStruct.  Superseded by #subclass:declaration:..."
     ^self
@@ -137,20 +144,29 @@ subclass: structName declaration: array
        poolDictionaries: pd
        category: category.
 
-    newClass compileDeclaration: array.
+    newClass declaration: array.
     ^newClass
 !
 
-compileDeclaration: array
+declaration
+    "Return the description of the fields in the receiver class."
+    ^declaration
+!
+
+declaration: array
     self subclassResponsibility
 !
 
-compileDeclaration: array inject: startOffset into: aBlock
+declaration: array inject: startOffset into: aBlock
     "Compile methods that implement the declaration in array.  To
      compute the offset after each field, the value of the
      old offset plus the new field's size is passed to aBlock,
      together with the new field's alignment requirements."
     | offset maxAlignment inspStr |
+    (declaration notNil and: [ declaration ~= array ])
+ ifTrue: [ self error: 'cannot redefine CStruct/CUnion' ].
+
+    declaration := array.
     offset := startOffset.
     maxAlignment := self superclass alignof.
     inspStr := WriteStream on: (String new: 8).
@@ -309,20 +325,20 @@ inspect
 
 !CStruct class methodsFor: 'subclass creation'!
 
-compileDeclaration: array
+declaration: array
     "Compile methods that implement the declaration in array."
     self
- compileDeclaration: array
+ declaration: array
  inject: self superclass sizeof
  into: [ :oldOffset :alignment | oldOffset alignTo: alignment ]
 ! !
 
 !CUnion class methodsFor: 'subclass creation'!
 
-compileDeclaration: array
+declaration: array
     "Compile methods that implement the declaration in array."
     self
- compileDeclaration: array
+ declaration: array
  inject: 0
  into: [ :oldOffset :alignment | 0 ]
 ! !


--- orig/kernel/Character.st
+++ mod/kernel/Character.st
@@ -367,6 +367,11 @@ displayOn: aStream
     self printCodePointOn: aStream.
     aStream nextPut: $> ]!
 
+storeLiteralOn: aStream
+    "Store on aStream some Smalltalk code which compiles to the receiver"
+    self storeOn: aStream
+!
+
 printOn: aStream
     "Print a representation of the receiver on aStream"
     self storeOn: aStream! !
@@ -375,6 +380,11 @@ printOn: aStream
 
 !Character methodsFor: 'storing'!
 
+isLiteralObject
+    "Answer whether the receiver is expressible as a Smalltalk literal."
+    ^true
+!
+
 storeOn: aStream
     "Store Smalltalk code compiling to the receiver on aStream"
     aStream nextPut: $$.


--- orig/kernel/Class.st
+++ mod/kernel/Class.st
@@ -182,6 +182,11 @@ sharedPools
     ^s
 !
 
+classPragmas
+    "Return the pragmas that are written in the file-out of this class."
+    ^#(#category #comment)
+!
+
 initializeAsRootClass
     "Perform special initialization reserved to root classes."
     self registerHandler: [ :method :ann |


--- orig/kernel/Float.st
+++ mod/kernel/Float.st
@@ -381,6 +381,16 @@ printOn: aStream
 
 !Float methodsFor: 'storing'!
 
+isLiteralObject
+    "Answer whether the receiver is expressible as a Smalltalk literal."
+    ^true
+!
+
+storeLiteralOn: aStream
+    "Store on aStream some Smalltalk code which compiles to the receiver"
+    self storeOn: aStream
+!
+
 storeOn: aStream
     "Print a representation of the receiver on aStream"
     | printString |


--- orig/kernel/Integer.st
+++ mod/kernel/Integer.st
@@ -451,6 +451,16 @@ asFraction
 
 !Integer methodsFor: 'printing'!
 
+isLiteralObject
+    "Answer whether the receiver is expressible as a Smalltalk literal."
+    ^true
+!
+
+storeLiteralOn: aStream
+    "Store on aStream some Smalltalk code which compiles to the receiver"
+    self storeOn: aStream
+!
+
 printOn: aStream base: b
     "Print on aStream the base b representation of the receiver"
     aStream nextPutAll: (self printString: b)


--- orig/kernel/Object.st
+++ mod/kernel/Object.st
@@ -504,6 +504,13 @@ storeString
     ^stream contents
 !
 
+storeLiteralOn: aStream
+    "Put a Smalltalk literal compiling to the receiver on aStream"
+    aStream nextPutAll: '##('.
+    self storeOn: aStream.
+    aStream nextPut: $).
+!
+
 storeOn: aStream
     "Put Smalltalk code compiling to the receiver on aStream"
     | class hasSemi |


--- orig/kernel/ScaledDec.st
+++ mod/kernel/ScaledDec.st
@@ -263,6 +263,16 @@ printOn: aStream
 
 !ScaledDecimal methodsFor: 'storing'!
 
+isLiteralObject
+    "Answer whether the receiver is expressible as a Smalltalk literal."
+    ^true
+!
+
+storeLiteralOn: aStream
+    "Store on aStream some Smalltalk code which compiles to the receiver"
+    self storeOn: aStream
+!
+
 storeOn: aStream
     "Print Smalltalk code that compiles to the receiver on aStream."
     self printOn: aStream! !


--- orig/kernel/String.st
+++ mod/kernel/String.st
@@ -81,14 +81,6 @@ or assumed to be the system default.'!
 ! !
 
 
-!String methodsFor: 'storing'!
-
-storeOn: aStream
-    "Print Smalltalk code compiling to the receiver on aStream"
-    self printOn: aStream
-! !
-
-
 !String methodsFor: 'converting'!
 
 encoding
@@ -140,13 +132,23 @@ displayOn: aStream
     aStream nextPutAll: self
 !
 
-storeOn: aStream
-    "Store Smalltalk code compiling to the receiver on aStream"
+isLiteralObject
+    "Answer whether the receiver is expressible as a Smalltalk literal."
+    ^self isReadOnly not
+!
+
+storeLiteralOn: aStream
+    "Store a Smalltalk literal compiling to the receiver on aStream"
     aStream nextPut: $'.
     self do:
      [ :char | char == $' ifTrue: [ aStream nextPut: char ].
       aStream nextPut: char ].
     aStream nextPut: $'.
+!
+
+storeOn: aStream
+    "Store Smalltalk code compiling to the receiver on aStream"
+    self storeLiteralOn: aStream.
     self isReadOnly
  ifFalse: [ aStream nextPutAll: ' copy' ]
 !


--- orig/kernel/Symbol.st
+++ mod/kernel/Symbol.st
@@ -267,6 +267,12 @@ displayOn: aStream
     self printOn: aStream
 !
 
+storeLiteralOn: aStream
+    "Print Smalltalk code on aStream that compiles
+     to the same symbol as the receiver."
+    self storeOn: aStream
+!
+
 storeOn: aStream
     "Print Smalltalk code on aStream that compiles
      to the same symbol as the receiver."


--- orig/kernel/UndefObject.st
+++ mod/kernel/UndefObject.st
@@ -126,10 +126,19 @@ printOn: aStream
 
 !UndefinedObject methodsFor: 'storing'!
 
+isLiteralObject
+    "Answer whether the receiver is expressible as a Smalltalk literal."
+    ^true
+!
+
+storeLiteralOn: aStream
+    "Store on aStream some Smalltalk code which compiles to the receiver"
+    self storeOn: aStream
+!
+
 storeOn: aStream
     "Store Smalltalk code compiling to the receiver on aStream."
     self printOn: aStream
-
 ! !
 
 


--- orig/kernel/VarBinding.st
+++ mod/kernel/VarBinding.st
@@ -77,6 +77,16 @@ printOn: aStream
 
 !VariableBinding methodsFor: 'storing'!
 
+isLiteralObject
+    "Answer whether the receiver is expressible as a Smalltalk literal."
+    ^true
+!
+
+storeLiteralOn: aStream
+    "Store on aStream some Smalltalk code which compiles to the receiver"
+    self storeOn: aStream
+!
+
 storeOn: aStream
     "Put on aStream some Smalltalk code compiling to the receiver"
 


--- orig/packages/stinst/parser/ChangeLog
+++ mod/packages/stinst/parser/ChangeLog
@@ -1,3 +1,10 @@
+2007-08-12  Paolo Bonzini  <[hidden email]>
+
+ * Exporter.st: Use #classPragmas to emit class metadata.
+ * RBFormatter.st: Use #storeLiteralOn:.
+ * STLoader.st: Support the CStruct creation method.
+ * STLoaderObjs.st: Likewise, and add #classPragmas.
+
 2007-08-10  Paolo Bonzini  <[hidden email]>
 
  * RBParser.st: Convert to FloatD if there is no exponent.


--- orig/packages/stinst/parser/Exporter.st
+++ mod/packages/stinst/parser/Exporter.st
@@ -201,15 +201,14 @@ Object subclass: FileOutExporter [
             outStream nextPutAll: '>' ].
 
     "category and comment"  
-        outStream nl; space: 4;
-  nextPutAll: '<category: ';
-              print: outClass category;
-  nextPut: $>;
-  nl; space: 4;
-            nextPutAll: '<comment: ';
-  print: outClass comment;
-  nextPut: $>;
-                  nl.
+ outStream nl.
+ outClass classPragmas do: [ :selector |
+            outStream space: 4;
+  nextPut: $<;
+  nextPutAll: selector;
+  nextPutAll: ': '.
+    (outClass perform: selector) storeLiteralOn: outStream.
+    outStream  nextPut: $>; nl ].
     
         "class instance varriables"            
         outClass asMetaclass instVarNames isEmpty


--- orig/packages/stinst/parser/RBFormatter.st
+++ mod/packages/stinst/parser/RBFormatter.st
@@ -171,12 +171,7 @@ formatLiteral: token
     [codeStream nextPut: $$;
  nextPut: aValue.
     ^self].
-    aValue class == String ifTrue:
-    [codeStream nextPut: $';
- nextPutAll: (aValue copyReplaceAll: '''' with: '''''');
- nextPut: $'.
-    ^self].
-    aValue storeOn: codeStream!
+    aValue storeLiteralOn: codeStream!
 
 formatMessage: aMessageNode cascade: cascadeBoolean
     | selectorParts arguments multiLine formattedArgs indentFirst firstArgLength length |


--- orig/packages/stinst/parser/STLoader.st
+++ mod/packages/stinst/parser/STLoader.st
@@ -131,6 +131,9 @@ initialize
  toEvaluate: #variableByteSubclass:instanceVariableNames:classVariableNames:poolDictionaries:category:
  perform: #doSubclass:selector:arguments:;
 
+ toEvaluate: #subclass:declaration:classVariableNames:poolDictionaries:category:
+ perform: #doSubclass:selector:arguments:;
+
  toEvaluate: #methodsFor:
  perform: #doMethodsFor:selector:arguments:;
 


--- orig/packages/stinst/parser/STLoaderObjs.st
+++ mod/packages/stinst/parser/STLoaderObjs.st
@@ -170,7 +170,7 @@ by an STClassLoader.'!
 
 LoadedBehavior subclass: #LoadedClass
         instanceVariableNames: 'name category sharedPools classVars class
- environment shape '
+ environment shape declaration '
         classVariableNames: ''
         poolDictionaries: ''
         category: 'System-Compiler'!
@@ -302,6 +302,16 @@ subclass: s instanceVariableNames: ivn c
  shape: nil
  loader: loader!
 
+subclass: s declaration: cstructDecl classVariableNames: cvn
+ poolDictionaries: pd category: c
+
+    ^(self
+ subclass: s
+ instanceVariableNames: ''
+ classVariableNames: cvn
+ poolDictionaries: pd
+ category: c) declaration: cstructDecl; yourself!
+
 subclass: s
 
     ^LoadedClass
@@ -592,6 +602,10 @@ proxy
    ^proxy
 !
 
+classPragmas
+    ^proxy classPragmas
+!
+
 printOn: aStream
     proxy printOn: aStream
 !
@@ -648,6 +662,10 @@ setProxy: aClass
 
 !ProxyNilClass methodsFor: 'accessing'!
 
+classPragmas
+    ^#(#comment #category)
+!
+
 nameIn: aNamespace
     ^'nil'
 ! !
@@ -895,6 +913,20 @@ category: aString
     category := aString
 !
 
+classPragmas
+    ^superclass classPragmas
+!
+
+declaration
+    "Answer the class declaration for CStruct subclasses"
+    ^declaration
+!
+
+declaration: aString
+    "Set the class declaration (for CStruct subclasses)"
+    declaration := aString
+!
+
 shape
     "Answer the class shape"
     ^shape




_______________________________________________
help-smalltalk mailing list
[hidden email]
http://lists.gnu.org/mailman/listinfo/help-smalltalk