[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Help-smalltalk] [PATCH] Convert CStructs
From: |
Paolo Bonzini |
Subject: |
[Help-smalltalk] [PATCH] Convert CStructs |
Date: |
Mon, 13 Aug 2007 10:47:02 +0200 |
User-agent: |
Thunderbird 2.0.0.6 (Macintosh/20070728) |
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 address@hidden/smalltalk--devo--2.2--patch-507 to compare with
* comparing to address@hidden/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 <address@hidden>
+
+ * 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 <address@hidden>
* 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 address@hidden@} )
- (#record address@hidden@} )
- (#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 address@hidden@} )
+ (#record address@hidden@} )
+ (#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
address@hidden replaced by @address@hidden
-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 <address@hidden>
+
+ * 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 <address@hidden>
* 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
[Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Help-smalltalk] [PATCH] Convert CStructs,
Paolo Bonzini <=