--- a/AssignNd.st Wed Mar 30 12:10:24 1994 +0200
+++ b/AssignNd.st Thu Jun 02 22:26:28 1994 +0200
@@ -18,12 +18,37 @@
!
AssignmentNode comment:'
-
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
+'!
-$Header: /cvs/stx/stx/libcomp/Attic/AssignNd.st,v 1.5 1994-03-30 10:06:50 claus Exp $
-'!
+!AssignmentNode class methodsFor:'documentation'!
+
+copyright
+"
+ COPYRIGHT (c) 1989 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/libcomp/Attic/AssignNd.st,v 1.6 1994-06-02 20:25:45 claus Exp $
+"
+!
+
+documentation
+"
+ node for parse-trees, representing assignments
+"
+! !
!AssignmentNode class methodsFor:'instance creation'!
--- a/AssignmentNode.st Wed Mar 30 12:10:24 1994 +0200
+++ b/AssignmentNode.st Thu Jun 02 22:26:28 1994 +0200
@@ -18,12 +18,37 @@
!
AssignmentNode comment:'
-
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
+'!
-$Header: /cvs/stx/stx/libcomp/AssignmentNode.st,v 1.5 1994-03-30 10:06:50 claus Exp $
-'!
+!AssignmentNode class methodsFor:'documentation'!
+
+copyright
+"
+ COPYRIGHT (c) 1989 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/libcomp/AssignmentNode.st,v 1.6 1994-06-02 20:25:45 claus Exp $
+"
+!
+
+documentation
+"
+ node for parse-trees, representing assignments
+"
+! !
!AssignmentNode class methodsFor:'instance creation'!
--- a/BCompiler.st Wed Mar 30 12:10:24 1994 +0200
+++ b/BCompiler.st Thu Jun 02 22:26:28 1994 +0200
@@ -22,15 +22,32 @@
!
ByteCodeCompiler comment:'
-
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
-
-$Header: /cvs/stx/stx/libcomp/Attic/BCompiler.st,v 1.10 1994-03-30 10:09:41 claus Exp $
'!
!ByteCodeCompiler class methodsFor:'documentation'!
+copyright
+"
+ COPYRIGHT (c) 1989 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/libcomp/Attic/BCompiler.st,v 1.11 1994-06-02 20:25:49 claus Exp $
+"
+!
+
documentation
"
This class performs compilation into ByteCodes.
@@ -73,6 +90,7 @@
notifying:nil
install:true
skipIfSame:false
+ silent:false
!
compile:aString forClass:aClass inCategory:cat
@@ -85,11 +103,12 @@
notifying:nil
install:true
skipIfSame:false
+ silent:false
!
compile:methodText forClass:classToCompileFor notifying:someOne
"compile a source-string for a method in classToCompileFor.
- errors are forwarded to someOne."
+ Errors are forwarded to someOne."
^ self compile:methodText
forClass:classToCompileFor
@@ -97,6 +116,7 @@
notifying:someOne
install:true
skipIfSame:false
+ silent:false
!
compile:aString forClass:aClass inCategory:cat notifying:someOne
@@ -110,31 +130,56 @@
notifying:someOne
install:true
skipIfSame:false
+ silent:false
!
-compile:aString forClass:aClass inCategory:cat notifying:someOne
- install:install
+compile:aString forClass:aClass inCategory:cat notifying:someOne install:install
+ "compile a source-string for a method in classToCompileFor.
+ The install-argument controls if the method is to be installed into the
+ classes method-dictionary, or just to be compiled and a method object to be returned.
+ Errors are forwarded to someOne. The method will get cat as category"
+
^ self compile:aString
forClass:aClass
inCategory:cat
notifying:someOne
install:true
skipIfSame:false
+ silent:false
!
compile:aString forClass:aClass inCategory:cat notifying:someOne
install:install skipIfSame:skipIfSame
+ "compile a source-string for a method in classToCompileFor.
+ The install-argument controls if the method is to be installed into the
+ classes method-dictionary, or just to be compiled and a method object to be returned.
+ Errors are forwarded to someOne. The method will get cat as category.
+ If skipIsSame is true, and the source is the same as an existing
+ methods source, this is a noop (for fast fileIn)."
- "the basic workhorse method for compiling.
+ ^ self compile:aString
+ forClass:aClass
+ inCategory:cat
+ notifying:someOne
+ install:true
+ skipIfSame:skipIfSame
+ silent:false
+!
+
+compile:aString forClass:aClass inCategory:cat notifying:someOne
+ install:install skipIfSame:skipIfSame silent:silent
+
+ "the basic workhorse method for compiling:
compile a source-string for a method in classToCompileFor.
errors are forwarded to someOne (report on Transcript and return
#Error, if someOne is nil).
- The new method will get cat as category. If install is true, the method
- will go into the classes method-table, otherwise the method is simply
- returned (for anonymous methods).
+ The new method will get cat as category.
+ If install is true, the method will go into the classes method-table,
+ otherwise the method is simply returned (for anonymous methods).
If skipIsSame is true, and the source is the same as an existing
- methods source, this is a noop (for fast fileIn)."
+ methods source, this is a noop (for fast fileIn).
+ The argument, silent controls if errors are to be reported."
|compiler newMethod tree lits symbolicCodeArray oldMethod lazy|
@@ -158,7 +203,7 @@
oldMethod := aClass compiledMethodAt:(compiler selector).
oldMethod notNil ifTrue:[
oldMethod source = aString ifTrue:[
- Smalltalk silentLoading == true ifFalse:[
+ (silent or:[Smalltalk silentLoading == true]) ifFalse:[
Transcript showCr:('unchanged: ',aClass name,' ',compiler selector)
].
^ oldMethod
@@ -248,7 +293,7 @@
aClass addSelector:(compiler selector) withMethod:newMethod
].
- Smalltalk silentLoading == true ifFalse:[
+ (silent or:[Smalltalk silentLoading == true]) ifFalse:[
Transcript showCr:('compiled: ',aClass name,' ',compiler selector)
].
@@ -699,7 +744,7 @@
((class == Float) or:[class == Fraction]) ifTrue:[
index := litArray indexOf:anObject.
].
- (index == 0) ifTrue:[
+ ((index == 0) or:[(litArray at:index) class ~~ class]) ifTrue:[
litArray := litArray copyWith:anObject.
^ litArray size
].
--- a/BinaryNd.st Wed Mar 30 12:10:24 1994 +0200
+++ b/BinaryNd.st Thu Jun 02 22:26:28 1994 +0200
@@ -20,9 +20,35 @@
BinaryNode comment:'
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
+'!
-$Header: /cvs/stx/stx/libcomp/Attic/BinaryNd.st,v 1.5 1994-01-16 03:51:32 claus Exp $
-'!
+!BinaryNode class methodsFor:'documentation'!
+
+copyright
+"
+ COPYRIGHT (c) 1989 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/libcomp/Attic/BinaryNd.st,v 1.6 1994-06-02 20:25:52 claus Exp $
+"
+!
+
+documentation
+"
+ node for parse-trees, representing binary message sends
+"
+! !
!BinaryNode methodsFor:'queries'!
--- a/BinaryNode.st Wed Mar 30 12:10:24 1994 +0200
+++ b/BinaryNode.st Thu Jun 02 22:26:28 1994 +0200
@@ -20,9 +20,35 @@
BinaryNode comment:'
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
+'!
-$Header: /cvs/stx/stx/libcomp/BinaryNode.st,v 1.5 1994-01-16 03:51:32 claus Exp $
-'!
+!BinaryNode class methodsFor:'documentation'!
+
+copyright
+"
+ COPYRIGHT (c) 1989 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/libcomp/BinaryNode.st,v 1.6 1994-06-02 20:25:52 claus Exp $
+"
+!
+
+documentation
+"
+ node for parse-trees, representing binary message sends
+"
+! !
!BinaryNode methodsFor:'queries'!
--- a/BlockNode.st Wed Mar 30 12:10:24 1994 +0200
+++ b/BlockNode.st Thu Jun 02 22:26:28 1994 +0200
@@ -20,14 +20,37 @@
!
BlockNode comment:'
+COPYRIGHT (c) 1989 by Claus Gittinger
+ All Rights Reserved
+'!
-COPYRIGHT (c) 1989 by Claus Gittinger
+!BlockNode class methodsFor:'documentation'!
+
+copyright
+"
+ COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
-implement interpreted blocks
+ 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.
+"
+!
-$Header: /cvs/stx/stx/libcomp/BlockNode.st,v 1.6 1994-03-30 10:09:44 claus Exp $
-'!
+version
+"
+$Header: /cvs/stx/stx/libcomp/BlockNode.st,v 1.7 1994-06-02 20:25:53 claus Exp $
+"
+!
+
+documentation
+"
+ node for parse-trees, representing blocks
+"
+! !
!BlockNode class methodsFor:'instance creation'!
--- a/ByteCodeCompiler.st Wed Mar 30 12:10:24 1994 +0200
+++ b/ByteCodeCompiler.st Thu Jun 02 22:26:28 1994 +0200
@@ -22,15 +22,32 @@
!
ByteCodeCompiler comment:'
-
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
-
-$Header: /cvs/stx/stx/libcomp/ByteCodeCompiler.st,v 1.10 1994-03-30 10:09:41 claus Exp $
'!
!ByteCodeCompiler class methodsFor:'documentation'!
+copyright
+"
+ COPYRIGHT (c) 1989 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/libcomp/ByteCodeCompiler.st,v 1.11 1994-06-02 20:25:49 claus Exp $
+"
+!
+
documentation
"
This class performs compilation into ByteCodes.
@@ -73,6 +90,7 @@
notifying:nil
install:true
skipIfSame:false
+ silent:false
!
compile:aString forClass:aClass inCategory:cat
@@ -85,11 +103,12 @@
notifying:nil
install:true
skipIfSame:false
+ silent:false
!
compile:methodText forClass:classToCompileFor notifying:someOne
"compile a source-string for a method in classToCompileFor.
- errors are forwarded to someOne."
+ Errors are forwarded to someOne."
^ self compile:methodText
forClass:classToCompileFor
@@ -97,6 +116,7 @@
notifying:someOne
install:true
skipIfSame:false
+ silent:false
!
compile:aString forClass:aClass inCategory:cat notifying:someOne
@@ -110,31 +130,56 @@
notifying:someOne
install:true
skipIfSame:false
+ silent:false
!
-compile:aString forClass:aClass inCategory:cat notifying:someOne
- install:install
+compile:aString forClass:aClass inCategory:cat notifying:someOne install:install
+ "compile a source-string for a method in classToCompileFor.
+ The install-argument controls if the method is to be installed into the
+ classes method-dictionary, or just to be compiled and a method object to be returned.
+ Errors are forwarded to someOne. The method will get cat as category"
+
^ self compile:aString
forClass:aClass
inCategory:cat
notifying:someOne
install:true
skipIfSame:false
+ silent:false
!
compile:aString forClass:aClass inCategory:cat notifying:someOne
install:install skipIfSame:skipIfSame
+ "compile a source-string for a method in classToCompileFor.
+ The install-argument controls if the method is to be installed into the
+ classes method-dictionary, or just to be compiled and a method object to be returned.
+ Errors are forwarded to someOne. The method will get cat as category.
+ If skipIsSame is true, and the source is the same as an existing
+ methods source, this is a noop (for fast fileIn)."
- "the basic workhorse method for compiling.
+ ^ self compile:aString
+ forClass:aClass
+ inCategory:cat
+ notifying:someOne
+ install:true
+ skipIfSame:skipIfSame
+ silent:false
+!
+
+compile:aString forClass:aClass inCategory:cat notifying:someOne
+ install:install skipIfSame:skipIfSame silent:silent
+
+ "the basic workhorse method for compiling:
compile a source-string for a method in classToCompileFor.
errors are forwarded to someOne (report on Transcript and return
#Error, if someOne is nil).
- The new method will get cat as category. If install is true, the method
- will go into the classes method-table, otherwise the method is simply
- returned (for anonymous methods).
+ The new method will get cat as category.
+ If install is true, the method will go into the classes method-table,
+ otherwise the method is simply returned (for anonymous methods).
If skipIsSame is true, and the source is the same as an existing
- methods source, this is a noop (for fast fileIn)."
+ methods source, this is a noop (for fast fileIn).
+ The argument, silent controls if errors are to be reported."
|compiler newMethod tree lits symbolicCodeArray oldMethod lazy|
@@ -158,7 +203,7 @@
oldMethod := aClass compiledMethodAt:(compiler selector).
oldMethod notNil ifTrue:[
oldMethod source = aString ifTrue:[
- Smalltalk silentLoading == true ifFalse:[
+ (silent or:[Smalltalk silentLoading == true]) ifFalse:[
Transcript showCr:('unchanged: ',aClass name,' ',compiler selector)
].
^ oldMethod
@@ -248,7 +293,7 @@
aClass addSelector:(compiler selector) withMethod:newMethod
].
- Smalltalk silentLoading == true ifFalse:[
+ (silent or:[Smalltalk silentLoading == true]) ifFalse:[
Transcript showCr:('compiled: ',aClass name,' ',compiler selector)
].
@@ -699,7 +744,7 @@
((class == Float) or:[class == Fraction]) ifTrue:[
index := litArray indexOf:anObject.
].
- (index == 0) ifTrue:[
+ ((index == 0) or:[(litArray at:index) class ~~ class]) ifTrue:[
litArray := litArray copyWith:anObject.
^ litArray size
].
--- a/CascadeNd.st Wed Mar 30 12:10:24 1994 +0200
+++ b/CascadeNd.st Thu Jun 02 22:26:28 1994 +0200
@@ -18,12 +18,37 @@
!
CascadeNode comment:'
-
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
+'!
-$Header: /cvs/stx/stx/libcomp/Attic/CascadeNd.st,v 1.5 1994-02-25 12:51:15 claus Exp $
-'!
+!CascadeNode class methodsFor:'documentation'!
+
+copyright
+"
+ COPYRIGHT (c) 1989 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/libcomp/Attic/CascadeNd.st,v 1.6 1994-06-02 20:25:55 claus Exp $
+"
+!
+
+documentation
+"
+ node for parse-trees, representing cascade message sends
+"
+! !
!CascadeNode methodsFor: 'code generation'!
--- a/CascadeNode.st Wed Mar 30 12:10:24 1994 +0200
+++ b/CascadeNode.st Thu Jun 02 22:26:28 1994 +0200
@@ -18,12 +18,37 @@
!
CascadeNode comment:'
-
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
+'!
-$Header: /cvs/stx/stx/libcomp/CascadeNode.st,v 1.5 1994-02-25 12:51:15 claus Exp $
-'!
+!CascadeNode class methodsFor:'documentation'!
+
+copyright
+"
+ COPYRIGHT (c) 1989 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/libcomp/CascadeNode.st,v 1.6 1994-06-02 20:25:55 claus Exp $
+"
+!
+
+documentation
+"
+ node for parse-trees, representing cascade message sends
+"
+! !
!CascadeNode methodsFor: 'code generation'!
--- a/ConstNode.st Wed Mar 30 12:10:24 1994 +0200
+++ b/ConstNode.st Thu Jun 02 22:26:28 1994 +0200
@@ -19,12 +19,37 @@
!
ConstantNode comment:'
-
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
+'!
-$Header: /cvs/stx/stx/libcomp/Attic/ConstNode.st,v 1.6 1994-01-16 03:51:34 claus Exp $
-'!
+!ConstantNode class methodsFor:'documentation'!
+
+copyright
+"
+ COPYRIGHT (c) 1989 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/libcomp/Attic/ConstNode.st,v 1.7 1994-06-02 20:25:56 claus Exp $
+"
+!
+
+documentation
+"
+ node for parse-trees, representing literal constants
+"
+! !
!ConstantNode class methodsFor:'queries'!
--- a/ConstantNode.st Wed Mar 30 12:10:24 1994 +0200
+++ b/ConstantNode.st Thu Jun 02 22:26:28 1994 +0200
@@ -19,12 +19,37 @@
!
ConstantNode comment:'
-
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
+'!
-$Header: /cvs/stx/stx/libcomp/ConstantNode.st,v 1.6 1994-01-16 03:51:34 claus Exp $
-'!
+!ConstantNode class methodsFor:'documentation'!
+
+copyright
+"
+ COPYRIGHT (c) 1989 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/libcomp/ConstantNode.st,v 1.7 1994-06-02 20:25:56 claus Exp $
+"
+!
+
+documentation
+"
+ node for parse-trees, representing literal constants
+"
+! !
!ConstantNode class methodsFor:'queries'!
--- a/Explainer.st Wed Mar 30 12:10:24 1994 +0200
+++ b/Explainer.st Thu Jun 02 22:26:28 1994 +0200
@@ -18,18 +18,37 @@
!
Explainer comment:'
-
COPYRIGHT (c) 1993 by Claus Gittinger
All Rights Reserved
-
-$Header: /cvs/stx/stx/libcomp/Explainer.st,v 1.3 1994-02-25 12:51:26 claus Exp $
'!
!Explainer class methodsFor:'documentation'!
+copyright
+"
+ COPYRIGHT (c) 1993 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/libcomp/Explainer.st,v 1.4 1994-06-02 20:25:58 claus Exp $
+"
+!
+
documentation
"
-a very simple explainer - much more should be added ...
+ a very simple explainer - much more should be added ...
+ This one is involved, when the 'explain' function is used in a
+ codeView.
"
! !
@@ -258,6 +277,17 @@
Beside this, Symbols behave mostly like Strings.'
].
+ "/ is it a symbol without hash-character ?
+ "/
+ string knownAsSymbol ifTrue:[
+ ^ 'is nothing, but #' , string , ' is known as a symbol.
+
+Symbols are unique strings, meaning that there exists
+exactly one instance of a given symbol. Therefore symbols can
+be compared using == (identity compare) instead of = (contents compare).
+Beside this, Symbols behave mostly like Strings.'
+ ].
+
parser isNil ifTrue:[
^ 'parse error -no explanation'
].
--- a/LazyMethod.st Wed Mar 30 12:10:24 1994 +0200
+++ b/LazyMethod.st Thu Jun 02 22:26:28 1994 +0200
@@ -17,6 +17,45 @@
category:'Kernel-Methods'
!
+LazyMethod comment:'
+COPYRIGHT (c) 1994 by Claus Gittinger
+ All Rights Reserved
+'!
+
+!LazyMethod class methodsFor:'documentation'!
+
+copyright
+"
+ COPYRIGHT (c) 1994 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/libcomp/LazyMethod.st,v 1.2 1994-06-02 20:26:00 claus Exp $
+"
+!
+
+documentation
+"
+ Instances of LazyMethod are created when doing a lazy autoload.
+ When executed, these will trigger an error in the VM (noByteCode),
+ which is cought here to create a real method from the receiver.
+ This allows faster loading of code, which will then be compiled
+ when first executed; for classes with a large number of methods, of
+ which only a small subset is actually used, this can also save
+ lots of memory.
+"
+! !
+
!LazyMethod methodsFor:'error handling'!
noByteCode
--- a/MessageNd.st Wed Mar 30 12:10:24 1994 +0200
+++ b/MessageNd.st Thu Jun 02 22:26:28 1994 +0200
@@ -20,9 +20,35 @@
MessageNode comment:'
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
+'!
-$Header: /cvs/stx/stx/libcomp/Attic/MessageNd.st,v 1.8 1994-03-30 10:09:47 claus Exp $
-'!
+!MessageNode class methodsFor:'documentation'!
+
+copyright
+"
+ COPYRIGHT (c) 1989 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/libcomp/Attic/MessageNd.st,v 1.9 1994-06-02 20:26:01 claus Exp $
+"
+!
+
+documentation
+"
+ node for parse-trees, representing message sends
+"
+! !
!MessageNode class methodsFor:'instance creation'!
@@ -37,50 +63,59 @@
receiver:recNode selector:selectorString arg:argNode fold:folding
|result recVal argVal selector|
-"
- The constant folding code can usually not optimize much
- - this may change when some kind of constant declaration is added to smalltalk.
-"
+ "
+ The constant folding code can usually not optimize much
+ - this may change when some kind of constant/macro declaration is added to smalltalk.
+ "
folding ifTrue:[
"do constant folding ..."
(recNode isConstant and:[argNode isConstant]) ifTrue:[
"check if we can do it ..."
selectorString knownAsSymbol ifTrue:[
selector := selectorString asSymbol.
- (recNode respondsTo:selector) ifTrue:[
+ recVal := recNode evaluate.
+ (recVal respondsTo:selector) ifTrue:[
"
we could do much more here - but then, we need a dependency from
the folded selectors method to the method we generate code for ...
limit optimizations to those that will never change
(or - if you change them - you will crash so bad ...)
"
- recVal := recNode evaluate.
argVal := argNode evaluate.
(recVal respondsToArithmetic and:[argVal respondsToArithmetic]) ifTrue:[
(#( @ + - * / // \\ min: max:) includes:selector) ifTrue:[
(#( / // \\ ) includes:selector) ifTrue:[
argVal = 0 ifTrue:[
- ^ 'division by zero'
+ ^ 'division by zero in constant expression'
].
].
- result := recVal perform:selector with:argVal.
- ^ ConstantNode type:(ConstantNode typeOfConstant:result)
- value:result
+ (SignalSet anySignal catch:[
+ result := recVal perform:selector with:argVal.
+ ]) ifTrue:[
+ ^ 'error in constant expression'
+ ].
+ ^ ConstantNode type:(ConstantNode typeOfConstant:result) value:result
]
].
(recVal isMemberOf:String) ifTrue:[
- argVal respondsToArithmetic ifTrue:[
+ argVal isInteger ifTrue:[
(selector == #at:) ifTrue:[
- result := recVal perform:selector with:argVal.
- ^ ConstantNode type:(ConstantNode typeOfConstant:result)
- value:result
+ (SignalSet anySignal catch:[
+ result := recVal perform:selector with:argVal.
+ ]) ifTrue:[
+ ^ 'error in constant expression'
+ ].
+ ^ ConstantNode type:(ConstantNode typeOfConstant:result) value:result
]
].
(argVal isMemberOf:String) ifTrue:[
(selector == #',') ifTrue:[
- result := recVal perform:selector with:argVal.
- ^ ConstantNode type:(ConstantNode typeOfConstant:result)
- value:result
+ (SignalSet anySignal catch:[
+ result := recVal perform:selector with:argVal.
+ ]) ifTrue:[
+ ^ 'error in constant expression'
+ ].
+ ^ ConstantNode type:(ConstantNode typeOfConstant:result) value:result
]
]
]
@@ -91,13 +126,66 @@
^ (self basicNew) receiver:recNode selector:selectorString args:(Array with:argNode) lineno:0
!
+receiver:recNode selector:selectorString arg1:argNode1 arg2:argNode2 fold:folding
+ |result recVal argVal selector|
+
+ "
+ This is just a demonstration - of how complex constants can be folded.
+ This was inspired by some discussion in c.l.s about enhancing the language - I prefer
+ enhancing the compiler ....
+ The following optimization will convert '#(...) with:#(...) collect:[...]' into an array constant,
+ allowing a constant arrays of complex objects.
+
+ Notice: this method is normally disabled - its just a demo after all.
+ "
+ folding ifTrue:[
+ "do constant folding ..."
+ (recNode isConstant and:[argNode1 isConstant]) ifTrue:[
+ "check if we can do it ..."
+ selectorString knownAsSymbol ifTrue:[
+ selector := selectorString asSymbol.
+ recVal := recNode evaluate.
+ (recVal respondsTo:selector) ifTrue:[
+ "
+ we could do much more here - but then, we need a dependency from
+ the folded selectors method to the method we generate code for ...
+ limit optimizations to those that will never change
+ (or - if you change them - you will crash so bad ...)
+ "
+ argVal := argNode1 evaluate.
+ ((recVal isMemberOf:Array) and:[argVal isMemberOf:Array]) ifTrue:[
+ (selector == #with:collect:) ifTrue:[
+ (argNode2 isMemberOf:BlockNode) ifTrue:[
+ (SignalSet anySignal catch:[
+ result := recVal perform:selector with:argVal with:(argNode2 evaluate).
+ ]) ifTrue:[
+ ^ 'error in constant expression'
+ ].
+ ^ ConstantNode type:(ConstantNode typeOfConstant:result) value:result
+ ]
+ ]
+ ]
+ ]
+ ]
+ ]
+ ].
+ ^ (self basicNew) receiver:recNode selector:selectorString args:(Array with:argNode1 with:argNode2) lineno:0
+!
+
receiver:recNode selector:selectorString args:anArray
^ self receiver:recNode selector:selectorString args:anArray fold:true
!
receiver:recNode selector:selectorString args:argArray fold:folding
- (argArray size == 1) ifTrue:[
- ^ self receiver:recNode selector:selectorString arg:(argArray at:1) fold:folding
+ folding ifTrue:[
+ (argArray size == 1) ifTrue:[
+ ^ self receiver:recNode selector:selectorString arg:(argArray at:1) fold:true
+ ].
+
+ "uncomment the follwoing for a nice array initializer optimization ..."
+"/ (argArray size == 2) ifTrue:[
+"/ ^ self receiver:recNode selector:selectorString arg1:(argArray at:1) arg2:(argArray at:2) fold:true
+"/ ].
].
^ (self basicNew) receiver:recNode selector:selectorString args:argArray lineno:0
! !
--- a/MessageNode.st Wed Mar 30 12:10:24 1994 +0200
+++ b/MessageNode.st Thu Jun 02 22:26:28 1994 +0200
@@ -20,9 +20,35 @@
MessageNode comment:'
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
+'!
-$Header: /cvs/stx/stx/libcomp/MessageNode.st,v 1.8 1994-03-30 10:09:47 claus Exp $
-'!
+!MessageNode class methodsFor:'documentation'!
+
+copyright
+"
+ COPYRIGHT (c) 1989 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/libcomp/MessageNode.st,v 1.9 1994-06-02 20:26:01 claus Exp $
+"
+!
+
+documentation
+"
+ node for parse-trees, representing message sends
+"
+! !
!MessageNode class methodsFor:'instance creation'!
@@ -37,50 +63,59 @@
receiver:recNode selector:selectorString arg:argNode fold:folding
|result recVal argVal selector|
-"
- The constant folding code can usually not optimize much
- - this may change when some kind of constant declaration is added to smalltalk.
-"
+ "
+ The constant folding code can usually not optimize much
+ - this may change when some kind of constant/macro declaration is added to smalltalk.
+ "
folding ifTrue:[
"do constant folding ..."
(recNode isConstant and:[argNode isConstant]) ifTrue:[
"check if we can do it ..."
selectorString knownAsSymbol ifTrue:[
selector := selectorString asSymbol.
- (recNode respondsTo:selector) ifTrue:[
+ recVal := recNode evaluate.
+ (recVal respondsTo:selector) ifTrue:[
"
we could do much more here - but then, we need a dependency from
the folded selectors method to the method we generate code for ...
limit optimizations to those that will never change
(or - if you change them - you will crash so bad ...)
"
- recVal := recNode evaluate.
argVal := argNode evaluate.
(recVal respondsToArithmetic and:[argVal respondsToArithmetic]) ifTrue:[
(#( @ + - * / // \\ min: max:) includes:selector) ifTrue:[
(#( / // \\ ) includes:selector) ifTrue:[
argVal = 0 ifTrue:[
- ^ 'division by zero'
+ ^ 'division by zero in constant expression'
].
].
- result := recVal perform:selector with:argVal.
- ^ ConstantNode type:(ConstantNode typeOfConstant:result)
- value:result
+ (SignalSet anySignal catch:[
+ result := recVal perform:selector with:argVal.
+ ]) ifTrue:[
+ ^ 'error in constant expression'
+ ].
+ ^ ConstantNode type:(ConstantNode typeOfConstant:result) value:result
]
].
(recVal isMemberOf:String) ifTrue:[
- argVal respondsToArithmetic ifTrue:[
+ argVal isInteger ifTrue:[
(selector == #at:) ifTrue:[
- result := recVal perform:selector with:argVal.
- ^ ConstantNode type:(ConstantNode typeOfConstant:result)
- value:result
+ (SignalSet anySignal catch:[
+ result := recVal perform:selector with:argVal.
+ ]) ifTrue:[
+ ^ 'error in constant expression'
+ ].
+ ^ ConstantNode type:(ConstantNode typeOfConstant:result) value:result
]
].
(argVal isMemberOf:String) ifTrue:[
(selector == #',') ifTrue:[
- result := recVal perform:selector with:argVal.
- ^ ConstantNode type:(ConstantNode typeOfConstant:result)
- value:result
+ (SignalSet anySignal catch:[
+ result := recVal perform:selector with:argVal.
+ ]) ifTrue:[
+ ^ 'error in constant expression'
+ ].
+ ^ ConstantNode type:(ConstantNode typeOfConstant:result) value:result
]
]
]
@@ -91,13 +126,66 @@
^ (self basicNew) receiver:recNode selector:selectorString args:(Array with:argNode) lineno:0
!
+receiver:recNode selector:selectorString arg1:argNode1 arg2:argNode2 fold:folding
+ |result recVal argVal selector|
+
+ "
+ This is just a demonstration - of how complex constants can be folded.
+ This was inspired by some discussion in c.l.s about enhancing the language - I prefer
+ enhancing the compiler ....
+ The following optimization will convert '#(...) with:#(...) collect:[...]' into an array constant,
+ allowing a constant arrays of complex objects.
+
+ Notice: this method is normally disabled - its just a demo after all.
+ "
+ folding ifTrue:[
+ "do constant folding ..."
+ (recNode isConstant and:[argNode1 isConstant]) ifTrue:[
+ "check if we can do it ..."
+ selectorString knownAsSymbol ifTrue:[
+ selector := selectorString asSymbol.
+ recVal := recNode evaluate.
+ (recVal respondsTo:selector) ifTrue:[
+ "
+ we could do much more here - but then, we need a dependency from
+ the folded selectors method to the method we generate code for ...
+ limit optimizations to those that will never change
+ (or - if you change them - you will crash so bad ...)
+ "
+ argVal := argNode1 evaluate.
+ ((recVal isMemberOf:Array) and:[argVal isMemberOf:Array]) ifTrue:[
+ (selector == #with:collect:) ifTrue:[
+ (argNode2 isMemberOf:BlockNode) ifTrue:[
+ (SignalSet anySignal catch:[
+ result := recVal perform:selector with:argVal with:(argNode2 evaluate).
+ ]) ifTrue:[
+ ^ 'error in constant expression'
+ ].
+ ^ ConstantNode type:(ConstantNode typeOfConstant:result) value:result
+ ]
+ ]
+ ]
+ ]
+ ]
+ ]
+ ].
+ ^ (self basicNew) receiver:recNode selector:selectorString args:(Array with:argNode1 with:argNode2) lineno:0
+!
+
receiver:recNode selector:selectorString args:anArray
^ self receiver:recNode selector:selectorString args:anArray fold:true
!
receiver:recNode selector:selectorString args:argArray fold:folding
- (argArray size == 1) ifTrue:[
- ^ self receiver:recNode selector:selectorString arg:(argArray at:1) fold:folding
+ folding ifTrue:[
+ (argArray size == 1) ifTrue:[
+ ^ self receiver:recNode selector:selectorString arg:(argArray at:1) fold:true
+ ].
+
+ "uncomment the follwoing for a nice array initializer optimization ..."
+"/ (argArray size == 2) ifTrue:[
+"/ ^ self receiver:recNode selector:selectorString arg1:(argArray at:1) arg2:(argArray at:2) fold:true
+"/ ].
].
^ (self basicNew) receiver:recNode selector:selectorString args:argArray lineno:0
! !
--- a/ObjFLoader.st Wed Mar 30 12:10:24 1994 +0200
+++ b/ObjFLoader.st Thu Jun 02 22:26:28 1994 +0200
@@ -12,23 +12,14 @@
Object subclass:#ObjectFileLoader
instanceVariableNames:''
- classVariableNames:'MySymbolTable StubNr Verbose'
+ classVariableNames:'MySymbolTable Verbose'
poolDictionaries:''
category:'System-Compiler'
!
ObjectFileLoader comment:'
-
COPYRIGHT (c) 1993 by Claus Gittinger
All Rights Reserved
-
-this one knowns how to load in external (c)-modules
-(see fileIn/cExample.c) it is all experimental and
-WILL DEFINITELY change soon ...
-
-(goal is to allow loading of binary classes)
-
-$Header: /cvs/stx/stx/libcomp/Attic/ObjFLoader.st,v 1.6 1994-03-30 10:09:51 claus Exp $
'!
%{
@@ -37,20 +28,24 @@
*/
#ifdef sunos
# define SUN_DL
+# define HAS_DL
#endif
#ifdef NeXT
# define NEXT_DL
+# define HAS_DL
#endif
#ifdef SYSV4
# define SYSV4_DL
+# define HAS_DL
#endif
/*
- * but GNU_DL overwrites this
+ * but GNU_DL overwrites this - its better
*/
#ifdef GNU_DL
+# define HAS_DL
# undef SYSV4_DL
# undef NEXT_DL
# undef SUN_DL
@@ -63,16 +58,90 @@
# endif
#endif /* NEXT_DL */
+#include <stdio.h>
+
+/*
+ * if no dynamic link facilities, do it the hard way ...
+ */
+#ifndef HAS_DL
+
+# ifdef A_DOT_OUT
+# include <a.out.h>
+# ifndef N_MAGIC
+# if defined(sinix) && defined(BSD)
+# define N_MAGIC(hdr) (hdr.a_magic & 0xFFFF)
+# else
+# define N_MAGIC(hdr) (hdr.a_magic)
+# endif
+# endif
+# endif /* a.out */
+
+# ifdef COFF
+# ifdef mips
+# include <sys/exec.h>
+# else
+# include <a.out.h>
+# endif
+# endif /* coff */
+
+# ifdef ELF
+# include <elf.h>
+# endif /* elf */
+
+#endif /* not HAS_DL */
+
static OBJ loadAddrLow, loadAddrHi;
%}
+!ObjectFileLoader class methodsFor:'documentation'!
+
+copyright
+"
+ COPYRIGHT (c) 1993 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/libcomp/Attic/ObjFLoader.st,v 1.7 1994-06-02 20:26:03 claus Exp $
+"
+!
+
+documentation
+"
+ This class knowns how to dynamically load in external object-modules.
+ There are basically two totally different mechanisms to do this:
+ a) if there exists some dynamic-link facility such as:
+ GNU-DL, dlopen (sparc, SYS5.4), rld_open (NeXT),
+ this is used
+ b) if no such facility exists, the normal linker is used to
+ link the module to text/data address as previously malloced,
+ and the object file loaded into that space.
+
+ Currently, not all mechanisms work fully satisfying.
+ For example, the sun dl*-functions do an exit on link-errors (which
+ is certainly not what we want here :-(; the NeXT mechanism does not
+ allow for selective unloading (only all or last).
+ The only really useful package is the GNU-dl package, which is only
+ available for a.out file formats. (i.e. only linux people can use
+ it at this time).
+"
+! !
+
!ObjectFileLoader class methodsFor:'initialization'!
initialize
"name of object file, where initial symbol table is found"
MySymbolTable := 'smalltalk'.
- StubNr := 1.
Verbose := false
!
@@ -87,7 +156,8 @@
!ObjectFileLoader class methodsFor:'command defaults'!
needSeparateIDSpaces
- "return true, if we need separate I and D spaces"
+ "return true, if we need separate I and D spaces.
+ This is only needed if no dynamic-link facilitiy exists."
|os cpu|
@@ -99,12 +169,13 @@
].
(os = 'linux') ifTrue:[ ^ false ].
- 'dont know if we need sepId - assume no' printNewline.
+ 'dont know if we need sepId - assume no' errorPrintNL.
^ false
!
absLd:file text:textAddr data:dataAddr
- "this should return a string to link file.o to absolute address"
+ "this should return a string to link file.o to absolute address.
+ This is only needed if no dynamic-link facilitiy exists."
|os cpu|
@@ -141,7 +212,8 @@
!
absLd:file text:textAddr
- "this should return a string to link file.o to absolute address"
+ "this should return a string to link file.o to absolute address.
+ This is only needed if no dynamic-link facilitiy exists."
|os cpu|
@@ -163,477 +235,21 @@
! !
-!ObjectFileLoader class methodsFor:'dynamic loading'!
-
-loadFile:aFileName library:librariesString withBindings:bindings in:aClass
- "first, load the file itself"
-
- (self loadFile:aFileName with:librariesString) ifFalse:[^ false].
-
- "then, create stubs"
- self bindExternalFunctions:bindings in:aClass
-!
-
-loadFile:aFileName withBindings:bindings in:aClass
- "load an object file containing external functions, and bind the functions as described
- in bindings, which is an Array of
- (selector functionName argTypes returnType)
- entries, example:
- #(
- (sel1:and: 'f1' (SmallInteger SmallInteger) nil) -> bind 'aClass sel1:and:' to: 'void f1(int, int)'
- (sel2:and: 'f2' (String SmallInteger) String) -> bind 'aClass sel2:and:' to: 'char *f2(char *, int)'
- )
- "
-
- "first, load the file itself"
-
- (self loadFile:aFileName) ifFalse:[^ false].
-
- "then, create stubs"
- self bindExternalFunctions:bindings in:aClass
-!
-
-bindExternalFunctions:bindings in:aClass
- | selector functionName argTypes returnType allOk |
-
- allOk := true.
- bindings do:[:aBinding |
- selector := aBinding at:1.
- functionName := aBinding at:2.
- argTypes := aBinding at:3.
- returnType := aBinding at:4.
- (self createStubFor:selector calling:functionName args:argTypes returning:returnType in:aClass)
- isNil ifTrue:[
- Transcript showCr:'binding of ' , functionName , ' failed.'.
- allOk := false
- ]
- ].
- ^ allOk
-! !
-
-!ObjectFileLoader class methodsFor:'creating stubs'!
-
-storeGlobalAddressesOn:aStream
-
- Smalltalk allKeysDo:[:key |
- self storeGlobalAddressOf:key on:aStream
- ]
-
- "ObjectFileLoader storeGlobalAddressesOn:Transcript"
- "|f|
- f := FileStream newFileNamed:'syms.c'.
- ObjectFileLoader storeGlobalAddressesOn:f.
- f close"
-!
-
-storeGlobalAddressOf:aSymbol on:aStream
- |globalName|
-
- globalName := aSymbol asString.
- (globalName includes:$:) ifTrue:[
- globalName replaceAll:$: by:$_
- ].
-
- aStream nextPutAll:'#define ',globalName,'_addr '.
- aStream nextPutAll:(Smalltalk cellAt:aSymbol) printString.
- aStream cr.
-
- aStream nextPutAll:'#define ',globalName,' ( *( (OBJ *) ',globalName,'_addr))'.
- aStream cr
-
- "ObjectFileLoader storeGlobalAddressOf:#String on:Transcript"
- "ObjectFileLoader storeGlobalAddressOf:#Symbol on:Transcript"
-!
-
-createStubFor:aSelector calling:functionName args:argTypes returning:returnType in:aClass
- "create a method calling a stub function"
-
- |address newMethod s|
-
- address := self createStubCalling:functionName args:argTypes returning:returnType.
- address isNil ifTrue:[^ nil].
-
- newMethod := Method new.
- newMethod code:address.
- newMethod category:'external functions'.
- s := '"calls external function
-
-' , (self cTypeFor:returnType) , ' ' , functionName , '( '.
- argTypes notNil ifTrue:[
- argTypes do:[:type |
- s := s , (self cTypeFor:type) , ' '
- ]
- ].
- s := s , ')
-"'.
- newMethod source:s.
- newMethod numberOfMethodVars:0.
- newMethod stackSize:0.
-
- aClass class addSelector:aSelector withMethod:newMethod.
-
- SilentLoading ifFalse:[
- Transcript showCr:('created stub: ',aClass class name,' ', aSelector)
- ].
-
- ^ newMethod
-
- "ObjectFileLoader createStubFor:#printf:
- calling:'printf'
- args:#(String)
- returning:nil
- in:TestClass"
- "ObjectFileLoader createStubFor:#printf:with:
- calling:'printf'
- args:#(String SmallInteger)
- returning:nil
- in:TestClass"
-!
-
-createStubCalling:functionName args:argTypes returning:returnType
- "create a stub function for calling functionName - return the address of the
- function in core or nil on error"
-
- |baseName p t l handle address stubName|
-
- stubName := 'stub000' , (StubNr printStringRadix:16).
- stubName := stubName copyFrom:(stubName size - 7).
-
- baseName := self createStubSource:stubName calling:functionName args:argTypes returning:returnType.
- baseName isNil ifTrue:[^ nil].
-
- "compile it ..."
- Verbose ifTrue:[
- Transcript showCr:'compiling stub ...', baseName. Transcript endEntry
- ].
-
- (OperatingSystem executeCommand:('make /tmp/' , baseName , '.o')) ifFalse:[
- Transcript showCr:'compilation error.'.
- ^ nil
- ].
- OperatingSystem executeCommand:('mv ' , baseName , '.o /tmp/' , baseName , '.o').
- Verbose ifFalse:[
- OperatingSystem executeCommand:('rm /tmp/' , baseName , '.c').
- ].
-
- (OperatingSystem getOSType = 'sys5.4') ifTrue:[
- "make it a sharable object"
-
- Verbose ifTrue:[
- Transcript showCr:'makeing shared object stub ...', baseName. Transcript endEntry.
- ].
- OperatingSystem executeCommand:('ld -G -o /tmp/',baseName,'.so /tmp/',baseName,'.o').
-
- "attach to it"
- handle := self openDynamicObject:('/tmp/',baseName,'.so').
- handle isNil ifTrue:[
- Transcript showCr:('dlopen error:', '/tmp/',baseName,'.so').
- ^ nil
- ].
- "find the stubs address"
- address := self getSymbol:stubName from:handle.
- address isNil ifTrue:[
- Transcript showCr:'dlsym failed'.
- ^ nil
- ]
- ].
-
- ((OperatingSystem getOSType = 'sunos')
- or:[OperatingSystem getOSType = 'linux']) ifTrue:[
- "load it"
- (self loadFile:('/tmp/' , baseName , '.o')) ifFalse:[
- Transcript showCr:'load error.'.
- ^ nil
- ].
-
- "find the stubs address (use nm to get the address)"
- t := Text new.
- p := PipeStream readingFrom:('nm SymbolTable|grep ' , stubName , ' |grep T').
- [p atEnd] whileFalse:[
- l := p nextLine.
- l notNil ifTrue:[
- t add:l
- ]
- ].
- p close.
- (t size == 1) ifFalse:[
- Transcript showCr:('oops, ' , stubName , ' not in name-list.').
- ^ nil
- ].
- address := Integer readFrom:(ReadStream on:(t at:1)) radix:16
- ].
-
- address isNil ifTrue:[
- Transcript showCr:'no way to dynamically load objects'.
- ^ nil
- ].
-
- Verbose ifTrue:[
- Transcript show:'stub ' , stubName , ' address:'.
- Transcript showCr:(address printStringRadix:16).
- ].
-
- StubNr := StubNr + 1.
- ^ address
-
- "ObjectFileLoader createStubCalling:'printf' args:#(String) returning:nil"
-!
-
-createStubSource:stubName calling:functionName args:argTypes returning:returnType
- "create a temp file with stub-code - return base-filename or nil"
-
- |pid baseName index aStream argName|
-
- pid := OperatingSystem getProcessId printString.
- baseName := 'stc' , pid.
- aStream := FileStream newFileNamed:('/tmp/' , baseName , '.c').
- aStream nextPutAll:'
-#include <stc.h>
-'.
-
- OperatingSystem getOSType = 'sys5.4' ifTrue:[
- self storeGlobalAddressesOn:aStream.
- ].
-
- aStream nextPutAll:'
-' , stubName , '(self, __sel, SND_COMMA __srch, __pI,
- __a1, __a2, __a3, __a4, __a5, __a6, __a7, __a8)
- OBJ __a1, __a2, __a3, __a4, __a5, __a6, __a7, __a8;
- OBJ __sel, __srch;
- SENDER_DECL
-{
- extern OBJ _ISKINDOF_(), ExternalStream;
-'.
-
- returnType notNil ifTrue:[
- aStream nextPutAll:' '.
- aStream nextPutAll:(self cTypeFor:returnType).
- aStream nextPutAll:' __ret;'.
- aStream cr
- ].
-
- "gen type checking code"
- argTypes notNil ifTrue:[
- index := 0.
- argTypes do:[:argType |
- (index + 1) timesRepeat:[ aStream nextPutAll:' '].
- argName := '__a' , (index + 1) printString.
- aStream nextPutAll:'if ('.
- (self checkType:argType name:argName on:aStream) ifFalse:[^ nil].
- aStream nextPutAll:') {'.
- aStream cr.
- index := index + 1
- ]
- ].
- "call the function"
-
- (index + 1) timesRepeat:[ aStream nextPutAll:' '].
- returnType notNil ifTrue:[
- aStream nextPutAll:'__ret = '
- ].
- aStream nextPutAll:functionName , '('.
- argTypes notNil ifTrue:[
- index := 0.
- argTypes do:[:argType |
- argName := '__a' , (index + 1) printString.
- self convertStToC:argType name:argName on:aStream.
- index := index + 1.
- (index == argTypes size) ifFalse:[
- aStream nextPutAll:','
- ]
- ]
- ].
- aStream nextPutAll:');'. aStream cr.
-
- argTypes notNil ifTrue:[
- argTypes size timesRepeat:[
- index timesRepeat:[ aStream nextPutAll:' '].
- aStream nextPutAll:'}'. aStream cr.
- index := index - 1
- ]
- ].
-
- returnType notNil ifTrue:[
- aStream nextPutAll:' return '.
- self convertCToSt:returnType name:'__ret' on:aStream.
- aStream nextPutAll:';'
- ] ifFalse:[
- aStream nextPutAll:' return self;'
- ].
- aStream cr.
-
- aStream nextPutAll:'}'. aStream cr.
- aStream close.
- ^ baseName
-
- "ObjectFileLoader createStubSource:'stub1' calling:'printMessage' args:#(String) returning:nil"
- "ObjectFileLoader createStubSource:'stub2' calling:'printMessage2' args:#(String SmallInteger) returning:#String"
- "ObjectFileLoader createStubSource:'stub3' calling:'sqrt' args:#(Float) returning:#Float"
- "ObjectFileLoader createStubSource:'stub4' calling:'checking' args:#(SmallInteger SmallInteger) returning:#Boolean"
- "ObjectFileLoader createStubSource:'stub5' calling:'fprintf' args:#(ExternalStream String) returning:#SmallInteger"
-!
-
-checkType:argType name:argName on:aStream
- "generate type checking code"
-
- (argType == #SmallInteger) ifTrue:[
- aStream nextPutAll:'_isSmallInteger(' , argName , ')'.
- ^ true
- ].
- (argType == #Float) ifTrue:[
- aStream nextPutAll:'__isFloat(' , argName , ')'.
- ^ true
- ].
- (argType == #Character) ifTrue:[
- aStream nextPutAll:'__isCharacter(' , argName , ')'.
- ^ true
- ].
- (argType == #String) ifTrue:[
- aStream nextPutAll:'__isString(' , argName , ')'.
- ^ true
- ].
- (argType == #Symbol) ifTrue:[
- aStream nextPutAll:'__isSymbol(' , argName , ')'.
- ^ true
- ].
- (argType == #Boolean) ifTrue:[
- aStream nextPutAll:'((' , argName , '==true)'.
- aStream nextPutAll:'||(' , argName , '==false))'.
- ^ true
- ].
- (argType == #ByteArray) ifTrue:[
- aStream nextPutAll:'__isByteArray(' , argName , ')'.
- ^ true
- ].
- (argType == #ExternalStream) ifTrue:[
- aStream nextPutAll:'(_ISKINDOF_(' , argName , ', SND_COMMA ExternalStream)==true)'.
- ^ true
- ].
- self error:'argType ' , argType, ' not (yet) supported'.
- ^ false
-!
-
-convertStToC:stType name:argName on:aStream
- "generate type conversion code"
-
- |idx|
-
- (stType == #SmallInteger) ifTrue:[
- aStream nextPutAll:'_intVal(' , argName , ')'.
- ^ true
- ].
- (stType == #Float) ifTrue:[
- aStream nextPutAll:'_floatVal(' , argName , ')'.
- ^ true
- ].
- (stType == #Character) ifTrue:[
- aStream nextPutAll:'_characterVal(' , argName , ')'.
- ^ true
- ].
- (stType == #String) ifTrue:[
- aStream nextPutAll:'_stringVal(' , argName , ')'.
- ^ true
- ].
- (stType == #Symbol) ifTrue:[
- aStream nextPutAll:'_stringVal(' , argName , ')'.
- ^ true
- ].
- (stType == #Boolean) ifTrue:[
- aStream nextPutAll:'((' , argName , '==true) ? 1 : 0)'.
- ^ true
- ].
- (stType == #ByteArray) ifTrue:[
- aStream nextPutAll:'(_ByteArrayInstPtr(' , argName , ')->ba_element)'.
- ^ true
- ].
- (stType == #ExternalStream) ifTrue:[
- "find the file-pointer inst-var"
- idx := (ExternalStream allInstVarNames indexOf:'filePointer').
- aStream nextPutAll:'_intVal(_InstPtr(' , argName , ')->i_instvars['.
- aStream nextPutAll:(idx - 1) printString, '])'.
- ^ true
- ].
- ^ false
-!
-
-convertCToSt:stType name:argName on:aStream
- "generate type conversion code"
-
- (stType == #SmallInteger) ifTrue:[
- aStream nextPutAll:'_MKSMALLINT(' , argName , ')'.
- ^ true
- ].
- (stType == #Float) ifTrue:[
- aStream nextPutAll:'_MKFLOAT(' , argName , ' COMMA_SND)'.
- ^ true
- ].
- (stType == #Character) ifTrue:[
- aStream nextPutAll:'_MKCHARACTER(' , argName , ')'.
- ^ true
- ].
- (stType == #String) ifTrue:[
- aStream nextPutAll:'(' , argName , ' ? _MKSTRING(' , argName , ' COMMA_SND) : nil)'.
- ^ true
- ].
- (stType == #Symbol) ifTrue:[
- aStream nextPutAll:'(' , argName , ' ? _MKSYMBOL(' , argName , ' COMMA_SND) : nil)'.
- ^ true
- ].
- (stType == #Boolean) ifTrue:[
- aStream nextPutAll:'(' , argName , ' ? true : false)'.
- ^ true
- ].
- ^ false
-!
-
-cTypeFor:aType
- "return c-type for an ST-type"
-
- (aType == #SmallInteger) ifTrue:[
- ^ 'int'
- ].
- (aType == #Boolean) ifTrue:[
- ^ 'int'
- ].
- (aType == #Float) ifTrue:[
- ^ 'double'
- ].
- (aType == #Character) ifTrue:[
- ^ 'char'
- ].
- (aType == #String) ifTrue:[
- ^ 'char *'
- ].
- (aType == #Symbol) ifTrue:[
- ^ 'char *'
- ].
- (aType == #ByteArray) ifTrue:[
- ^ 'unsigned char *'
- ].
- (aType == nil) ifTrue:[
- ^ 'void'
- ].
- (aType == #ExternalStream) ifTrue:[
- ^ 'void *' "actually its FILE *, but better avoid including stdio.h"
- ].
- self error:'type ' , aType, ' not supported'.
- ^ ''
-! !
-
!ObjectFileLoader class methodsFor:'loading objects'!
loadFile:oFile with:librariesString
- "load in an object files code, linking in libraries"
+ "load in an object files code, linking in libraries.
+ This is only needed if no dynamic link facility exists."
- |tmpOfile errStream errors errText ok pid|
+ |tmpOfile errStream errors errText handle pid cmd|
pid := OperatingSystem getProcessId printString.
tmpOfile := '/tmp/stc_ld' , pid.
+ cmd := 'ld -o ', tmpOfile, ' -r ' , oFile , ' ' , librariesString , '>/tmp/out 2>/tmp/err'.
Verbose ifTrue:[
- Transcript showCr:'executing: ' , ('ld -o ',tmpOfile,' -r ' , oFile , ' ' , librariesString , '>/tmp/out 2>/tmp/err')
+ ('executing: ld -o ', cmd) errorPrintNL
].
- (OperatingSystem executeCommand:'ld -o ',tmpOfile,' -r ' , oFile , ' ' , librariesString , '>/tmp/out 2>/tmp/err')
- ifFalse:[
+ (OperatingSystem executeCommand:cmd) ifFalse:[
errStream := FileStream oldFileNamed:'/tmp/err'.
errStream isNil ifTrue:[
self notify:'errors during link.'
@@ -650,36 +266,37 @@
].
^ false
].
- ok := self loadFile:tmpOfile.
+ handle := self loadFile:tmpOfile.
OperatingSystem executeCommand:('rm ' , tmpOfile).
- ^ ok
+ ^ handle
!
loadFile:oFile
- "load in an object file"
+ "load in an object file - return a handle or nil.
+ This is only needed if no dynamic link facility exists."
- | unixCommand errStream errors errText
- text data textSize dataSize dataAddr textAddr newTextSize newDataSize|
+ |unixCommand errStream errors errText
+ text data textSize dataSize dataAddr textAddr newTextSize newDataSize|
"find out, how much memory we need"
- textSize := ObjectFile textSizeOf:oFile.
+ textSize := self textSizeOf:oFile.
textSize isNil ifTrue:[
- Transcript showCr:'bad text-size in object file'.
- ^ false
+ 'bad text-size in object file' errorPrintNL.
+ ^ nil
].
Verbose ifTrue:[
- Transcript showCr:'text-size: ' , (textSize printStringRadix:16)
+ ('text-size: ' , (textSize printStringRadix:16)) errorPrintNL
].
- dataSize := ObjectFile dataSizeOf:oFile.
+ dataSize := self dataSizeOf:oFile.
dataSize isNil ifTrue:[
- Transcript showCr:'bad data-size in object file'.
- ^ false
+ 'bad data-size in object file' errorPrintNL.
+ ^ nil
].
Verbose ifTrue:[
- Transcript showCr:'data-size: ' , (dataSize printStringRadix:16)
+ ('data-size: ' , (dataSize printStringRadix:16)) errorPrintNL
].
"allocate some memory for text and some for data;
@@ -688,48 +305,45 @@
self needSeparateIDSpaces ifTrue:[
text := ExternalBytes newForText:textSize.
text isNil ifTrue:[
- Transcript showCr:'cannot allocate memory for text'.
- ^ false
+ 'cannot allocate memory for text' errorPrintNL.
+ ^ nil
].
Verbose ifTrue:[
- Transcript showCr:'text: ' , (text address printStringRadix:16)
+ ('text: ' , (text address printStringRadix:16)) errorPrintNL
].
(dataSize ~~ 0) ifTrue:[
data := ExternalBytes newForData:dataSize.
(data isNil) ifTrue:[
- Transcript showCr:'cannot allocate memory for data'.
+ 'cannot allocate memory for data' errorPrintNL.
text notNil ifTrue:[text free].
- ^ false
+ ^ nil
].
Verbose ifTrue:[
- Transcript showCr:'data: ' , (data address printStringRadix:16)
+ ('data: ' , (data address printStringRadix:16)) errorPrintNL
]
].
dataSize == 0 ifTrue:[
- unixCommand := (self absLd:oFile text:text address)
- , ' >/tmp/out 2>/tmp/err'.
+ unixCommand := (self absLd:oFile text:text address) , ' >/tmp/out 2>/tmp/err'.
] ifFalse:[
- unixCommand := (self absLd:oFile text:text address
- data:data address)
+ unixCommand := (self absLd:oFile text:text address data:data address)
, ' >/tmp/out 2>/tmp/err'.
]
] ifFalse:[
text := ExternalBytes newForText:(textSize + dataSize).
text isNil ifTrue:[
- Transcript showCr:'cannot allocate memory for text+data'.
- ^ false
+ 'cannot allocate memory for text+data' errorPrintNL.
+ ^ nil
].
Verbose ifTrue:[
- Transcript showCr:'addr: ' , (text address printStringRadix:16)
+ ('addr: ' , (text address printStringRadix:16)) errorPrintNL
].
- unixCommand := (self absLd:oFile text:text address)
- , ' >/tmp/out 2>/tmp/err'.
+ unixCommand := (self absLd:oFile text:text address) , ' >/tmp/out 2>/tmp/err'.
].
Verbose ifTrue:[
- Transcript showCr:'executing: ' , unixCommand
+ ('executing: ' , unixCommand) errorPrintNL
].
'linking ...' printNewline.
@@ -746,39 +360,39 @@
OperatingSystem executeCommand:'rm /tmp/err /tmp/out'.
self notify:('link errors:\\' , errors asString) withCRs
].
- Transcript showCr:'link unsuccessful.'.
+ 'link unsuccessful.' errorPrintNL.
text notNil ifTrue:[text free].
data notNil ifTrue:[data free].
- ^ false
+ ^ nil
].
- 'link successful' printNewline.
+ 'link successful' errorPrintNL.
OperatingSystem executeCommand:'rm /tmp/err /tmp/out'.
"find out, if space needs have changed after link (they do so on some machines)"
- newTextSize := ObjectFile textSizeOf:'a.out'.
+ newTextSize := self textSizeOf:'a.out'.
newTextSize isNil ifTrue:[
- Transcript showCr:'bad new-text-size in a.out object file'.
+ 'bad new-text-size in a.out object file' errorPrintNL.
text notNil ifTrue:[text free].
data notNil ifTrue:[data free].
- ^ false
+ ^ nil
].
Verbose ifTrue:[
- Transcript showCr:'new-text-size: ' , (newTextSize printStringRadix:16)
+ ('new-text-size: ' , (newTextSize printStringRadix:16)) errorPrintNL
].
- newDataSize := ObjectFile dataSizeOf:'a.out'.
+ newDataSize := self dataSizeOf:'a.out'.
newDataSize isNil ifTrue:[
- Transcript showCr:'bad new-data-size in a.out object file'.
+ 'bad new-data-size in a.out object file' errorPrintNL.
text notNil ifTrue:[text free].
data notNil ifTrue:[data free].
- ^ false
+ ^ nil
].
Verbose ifTrue:[
- Transcript showCr:'new-data-size: ' , (newDataSize printStringRadix:16)
+ ('new-data-size: ' , (newDataSize printStringRadix:16)) errorPrintNL
].
"if size has changed, do it again"
@@ -795,52 +409,49 @@
self needSeparateIDSpaces ifTrue:[
text := ExternalBytes newForText:textSize.
text isNil ifTrue:[
- Transcript showCr:'cannot allocate memory for text'.
- ^ false
+ 'cannot allocate memory for new text' errorPrintNL.
+ ^ nil
].
Verbose ifTrue:[
- Transcript showCr:'text: ' , (text address printStringRadix:16)
+ ('new text: ' , (text address printStringRadix:16)) errorPrintNL
].
(dataSize ~~ 0) ifTrue:[
data := ExternalBytes newForData:dataSize.
(data isNil) ifTrue:[
- Transcript showCr:'cannot allocate memory for data'.
+ 'cannot allocate memory for new data' errorPrintNL.
text notNil ifTrue:[text free].
- ^ false
+ ^ nil
].
Verbose ifTrue:[
- Transcript showCr:'data: ' , (data address printStringRadix:16)
+ ('new data: ' , (data address printStringRadix:16)) errorPrintNL
]
].
dataSize == 0 ifTrue:[
- unixCommand := (self absLd:oFile text:text address)
- , ' >/tmp/out 2>/tmp/err'.
+ unixCommand := (self absLd:oFile text:text address) , ' >/tmp/out 2>/tmp/err'.
] ifFalse:[
- unixCommand := (self absLd:oFile text:text address
- data:data address)
+ unixCommand := (self absLd:oFile text:text address data:data address)
, ' >/tmp/out 2>/tmp/err'.
]
] ifFalse:[
text := ExternalBytes newForText:(textSize + dataSize).
text isNil ifTrue:[
- Transcript showCr:'cannot allocate memory for text'.
- ^ false
+ 'cannot allocate memory for new text' errorPrintNL.
+ ^ nil
].
Verbose ifTrue:[
- Transcript showCr:'addr: ' , (text address printStringRadix:16)
+ ('new text+data: ' , (text address printStringRadix:16)) errorPrintNL
].
- unixCommand := (self absLd:oFile text:text address)
- , ' >/tmp/out 2>/tmp/err'.
+ unixCommand := (self absLd:oFile text:text address) , ' >/tmp/out 2>/tmp/err'.
].
Verbose ifTrue:[
- Transcript showCr:'executing: ' , unixCommand
+ ('executing: ' , unixCommand) errorPrintNL
].
- 'linking ...' printNewline.
+ 'linking ...' errorPrintNL.
(OperatingSystem executeCommand:unixCommand) ifFalse: [
errStream := FileStream oldFileNamed:'/tmp/err'.
errStream notNil ifTrue:[
@@ -854,46 +465,46 @@
OperatingSystem executeCommand:'rm /tmp/err /tmp/out'.
self notify:('link errors:\\' , errors asString) withCRs
].
- Transcript showCr:'link unsuccessful.'.
+ 'link unsuccessful.' errorPrintNL.
text notNil ifTrue:[text free].
data notNil ifTrue:[data free].
- ^ false
+ ^ nil
].
- 'link successful' printNewline.
+ 'link successful' errorPrintNL.
OperatingSystem executeCommand:'rm /tmp/err /tmp/out'.
"check again for size change - should not happen"
- newTextSize := ObjectFile textSizeOf:'a.out'.
+ newTextSize := self textSizeOf:'a.out'.
newTextSize isNil ifTrue:[
- Transcript showCr:'bad text-size in a.out object file'.
+ 'bad text-size in a.out object file' errorPrintNL.
text notNil ifTrue:[text free].
data notNil ifTrue:[data free].
- ^ false
+ ^ nil
].
Verbose ifTrue:[
- Transcript showCr:'new-text-size: ' , (newTextSize printStringRadix:16)
+ ('new-text-size: ' , (newTextSize printStringRadix:16)) errorPrintNL
].
- newDataSize := ObjectFile dataSizeOf:'a.out'.
+ newDataSize := self dataSizeOf:'a.out'.
newDataSize isNil ifTrue:[
- Transcript showCr:'bad data-size in object file'.
+ 'bad data-size in object file' errorPrintNL.
text notNil ifTrue:[text free].
data notNil ifTrue:[data free].
- ^ false
+ ^ nil
].
Verbose ifTrue:[
- Transcript showCr:'new-data-size: ' , (newDataSize printStringRadix:16)
+ ('new-data-size: ' , (newDataSize printStringRadix:16)) errorPrintNL
].
((newTextSize ~~ textSize) or:[newDataSize ~~ dataSize]) ifTrue:[
- Transcript showCr:'size changed again - I give up'.
+ 'size changed again - I give up' errorPrintNL.
text notNil ifTrue:[text free].
data notNil ifTrue:[data free].
- ^ false
+ ^ nil
].
].
@@ -913,27 +524,27 @@
Verbose ifTrue:[
textAddr notNil ifTrue:[
- Transcript showCr:'loading ' , textSize printString , ' bytes at ' , (textAddr printStringRadix:16).
+ ('loading ' , textSize printString , ' bytes at ' , (textAddr printStringRadix:16)) errorPrintNL.
].
dataAddr notNil ifTrue:[
- Transcript showCr:'loading ' , dataSize printString , ' bytes at ' , (dataAddr printStringRadix:16).
+ ('loading ' , dataSize printString , ' bytes at ' , (dataAddr printStringRadix:16)) errorPrintNL.
].
].
- (ObjectFile loadObjectFile:'a.out'
+ (self loadObjectFile:'a.out'
textAddr:textAddr textSize:textSize
dataAddr:dataAddr dataSize:dataSize) isNil ifTrue: [
- Transcript showCr:'load in error'.
+ 'load error' errorPrintNL.
text notNil ifTrue:[text free].
data notNil ifTrue:[data free].
- ^ false
+ ^ nil
].
- 'dynamic load successful' printNewline.
+ 'dynamic load successful' errorPrintNL.
OperatingSystem executeCommand:'mv a.out SymbolTable'.
MySymbolTable := 'SymbolTable'.
- ^ true
+ ^ (Array with:textAddr with:dataAddr)
! !
!ObjectFileLoader class methodsFor:'dynamic class loading'!
@@ -941,36 +552,90 @@
loadClass:aClassName fromObjectFile:aFileName
"load a compiled class (.o-file) into the image"
- |handle initAddr symName|
+ |handle initAddr symName newClass list moreHandles|
handle := self openDynamicObject:aFileName.
handle isNil ifTrue:[
Transcript showCr:('openDynamic: ',aFileName,' failed.').
^ nil
].
+
+ "
+ get the Init-function; let the class install itself
+ "
symName := '_' , aClassName , '_Init'.
- initAddr := self getSymbol:symName from:handle.
+ initAddr := self getFunction:symName from:handle.
initAddr isNil ifTrue:[
"try with added underscore"
symName := '__' , aClassName , '_Init'.
- initAddr := self getSymbol:symName from:handle.
+ initAddr := self getFunction:symName from:handle.
+ ].
+
+ "
+ if there are any undefined symbols, we may have to load more
+ "
+ list := self getListOfUndefinedSymbolsFrom:handle.
+ list notNil ifTrue:[
+ moreHandles := self loadModulesFromListOfUndefined:list.
+
+ "
+ now, try again
+ "
+ symName := '_' , aClassName , '_Init'.
+ initAddr := self getFunction:symName from:handle.
initAddr isNil ifTrue:[
- Transcript showCr:('no symbol: ',symName,' in ',aFileName).
- ^ nil
+ "try with added underscore"
+ symName := '__' , aClassName , '_Init'.
+ initAddr := self getFunction:symName from:handle.
].
].
- self callFunctionAt:initAddr.
- ^ Smalltalk at:aClassName asSymbol
+
+ initAddr notNil ifTrue:[
+ Verbose ifTrue:[
+ Transcript showCr:'calling init at: ' , (initAddr printStringRadix:16)
+ ].
+ self callInitFunctionAt:initAddr.
+ (Symbol hasInterned:aClassName) ifTrue:[
+ newClass := Smalltalk at:aClassName asSymbol ifAbsent:[nil].
+ newClass notNil ifTrue:[
+ newClass initialize.
+ "force cache flush"
+ Smalltalk at:aClassName asSymbol put:newClass.
+ Smalltalk changed.
+ ].
+ ] ifFalse:[
+ 'LOADER: class ' errorPrintNL. aClassName errorPrintNL.
+ ' did not define itself' errorPrintNL
+ "
+ do not unload - could have installed its methods ...
+ "
+ ].
+ ^ newClass
+ ].
+
+ Verbose ifTrue:[
+ Transcript showCr:('no symbol: ', symName,' in ',aFileName).
+ ].
+
+ "
+ unload
+ "
+ moreHandles notNil ifTrue:[
+ self closeAllDynamicObjects:moreHandles.
+ ].
+ self closeDynamicObject:handle.
+ ^ nil
"ObjectFileLoader loadClass:'Tetris' fromObjectFile:'../clients/Tetris/Tetris.o'"
"ObjectFileLoader loadClass:'TetrisBlock' fromObjectFile:'../clients/Tetris/TBlock.o'"
+ "ObjectFileLoader loadClass:'Foo' fromObjectFile:'classList.o'"
!
loadObjectFile:aFileName
- "load a compiled class (.o-file) into the image; the class name
- is not needed (multiple definitions may be in the file)"
+ "load an object file (.o-file) into the image;
+ the class name is not needed (multiple definitions may be in the file)."
- |handle initAddr symName className|
+ |handle initAddr symName className newClass list|
handle := self openDynamicObject:aFileName.
handle isNil ifTrue:[
@@ -978,77 +643,229 @@
^ nil
].
- "load worked - now get init functions address"
-
+ "
+ look for init-function
+ "
className := OperatingSystem baseNameOf:aFileName.
(className endsWith:'.o') ifTrue:[
className := className copyTo:(className size - 2)
].
symName := '_' , className , '_Init'.
- initAddr := self getSymbol:symName from:handle.
+ initAddr := self getFunction:symName from:handle.
initAddr isNil ifTrue:[
"try with added underscore"
symName := '__' , className , '_Init'.
- initAddr := self getSymbol:symName from:handle.
+ initAddr := self getFunction:symName from:handle.
initAddr isNil ifTrue:[
"try className from fileName"
className := Smalltalk classNameForFile:className.
symName := '_' , className , '_Init'.
- initAddr := self getSymbol:symName from:handle.
+ initAddr := self getFunction:symName from:handle.
initAddr isNil ifTrue:[
"and with added underscore"
symName := '__' , className , '_Init'.
- initAddr := self getSymbol:symName from:handle.
+ initAddr := self getFunction:symName from:handle.
initAddr isNil ifTrue:[
Transcript showCr:('no symbol: ',symName,' in ',aFileName).
+ "
+ unload
+ "
+ self closeDynamicObject:handle.
^ nil
].
].
].
].
- self callFunctionAt:initAddr.
+ Verbose ifTrue:[
+ Transcript showCr:'calling init at:' , (initAddr printStringRadix:16)
+ ].
+ self callInitFunctionAt:initAddr.
+
+ (Symbol hasInterned:className) ifTrue:[
+ newClass := Smalltalk at:className asSymbol ifAbsent:[nil].
+ newClass notNil ifTrue:[
+ newClass initialize.
+ "force cache flush"
+ Smalltalk at:className asSymbol put:newClass.
+ Smalltalk changed.
+ ].
+ ].
+ ^ newClass
+!
+
+loadCPlusPlusObjectFile:aFileName
+ "load a c++ object file (.o-file) into the image"
+
+ |handle initAddr symName className newClass list|
+
+ handle := self openDynamicObject:aFileName.
+ handle isNil ifTrue:[
+ Transcript showCr:('openDynamic: ',aFileName,' failed.').
+ ^ nil
+ ].
+
+ list := self namesMatching:'__GLOBAL_$I*' in:aFileName.
+list size == 1 ifTrue:[
+"/ (self isCPlusPlusObject:handle) ifTrue:[
+ Verbose ifTrue:[
+ Transcript showCr:'a c++ object file'
+ ].
+ "
+ what I would like to get is the CTOR_LIST,
+ and call each function.
+ But dld cannot (currently) handle SET-type symbols, therefore
+ we search (using nm) for all __GLOBAL_$I* syms, get their values
+ and call them each
+ "
+"/ list := self namesMatching:'__GLOBAL_$I*' in:aFileName.
+
+"/ initAddr := self getFunction:'__CTOR_LIST__' from:handle.
+"/ Verbose ifTrue:[
+"/ Transcript showCr:'calling CTORs at:' , (initAddr printStringRadix:16)
+"/ ].
+
+ initAddr := self getFunction:list first from:handle.
+ initAddr isNil ifTrue:[
+ "
+ try with added underscore
+ "
+ initAddr := self getFunction:('_' , list first) from:handle.
+ ].
+ (initAddr isNil and:[list first startsWith:'_']) ifTrue:[
+ "
+ try with removed underscore
+ "
+ initAddr := self getFunction:(list first copyFrom:2) from:handle.
+ ].
+ initAddr isNil ifTrue:[
+ Verbose ifTrue:[
+ Transcript showCr:'no CTOR-func found (' , list first , ')'
+ ].
+ self closeDynamicObject:aFileName.
+ ^ nil
+ ].
+ Verbose ifTrue:[
+ Transcript showCr:'calling CTORs at:' , (initAddr printStringRadix:16)
+ ].
+ self callFunctionAt:initAddr forceOld:false arg:0.
+ Verbose ifTrue:[
+ Transcript showCr:'done with CTORs.'
+ ].
+
+ "
+ cannot create a CPlusPlus class automatically (there could be more than
+ one classes in it too ...)
+ "
+ ^ handle
+ ].
+
+
+ Verbose ifTrue:[
+ Transcript showCr:'unknown object file'
+ ].
+ self closeDynamicObject:aFileName.
+ ^ nil
+!
+
+loadModulesFromListOfUndefined:list
+ "try to figure out what has to be loaded to resolve symbols from list.
+ return a list of handles of loaded objects
+ "
+ |inits classNames moreHandles|
+
+ inits := list select:[:symbol | symbol notNil and:[symbol endsWith:'_Init']].
+ inits notNil ifTrue:[
+ classNames := inits collect:[:symbol |
+ (symbol startsWith:'___') ifTrue:[
+ symbol copyFrom:4 to:(symbol size - 5)
+ ] ifFalse:[
+ (symbol startsWith:'__') ifTrue:[
+ symbol copyFrom:3 to:(symbol size - 5)
+ ] ifFalse:[
+ (symbol startsWith:'_') ifTrue:[
+ symbol copyFrom:2 to:(symbol size - 5)
+ ] ifFalse:[
+ symbol
+ ]
+ ]
+ ]
+ ].
+ "
+ autoload those classes
+ "
+ classNames do:[:aClassName |
+ aClassName knownAsSymbol ifTrue:[
+ (Smalltalk includesKey:aClassName asSymbol) ifTrue:[
+'autoloading ' print. aClassName printNL.
+ (Smalltalk at:aClassName asSymbol) autoload
+ ]
+ ]
+ ]
+ ].
+ ^ nil
! !
!ObjectFileLoader class methodsFor:'dynamic object access'!
openDynamicObject:pathName
- "open an object-file (map into my address space).
+ "open an object-file (load/map into my address space).
Return a non-nil handle if ok, nil otherwise.
- This function is not supported on all architectures."
+ No bindings are done - only a pure load is performed.
+ This function is not supported on all architectures.
+ "
|handle|
+ Verbose ifTrue:[
+ Transcript showCr:'openDynamic: ' , pathName
+ ].
+
handle := self primOpenDynamicObject:pathName into:(Array new:2).
+ handle isNil ifTrue:[
+ Verbose ifTrue:[
+ Transcript showCr:'no dynamic load facility or load failed.'.
+ ].
+ "try it the hard way"
+ handle := self loadFile:pathName.
+ ].
^ handle
"sys5.4:
|handle|
handle := ObjectFileLoader openDynamicObject:'../stc/mod1.so'.
- ObjectFileLoader getSymbol:'module1' from:handle
+ ObjectFileLoader getFunction:'module1' from:handle
"
"next:
|handle|
handle := ObjectFileLoader openDynamicObject:'../goodies/Path/AbstrPath.o'.
- ObjectFileLoader getSymbol:'__AbstractPath_Init' from:handle
+ ObjectFileLoader getFunction:'__AbstractPath_Init' from:handle
"
"GLD:
|handle|
handle := ObjectFileLoader openDynamicObject:'../clients/Tetris/Tetris.o'.
- ObjectFileLoader getSymbol:'__TetrisBlock_Init' from:handle
+ ObjectFileLoader getFunction:'__TetrisBlock_Init' from:handle
"
!
primOpenDynamicObject:pathName into:aBuffer
"open an object-file (map into my address space).
This function is not supported on all architectures.
- Dont depend on the returned value or class of it, it depends
- on the underlying dynamic load package."
+ Dont depend on the values or types returned in aBuffer,
+ it depends on the underlying dynamic load package."
%{ /* UNLIMITEDSTACK */
#ifdef GNU_DL
# include "dld.h"
+ static firstCall = 1;
+ extern char *__myName__;
+
+ if (firstCall) {
+ firstCall = 0;
+ (void) dld_init (__myName__);
+ }
+
if (__isString(pathName)) {
if (dld_link(_stringVal(pathName))) {
dld_perror("cant link");
@@ -1070,11 +887,12 @@
handle = dlopen(_stringVal(pathName), RTLD_NOW);
if (! handle) {
- printf("dlopen %s error: <%s>\n", _stringVal(pathName), dlerror());
+ fprintf(stderr, "dlopen %s error: <%s>\n", _stringVal(pathName), dlerror());
RETURN (nil);
}
- printf("open %s handle = %x\n", _stringVal(pathName), handle);
+ if (ObjectFileLoader_Verbose == true)
+ printf("open %s handle = %x\n", _stringVal(pathName), handle);
_AT_PUT_(aBuffer COMMA_SND, _MKSMALLINT(1),
_MKSMALLINT( (int)handle & 0xFFFF ));
_AT_PUT_(aBuffer COMMA_SND, _MKSMALLINT(2),
@@ -1086,8 +904,6 @@
# include <dlfcn.h>
void *handle;
- loadAddrLow = nil;
- loadAddrHi = nil;
if ((pathName == nil) || __isString(pathName)) {
if (pathName == nil)
handle = dlopen((char *)0, 1);
@@ -1095,11 +911,12 @@
handle = dlopen(_stringVal(pathName), 1);
if (! handle) {
- printf("dlopen %s error: <%s>\n", _stringVal(pathName), dlerror());
+ fprintf(stderr, "dlopen %s error: <%s>\n", _stringVal(pathName), dlerror());
RETURN (nil);
}
- printf("open %s handle = %x\n", _stringVal(pathName), handle);
+ if (ObjectFileLoader_Verbose == true)
+ printf("open %s handle = %x\n", _stringVal(pathName), handle);
_AT_PUT_(aBuffer COMMA_SND, _MKSMALLINT(1),
_MKSMALLINT( (int)handle & 0xFFFF ));
_AT_PUT_(aBuffer COMMA_SND, _MKSMALLINT(2),
@@ -1112,8 +929,6 @@
char *files[2];
NXStream *errOut;
- loadAddrLow = nil;
- loadAddrHi = nil;
if (__isString(pathName)) {
files[0] = (char *) _stringVal(pathName);
files[1] = (char *) 0;
@@ -1124,11 +939,12 @@
(char *)0);
NXClose(errOut);
if (! result) {
- printf("rld_load %s failed\n", _stringVal(pathName));
+ fprintf(stderr, "rld_load %s failed\n", _stringVal(pathName));
RETURN (nil);
}
- printf("rld_load %s ok\n", _stringVal(pathName));
+ if (ObjectFileLoader_Verbose == true)
+ printf("rld_load %s ok\n", _stringVal(pathName));
_AT_PUT_(aBuffer COMMA_SND, _MKSMALLINT(1), _MKSMALLINT(1));
_AT_PUT_(aBuffer COMMA_SND, _MKSMALLINT(2), _MKSMALLINT(0));
}
@@ -1150,6 +966,7 @@
}
RETURN ( self );
}
+ RETURN (self);
#endif
%}.
@@ -1164,7 +981,8 @@
if (_isSmallInteger(low) && _isSmallInteger(hi)) {
val = (_intVal(hi) << 16) + _intVal(low);
h = (void *)(val);
- printf("close handle = %x\n", h);
+ if (ObjectFileLoader_Verbose == true)
+ printf("close handle = %x\n", h);
dlclose(h);
}
#endif
@@ -1177,33 +995,123 @@
if (_isSmallInteger(low) && _isSmallInteger(hi)) {
val = (_intVal(hi) << 16) + _intVal(low);
h = (void *)(val);
- printf("close handle = %x\n", h);
+ if (ObjectFileLoader_Verbose == true)
+ printf("close handle = %x\n", h);
dlclose(h);
}
#endif
%}
!
-getSymbol:aString from:handle
- "return the address of a symbol from a dynamically loaded object file.
+isSmalltalkObject:handle
+ "return true, if the loaded object is a smalltalk object module"
+
+ "not yet implemented - stc_compiled_smalltalk is a static symbol,
+ not found in list - need nm-interface, or nlist-walker
+ "
+ ^ true.
+
+ (self getSymbol:'__stc_compiled_smalltalk' function:true from:handle) notNil ifTrue:[^ true].
+ (self getSymbol:'__stc_compiled_smalltalk' function:false from:handle) notNil ifTrue:[^ true].
+ ^ false
+!
+
+isCPlusPlusObject:handle
+ "return true, if the loaded object is a c++ object module"
+
+ (self getSymbol:'__gnu_compiled_cplusplus' function:true from:handle) notNil ifTrue:[^ true].
+ (self getSymbol:'__CTOR_LIST__' function:true from:handle) notNil ifTrue:[^ true].
+ (self getSymbol:'__CTOR_LIST__' function:false from:handle) notNil ifTrue:[^ true].
+ (self getSymbol:'__gnu_compiled_cplusplus' function:false from:handle) notNil ifTrue:[^ true].
+ ^ false
+!
+
+namesMatching:aPattern in:aFileName
+ |p l s addr segment name entry|
+
+ l := OrderedCollection new.
+ p := PipeStream readingFrom:('nm ' , aFileName).
+ p isNil ifTrue:[
+ ('cannot read names from ' , aFileName) errorPrintNL.
+ ^ nil
+ ].
+ [p atEnd] whileFalse:[
+ entry := p nextLine.
+ s := ReadStream on:entry.
+ addr := s nextWord.
+ segment := s nextWord.
+ name := s upToEnd withoutSeparators.
+ (addr notNil and:[segment notNil and:[name notNil]]) ifTrue:[
+ (aPattern match:name) ifTrue:[
+ l add:name
+ ]
+ ]
+ ].
+ p close.
+ ^ l
+!
+
+isObjectiveCObject:handle
+ "not yet implemented"
+
+ ^ false
+!
+
+getFunction:aString from:handle
+ "return the address of a function from a dynamically loaded object file.
+ Handle must be the one returned previously from openDynamicObject.
+ Return the address of the function, or nil on any error."
+
+ ^ self getSymbol:aString function:true from:handle
+!
+
+getSymbol:aString function:isFunction from:handle
+ "return the address of a symbol/function from a dynamically loaded object file.
Handle must be the one returned previously from openDynamicObject.
Return the address of the symbol, or nil on any error."
|low hi lowAddr hiAddr|
-%{
+%{ /* STACK: 20000 */
+
#ifdef GNU_DL
# include "dld.h"
void (*func)();
+ unsigned long addr;
+ char *name;
if (__isString(aString)) {
- func = (void (*) ()) dld_get_func(_stringVal(aString));
- if (func) {
- printf("addr = %x\n", (INT)func);
- lowAddr = _MKSMALLINT( (INT)func & 0xFFFF );
- hiAddr = _MKSMALLINT( ((INT)func >> 16) & 0xFFFF );
+ name = (char *) _stringVal(aString);
+ if (isFunction == false) {
+ addr = dld_get_symbol(name);
} else {
- dld_perror("get_func");
+ func = (void (*) ()) dld_get_func(name);
+ if (func) {
+ if (ObjectFileLoader_Verbose == true)
+ printf("addr of %s = %x\n", name, (INT)func);
+ if (dld_function_executable_p(name)) {
+ lowAddr = _MKSMALLINT( (INT)func & 0xFFFF );
+ hiAddr = _MKSMALLINT( ((INT)func >> 16) & 0xFFFF );
+ } else {
+ char **undefNames;
+ char **nm;
+ int i;
+
+ if (ObjectFileLoader_Verbose == true) {
+ printf ("function %s not executable\n", name);
+ dld_perror("not executable");
+
+ printf("undefined:\n");
+ nm = undefNames = dld_list_undefined_sym();
+ for (i=dld_undefined_sym_count; i; i--) {
+ printf(" %s\n", *nm++);
+ }
+ }
+ free(undefNames);
+ }
+ } else {
+ dld_perror("get_func");
+ }
}
}
#endif
@@ -1222,14 +1130,17 @@
val = (_intVal(hi) << 16) + _intVal(low);
h = (void *)(val);
if (__isString(aString)) {
- printf("get sym <%s> handle = %x\n", _stringVal(aString), h);
+ if (ObjectFileLoader_Verbose == true)
+ printf("get sym <%s> handle = %x\n", _stringVal(aString), h);
addr = dlsym(h, _stringVal(aString));
if (addr) {
- printf("addr = %x\n", addr);
+ if (ObjectFileLoader_Verbose == true)
+ printf("addr = %x\n", addr);
lowAddr = _MKSMALLINT( (int)addr & 0xFFFF );
hiAddr = _MKSMALLINT( ((int)addr >> 16) & 0xFFFF );
} else {
- printf("dlsym %s error: <%s>\n", _stringVal(aString), dlerror());
+ if (ObjectFileLoader_Verbose == true)
+ printf("dlsym %s error: <%s>\n", _stringVal(aString), dlerror());
}
}
}
@@ -1245,14 +1156,17 @@
val = (_intVal(hi) << 16) + _intVal(low);
h = (void *)(val);
if (__isString(aString)) {
- printf("get sym <%s> handle = %x\n", _stringVal(aString), h);
+ if (ObjectFileLoader_Verbose == true)
+ printf("get sym <%s> handle = %x\n", _stringVal(aString), h);
addr = dlsym(h, _stringVal(aString));
if (addr) {
- printf("addr = %x\n", addr);
+ if (ObjectFileLoader_Verbose == true)
+ printf("addr = %x\n", addr);
lowAddr = _MKSMALLINT( (int)addr & 0xFFFF );
hiAddr = _MKSMALLINT( ((int)addr >> 16) & 0xFFFF );
} else {
- printf("dlsym %s error: <%s>\n", _stringVal(aString), dlerror());
+ if (ObjectFileLoader_Verbose == true)
+ printf("dlsym %s error: <%s>\n", _stringVal(aString), dlerror());
}
}
}
@@ -1264,14 +1178,16 @@
NXStream *errOut;
if (__isString(aString)) {
- printf("get sym <%s>\n", _stringVal(aString));
+ if (ObjectFileLoader_Verbose == true)
+ printf("get sym <%s>\n", _stringVal(aString));
errOut = NXOpenFile(2, 2);
result = rld_lookup(errOut,
(char *) _stringVal(aString),
&addr);
NXClose(errOut);
if (result) {
- printf("addr = %x\n", addr);
+ if (ObjectFileLoader_Verbose == true)
+ printf("addr = %x\n", addr);
lowAddr = _MKSMALLINT( (int)addr & 0xFFFF );
hiAddr = _MKSMALLINT( ((int)addr >> 16) & 0xFFFF );
}
@@ -1285,6 +1201,60 @@
^ nil
!
+getListOfUndefinedSymbolsFrom:handle
+ "return a collection of undefined symbols in a dynamically loaded object file.
+ Handle must be the one returned previously from openDynamicObject."
+
+ |list|
+
+ list := Array new:100. "no more than 100 symbols"
+%{
+
+#ifdef GNU_DL
+# include "dld.h"
+ void (*func)();
+ unsigned long addr;
+ char *name;
+ int nMax;
+
+ if (__isArray(list)) {
+ char **undefNames;
+ char **nm;
+ int index;
+
+ nMax = _arraySize(list);
+
+ nm = undefNames = dld_list_undefined_sym();
+ for (index = 0; index < dld_undefined_sym_count; index++) {
+ _ArrayInstPtr(list)->a_element[index] = _MKSTRING(*nm++);
+ if (index == nMax)
+ break;
+ }
+ free(undefNames);
+ }
+#endif
+
+#ifdef SYSV4_DL
+ /*
+ * dont know how to do it
+ */
+#endif
+
+#ifdef SUN_DL
+ /*
+ * dont know how to do it
+ */
+#endif
+
+#ifdef NEXT_DL
+ /*
+ * dont know how to do it
+ */
+#endif
+%}.
+ ^ list
+!
+
releaseSymbolTable
"this is needed on NeXT to forget loaded names. If this wasnt done,
the same class could not be loaded in again due to multiple defines.
@@ -1302,7 +1272,18 @@
%}
!
-callFunctionAt:address
+callInitFunctionAt:initAddr
+ "
+ need 3 passes to init: 1: create my pools
+ 2: get var-refs to other pools
+ 3: install class, methods and literals
+ "
+ self callFunctionAt:initAddr forceOld:true arg:0.
+ self callFunctionAt:initAddr forceOld:true arg:1.
+ self callFunctionAt:initAddr forceOld:true arg:2.
+!
+
+callFunctionAt:address forceOld:forceOld arg:argument
"call a function at address - this is very dangerous.
This is needed to call the classes init-function after loading in a
class-object file. Dont use in your programs."
@@ -1317,22 +1298,298 @@
typedef void (*VOIDFUNC)();
int savInt;
extern int _immediateInterrupt;
+ int prevSpace;
+ int arg = 0;
if (_isSmallInteger(low) && _isSmallInteger(hi)) {
val = (_intVal(hi) << 16) + _intVal(low);
addr = (VOIDFUNC) val;
+ if (_isSmallInteger(argument)) {
+ arg = _intVal(argument);
+ }
/*
* allow function to be interrupted
*/
savInt = _immediateInterrupt;
_immediateInterrupt = 1;
- (*addr)();
+ if (forceOld == true) {
+ prevSpace = allocForceSpace(OLDSPACE);
+ (*addr)(arg);
+ allocForceSpace(prevSpace);
+ } else {
+ (*addr)(arg);
+ }
_immediateInterrupt = savInt;
}
%}
! !
+!ObjectFileLoader class methodsFor:'primitive loading'!
+
+textSizeOf:aFileName
+ "
+ get the size of the text-segment (nBytes)
+ "
+
+%{ /* NOCONTEXT */
+#ifdef HAS_DL
+ /*
+ * not needed, if dynamic link facilities exist
+ */
+#else /* no DL-support */
+ char *fname;
+ int fd;
+
+ if (! __isString(aFileName)) {
+ RETURN (nil);
+ }
+
+ fname = (char *) _stringVal(aFileName);
+
+# if defined(A_DOT_OUT) && !defined(ELF)
+# if !defined(sco) && !defined(isc)
+ {
+ struct exec header;
+
+ if ((fd = open(fname, 0)) < 0) {
+ fprintf(stderr, "cannot open <%s>\n", fname);
+ RETURN ( nil );
+ }
+ if (read(fd, &header, sizeof(header)) != sizeof(header)) {
+ fprintf(stderr, "cannot read header of <%s>\n", fname);
+ close(fd);
+ RETURN ( nil );
+ }
+ close(fd);
+
+ if (N_MAGIC(header) != OMAGIC) {
+ fprintf(stderr, "header is (0%o) %x - should be (0%o)%x\n",
+ N_MAGIC(header), N_MAGIC(header),
+ OMAGIC, OMAGIC);
+ RETURN ( nil );
+ }
+ RETURN ( _MKSMALLINT(header.a_text) );
+ }
+# endif
+# endif
+ /*
+ * need support for other headers ... (i.e. coff, elf)
+ */
+#endif
+%}.
+ ^ self error:'objectFile format not supported'
+!
+
+dataSizeOf:aFileName
+ "
+ get the size of the data-segment (nBytes)
+ "
+
+%{ /* NOCONTEXT */
+#ifdef HAS_DL
+ /*
+ * not needed, if dynamic link facilities exist
+ */
+#else /* no DL-support */
+ char *fname;
+ int fd;
+
+ if (! __isString(aFileName)) {
+ RETURN ( nil );
+ }
+
+ fname = (char *) _stringVal(aFileName);
+
+# if defined(A_DOT_OUT) && !defined(ELF)
+# if !defined(sco) && !defined(isc)
+ {
+ struct exec header;
+ unsigned size;
+
+ if ((fd = open(fname, 0)) < 0) {
+ fprintf(stderr, "cannot open <%s>\n", fname);
+ RETURN ( nil );
+ }
+ if (read(fd, &header, sizeof(header)) != sizeof(header)) {
+ fprintf(stderr, "cannot read header of <%s>\n", fname);
+ close(fd);
+ RETURN ( nil );
+ }
+ close(fd);
+
+ if (N_MAGIC(header) != OMAGIC) {
+ fprintf(stderr, "header is (0%o) %x - should be (0%o)%x\n",
+ N_MAGIC(header), N_MAGIC(header),
+ OMAGIC, OMAGIC);
+ RETURN ( nil );
+ }
+ size = header.a_data;
+# if defined(sinix) && defined(BSD)
+ size += header.a_bss;
+# endif
+ RETURN ( _MKSMALLINT(size) );
+ }
+# endif
+# endif
+ /*
+ * need support for other headers ... (i.e. coff, elf)
+ */
+#endif
+%}
+.
+ ^ self error:'objectFile format not supported'
+!
+
+loadObjectFile:aFileName textAddr:textAddr textSize:textSize
+ dataAddr:dataAddr dataSize:dataSize
+
+ "the object in aFileName must have been linked for
+ absolute address textAddr/dataAddr (using ld -A).
+ Load the contents from the file. Memory must have previously
+ been allocated using ExternalBytes."
+
+%{ /* NOCONTEXT */
+#ifdef HAS_DL
+ /*
+ * not needed, if dynamic link facilities exist
+ */
+#else /* no DL-support */
+ if (! __isString(aFileName)) {
+ RETURN ( nil );
+ }
+
+# if defined(A_DOT_OUT) && !defined(ELF)
+# if !defined(sco) && !defined(isc)
+ {
+ char *fname = (char *) _stringVal(aFileName);
+ unsigned taddr, daddr;
+ unsigned tsize, dsize;
+ unsigned toffset = 0;
+ unsigned doffset = 0;
+ int fd;
+ struct exec header;
+ char *cp;
+ int bssCount;
+ unsigned magic = OMAGIC;
+ int nread;
+
+ taddr = _isSmallInteger(textAddr) ? (unsigned) _intVal(textAddr) : 0;
+ daddr = _isSmallInteger(dataAddr) ? (unsigned) _intVal(dataAddr) : 0;
+ tsize = _isSmallInteger(textSize) ? _intVal(textSize) : 0;
+ dsize = _isSmallInteger(dataSize) ? _intVal(dataSize) : 0;
+
+ if ((fd = open(fname, 0)) < 0) {
+ fprintf(stderr, "cannot open <%s>\n", fname);
+ RETURN ( nil );
+ }
+ if (read(fd, &header, sizeof(header)) != sizeof(header)) {
+ fprintf(stderr, "cannot read header of <%s>\n", fname);
+ close(fd);
+ RETURN ( nil );
+ }
+ if (N_MAGIC(header) != magic) {
+ fprintf(stderr, "header is (0%o) %x should be (0%o) %x\n",
+ N_MAGIC(header), N_MAGIC(header),
+ magic, magic);
+ close(fd);
+ RETURN ( nil );
+ }
+
+ /*
+ * some linkers produce a huge output file, with zeros up to the
+ * real code ... - thats what toffset, doffset are for.
+ */
+# if defined(sinix) && defined(BSD)
+ toffset = N_TXTADDR(header);
+ doffset = toffset + taddr + tsize /* - 0x800 */;
+ daddr = taddr + tsize;
+# else
+# if defined(mips) && defined(ultrix)
+ toffset = N_TXTOFF(header.ex_f, header.ex_o);
+ doffset = toffset + tsize;
+ daddr = taddr + tsize;
+# else
+# if defined(N_TXTOFF)
+ toffset = N_TXTOFF(header);
+ doffset = N_DATOFF(header);
+ daddr = taddr + tsize;
+# else
+ fprintf(stderr, "dont know text/data offsets in objectfile\n");
+ RETURN ( nil );
+# endif
+# endif
+# endif
+
+# ifdef SUPERDEBUG
+ printf("toffs:%x taddr:%x tsize:%d doffs:%x daddr:%x dsize:%d\n",
+ toffset, taddr, tsize, doffset,daddr, dsize);
+# endif
+
+ if (lseek(fd, (long)toffset, 0) < 0) {
+ fprintf(stderr, "cannot seek to text\n");
+ close(fd);
+ RETURN ( nil );
+ }
+ if ((nread = read(fd, taddr, tsize)) != tsize) {
+ perror("read");
+ fprintf(stderr, "cannot read text wanted:%d got:%d\n", tsize, nread);
+ close(fd);
+ RETURN ( nil );
+ }
+
+# ifdef SUPERDEBUG
+ printf("1st bytes of text: %02x %02x %02x %02x\n",
+ *((char *)taddr) & 0xFF, *((char *)taddr+1) & 0xFF,
+ *((char *)taddr+2) & 0xFF, *((char *)taddr+3) & 0xFF);
+# endif
+
+ if (dsize) {
+ if (lseek(fd, (long)doffset, 0) < 0) {
+ fprintf(stderr, "cannot seek to data\n");
+ close(fd);
+ RETURN ( nil );
+ }
+
+ if (read(fd, daddr, dsize) != dsize) {
+ fprintf(stderr, "cannot read data\n");
+ close(fd);
+ RETURN ( nil );
+ }
+# ifdef SUPERDEBUG
+ {
+ char *ptr;
+ int i;
+
+ ptr = (char *)daddr;
+ fprintf(stderr, "bytes of data (at %x):\n", ptr);
+ for (i=dsize; i>0; i--, ptr++)
+ printf("%02x ", *ptr & 0xFF);
+ }
+# endif
+ }
+ close(fd);
+
+# ifdef NOTDEF
+ if (header.a_bss != 0) {
+ fprintf(stderr, "warning: bss not empty\n");
+ cp = ((char *)daddr) + header.a_data;
+ for (bssCount=header.a_bss; bssCount; bssCount--)
+ *cp++ = 0;
+ }
+# endif
+ }
+ RETURN ( self );
+# endif
+# endif
+ /*
+ * need support for other headers ... (i.e. coff, elf)
+ */
+#endif
+%}.
+ ^ self error:'objectFile format not supported'
+! !
+
ObjectFileLoader initialize!
--- a/ObjectFileLoader.st Wed Mar 30 12:10:24 1994 +0200
+++ b/ObjectFileLoader.st Thu Jun 02 22:26:28 1994 +0200
@@ -12,23 +12,14 @@
Object subclass:#ObjectFileLoader
instanceVariableNames:''
- classVariableNames:'MySymbolTable StubNr Verbose'
+ classVariableNames:'MySymbolTable Verbose'
poolDictionaries:''
category:'System-Compiler'
!
ObjectFileLoader comment:'
-
COPYRIGHT (c) 1993 by Claus Gittinger
All Rights Reserved
-
-this one knowns how to load in external (c)-modules
-(see fileIn/cExample.c) it is all experimental and
-WILL DEFINITELY change soon ...
-
-(goal is to allow loading of binary classes)
-
-$Header: /cvs/stx/stx/libcomp/ObjectFileLoader.st,v 1.6 1994-03-30 10:09:51 claus Exp $
'!
%{
@@ -37,20 +28,24 @@
*/
#ifdef sunos
# define SUN_DL
+# define HAS_DL
#endif
#ifdef NeXT
# define NEXT_DL
+# define HAS_DL
#endif
#ifdef SYSV4
# define SYSV4_DL
+# define HAS_DL
#endif
/*
- * but GNU_DL overwrites this
+ * but GNU_DL overwrites this - its better
*/
#ifdef GNU_DL
+# define HAS_DL
# undef SYSV4_DL
# undef NEXT_DL
# undef SUN_DL
@@ -63,16 +58,90 @@
# endif
#endif /* NEXT_DL */
+#include <stdio.h>
+
+/*
+ * if no dynamic link facilities, do it the hard way ...
+ */
+#ifndef HAS_DL
+
+# ifdef A_DOT_OUT
+# include <a.out.h>
+# ifndef N_MAGIC
+# if defined(sinix) && defined(BSD)
+# define N_MAGIC(hdr) (hdr.a_magic & 0xFFFF)
+# else
+# define N_MAGIC(hdr) (hdr.a_magic)
+# endif
+# endif
+# endif /* a.out */
+
+# ifdef COFF
+# ifdef mips
+# include <sys/exec.h>
+# else
+# include <a.out.h>
+# endif
+# endif /* coff */
+
+# ifdef ELF
+# include <elf.h>
+# endif /* elf */
+
+#endif /* not HAS_DL */
+
static OBJ loadAddrLow, loadAddrHi;
%}
+!ObjectFileLoader class methodsFor:'documentation'!
+
+copyright
+"
+ COPYRIGHT (c) 1993 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/libcomp/ObjectFileLoader.st,v 1.7 1994-06-02 20:26:03 claus Exp $
+"
+!
+
+documentation
+"
+ This class knowns how to dynamically load in external object-modules.
+ There are basically two totally different mechanisms to do this:
+ a) if there exists some dynamic-link facility such as:
+ GNU-DL, dlopen (sparc, SYS5.4), rld_open (NeXT),
+ this is used
+ b) if no such facility exists, the normal linker is used to
+ link the module to text/data address as previously malloced,
+ and the object file loaded into that space.
+
+ Currently, not all mechanisms work fully satisfying.
+ For example, the sun dl*-functions do an exit on link-errors (which
+ is certainly not what we want here :-(; the NeXT mechanism does not
+ allow for selective unloading (only all or last).
+ The only really useful package is the GNU-dl package, which is only
+ available for a.out file formats. (i.e. only linux people can use
+ it at this time).
+"
+! !
+
!ObjectFileLoader class methodsFor:'initialization'!
initialize
"name of object file, where initial symbol table is found"
MySymbolTable := 'smalltalk'.
- StubNr := 1.
Verbose := false
!
@@ -87,7 +156,8 @@
!ObjectFileLoader class methodsFor:'command defaults'!
needSeparateIDSpaces
- "return true, if we need separate I and D spaces"
+ "return true, if we need separate I and D spaces.
+ This is only needed if no dynamic-link facilitiy exists."
|os cpu|
@@ -99,12 +169,13 @@
].
(os = 'linux') ifTrue:[ ^ false ].
- 'dont know if we need sepId - assume no' printNewline.
+ 'dont know if we need sepId - assume no' errorPrintNL.
^ false
!
absLd:file text:textAddr data:dataAddr
- "this should return a string to link file.o to absolute address"
+ "this should return a string to link file.o to absolute address.
+ This is only needed if no dynamic-link facilitiy exists."
|os cpu|
@@ -141,7 +212,8 @@
!
absLd:file text:textAddr
- "this should return a string to link file.o to absolute address"
+ "this should return a string to link file.o to absolute address.
+ This is only needed if no dynamic-link facilitiy exists."
|os cpu|
@@ -163,477 +235,21 @@
! !
-!ObjectFileLoader class methodsFor:'dynamic loading'!
-
-loadFile:aFileName library:librariesString withBindings:bindings in:aClass
- "first, load the file itself"
-
- (self loadFile:aFileName with:librariesString) ifFalse:[^ false].
-
- "then, create stubs"
- self bindExternalFunctions:bindings in:aClass
-!
-
-loadFile:aFileName withBindings:bindings in:aClass
- "load an object file containing external functions, and bind the functions as described
- in bindings, which is an Array of
- (selector functionName argTypes returnType)
- entries, example:
- #(
- (sel1:and: 'f1' (SmallInteger SmallInteger) nil) -> bind 'aClass sel1:and:' to: 'void f1(int, int)'
- (sel2:and: 'f2' (String SmallInteger) String) -> bind 'aClass sel2:and:' to: 'char *f2(char *, int)'
- )
- "
-
- "first, load the file itself"
-
- (self loadFile:aFileName) ifFalse:[^ false].
-
- "then, create stubs"
- self bindExternalFunctions:bindings in:aClass
-!
-
-bindExternalFunctions:bindings in:aClass
- | selector functionName argTypes returnType allOk |
-
- allOk := true.
- bindings do:[:aBinding |
- selector := aBinding at:1.
- functionName := aBinding at:2.
- argTypes := aBinding at:3.
- returnType := aBinding at:4.
- (self createStubFor:selector calling:functionName args:argTypes returning:returnType in:aClass)
- isNil ifTrue:[
- Transcript showCr:'binding of ' , functionName , ' failed.'.
- allOk := false
- ]
- ].
- ^ allOk
-! !
-
-!ObjectFileLoader class methodsFor:'creating stubs'!
-
-storeGlobalAddressesOn:aStream
-
- Smalltalk allKeysDo:[:key |
- self storeGlobalAddressOf:key on:aStream
- ]
-
- "ObjectFileLoader storeGlobalAddressesOn:Transcript"
- "|f|
- f := FileStream newFileNamed:'syms.c'.
- ObjectFileLoader storeGlobalAddressesOn:f.
- f close"
-!
-
-storeGlobalAddressOf:aSymbol on:aStream
- |globalName|
-
- globalName := aSymbol asString.
- (globalName includes:$:) ifTrue:[
- globalName replaceAll:$: by:$_
- ].
-
- aStream nextPutAll:'#define ',globalName,'_addr '.
- aStream nextPutAll:(Smalltalk cellAt:aSymbol) printString.
- aStream cr.
-
- aStream nextPutAll:'#define ',globalName,' ( *( (OBJ *) ',globalName,'_addr))'.
- aStream cr
-
- "ObjectFileLoader storeGlobalAddressOf:#String on:Transcript"
- "ObjectFileLoader storeGlobalAddressOf:#Symbol on:Transcript"
-!
-
-createStubFor:aSelector calling:functionName args:argTypes returning:returnType in:aClass
- "create a method calling a stub function"
-
- |address newMethod s|
-
- address := self createStubCalling:functionName args:argTypes returning:returnType.
- address isNil ifTrue:[^ nil].
-
- newMethod := Method new.
- newMethod code:address.
- newMethod category:'external functions'.
- s := '"calls external function
-
-' , (self cTypeFor:returnType) , ' ' , functionName , '( '.
- argTypes notNil ifTrue:[
- argTypes do:[:type |
- s := s , (self cTypeFor:type) , ' '
- ]
- ].
- s := s , ')
-"'.
- newMethod source:s.
- newMethod numberOfMethodVars:0.
- newMethod stackSize:0.
-
- aClass class addSelector:aSelector withMethod:newMethod.
-
- SilentLoading ifFalse:[
- Transcript showCr:('created stub: ',aClass class name,' ', aSelector)
- ].
-
- ^ newMethod
-
- "ObjectFileLoader createStubFor:#printf:
- calling:'printf'
- args:#(String)
- returning:nil
- in:TestClass"
- "ObjectFileLoader createStubFor:#printf:with:
- calling:'printf'
- args:#(String SmallInteger)
- returning:nil
- in:TestClass"
-!
-
-createStubCalling:functionName args:argTypes returning:returnType
- "create a stub function for calling functionName - return the address of the
- function in core or nil on error"
-
- |baseName p t l handle address stubName|
-
- stubName := 'stub000' , (StubNr printStringRadix:16).
- stubName := stubName copyFrom:(stubName size - 7).
-
- baseName := self createStubSource:stubName calling:functionName args:argTypes returning:returnType.
- baseName isNil ifTrue:[^ nil].
-
- "compile it ..."
- Verbose ifTrue:[
- Transcript showCr:'compiling stub ...', baseName. Transcript endEntry
- ].
-
- (OperatingSystem executeCommand:('make /tmp/' , baseName , '.o')) ifFalse:[
- Transcript showCr:'compilation error.'.
- ^ nil
- ].
- OperatingSystem executeCommand:('mv ' , baseName , '.o /tmp/' , baseName , '.o').
- Verbose ifFalse:[
- OperatingSystem executeCommand:('rm /tmp/' , baseName , '.c').
- ].
-
- (OperatingSystem getOSType = 'sys5.4') ifTrue:[
- "make it a sharable object"
-
- Verbose ifTrue:[
- Transcript showCr:'makeing shared object stub ...', baseName. Transcript endEntry.
- ].
- OperatingSystem executeCommand:('ld -G -o /tmp/',baseName,'.so /tmp/',baseName,'.o').
-
- "attach to it"
- handle := self openDynamicObject:('/tmp/',baseName,'.so').
- handle isNil ifTrue:[
- Transcript showCr:('dlopen error:', '/tmp/',baseName,'.so').
- ^ nil
- ].
- "find the stubs address"
- address := self getSymbol:stubName from:handle.
- address isNil ifTrue:[
- Transcript showCr:'dlsym failed'.
- ^ nil
- ]
- ].
-
- ((OperatingSystem getOSType = 'sunos')
- or:[OperatingSystem getOSType = 'linux']) ifTrue:[
- "load it"
- (self loadFile:('/tmp/' , baseName , '.o')) ifFalse:[
- Transcript showCr:'load error.'.
- ^ nil
- ].
-
- "find the stubs address (use nm to get the address)"
- t := Text new.
- p := PipeStream readingFrom:('nm SymbolTable|grep ' , stubName , ' |grep T').
- [p atEnd] whileFalse:[
- l := p nextLine.
- l notNil ifTrue:[
- t add:l
- ]
- ].
- p close.
- (t size == 1) ifFalse:[
- Transcript showCr:('oops, ' , stubName , ' not in name-list.').
- ^ nil
- ].
- address := Integer readFrom:(ReadStream on:(t at:1)) radix:16
- ].
-
- address isNil ifTrue:[
- Transcript showCr:'no way to dynamically load objects'.
- ^ nil
- ].
-
- Verbose ifTrue:[
- Transcript show:'stub ' , stubName , ' address:'.
- Transcript showCr:(address printStringRadix:16).
- ].
-
- StubNr := StubNr + 1.
- ^ address
-
- "ObjectFileLoader createStubCalling:'printf' args:#(String) returning:nil"
-!
-
-createStubSource:stubName calling:functionName args:argTypes returning:returnType
- "create a temp file with stub-code - return base-filename or nil"
-
- |pid baseName index aStream argName|
-
- pid := OperatingSystem getProcessId printString.
- baseName := 'stc' , pid.
- aStream := FileStream newFileNamed:('/tmp/' , baseName , '.c').
- aStream nextPutAll:'
-#include <stc.h>
-'.
-
- OperatingSystem getOSType = 'sys5.4' ifTrue:[
- self storeGlobalAddressesOn:aStream.
- ].
-
- aStream nextPutAll:'
-' , stubName , '(self, __sel, SND_COMMA __srch, __pI,
- __a1, __a2, __a3, __a4, __a5, __a6, __a7, __a8)
- OBJ __a1, __a2, __a3, __a4, __a5, __a6, __a7, __a8;
- OBJ __sel, __srch;
- SENDER_DECL
-{
- extern OBJ _ISKINDOF_(), ExternalStream;
-'.
-
- returnType notNil ifTrue:[
- aStream nextPutAll:' '.
- aStream nextPutAll:(self cTypeFor:returnType).
- aStream nextPutAll:' __ret;'.
- aStream cr
- ].
-
- "gen type checking code"
- argTypes notNil ifTrue:[
- index := 0.
- argTypes do:[:argType |
- (index + 1) timesRepeat:[ aStream nextPutAll:' '].
- argName := '__a' , (index + 1) printString.
- aStream nextPutAll:'if ('.
- (self checkType:argType name:argName on:aStream) ifFalse:[^ nil].
- aStream nextPutAll:') {'.
- aStream cr.
- index := index + 1
- ]
- ].
- "call the function"
-
- (index + 1) timesRepeat:[ aStream nextPutAll:' '].
- returnType notNil ifTrue:[
- aStream nextPutAll:'__ret = '
- ].
- aStream nextPutAll:functionName , '('.
- argTypes notNil ifTrue:[
- index := 0.
- argTypes do:[:argType |
- argName := '__a' , (index + 1) printString.
- self convertStToC:argType name:argName on:aStream.
- index := index + 1.
- (index == argTypes size) ifFalse:[
- aStream nextPutAll:','
- ]
- ]
- ].
- aStream nextPutAll:');'. aStream cr.
-
- argTypes notNil ifTrue:[
- argTypes size timesRepeat:[
- index timesRepeat:[ aStream nextPutAll:' '].
- aStream nextPutAll:'}'. aStream cr.
- index := index - 1
- ]
- ].
-
- returnType notNil ifTrue:[
- aStream nextPutAll:' return '.
- self convertCToSt:returnType name:'__ret' on:aStream.
- aStream nextPutAll:';'
- ] ifFalse:[
- aStream nextPutAll:' return self;'
- ].
- aStream cr.
-
- aStream nextPutAll:'}'. aStream cr.
- aStream close.
- ^ baseName
-
- "ObjectFileLoader createStubSource:'stub1' calling:'printMessage' args:#(String) returning:nil"
- "ObjectFileLoader createStubSource:'stub2' calling:'printMessage2' args:#(String SmallInteger) returning:#String"
- "ObjectFileLoader createStubSource:'stub3' calling:'sqrt' args:#(Float) returning:#Float"
- "ObjectFileLoader createStubSource:'stub4' calling:'checking' args:#(SmallInteger SmallInteger) returning:#Boolean"
- "ObjectFileLoader createStubSource:'stub5' calling:'fprintf' args:#(ExternalStream String) returning:#SmallInteger"
-!
-
-checkType:argType name:argName on:aStream
- "generate type checking code"
-
- (argType == #SmallInteger) ifTrue:[
- aStream nextPutAll:'_isSmallInteger(' , argName , ')'.
- ^ true
- ].
- (argType == #Float) ifTrue:[
- aStream nextPutAll:'__isFloat(' , argName , ')'.
- ^ true
- ].
- (argType == #Character) ifTrue:[
- aStream nextPutAll:'__isCharacter(' , argName , ')'.
- ^ true
- ].
- (argType == #String) ifTrue:[
- aStream nextPutAll:'__isString(' , argName , ')'.
- ^ true
- ].
- (argType == #Symbol) ifTrue:[
- aStream nextPutAll:'__isSymbol(' , argName , ')'.
- ^ true
- ].
- (argType == #Boolean) ifTrue:[
- aStream nextPutAll:'((' , argName , '==true)'.
- aStream nextPutAll:'||(' , argName , '==false))'.
- ^ true
- ].
- (argType == #ByteArray) ifTrue:[
- aStream nextPutAll:'__isByteArray(' , argName , ')'.
- ^ true
- ].
- (argType == #ExternalStream) ifTrue:[
- aStream nextPutAll:'(_ISKINDOF_(' , argName , ', SND_COMMA ExternalStream)==true)'.
- ^ true
- ].
- self error:'argType ' , argType, ' not (yet) supported'.
- ^ false
-!
-
-convertStToC:stType name:argName on:aStream
- "generate type conversion code"
-
- |idx|
-
- (stType == #SmallInteger) ifTrue:[
- aStream nextPutAll:'_intVal(' , argName , ')'.
- ^ true
- ].
- (stType == #Float) ifTrue:[
- aStream nextPutAll:'_floatVal(' , argName , ')'.
- ^ true
- ].
- (stType == #Character) ifTrue:[
- aStream nextPutAll:'_characterVal(' , argName , ')'.
- ^ true
- ].
- (stType == #String) ifTrue:[
- aStream nextPutAll:'_stringVal(' , argName , ')'.
- ^ true
- ].
- (stType == #Symbol) ifTrue:[
- aStream nextPutAll:'_stringVal(' , argName , ')'.
- ^ true
- ].
- (stType == #Boolean) ifTrue:[
- aStream nextPutAll:'((' , argName , '==true) ? 1 : 0)'.
- ^ true
- ].
- (stType == #ByteArray) ifTrue:[
- aStream nextPutAll:'(_ByteArrayInstPtr(' , argName , ')->ba_element)'.
- ^ true
- ].
- (stType == #ExternalStream) ifTrue:[
- "find the file-pointer inst-var"
- idx := (ExternalStream allInstVarNames indexOf:'filePointer').
- aStream nextPutAll:'_intVal(_InstPtr(' , argName , ')->i_instvars['.
- aStream nextPutAll:(idx - 1) printString, '])'.
- ^ true
- ].
- ^ false
-!
-
-convertCToSt:stType name:argName on:aStream
- "generate type conversion code"
-
- (stType == #SmallInteger) ifTrue:[
- aStream nextPutAll:'_MKSMALLINT(' , argName , ')'.
- ^ true
- ].
- (stType == #Float) ifTrue:[
- aStream nextPutAll:'_MKFLOAT(' , argName , ' COMMA_SND)'.
- ^ true
- ].
- (stType == #Character) ifTrue:[
- aStream nextPutAll:'_MKCHARACTER(' , argName , ')'.
- ^ true
- ].
- (stType == #String) ifTrue:[
- aStream nextPutAll:'(' , argName , ' ? _MKSTRING(' , argName , ' COMMA_SND) : nil)'.
- ^ true
- ].
- (stType == #Symbol) ifTrue:[
- aStream nextPutAll:'(' , argName , ' ? _MKSYMBOL(' , argName , ' COMMA_SND) : nil)'.
- ^ true
- ].
- (stType == #Boolean) ifTrue:[
- aStream nextPutAll:'(' , argName , ' ? true : false)'.
- ^ true
- ].
- ^ false
-!
-
-cTypeFor:aType
- "return c-type for an ST-type"
-
- (aType == #SmallInteger) ifTrue:[
- ^ 'int'
- ].
- (aType == #Boolean) ifTrue:[
- ^ 'int'
- ].
- (aType == #Float) ifTrue:[
- ^ 'double'
- ].
- (aType == #Character) ifTrue:[
- ^ 'char'
- ].
- (aType == #String) ifTrue:[
- ^ 'char *'
- ].
- (aType == #Symbol) ifTrue:[
- ^ 'char *'
- ].
- (aType == #ByteArray) ifTrue:[
- ^ 'unsigned char *'
- ].
- (aType == nil) ifTrue:[
- ^ 'void'
- ].
- (aType == #ExternalStream) ifTrue:[
- ^ 'void *' "actually its FILE *, but better avoid including stdio.h"
- ].
- self error:'type ' , aType, ' not supported'.
- ^ ''
-! !
-
!ObjectFileLoader class methodsFor:'loading objects'!
loadFile:oFile with:librariesString
- "load in an object files code, linking in libraries"
+ "load in an object files code, linking in libraries.
+ This is only needed if no dynamic link facility exists."
- |tmpOfile errStream errors errText ok pid|
+ |tmpOfile errStream errors errText handle pid cmd|
pid := OperatingSystem getProcessId printString.
tmpOfile := '/tmp/stc_ld' , pid.
+ cmd := 'ld -o ', tmpOfile, ' -r ' , oFile , ' ' , librariesString , '>/tmp/out 2>/tmp/err'.
Verbose ifTrue:[
- Transcript showCr:'executing: ' , ('ld -o ',tmpOfile,' -r ' , oFile , ' ' , librariesString , '>/tmp/out 2>/tmp/err')
+ ('executing: ld -o ', cmd) errorPrintNL
].
- (OperatingSystem executeCommand:'ld -o ',tmpOfile,' -r ' , oFile , ' ' , librariesString , '>/tmp/out 2>/tmp/err')
- ifFalse:[
+ (OperatingSystem executeCommand:cmd) ifFalse:[
errStream := FileStream oldFileNamed:'/tmp/err'.
errStream isNil ifTrue:[
self notify:'errors during link.'
@@ -650,36 +266,37 @@
].
^ false
].
- ok := self loadFile:tmpOfile.
+ handle := self loadFile:tmpOfile.
OperatingSystem executeCommand:('rm ' , tmpOfile).
- ^ ok
+ ^ handle
!
loadFile:oFile
- "load in an object file"
+ "load in an object file - return a handle or nil.
+ This is only needed if no dynamic link facility exists."
- | unixCommand errStream errors errText
- text data textSize dataSize dataAddr textAddr newTextSize newDataSize|
+ |unixCommand errStream errors errText
+ text data textSize dataSize dataAddr textAddr newTextSize newDataSize|
"find out, how much memory we need"
- textSize := ObjectFile textSizeOf:oFile.
+ textSize := self textSizeOf:oFile.
textSize isNil ifTrue:[
- Transcript showCr:'bad text-size in object file'.
- ^ false
+ 'bad text-size in object file' errorPrintNL.
+ ^ nil
].
Verbose ifTrue:[
- Transcript showCr:'text-size: ' , (textSize printStringRadix:16)
+ ('text-size: ' , (textSize printStringRadix:16)) errorPrintNL
].
- dataSize := ObjectFile dataSizeOf:oFile.
+ dataSize := self dataSizeOf:oFile.
dataSize isNil ifTrue:[
- Transcript showCr:'bad data-size in object file'.
- ^ false
+ 'bad data-size in object file' errorPrintNL.
+ ^ nil
].
Verbose ifTrue:[
- Transcript showCr:'data-size: ' , (dataSize printStringRadix:16)
+ ('data-size: ' , (dataSize printStringRadix:16)) errorPrintNL
].
"allocate some memory for text and some for data;
@@ -688,48 +305,45 @@
self needSeparateIDSpaces ifTrue:[
text := ExternalBytes newForText:textSize.
text isNil ifTrue:[
- Transcript showCr:'cannot allocate memory for text'.
- ^ false
+ 'cannot allocate memory for text' errorPrintNL.
+ ^ nil
].
Verbose ifTrue:[
- Transcript showCr:'text: ' , (text address printStringRadix:16)
+ ('text: ' , (text address printStringRadix:16)) errorPrintNL
].
(dataSize ~~ 0) ifTrue:[
data := ExternalBytes newForData:dataSize.
(data isNil) ifTrue:[
- Transcript showCr:'cannot allocate memory for data'.
+ 'cannot allocate memory for data' errorPrintNL.
text notNil ifTrue:[text free].
- ^ false
+ ^ nil
].
Verbose ifTrue:[
- Transcript showCr:'data: ' , (data address printStringRadix:16)
+ ('data: ' , (data address printStringRadix:16)) errorPrintNL
]
].
dataSize == 0 ifTrue:[
- unixCommand := (self absLd:oFile text:text address)
- , ' >/tmp/out 2>/tmp/err'.
+ unixCommand := (self absLd:oFile text:text address) , ' >/tmp/out 2>/tmp/err'.
] ifFalse:[
- unixCommand := (self absLd:oFile text:text address
- data:data address)
+ unixCommand := (self absLd:oFile text:text address data:data address)
, ' >/tmp/out 2>/tmp/err'.
]
] ifFalse:[
text := ExternalBytes newForText:(textSize + dataSize).
text isNil ifTrue:[
- Transcript showCr:'cannot allocate memory for text+data'.
- ^ false
+ 'cannot allocate memory for text+data' errorPrintNL.
+ ^ nil
].
Verbose ifTrue:[
- Transcript showCr:'addr: ' , (text address printStringRadix:16)
+ ('addr: ' , (text address printStringRadix:16)) errorPrintNL
].
- unixCommand := (self absLd:oFile text:text address)
- , ' >/tmp/out 2>/tmp/err'.
+ unixCommand := (self absLd:oFile text:text address) , ' >/tmp/out 2>/tmp/err'.
].
Verbose ifTrue:[
- Transcript showCr:'executing: ' , unixCommand
+ ('executing: ' , unixCommand) errorPrintNL
].
'linking ...' printNewline.
@@ -746,39 +360,39 @@
OperatingSystem executeCommand:'rm /tmp/err /tmp/out'.
self notify:('link errors:\\' , errors asString) withCRs
].
- Transcript showCr:'link unsuccessful.'.
+ 'link unsuccessful.' errorPrintNL.
text notNil ifTrue:[text free].
data notNil ifTrue:[data free].
- ^ false
+ ^ nil
].
- 'link successful' printNewline.
+ 'link successful' errorPrintNL.
OperatingSystem executeCommand:'rm /tmp/err /tmp/out'.
"find out, if space needs have changed after link (they do so on some machines)"
- newTextSize := ObjectFile textSizeOf:'a.out'.
+ newTextSize := self textSizeOf:'a.out'.
newTextSize isNil ifTrue:[
- Transcript showCr:'bad new-text-size in a.out object file'.
+ 'bad new-text-size in a.out object file' errorPrintNL.
text notNil ifTrue:[text free].
data notNil ifTrue:[data free].
- ^ false
+ ^ nil
].
Verbose ifTrue:[
- Transcript showCr:'new-text-size: ' , (newTextSize printStringRadix:16)
+ ('new-text-size: ' , (newTextSize printStringRadix:16)) errorPrintNL
].
- newDataSize := ObjectFile dataSizeOf:'a.out'.
+ newDataSize := self dataSizeOf:'a.out'.
newDataSize isNil ifTrue:[
- Transcript showCr:'bad new-data-size in a.out object file'.
+ 'bad new-data-size in a.out object file' errorPrintNL.
text notNil ifTrue:[text free].
data notNil ifTrue:[data free].
- ^ false
+ ^ nil
].
Verbose ifTrue:[
- Transcript showCr:'new-data-size: ' , (newDataSize printStringRadix:16)
+ ('new-data-size: ' , (newDataSize printStringRadix:16)) errorPrintNL
].
"if size has changed, do it again"
@@ -795,52 +409,49 @@
self needSeparateIDSpaces ifTrue:[
text := ExternalBytes newForText:textSize.
text isNil ifTrue:[
- Transcript showCr:'cannot allocate memory for text'.
- ^ false
+ 'cannot allocate memory for new text' errorPrintNL.
+ ^ nil
].
Verbose ifTrue:[
- Transcript showCr:'text: ' , (text address printStringRadix:16)
+ ('new text: ' , (text address printStringRadix:16)) errorPrintNL
].
(dataSize ~~ 0) ifTrue:[
data := ExternalBytes newForData:dataSize.
(data isNil) ifTrue:[
- Transcript showCr:'cannot allocate memory for data'.
+ 'cannot allocate memory for new data' errorPrintNL.
text notNil ifTrue:[text free].
- ^ false
+ ^ nil
].
Verbose ifTrue:[
- Transcript showCr:'data: ' , (data address printStringRadix:16)
+ ('new data: ' , (data address printStringRadix:16)) errorPrintNL
]
].
dataSize == 0 ifTrue:[
- unixCommand := (self absLd:oFile text:text address)
- , ' >/tmp/out 2>/tmp/err'.
+ unixCommand := (self absLd:oFile text:text address) , ' >/tmp/out 2>/tmp/err'.
] ifFalse:[
- unixCommand := (self absLd:oFile text:text address
- data:data address)
+ unixCommand := (self absLd:oFile text:text address data:data address)
, ' >/tmp/out 2>/tmp/err'.
]
] ifFalse:[
text := ExternalBytes newForText:(textSize + dataSize).
text isNil ifTrue:[
- Transcript showCr:'cannot allocate memory for text'.
- ^ false
+ 'cannot allocate memory for new text' errorPrintNL.
+ ^ nil
].
Verbose ifTrue:[
- Transcript showCr:'addr: ' , (text address printStringRadix:16)
+ ('new text+data: ' , (text address printStringRadix:16)) errorPrintNL
].
- unixCommand := (self absLd:oFile text:text address)
- , ' >/tmp/out 2>/tmp/err'.
+ unixCommand := (self absLd:oFile text:text address) , ' >/tmp/out 2>/tmp/err'.
].
Verbose ifTrue:[
- Transcript showCr:'executing: ' , unixCommand
+ ('executing: ' , unixCommand) errorPrintNL
].
- 'linking ...' printNewline.
+ 'linking ...' errorPrintNL.
(OperatingSystem executeCommand:unixCommand) ifFalse: [
errStream := FileStream oldFileNamed:'/tmp/err'.
errStream notNil ifTrue:[
@@ -854,46 +465,46 @@
OperatingSystem executeCommand:'rm /tmp/err /tmp/out'.
self notify:('link errors:\\' , errors asString) withCRs
].
- Transcript showCr:'link unsuccessful.'.
+ 'link unsuccessful.' errorPrintNL.
text notNil ifTrue:[text free].
data notNil ifTrue:[data free].
- ^ false
+ ^ nil
].
- 'link successful' printNewline.
+ 'link successful' errorPrintNL.
OperatingSystem executeCommand:'rm /tmp/err /tmp/out'.
"check again for size change - should not happen"
- newTextSize := ObjectFile textSizeOf:'a.out'.
+ newTextSize := self textSizeOf:'a.out'.
newTextSize isNil ifTrue:[
- Transcript showCr:'bad text-size in a.out object file'.
+ 'bad text-size in a.out object file' errorPrintNL.
text notNil ifTrue:[text free].
data notNil ifTrue:[data free].
- ^ false
+ ^ nil
].
Verbose ifTrue:[
- Transcript showCr:'new-text-size: ' , (newTextSize printStringRadix:16)
+ ('new-text-size: ' , (newTextSize printStringRadix:16)) errorPrintNL
].
- newDataSize := ObjectFile dataSizeOf:'a.out'.
+ newDataSize := self dataSizeOf:'a.out'.
newDataSize isNil ifTrue:[
- Transcript showCr:'bad data-size in object file'.
+ 'bad data-size in object file' errorPrintNL.
text notNil ifTrue:[text free].
data notNil ifTrue:[data free].
- ^ false
+ ^ nil
].
Verbose ifTrue:[
- Transcript showCr:'new-data-size: ' , (newDataSize printStringRadix:16)
+ ('new-data-size: ' , (newDataSize printStringRadix:16)) errorPrintNL
].
((newTextSize ~~ textSize) or:[newDataSize ~~ dataSize]) ifTrue:[
- Transcript showCr:'size changed again - I give up'.
+ 'size changed again - I give up' errorPrintNL.
text notNil ifTrue:[text free].
data notNil ifTrue:[data free].
- ^ false
+ ^ nil
].
].
@@ -913,27 +524,27 @@
Verbose ifTrue:[
textAddr notNil ifTrue:[
- Transcript showCr:'loading ' , textSize printString , ' bytes at ' , (textAddr printStringRadix:16).
+ ('loading ' , textSize printString , ' bytes at ' , (textAddr printStringRadix:16)) errorPrintNL.
].
dataAddr notNil ifTrue:[
- Transcript showCr:'loading ' , dataSize printString , ' bytes at ' , (dataAddr printStringRadix:16).
+ ('loading ' , dataSize printString , ' bytes at ' , (dataAddr printStringRadix:16)) errorPrintNL.
].
].
- (ObjectFile loadObjectFile:'a.out'
+ (self loadObjectFile:'a.out'
textAddr:textAddr textSize:textSize
dataAddr:dataAddr dataSize:dataSize) isNil ifTrue: [
- Transcript showCr:'load in error'.
+ 'load error' errorPrintNL.
text notNil ifTrue:[text free].
data notNil ifTrue:[data free].
- ^ false
+ ^ nil
].
- 'dynamic load successful' printNewline.
+ 'dynamic load successful' errorPrintNL.
OperatingSystem executeCommand:'mv a.out SymbolTable'.
MySymbolTable := 'SymbolTable'.
- ^ true
+ ^ (Array with:textAddr with:dataAddr)
! !
!ObjectFileLoader class methodsFor:'dynamic class loading'!
@@ -941,36 +552,90 @@
loadClass:aClassName fromObjectFile:aFileName
"load a compiled class (.o-file) into the image"
- |handle initAddr symName|
+ |handle initAddr symName newClass list moreHandles|
handle := self openDynamicObject:aFileName.
handle isNil ifTrue:[
Transcript showCr:('openDynamic: ',aFileName,' failed.').
^ nil
].
+
+ "
+ get the Init-function; let the class install itself
+ "
symName := '_' , aClassName , '_Init'.
- initAddr := self getSymbol:symName from:handle.
+ initAddr := self getFunction:symName from:handle.
initAddr isNil ifTrue:[
"try with added underscore"
symName := '__' , aClassName , '_Init'.
- initAddr := self getSymbol:symName from:handle.
+ initAddr := self getFunction:symName from:handle.
+ ].
+
+ "
+ if there are any undefined symbols, we may have to load more
+ "
+ list := self getListOfUndefinedSymbolsFrom:handle.
+ list notNil ifTrue:[
+ moreHandles := self loadModulesFromListOfUndefined:list.
+
+ "
+ now, try again
+ "
+ symName := '_' , aClassName , '_Init'.
+ initAddr := self getFunction:symName from:handle.
initAddr isNil ifTrue:[
- Transcript showCr:('no symbol: ',symName,' in ',aFileName).
- ^ nil
+ "try with added underscore"
+ symName := '__' , aClassName , '_Init'.
+ initAddr := self getFunction:symName from:handle.
].
].
- self callFunctionAt:initAddr.
- ^ Smalltalk at:aClassName asSymbol
+
+ initAddr notNil ifTrue:[
+ Verbose ifTrue:[
+ Transcript showCr:'calling init at: ' , (initAddr printStringRadix:16)
+ ].
+ self callInitFunctionAt:initAddr.
+ (Symbol hasInterned:aClassName) ifTrue:[
+ newClass := Smalltalk at:aClassName asSymbol ifAbsent:[nil].
+ newClass notNil ifTrue:[
+ newClass initialize.
+ "force cache flush"
+ Smalltalk at:aClassName asSymbol put:newClass.
+ Smalltalk changed.
+ ].
+ ] ifFalse:[
+ 'LOADER: class ' errorPrintNL. aClassName errorPrintNL.
+ ' did not define itself' errorPrintNL
+ "
+ do not unload - could have installed its methods ...
+ "
+ ].
+ ^ newClass
+ ].
+
+ Verbose ifTrue:[
+ Transcript showCr:('no symbol: ', symName,' in ',aFileName).
+ ].
+
+ "
+ unload
+ "
+ moreHandles notNil ifTrue:[
+ self closeAllDynamicObjects:moreHandles.
+ ].
+ self closeDynamicObject:handle.
+ ^ nil
"ObjectFileLoader loadClass:'Tetris' fromObjectFile:'../clients/Tetris/Tetris.o'"
"ObjectFileLoader loadClass:'TetrisBlock' fromObjectFile:'../clients/Tetris/TBlock.o'"
+ "ObjectFileLoader loadClass:'Foo' fromObjectFile:'classList.o'"
!
loadObjectFile:aFileName
- "load a compiled class (.o-file) into the image; the class name
- is not needed (multiple definitions may be in the file)"
+ "load an object file (.o-file) into the image;
+ the class name is not needed (multiple definitions may be in the file)."
- |handle initAddr symName className|
+ |handle initAddr symName className newClass list|
handle := self openDynamicObject:aFileName.
handle isNil ifTrue:[
@@ -978,77 +643,229 @@
^ nil
].
- "load worked - now get init functions address"
-
+ "
+ look for init-function
+ "
className := OperatingSystem baseNameOf:aFileName.
(className endsWith:'.o') ifTrue:[
className := className copyTo:(className size - 2)
].
symName := '_' , className , '_Init'.
- initAddr := self getSymbol:symName from:handle.
+ initAddr := self getFunction:symName from:handle.
initAddr isNil ifTrue:[
"try with added underscore"
symName := '__' , className , '_Init'.
- initAddr := self getSymbol:symName from:handle.
+ initAddr := self getFunction:symName from:handle.
initAddr isNil ifTrue:[
"try className from fileName"
className := Smalltalk classNameForFile:className.
symName := '_' , className , '_Init'.
- initAddr := self getSymbol:symName from:handle.
+ initAddr := self getFunction:symName from:handle.
initAddr isNil ifTrue:[
"and with added underscore"
symName := '__' , className , '_Init'.
- initAddr := self getSymbol:symName from:handle.
+ initAddr := self getFunction:symName from:handle.
initAddr isNil ifTrue:[
Transcript showCr:('no symbol: ',symName,' in ',aFileName).
+ "
+ unload
+ "
+ self closeDynamicObject:handle.
^ nil
].
].
].
].
- self callFunctionAt:initAddr.
+ Verbose ifTrue:[
+ Transcript showCr:'calling init at:' , (initAddr printStringRadix:16)
+ ].
+ self callInitFunctionAt:initAddr.
+
+ (Symbol hasInterned:className) ifTrue:[
+ newClass := Smalltalk at:className asSymbol ifAbsent:[nil].
+ newClass notNil ifTrue:[
+ newClass initialize.
+ "force cache flush"
+ Smalltalk at:className asSymbol put:newClass.
+ Smalltalk changed.
+ ].
+ ].
+ ^ newClass
+!
+
+loadCPlusPlusObjectFile:aFileName
+ "load a c++ object file (.o-file) into the image"
+
+ |handle initAddr symName className newClass list|
+
+ handle := self openDynamicObject:aFileName.
+ handle isNil ifTrue:[
+ Transcript showCr:('openDynamic: ',aFileName,' failed.').
+ ^ nil
+ ].
+
+ list := self namesMatching:'__GLOBAL_$I*' in:aFileName.
+list size == 1 ifTrue:[
+"/ (self isCPlusPlusObject:handle) ifTrue:[
+ Verbose ifTrue:[
+ Transcript showCr:'a c++ object file'
+ ].
+ "
+ what I would like to get is the CTOR_LIST,
+ and call each function.
+ But dld cannot (currently) handle SET-type symbols, therefore
+ we search (using nm) for all __GLOBAL_$I* syms, get their values
+ and call them each
+ "
+"/ list := self namesMatching:'__GLOBAL_$I*' in:aFileName.
+
+"/ initAddr := self getFunction:'__CTOR_LIST__' from:handle.
+"/ Verbose ifTrue:[
+"/ Transcript showCr:'calling CTORs at:' , (initAddr printStringRadix:16)
+"/ ].
+
+ initAddr := self getFunction:list first from:handle.
+ initAddr isNil ifTrue:[
+ "
+ try with added underscore
+ "
+ initAddr := self getFunction:('_' , list first) from:handle.
+ ].
+ (initAddr isNil and:[list first startsWith:'_']) ifTrue:[
+ "
+ try with removed underscore
+ "
+ initAddr := self getFunction:(list first copyFrom:2) from:handle.
+ ].
+ initAddr isNil ifTrue:[
+ Verbose ifTrue:[
+ Transcript showCr:'no CTOR-func found (' , list first , ')'
+ ].
+ self closeDynamicObject:aFileName.
+ ^ nil
+ ].
+ Verbose ifTrue:[
+ Transcript showCr:'calling CTORs at:' , (initAddr printStringRadix:16)
+ ].
+ self callFunctionAt:initAddr forceOld:false arg:0.
+ Verbose ifTrue:[
+ Transcript showCr:'done with CTORs.'
+ ].
+
+ "
+ cannot create a CPlusPlus class automatically (there could be more than
+ one classes in it too ...)
+ "
+ ^ handle
+ ].
+
+
+ Verbose ifTrue:[
+ Transcript showCr:'unknown object file'
+ ].
+ self closeDynamicObject:aFileName.
+ ^ nil
+!
+
+loadModulesFromListOfUndefined:list
+ "try to figure out what has to be loaded to resolve symbols from list.
+ return a list of handles of loaded objects
+ "
+ |inits classNames moreHandles|
+
+ inits := list select:[:symbol | symbol notNil and:[symbol endsWith:'_Init']].
+ inits notNil ifTrue:[
+ classNames := inits collect:[:symbol |
+ (symbol startsWith:'___') ifTrue:[
+ symbol copyFrom:4 to:(symbol size - 5)
+ ] ifFalse:[
+ (symbol startsWith:'__') ifTrue:[
+ symbol copyFrom:3 to:(symbol size - 5)
+ ] ifFalse:[
+ (symbol startsWith:'_') ifTrue:[
+ symbol copyFrom:2 to:(symbol size - 5)
+ ] ifFalse:[
+ symbol
+ ]
+ ]
+ ]
+ ].
+ "
+ autoload those classes
+ "
+ classNames do:[:aClassName |
+ aClassName knownAsSymbol ifTrue:[
+ (Smalltalk includesKey:aClassName asSymbol) ifTrue:[
+'autoloading ' print. aClassName printNL.
+ (Smalltalk at:aClassName asSymbol) autoload
+ ]
+ ]
+ ]
+ ].
+ ^ nil
! !
!ObjectFileLoader class methodsFor:'dynamic object access'!
openDynamicObject:pathName
- "open an object-file (map into my address space).
+ "open an object-file (load/map into my address space).
Return a non-nil handle if ok, nil otherwise.
- This function is not supported on all architectures."
+ No bindings are done - only a pure load is performed.
+ This function is not supported on all architectures.
+ "
|handle|
+ Verbose ifTrue:[
+ Transcript showCr:'openDynamic: ' , pathName
+ ].
+
handle := self primOpenDynamicObject:pathName into:(Array new:2).
+ handle isNil ifTrue:[
+ Verbose ifTrue:[
+ Transcript showCr:'no dynamic load facility or load failed.'.
+ ].
+ "try it the hard way"
+ handle := self loadFile:pathName.
+ ].
^ handle
"sys5.4:
|handle|
handle := ObjectFileLoader openDynamicObject:'../stc/mod1.so'.
- ObjectFileLoader getSymbol:'module1' from:handle
+ ObjectFileLoader getFunction:'module1' from:handle
"
"next:
|handle|
handle := ObjectFileLoader openDynamicObject:'../goodies/Path/AbstrPath.o'.
- ObjectFileLoader getSymbol:'__AbstractPath_Init' from:handle
+ ObjectFileLoader getFunction:'__AbstractPath_Init' from:handle
"
"GLD:
|handle|
handle := ObjectFileLoader openDynamicObject:'../clients/Tetris/Tetris.o'.
- ObjectFileLoader getSymbol:'__TetrisBlock_Init' from:handle
+ ObjectFileLoader getFunction:'__TetrisBlock_Init' from:handle
"
!
primOpenDynamicObject:pathName into:aBuffer
"open an object-file (map into my address space).
This function is not supported on all architectures.
- Dont depend on the returned value or class of it, it depends
- on the underlying dynamic load package."
+ Dont depend on the values or types returned in aBuffer,
+ it depends on the underlying dynamic load package."
%{ /* UNLIMITEDSTACK */
#ifdef GNU_DL
# include "dld.h"
+ static firstCall = 1;
+ extern char *__myName__;
+
+ if (firstCall) {
+ firstCall = 0;
+ (void) dld_init (__myName__);
+ }
+
if (__isString(pathName)) {
if (dld_link(_stringVal(pathName))) {
dld_perror("cant link");
@@ -1070,11 +887,12 @@
handle = dlopen(_stringVal(pathName), RTLD_NOW);
if (! handle) {
- printf("dlopen %s error: <%s>\n", _stringVal(pathName), dlerror());
+ fprintf(stderr, "dlopen %s error: <%s>\n", _stringVal(pathName), dlerror());
RETURN (nil);
}
- printf("open %s handle = %x\n", _stringVal(pathName), handle);
+ if (ObjectFileLoader_Verbose == true)
+ printf("open %s handle = %x\n", _stringVal(pathName), handle);
_AT_PUT_(aBuffer COMMA_SND, _MKSMALLINT(1),
_MKSMALLINT( (int)handle & 0xFFFF ));
_AT_PUT_(aBuffer COMMA_SND, _MKSMALLINT(2),
@@ -1086,8 +904,6 @@
# include <dlfcn.h>
void *handle;
- loadAddrLow = nil;
- loadAddrHi = nil;
if ((pathName == nil) || __isString(pathName)) {
if (pathName == nil)
handle = dlopen((char *)0, 1);
@@ -1095,11 +911,12 @@
handle = dlopen(_stringVal(pathName), 1);
if (! handle) {
- printf("dlopen %s error: <%s>\n", _stringVal(pathName), dlerror());
+ fprintf(stderr, "dlopen %s error: <%s>\n", _stringVal(pathName), dlerror());
RETURN (nil);
}
- printf("open %s handle = %x\n", _stringVal(pathName), handle);
+ if (ObjectFileLoader_Verbose == true)
+ printf("open %s handle = %x\n", _stringVal(pathName), handle);
_AT_PUT_(aBuffer COMMA_SND, _MKSMALLINT(1),
_MKSMALLINT( (int)handle & 0xFFFF ));
_AT_PUT_(aBuffer COMMA_SND, _MKSMALLINT(2),
@@ -1112,8 +929,6 @@
char *files[2];
NXStream *errOut;
- loadAddrLow = nil;
- loadAddrHi = nil;
if (__isString(pathName)) {
files[0] = (char *) _stringVal(pathName);
files[1] = (char *) 0;
@@ -1124,11 +939,12 @@
(char *)0);
NXClose(errOut);
if (! result) {
- printf("rld_load %s failed\n", _stringVal(pathName));
+ fprintf(stderr, "rld_load %s failed\n", _stringVal(pathName));
RETURN (nil);
}
- printf("rld_load %s ok\n", _stringVal(pathName));
+ if (ObjectFileLoader_Verbose == true)
+ printf("rld_load %s ok\n", _stringVal(pathName));
_AT_PUT_(aBuffer COMMA_SND, _MKSMALLINT(1), _MKSMALLINT(1));
_AT_PUT_(aBuffer COMMA_SND, _MKSMALLINT(2), _MKSMALLINT(0));
}
@@ -1150,6 +966,7 @@
}
RETURN ( self );
}
+ RETURN (self);
#endif
%}.
@@ -1164,7 +981,8 @@
if (_isSmallInteger(low) && _isSmallInteger(hi)) {
val = (_intVal(hi) << 16) + _intVal(low);
h = (void *)(val);
- printf("close handle = %x\n", h);
+ if (ObjectFileLoader_Verbose == true)
+ printf("close handle = %x\n", h);
dlclose(h);
}
#endif
@@ -1177,33 +995,123 @@
if (_isSmallInteger(low) && _isSmallInteger(hi)) {
val = (_intVal(hi) << 16) + _intVal(low);
h = (void *)(val);
- printf("close handle = %x\n", h);
+ if (ObjectFileLoader_Verbose == true)
+ printf("close handle = %x\n", h);
dlclose(h);
}
#endif
%}
!
-getSymbol:aString from:handle
- "return the address of a symbol from a dynamically loaded object file.
+isSmalltalkObject:handle
+ "return true, if the loaded object is a smalltalk object module"
+
+ "not yet implemented - stc_compiled_smalltalk is a static symbol,
+ not found in list - need nm-interface, or nlist-walker
+ "
+ ^ true.
+
+ (self getSymbol:'__stc_compiled_smalltalk' function:true from:handle) notNil ifTrue:[^ true].
+ (self getSymbol:'__stc_compiled_smalltalk' function:false from:handle) notNil ifTrue:[^ true].
+ ^ false
+!
+
+isCPlusPlusObject:handle
+ "return true, if the loaded object is a c++ object module"
+
+ (self getSymbol:'__gnu_compiled_cplusplus' function:true from:handle) notNil ifTrue:[^ true].
+ (self getSymbol:'__CTOR_LIST__' function:true from:handle) notNil ifTrue:[^ true].
+ (self getSymbol:'__CTOR_LIST__' function:false from:handle) notNil ifTrue:[^ true].
+ (self getSymbol:'__gnu_compiled_cplusplus' function:false from:handle) notNil ifTrue:[^ true].
+ ^ false
+!
+
+namesMatching:aPattern in:aFileName
+ |p l s addr segment name entry|
+
+ l := OrderedCollection new.
+ p := PipeStream readingFrom:('nm ' , aFileName).
+ p isNil ifTrue:[
+ ('cannot read names from ' , aFileName) errorPrintNL.
+ ^ nil
+ ].
+ [p atEnd] whileFalse:[
+ entry := p nextLine.
+ s := ReadStream on:entry.
+ addr := s nextWord.
+ segment := s nextWord.
+ name := s upToEnd withoutSeparators.
+ (addr notNil and:[segment notNil and:[name notNil]]) ifTrue:[
+ (aPattern match:name) ifTrue:[
+ l add:name
+ ]
+ ]
+ ].
+ p close.
+ ^ l
+!
+
+isObjectiveCObject:handle
+ "not yet implemented"
+
+ ^ false
+!
+
+getFunction:aString from:handle
+ "return the address of a function from a dynamically loaded object file.
+ Handle must be the one returned previously from openDynamicObject.
+ Return the address of the function, or nil on any error."
+
+ ^ self getSymbol:aString function:true from:handle
+!
+
+getSymbol:aString function:isFunction from:handle
+ "return the address of a symbol/function from a dynamically loaded object file.
Handle must be the one returned previously from openDynamicObject.
Return the address of the symbol, or nil on any error."
|low hi lowAddr hiAddr|
-%{
+%{ /* STACK: 20000 */
+
#ifdef GNU_DL
# include "dld.h"
void (*func)();
+ unsigned long addr;
+ char *name;
if (__isString(aString)) {
- func = (void (*) ()) dld_get_func(_stringVal(aString));
- if (func) {
- printf("addr = %x\n", (INT)func);
- lowAddr = _MKSMALLINT( (INT)func & 0xFFFF );
- hiAddr = _MKSMALLINT( ((INT)func >> 16) & 0xFFFF );
+ name = (char *) _stringVal(aString);
+ if (isFunction == false) {
+ addr = dld_get_symbol(name);
} else {
- dld_perror("get_func");
+ func = (void (*) ()) dld_get_func(name);
+ if (func) {
+ if (ObjectFileLoader_Verbose == true)
+ printf("addr of %s = %x\n", name, (INT)func);
+ if (dld_function_executable_p(name)) {
+ lowAddr = _MKSMALLINT( (INT)func & 0xFFFF );
+ hiAddr = _MKSMALLINT( ((INT)func >> 16) & 0xFFFF );
+ } else {
+ char **undefNames;
+ char **nm;
+ int i;
+
+ if (ObjectFileLoader_Verbose == true) {
+ printf ("function %s not executable\n", name);
+ dld_perror("not executable");
+
+ printf("undefined:\n");
+ nm = undefNames = dld_list_undefined_sym();
+ for (i=dld_undefined_sym_count; i; i--) {
+ printf(" %s\n", *nm++);
+ }
+ }
+ free(undefNames);
+ }
+ } else {
+ dld_perror("get_func");
+ }
}
}
#endif
@@ -1222,14 +1130,17 @@
val = (_intVal(hi) << 16) + _intVal(low);
h = (void *)(val);
if (__isString(aString)) {
- printf("get sym <%s> handle = %x\n", _stringVal(aString), h);
+ if (ObjectFileLoader_Verbose == true)
+ printf("get sym <%s> handle = %x\n", _stringVal(aString), h);
addr = dlsym(h, _stringVal(aString));
if (addr) {
- printf("addr = %x\n", addr);
+ if (ObjectFileLoader_Verbose == true)
+ printf("addr = %x\n", addr);
lowAddr = _MKSMALLINT( (int)addr & 0xFFFF );
hiAddr = _MKSMALLINT( ((int)addr >> 16) & 0xFFFF );
} else {
- printf("dlsym %s error: <%s>\n", _stringVal(aString), dlerror());
+ if (ObjectFileLoader_Verbose == true)
+ printf("dlsym %s error: <%s>\n", _stringVal(aString), dlerror());
}
}
}
@@ -1245,14 +1156,17 @@
val = (_intVal(hi) << 16) + _intVal(low);
h = (void *)(val);
if (__isString(aString)) {
- printf("get sym <%s> handle = %x\n", _stringVal(aString), h);
+ if (ObjectFileLoader_Verbose == true)
+ printf("get sym <%s> handle = %x\n", _stringVal(aString), h);
addr = dlsym(h, _stringVal(aString));
if (addr) {
- printf("addr = %x\n", addr);
+ if (ObjectFileLoader_Verbose == true)
+ printf("addr = %x\n", addr);
lowAddr = _MKSMALLINT( (int)addr & 0xFFFF );
hiAddr = _MKSMALLINT( ((int)addr >> 16) & 0xFFFF );
} else {
- printf("dlsym %s error: <%s>\n", _stringVal(aString), dlerror());
+ if (ObjectFileLoader_Verbose == true)
+ printf("dlsym %s error: <%s>\n", _stringVal(aString), dlerror());
}
}
}
@@ -1264,14 +1178,16 @@
NXStream *errOut;
if (__isString(aString)) {
- printf("get sym <%s>\n", _stringVal(aString));
+ if (ObjectFileLoader_Verbose == true)
+ printf("get sym <%s>\n", _stringVal(aString));
errOut = NXOpenFile(2, 2);
result = rld_lookup(errOut,
(char *) _stringVal(aString),
&addr);
NXClose(errOut);
if (result) {
- printf("addr = %x\n", addr);
+ if (ObjectFileLoader_Verbose == true)
+ printf("addr = %x\n", addr);
lowAddr = _MKSMALLINT( (int)addr & 0xFFFF );
hiAddr = _MKSMALLINT( ((int)addr >> 16) & 0xFFFF );
}
@@ -1285,6 +1201,60 @@
^ nil
!
+getListOfUndefinedSymbolsFrom:handle
+ "return a collection of undefined symbols in a dynamically loaded object file.
+ Handle must be the one returned previously from openDynamicObject."
+
+ |list|
+
+ list := Array new:100. "no more than 100 symbols"
+%{
+
+#ifdef GNU_DL
+# include "dld.h"
+ void (*func)();
+ unsigned long addr;
+ char *name;
+ int nMax;
+
+ if (__isArray(list)) {
+ char **undefNames;
+ char **nm;
+ int index;
+
+ nMax = _arraySize(list);
+
+ nm = undefNames = dld_list_undefined_sym();
+ for (index = 0; index < dld_undefined_sym_count; index++) {
+ _ArrayInstPtr(list)->a_element[index] = _MKSTRING(*nm++);
+ if (index == nMax)
+ break;
+ }
+ free(undefNames);
+ }
+#endif
+
+#ifdef SYSV4_DL
+ /*
+ * dont know how to do it
+ */
+#endif
+
+#ifdef SUN_DL
+ /*
+ * dont know how to do it
+ */
+#endif
+
+#ifdef NEXT_DL
+ /*
+ * dont know how to do it
+ */
+#endif
+%}.
+ ^ list
+!
+
releaseSymbolTable
"this is needed on NeXT to forget loaded names. If this wasnt done,
the same class could not be loaded in again due to multiple defines.
@@ -1302,7 +1272,18 @@
%}
!
-callFunctionAt:address
+callInitFunctionAt:initAddr
+ "
+ need 3 passes to init: 1: create my pools
+ 2: get var-refs to other pools
+ 3: install class, methods and literals
+ "
+ self callFunctionAt:initAddr forceOld:true arg:0.
+ self callFunctionAt:initAddr forceOld:true arg:1.
+ self callFunctionAt:initAddr forceOld:true arg:2.
+!
+
+callFunctionAt:address forceOld:forceOld arg:argument
"call a function at address - this is very dangerous.
This is needed to call the classes init-function after loading in a
class-object file. Dont use in your programs."
@@ -1317,22 +1298,298 @@
typedef void (*VOIDFUNC)();
int savInt;
extern int _immediateInterrupt;
+ int prevSpace;
+ int arg = 0;
if (_isSmallInteger(low) && _isSmallInteger(hi)) {
val = (_intVal(hi) << 16) + _intVal(low);
addr = (VOIDFUNC) val;
+ if (_isSmallInteger(argument)) {
+ arg = _intVal(argument);
+ }
/*
* allow function to be interrupted
*/
savInt = _immediateInterrupt;
_immediateInterrupt = 1;
- (*addr)();
+ if (forceOld == true) {
+ prevSpace = allocForceSpace(OLDSPACE);
+ (*addr)(arg);
+ allocForceSpace(prevSpace);
+ } else {
+ (*addr)(arg);
+ }
_immediateInterrupt = savInt;
}
%}
! !
+!ObjectFileLoader class methodsFor:'primitive loading'!
+
+textSizeOf:aFileName
+ "
+ get the size of the text-segment (nBytes)
+ "
+
+%{ /* NOCONTEXT */
+#ifdef HAS_DL
+ /*
+ * not needed, if dynamic link facilities exist
+ */
+#else /* no DL-support */
+ char *fname;
+ int fd;
+
+ if (! __isString(aFileName)) {
+ RETURN (nil);
+ }
+
+ fname = (char *) _stringVal(aFileName);
+
+# if defined(A_DOT_OUT) && !defined(ELF)
+# if !defined(sco) && !defined(isc)
+ {
+ struct exec header;
+
+ if ((fd = open(fname, 0)) < 0) {
+ fprintf(stderr, "cannot open <%s>\n", fname);
+ RETURN ( nil );
+ }
+ if (read(fd, &header, sizeof(header)) != sizeof(header)) {
+ fprintf(stderr, "cannot read header of <%s>\n", fname);
+ close(fd);
+ RETURN ( nil );
+ }
+ close(fd);
+
+ if (N_MAGIC(header) != OMAGIC) {
+ fprintf(stderr, "header is (0%o) %x - should be (0%o)%x\n",
+ N_MAGIC(header), N_MAGIC(header),
+ OMAGIC, OMAGIC);
+ RETURN ( nil );
+ }
+ RETURN ( _MKSMALLINT(header.a_text) );
+ }
+# endif
+# endif
+ /*
+ * need support for other headers ... (i.e. coff, elf)
+ */
+#endif
+%}.
+ ^ self error:'objectFile format not supported'
+!
+
+dataSizeOf:aFileName
+ "
+ get the size of the data-segment (nBytes)
+ "
+
+%{ /* NOCONTEXT */
+#ifdef HAS_DL
+ /*
+ * not needed, if dynamic link facilities exist
+ */
+#else /* no DL-support */
+ char *fname;
+ int fd;
+
+ if (! __isString(aFileName)) {
+ RETURN ( nil );
+ }
+
+ fname = (char *) _stringVal(aFileName);
+
+# if defined(A_DOT_OUT) && !defined(ELF)
+# if !defined(sco) && !defined(isc)
+ {
+ struct exec header;
+ unsigned size;
+
+ if ((fd = open(fname, 0)) < 0) {
+ fprintf(stderr, "cannot open <%s>\n", fname);
+ RETURN ( nil );
+ }
+ if (read(fd, &header, sizeof(header)) != sizeof(header)) {
+ fprintf(stderr, "cannot read header of <%s>\n", fname);
+ close(fd);
+ RETURN ( nil );
+ }
+ close(fd);
+
+ if (N_MAGIC(header) != OMAGIC) {
+ fprintf(stderr, "header is (0%o) %x - should be (0%o)%x\n",
+ N_MAGIC(header), N_MAGIC(header),
+ OMAGIC, OMAGIC);
+ RETURN ( nil );
+ }
+ size = header.a_data;
+# if defined(sinix) && defined(BSD)
+ size += header.a_bss;
+# endif
+ RETURN ( _MKSMALLINT(size) );
+ }
+# endif
+# endif
+ /*
+ * need support for other headers ... (i.e. coff, elf)
+ */
+#endif
+%}
+.
+ ^ self error:'objectFile format not supported'
+!
+
+loadObjectFile:aFileName textAddr:textAddr textSize:textSize
+ dataAddr:dataAddr dataSize:dataSize
+
+ "the object in aFileName must have been linked for
+ absolute address textAddr/dataAddr (using ld -A).
+ Load the contents from the file. Memory must have previously
+ been allocated using ExternalBytes."
+
+%{ /* NOCONTEXT */
+#ifdef HAS_DL
+ /*
+ * not needed, if dynamic link facilities exist
+ */
+#else /* no DL-support */
+ if (! __isString(aFileName)) {
+ RETURN ( nil );
+ }
+
+# if defined(A_DOT_OUT) && !defined(ELF)
+# if !defined(sco) && !defined(isc)
+ {
+ char *fname = (char *) _stringVal(aFileName);
+ unsigned taddr, daddr;
+ unsigned tsize, dsize;
+ unsigned toffset = 0;
+ unsigned doffset = 0;
+ int fd;
+ struct exec header;
+ char *cp;
+ int bssCount;
+ unsigned magic = OMAGIC;
+ int nread;
+
+ taddr = _isSmallInteger(textAddr) ? (unsigned) _intVal(textAddr) : 0;
+ daddr = _isSmallInteger(dataAddr) ? (unsigned) _intVal(dataAddr) : 0;
+ tsize = _isSmallInteger(textSize) ? _intVal(textSize) : 0;
+ dsize = _isSmallInteger(dataSize) ? _intVal(dataSize) : 0;
+
+ if ((fd = open(fname, 0)) < 0) {
+ fprintf(stderr, "cannot open <%s>\n", fname);
+ RETURN ( nil );
+ }
+ if (read(fd, &header, sizeof(header)) != sizeof(header)) {
+ fprintf(stderr, "cannot read header of <%s>\n", fname);
+ close(fd);
+ RETURN ( nil );
+ }
+ if (N_MAGIC(header) != magic) {
+ fprintf(stderr, "header is (0%o) %x should be (0%o) %x\n",
+ N_MAGIC(header), N_MAGIC(header),
+ magic, magic);
+ close(fd);
+ RETURN ( nil );
+ }
+
+ /*
+ * some linkers produce a huge output file, with zeros up to the
+ * real code ... - thats what toffset, doffset are for.
+ */
+# if defined(sinix) && defined(BSD)
+ toffset = N_TXTADDR(header);
+ doffset = toffset + taddr + tsize /* - 0x800 */;
+ daddr = taddr + tsize;
+# else
+# if defined(mips) && defined(ultrix)
+ toffset = N_TXTOFF(header.ex_f, header.ex_o);
+ doffset = toffset + tsize;
+ daddr = taddr + tsize;
+# else
+# if defined(N_TXTOFF)
+ toffset = N_TXTOFF(header);
+ doffset = N_DATOFF(header);
+ daddr = taddr + tsize;
+# else
+ fprintf(stderr, "dont know text/data offsets in objectfile\n");
+ RETURN ( nil );
+# endif
+# endif
+# endif
+
+# ifdef SUPERDEBUG
+ printf("toffs:%x taddr:%x tsize:%d doffs:%x daddr:%x dsize:%d\n",
+ toffset, taddr, tsize, doffset,daddr, dsize);
+# endif
+
+ if (lseek(fd, (long)toffset, 0) < 0) {
+ fprintf(stderr, "cannot seek to text\n");
+ close(fd);
+ RETURN ( nil );
+ }
+ if ((nread = read(fd, taddr, tsize)) != tsize) {
+ perror("read");
+ fprintf(stderr, "cannot read text wanted:%d got:%d\n", tsize, nread);
+ close(fd);
+ RETURN ( nil );
+ }
+
+# ifdef SUPERDEBUG
+ printf("1st bytes of text: %02x %02x %02x %02x\n",
+ *((char *)taddr) & 0xFF, *((char *)taddr+1) & 0xFF,
+ *((char *)taddr+2) & 0xFF, *((char *)taddr+3) & 0xFF);
+# endif
+
+ if (dsize) {
+ if (lseek(fd, (long)doffset, 0) < 0) {
+ fprintf(stderr, "cannot seek to data\n");
+ close(fd);
+ RETURN ( nil );
+ }
+
+ if (read(fd, daddr, dsize) != dsize) {
+ fprintf(stderr, "cannot read data\n");
+ close(fd);
+ RETURN ( nil );
+ }
+# ifdef SUPERDEBUG
+ {
+ char *ptr;
+ int i;
+
+ ptr = (char *)daddr;
+ fprintf(stderr, "bytes of data (at %x):\n", ptr);
+ for (i=dsize; i>0; i--, ptr++)
+ printf("%02x ", *ptr & 0xFF);
+ }
+# endif
+ }
+ close(fd);
+
+# ifdef NOTDEF
+ if (header.a_bss != 0) {
+ fprintf(stderr, "warning: bss not empty\n");
+ cp = ((char *)daddr) + header.a_data;
+ for (bssCount=header.a_bss; bssCount; bssCount--)
+ *cp++ = 0;
+ }
+# endif
+ }
+ RETURN ( self );
+# endif
+# endif
+ /*
+ * need support for other headers ... (i.e. coff, elf)
+ */
+#endif
+%}.
+ ^ self error:'objectFile format not supported'
+! !
+
ObjectFileLoader initialize!
--- a/ParseNode.st Wed Mar 30 12:10:24 1994 +0200
+++ b/ParseNode.st Thu Jun 02 22:26:28 1994 +0200
@@ -18,12 +18,37 @@
!
ParseNode comment:'
-
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
+'!
-$Header: /cvs/stx/stx/libcomp/ParseNode.st,v 1.5 1994-03-30 10:09:54 claus Exp $
-'!
+!ParseNode class methodsFor:'documentation'!
+
+copyright
+"
+ COPYRIGHT (c) 1989 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/libcomp/ParseNode.st,v 1.6 1994-06-02 20:26:06 claus Exp $
+"
+!
+
+documentation
+"
+ node for parse-trees; abstract class
+"
+! !
!ParseNode class methodsFor:'instance creation'!
--- a/Parser.st Wed Mar 30 12:10:24 1994 +0200
+++ b/Parser.st Thu Jun 02 22:26:28 1994 +0200
@@ -34,15 +34,32 @@
!
Parser comment:'
-
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
-
-$Header: /cvs/stx/stx/libcomp/Parser.st,v 1.10 1994-03-30 10:10:24 claus Exp $
'!
!Parser class methodsFor:'documentation'!
+copyright
+"
+ COPYRIGHT (c) 1989 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/libcomp/Parser.st,v 1.11 1994-06-02 20:26:08 claus Exp $
+"
+!
+
documentation
"
Parser is used for both parsing and evaluating smalltalk expressions;
@@ -66,8 +83,8 @@
You can also use parsers for all kinds of other things (ChangesBrowser for
example analyzes the expressions in the changelist ...) by looking at the
parsers tree. (Although this is somewhat dangerous, since it exports the
- compilers internals ... better style would be to add specialized query
- methods here.)
+ compilers internals ... better style is to add specialized query methods here,
+ which will be done incrementally.)
One instance of Parser is created to parse one method or expression - i.e.
its not suggested to reuse parsers.
@@ -150,6 +167,7 @@
in:nil
receiver:nil
notifying:nil
+ logged:false
ifFail:nil
"
@@ -159,6 +177,36 @@
"
!
+evaluate:aStringOrStream ifFail:failBlock
+ "return the result of evaluating an expression in aStringOrStream.
+ In case of any syntax errors, return the value of failBlock."
+
+ ^ self
+ evaluate:aStringOrStream
+ in:nil
+ receiver:nil
+ notifying:nil
+ logged:false
+ ifFail:failBlock
+
+ "
+ Compiler evaluate:'1 +' ifFail:['oops']
+
+ "
+!
+
+evaluate:aStringOrStream logged:logged
+ "return the result of evaluating an expression in aStringOrStream"
+
+ ^ self
+ evaluate:aStringOrStream
+ in:nil
+ receiver:nil
+ notifying:nil
+ logged:logged
+ ifFail:nil
+!
+
evaluate:aStringOrStream notifying:requestor
"return the result of evaluating aString,
errors are reported to requestor"
@@ -168,26 +216,45 @@
in:nil
receiver:nil
notifying:requestor
+ logged:false
ifFail:nil
!
-evaluate:aString receiver:anObject notifying:requestor
+evaluate:aStringOrStream receiver:anObject notifying:requestor
"return the result of evaluating aString,
errors are reported to requestor. Allow access to
anObject as self and to its instVars (used in the inspector)"
^ self
- evaluate:aString
+ evaluate:aStringOrStream
in:nil
receiver:anObject
notifying:requestor
+ logged:false
ifFail:nil
!
evaluate:aStringOrStream in:aContext receiver:anObject
notifying:requestor
ifFail:failBlock
+ ^ self
+ evaluate:aStringOrStream
+ in:nil
+ receiver:anObject
+ notifying:requestor
+ logged:false
+ ifFail:nil
+!
+
+evaluate:aStringOrStream in:aContext receiver:anObject notifying:requestor logged:logged ifFail:failBlock
+ "return the result of evaluating aStringOrStream, errors are reported to requestor.
+ Allow access to anObject as self and to its instVars (used in the inspector).
+ If logged is true, an entry is added to the change-file. If the failBlock argument
+ is non-nil, it is evaluated if an error occurs."
+
+ "XXX: logging is not yet implemented"
+
|parser tree mustBackup|
aStringOrStream isNil ifTrue:[^ nil].
@@ -238,7 +305,7 @@
selectorInExpression:aString
"parse an expression - return the selector. Used for
- SystemBrowsers implementors/senders query-box initial text"
+ SystemBrowsers implementors/senders query-box initial text."
|tree parser|
@@ -265,12 +332,12 @@
^ parser degeneratedKeywordExpressionForSelector
"
- Parser selectorInExpression:'foo at:1 put:(5 * bar)'
- Parser selectorInExpression:'(foo at:1) at:1'
- Parser selectorInExpression:'1 + 4'
- Parser selectorInExpression:'1 negated'
- Parser selectorInExpression:'at:1 put:5'
- Parser selectorInExpression:'a := foo at:1 put:5'
+ Parser selectorInExpression:'foo at:1 put:(5 * bar)'
+ Parser selectorInExpression:'(foo at:1) at:1'
+ Parser selectorInExpression:'1 + 4'
+ Parser selectorInExpression:'1 negated'
+ Parser selectorInExpression:'at:1 put:5'
+ Parser selectorInExpression:'a := foo at:1 put:5'
"
!
@@ -309,6 +376,15 @@
return the parser, nil or #error"
^ self parseMethodSpecification:aString in:nil
+
+ "
+ |p|
+
+ p := Parser parseMethodSpecification:'foo:arg1 bar:arg2 baz:arg3'.
+ 'nArgs: ' print. p numberOfMethodArgs printNL.
+ 'args: ' print. p methodArgs printNL.
+ 'sel: ' print. p selector printNL
+ "
!
parseMethodSpecification:aString in:aClass
@@ -330,6 +406,17 @@
return the parser, nil or #error"
^ self parseMethodArgAndVarSpecification:aString in:nil
+
+ "
+ |p|
+
+ p := Parser parseMethodArgAndVarSpecification:'foo:arg1 bar:arg2 baz:arg3 |l1 l2|'.
+ 'nArgs: ' print. p numberOfMethodArgs printNL.
+ 'args: ' print. p methodArgs printNL.
+ 'sel: ' print. p selector printNL.
+ 'nLocal: ' print. p numberOfMethodVars printNL.
+ 'locals: ' print. p methodVars printNL.
+ "
!
parseMethodArgAndVarSpecification:aString in:aClass
@@ -351,6 +438,18 @@
"parse a method; return parser, nil or #error"
^ self parseMethod:aString in:nil
+
+ "
+ |p|
+
+ p := Parser parseMethod:'foo:arg1 bar:arg2 baz:arg3 |l1 l2| l1 := 0. l2 := arg1. ^ self'.
+ 'nArgs: ' print. p numberOfMethodArgs printNL.
+ 'args: ' print. p methodArgs printNL.
+ 'sel: ' print. p selector printNL.
+ 'nLocal: ' print. p numberOfMethodVars printNL.
+ 'locals: ' print. p methodVars printNL.
+ 'tree: ' printNL. p tree printAllOn:Stdout. Stdout cr.
+ "
!
parseMethod:aString in:aClass
@@ -365,6 +464,51 @@
^ parser
! !
+!Parser class methodsFor:'unparsing'!
+
+methodSpecificationForSelector:aSelector
+ "given a selector such as #foo:bar:, return a string that could
+ serve as a methods specification source code.
+ To be used for code generators"
+
+ ^ self methodSpecificationForSelector:aSelector
+ argNames:#('arg1' 'arg2' 'arg3' 'arg4' 'arg5' 'arg6'
+ 'arg7' 'arg8' 'arg9' 'arg10' 'arg11' 'arg12'
+ 'arg13' 'arg14' 'arg15')
+ "
+ Parser methodSpecificationForSelector:#foo:bar:
+ Parser methodSpecificationForSelector:#+
+ Parser methodSpecificationForSelector:#negated
+ "
+!
+
+methodSpecificationForSelector:aSelector argNames:argNames
+ "given a selector such as #foo:bar:, return a string that could
+ serve as a methods specification source code.
+ To be used for code generators"
+
+ |s nargs parts|
+
+ s := WriteStream on:String new.
+ nargs := aSelector nArgsIfSelector.
+ nargs == 0 ifTrue:[
+ s nextPutAll:aSelector
+ ] ifFalse:[
+ parts := aSelector partsIfSelector.
+ 1 to:nargs do:[:i |
+ s nextPutAll:(parts at:i); space;
+ nextPutAll:(argNames at:i); space.
+ ]
+ ].
+ ^ s contents
+
+ "
+ Parser methodSpecificationForSelector:#foo:bar: argNames:#('one' 'two' 'three')
+ Parser methodSpecificationForSelector:#+ argNames:#('one')
+ Parser methodSpecificationForSelector:#negated
+ "
+! !
+
!Parser class methodsFor:'controlling compilation'!
compileLazy:aBoolean
@@ -1099,15 +1243,15 @@
try := MessageNode receiver:receiver selector:sel args:args.
(try isMemberOf:String) ifTrue:[
self parseError:try position:pos1 to:pos2.
- receiver := MessageNode receiver:receiver selector:sel args:args fold:false
+ receiver := MessageNode receiver:receiver selector:sel args:args fold:false.
+ note := receiver plausibilityCheck.
+ note notNil ifTrue:[
+ self warning:note position:pos1 to:pos2
+ ].
+ receiver lineNumber:lno
] ifFalse:[
receiver := try
].
- note := receiver plausibilityCheck.
- note notNil ifTrue:[
- self warning:note position:pos1 to:pos2
- ].
- receiver lineNumber:lno
].
^ receiver
!
@@ -1169,15 +1313,15 @@
try := BinaryNode receiver:receiver selector:sel arg:arg.
(try isMemberOf:String) ifTrue:[
self parseError:try position:pos to:tokenPosition.
- receiver := BinaryNode receiver:receiver selector:sel arg:arg fold:false
+ receiver := BinaryNode receiver:receiver selector:sel arg:arg fold:false.
+ note := receiver plausibilityCheck.
+ note notNil ifTrue:[
+ self warning:note position:pos to:tokenPosition
+ ].
+ receiver lineNumber:lno
] ifFalse:[
receiver := try
].
- note := receiver plausibilityCheck.
- note notNil ifTrue:[
- self warning:note position:pos to:tokenPosition
- ].
- receiver lineNumber:lno
].
^ receiver
!
@@ -1196,11 +1340,11 @@
try := UnaryNode receiver:receiver selector:sel.
(try isMemberOf:String) ifTrue:[
self warning:try position:pos to:pos2.
- receiver := UnaryNode receiver:receiver selector:sel fold:false
+ receiver := UnaryNode receiver:receiver selector:sel fold:false.
+ receiver lineNumber:tokenLineNr.
] ifFalse:[
receiver := try
].
- receiver lineNumber:tokenLineNr.
self nextToken.
].
^ receiver
@@ -1728,7 +1872,7 @@
|arr elem pos1|
pos1 := tokenPosition.
- arr := OrderedCollection new:200.
+ arr := OrderedCollection new:20.
[tokenType ~~ $) ] whileTrue:[
elem := self arrayConstant.
(elem == #Error) ifTrue:[
@@ -1750,7 +1894,7 @@
|arr elem pos1 pos2|
pos1 := tokenPosition.
- arr := OrderedCollection new.
+ arr := OrderedCollection new:50.
[tokenType ~~ $] ] whileTrue:[
pos2 := tokenPosition.
elem := self arrayConstant.
@@ -1969,7 +2113,34 @@
dists := dists reverse.
names := names reverse.
n := names size min:10.
- ^ names copyTo:n
+ names := names copyTo:n.
+
+ "if it starts with a lower case character, add all local & instvar names"
+ (aString at:1) isLowercase ifTrue:[
+ methodVarNames size > 0 ifTrue:[
+ names add:'---- method locals ----'.
+ methodVarNames do:[:methodVarName |
+ names add:methodVarName.
+ ].
+ ].
+
+
+ methodArgs notNil ifTrue:[
+ names add:'---- method arguments ----'.
+ methodArgNames do:[:methodArgName |
+ names add:methodArgName.
+ ]
+ ].
+
+ names add:'---- instance variables ----'.
+ PrevInstVarNames do:[:instVarName |
+ (names includes:instVarName) ifFalse:[
+ names add:instVarName.
+ ]
+ ]
+ ].
+
+ ^ names
].
^ nil
!
--- a/PrimNd.st Wed Mar 30 12:10:24 1994 +0200
+++ b/PrimNd.st Thu Jun 02 22:26:28 1994 +0200
@@ -18,21 +18,46 @@
!
PrimitiveNode comment:'
-
COPYRIGHT (c) 1990 by Claus Gittinger
All Rights Reserved
+'!
-$Header: /cvs/stx/stx/libcomp/Attic/PrimNd.st,v 1.3 1993-10-13 02:41:39 claus Exp $
+!PrimitiveNode class methodsFor:'documentation'!
+
+copyright
+"
+ COPYRIGHT (c) 1990 by Claus Gittinger
+ All Rights Reserved
-Primitives are currently not supported by the compiler - if you
-want a primitive, you must use the stc-compiler and link a new smalltalk.
+ 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.
+"
+!
-In the future, methods with primitives will be passed to stc and the resulting
-binary be loaded into the image (also a limited set of numeric primitives
-could be implemented for more ST-80 compatibility - if thats really needed).
+version
+"
+$Header: /cvs/stx/stx/libcomp/Attic/PrimNd.st,v 1.4 1994-06-02 20:26:11 claus Exp $
+"
+!
+
+documentation
+"
+ node for parse-trees, representing primitive code
-written 90 by claus
-'!
+ Primitives are currently not supported by the compiler
+ - if you want a primitive, you must use the stc-compiler and
+ link a new smalltalk.
+
+ In the future, methods with primitives will be passed to stc and
+ the resulting binary be loaded into the image (also a limited set
+ of numeric primitives could be implemented for more ST-80
+ compatibility - if there is a need).
+"
+! !
!PrimitiveNode class methodsFor:'instance creation'!
--- a/PrimaryNd.st Wed Mar 30 12:10:24 1994 +0200
+++ b/PrimaryNd.st Thu Jun 02 22:26:28 1994 +0200
@@ -18,13 +18,37 @@
!
PrimaryNode comment:'
-
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
+'!
-$Header: /cvs/stx/stx/libcomp/Attic/PrimaryNd.st,v 1.6 1994-03-30 10:09:38 claus Exp $
-written 88 by claus
-'!
+!PrimaryNode class methodsFor:'documentation'!
+
+copyright
+"
+ COPYRIGHT (c) 1989 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/libcomp/Attic/PrimaryNd.st,v 1.7 1994-06-02 20:26:13 claus Exp $
+"
+!
+
+documentation
+"
+ node for parse-trees, representing primaries (variables & literals)
+"
+! !
!PrimaryNode methodsFor:'accessing'!
--- a/PrimaryNode.st Wed Mar 30 12:10:24 1994 +0200
+++ b/PrimaryNode.st Thu Jun 02 22:26:28 1994 +0200
@@ -18,13 +18,37 @@
!
PrimaryNode comment:'
-
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
+'!
-$Header: /cvs/stx/stx/libcomp/PrimaryNode.st,v 1.6 1994-03-30 10:09:38 claus Exp $
-written 88 by claus
-'!
+!PrimaryNode class methodsFor:'documentation'!
+
+copyright
+"
+ COPYRIGHT (c) 1989 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/libcomp/PrimaryNode.st,v 1.7 1994-06-02 20:26:13 claus Exp $
+"
+!
+
+documentation
+"
+ node for parse-trees, representing primaries (variables & literals)
+"
+! !
!PrimaryNode methodsFor:'accessing'!
--- a/PrimitiveNode.st Wed Mar 30 12:10:24 1994 +0200
+++ b/PrimitiveNode.st Thu Jun 02 22:26:28 1994 +0200
@@ -18,21 +18,46 @@
!
PrimitiveNode comment:'
-
COPYRIGHT (c) 1990 by Claus Gittinger
All Rights Reserved
+'!
-$Header: /cvs/stx/stx/libcomp/PrimitiveNode.st,v 1.3 1993-10-13 02:41:39 claus Exp $
+!PrimitiveNode class methodsFor:'documentation'!
+
+copyright
+"
+ COPYRIGHT (c) 1990 by Claus Gittinger
+ All Rights Reserved
-Primitives are currently not supported by the compiler - if you
-want a primitive, you must use the stc-compiler and link a new smalltalk.
+ 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.
+"
+!
-In the future, methods with primitives will be passed to stc and the resulting
-binary be loaded into the image (also a limited set of numeric primitives
-could be implemented for more ST-80 compatibility - if thats really needed).
+version
+"
+$Header: /cvs/stx/stx/libcomp/PrimitiveNode.st,v 1.4 1994-06-02 20:26:11 claus Exp $
+"
+!
+
+documentation
+"
+ node for parse-trees, representing primitive code
-written 90 by claus
-'!
+ Primitives are currently not supported by the compiler
+ - if you want a primitive, you must use the stc-compiler and
+ link a new smalltalk.
+
+ In the future, methods with primitives will be passed to stc and
+ the resulting binary be loaded into the image (also a limited set
+ of numeric primitives could be implemented for more ST-80
+ compatibility - if there is a need).
+"
+! !
!PrimitiveNode class methodsFor:'instance creation'!
--- a/RetNode.st Wed Mar 30 12:10:24 1994 +0200
+++ b/RetNode.st Thu Jun 02 22:26:28 1994 +0200
@@ -20,9 +20,35 @@
ReturnNode comment:'
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
+'!
-$Header: /cvs/stx/stx/libcomp/Attic/RetNode.st,v 1.4 1994-01-16 03:51:44 claus Exp $
-'!
+!ReturnNode class methodsFor:'documentation'!
+
+copyright
+"
+ COPYRIGHT (c) 1989 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/libcomp/Attic/RetNode.st,v 1.5 1994-06-02 20:26:14 claus Exp $
+"
+!
+
+documentation
+"
+ node for parse-trees, representing return expressions
+"
+! !
!ReturnNode methodsFor:'accessing'!
--- a/ReturnNode.st Wed Mar 30 12:10:24 1994 +0200
+++ b/ReturnNode.st Thu Jun 02 22:26:28 1994 +0200
@@ -20,9 +20,35 @@
ReturnNode comment:'
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
+'!
-$Header: /cvs/stx/stx/libcomp/ReturnNode.st,v 1.4 1994-01-16 03:51:44 claus Exp $
-'!
+!ReturnNode class methodsFor:'documentation'!
+
+copyright
+"
+ COPYRIGHT (c) 1989 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/libcomp/ReturnNode.st,v 1.5 1994-06-02 20:26:14 claus Exp $
+"
+!
+
+documentation
+"
+ node for parse-trees, representing return expressions
+"
+! !
!ReturnNode methodsFor:'accessing'!
--- a/Scanner.st Wed Mar 30 12:10:24 1994 +0200
+++ b/Scanner.st Thu Jun 02 22:26:28 1994 +0200
@@ -18,20 +18,46 @@
requestor exitBlock
errorFlag
ignoreErrors ignoreWarnings
- saveComments currentComments'
+ saveComments currentComments
+ warnSTXSpecialComment
+ outStream outCol'
classVariableNames:'typeArray ActionArray'
poolDictionaries:''
category:'System-Compiler'
!
Scanner comment:'
-
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
+'!
-Scanner reads from a stream and returns individual smalltalk tokens
-$Header: /cvs/stx/stx/libcomp/Scanner.st,v 1.7 1994-03-30 10:07:33 claus Exp $
-'!
+!Scanner class methodsFor:'documentation'!
+
+copyright
+"
+ COPYRIGHT (c) 1989 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/libcomp/Scanner.st,v 1.8 1994-06-02 20:26:16 claus Exp $
+"
+!
+
+documentation
+"
+ Scanner reads from a stream and returns individual smalltalk tokens
+"
+! !
!Scanner class methodsFor:'instance creation'!
@@ -56,6 +82,7 @@
saveComments := false.
ignoreErrors := false.
ignoreWarnings := false.
+ warnSTXSpecialComment := true.
ActionArray isNil ifTrue:[
ActionArray := Array new:256.
@@ -105,6 +132,7 @@
saveComments := false.
ignoreErrors := false.
ignoreWarnings := false.
+ warnSTXSpecialComment := true
!
notifying:anObject
@@ -132,6 +160,20 @@
(tokenType == #EOF) ifFalse:[
source position:tokenPosition
]
+!
+
+beginComment
+ ^ self
+!
+
+endComment:comment
+ saveComments ifTrue:[
+ currentComments isNil ifTrue:[
+ currentComments := OrderedCollection with:comment
+ ] ifFalse:[
+ currentComments add:comment
+ ]
+ ].
! !
!Scanner methodsFor:'error handling'!
@@ -261,6 +303,12 @@
comment := ''.
+ self beginComment.
+ outStream notNil ifTrue:[
+ outStream nextPut:Character doubleQuote.
+ outCol := outCol + 1
+ ].
+
startPos := source position.
source next.
thisChar := source peek.
@@ -277,12 +325,25 @@
saveComments ifTrue:[
comment := comment copyWith:thisChar
].
+ outStream notNil ifTrue:[
+ outStream nextPut:thisChar.
+ outCol := outCol + 1
+ ].
thisChar := source nextPeek.
].
tokenLineNr := tokenLineNr + 1.
- self warning:'end-of-line comments are a nonstandard feature of ST/X'
- position:startPos
- to:(source position)
+ warnSTXSpecialComment ifTrue:[
+ self warning:'end-of-line comments are a nonstandard feature of ST/X'
+ position:startPos to:(source position).
+ "
+ only warn once
+ "
+ warnSTXSpecialComment := false
+ ].
+ outStream notNil ifTrue:[
+ outStream cr.
+ outCol := 1
+ ].
] ifFalse:[
[thisChar notNil and:[thisChar ~~ (Character doubleQuote)]] whileTrue:[
thisChar == (Character cr) ifTrue:[
@@ -291,11 +352,20 @@
saveComments ifTrue:[
comment := comment copyWith:thisChar
].
+ outStream notNil ifTrue:[
+ outStream nextPut:thisChar.
+ outCol := outCol + 1
+ ].
thisChar := source nextPeek
].
thisChar isNil ifTrue:[
self warning:'unclosed comment' position:startPos to:(source position)
- ].
+ ] ifFalse:[
+ outStream notNil ifTrue:[
+ outStream nextPut:(Character doubleQuote).
+ outCol := outCol + 1
+ ].
+ ]
].
saveComments ifTrue:[
@@ -306,8 +376,10 @@
]
].
- "skip final dQuote"
+ "skip final dQuote or cr"
source next.
+
+ self endComment:comment.
!
nextToken
@@ -321,10 +393,22 @@
] ifFalse:[
skipping := true.
[skipping] whileTrue:[
- thisChar := source skipSeparatorsExceptCR.
+ outStream notNil ifTrue:[
+ [(thisChar := source peek) == Character space] whileTrue:[
+ source next.
+ outStream space.
+ outCol := outCol + 1.
+ ]
+ ] ifFalse:[
+ thisChar := source skipSeparatorsExceptCR.
+ ].
thisChar == (Character cr) ifTrue:[
tokenLineNr := tokenLineNr + 1.
- source next
+ source next.
+ outStream notNil ifTrue:[
+ outStream cr.
+ outCol := 1
+ ]
] ifFalse:[
thisChar == (Character doubleQuote) ifTrue:[
"start of a comment"
@@ -389,21 +473,23 @@
]
].
string := firstChar asString.
- ((TypeArray at:(secondChar asciiValue)) == #special) ifTrue:[
- (secondChar == $-) ifTrue:[
- "special- look if minus belongs to number following"
- p := source position.
+ secondChar notNil ifTrue:[
+ ((TypeArray at:(secondChar asciiValue)) == #special) ifTrue:[
+ (secondChar == $-) ifTrue:[
+ "special- look if minus belongs to number following"
+ p := source position.
+ source next.
+ thirdChar := source peek.
+ source position:p.
+ thirdChar isDigit ifTrue:[
+ tokenName := string.
+ tokenType := #BinaryOperator.
+ ^ tokenType
+ ]
+ ].
source next.
- thirdChar := source peek.
- source position:p.
- thirdChar isDigit ifTrue:[
- tokenName := string.
- tokenType := #BinaryOperator.
- ^ tokenType
- ]
+ string := string copyWith:secondChar
].
- source next.
- string := string copyWith:secondChar
].
tokenName := string.
tokenType := #BinaryOperator.
@@ -534,6 +620,7 @@
].
peekChar := $_
].
+ tokenName := string.
firstChar := string at:1.
(firstChar == $s) ifTrue:[
(string = 'self') ifTrue:[tokenType := #Self. ^self].
@@ -549,7 +636,6 @@
(firstChar == $f) ifTrue:[
(string = 'false') ifTrue:[tokenType := #False. ^self]
].
- tokenName := string.
tokenType := #Identifier.
^ tokenType
!
--- a/SelfNode.st Wed Mar 30 12:10:24 1994 +0200
+++ b/SelfNode.st Thu Jun 02 22:26:28 1994 +0200
@@ -18,13 +18,37 @@
!
SelfNode comment:'
-
COPYRIGHT (c) 1994 by Claus Gittinger
All Rights Reserved
+'!
-$Header: /cvs/stx/stx/libcomp/SelfNode.st,v 1.1 1994-01-17 09:14:03 claus Exp $
-written 94 by claus
-'!
+!SelfNode class methodsFor:'documentation'!
+
+copyright
+"
+ COPYRIGHT (c) 1994 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/libcomp/SelfNode.st,v 1.2 1994-06-02 20:26:18 claus Exp $
+"
+!
+
+documentation
+"
+ node for parse-trees, representing self
+"
+! !
!SelfNode class methodsFor:'instance creation'!
--- a/StatNode.st Wed Mar 30 12:10:24 1994 +0200
+++ b/StatNode.st Thu Jun 02 22:26:28 1994 +0200
@@ -18,12 +18,37 @@
!
StatementNode comment:'
-
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
+'!
-$Header: /cvs/stx/stx/libcomp/Attic/StatNode.st,v 1.3 1993-10-13 02:41:48 claus Exp $
-'!
+!StatementNode class methodsFor:'documentation'!
+
+copyright
+"
+ COPYRIGHT (c) 1989 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/libcomp/Attic/StatNode.st,v 1.4 1994-06-02 20:26:19 claus Exp $
+"
+!
+
+documentation
+"
+ node for parse-trees, representing statements
+"
+! !
!StatementNode class methodsFor:'instance creation'!
--- a/StatementNode.st Wed Mar 30 12:10:24 1994 +0200
+++ b/StatementNode.st Thu Jun 02 22:26:28 1994 +0200
@@ -18,12 +18,37 @@
!
StatementNode comment:'
-
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
+'!
-$Header: /cvs/stx/stx/libcomp/StatementNode.st,v 1.3 1993-10-13 02:41:48 claus Exp $
-'!
+!StatementNode class methodsFor:'documentation'!
+
+copyright
+"
+ COPYRIGHT (c) 1989 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/libcomp/StatementNode.st,v 1.4 1994-06-02 20:26:19 claus Exp $
+"
+!
+
+documentation
+"
+ node for parse-trees, representing statements
+"
+! !
!StatementNode class methodsFor:'instance creation'!
--- a/SuperNode.st Wed Mar 30 12:10:24 1994 +0200
+++ b/SuperNode.st Thu Jun 02 22:26:28 1994 +0200
@@ -18,13 +18,37 @@
!
SuperNode comment:'
-
COPYRIGHT (c) 1994 by Claus Gittinger
All Rights Reserved
+'!
-$Header: /cvs/stx/stx/libcomp/SuperNode.st,v 1.1 1994-01-17 09:14:05 claus Exp $
-written 94 by claus
-'!
+!SuperNode class methodsFor:'documentation'!
+
+copyright
+"
+ COPYRIGHT (c) 1994 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/libcomp/SuperNode.st,v 1.2 1994-06-02 20:26:22 claus Exp $
+"
+!
+
+documentation
+"
+ node for parse-trees, representing super
+"
+! !
!SuperNode class methodsFor:'instance creation'!
--- a/UnaryNd.st Wed Mar 30 12:10:24 1994 +0200
+++ b/UnaryNd.st Thu Jun 02 22:26:28 1994 +0200
@@ -18,12 +18,37 @@
!
UnaryNode comment:'
-
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
+'!
-$Header: /cvs/stx/stx/libcomp/Attic/UnaryNd.st,v 1.7 1994-03-30 10:07:15 claus Exp $
-'!
+!UnaryNode class methodsFor:'documentation'!
+
+copyright
+"
+ COPYRIGHT (c) 1989 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/libcomp/Attic/UnaryNd.st,v 1.8 1994-06-02 20:26:23 claus Exp $
+"
+!
+
+documentation
+"
+ node for parse-trees, representing unary messages
+"
+! !
!UnaryNode class methodsFor:'instance creation'!
--- a/UnaryNode.st Wed Mar 30 12:10:24 1994 +0200
+++ b/UnaryNode.st Thu Jun 02 22:26:28 1994 +0200
@@ -18,12 +18,37 @@
!
UnaryNode comment:'
-
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
+'!
-$Header: /cvs/stx/stx/libcomp/UnaryNode.st,v 1.7 1994-03-30 10:07:15 claus Exp $
-'!
+!UnaryNode class methodsFor:'documentation'!
+
+copyright
+"
+ COPYRIGHT (c) 1989 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/libcomp/UnaryNode.st,v 1.8 1994-06-02 20:26:23 claus Exp $
+"
+!
+
+documentation
+"
+ node for parse-trees, representing unary messages
+"
+! !
!UnaryNode class methodsFor:'instance creation'!
--- a/UndefVar.st Wed Mar 30 12:10:24 1994 +0200
+++ b/UndefVar.st Thu Jun 02 22:26:28 1994 +0200
@@ -18,18 +18,43 @@
!
UndefinedVariable comment:'
+COPYRIGHT (c) 1993 by Claus Gittinger
+ All Rights Reserved
+'!
-COPYRIGHT (c) 1993 by Claus Gittinger
+!UndefinedVariable class methodsFor:'documentation'!
+
+copyright
+"
+ COPYRIGHT (c) 1993 by Claus Gittinger
All Rights Reserved
-This class exists solely for the error message when accessing undefined
-variables - instead of returning nil, the compiler returns an instance
-of this class, which will not understand ANY message.
-The error message will then be "UndefinedVariable ..." instead of
-"UndefineObject ..."
+ 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.
+"
+!
-$Header: /cvs/stx/stx/libcomp/Attic/UndefVar.st,v 1.2 1993-10-13 00:26:22 claus Exp $
-'!
+version
+"
+$Header: /cvs/stx/stx/libcomp/Attic/UndefVar.st,v 1.3 1994-06-02 20:26:25 claus Exp $
+"
+!
+
+documentation
+"
+ node for parse-trees, representing undefined variables
+
+ This class exists solely for the error message when accessing undefined
+ variables - instead of returning nil, the compiler returns an instance
+ of this class, which will not understand ANY message.
+ The error message will then be 'UndefinedVariable ...'
+ instead of 'UndefineObject ...', which is somewhat more informative.
+"
+! !
!UndefinedVariable class methodsFor:'instance creation'!
--- a/UndefinedVariable.st Wed Mar 30 12:10:24 1994 +0200
+++ b/UndefinedVariable.st Thu Jun 02 22:26:28 1994 +0200
@@ -18,18 +18,43 @@
!
UndefinedVariable comment:'
+COPYRIGHT (c) 1993 by Claus Gittinger
+ All Rights Reserved
+'!
-COPYRIGHT (c) 1993 by Claus Gittinger
+!UndefinedVariable class methodsFor:'documentation'!
+
+copyright
+"
+ COPYRIGHT (c) 1993 by Claus Gittinger
All Rights Reserved
-This class exists solely for the error message when accessing undefined
-variables - instead of returning nil, the compiler returns an instance
-of this class, which will not understand ANY message.
-The error message will then be "UndefinedVariable ..." instead of
-"UndefineObject ..."
+ 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.
+"
+!
-$Header: /cvs/stx/stx/libcomp/UndefinedVariable.st,v 1.2 1993-10-13 00:26:22 claus Exp $
-'!
+version
+"
+$Header: /cvs/stx/stx/libcomp/UndefinedVariable.st,v 1.3 1994-06-02 20:26:25 claus Exp $
+"
+!
+
+documentation
+"
+ node for parse-trees, representing undefined variables
+
+ This class exists solely for the error message when accessing undefined
+ variables - instead of returning nil, the compiler returns an instance
+ of this class, which will not understand ANY message.
+ The error message will then be 'UndefinedVariable ...'
+ instead of 'UndefineObject ...', which is somewhat more informative.
+"
+! !
!UndefinedVariable class methodsFor:'instance creation'!
--- a/VarNode.st Wed Mar 30 12:10:24 1994 +0200
+++ b/VarNode.st Thu Jun 02 22:26:28 1994 +0200
@@ -18,12 +18,37 @@
!
VariableNode comment:'
-
COPYRIGHT (c) 1994 by Claus Gittinger
All Rights Reserved
+'!
-$Header: /cvs/stx/stx/libcomp/Attic/VarNode.st,v 1.1 1994-01-17 09:14:07 claus Exp $
-'!
+!VariableNode class methodsFor:'documentation'!
+
+copyright
+"
+ COPYRIGHT (c) 1994 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/libcomp/Attic/VarNode.st,v 1.2 1994-06-02 20:26:27 claus Exp $
+"
+!
+
+documentation
+"
+ node for parse-trees, representing variables
+"
+! !
!VariableNode class methodsFor:'instance creation'!
--- a/Variable.st Wed Mar 30 12:10:24 1994 +0200
+++ b/Variable.st Thu Jun 02 22:26:28 1994 +0200
@@ -18,12 +18,37 @@
!
Variable comment:'
-
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
+'!
-$Header: /cvs/stx/stx/libcomp/Variable.st,v 1.4 1994-01-09 21:30:29 claus Exp $
-'!
+!Variable class methodsFor:'documentation'!
+
+copyright
+"
+ COPYRIGHT (c) 1989 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/libcomp/Variable.st,v 1.5 1994-06-02 20:26:28 claus Exp $
+"
+!
+
+documentation
+"
+ node for parse-trees, representing variables
+"
+! !
!Variable class methodsFor:'instance creation'!
--- a/VariableNode.st Wed Mar 30 12:10:24 1994 +0200
+++ b/VariableNode.st Thu Jun 02 22:26:28 1994 +0200
@@ -18,12 +18,37 @@
!
VariableNode comment:'
-
COPYRIGHT (c) 1994 by Claus Gittinger
All Rights Reserved
+'!
-$Header: /cvs/stx/stx/libcomp/VariableNode.st,v 1.1 1994-01-17 09:14:07 claus Exp $
-'!
+!VariableNode class methodsFor:'documentation'!
+
+copyright
+"
+ COPYRIGHT (c) 1994 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/libcomp/VariableNode.st,v 1.2 1994-06-02 20:26:27 claus Exp $
+"
+!
+
+documentation
+"
+ node for parse-trees, representing variables
+"
+! !
!VariableNode class methodsFor:'instance creation'!