--- a/AssignNd.st Wed Oct 13 01:25:45 1993 +0100
+++ b/AssignNd.st Wed Oct 13 01:26:26 1993 +0100
@@ -22,7 +22,7 @@
COPYRIGHT (c) 1989-93 by Claus Gittinger
All Rights Reserved
-%W% %E%
+$Header: /cvs/stx/stx/libcomp/Attic/AssignNd.st,v 1.2 1993-10-13 00:25:24 claus Exp $
'!
!AssignmentNode class methodsFor:'instance creation'!
--- a/AssignmentNode.st Wed Oct 13 01:25:45 1993 +0100
+++ b/AssignmentNode.st Wed Oct 13 01:26:26 1993 +0100
@@ -22,7 +22,7 @@
COPYRIGHT (c) 1989-93 by Claus Gittinger
All Rights Reserved
-%W% %E%
+$Header: /cvs/stx/stx/libcomp/AssignmentNode.st,v 1.2 1993-10-13 00:25:24 claus Exp $
'!
!AssignmentNode class methodsFor:'instance creation'!
--- a/BCompiler.st Wed Oct 13 01:25:45 1993 +0100
+++ b/BCompiler.st Wed Oct 13 01:26:26 1993 +0100
@@ -26,7 +26,14 @@
COPYRIGHT (c) 1989-93 by Claus Gittinger
All Rights Reserved
-This class defines how compilation into ByteCodes is done.
+$Header: /cvs/stx/stx/libcomp/Attic/BCompiler.st,v 1.3 1993-10-13 00:25:27 claus Exp $
+'!
+
+!ByteCodeCompiler class methodsFor:'documentation'!
+
+documentation
+"
+This class performs compilation into ByteCodes.
First, parsing is done using superclass methods,
then the parse-tree is converted into an array of symbolic codes
and a relocation table;
@@ -44,9 +51,8 @@
extra <Symbol> return value of byteCodeFor:
maxStackDepth <SmallInteger> stack need of method
relocList <Array> used temporary for relocation
-
-%W% %E%
-'!
+"
+! !
!ByteCodeCompiler class methodsFor:'compiling methods'!
@@ -166,7 +172,7 @@
^ nil
].
- "let it produce symbolic code first"
+ "produce symbolic code first"
symbolicCodeArray := compiler genSymbolicCode.
(symbolicCodeArray == #Error) ifTrue:[
@@ -249,7 +255,7 @@
!
code
- "return the literal array - only valid after code-generation"
+ "return the bytecode array - only valid after code-generation"
^ code
!
@@ -286,9 +292,14 @@
"this was added to allow emulation of (some) ST-80
primitives (to fileIn Remote-Package)"
- (primNr == 75) ifTrue:[ ^ (Object compiledMethodAt:#identityHash) code ].
- (primNr == 110) ifTrue:[ ^ (Object compiledMethodAt:#==) code ].
- (primNr == 111) ifTrue:[ ^ (Object compiledMethodAt:#class) code ].
+ |cls sel|
+
+ (primNr == 75) ifTrue:[ cls := Object. sel := #identityHash ].
+ (primNr == 110) ifTrue:[ cls := Object. sel := #== ].
+ (primNr == 111) ifTrue:[ cls := Object. sel := #class ].
+ cls notNil ifTrue:[
+ ^ (cls compiledMethodAt:sel) code
+ ].
^ nil
!
@@ -313,7 +324,7 @@
stackDepth := 0.
maxStackDepth := 0.
- code := ByteArray new:codeSize.
+ code := ByteArray uninitializedNew:codeSize.
relocInfo := Array new:(codeSize + 1).
symIndex := 1.
codeIndex := 1.
@@ -386,6 +397,7 @@
] ifFalse:[
(extra == #absoffset) ifTrue:[
relocInfo at:symIndex put:codeIndex.
+ self addReloc:symIndex.
addr := symbolicCodeArray at:symIndex.
symIndex := symIndex + 1.
self appendByte:(addr bitAnd:16rFF).
@@ -393,6 +405,7 @@
] ifFalse:[
(extra == #absoffsetNvarNarg) ifTrue:[
relocInfo at:symIndex put:codeIndex.
+ self addReloc:symIndex.
addr := symbolicCodeArray at:symIndex.
symIndex := symIndex + 1.
self appendByte:(addr bitAnd:16rFF).
@@ -452,7 +465,10 @@
done := self relocateWith:symbolicCodeArray relocInfo:relocInfo.
"if returned with false, a relative jump was made into
an absolute jump - need to start over with one more byte space"
- codeSize := codeSize + 1.
+ done ifFalse:[
+ relocList := nil.
+ codeSize := codeSize + 1.
+ ]
].
].
"code printNewline."
@@ -460,18 +476,20 @@
!
absJumpFromJump:code
+ "given a jump-symbolic code, return corresponding absolute jump"
+
JumpToAbsJump isNil ifTrue:[
- JumpToAbsJump := IdentityDictionary new.
- JumpToAbsJump at:#jump put:#jumpabs.
- JumpToAbsJump at:#trueJump put:#trueJumpabs.
- JumpToAbsJump at:#falseJump put:#falseJumpabs.
- JumpToAbsJump at:#nilJump put:#nilJumpabs.
- JumpToAbsJump at:#notNilJump put:#notNilJumpabs.
- JumpToAbsJump at:#eqJump put:#eqJumpabs.
- JumpToAbsJump at:#notEqJump put:#notEqJumpabs.
- JumpToAbsJump at:#zeroJump put:#zeroJumpabs.
- JumpToAbsJump at:#notZeroJump put:#notZeroJumpabs.
- JumpToAbsJump at:#makeBlock put:#makeBlockabs.
+ JumpToAbsJump := IdentityDictionary new.
+ JumpToAbsJump at:#jump put:#jumpabs.
+ JumpToAbsJump at:#trueJump put:#trueJumpabs.
+ JumpToAbsJump at:#falseJump put:#falseJumpabs.
+ JumpToAbsJump at:#nilJump put:#nilJumpabs.
+ JumpToAbsJump at:#notNilJump put:#notNilJumpabs.
+ JumpToAbsJump at:#eqJump put:#eqJumpabs.
+ JumpToAbsJump at:#notEqJump put:#notEqJumpabs.
+ JumpToAbsJump at:#zeroJump put:#zeroJumpabs.
+ JumpToAbsJump at:#notZeroJump put:#notZeroJumpabs.
+ JumpToAbsJump at:#makeBlock put:#makeBlockabs.
].
^ JumpToAbsJump at:code
!
@@ -480,63 +498,102 @@
"helper for genByteCodeFrom - relocate code using relocInfo.
if relocation fails badly (due to long relative jumps) patch
symbolicCode to use absolute jumps instead and return false
- (genByteCodeFrom will then try again). Otherwise return true."
+ (genByteCodeFrom will then try again). Otherwise return true.
+ Also, on the fly, jumps to jumps and jumps to return are handled."
|delta "<SmallInteger>"
codePos "<SmallInteger>"
opCodePos "<SmallInteger>"
codeOffset "<SmallInteger>"
symOffset opcode dstOpcode jumpTarget
- jumpCode|
+ jumpCode deleteSet|
+ deleteSet := OrderedCollection new.
relocList do:[:sIndex |
"have to relocate symCode at sIndex ..."
- symOffset := symbolicCodeArray at:sIndex.
- codePos := relocInfo at:sIndex.
- codeOffset := relocInfo at:symOffset.
+ symOffset := symbolicCodeArray at:sIndex. "the target in the symbolic code"
+ codePos := relocInfo at:sIndex. "position of the offet in byte code"
+ codeOffset := relocInfo at:symOffset. "position of the target in byte code"
delta := codeOffset - codePos - 1.
opCodePos := codePos - 1.
opcode := code at:opCodePos.
- (opcode between:190 and:199) ifTrue:[
- "an absolute jump/makeBlock"
+ (opcode between:190 and:199) ifTrue:[
+ "an absolute jump/makeBlock"
- code at:codePos put:(codeOffset bitAnd:16rFF).
- code at:(codePos + 1) put:(codeOffset bitShift:-8)
- ] ifFalse:[
- "get jump-code from long and vlong codes"
- (opcode between:50 and:59) ifFalse:[
- (opcode between:60 and:69) ifTrue:[
- opcode := opcode - 10
- ] ifFalse:[
- (opcode between:70 and:79) ifTrue:[
- opcode := opcode - 20
- ] ifFalse:[
+ code at:codePos put:(codeOffset bitAnd:16rFF).
+ code at:(codePos + 1) put:(codeOffset bitShift:-8)
+ ] ifFalse:[
+ "get jump-code from long and vlong codes"
+ (opcode between:50 and:59) ifFalse:[
+ (opcode between:60 and:69) ifTrue:[
+ opcode := opcode - 10
+ ] ifFalse:[
+ (opcode between:70 and:79) ifTrue:[
+ opcode := opcode - 20
+ ] ifFalse:[
self error:'invalid code to relocate'
- ]
+ ]
].
- ].
+ ].
"optimize jump to return and jump to jump"
(opcode == 54) ifTrue:[
"a jump"
dstOpcode := symbolicCodeArray at:symOffset.
- (#(retSelf retTop retNil retTrue retFalse ret0) includes:dstOpcode) ifTrue:[
+
+ (#(retSelf retTop retNil retTrue retFalse ret0 blockRetTop) includes:dstOpcode) ifTrue:[
"a jump to a return - put in the return instead jump"
+
+ symbolicCodeArray at:(sIndex - 1) put:dstOpcode.
+ symbolicCodeArray at:sIndex put:dstOpcode.
code at:opCodePos put:(self byteCodeFor:dstOpcode).
- delta := 0
+ delta := 0.
+ deleteSet add:sIndex.
+
+"
+'jump to return at: ' print. (sIndex - 1) printNewline.
+"
] ifFalse:[
(dstOpcode == #jump) ifTrue:[
"jump to jump to be done soon"
- jumpTarget := symbolicCodeArray at:(codeOffset + 1)
-"
- .
- 'jump to jump: ' print. dstOpcode printNewline
-"
+ jumpTarget := symbolicCodeArray at:(symOffset + 1).
+"
+'jump to jump at: ' print. (sIndex - 1) print.
+' newTarget:' print. jumpTarget printNewline.
+"
+
+ symbolicCodeArray at:sIndex put:jumpTarget.
+ symOffset := jumpTarget.
+ codeOffset := relocInfo at:symOffset.
+ delta := codeOffset - codePos - 1.
+
+ "continue with new delta"
]
]
].
+ (#(50 51 52 53 56 57 58 59) includes:opcode) ifTrue:[
+ "a conditional jump"
+
+ dstOpcode := symbolicCodeArray at:symOffset.
+ (dstOpcode == #jump) ifTrue:[
+ "conditional jump to unconditional jump"
+ jumpTarget := symbolicCodeArray at:(symOffset + 1).
+"
+'cond jump to jump at: ' print. (sIndex - 1) print.
+' newTarget:' print. jumpTarget printNewline.
+"
+
+ symbolicCodeArray at:sIndex put:jumpTarget.
+ symOffset := jumpTarget.
+ codeOffset := relocInfo at:symOffset.
+ delta := codeOffset - codePos - 1.
+
+ "continue with new delta"
+ ].
+ ].
+
(delta >= 0) ifTrue:[
(delta > 127) ifTrue:[
(opcode between:50 and:59) ifFalse:[
@@ -554,8 +611,12 @@
(delta > 127) ifTrue:[
"change symbolic into a jump absolute and fail"
jumpCode := symbolicCodeArray at:(sIndex - 1).
- symbolicCodeArray at:(sIndex - 1) put:(self absJumpFromJump:jumpCode).
+ symbolicCodeArray at:(sIndex - 1) put:(self absJumpFromJump:jumpCode).
symbolicCodeArray at:sIndex put:symOffset.
+"
+'change short into abs jump' printNewline.
+"
+ deleteSet do:[:d | relocList remove:d].
^ false
].
].
@@ -577,8 +638,12 @@
(delta < -128) ifTrue:[
"change symbolic into a jump absolute and fail"
jumpCode := symbolicCodeArray at:(sIndex - 1).
- symbolicCodeArray at:(sIndex - 1) put:(self absJumpFromJump:jumpCode).
+ symbolicCodeArray at:(sIndex - 1) put:(self absJumpFromJump:jumpCode).
symbolicCodeArray at:sIndex put:symOffset.
+"
+'change short into abs jump' printNewline.
+"
+ deleteSet do:[:d | relocList remove:d].
^ false
]
].
@@ -596,7 +661,7 @@
"add a literal to the literalArray - watch for and eliminate
duplicates. return the index of the literal in the Array"
- |index|
+ |index class|
litArray isNil ifTrue:[
litArray := Array with:anObject.
@@ -604,8 +669,14 @@
].
index := litArray identityIndexOf:anObject.
(index == 0) ifTrue:[
- litArray := litArray copyWith:anObject.
- ^ litArray size
+ class := anObject class.
+ ((class == Float) or:[class == Fraction]) ifTrue:[
+ index := litArray indexOf:anObject.
+ ].
+ (index == 0) ifTrue:[
+ litArray := litArray copyWith:anObject.
+ ^ litArray size
+ ].
].
^ index
!
@@ -733,6 +804,7 @@
(aSymbol == #pushChar) ifTrue:[stackDelta := 1. ^17].
(aSymbol == #push0) ifTrue:[stackDelta := 1. ^120].
(aSymbol == #push1) ifTrue:[stackDelta := 1. ^121].
+ (aSymbol == #push2) ifTrue:[stackDelta := 1. ^139].
(aSymbol == #pushMinus1) ifTrue:[stackDelta := 1. ^122].
(aSymbol == #send0) ifTrue:[lineno := true. extra := #lit. ^21].
@@ -879,7 +951,9 @@
!ByteCodeCompiler class methodsFor:'machine code constants'!
sharedCodeFunctionFor:aSymbol
- "return the address of a shared code-function"
+ "return the address of a shared code-function;
+ the code below looks ugly, but adds some speed to instvar-access
+ methods"
|codeSymbol|
@@ -1189,6 +1263,61 @@
RETURN ( _MKSMALLINT((int)__retInst24) );
%}
].
+ (aSymbol == #retInstVar26) ifTrue:[
+%{
+ extern OBJ __retInst25();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __retInst25;
+#endif
+ RETURN ( _MKSMALLINT((int)__retInst25) );
+%}
+ ].
+ (aSymbol == #retInstVar27) ifTrue:[
+%{
+ extern OBJ __retInst26();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __retInst26;
+#endif
+ RETURN ( _MKSMALLINT((int)__retInst26) );
+%}
+ ].
+ (aSymbol == #retInstVar28) ifTrue:[
+%{
+ extern OBJ __retInst27();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __retInst27;
+#endif
+ RETURN ( _MKSMALLINT((int)__retInst27) );
+%}
+ ].
+ (aSymbol == #retInstVar29) ifTrue:[
+%{
+ extern OBJ __retInst28();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __retInst28;
+#endif
+ RETURN ( _MKSMALLINT((int)__retInst28) );
+%}
+ ].
+ (aSymbol == #retInstVar30) ifTrue:[
+%{
+ extern OBJ __retInst29();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __retInst29;
+#endif
+ RETURN ( _MKSMALLINT((int)__retInst29) );
+%}
+ ].
+ (aSymbol == #retInstVar31) ifTrue:[
+%{
+ extern OBJ __retInst30();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __retInst30;
+#endif
+ RETURN ( _MKSMALLINT((int)__retInst30) );
+%}
+ ].
+
(aSymbol == #storeInstVar1) ifTrue:[
%{
extern OBJ __setInst0();
@@ -1378,6 +1507,114 @@
RETURN ( _MKSMALLINT((int)__setInst19) );
%}
].
+ (aSymbol == #storeInstVar21) ifTrue:[
+%{
+ extern OBJ __setInst20();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __setInst20;
+#endif
+ RETURN ( _MKSMALLINT((int)__setInst20) );
+%}
+ ].
+ (aSymbol == #storeInstVar22) ifTrue:[
+%{
+ extern OBJ __setInst21();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __setInst21;
+#endif
+ RETURN ( _MKSMALLINT((int)__setInst21) );
+%}
+ ].
+ (aSymbol == #storeInstVar23) ifTrue:[
+%{
+ extern OBJ __setInst22();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __setInst22;
+#endif
+ RETURN ( _MKSMALLINT((int)__setInst22) );
+%}
+ ].
+ (aSymbol == #storeInstVar23) ifTrue:[
+%{
+ extern OBJ __setInst22();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __setInst22;
+#endif
+ RETURN ( _MKSMALLINT((int)__setInst22) );
+%}
+ ].
+ (aSymbol == #storeInstVar24) ifTrue:[
+%{
+ extern OBJ __setInst23();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __setInst23;
+#endif
+ RETURN ( _MKSMALLINT((int)__setInst23) );
+%}
+ ].
+ (aSymbol == #storeInstVar25) ifTrue:[
+%{
+ extern OBJ __setInst24();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __setInst24;
+#endif
+ RETURN ( _MKSMALLINT((int)__setInst24) );
+%}
+ ].
+ (aSymbol == #storeInstVar26) ifTrue:[
+%{
+ extern OBJ __setInst25();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __setInst25;
+#endif
+ RETURN ( _MKSMALLINT((int)__setInst25) );
+%}
+ ].
+ (aSymbol == #storeInstVar27) ifTrue:[
+%{
+ extern OBJ __setInst26();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __setInst26;
+#endif
+ RETURN ( _MKSMALLINT((int)__setInst26) );
+%}
+ ].
+ (aSymbol == #storeInstVar28) ifTrue:[
+%{
+ extern OBJ __setInst27();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __setInst27;
+#endif
+ RETURN ( _MKSMALLINT((int)__setInst27) );
+%}
+ ].
+ (aSymbol == #storeInstVar29) ifTrue:[
+%{
+ extern OBJ __setInst28();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __setInst28;
+#endif
+ RETURN ( _MKSMALLINT((int)__setInst28) );
+%}
+ ].
+ (aSymbol == #storeInstVar30) ifTrue:[
+%{
+ extern OBJ __setInst29();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __setInst29;
+#endif
+ RETURN ( _MKSMALLINT((int)__setInst29) );
+%}
+ ].
+ (aSymbol == #storeInstVar31) ifTrue:[
+%{
+ extern OBJ __setInst30();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __setInst30;
+#endif
+ RETURN ( _MKSMALLINT((int)__setInst30) );
+%}
+ ].
^ nil
! !
@@ -1405,9 +1642,9 @@
index := symbolicCodeArray at:3.
((symbolicCodeArray at:4) == #retSelf) ifTrue:[
^ ('storeInstVar' , index printString) asSymbol
- ].
- ^ nil
- ].
+ ].
+ ^ nil
+ ].
('storeInstVar*' match:(symbolicCodeArray at:2)) ifTrue:[
((symbolicCodeArray at:3) == #retSelf) ifTrue:[^ symbolicCodeArray at:2]
].
--- a/BinaryNd.st Wed Oct 13 01:25:45 1993 +0100
+++ b/BinaryNd.st Wed Oct 13 01:26:26 1993 +0100
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1989-93 by Claus Gittinger
All Rights Reserved
-%W% %E%
+$Header: /cvs/stx/stx/libcomp/Attic/BinaryNd.st,v 1.2 1993-10-13 00:25:33 claus Exp $
'!
!BinaryNode methodsFor:'queries'!
--- a/BinaryNode.st Wed Oct 13 01:25:45 1993 +0100
+++ b/BinaryNode.st Wed Oct 13 01:26:26 1993 +0100
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1989-93 by Claus Gittinger
All Rights Reserved
-%W% %E%
+$Header: /cvs/stx/stx/libcomp/BinaryNode.st,v 1.2 1993-10-13 00:25:33 claus Exp $
'!
!BinaryNode methodsFor:'queries'!
--- a/BlockNode.st Wed Oct 13 01:25:45 1993 +0100
+++ b/BlockNode.st Wed Oct 13 01:26:26 1993 +0100
@@ -26,20 +26,22 @@
implement interpreted blocks
-%W% %E%
+$Header: /cvs/stx/stx/libcomp/BlockNode.st,v 1.2 1993-10-13 00:25:35 claus Exp $
'!
!BlockNode class methodsFor:'instance creation'!
-arguments:argList
- ^ (self basicNew) setArguments:argList
+arguments:argList home:h variables:vars
+ ^ (self basicNew) setArguments:argList home:h variables:vars
! !
!BlockNode methodsFor:'private accessing'!
-setArguments:argList
+setArguments:argList home:h variables:vars
needsHome := false.
- blockArgs := argList
+ blockArgs := argList.
+ home := h.
+ blockVars := vars
! !
!BlockNode methodsFor:'accessing'!
@@ -237,6 +239,34 @@
(blockArgs at:3) value:oldValue3.
(blockArgs at:4) value:oldValue4.
^ val
+!
+
+valueWithArguments:argArray
+ |oldValues val|
+
+ (blockArgs size ~~ argArray size) ifTrue:[
+ ^ self argumentCountError:argArray size
+ ].
+ statements isNil ifTrue:[^ nil].
+
+ oldValues := Array new:(argArray size).
+ 1 to:argArray size do:[:i |
+ oldValues at:i put:(blockArgs at:i) value.
+ (blockArgs at:i) value:(argArray at:i).
+ ].
+ exitBlock := [:val |
+ 1 to:argArray size do:[:i |
+ ( blockArgs at:i) value:(oldValues at:i)
+ ].
+ ^ val
+ ].
+
+ val := statements evaluate.
+
+ 1 to:argArray size do:[:i |
+ (blockArgs at:i) value:(oldValues at:i)
+ ].
+ ^ val
! !
!BlockNode methodsFor:'looping'!
@@ -276,7 +306,11 @@
numArgs == 3 ifTrue:[
kludgeBlock := [:a1 :a2 :a3| self value:a1 value:a2 value:a3].
] ifFalse:[
- ^ self error:'only support blocks with up-to 3 args'
+ numArgs == 4 ifTrue:[
+ kludgeBlock := [:a1 :a2 :a3 :a4| self value:a1 value:a2 value:a3 value:a4].
+ ] ifFalse:[
+ ^ self error:'only support blocks with up-to 4 args'
+ ]
]
]
]
--- a/ByteCodeCompiler.st Wed Oct 13 01:25:45 1993 +0100
+++ b/ByteCodeCompiler.st Wed Oct 13 01:26:26 1993 +0100
@@ -26,7 +26,14 @@
COPYRIGHT (c) 1989-93 by Claus Gittinger
All Rights Reserved
-This class defines how compilation into ByteCodes is done.
+$Header: /cvs/stx/stx/libcomp/ByteCodeCompiler.st,v 1.3 1993-10-13 00:25:27 claus Exp $
+'!
+
+!ByteCodeCompiler class methodsFor:'documentation'!
+
+documentation
+"
+This class performs compilation into ByteCodes.
First, parsing is done using superclass methods,
then the parse-tree is converted into an array of symbolic codes
and a relocation table;
@@ -44,9 +51,8 @@
extra <Symbol> return value of byteCodeFor:
maxStackDepth <SmallInteger> stack need of method
relocList <Array> used temporary for relocation
-
-%W% %E%
-'!
+"
+! !
!ByteCodeCompiler class methodsFor:'compiling methods'!
@@ -166,7 +172,7 @@
^ nil
].
- "let it produce symbolic code first"
+ "produce symbolic code first"
symbolicCodeArray := compiler genSymbolicCode.
(symbolicCodeArray == #Error) ifTrue:[
@@ -249,7 +255,7 @@
!
code
- "return the literal array - only valid after code-generation"
+ "return the bytecode array - only valid after code-generation"
^ code
!
@@ -286,9 +292,14 @@
"this was added to allow emulation of (some) ST-80
primitives (to fileIn Remote-Package)"
- (primNr == 75) ifTrue:[ ^ (Object compiledMethodAt:#identityHash) code ].
- (primNr == 110) ifTrue:[ ^ (Object compiledMethodAt:#==) code ].
- (primNr == 111) ifTrue:[ ^ (Object compiledMethodAt:#class) code ].
+ |cls sel|
+
+ (primNr == 75) ifTrue:[ cls := Object. sel := #identityHash ].
+ (primNr == 110) ifTrue:[ cls := Object. sel := #== ].
+ (primNr == 111) ifTrue:[ cls := Object. sel := #class ].
+ cls notNil ifTrue:[
+ ^ (cls compiledMethodAt:sel) code
+ ].
^ nil
!
@@ -313,7 +324,7 @@
stackDepth := 0.
maxStackDepth := 0.
- code := ByteArray new:codeSize.
+ code := ByteArray uninitializedNew:codeSize.
relocInfo := Array new:(codeSize + 1).
symIndex := 1.
codeIndex := 1.
@@ -386,6 +397,7 @@
] ifFalse:[
(extra == #absoffset) ifTrue:[
relocInfo at:symIndex put:codeIndex.
+ self addReloc:symIndex.
addr := symbolicCodeArray at:symIndex.
symIndex := symIndex + 1.
self appendByte:(addr bitAnd:16rFF).
@@ -393,6 +405,7 @@
] ifFalse:[
(extra == #absoffsetNvarNarg) ifTrue:[
relocInfo at:symIndex put:codeIndex.
+ self addReloc:symIndex.
addr := symbolicCodeArray at:symIndex.
symIndex := symIndex + 1.
self appendByte:(addr bitAnd:16rFF).
@@ -452,7 +465,10 @@
done := self relocateWith:symbolicCodeArray relocInfo:relocInfo.
"if returned with false, a relative jump was made into
an absolute jump - need to start over with one more byte space"
- codeSize := codeSize + 1.
+ done ifFalse:[
+ relocList := nil.
+ codeSize := codeSize + 1.
+ ]
].
].
"code printNewline."
@@ -460,18 +476,20 @@
!
absJumpFromJump:code
+ "given a jump-symbolic code, return corresponding absolute jump"
+
JumpToAbsJump isNil ifTrue:[
- JumpToAbsJump := IdentityDictionary new.
- JumpToAbsJump at:#jump put:#jumpabs.
- JumpToAbsJump at:#trueJump put:#trueJumpabs.
- JumpToAbsJump at:#falseJump put:#falseJumpabs.
- JumpToAbsJump at:#nilJump put:#nilJumpabs.
- JumpToAbsJump at:#notNilJump put:#notNilJumpabs.
- JumpToAbsJump at:#eqJump put:#eqJumpabs.
- JumpToAbsJump at:#notEqJump put:#notEqJumpabs.
- JumpToAbsJump at:#zeroJump put:#zeroJumpabs.
- JumpToAbsJump at:#notZeroJump put:#notZeroJumpabs.
- JumpToAbsJump at:#makeBlock put:#makeBlockabs.
+ JumpToAbsJump := IdentityDictionary new.
+ JumpToAbsJump at:#jump put:#jumpabs.
+ JumpToAbsJump at:#trueJump put:#trueJumpabs.
+ JumpToAbsJump at:#falseJump put:#falseJumpabs.
+ JumpToAbsJump at:#nilJump put:#nilJumpabs.
+ JumpToAbsJump at:#notNilJump put:#notNilJumpabs.
+ JumpToAbsJump at:#eqJump put:#eqJumpabs.
+ JumpToAbsJump at:#notEqJump put:#notEqJumpabs.
+ JumpToAbsJump at:#zeroJump put:#zeroJumpabs.
+ JumpToAbsJump at:#notZeroJump put:#notZeroJumpabs.
+ JumpToAbsJump at:#makeBlock put:#makeBlockabs.
].
^ JumpToAbsJump at:code
!
@@ -480,63 +498,102 @@
"helper for genByteCodeFrom - relocate code using relocInfo.
if relocation fails badly (due to long relative jumps) patch
symbolicCode to use absolute jumps instead and return false
- (genByteCodeFrom will then try again). Otherwise return true."
+ (genByteCodeFrom will then try again). Otherwise return true.
+ Also, on the fly, jumps to jumps and jumps to return are handled."
|delta "<SmallInteger>"
codePos "<SmallInteger>"
opCodePos "<SmallInteger>"
codeOffset "<SmallInteger>"
symOffset opcode dstOpcode jumpTarget
- jumpCode|
+ jumpCode deleteSet|
+ deleteSet := OrderedCollection new.
relocList do:[:sIndex |
"have to relocate symCode at sIndex ..."
- symOffset := symbolicCodeArray at:sIndex.
- codePos := relocInfo at:sIndex.
- codeOffset := relocInfo at:symOffset.
+ symOffset := symbolicCodeArray at:sIndex. "the target in the symbolic code"
+ codePos := relocInfo at:sIndex. "position of the offet in byte code"
+ codeOffset := relocInfo at:symOffset. "position of the target in byte code"
delta := codeOffset - codePos - 1.
opCodePos := codePos - 1.
opcode := code at:opCodePos.
- (opcode between:190 and:199) ifTrue:[
- "an absolute jump/makeBlock"
+ (opcode between:190 and:199) ifTrue:[
+ "an absolute jump/makeBlock"
- code at:codePos put:(codeOffset bitAnd:16rFF).
- code at:(codePos + 1) put:(codeOffset bitShift:-8)
- ] ifFalse:[
- "get jump-code from long and vlong codes"
- (opcode between:50 and:59) ifFalse:[
- (opcode between:60 and:69) ifTrue:[
- opcode := opcode - 10
- ] ifFalse:[
- (opcode between:70 and:79) ifTrue:[
- opcode := opcode - 20
- ] ifFalse:[
+ code at:codePos put:(codeOffset bitAnd:16rFF).
+ code at:(codePos + 1) put:(codeOffset bitShift:-8)
+ ] ifFalse:[
+ "get jump-code from long and vlong codes"
+ (opcode between:50 and:59) ifFalse:[
+ (opcode between:60 and:69) ifTrue:[
+ opcode := opcode - 10
+ ] ifFalse:[
+ (opcode between:70 and:79) ifTrue:[
+ opcode := opcode - 20
+ ] ifFalse:[
self error:'invalid code to relocate'
- ]
+ ]
].
- ].
+ ].
"optimize jump to return and jump to jump"
(opcode == 54) ifTrue:[
"a jump"
dstOpcode := symbolicCodeArray at:symOffset.
- (#(retSelf retTop retNil retTrue retFalse ret0) includes:dstOpcode) ifTrue:[
+
+ (#(retSelf retTop retNil retTrue retFalse ret0 blockRetTop) includes:dstOpcode) ifTrue:[
"a jump to a return - put in the return instead jump"
+
+ symbolicCodeArray at:(sIndex - 1) put:dstOpcode.
+ symbolicCodeArray at:sIndex put:dstOpcode.
code at:opCodePos put:(self byteCodeFor:dstOpcode).
- delta := 0
+ delta := 0.
+ deleteSet add:sIndex.
+
+"
+'jump to return at: ' print. (sIndex - 1) printNewline.
+"
] ifFalse:[
(dstOpcode == #jump) ifTrue:[
"jump to jump to be done soon"
- jumpTarget := symbolicCodeArray at:(codeOffset + 1)
-"
- .
- 'jump to jump: ' print. dstOpcode printNewline
-"
+ jumpTarget := symbolicCodeArray at:(symOffset + 1).
+"
+'jump to jump at: ' print. (sIndex - 1) print.
+' newTarget:' print. jumpTarget printNewline.
+"
+
+ symbolicCodeArray at:sIndex put:jumpTarget.
+ symOffset := jumpTarget.
+ codeOffset := relocInfo at:symOffset.
+ delta := codeOffset - codePos - 1.
+
+ "continue with new delta"
]
]
].
+ (#(50 51 52 53 56 57 58 59) includes:opcode) ifTrue:[
+ "a conditional jump"
+
+ dstOpcode := symbolicCodeArray at:symOffset.
+ (dstOpcode == #jump) ifTrue:[
+ "conditional jump to unconditional jump"
+ jumpTarget := symbolicCodeArray at:(symOffset + 1).
+"
+'cond jump to jump at: ' print. (sIndex - 1) print.
+' newTarget:' print. jumpTarget printNewline.
+"
+
+ symbolicCodeArray at:sIndex put:jumpTarget.
+ symOffset := jumpTarget.
+ codeOffset := relocInfo at:symOffset.
+ delta := codeOffset - codePos - 1.
+
+ "continue with new delta"
+ ].
+ ].
+
(delta >= 0) ifTrue:[
(delta > 127) ifTrue:[
(opcode between:50 and:59) ifFalse:[
@@ -554,8 +611,12 @@
(delta > 127) ifTrue:[
"change symbolic into a jump absolute and fail"
jumpCode := symbolicCodeArray at:(sIndex - 1).
- symbolicCodeArray at:(sIndex - 1) put:(self absJumpFromJump:jumpCode).
+ symbolicCodeArray at:(sIndex - 1) put:(self absJumpFromJump:jumpCode).
symbolicCodeArray at:sIndex put:symOffset.
+"
+'change short into abs jump' printNewline.
+"
+ deleteSet do:[:d | relocList remove:d].
^ false
].
].
@@ -577,8 +638,12 @@
(delta < -128) ifTrue:[
"change symbolic into a jump absolute and fail"
jumpCode := symbolicCodeArray at:(sIndex - 1).
- symbolicCodeArray at:(sIndex - 1) put:(self absJumpFromJump:jumpCode).
+ symbolicCodeArray at:(sIndex - 1) put:(self absJumpFromJump:jumpCode).
symbolicCodeArray at:sIndex put:symOffset.
+"
+'change short into abs jump' printNewline.
+"
+ deleteSet do:[:d | relocList remove:d].
^ false
]
].
@@ -596,7 +661,7 @@
"add a literal to the literalArray - watch for and eliminate
duplicates. return the index of the literal in the Array"
- |index|
+ |index class|
litArray isNil ifTrue:[
litArray := Array with:anObject.
@@ -604,8 +669,14 @@
].
index := litArray identityIndexOf:anObject.
(index == 0) ifTrue:[
- litArray := litArray copyWith:anObject.
- ^ litArray size
+ class := anObject class.
+ ((class == Float) or:[class == Fraction]) ifTrue:[
+ index := litArray indexOf:anObject.
+ ].
+ (index == 0) ifTrue:[
+ litArray := litArray copyWith:anObject.
+ ^ litArray size
+ ].
].
^ index
!
@@ -733,6 +804,7 @@
(aSymbol == #pushChar) ifTrue:[stackDelta := 1. ^17].
(aSymbol == #push0) ifTrue:[stackDelta := 1. ^120].
(aSymbol == #push1) ifTrue:[stackDelta := 1. ^121].
+ (aSymbol == #push2) ifTrue:[stackDelta := 1. ^139].
(aSymbol == #pushMinus1) ifTrue:[stackDelta := 1. ^122].
(aSymbol == #send0) ifTrue:[lineno := true. extra := #lit. ^21].
@@ -879,7 +951,9 @@
!ByteCodeCompiler class methodsFor:'machine code constants'!
sharedCodeFunctionFor:aSymbol
- "return the address of a shared code-function"
+ "return the address of a shared code-function;
+ the code below looks ugly, but adds some speed to instvar-access
+ methods"
|codeSymbol|
@@ -1189,6 +1263,61 @@
RETURN ( _MKSMALLINT((int)__retInst24) );
%}
].
+ (aSymbol == #retInstVar26) ifTrue:[
+%{
+ extern OBJ __retInst25();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __retInst25;
+#endif
+ RETURN ( _MKSMALLINT((int)__retInst25) );
+%}
+ ].
+ (aSymbol == #retInstVar27) ifTrue:[
+%{
+ extern OBJ __retInst26();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __retInst26;
+#endif
+ RETURN ( _MKSMALLINT((int)__retInst26) );
+%}
+ ].
+ (aSymbol == #retInstVar28) ifTrue:[
+%{
+ extern OBJ __retInst27();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __retInst27;
+#endif
+ RETURN ( _MKSMALLINT((int)__retInst27) );
+%}
+ ].
+ (aSymbol == #retInstVar29) ifTrue:[
+%{
+ extern OBJ __retInst28();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __retInst28;
+#endif
+ RETURN ( _MKSMALLINT((int)__retInst28) );
+%}
+ ].
+ (aSymbol == #retInstVar30) ifTrue:[
+%{
+ extern OBJ __retInst29();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __retInst29;
+#endif
+ RETURN ( _MKSMALLINT((int)__retInst29) );
+%}
+ ].
+ (aSymbol == #retInstVar31) ifTrue:[
+%{
+ extern OBJ __retInst30();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __retInst30;
+#endif
+ RETURN ( _MKSMALLINT((int)__retInst30) );
+%}
+ ].
+
(aSymbol == #storeInstVar1) ifTrue:[
%{
extern OBJ __setInst0();
@@ -1378,6 +1507,114 @@
RETURN ( _MKSMALLINT((int)__setInst19) );
%}
].
+ (aSymbol == #storeInstVar21) ifTrue:[
+%{
+ extern OBJ __setInst20();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __setInst20;
+#endif
+ RETURN ( _MKSMALLINT((int)__setInst20) );
+%}
+ ].
+ (aSymbol == #storeInstVar22) ifTrue:[
+%{
+ extern OBJ __setInst21();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __setInst21;
+#endif
+ RETURN ( _MKSMALLINT((int)__setInst21) );
+%}
+ ].
+ (aSymbol == #storeInstVar23) ifTrue:[
+%{
+ extern OBJ __setInst22();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __setInst22;
+#endif
+ RETURN ( _MKSMALLINT((int)__setInst22) );
+%}
+ ].
+ (aSymbol == #storeInstVar23) ifTrue:[
+%{
+ extern OBJ __setInst22();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __setInst22;
+#endif
+ RETURN ( _MKSMALLINT((int)__setInst22) );
+%}
+ ].
+ (aSymbol == #storeInstVar24) ifTrue:[
+%{
+ extern OBJ __setInst23();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __setInst23;
+#endif
+ RETURN ( _MKSMALLINT((int)__setInst23) );
+%}
+ ].
+ (aSymbol == #storeInstVar25) ifTrue:[
+%{
+ extern OBJ __setInst24();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __setInst24;
+#endif
+ RETURN ( _MKSMALLINT((int)__setInst24) );
+%}
+ ].
+ (aSymbol == #storeInstVar26) ifTrue:[
+%{
+ extern OBJ __setInst25();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __setInst25;
+#endif
+ RETURN ( _MKSMALLINT((int)__setInst25) );
+%}
+ ].
+ (aSymbol == #storeInstVar27) ifTrue:[
+%{
+ extern OBJ __setInst26();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __setInst26;
+#endif
+ RETURN ( _MKSMALLINT((int)__setInst26) );
+%}
+ ].
+ (aSymbol == #storeInstVar28) ifTrue:[
+%{
+ extern OBJ __setInst27();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __setInst27;
+#endif
+ RETURN ( _MKSMALLINT((int)__setInst27) );
+%}
+ ].
+ (aSymbol == #storeInstVar29) ifTrue:[
+%{
+ extern OBJ __setInst28();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __setInst28;
+#endif
+ RETURN ( _MKSMALLINT((int)__setInst28) );
+%}
+ ].
+ (aSymbol == #storeInstVar30) ifTrue:[
+%{
+ extern OBJ __setInst29();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __setInst29;
+#endif
+ RETURN ( _MKSMALLINT((int)__setInst29) );
+%}
+ ].
+ (aSymbol == #storeInstVar31) ifTrue:[
+%{
+ extern OBJ __setInst30();
+#if defined(SYSV4) && defined(i386)
+ OBJ (*dummy)() = __setInst30;
+#endif
+ RETURN ( _MKSMALLINT((int)__setInst30) );
+%}
+ ].
^ nil
! !
@@ -1405,9 +1642,9 @@
index := symbolicCodeArray at:3.
((symbolicCodeArray at:4) == #retSelf) ifTrue:[
^ ('storeInstVar' , index printString) asSymbol
- ].
- ^ nil
- ].
+ ].
+ ^ nil
+ ].
('storeInstVar*' match:(symbolicCodeArray at:2)) ifTrue:[
((symbolicCodeArray at:3) == #retSelf) ifTrue:[^ symbolicCodeArray at:2]
].
--- a/CascadeNd.st Wed Oct 13 01:25:45 1993 +0100
+++ b/CascadeNd.st Wed Oct 13 01:26:26 1993 +0100
@@ -22,7 +22,7 @@
COPYRIGHT (c) 1989-93 by Claus Gittinger
All Rights Reserved
-%W% %E%
+$Header: /cvs/stx/stx/libcomp/Attic/CascadeNd.st,v 1.2 1993-10-13 00:25:39 claus Exp $
'!
!CascadeNode methodsFor: 'code generation'!
@@ -41,36 +41,26 @@
!CascadeNode methodsFor: 'evaluating'!
evaluate
- |t argValueArray index|
+ |t argValueArray|
t := receiver evaluateForCascade.
argArray isNil ifTrue:[
t perform:selector.
^ t
].
- argValueArray := Array new:(argArray size).
- index := 1.
- argArray do:[:arg |
- argValueArray at:index put:(arg evaluate).
- index := index + 1
- ].
+ argValueArray := argArray collect:[:arg | arg evaluate].
^ t perform:selector withArguments:argValueArray
!
evaluateForCascade
- |t argValueArray index|
+ |t argValueArray|
t := receiver evaluateForCascade.
argArray isNil ifTrue:[
t perform:selector.
^ t
].
- argValueArray := Array new:(argArray size).
- index := 1.
- argArray do:[:arg |
- argValueArray at:index put:(arg evaluate).
- index := index + 1
- ].
+ argValueArray := argArray collect:[:arg | arg evaluate].
t perform:selector withArguments:argValueArray.
^ t
! !
--- a/CascadeNode.st Wed Oct 13 01:25:45 1993 +0100
+++ b/CascadeNode.st Wed Oct 13 01:26:26 1993 +0100
@@ -22,7 +22,7 @@
COPYRIGHT (c) 1989-93 by Claus Gittinger
All Rights Reserved
-%W% %E%
+$Header: /cvs/stx/stx/libcomp/CascadeNode.st,v 1.2 1993-10-13 00:25:39 claus Exp $
'!
!CascadeNode methodsFor: 'code generation'!
@@ -41,36 +41,26 @@
!CascadeNode methodsFor: 'evaluating'!
evaluate
- |t argValueArray index|
+ |t argValueArray|
t := receiver evaluateForCascade.
argArray isNil ifTrue:[
t perform:selector.
^ t
].
- argValueArray := Array new:(argArray size).
- index := 1.
- argArray do:[:arg |
- argValueArray at:index put:(arg evaluate).
- index := index + 1
- ].
+ argValueArray := argArray collect:[:arg | arg evaluate].
^ t perform:selector withArguments:argValueArray
!
evaluateForCascade
- |t argValueArray index|
+ |t argValueArray|
t := receiver evaluateForCascade.
argArray isNil ifTrue:[
t perform:selector.
^ t
].
- argValueArray := Array new:(argArray size).
- index := 1.
- argArray do:[:arg |
- argValueArray at:index put:(arg evaluate).
- index := index + 1
- ].
+ argValueArray := argArray collect:[:arg | arg evaluate].
t perform:selector withArguments:argValueArray.
^ t
! !
--- a/ConstNode.st Wed Oct 13 01:25:45 1993 +0100
+++ b/ConstNode.st Wed Oct 13 01:26:26 1993 +0100
@@ -23,7 +23,7 @@
COPYRIGHT (c) 1989-93 by Claus Gittinger
All Rights Reserved
-%W% %E%
+$Header: /cvs/stx/stx/libcomp/Attic/ConstNode.st,v 1.2 1993-10-13 00:25:41 claus Exp $
'!
!ConstantNode class methodsFor:'queries'!
@@ -124,6 +124,9 @@
(value == 1) ifTrue:[
aStream nextPut:#push1. ^ self
].
+ (value == 2) ifTrue:[
+ aStream nextPut:#push2. ^ self
+ ].
(value == -1) ifTrue:[
aStream nextPut:#pushMinus1. ^ self
].
--- a/ConstantNode.st Wed Oct 13 01:25:45 1993 +0100
+++ b/ConstantNode.st Wed Oct 13 01:26:26 1993 +0100
@@ -23,7 +23,7 @@
COPYRIGHT (c) 1989-93 by Claus Gittinger
All Rights Reserved
-%W% %E%
+$Header: /cvs/stx/stx/libcomp/ConstantNode.st,v 1.2 1993-10-13 00:25:41 claus Exp $
'!
!ConstantNode class methodsFor:'queries'!
@@ -124,6 +124,9 @@
(value == 1) ifTrue:[
aStream nextPut:#push1. ^ self
].
+ (value == 2) ifTrue:[
+ aStream nextPut:#push2. ^ self
+ ].
(value == -1) ifTrue:[
aStream nextPut:#pushMinus1. ^ self
].
--- a/Decomp.st Wed Oct 13 01:25:45 1993 +0100
+++ b/Decomp.st Wed Oct 13 01:26:26 1993 +0100
@@ -19,12 +19,12 @@
Decompiler comment:'
-COPYRIGHT (c) 1991-92 by Claus Gittinger
+COPYRIGHT (c) 1991-93 by Claus Gittinger
All Rights Reserved
additional methods for decompilation
-%W% %E%
+$Header: /cvs/stx/stx/libcomp/Attic/Decomp.st,v 1.2 1993-10-13 00:25:43 claus Exp $
'!
!Decompiler class methodsFor:'decompiling'!
@@ -82,6 +82,34 @@
Transcript show:')'
!
+showAbsOffset:byte
+ |offs b2|
+
+ index := index + 1.
+ b2 := (bytes at:index).
+ offs := byte + (b2 bitShift:8).
+ index := index + 1.
+ Transcript show:offs printString.
+ Transcript show:' ('.
+ Transcript show:offs printString.
+ Transcript show:')'
+!
+
+showAbsOffsetLevel:byte
+ |offs b2|
+
+ index := index + 1.
+ b2 := (bytes at:index).
+ offs := byte + (b2 bitShift:8).
+ index := index + 1.
+ Transcript show:offs printString.
+ Transcript show:' ('.
+ Transcript show:offs printString.
+ Transcript show:')'.
+ self showNvarNargsAt:index.
+ index := index + 2
+!
+
showNvarNargsAt:index
Transcript show:' nv='.
Transcript show:(bytes at:index) printString.
@@ -129,7 +157,8 @@
Transcript show:byte printString.
Transcript show:' '.
index := index + 1.
- self showLiteralAt:index
+ self showLiteralAt:index.
+ index := index + 1
!
showSuperSendArgs:byte
@@ -137,6 +166,8 @@
Transcript show:' '.
index := index + 1.
self showLiteralAt:index.
+ index := index + 1.
+ self showLiteralAt:index.
index := index + 1
!
@@ -150,6 +181,12 @@
index := index + 1
!
+showIndexLevel:byte
+ self showIndex:byte.
+ self showNvarNargsAt:index.
+ index := index + 2
+!
+
showNumber:byte
Transcript show:byte printString.
index := index + 1
@@ -312,10 +349,10 @@
storeMethodVar4
storeMethodVar5
storeMethodVar6 " 105 "
- nil
- nil
- nil
- nil
+ sendY
+ sendX
+ sendWidth
+ sendHeight
storeInstVar1 " 110 "
storeInstVar2
storeInstVar3
@@ -345,7 +382,7 @@
sendATPUT
sendBitAnd
sendBitOr
- nil
+ push2
pushBlockArg1 " 140 "
pushBlockArg2
pushBlockArg3
@@ -394,6 +431,18 @@
sendSelfDrop1 " 185 "
sendSelfDrop2
sendSelfDrop3
+ nil
+ nil
+ falseJumpAbs " 190 "
+ trueJumpAbs
+ nilJumpAbs
+ notNilJumpAbs
+ jumpAbs
+ makeBlockAbs " 195 "
+ zeroJumpAbs
+ notZeroJumpAbs
+ eqJumpAbs
+ notEqJumpAbs " 199 "
).
lnos := #( false " 0 "
@@ -576,14 +625,26 @@
false
false
false
- true " 180 "
+ true " 180 "
true
true
true
true
- true " 185 "
+ true " 185 "
true
true
+ false
+ false
+ false " 190 "
+ false
+ false
+ false
+ false
+ false " 195 "
+ false
+ false
+ false
+ false " 199 "
).
extras := #(nil " 0 "
@@ -774,6 +835,18 @@
literal " 185 "
literal
literal
+ nil
+ nil
+ absOffset " 190 "
+ absOffset
+ absOffset
+ absOffset
+ absOffset
+ absOffsetLevel
+ absOffset
+ absOffset
+ absOffset
+ absOffset " 199 "
).
extra := extras at:(aByte + 1).
--- a/Decompiler.st Wed Oct 13 01:25:45 1993 +0100
+++ b/Decompiler.st Wed Oct 13 01:26:26 1993 +0100
@@ -19,12 +19,12 @@
Decompiler comment:'
-COPYRIGHT (c) 1991-92 by Claus Gittinger
+COPYRIGHT (c) 1991-93 by Claus Gittinger
All Rights Reserved
additional methods for decompilation
-%W% %E%
+$Header: /cvs/stx/stx/libcomp/Decompiler.st,v 1.2 1993-10-13 00:25:43 claus Exp $
'!
!Decompiler class methodsFor:'decompiling'!
@@ -82,6 +82,34 @@
Transcript show:')'
!
+showAbsOffset:byte
+ |offs b2|
+
+ index := index + 1.
+ b2 := (bytes at:index).
+ offs := byte + (b2 bitShift:8).
+ index := index + 1.
+ Transcript show:offs printString.
+ Transcript show:' ('.
+ Transcript show:offs printString.
+ Transcript show:')'
+!
+
+showAbsOffsetLevel:byte
+ |offs b2|
+
+ index := index + 1.
+ b2 := (bytes at:index).
+ offs := byte + (b2 bitShift:8).
+ index := index + 1.
+ Transcript show:offs printString.
+ Transcript show:' ('.
+ Transcript show:offs printString.
+ Transcript show:')'.
+ self showNvarNargsAt:index.
+ index := index + 2
+!
+
showNvarNargsAt:index
Transcript show:' nv='.
Transcript show:(bytes at:index) printString.
@@ -129,7 +157,8 @@
Transcript show:byte printString.
Transcript show:' '.
index := index + 1.
- self showLiteralAt:index
+ self showLiteralAt:index.
+ index := index + 1
!
showSuperSendArgs:byte
@@ -137,6 +166,8 @@
Transcript show:' '.
index := index + 1.
self showLiteralAt:index.
+ index := index + 1.
+ self showLiteralAt:index.
index := index + 1
!
@@ -150,6 +181,12 @@
index := index + 1
!
+showIndexLevel:byte
+ self showIndex:byte.
+ self showNvarNargsAt:index.
+ index := index + 2
+!
+
showNumber:byte
Transcript show:byte printString.
index := index + 1
@@ -312,10 +349,10 @@
storeMethodVar4
storeMethodVar5
storeMethodVar6 " 105 "
- nil
- nil
- nil
- nil
+ sendY
+ sendX
+ sendWidth
+ sendHeight
storeInstVar1 " 110 "
storeInstVar2
storeInstVar3
@@ -345,7 +382,7 @@
sendATPUT
sendBitAnd
sendBitOr
- nil
+ push2
pushBlockArg1 " 140 "
pushBlockArg2
pushBlockArg3
@@ -394,6 +431,18 @@
sendSelfDrop1 " 185 "
sendSelfDrop2
sendSelfDrop3
+ nil
+ nil
+ falseJumpAbs " 190 "
+ trueJumpAbs
+ nilJumpAbs
+ notNilJumpAbs
+ jumpAbs
+ makeBlockAbs " 195 "
+ zeroJumpAbs
+ notZeroJumpAbs
+ eqJumpAbs
+ notEqJumpAbs " 199 "
).
lnos := #( false " 0 "
@@ -576,14 +625,26 @@
false
false
false
- true " 180 "
+ true " 180 "
true
true
true
true
- true " 185 "
+ true " 185 "
true
true
+ false
+ false
+ false " 190 "
+ false
+ false
+ false
+ false
+ false " 195 "
+ false
+ false
+ false
+ false " 199 "
).
extras := #(nil " 0 "
@@ -774,6 +835,18 @@
literal " 185 "
literal
literal
+ nil
+ nil
+ absOffset " 190 "
+ absOffset
+ absOffset
+ absOffset
+ absOffset
+ absOffsetLevel
+ absOffset
+ absOffset
+ absOffset
+ absOffset " 199 "
).
extra := extras at:(aByte + 1).
--- a/Make.proto Wed Oct 13 01:25:45 1993 +0100
+++ b/Make.proto Wed Oct 13 01:26:26 1993 +0100
@@ -18,15 +18,13 @@
PrimNd.$(O) CascadeNd.$(O) ConstNode.$(O) \
ObjectFile.$(O) ObjFLoader.$(O) UndefVar.$(O)
-AUXOBJS= PermBench.$(O) HanoiBench.$(O) HanoiDisk.$(O) \
- Benchmarks.$(O) Slopstones.$(O) Smopstones.$(O)
+AUXOBJS= Explainer.$(O)
all:: $(OBJTARGET)
objs:: level0 \
level1 \
- level2 \
- level4
+ level2
#
# you may want to remove these ...
@@ -58,21 +56,11 @@
PrimNd.o \
ConstNode.o
-# currently not implemented
-
-level3:$(P) \
- CMethod.o \
- MCompiler.o
+install::
+ -mkdir $(DESTLIBDIR)
+ -$(INSTALL) $(LIBNAME)$(OBJNAME) $(DESTLIBDIR)
-level4:$(P) \
- HanoiBench.o \
- HanoiDisk.o \
- PermBench.o \
- Benchmarks.o \
- Slopstones.o \
- Smopstones.o
-
-install::
+qinstall::
-mkdir $(DESTLIBDIR)
-$(INSTALL) $(LIBNAME)$(OBJNAME) $(DESTLIBDIR)
@@ -109,10 +97,10 @@
PRIMARYNODE=$(I)/PrimaryNd.H $(PARSENODE)
MESSAGENODE=$(I)/MessageNd.H $(PARSENODE)
-Scanner.o: Scanner.st $(OBJECT)
ObjectFile.o: ObjectFile.st $(OBJECT)
ObjFLoader.o: ObjFLoader.st $(OBJECT)
UndefVar.o: UndefVar.st $(OBJECT)
+Scanner.o: Scanner.st $(OBJECT)
Parser.o: Parser.st $(SCANNER)
BCompiler.o: BCompiler.st $(PARSER)
Variable.o: Variable.st $(OBJECT)
@@ -131,10 +119,4 @@
CMethod.o: CMethod.st $(I)/Method.H $(OBJECT)
MCompiler.o: MCompiler.st $(PARSER)
-
-Benchmarks.o: Benchmarks.st $(OBJECT)
-PermBench.o: PermBench.st $(OBJECT)
-HanoiBench.o: HanoiBench.st $(OBJECT)
-HanoiDisk.o: HanoiDisk.st $(OBJECT)
-Slopstones.o: Slopstones.st $(OBJECT)
-Smopstones.o: Smopstones.st $(OBJECT)
+Explainer.o: Explainer.st $(PARSER)
--- a/MessageNd.st Wed Oct 13 01:25:45 1993 +0100
+++ b/MessageNd.st Wed Oct 13 01:26:26 1993 +0100
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1989-93 by Claus Gittinger
All Rights Reserved
-%W% %E%
+$Header: /cvs/stx/stx/libcomp/Attic/MessageNd.st,v 1.2 1993-10-13 00:25:52 claus Exp $
'!
!MessageNode class methodsFor:'instance creation'!
@@ -130,11 +130,13 @@
lineNr := num
! !
-!MessageNode class methodsFor:'queries'!
+!MessageNode methodsFor:'queries'!
isMessage
^ true
-!
+! !
+
+!MessageNode class methodsFor:'queries'!
isBuiltInUnarySelector:sel
"return true, if unary selector sel is built in"
@@ -232,7 +234,7 @@
!
printWhileOn:aStream indent:i
- |needParen selectorParts index index2 arg|
+ |needParen selectorParts arg|
"special handling of whileTrue/whileFalse"
@@ -263,9 +265,10 @@
plausibilityCheck
|rec arg operand|
- "it once costed me 1h, to find a '==' which
- should have been an '=' (well, I saw it 50 times but
- didn't think about it ...).
+ "
+ it once took me almost an hour, to find a '==' which
+ should have been an '=' (you cannot compare floats with ==)
+ (well, I saw it 50 times but didn't think about it ...).
reason enough to add this check here.
"
((selector == #==) or:[selector == #~~]) ifTrue:[
@@ -292,6 +295,41 @@
^ 'identity compare will usually return true here'
]
].
+
+ "
+ an error often occuring when you are a beginner ...
+ "
+ ((selector == #ifTrue:) or:[selector == #ifFalse:]) ifTrue:[
+ receiver isBlock ifTrue:[
+ (Block canUnderstand:selector) ifFalse:[
+ ^ 'blocks usually do not respond to ' , selector , ' messages'
+ ].
+ ].
+ (argArray at:1) isBlock ifFalse:[
+ ^ 'will fail at runtime, if argument to ' , selector , ' does not evaluate to a block'
+ ]
+ ].
+ ((selector == #ifTrue:ifFalse) or:[selector == #ifFalse:ifTrue]) ifTrue:[
+ receiver isBlock ifTrue:[
+ (Block canUnderstand:selector) ifFalse:[
+ ^ 'blocks usually do not respond to ' , selector , ' messages'
+ ].
+ ].
+ (argArray at:1) isBlock ifFalse:[
+ ^ 'will fail at runtime, if 1st. argument to ' , selector , ' does not evaluate to a block'
+ ].
+ (argArray at:2) isBlock ifFalse:[
+ ^ 'will fail at runtime, if 2nd. argument to ' , selector , ' does not evaluate to a block'
+ ]
+ ].
+ ((selector == #whileTrue:) or:[selector == #whileFalse:]) ifTrue:[
+ receiver isBlock ifFalse:[
+ ^ 'will fail at runtime, if receiver of ' , selector , ' does not evaluate to a block'
+ ].
+ (argArray at:1) isBlock ifFalse:[
+ ^ 'will fail at runtime, if argument to ' , selector , ' does not evaluate to a block'
+ ].
+ ].
^ nil
! !
@@ -468,7 +506,7 @@
codeTimesRepeatOn:aStream inBlock:b valueNeeded:valueNeeded
"generate code for n timesRepeat:[ ... ]"
- |pos pos2 theReceiver theArg theByteCode optByteCode|
+ |pos pos2 theReceiver theByteCode optByteCode|
theReceiver := receiver.
theReceiver codeOn:aStream inBlock:b.
@@ -645,12 +683,10 @@
|theByteCode optByteCode theReceiver theArg pos1 pos2 pos3|
-
theByteCode := #trueJump.
theReceiver := receiver receiver.
- optByteCode := self optimizedConditionFor:theReceiver
- with:theByteCode.
+ optByteCode := self optimizedConditionFor:theReceiver with:theByteCode.
optByteCode notNil ifTrue:[
((optByteCode == #eqJump) or:[optByteCode == #notEqJump]) ifTrue:[
theArg := theReceiver arg1
@@ -666,12 +702,40 @@
pos1 := aStream position.
aStream nextPut:0.
+
theReceiver := receiver arg1.
- theReceiver codeInlineOn:aStream inBlock:b.
+
+"new:"
(selector == #ifTrue:) ifTrue:[
- aStream nextPut:#falseJump
+ theByteCode := #falseJump
] ifFalse:[
- aStream nextPut:#trueJump
+ theByteCode := #trueJump
+ ].
+ optByteCode := self optimizedConditionFor:theReceiver with:theByteCode.
+ optByteCode notNil ifTrue:[
+ theReceiver isBlock ifTrue:[
+ theReceiver := theReceiver statements expression
+ ].
+ ((optByteCode == #eqJump) or:[optByteCode == #notEqJump]) ifTrue:[
+ theArg := theReceiver arg1
+ ].
+ theReceiver := theReceiver receiver.
+ theByteCode := optByteCode.
+
+ theReceiver codeOn:aStream inBlock:b.
+ theArg notNil ifTrue:[
+ theArg codeOn:aStream inBlock:b
+ ].
+ aStream nextPut:theByteCode.
+
+ ] ifFalse:[
+"org"
+ theReceiver codeInlineOn:aStream inBlock:b.
+ (selector == #ifTrue:) ifTrue:[
+ aStream nextPut:#falseJump
+ ] ifFalse:[
+ aStream nextPut:#trueJump
+ ].
].
pos2 := aStream position.
aStream nextPut:0.
--- a/MessageNode.st Wed Oct 13 01:25:45 1993 +0100
+++ b/MessageNode.st Wed Oct 13 01:26:26 1993 +0100
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1989-93 by Claus Gittinger
All Rights Reserved
-%W% %E%
+$Header: /cvs/stx/stx/libcomp/MessageNode.st,v 1.2 1993-10-13 00:25:52 claus Exp $
'!
!MessageNode class methodsFor:'instance creation'!
@@ -130,11 +130,13 @@
lineNr := num
! !
-!MessageNode class methodsFor:'queries'!
+!MessageNode methodsFor:'queries'!
isMessage
^ true
-!
+! !
+
+!MessageNode class methodsFor:'queries'!
isBuiltInUnarySelector:sel
"return true, if unary selector sel is built in"
@@ -232,7 +234,7 @@
!
printWhileOn:aStream indent:i
- |needParen selectorParts index index2 arg|
+ |needParen selectorParts arg|
"special handling of whileTrue/whileFalse"
@@ -263,9 +265,10 @@
plausibilityCheck
|rec arg operand|
- "it once costed me 1h, to find a '==' which
- should have been an '=' (well, I saw it 50 times but
- didn't think about it ...).
+ "
+ it once took me almost an hour, to find a '==' which
+ should have been an '=' (you cannot compare floats with ==)
+ (well, I saw it 50 times but didn't think about it ...).
reason enough to add this check here.
"
((selector == #==) or:[selector == #~~]) ifTrue:[
@@ -292,6 +295,41 @@
^ 'identity compare will usually return true here'
]
].
+
+ "
+ an error often occuring when you are a beginner ...
+ "
+ ((selector == #ifTrue:) or:[selector == #ifFalse:]) ifTrue:[
+ receiver isBlock ifTrue:[
+ (Block canUnderstand:selector) ifFalse:[
+ ^ 'blocks usually do not respond to ' , selector , ' messages'
+ ].
+ ].
+ (argArray at:1) isBlock ifFalse:[
+ ^ 'will fail at runtime, if argument to ' , selector , ' does not evaluate to a block'
+ ]
+ ].
+ ((selector == #ifTrue:ifFalse) or:[selector == #ifFalse:ifTrue]) ifTrue:[
+ receiver isBlock ifTrue:[
+ (Block canUnderstand:selector) ifFalse:[
+ ^ 'blocks usually do not respond to ' , selector , ' messages'
+ ].
+ ].
+ (argArray at:1) isBlock ifFalse:[
+ ^ 'will fail at runtime, if 1st. argument to ' , selector , ' does not evaluate to a block'
+ ].
+ (argArray at:2) isBlock ifFalse:[
+ ^ 'will fail at runtime, if 2nd. argument to ' , selector , ' does not evaluate to a block'
+ ]
+ ].
+ ((selector == #whileTrue:) or:[selector == #whileFalse:]) ifTrue:[
+ receiver isBlock ifFalse:[
+ ^ 'will fail at runtime, if receiver of ' , selector , ' does not evaluate to a block'
+ ].
+ (argArray at:1) isBlock ifFalse:[
+ ^ 'will fail at runtime, if argument to ' , selector , ' does not evaluate to a block'
+ ].
+ ].
^ nil
! !
@@ -468,7 +506,7 @@
codeTimesRepeatOn:aStream inBlock:b valueNeeded:valueNeeded
"generate code for n timesRepeat:[ ... ]"
- |pos pos2 theReceiver theArg theByteCode optByteCode|
+ |pos pos2 theReceiver theByteCode optByteCode|
theReceiver := receiver.
theReceiver codeOn:aStream inBlock:b.
@@ -645,12 +683,10 @@
|theByteCode optByteCode theReceiver theArg pos1 pos2 pos3|
-
theByteCode := #trueJump.
theReceiver := receiver receiver.
- optByteCode := self optimizedConditionFor:theReceiver
- with:theByteCode.
+ optByteCode := self optimizedConditionFor:theReceiver with:theByteCode.
optByteCode notNil ifTrue:[
((optByteCode == #eqJump) or:[optByteCode == #notEqJump]) ifTrue:[
theArg := theReceiver arg1
@@ -666,12 +702,40 @@
pos1 := aStream position.
aStream nextPut:0.
+
theReceiver := receiver arg1.
- theReceiver codeInlineOn:aStream inBlock:b.
+
+"new:"
(selector == #ifTrue:) ifTrue:[
- aStream nextPut:#falseJump
+ theByteCode := #falseJump
] ifFalse:[
- aStream nextPut:#trueJump
+ theByteCode := #trueJump
+ ].
+ optByteCode := self optimizedConditionFor:theReceiver with:theByteCode.
+ optByteCode notNil ifTrue:[
+ theReceiver isBlock ifTrue:[
+ theReceiver := theReceiver statements expression
+ ].
+ ((optByteCode == #eqJump) or:[optByteCode == #notEqJump]) ifTrue:[
+ theArg := theReceiver arg1
+ ].
+ theReceiver := theReceiver receiver.
+ theByteCode := optByteCode.
+
+ theReceiver codeOn:aStream inBlock:b.
+ theArg notNil ifTrue:[
+ theArg codeOn:aStream inBlock:b
+ ].
+ aStream nextPut:theByteCode.
+
+ ] ifFalse:[
+"org"
+ theReceiver codeInlineOn:aStream inBlock:b.
+ (selector == #ifTrue:) ifTrue:[
+ aStream nextPut:#falseJump
+ ] ifFalse:[
+ aStream nextPut:#trueJump
+ ].
].
pos2 := aStream position.
aStream nextPut:0.
--- a/ObjFLoader.st Wed Oct 13 01:25:45 1993 +0100
+++ b/ObjFLoader.st Wed Oct 13 01:26:26 1993 +0100
@@ -28,7 +28,7 @@
(goal is to allow loading of binary classes)
-%W% %E%
+$Header: /cvs/stx/stx/libcomp/Attic/ObjFLoader.st,v 1.2 1993-10-13 00:25:54 claus Exp $
'!
%{
@@ -700,11 +700,19 @@
].
initAddr := self getSymbol:symName from:handle.
initAddr isNil ifTrue:[
- Transcript showCr:('no symbol: ',symName,' in ',aFileName).
- ^ nil
+ className := Smalltalk classNameForFile:className.
+ OperatingSystem getOSType = 'sys5.4' ifTrue:[
+ symName := '_' , className , '_Init'
+ ] ifFalse:[
+ symName := '__' , className , '_Init'
+ ].
+ initAddr := self getSymbol:symName from:handle.
+ initAddr isNil ifTrue:[
+ Transcript showCr:('no symbol: ',symName,' in ',aFileName).
+ ^ nil
+ ].
].
self callFunctionAt:initAddr.
- ^ self
! !
!ObjectFileLoader class methodsFor:'dynamic object access'!
@@ -734,14 +742,32 @@
}
}
#endif
+#ifdef sunos
+# include <dlfcn.h>
+ void *handle;
+
+ if ((pathName == nil) || _isString(pathName)) {
+ if (pathName == nil)
+ handle = dlopen((char *)0, 1);
+ else
+ handle = dlopen(_stringVal(pathName), 1);
+ if (handle) {
+ printf("open %s handle = %x\n", _stringVal(pathName), handle);
+ low = _MKSMALLINT( (int)handle & 0xFFFF );
+ hi = _MKSMALLINT( ((int)handle >> 16) & 0xFFFF );
+ } else {
+ printf("dlopen %s error: <%s>\n", _stringVal(pathName), dlerror());
+ }
+ }
+#endif
#ifdef NeXT
long result;
char *files[2];
NXStream *errOut;
if (_isString(pathName)) {
- files[0] = _stringVal(pathName);
- files[1] = (char *)0;
+ files[0] = (char *) _stringVal(pathName);
+ files[1] = (char *) 0;
errOut = NXOpenFile(2, 2);
result = rld_load(errOut,
(struct mach_header **)0,
@@ -793,6 +819,18 @@
dlclose(h);
}
#endif
+#ifdef sunos
+# include <dlfcn.h>
+ void *h;
+ int val;
+
+ if (_isSmallInteger(low) && _isSmallInteger(hi)) {
+ val = (_intVal(hi) << 16) + _intVal(low);
+ h = (void *)(val);
+ printf("close handle = %x\n", h);
+ dlclose(h);
+ }
+#endif
%}
!
@@ -828,6 +866,28 @@
}
}
#endif
+#ifdef sunos
+# include <dlfcn.h>
+ void *h;
+ void *addr;
+ int val;
+
+ if (_isSmallInteger(low) && _isSmallInteger(hi)) {
+ val = (_intVal(hi) << 16) + _intVal(low);
+ h = (void *)(val);
+ if (_isString(aString)) {
+ printf("get sym <%s> handle = %x\n", _stringVal(aString), h);
+ addr = dlsym(h, _stringVal(aString));
+ if (addr) {
+ 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());
+ }
+ }
+ }
+#endif
#ifdef NeXT
unsigned long addr;
long result;
@@ -837,7 +897,7 @@
printf("get sym <%s>\n", _stringVal(aString));
errOut = NXOpenFile(2, 2);
result = rld_lookup(errOut,
- _stringVal(aString),
+ (char *) _stringVal(aString),
&addr);
NXClose(errOut);
if (result) {
--- a/ObjectFileLoader.st Wed Oct 13 01:25:45 1993 +0100
+++ b/ObjectFileLoader.st Wed Oct 13 01:26:26 1993 +0100
@@ -28,7 +28,7 @@
(goal is to allow loading of binary classes)
-%W% %E%
+$Header: /cvs/stx/stx/libcomp/ObjectFileLoader.st,v 1.2 1993-10-13 00:25:54 claus Exp $
'!
%{
@@ -700,11 +700,19 @@
].
initAddr := self getSymbol:symName from:handle.
initAddr isNil ifTrue:[
- Transcript showCr:('no symbol: ',symName,' in ',aFileName).
- ^ nil
+ className := Smalltalk classNameForFile:className.
+ OperatingSystem getOSType = 'sys5.4' ifTrue:[
+ symName := '_' , className , '_Init'
+ ] ifFalse:[
+ symName := '__' , className , '_Init'
+ ].
+ initAddr := self getSymbol:symName from:handle.
+ initAddr isNil ifTrue:[
+ Transcript showCr:('no symbol: ',symName,' in ',aFileName).
+ ^ nil
+ ].
].
self callFunctionAt:initAddr.
- ^ self
! !
!ObjectFileLoader class methodsFor:'dynamic object access'!
@@ -734,14 +742,32 @@
}
}
#endif
+#ifdef sunos
+# include <dlfcn.h>
+ void *handle;
+
+ if ((pathName == nil) || _isString(pathName)) {
+ if (pathName == nil)
+ handle = dlopen((char *)0, 1);
+ else
+ handle = dlopen(_stringVal(pathName), 1);
+ if (handle) {
+ printf("open %s handle = %x\n", _stringVal(pathName), handle);
+ low = _MKSMALLINT( (int)handle & 0xFFFF );
+ hi = _MKSMALLINT( ((int)handle >> 16) & 0xFFFF );
+ } else {
+ printf("dlopen %s error: <%s>\n", _stringVal(pathName), dlerror());
+ }
+ }
+#endif
#ifdef NeXT
long result;
char *files[2];
NXStream *errOut;
if (_isString(pathName)) {
- files[0] = _stringVal(pathName);
- files[1] = (char *)0;
+ files[0] = (char *) _stringVal(pathName);
+ files[1] = (char *) 0;
errOut = NXOpenFile(2, 2);
result = rld_load(errOut,
(struct mach_header **)0,
@@ -793,6 +819,18 @@
dlclose(h);
}
#endif
+#ifdef sunos
+# include <dlfcn.h>
+ void *h;
+ int val;
+
+ if (_isSmallInteger(low) && _isSmallInteger(hi)) {
+ val = (_intVal(hi) << 16) + _intVal(low);
+ h = (void *)(val);
+ printf("close handle = %x\n", h);
+ dlclose(h);
+ }
+#endif
%}
!
@@ -828,6 +866,28 @@
}
}
#endif
+#ifdef sunos
+# include <dlfcn.h>
+ void *h;
+ void *addr;
+ int val;
+
+ if (_isSmallInteger(low) && _isSmallInteger(hi)) {
+ val = (_intVal(hi) << 16) + _intVal(low);
+ h = (void *)(val);
+ if (_isString(aString)) {
+ printf("get sym <%s> handle = %x\n", _stringVal(aString), h);
+ addr = dlsym(h, _stringVal(aString));
+ if (addr) {
+ 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());
+ }
+ }
+ }
+#endif
#ifdef NeXT
unsigned long addr;
long result;
@@ -837,7 +897,7 @@
printf("get sym <%s>\n", _stringVal(aString));
errOut = NXOpenFile(2, 2);
result = rld_lookup(errOut,
- _stringVal(aString),
+ (char *) _stringVal(aString),
&addr);
NXClose(errOut);
if (result) {
--- a/ParseNode.st Wed Oct 13 01:25:45 1993 +0100
+++ b/ParseNode.st Wed Oct 13 01:26:26 1993 +0100
@@ -11,7 +11,7 @@
"
Object subclass:#ParseNode
- instanceVariableNames:'type'
+ instanceVariableNames:'type comments'
classVariableNames:''
poolDictionaries:''
category:'System-Compiler-Support'
@@ -22,7 +22,7 @@
COPYRIGHT (c) 1989-93 by Claus Gittinger
All Rights Reserved
-%W% %E%
+$Header: /cvs/stx/stx/libcomp/ParseNode.st,v 1.2 1993-10-13 00:25:59 claus Exp $
'!
!ParseNode class methodsFor:'instance creation'!
--- a/Parser.st Wed Oct 13 01:25:45 1993 +0100
+++ b/Parser.st Wed Oct 13 01:26:26 1993 +0100
@@ -18,11 +18,12 @@
methodVars methodVarNames
tree
currentBlock
- usedInstVars usedClassVars
+ usedInstVars usedClassVars usedVars
modifiedInstVars modifiedClassVars
localVarDefPosition
evalExitBlock
- selfNode superNode primNr logged'
+ selfNode superNode primNr logged
+ warnedUndefVars'
classVariableNames:'prevClass prevInstVarNames
prevClassVarNames prevClassInstVarNames'
poolDictionaries:''
@@ -42,7 +43,7 @@
a method - this is done by sending parseXXX message to a parser and asking
the parser for referencedXVars or modifiedXVars (see SystemBrowser).
-%W% %E%
+$Header: /cvs/stx/stx/libcomp/Parser.st,v 1.2 1993-10-13 00:26:01 claus Exp $
'!
!Parser class methodsFor:'evaluating expressions'!
@@ -230,242 +231,6 @@
^ parser
! !
-!Parser class methodsFor:'explaining'!
-
-explain:someText in:source forClass:aClass
- "this is just a q&d implementation - there could be much more"
-
- |parser variables v c string sym list count tmp|
-
- string := someText withoutSeparators.
- parser := self parseMethod:source in:aClass.
- parser notNil ifTrue:[
- "look for variables"
-
- variables := parser methodVars.
- (variables notNil and:[variables includes:string]) ifTrue:[
- ^ string , ' is a method variable'
- ].
- variables := parser methodArgs.
- (variables notNil and:[variables includes:string]) ifTrue:[
- ^ string , ' is a method argument'
- ]
- ].
- parser isNil ifTrue:[
- parser := self for:(ReadStream on:source) in:aClass
- ].
-
- "instvars"
- variables := aClass allInstVarNames.
- (variables notNil and:[variables includes:string]) ifTrue:[
- "where is it"
- c := aClass.
- [c notNil] whileTrue:[
- v := c instVarNames.
- (v notNil and:[v includes:string]) ifTrue:[
- ^ string , ' is an instance variable in ' , c name
- ].
- c := c superclass
- ].
- self error:'oops'
- ].
- "class instvars"
- variables := aClass class allInstVarNames.
- (variables notNil and:[variables includes:string]) ifTrue:[
- "where is it"
- c := aClass.
- [c notNil] whileTrue:[
- v := c class instVarNames.
- (v notNil and:[v includes:string]) ifTrue:[
- ^ string , ' is a class instance variable in ' , c name
- ].
- c := c superclass
- ].
- self error:'oops'
- ].
- "classvars"
- c := parser inWhichClassIsClassVar:string.
- c notNil ifTrue:[
- ^ string , ' is a class variable in ' , c name
- ].
-
- string knownAsSymbol ifTrue:[
- "globals"
- sym := string asSymbol.
- (Smalltalk includesKey:sym) ifTrue:[
- (Smalltalk at:sym) isBehavior ifTrue:[
- ^ string , ' is a global variable.
-
-' , string , ' is a class in category ' , (Smalltalk at:sym) category , '.'
- ] ifFalse:[
- ^ string , ' is a global variable.
-
-Its current value is ' , (Smalltalk at:sym) classNameWithArticle , '.'
- ]
- ].
-
- list := OrderedCollection new.
- "selectors"
- Smalltalk allClassesDo:[:c|
- (c implements:sym) ifTrue:[
- list add:(c name)
- ].
- (c class implements:sym) ifTrue:[
- list add:(c name , 'class')
- ]
- ].
- count := list size.
- (count ~~ 0) ifTrue:[
- tmp := ' is a selector implemented in '.
- (count == 1) ifTrue:[
- ^ string , tmp , (list at:1) , '.'
- ].
- (count == 2) ifTrue:[
- ^ string , tmp , (list at:1) , ' and ' , (list at:2) , '.'
- ].
- (count == 3) ifTrue:[
- ^ string , tmp , '
-' , (list at:1) , ', ' , (list at:2) , ' and ' , (list at:3) , '.'
- ].
- (count == 4) ifTrue:[
- ^ string , tmp , '
-' , (list at:1) , ', ' , (list at:2) , ', ' , (list at:3), ' and ' , (list at:4) , '.'
- ].
- ^ string , tmp , count printString , ' classes.'
- ]
- ].
-
- "try for some obvious things"
- tmp := self explainPseudoVariable:string in:aClass.
- tmp notNil ifTrue:[ ^ tmp].
-
- "try syntax ..."
-
- ((string = ':=') or:[string = '_']) ifTrue:[
- ^ '<variable> := <expression>
-
-:= and _ (which is left-arrow in some fonts) mean assignment.
-The variable is bound to (i.e. points to) the value of <expression>.'
- ].
-
- (string = '^') ifTrue:[
- ^ '^ <expression>
-
-return the value of <expression> as value from the method.
-A return from within a block exits the method where the block is defined.'
- ].
-
- (string = '|') ifTrue:[
- ^ '| locals | or: [:arg | statements]
-
-| is used to mark a local variable declaration or separates arguments
-from the statements in a block. Notice, that in a block-argument declaration
-these must be prefixed by a colon character.
-| is also a selector understood by Booleans.'
- ].
-
- ((string startsWith:'(') or:[string endsWith:')']) ifTrue:[
- ^ '(<expression>)
-
-expression grouping.'
- ].
-
- ((string startsWith:'[') or:[string endsWith:']']) ifTrue:[
- ^ '[arguments | statements]
-
-defines a block.
-Blocks represent pieces of executable code. Definition of a block does
-not evaluate it. The block is evaluated by sending it a value/value:
-message.
-Blocks are often passed as arguments to Booleans (i.e. ifTrue:[...]) or
-collections (i.e. do:[...]).'
- ].
-
- string knownAsSymbol ifTrue:[
- ^ 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).'
- ].
-
- (string startsWith:'#' ) ifTrue:[
- (string startsWith:'#(' ) ifTrue:[
- ^ 'is a constant Array.
-
-The elements of a constant Array must be Number-constants, nil, true or false.
-(notice, that not all smalltalk implementations allow true, false and nil as
- constant-Array elements).'
- ].
-
- (string startsWith:'#[') ifTrue:[
- ^ 'is a constant ByteArray.
-
-The elements of a constant ByteArray must be Integer constants in the range
-0 .. 255.
-(notice, that not all smalltalk implementations support constant ByteArrays).'
- ].
-
- ^ 'is 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).'
- ].
-
- parser isNil ifTrue:[
- ^ 'parse error -no explanation'
- ].
- ^ 'cannot explain this - select individual tokens for an explanation.'
-!
-
-explainPseudoVariable:string in:aClass
- "return explanation for the pseudoVariables self, super etc."
-
- (string = 'self') ifTrue:[
- ^ 'self refers to the object which received the message.
-
-In this case, it will be an instance of ' , aClass name , '
-or one of its subclasses.'
- ].
-
- (string = 'super') ifTrue:[
- ^ 'like self, super refers to the object which received the message.
-
-However, when sending a message to super the search for methods
-implementing this message will start in the superclass (' , aClass superclass name , ')
-instead of selfs class.'
- ].
-
- (string = 'true') ifTrue:[
- ^ 'true is a pseudo variable (i.e. it is built in).
-
-True represents logical truth. It is the one and only instance of class True.'
- ].
-
- (string = 'thisContext') ifTrue:[
- ^ 'thisContext is a pseudo variable (i.e. it is built in).
-
-ThisContext always refers to the context object for the currently executed Method or
-Block (an instance of Context or BlockContext respectively). The calling chain and calling
-selectors can be accessed via thisContext.'
- ].
-
- (string = 'false') ifTrue:[
- ^ 'false is a pseudo variable (i.e. it is built in).
-
-False represents logical falseness. It is the one and only instance of class False.'
- ].
-
- (string = 'nil') ifTrue:[
- ^ 'nil is a pseudo variable (i.e. it is built in).
-
-Nil is used for unitialized variables (among other uses).
-Nil is the one and only instance of class UndefinedObject.'
- ].
- ^ nil
-! !
-
!Parser methodsFor:'ST-80 compatibility'!
evaluate:aString in:aClass to:to notifying:aRequestor ifFail:failBlock
@@ -580,6 +345,12 @@
^ methodVarNames
!
+usedVars
+ "return a collection with variablenames refd by method"
+
+ ^ usedVars
+!
+
usedInstVars
"return a collection with instvariablenames refd by method"
@@ -659,7 +430,8 @@
!
correctableError:message position:pos1 to:pos2
- "report an error which can be corrected by compiler"
+ "report an error which can be corrected by compiler -
+ return true if correction is wanted"
|correctIt|
@@ -676,7 +448,23 @@
!
undefError:aName position:pos1 to:pos2
- "report an undefined variable error"
+ "report an undefined variable error - return true, if it should be
+ corrected"
+
+ requestor isNil ifTrue:[
+ warnedUndefVars notNil ifTrue:[
+ (warnedUndefVars includes:aName) ifTrue:[
+ "already warned about this one"
+ ^ false
+ ].
+ ].
+ self showErrorMessage:('Error: ' , aName , ' is undefined') position:pos1.
+ warnedUndefVars isNil ifTrue:[
+ warnedUndefVars := Set new.
+ ].
+ warnedUndefVars add:aName.
+ ^ false
+ ].
^ self correctableError:('Error: ' , aName , ' is undefined')
position:pos1 to:pos2
@@ -962,28 +750,28 @@
|receiver arg sel args pos pos2|
+ pos := tokenPosition.
receiver := self keywordExpression.
(receiver == #Error) ifTrue:[^ #Error].
[tokenType == $;] whileTrue:[
+ receiver isMessage ifFalse:[
+ self syntaxError:'left side of cascade must be a message expression'
+ position:pos to:tokenPosition
+ ].
self nextToken.
(tokenType == #Identifier) ifTrue:[
sel := tokenName.
- self selectorCheck:sel position:tokenPosition
- to:(tokenPosition + sel size - 1).
- receiver := CascadeNode receiver:receiver
- selector:sel.
+ self selectorCheck:sel position:tokenPosition to:(tokenPosition + sel size - 1).
+ receiver := CascadeNode receiver:receiver selector:sel.
self nextToken
] ifFalse:[
(tokenType == #BinaryOperator) ifTrue:[
sel := tokenName.
- self selectorCheck:sel position:tokenPosition
- to:(tokenPosition + sel size - 1).
+ self selectorCheck:sel position:tokenPosition to:(tokenPosition + sel size - 1).
self nextToken.
arg := self unaryExpression.
(arg == #Error) ifTrue:[^ #Error].
- receiver := CascadeNode receiver:receiver
- selector:sel
- arg:arg
+ receiver := CascadeNode receiver:receiver selector:sel arg:arg
] ifFalse:[
(tokenType == #Keyword) ifTrue:[
pos := tokenPosition.
@@ -1001,14 +789,11 @@
pos2 := tokenPosition
].
self selectorCheck:sel position:pos to:pos2.
- receiver := CascadeNode receiver:receiver
- selector:sel
- args:args
+ receiver := CascadeNode receiver:receiver selector:sel args:args
] ifFalse:[
(tokenType == #Error) ifTrue:[^ #Error].
- self syntaxError:('invalid cascade; '
- , tokenType printString
- , ' unexpected').
+ self syntaxError:('invalid cascade; ' , tokenType printString , ' unexpected')
+ position:tokenPosition to:source position - 1.
^ #Error
]
]
@@ -1020,7 +805,7 @@
keywordExpression
"parse a keyword-expression; return a node-tree, nil or #Error"
- |receiver sel arg args pos1 pos2 try lno|
+ |receiver sel arg args pos1 pos2 try lno note|
receiver := self binaryExpression.
(receiver == #Error) ifTrue:[^ #Error].
@@ -1049,6 +834,10 @@
] ifFalse:[
receiver := try
].
+ note := receiver plausibilityCheck.
+ note notNil ifTrue:[
+ self warning:note position:pos1 to:pos2
+ ].
receiver lineNumber:lno
].
^ receiver
@@ -1193,6 +982,17 @@
].
^ val
].
+ (tokenType == #Self) ifTrue:[
+ self nextToken.
+ (tokenType == $_) ifTrue:[
+ self parseError:'assignment to self' position:pos to:tokenPosition.
+ ^ #Error
+ ].
+ selfNode isNil ifTrue:[
+ selfNode := PrimaryNode type:#Self value:selfValue
+ ].
+ ^ selfNode
+ ].
(tokenType == #String) ifTrue:[
val := ConstantNode type:tokenType value:tokenValue.
self nextToken.
@@ -1235,17 +1035,6 @@
].
^ ConstantNode type:#False value:false
].
- (tokenType == #Self) ifTrue:[
- self nextToken.
- (tokenType == $_) ifTrue:[
- self parseError:'assignment to self' position:pos to:tokenPosition.
- ^ #Error
- ].
- selfNode isNil ifTrue:[
- selfNode := PrimaryNode type:#Self value:selfValue
- ].
- ^ selfNode
- ].
(tokenType == #Super) ifTrue:[
self nextToken.
(tokenType == $_) ifTrue:[
@@ -1412,6 +1201,12 @@
(usedInstVars includes:varName) ifFalse:[
usedInstVars add:varName
].
+ usedVars isNil ifTrue:[
+ usedVars := OrderedCollection new
+ ].
+ (usedVars includes:varName) ifFalse:[
+ usedVars add:varName
+ ].
^ PrimaryNode type:#InstanceVariable
name:varName
index:instIndex
@@ -1431,6 +1226,12 @@
instIndex notNil ifTrue:[
aClass := self inWhichClassIsClassInstVar:varName.
aClass notNil ifTrue:[
+ usedVars isNil ifTrue:[
+ usedVars := OrderedCollection new
+ ].
+ (usedVars includes:varName) ifFalse:[
+ usedVars add:varName
+ ].
^ PrimaryNode type:#ClassInstanceVariable
name:varName
index:instIndex
@@ -1466,6 +1267,12 @@
(usedClassVars includes:varName) ifFalse:[
usedClassVars add:varName
].
+ usedVars isNil ifTrue:[
+ usedVars := OrderedCollection new
+ ].
+ (usedVars includes:varName) ifFalse:[
+ usedVars add:varName
+ ].
^ PrimaryNode type:#ClassVariable
name:(aClass name , ':' , varName) asSymbol
]
@@ -1475,6 +1282,12 @@
"is it a global-variable ?"
tokenSymbol := varName asSymbol.
(Smalltalk includesKey:tokenSymbol) ifTrue:[
+ usedVars isNil ifTrue:[
+ usedVars := OrderedCollection new
+ ].
+ (usedVars includes:varName) ifFalse:[
+ usedVars add:varName
+ ].
^ PrimaryNode type:#GlobalVariable
name:tokenSymbol
].
@@ -1556,9 +1369,7 @@
(tokenType ~~ $| ) ifTrue:[
"ST-80 allows [:arg ]"
(tokenType == $] ) ifTrue:[
- node := BlockNode arguments:args.
- node home:currentBlock.
- ^ node
+ ^ BlockNode arguments:args home:currentBlock variables:nil.
].
self syntaxError:'| expected after block-arg declaration'.
^ #Error
@@ -1583,9 +1394,7 @@
].
self nextToken
].
- node := BlockNode arguments:args.
- node home:currentBlock.
- node variables:vars.
+ node := BlockNode arguments:args home:currentBlock variables:vars.
currentBlock := node.
stats := self blockStatementList.
node statements:stats.
--- a/PrimNd.st Wed Oct 13 01:25:45 1993 +0100
+++ b/PrimNd.st Wed Oct 13 01:26:26 1993 +0100
@@ -22,7 +22,7 @@
COPYRIGHT (c) 1990-93 by Claus Gittinger
All Rights Reserved
-%W% %E%
+$Header: /cvs/stx/stx/libcomp/Attic/PrimNd.st,v 1.2 1993-10-13 00:26:06 claus Exp $
Primitives are currently not supported by the compiler - if you
want a primitive, you must use the stc-compiler and link a new smalltalk.
--- a/PrimaryNd.st Wed Oct 13 01:25:45 1993 +0100
+++ b/PrimaryNd.st Wed Oct 13 01:26:26 1993 +0100
@@ -22,7 +22,7 @@
COPYRIGHT (c) 1989-93 by Claus Gittinger
All Rights Reserved
-%W% %E%
+$Header: /cvs/stx/stx/libcomp/Attic/PrimaryNd.st,v 1.2 1993-10-13 00:26:09 claus Exp $
written 88 by claus
'!
--- a/PrimaryNode.st Wed Oct 13 01:25:45 1993 +0100
+++ b/PrimaryNode.st Wed Oct 13 01:26:26 1993 +0100
@@ -22,7 +22,7 @@
COPYRIGHT (c) 1989-93 by Claus Gittinger
All Rights Reserved
-%W% %E%
+$Header: /cvs/stx/stx/libcomp/PrimaryNode.st,v 1.2 1993-10-13 00:26:09 claus Exp $
written 88 by claus
'!
--- a/PrimitiveNode.st Wed Oct 13 01:25:45 1993 +0100
+++ b/PrimitiveNode.st Wed Oct 13 01:26:26 1993 +0100
@@ -22,7 +22,7 @@
COPYRIGHT (c) 1990-93 by Claus Gittinger
All Rights Reserved
-%W% %E%
+$Header: /cvs/stx/stx/libcomp/PrimitiveNode.st,v 1.2 1993-10-13 00:26:06 claus Exp $
Primitives are currently not supported by the compiler - if you
want a primitive, you must use the stc-compiler and link a new smalltalk.
--- a/RetNode.st Wed Oct 13 01:25:45 1993 +0100
+++ b/RetNode.st Wed Oct 13 01:26:26 1993 +0100
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1989-93 by Claus Gittinger
All Rights Reserved
-%W% %E%
+$Header: /cvs/stx/stx/libcomp/Attic/RetNode.st,v 1.2 1993-10-13 00:26:13 claus Exp $
'!
!ReturnNode methodsFor:'accessing'!
--- a/ReturnNode.st Wed Oct 13 01:25:45 1993 +0100
+++ b/ReturnNode.st Wed Oct 13 01:26:26 1993 +0100
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1989-93 by Claus Gittinger
All Rights Reserved
-%W% %E%
+$Header: /cvs/stx/stx/libcomp/ReturnNode.st,v 1.2 1993-10-13 00:26:13 claus Exp $
'!
!ReturnNode methodsFor:'accessing'!
--- a/Scanner.st Wed Oct 13 01:25:45 1993 +0100
+++ b/Scanner.st Wed Oct 13 01:26:26 1993 +0100
@@ -16,7 +16,8 @@
tokenName tokenLineNr
thisChar peekChar
requestor exitBlock
- errorFlag'
+ errorFlag
+ saveComments currentComments'
classVariableNames:'typeArray actionArray'
poolDictionaries:''
category:'System-Compiler'
@@ -28,7 +29,7 @@
All Rights Reserved
Scanner reads from a stream and returns individual smalltalk tokens
-%W% %E%
+$Header: /cvs/stx/stx/libcomp/Scanner.st,v 1.2 1993-10-13 00:26:15 claus Exp $
'!
!Scanner class methodsFor:'instance creation'!
@@ -50,6 +51,8 @@
errorFlag := false.
tokenLineNr := 1.
source := aStream.
+ currentComments := nil.
+ saveComments := false.
actionArray isNil ifTrue:[
actionArray := Array new:256.
@@ -90,19 +93,21 @@
]
!
+initialize
+ "prepare a scan"
+
+ errorFlag := false.
+ tokenLineNr := 1.
+ currentComments := nil.
+ saveComments := false.
+!
+
notifying:anObject
"set the requestor to be notified"
requestor := anObject
!
-initialize
- "prepare a scan"
-
- errorFlag := false.
- tokenLineNr := 1
-!
-
backupPosition
"if reading from a stream, at the end we might have read
one token too many"
@@ -184,10 +189,38 @@
!Scanner methodsFor:'reading next token'!
+skipComment
+ |comment|
+
+ comment := ''.
+
+ source next.
+ thisChar := source peek.
+ [thisChar notNil and:[thisChar ~~ (Character doubleQuote)]] whileTrue:[
+ thisChar == (Character cr) ifTrue:[
+ tokenLineNr := tokenLineNr + 1.
+ ].
+ saveComments ifTrue:[
+ comment := comment copyWith:thisChar
+ ].
+ source next.
+ thisChar := source peek
+ ].
+ saveComments ifTrue:[
+ currentComments isNil ifTrue:[
+ currentComments := OrderedCollection with:comment
+ ] ifFalse:[
+ currentComments add:comment
+ ]
+ ].
+ "skip final dQuote"
+ source next.
+!
+
nextToken
"return the next token from the source-stream"
- |skipping actionBlock|
+ |skipping actionBlock comment|
peekChar notNil ifTrue:[
thisChar := peekChar.
@@ -201,23 +234,10 @@
source next
] ifFalse:[
thisChar == (Character doubleQuote) ifTrue:[
- source next.
+ "start of a comment"
+
+ self skipComment.
thisChar := source peek.
- [thisChar notNil and:[thisChar ~~ (Character doubleQuote)]] whileTrue:[
- thisChar == (Character cr) ifTrue:[
- tokenLineNr := tokenLineNr + 1.
- ].
- source next.
- thisChar := source peek
- ].
- source next.
- thisChar := source peek.
-"
- thisChar == (Character cr) ifTrue:[
- tokenLineNr := tokenLineNr + 1.
- ].
-"
- "thisChar := source skipFor:(Character doubleQuote) "
] ifFalse:[
skipping := false
]
@@ -345,6 +365,9 @@
value := value asFloat + (self nextMantissa:radix).
nextChar := source peek
] ifFalse:[
+ nextChar == (Character cr) ifTrue:[
+ tokenLineNr := tokenLineNr + 1.
+ ].
peekChar := $.
]
].
@@ -487,7 +510,6 @@
nextHash
|nextChar string|
- tokenType := #Symbol.
nextChar := source nextPeek.
nextChar notNil ifTrue:[
nextChar isAlphaNumeric ifTrue:[
@@ -497,12 +519,14 @@
nextChar := source peek.
(nextChar == $:) ifFalse:[
tokenValue := string asSymbol.
- ^ self
+ tokenType := #Symbol.
+ ^ tokenType
].
string := string copyWith:nextChar.
nextChar := source nextPeek
].
tokenValue := string asSymbol.
+ tokenType := #Symbol.
^ tokenType
].
(nextChar == $( ) ifTrue:[
@@ -535,12 +559,21 @@
]
].
tokenValue := string asSymbol.
+ tokenType := #Symbol.
^ tokenType
]
].
+ "this allows hash to be used as binop -
+ I dont know, if this is correct ..."
+
+ tokenName := '#'.
+ tokenType := BinaryOperator.
+ ^ tokenType
+"
self syntaxError:'unexpected end-of-input in Symbol'
position:tokenPosition to:(tokenPosition + 1).
^ #Error
+"
!
nextString
--- a/StatNode.st Wed Oct 13 01:25:45 1993 +0100
+++ b/StatNode.st Wed Oct 13 01:26:26 1993 +0100
@@ -22,7 +22,7 @@
COPYRIGHT (c) 1989-93 by Claus Gittinger
All Rights Reserved
-%W% %E%
+$Header: /cvs/stx/stx/libcomp/Attic/StatNode.st,v 1.2 1993-10-13 00:26:18 claus Exp $
'!
!StatementNode class methodsFor:'instance creation'!
--- a/StatementNode.st Wed Oct 13 01:25:45 1993 +0100
+++ b/StatementNode.st Wed Oct 13 01:26:26 1993 +0100
@@ -22,7 +22,7 @@
COPYRIGHT (c) 1989-93 by Claus Gittinger
All Rights Reserved
-%W% %E%
+$Header: /cvs/stx/stx/libcomp/StatementNode.st,v 1.2 1993-10-13 00:26:18 claus Exp $
'!
!StatementNode class methodsFor:'instance creation'!
--- a/UnaryNd.st Wed Oct 13 01:25:45 1993 +0100
+++ b/UnaryNd.st Wed Oct 13 01:26:26 1993 +0100
@@ -22,7 +22,7 @@
COPYRIGHT (c) 1989-93 by Claus Gittinger
All Rights Reserved
-%W% %E%
+$Header: /cvs/stx/stx/libcomp/Attic/UnaryNd.st,v 1.2 1993-10-13 00:26:20 claus Exp $
'!
!UnaryNode class methodsFor:'instance creation'!
@@ -100,8 +100,6 @@
!UnaryNode methodsFor:'checks'!
plausibilityCheck
- |rec arg operand|
-
"check for funny selector - careful to do string compare instead
of symbol identity compare: I dont want to introduce these as symbols
into the system (would make the '... is nowhere implemented' warning
@@ -112,6 +110,7 @@
(Smalltalk includesKey:selector)]]) ifTrue:[
^ 'funny selector; possible missing ''.'' or keyword'
].
+ "more to come ..."
^ nil
! !
--- a/UnaryNode.st Wed Oct 13 01:25:45 1993 +0100
+++ b/UnaryNode.st Wed Oct 13 01:26:26 1993 +0100
@@ -22,7 +22,7 @@
COPYRIGHT (c) 1989-93 by Claus Gittinger
All Rights Reserved
-%W% %E%
+$Header: /cvs/stx/stx/libcomp/UnaryNode.st,v 1.2 1993-10-13 00:26:20 claus Exp $
'!
!UnaryNode class methodsFor:'instance creation'!
@@ -100,8 +100,6 @@
!UnaryNode methodsFor:'checks'!
plausibilityCheck
- |rec arg operand|
-
"check for funny selector - careful to do string compare instead
of symbol identity compare: I dont want to introduce these as symbols
into the system (would make the '... is nowhere implemented' warning
@@ -112,6 +110,7 @@
(Smalltalk includesKey:selector)]]) ifTrue:[
^ 'funny selector; possible missing ''.'' or keyword'
].
+ "more to come ..."
^ nil
! !
--- a/UndefVar.st Wed Oct 13 01:25:45 1993 +0100
+++ b/UndefVar.st Wed Oct 13 01:26:26 1993 +0100
@@ -28,7 +28,7 @@
The error message will then be "UndefinedVariable ..." instead of
"UndefineObject ..."
-%W% %E%
+$Header: /cvs/stx/stx/libcomp/Attic/UndefVar.st,v 1.2 1993-10-13 00:26:22 claus Exp $
'!
!UndefinedVariable class methodsFor:'instance creation'!
--- a/UndefinedVariable.st Wed Oct 13 01:25:45 1993 +0100
+++ b/UndefinedVariable.st Wed Oct 13 01:26:26 1993 +0100
@@ -28,7 +28,7 @@
The error message will then be "UndefinedVariable ..." instead of
"UndefineObject ..."
-%W% %E%
+$Header: /cvs/stx/stx/libcomp/UndefinedVariable.st,v 1.2 1993-10-13 00:26:22 claus Exp $
'!
!UndefinedVariable class methodsFor:'instance creation'!
--- a/Variable.st Wed Oct 13 01:25:45 1993 +0100
+++ b/Variable.st Wed Oct 13 01:26:26 1993 +0100
@@ -22,7 +22,7 @@
COPYRIGHT (c) 1989-92 by Claus Gittinger
All Rights Reserved
-%W% %E%
+$Header: /cvs/stx/stx/libcomp/Variable.st,v 1.2 1993-10-13 00:26:24 claus Exp $
'!
!Variable class methodsFor:'instance creation'!