Hi,
Nathan Cain <[EMAIL PROTECTED]> writes:
> I was hoping to toy with this some, and start in on adapting an arm
> backend...
Cool! I'd be more than happy to help with this process, if you need
any assistance at all. I think most of it should be relatively
straightforward by staring at the patch to CodeGenerator-i386.st.
> unfortunately, the patch does not want to apply, as it seems to
> expect a different jolt2/boot.k then what is in svn r407. Perhaps I
> need another of your patches as well, beyond just jolt2-fixes?
> Could you tell me which?
Actually, I just described the patch requirements really badly. The
idea is:
$ svn checkout -r407 ...
$ cd idst
$ patch -p0 < ../jolt2-fixes.patch
$ patch -p0 < ../jolt2-slink.patch
I've attached new versions of these patches that fix a few issues
(forgot the '{...} grammar syntax in jolt2-fixes.patch, mangle Jolt
names that can't be directly expressed in the output) and demonstrates
the use of (syntax ...) in function/examples2/slink/main.k.
Good luck,
--
Michael FIG <[EMAIL PROTECTED]> //\
http://michael.fig.org/ \//
Get jolt2 and examples2 to work.
diff -r 2e8939abc3c6 function/examples/cairo/Makefile
--- a/function/examples/cairo/Makefile Wed Apr 23 23:45:22 2008 -0600
+++ b/function/examples/cairo/Makefile Fri Apr 25 16:12:38 2008 -0600
@@ -6,7 +6,7 @@ run test : cairolib.so .FORCE
$(JOLT) boot.k main.k
cairolib.so : cairolib.st
- $(IDC) $(CAIROINC) -I../../objects -s $<
+ $(IDC) -g -k $(CAIROINC) -I../../objects -s $<
clean : .FORCE
rm -f *~ *.so *.o
diff -r 2e8939abc3c6 function/examples/cairo/libcairo.k
--- a/function/examples/cairo/libcairo.k Wed Apr 23 23:45:22 2008 -0600
+++ b/function/examples/cairo/libcairo.k Fri Apr 25 16:12:38 2008 -0600
@@ -1,5 +1,4 @@
(dlopen "libcairo")
-(define cairolib (dlopen "cairolib"))
-((_dlsym cairolib "__id__init__"))
+[Object _import: "cairolib"]
(define libcairo (import "libcairo"))
diff -r 2e8939abc3c6 function/examples/regexp/Makefile
--- a/function/examples/regexp/Makefile Wed Apr 23 23:45:22 2008 -0600
+++ b/function/examples/regexp/Makefile Fri Apr 25 16:12:38 2008 -0600
@@ -12,55 +12,55 @@ test1 : .FORCE
test1 : .FORCE
time egrep 'break|continue|for|while|switch|case|return|static|extern' < tests/test.c | tee out.e | wc -l
time $(GREP) 'break|continue|for|while|switch|case|return|static|extern' < tests/test.c | tee out.p | wc -l
- diff out.e out.p
+ cmp out.e out.p
rm out.e out.p
test2 : .FORCE
time egrep 'd?e?l?t?a?' < tests/termcap | tee out.e | wc -l
time $(GREP) 'd?e?l?t?a?' < tests/termcap | tee out.p | wc -l
- diff out.e out.p
+ cmp out.e out.p
rm out.e out.p
test3 : .FORCE
time egrep 'd?e+l*t?a+' < tests/termcap | tee out.e | wc -l
time $(GREP) 'd?e+l*t?a+' < tests/termcap | tee out.p | wc -l
- diff out.e out.p
+ cmp out.e out.p
rm out.e out.p
test4 : .FORCE
time egrep 'd?e+l*t?a+' < tests/termcap | tee out.e | wc -l
time $(GREP) 'd?e+l*t?a+' < tests/termcap | tee out.p | wc -l
- diff out.e out.p
+ cmp out.e out.p
rm out.e out.p
test5 : .FORCE
time egrep 'p[aeiou]t' < tests/termcap | tee out.e | wc -l
time $(GREP) 'p[aeiou]t' < tests/termcap | tee out.p | wc -l
- diff out.e out.p
+ cmp out.e out.p
rm out.e out.p
test6 : .FORCE
time egrep 'p[^aeiou]t' < tests/termcap | tee out.e | wc -l
time $(GREP) 'p[^aeiou]t' < tests/termcap | tee out.p | wc -l
- diff out.e out.p
+ cmp out.e out.p
rm out.e out.p
test7 : .FORCE
time egrep '19[0-9]+' < tests/termcap | tee out.e | wc -l
time $(GREP) '19[0-9]+' < tests/termcap | tee out.p | wc -l
- diff out.e out.p
+ cmp out.e out.p
rm out.e out.p
test8 : .FORCE
time egrep '19[^0-9]+' < tests/termcap | tee out.e | wc -l
time $(GREP) '19[^0-9]+' < tests/termcap | tee out.p | wc -l
- diff out.e out.p
+ cmp out.e out.p
rm out.e out.p
test9 : .FORCE
time egrep '..a.....b' < tests/termcap | tee out.e | wc -l
time $(GREP) '..a.....b' < tests/termcap | tee out.p | wc -l
- diff out.e out.p
+ cmp out.e out.p
rm out.e out.p
diff -r 2e8939abc3c6 function/jolt2/ColaGrammar.st
--- a/function/jolt2/ColaGrammar.st Wed Apr 23 23:45:22 2008 -0600
+++ b/function/jolt2/ColaGrammar.st Fri Apr 25 16:12:38 2008 -0600
@@ -17,6 +17,7 @@ ColaParsingGrammar := [ Grammar new ]
at: #comment put: ( '//' parse , (#eol parse not , PeAny) zeroMore , #eol parse);
at: #_ put: ( _ := ( (#space parse | #comment parse) zeroMore ) ).
g at: #pling put: '!' parse , _;
+ at: #EXTENDS put: 'EXTENDS:' parse , _;
at: #lparen put: '(' parse , _;
at: #rparen put: ')' parse , _;
at: #query put: '?' parse , _;
@@ -67,9 +68,11 @@ ColaParsingGrammar := [ Grammar new ]
| ( ( #larrow parse , #number parse <- [:p | ([EMAIL PROTECTED]) <- p result] ->0 ) zeroOne <- [:p | [EMAIL PROTECTED] ) ) ).
g at: #sequence put: ( #suffix parse ->0 , ( #suffix parse <- [:p | ([EMAIL PROTECTED]) , p result] ->0 ) zeroMore <- [:p | [EMAIL PROTECTED] ).
g at: #expression put: ( #sequence parse ->0 , ( #bar parse , #sequence parse <- [:p | ([EMAIL PROTECTED]) | p result] ->0 ) zeroMore <- [:p | [EMAIL PROTECTED] ).
- g at: #grammar put: ( [Grammar new] setResult ->0
+ g at: #grammar put: ( [Grammar new] setResult ->0 , _
, ( #identifier parse ->1 , #equal parse , #expression parse , #semicolon parse zeroOne <- [:p | [EMAIL PROTECTED] at: [EMAIL PROTECTED] put: p result] ) zeroMore
+ , ( #EXTENDS parse , ( ColaFunctionGrammar-#expression ) <- [:p | [EMAIL PROTECTED] extends: p result _eval] , _ ) zeroMore
, ( #expression parse <- [:p | [EMAIL PROTECTED] startRule: p result] ) zeroOne
+
) <- [:p | ([EMAIL PROTECTED]) finalise "println"].
]
@@ -88,9 +91,9 @@ ColaParsingGrammar := [ Grammar new ]
at: #other put: '-+!#$%&*./:<=>[EMAIL PROTECTED]|~' parseClass.
g at: #identifier put: ( ( #alpha parse | #other parse ) , ( #alpha parse | #digit parse | #other parse ) zeroMore ) textResult <- [:p | p result asSymbol].
g at: #decimal put: ( #digit parse oneMore textResult <- [:p | p result inject: 0 into: [:n :c | n * 10 + c digitValue]] );
- at: #heximal put: ( ( '0x' parse , ( #digit parse | #hex parse ) oneMore ) textResult <- [:p | p result inject: 0 into: [:n :c | n * 16 + c digitValue]] );
+ at: #heximal put: ( '0x' parse , ( ( #digit parse | #hex parse ) oneMore textResult <- [:p | p result inject: 0 into: [:n :c | n * 16 + c digitValue]] ) );
at: #posfloat put: ( #decimal parse -> 0 , '.' parse , ( #digit parse oneMore textResult ) -> 1 <- [:p | ([EMAIL PROTECTED] reverseInject: 0.0 into: [:n :c | n / 10.0 + c digitValue]) / 10.0 + ([EMAIL PROTECTED])] );
- at: #posnumber put: ( #decimal parse | #heximal parse | #posfloat parse );
+ at: #posnumber put: ( #heximal parse | #posfloat parse | #decimal parse );
at: #number put: ( ( '-' parse , #posnumber parse <- [:p | p result negated] )
| ( '+' parse zeroMore , #posnumber parse ) ).
g at: #plainChar put: ( PeAny textResult <- [:p | p last] );
@@ -109,8 +112,8 @@ ColaParsingGrammar := [ Grammar new ]
g at: #unary put: ( ( #alpha parse , ( #alpha parse | #digit parse ) zeroMore ) textResult, _ );
at: #binary put: ( ( '-+!%&*,/<=>[EMAIL PROTECTED]|~' parseClass oneMore ) textResult , _ );
at: #keyword put: ( ( #alpha parse , ( #alpha parse | #digit parse ) zeroMore , ':' parse ) textResult , _ ).
- g at: #unymsg put: ( #unary parse ->0 <- [:p | Array with: [EMAIL PROTECTED] );
- at: #binmsg put: ( #binary parse ->0 , #expr parse ->1 , _ <- [:p | Array with: [EMAIL PROTECTED] with: [EMAIL PROTECTED] );
+ g at: #unymsg put: ( #unary parse ->0 <- [:p | OrderedCollection with: [EMAIL PROTECTED] );
+ at: #binmsg put: ( #binary parse ->0 , #expr parse ->1 , _ <- [:p | OrderedCollection with: [EMAIL PROTECTED] with: [EMAIL PROTECTED] );
at: #keyarg put: ( #keyword parse ->0 , #expr parse ->1 , _ <- [:p | OrderedCollection with: [EMAIL PROTECTED] with: [EMAIL PROTECTED] );
at: #keymsg put: ( #keyarg parse ->0 , ( #keyword parse ->1 , #expr parse ->2 , _ <- [:p | ([EMAIL PROTECTED]) first: ([EMAIL PROTECTED]) first, ([EMAIL PROTECTED]); add: ([EMAIL PROTECTED]); yourself]
) zeroMore <- [:p | ([EMAIL PROTECTED])]
@@ -129,7 +132,7 @@ ColaParsingGrammar := [ Grammar new ]
at: #expression put: _ , ( #expr parse | #eof parse | #error parse ).
]
-"mutually recursive rules between the above grammars can now be resolve"
+"mutually recursive rules between the above grammars can now be resolved"
[
ColaParsingGrammar startSymbol: #grammar.
diff -r 2e8939abc3c6 function/jolt2/Compiler.st
--- a/function/jolt2/Compiler.st Wed Apr 23 23:45:22 2008 -0600
+++ b/function/jolt2/Compiler.st Fri Apr 25 16:12:38 2008 -0600
@@ -919,7 +919,7 @@ Compiler xEvaluate: form
Compiler errorUndefined: aSymbol [ self error: 'undefined: ', aSymbol ]
Compiler errorSyntax: form [ self error: 'syntax error: ', form printString ]
-Compiler errorArgumentCount: form [ self error: 'wrong number of aguments: ', form printString ]
+Compiler errorArgumentCount: form [ self error: 'wrong number of arguments: ', form printString ]
Compiler errorLoop: form [ self error: 'no loop: ', form printString ]
"----------------------------------------------------------------"
diff -r 2e8939abc3c6 function/jolt2/Grammar.st
--- a/function/jolt2/Grammar.st Wed Apr 23 23:45:22 2008 -0600
+++ b/function/jolt2/Grammar.st Fri Apr 25 16:12:38 2008 -0600
@@ -39,6 +39,11 @@ Grammar startRule: pe
startRule := PeRule withValue: pe name: #'<start>'.
dirty := true.
self finalise.
+]
+
+Grammar extends: aGrammar
+[
+ aGrammar do: [:assoc | self at: assoc key ifAbsentPut: assoc value].
]
Grammar finalise
diff -r 2e8939abc3c6 function/jolt2/Makefile
--- a/function/jolt2/Makefile Wed Apr 23 23:45:22 2008 -0600
+++ b/function/jolt2/Makefile Fri Apr 25 16:12:38 2008 -0600
@@ -28,7 +28,10 @@ all : main$(OBJEXT)
all : main$(OBJEXT)
test : main$(OBJEXT) .FORCE
- ./main$(OBJEXT) boot.k sanaras.k
+ ./main$(OBJEXT) -L../jolt-burg boot.k sanaras.k
+
+test-old: main$(OBJEXT) .FORCE
+ cd ../examples && $(MAKE) test JOLT="../../jolt2/main$(OBJEXT) -L../../jolt-burg"
.SUFFIXES :
diff -r 2e8939abc3c6 function/jolt2/Options.st
--- a/function/jolt2/Options.st Wed Apr 23 23:45:22 2008 -0600
+++ b/function/jolt2/Options.st Fri Apr 25 16:12:38 2008 -0600
@@ -20,13 +20,15 @@
{ import: Objects }
-Options : Object ( verbose compile list libdir )
+Options : Object ( verbose compile list libdir progdir )
Options verbose [ ^verbose ]
Options compile [ ^compile ]
Options list [ ^list ]
Options libdir: aString [ libdir := aString ]
Options libdir [ ^libdir ]
+Options progdir: aDir [ progdir := aDir ]
+Options progdir [ ^progdir ]
Options new
[
diff -r 2e8939abc3c6 function/jolt2/Parser.st
--- a/function/jolt2/Parser.st Wed Apr 23 23:45:22 2008 -0600
+++ b/function/jolt2/Parser.st Fri Apr 25 16:12:38 2008 -0600
@@ -113,5 +113,5 @@ Parser errorContents
Parser setResultFromFunction_: _function
{
- self->v_result= ((oop(*)())v__function)(v__closure, self, self, self->v_result);
+ self->v_result= ((oop(*)())v__function)(v__closure, v_stateful_self, v_self, self->v_result);
}
diff -r 2e8939abc3c6 function/jolt2/boot.k
--- a/function/jolt2/boot.k Wed Apr 23 23:45:22 2008 -0600
+++ b/function/jolt2/boot.k Fri Apr 25 16:12:38 2008 -0600
@@ -191,16 +191,53 @@
| error )
} match: node]))
-;; methods
-
-(define add-method ; type selector implementation
- (lambda (type selector implementation)
- [[type _vtable] methodAt: selector put: implementation with: 0]))
-
-(syntax define-send ; selector type args... expr
- (lambda (form compiler)
- (let ((selector [form second])
- (type [form third])
- (args [form copyFrom: '3 to: [[form size] - '2]])
- (expr [form last]))
- `(add-method ,type ,selector (lambda (_closure _self self ,@args) ,expr)))))
+;; Add features that aren't present in the original grammar.
+(define ColaFunctionGrammar (import "ColaFunctionGrammar"))
+(define Integer (import "Integer"))
+(define new-grammar '{
+ // Add character literals ($CHAR)
+ atom = number | charLiteral | identifier | string | grammar
+ charLiteral = '$' char->0 <- [self @ '0]
+
+ // Add octal character escapes ("\\([0-3]?[0-7])?[0-7]").
+ escapeSeq = '\\' (escapeChar | octalChar | plainChar)
+ oct = [0-7]
+ octalChar = (([0-3] oct oct) | (oct oct) | oct) $ <- [Integer fromString: [self result] base: '8]
+
+ // Binary integers.
+ posnumber = heximal | binimal | posfloat | decimal
+ binimal = '0b' [0-1]+ $ <- [Integer fromString: [self result] base: '2]
+
+ // Variadic message sends ([obj msg expr...]).
+ send = '[' _ expr->0 _ message->1 _ (expr->2 _ <- [[self @ '1] add: [self @ '2]])*
+ ']' <- [Expression with: 'send
+ with: [Expression with: 'quote with: [[[self @ '1] first] asSymbol]]
+ with: [self @ '0]
+ withAll: [self @ '1] from: '1]
+ ;
+ EXTENDS: ColaFunctionGrammar // Import from the default grammar.
+ expression // Start term
+ })
+
+[new-grammar name: 'ColaFunctionGrammar]
+(export "ColaFunctionGrammar" new-grammar)
+
+(load "syntax.k")
+(load "debug.k")
+(load "object.k")
+
+(define *package-list* [IdentitySet new])
+
+(define %require
+ (lambda (package)
+ (or [*package-list* includes: [package asSymbol]]
+ (let ()
+ (load [[[package asString] , '".k"] _stringValue])
+ [*package-list* add: [package asSymbol]]))))
+
+(syntax require
+ (lambda (node comp)
+ (let ((requires [WriteStream on: [Expression new: '8]]))
+ (for (i '1 2 [[node size] - '1])
+ [requires nextPut: `(%require ,[node at: i])])
+ `(let () ,@[requires contents]))))
diff -r 2e8939abc3c6 function/jolt2/main.st
--- a/function/jolt2/main.st Wed Apr 23 23:45:22 2008 -0600
+++ b/function/jolt2/main.st Fri Apr 25 16:12:38 2008 -0600
@@ -91,7 +91,10 @@ ColaEvaluator map: aBlock
ColaEvaluator readFileNamed: fileName
[
- self readFile: (fileName = '-' ifTrue: [StdIn] ifFalse: [File open: fileName])
+ self readFile: (fileName = '-' ifTrue: [StdIn]
+ ifFalse: [((File openIfPresent: fileName)
+ ifNil: [File openIfPresent: Options progdir, '/', fileName])
+ ifNil: [File open: Options libdir, '/', fileName]])
]
ColaEvaluator readFile: aFile
@@ -108,9 +111,14 @@ ColaEvaluator readFile: aFile
[
- | done |
+ | done args arg |
"ColaFunctionGrammar println."
+ Options progdir: (OS argumentAt: 0) dirname.
Options libdir: '.'.
- OS arguments do: [:arg | (Options parseOption: arg) ifFalse: [ColaEvaluator readFileNamed: (done := arg)]].
+ args := OS arguments.
+ [args notEmpty]
+ whileTrue:
+ [ arg := args removeFirst.
+ (Options parseOption: arg) ifFalse: [ColaEvaluator readFileNamed: (done := arg)]].
done ifFalse: [ColaEvaluator readFile: StdIn].
]
diff -r 2e8939abc3c6 function/objects/SequenceableCollection.st
--- a/function/objects/SequenceableCollection.st Wed Apr 23 23:45:22 2008 -0600
+++ b/function/objects/SequenceableCollection.st Fri Apr 25 16:12:38 2008 -0600
@@ -216,6 +216,12 @@ SequenceableCollection inject: result in
SequenceableCollection inject: result into: binaryBlock
[
self do: [:element | result := binaryBlock value: result value: element].
+ ^result
+]
+
+SequenceableCollection reverseInject: result into: binaryBlock
+[
+ self reverseDo: [:element | result := binaryBlock value: result value: element].
^result
]
Generate assembler from Jolt code.
diff -r 1e71558180f0 function/examples2/slink/README
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/function/examples2/slink/README Fri Apr 25 16:12:05 2008 -0600
@@ -0,0 +1,75 @@
+SLINK 0.3
+*********
+
+Slink is the beginning of a statically-linking compiler extension for
+Jolt2 (think "Static LINK" or "System LINK"). It was partly inspired
+by John Leuner's Common Lisp port of jolt-burg that creates
+relocatable ELF objects. I'm basically attempting to land the same
+kinds of features in COLA proper without changing too much of the
+existing compiler machinery.
+
+It has many limitations, but is a proof-of-concept and will probably
+evolve (the main direction for evolution is to make the changes less
+and less dependent on patching Jolt2's Id sources directly, and
+instead accomplish its features at runtime via slink.k and friends).
+
+The centerpiece of this system is slink-compile, which currently can
+only generate i386 assembly code. The following new syntax is
+introduced:
+
+(define (slink SYMBOL))
+ Import SYMBOL from the system linker. If running with the dynamic
+ compiler, this is equivalent to:
+
+ (active SYMBOL (dlsym "SYMBOL"))
+
+ If under the static compiler (slink-compile), this will cause future
+ references to SYMBOL to be resolved at link time rather than
+ runtime.
+
+(define (slink SYMBOL) EXPRESSION)
+ Create a region of memory containing the results of EXPRESSION.
+ SYMBOL is exported to the system linker. Only expressions resulting
+ in integers, strings, floats, and lambdas currently work.
+
+To get a feel for things, run "make test" which exercises slink both
+at runtime and compile time. You'll notice that the results of this
+execution are a binary executable (slinktest) with no runtime
+dependency on COLA.
+
+IMPLEMENTATION
+**************
+
+I did a lot of work creating a bunch of slink-specific methods in the
+existing COLA compiler. Now I'm gradually undoing as much of that
+work as possible to leave only the core features in Jolt2, so that the
+rest can be just another unprivileged application.
+
+Once you understand what the slink syntax does, it shouldn't be too
+hard to follow what I needed to do to get things working. A "grep -i
+slink *.st" is very informative (and half the reason I needed to find
+a catchy name that wouldn't be buried in the other identifiers).
+
+Toplevel Jolt expressions are gathered up and attached to the system's
+initialisation functions so that they are executed at program start
+(for i386, using the same method as C++ constructors).
+
+I'm in the process of creating a "compiler-stage" syntax which
+immediately evaluates its child expressions in the compiler instead of
+compiling them. Marking up boot.k will make it possible to be used
+for slink-compile as well.
+
+It would be really nice to implement a few more CodeGenerator backends
+to bypass assembly language entirely and generate binaries.
+
+Slink has a naive three-region model for assembler output. First
+comes a bss section with all the variables, then a data section with
+all the strings, then finally a text section with all the compiled
+functions. To my knowledge, this is adequate for the platforms on
+which COLA already runs, but of course it would be good to be able to
+provide something akin to linker scripts in the future to allow much
+more flexible layout.
+
+Have fun,
+
+Michael FIG <[EMAIL PROTECTED]>, 2008-04-17
diff -r 1e71558180f0 function/examples2/slink/main.k
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/function/examples2/slink/main.k Fri Apr 25 16:12:05 2008 -0600
@@ -0,0 +1,37 @@
+(syntax syntax-test
+ (lambda (node compiler)
+ (printf "Here's a little test of compile-time syntax.\n")
+ '(printf "Here's a little test of runtime syntax.\n")))
+
+;; FIXME: Eventually slink-compile should include this for us.
+(syntax addrof ; (addrof varName) => address of varName
+ (lambda (node compiler)
+ (or (and [[node size] = '2]
+ [[node second] isSymbol])
+ [compiler errorSyntax: node])
+ [[compiler lookupVariable: [node second]] translateLvalue: compiler]))
+
+(define (slink printf))
+(printf "Hello from constructor\n")
+(define zot 0x123456)
+;;(slink mylist '(1 2 3 "foo" 0.3456))
+(define baz zot)
+(define (slink zot_addr) zot)
+
+(define (slink hello)
+ (lambda (progname argc)
+ (printf "Have an int: 0x%x@(0x%x==0x%x), and a copy [EMAIL PROTECTED]"
+ zot (addrof zot) zot_addr baz (addrof baz))
+ (syntax-test)
+ (printf "Goodbye, world (%s with %d arguments)!\n" progname argc)))
+
+(define test2
+ (lambda ()
+ (printf "Another test from constructor\n")))
+
+(define (slink main)
+ (lambda (argc argv)
+ (hello (long@ argv) (- argc 1))
+ 0))
+
+(test2)
diff -r 1e71558180f0 function/examples2/slink/slink.k
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/function/examples2/slink/slink.k Fri Apr 25 16:12:05 2008 -0600
@@ -0,0 +1,63 @@
+(define slink-require
+ (lambda (filename compiler generator environment package-list)
+ (let ((path filename)
+ (file [File openIfPresent: filename]))
+ (or file
+ (let ()
+ (set path [[[Options libdir] , '"/"] , filename])
+ (set file [File openIfPresent: path])))
+ (or file
+ (let ()
+ (set path [[[Options progdir] , '"/"] , filename])
+ (set file [File openIfPresent: path])))
+ (if file
+ (let ((parser [ColaFunctionGrammar parserOn: file])
+ (expr 0))
+ [StdOut nextPutAll: '"; compiling: "] [StdOut nextPutAll: path] [StdOut cr]
+ (while (set expr [parser next])
+ (or (and [[expr size] = '2]
+ [[expr first] = 'require]
+ [[expr second] isArray]
+ (let ((qpackage [expr second]))
+ (and [[qpackage size] = '2]
+ [[qpackage first] = 'quote]
+ [[qpackage second] isSymbol]
+ (let ((package [qpackage second]))
+ (or [package-list includes: package]
+ (let ((filename [[package asString] , '".k"]))
+ ;; Allow code to require other packages with (require 'package).
+ (slink-require filename compiler generator environment package-list)
+ [package-list add: package]))))))
+ [compiler compile: expr for: generator with: environment])))
+ (let ()
+ [StdErr nextPutAll: '";; cannot open "]
+ [StdErr nextPutAll: filename]
+ [StdErr cr])))))
+
+
+(define slink-compile
+ (lambda (path)
+ (let ((pathstr [String value_: path])
+ (outname [pathstr , '".s"])
+ (CodeGenerator (import "CodeGenerator"))
+ (gen [[CodeGenerator default] static])
+ (SlinkEnvironment (import "SlinkEnvironment"))
+ (env [SlinkEnvironment new])
+ (Compiler (import "Compiler"))
+ (CompilerOptions (import "CompilerOptions"))
+ (package-list [IdentitySet new]))
+
+ [StdErr nextPutAll: '";; slink-compile "] [StdErr nextPutAll: pathstr]
+ [StdErr nextPutAll: '" starting"] [StdErr cr]
+
+ ;; [CompilerOptions verboseTree: '1]
+ ;(slink-require '"sboot.k" Compiler gen env package-list)
+ (slink-require pathstr Compiler gen env package-list)
+ ;; [CompilerOptions verboseTree: 0]
+
+ (let ((out [File create: outname]))
+ [StdOut nextPutAll: '"; write output to "] [StdOut nextPutAll: outname] [StdOut cr]
+ [gen toStream: out]
+ [out close])
+ [StdErr nextPutAll: '";; slink-compile "] [StdErr nextPutAll: pathstr]
+ [StdErr nextPutAll: '" finished"] [StdErr cr])))
diff -r 1e71558180f0 function/examples2/slink/test.k
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/function/examples2/slink/test.k Fri Apr 25 16:12:05 2008 -0600
@@ -0,0 +1,9 @@
+((define (slink hello) (lambda (msg) (printf "hello %s\n" msg))) "the first time")
+(define zot hello)
+(define (slink zorgar) (let () 42))
+(printf "these should match %x == %x but this %d == 42!\n" hello zot zorgar)
+(hello "the second time")
+(zot "the third time")
+
+(load "main.k")
+(hello "from test.k" 666)
diff -r 1e71558180f0 function/jolt2/CodeGenerator-arm.st
--- a/function/jolt2/CodeGenerator-arm.st Thu Apr 24 23:17:10 2008 -0600
+++ b/function/jolt2/CodeGenerator-arm.st Fri Apr 25 16:12:05 2008 -0600
@@ -29,9 +29,9 @@
ARMCodeGenerator : CodeGenerator ( tempsSize registerList r0 r1 ip sp lr pc )
-ARMCodeGenerator new
-[
- self := super new.
+ARMCodeGenerator newScope
+[
+ self := super newScope.
tempsSize := 0.
ccrs
add: (r0 := Register withClass: I4 name: 'r0' encoding: 0);
diff -r 1e71558180f0 function/jolt2/CodeGenerator-i386.st
--- a/function/jolt2/CodeGenerator-i386.st Thu Apr 24 23:17:10 2008 -0600
+++ b/function/jolt2/CodeGenerator-i386.st Fri Apr 25 16:12:05 2008 -0600
@@ -29,9 +29,9 @@
Intel32CodeGenerator : CodeGenerator ( tempsSize eax ecx edx ebx esp ebp esi edi cx cl )
-Intel32CodeGenerator new
-[
- self := super new.
+Intel32CodeGenerator newScope
+[
+ self := super newScope.
tempsSize := 0.
ccrs
add: (eax := Register withClass: I4 name: '%eax' encoding: 0x40);
@@ -153,62 +153,123 @@ Intel32CodeGenerator emit: call argument
"----------------------------------------------------------------"
-StaticIntel32CodeGenerator : Intel32CodeGenerator ()
-
-StaticIntel32CodeGenerator addrgp4 :d :v [ StdOut nextPutAll: ' movl '; nextPut: $$; print: v; nextPut: $,; print: d; cr ]
-StaticIntel32CodeGenerator addrjp4 :d :l [ StdOut nextPutAll: ' movl $L'; print: l ordinal; nextPut: $,; print: d; cr ]
-
-StaticIntel32CodeGenerator addlI: i R: d [ StdOut nextPutAll: ' addl '; nextPut: $$; print: i; nextPut: $,; print: d; cr ]
-StaticIntel32CodeGenerator addlI_: i R: d [ StdOut nextPutAll: ' addl '; nextPut: $$; print: (SmallInteger value_: i); nextPut: $,; print: d; cr ]
-StaticIntel32CodeGenerator addlR: s R: d [ StdOut nextPutAll: ' addl '; print: s; nextPut: $,; print: d; cr ]
-StaticIntel32CodeGenerator andlR: s R: d [ StdOut nextPutAll: ' andl '; print: s; nextPut: $,; print: d; cr ]
-StaticIntel32CodeGenerator callMb: b [ StdOut nextPutAll: ' call ('; print: b; nextPutAll: ')\n' ]
-StaticIntel32CodeGenerator cltd [ StdOut nextPutAll: ' cltd\n' ]
-StaticIntel32CodeGenerator cmplI: i R: d [ StdOut nextPutAll: ' cmpl '; nextPut: $$; print: i; nextPut: $,; print: d; cr ]
-StaticIntel32CodeGenerator cmplI_: i Md: d b: b [ StdOut nextPutAll: ' cmpl '; nextPut: $$; print: (SmallInteger value_: i); nextPut: $,; print: d; nextPut: $(; print: b; nextPut: $); cr]
-StaticIntel32CodeGenerator cmplR: s R: d [ StdOut nextPutAll: ' cmpl '; print: s; nextPut: $,; print: d; cr ]
-StaticIntel32CodeGenerator define: l [ StdOut nextPutAll: 'L'; print: l ordinal; nextPut: $:; cr ]
-StaticIntel32CodeGenerator idivlR: s [ StdOut nextPutAll: ' idivl '; print: s; cr ]
-StaticIntel32CodeGenerator imullR: s R: d [ StdOut nextPutAll: ' imull '; print: s; nextPut: $,; print: d; cr ]
-StaticIntel32CodeGenerator jeL: l [ StdOut nextPutAll: ' je L'; print: l ordinal; cr ]
-StaticIntel32CodeGenerator jgeL: l [ StdOut nextPutAll: ' jge L'; print: l ordinal; cr ]
-StaticIntel32CodeGenerator jmpL: l [ StdOut nextPutAll: ' jmp L'; print: l ordinal; cr ]
-StaticIntel32CodeGenerator jmpMb: b [ StdOut nextPutAll: ' jmp *'; print: b; cr ]
-StaticIntel32CodeGenerator jneL: l [ StdOut nextPutAll: ' jne L'; print: l ordinal; cr ]
-StaticIntel32CodeGenerator lealMd: d b: b R: r [ StdOut nextPutAll: ' leal '; print: d; nextPut: $(; print: b; nextPutAll: '),'; print: r; cr]
-StaticIntel32CodeGenerator lealMd_: d b: b R: r [ StdOut nextPutAll: ' leal '; print: (SmallInteger value_: d); nextPut: $(; print: b; nextPutAll: '),'; print: r; cr]
-StaticIntel32CodeGenerator movbR: r Mb: b [ StdOut nextPutAll: ' movb '; print: r; nextPutAll: ',('; print: b; nextPut: $); cr ]
-StaticIntel32CodeGenerator movlI_: i R: d [ StdOut nextPutAll: ' movl '; nextPut: $$; print: (SmallInteger value_: i); nextPut: $,; print: d; cr ]
-StaticIntel32CodeGenerator movlMb: b R: r [ StdOut nextPutAll: ' movl ('; print: b; nextPutAll: '),'; print: r; cr]
-StaticIntel32CodeGenerator movlMd: d b: b R: r [ StdOut nextPutAll: ' movl '; print: d; nextPut: $(; print: b; nextPutAll: '),'; print: r; cr]
-StaticIntel32CodeGenerator movlMd_: d R: r [ StdOut nextPutAll: ' movl '; print: (SmallInteger value_: d); nextPut: $,; print: r; cr ]
-StaticIntel32CodeGenerator movlR: r Mb: b [ StdOut nextPutAll: ' movl '; print: r; nextPutAll: ',('; print: b; nextPut: $); cr ]
-StaticIntel32CodeGenerator movlR: s Md: d b: b [ StdOut nextPutAll: ' movl '; print: s; nextPut: $,; print: d; nextPut: $(; print: b; nextPut: $); cr]
-StaticIntel32CodeGenerator movlR: s R: d [ s == d ifFalse: [StdOut nextPutAll: ' movl '; print: s; nextPut: $,; print: d; cr] ]
-StaticIntel32CodeGenerator movsblMb: s R: d [ StdOut nextPutAll: ' movsbl ('; print: s; nextPutAll: '),'; print: d; cr ]
-StaticIntel32CodeGenerator movswlMb: s R: d [ StdOut nextPutAll: ' movswl ('; print: s; nextPutAll: '),'; print: d; cr ]
-StaticIntel32CodeGenerator movwR: r Mb: b [ StdOut nextPutAll: ' movw '; print: r; nextPutAll: ',('; print: b; nextPut: $); cr ]
-StaticIntel32CodeGenerator neglR: d [ StdOut nextPutAll: ' negl '; print: d; cr ]
-StaticIntel32CodeGenerator notlR: d [ StdOut nextPutAll: ' notl '; print: d; cr ]
-StaticIntel32CodeGenerator orlR: s R: d [ StdOut nextPutAll: ' orl '; print: s; nextPut: $,; print: d; cr ]
-StaticIntel32CodeGenerator poplR: d [ StdOut nextPutAll: ' popl '; print: d; cr ]
-StaticIntel32CodeGenerator pushlR: s [ StdOut nextPutAll: ' pushl '; print: s; cr ]
-StaticIntel32CodeGenerator ret [ StdOut nextPutAll: ' ret\n' ]
-StaticIntel32CodeGenerator sallR: s R: d [ StdOut nextPutAll: ' sall '; print: s; nextPut: $,; print: d; cr ]
-StaticIntel32CodeGenerator sarlR: s R: d [ StdOut nextPutAll: ' sarl '; print: s; nextPut: $,; print: d; cr ]
-StaticIntel32CodeGenerator seteR: d [ StdOut nextPutAll: ' sete '; print: d; cr ]
-StaticIntel32CodeGenerator setgR: d [ StdOut nextPutAll: ' setg '; print: d; cr ]
-StaticIntel32CodeGenerator setgeR: d [ StdOut nextPutAll: ' setge '; print: d; cr ]
-StaticIntel32CodeGenerator setlR: d [ StdOut nextPutAll: ' setl '; print: d; cr ]
-StaticIntel32CodeGenerator setleR: d [ StdOut nextPutAll: ' setle '; print: d; cr ]
-StaticIntel32CodeGenerator setneR: d [ StdOut nextPutAll: ' setne '; print: d; cr ]
-StaticIntel32CodeGenerator shllR: s R: d [ StdOut nextPutAll: ' shll '; print: s; nextPut: $,; print: d; cr ]
-StaticIntel32CodeGenerator shrlR: s R: d [ StdOut nextPutAll: ' shrl '; print: s; nextPut: $,; print: d; cr ]
-StaticIntel32CodeGenerator sublI: i R: d [ StdOut nextPutAll: ' subl '; nextPut: $$; print: i; nextPut: $,; print: d; cr ]
-StaticIntel32CodeGenerator sublI_: i R: d [ StdOut nextPutAll: ' subl '; nextPut: $$; print: (SmallInteger value_: i); nextPut: $,; print: d; cr ]
-StaticIntel32CodeGenerator sublR: s R: d [ StdOut nextPutAll: ' subl '; print: s; nextPut: $,; print: d; cr ]
-StaticIntel32CodeGenerator testlR: s R: d [ StdOut nextPutAll: ' testl '; print: s; nextPut: $,; print: d; cr ]
-StaticIntel32CodeGenerator xorlR: s R: d [ StdOut nextPutAll: ' xorl '; print: s; nextPut: $,; print: d; cr ]
+StaticIntel32CodeGenerator : Intel32CodeGenerator (bss data text ctor lambdas extern)
+StaticIntel32CodeGenerator new
+[
+ self := super new.
+ bss := IdentitySet new.
+ data := WriteStream on: (String new: 8192).
+ ctor := WriteStream on: (String new: 8192).
+ lambdas := WriteStream on: (String new: 8192).
+ text := ctor.
+]
+
+StaticIntel32CodeGenerator newScope
+[
+ | newGen saveBss saveData saveCtor saveLambdas saveText |
+ saveBss := bss.
+ saveData := data.
+ saveCtor := ctor.
+ saveLambdas := lambdas.
+ saveText := text.
+ self := super newScope.
+ bss := saveBss.
+ data := saveData.
+ ctor := saveCtor.
+ lambdas := saveLambdas.
+ text := saveText.
+]
+
+StaticIntel32CodeGenerator toStream: out
+[
+ | hdr dataPfx ctorPtr label textPfx ctorPfx ctorSfx |
+ hdr := '# Generated by COLA ', self versionString, '\n'.
+
+ dataPfx := data position == 0 ifTrue: [''] ifFalse: ['\t.data\n'].
+ textPfx := (ctor position + lambdas position) == 0 ifTrue: [''] ifFalse: ['\n\t.text\n'].
+
+ ctor position == 0
+ ifTrue: [ctorPtr := ''. ctorPfx := ''. ctorSfx := '']
+ ifFalse: [ label := 'L', Label new ordinal asString.
+ ctorPtr := '\n\t.section .ctors\n\t.long ', label, '\n'.
+ ctorPfx := label, ':\n'.
+ ctorSfx := '\tret\n'].
+
+ out nextPutAll: hdr.
+ bss do: [:elt | out nextPutAll: '\t.lcomm '; nextPutAll: (self slinkName: elt asString); nextPutAll: ', 4'; cr].
+
+ out nextPutAll: dataPfx.
+ out nextPutAll: (String size: data position value_: data collection _stringValue).
+
+ out nextPutAll: ctorPtr.
+
+ out nextPutAll: textPfx.
+
+ out nextPutAll: ctorPfx.
+ out nextPutAll: (String size: ctor position value_: ctor collection _stringValue).
+ out nextPutAll: ctorSfx.
+
+ out nextPutAll: (String size: lambdas position value_: lambdas collection _stringValue).
+]
+
+StaticIntel32CodeGenerator define: l
+[
+ text == ctor ifFalse: [text nextPutAll: 'L'; print: l ordinal; nextPut: $:; cr]
+]
+
+StaticIntel32CodeGenerator addrgp4 :d :v [ text nextPutAll: ' movl $'; print: v; nextPut: $,; print: d; cr ]
+StaticIntel32CodeGenerator addlI: i R: d [ text nextPutAll: ' addl '; nextPut: $$; print: i; nextPut: $,; print: d; cr ]
+StaticIntel32CodeGenerator addlI_: i R: d [ text nextPutAll: ' addl '; nextPut: $$; print: (SmallInteger value_: i); nextPut: $,; print: d; cr ]
+StaticIntel32CodeGenerator addlR: s R: d [ text nextPutAll: ' addl '; print: s; nextPut: $,; print: d; cr ]
+StaticIntel32CodeGenerator andlR: s R: d [ text nextPutAll: ' andl '; print: s; nextPut: $,; print: d; cr ]
+StaticIntel32CodeGenerator callMb: b [ text nextPutAll: ' call *'; print: b; cr ]
+StaticIntel32CodeGenerator cltd [ text nextPutAll: ' cltd'; cr ]
+StaticIntel32CodeGenerator cmplI: i R: d [ text nextPutAll: ' cmpl '; nextPut: $$; print: i; nextPut: $,; print: d; cr ]
+StaticIntel32CodeGenerator cmplI_: i Md: d b: b [ text nextPutAll: ' cmpl '; nextPut: $$; print: (SmallInteger value_: i); nextPut: $,; print: d; nextPut: $(; print: b; nextPut: $); cr]
+StaticIntel32CodeGenerator cmplR: s R: d [ text nextPutAll: ' cmpl '; print: s; nextPut: $,; print: d; cr ]
+StaticIntel32CodeGenerator idivlR: s [ text nextPutAll: ' idivl '; print: s; cr ]
+StaticIntel32CodeGenerator imullR: s R: d [ text nextPutAll: ' imull '; print: s; nextPut: $,; print: d; cr ]
+StaticIntel32CodeGenerator jeL: l [ text nextPutAll: ' je L'; print: l ordinal; cr ]
+StaticIntel32CodeGenerator jgeL: l [ text nextPutAll: ' jge L'; print: l ordinal; cr ]
+StaticIntel32CodeGenerator jmpL: l [ text nextPutAll: ' jmp L'; print: l ordinal; cr ]
+StaticIntel32CodeGenerator jmpMb: b [ text nextPutAll: ' jmp *'; print: b; cr ]
+StaticIntel32CodeGenerator jneL: l [ text nextPutAll: ' jne L'; print: l ordinal; cr ]
+StaticIntel32CodeGenerator lealMd: d b: b R: r [ text nextPutAll: ' leal '; print: d; nextPut: $(; print: b; nextPutAll: '),'; print: r; cr]
+StaticIntel32CodeGenerator lealMd_: d b: b R: r [ text nextPutAll: ' leal '; print: (SmallInteger value_: d); nextPut: $(; print: b; nextPutAll: '),'; print: r; cr]
+StaticIntel32CodeGenerator lealS: s R: r [ text nextPutAll: ' leal '; nextPutAll: s; nextPut: $,; print: r; cr]
+StaticIntel32CodeGenerator movbR: r Mb: b [ text nextPutAll: ' movb '; print: r; nextPutAll: ',('; print: b; nextPut: $); cr ]
+StaticIntel32CodeGenerator movlI_: i R: d [ text nextPutAll: ' movl '; nextPut: $$; print: (SmallInteger value_: i); nextPut: $,; print: d; cr ]
+StaticIntel32CodeGenerator movlMb: b R: r [ text nextPutAll: ' movl ('; print: b; nextPutAll: '),'; print: r; cr]
+StaticIntel32CodeGenerator movlMd: d b: b R: r [ text nextPutAll: ' movl '; print: d; nextPut: $(; print: b; nextPutAll: '),'; print: r; cr]
+StaticIntel32CodeGenerator movlMd_: d R: r [ text nextPutAll: ' movl '; print: (SmallInteger value_: d); nextPut: $,; print: r; cr ]
+StaticIntel32CodeGenerator movlR: r Mb: b [ text nextPutAll: ' movl '; print: r; nextPutAll: ',('; print: b; nextPut: $); cr ]
+StaticIntel32CodeGenerator movlR: s Md: d b: b [ text nextPutAll: ' movl '; print: s; nextPut: $,; print: d; nextPut: $(; print: b; nextPut: $); cr]
+StaticIntel32CodeGenerator movlR: s R: d [ s == d ifFalse: [text nextPutAll: ' movl '; print: s; nextPut: $,; print: d; cr] ]
+StaticIntel32CodeGenerator movlS: s R: d [ text nextPutAll: ' movl '; nextPutAll: s; nextPut: $,; print: d; cr ]
+StaticIntel32CodeGenerator movsblMb: s R: d [ text nextPutAll: ' movsbl ('; print: s; nextPutAll: '),'; print: d; cr ]
+StaticIntel32CodeGenerator movswlMb: s R: d [ text nextPutAll: ' movswl ('; print: s; nextPutAll: '),'; print: d; cr ]
+StaticIntel32CodeGenerator movwR: r Mb: b [ text nextPutAll: ' movw '; print: r; nextPutAll: ',('; print: b; nextPut: $); cr ]
+StaticIntel32CodeGenerator neglR: d [ text nextPutAll: ' negl '; print: d; cr ]
+StaticIntel32CodeGenerator notlR: d [ text nextPutAll: ' notl '; print: d; cr ]
+StaticIntel32CodeGenerator orlR: s R: d [ text nextPutAll: ' orl '; print: s; nextPut: $,; print: d; cr ]
+StaticIntel32CodeGenerator poplR: d [ text nextPutAll: ' popl '; print: d; cr ]
+StaticIntel32CodeGenerator pushlR: s [ text nextPutAll: ' pushl '; print: s; cr ]
+StaticIntel32CodeGenerator ret [ text == ctor ifFalse: [text nextPutAll: ' ret'; cr] ]
+StaticIntel32CodeGenerator sallR: s R: d [ text nextPutAll: ' sall '; print: s; nextPut: $,; print: d; cr ]
+StaticIntel32CodeGenerator sarlR: s R: d [ text nextPutAll: ' sarl '; print: s; nextPut: $,; print: d; cr ]
+StaticIntel32CodeGenerator seteR: d [ text nextPutAll: ' sete '; print: d; cr ]
+StaticIntel32CodeGenerator setgR: d [ text nextPutAll: ' setg '; print: d; cr ]
+StaticIntel32CodeGenerator setgeR: d [ text nextPutAll: ' setge '; print: d; cr ]
+StaticIntel32CodeGenerator setlR: d [ text nextPutAll: ' setl '; print: d; cr ]
+StaticIntel32CodeGenerator setleR: d [ text nextPutAll: ' setle '; print: d; cr ]
+StaticIntel32CodeGenerator setneR: d [ text nextPutAll: ' setne '; print: d; cr ]
+StaticIntel32CodeGenerator shllR: s R: d [ text nextPutAll: ' shll '; print: s; nextPut: $,; print: d; cr ]
+StaticIntel32CodeGenerator shrlR: s R: d [ text nextPutAll: ' shrl '; print: s; nextPut: $,; print: d; cr ]
+StaticIntel32CodeGenerator sublI: i R: d [ text nextPutAll: ' subl '; nextPut: $$; print: i; nextPut: $,; print: d; cr ]
+StaticIntel32CodeGenerator sublI_: i R: d [ text nextPutAll: ' subl '; nextPut: $$; print: (SmallInteger value_: i); nextPut: $,; print: d; cr ]
+StaticIntel32CodeGenerator sublR: s R: d [ text nextPutAll: ' subl '; print: s; nextPut: $,; print: d; cr ]
+StaticIntel32CodeGenerator testlR: s R: d [ text nextPutAll: ' testl '; print: s; nextPut: $,; print: d; cr ]
+StaticIntel32CodeGenerator xorlR: s R: d [ text nextPutAll: ' xorl '; print: s; nextPut: $,; print: d; cr ]
Intel32CodeGenerator spilli4: reg to: tmp [ self movlR: reg Md: tmp offset b: esp ]
Intel32CodeGenerator reloadi4: reg from: tmp [ self movlMd: tmp offset b: esp R: reg ]
@@ -299,7 +360,7 @@ CodeGenerator versionString [ ^self defa
CodeGenerator default [ ^Intel32CodeGenerator ]
-Intel32CodeGenerator static [ ^StaticIntel32CodeGenerator ]
+Intel32CodeGenerator static [ ^StaticIntel32CodeGenerator new ]
Intel32CodeGenerator dynamic [ ^DynamicIntel32CodeGenerator ]
Intel32CodeGenerator versionString
@@ -315,15 +376,83 @@ CodeGenerator isDynamic [ ^false ]
CodeGenerator isDynamic [ ^false ]
DynamicIntel32CodeGenerator isDynamic [ ^true ]
-StaticIntel32CodeGenerator defineVariable: name
-[
- StdOut nextPutAll: ' .data\n'.
- StdOut nextPutAll: name; nextPutAll: ': .long _'; nextPutAll: name; cr.
- StdOut nextPutAll: ' .text\n'.
-]
-
-DynamicIntel32CodeGenerator defineVariable: name
-[
+NameManglingTable : Array ()
+[
+ "For (relative) readability:
+ _a-zA-Z0-9 -> _a-zA-Z0-9
+ . -> _<hex-value>_"
+ NameManglingTable := Array new: 256.
+ NameManglingTable atAllPut: #'mangleOther:to:'.
+ '_abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789'
+ do: [:char | NameManglingTable at: char put: #'mangleLetter:to:'].
+]
+
+Intel32CodeGenerator slinkName: name
+[
+ | uscore mangled |
+ {
+#if defined(__MACH__) || defined(__CYGWIN__) || defined(__WIN32__)
+ v_uscore = 1;
+#endif
+ }.
+ mangled := (String new: name size * 2) writeStream.
+ uscore ifTrue: [mangled nextPut: $_].
+ name do: [:char | self perform: (NameManglingTable at: char) with: char with: mangled].
+ ^mangled contents
+]
+
+Intel32CodeGenerator mangleLetter: aCharacter to: aStream [ aStream nextPut: aCharacter ]
+Intel32CodeGenerator mangleOther: aCharacter to: aStream
+[
+ aStream nextPut: $_; print: aCharacter base: 16; nextPut: $_.
+]
+
+StaticIntel32CodeGenerator slinkVariable: name [ bss add: name ]
+StaticIntel32CodeGenerator slinkImport: name []
+StaticIntel32CodeGenerator slinkExport: name translate: aForm with: aCompiler
+[
+ | ext result |
+ extern := self slinkName: name.
+ result := aForm translate: aCompiler.
+ (extern and: [result name == #slink or: [result name == #slinki]])
+ ifTrue: [data nextPutAll: '\n\t.globl '; nextPutAll: extern; cr;
+ nextPutAll: '\t.set '; nextPutAll: extern; nextPut: $,; nextPutAll: result arg; cr.
+ extern := nil].
+ ^nil
+]
+
+StaticIntel32CodeGenerator compileLambda: form with: aCompiler
+[
+ | save label |
+ save := text.
+ text == ctor ifTrue: [text := lambdas].
+ extern ifTrue: [ text cr; nextPutAll: '\t.globl '; nextPutAll: extern; cr;
+ nextPutAll: extern; nextPut: $:; cr.
+ extern := nil ].
+ label := aCompiler compileLambda: form.
+ text := save.
+ ^SLINK new arg: ('L', label ordinal asString)
+]
+
+StaticIntel32CodeGenerator translateData_: _bytes length: aLength
+[
+ | name comma s |
+ extern
+ ifTrue: [ name := extern.
+ data cr; nextPutAll: '\t.globl '; nextPutAll: name; cr.
+ extern := nil ]
+ ifFalse: [ name := 'L', (Label new ordinal asString) ].
+
+ s := String size: aLength value_: _bytes.
+ data nextPutAll: name; nextPut: $:.
+ 0 to: aLength - 1 do:
+ [:i | i \\ 8 == 0 ifTrue: [data cr; nextPutAll: '\t.byte '. comma := ''].
+ data nextPutAll: comma; nextPutAll: '0x'; print_x: (s at: i) _integerValue.
+ comma := ', '
+ ].
+ data cr.
+
+ ^SLINK new arg: name
]
"----------------------------------------------------------------"
@@ -353,6 +482,8 @@ Intel32Grammar := [
at: #VOID add: #(label ) do: [:op :gen | gen define: op ];
at: #REG add: #(cnsti4 ) do: [:op :gen | gen movlI_: op arg R: op output ];
at: #REG add: #(cnstp4 ) do: [:op :gen | gen movlI_: op arg R: op output ];
+ at: #REG add: #(slink ) do: [:op :gen | gen lealS: (gen slinkName: op arg) R: op output ];
+ at: #REG add: #(slinki ) do: [:op :gen | gen movlS: (gen slinkName: op arg) R: op output ];
at: #REG add: #(parami4 ) do: [:op :gen | ];
at: #REG add: #(addrfp4 ) do: [:op :gen | gen movlR: gen ebp R: op output ];
at: #REG add: #(addrgp4 ) do: [:op :gen | gen movlI_: op arg _address R: op output ];
@@ -367,7 +498,7 @@ Intel32Grammar := [
movlR: gen ecx R: op output ];
at: #REG add: #(comi4 REG ) do: [:op :gen | gen notlR: op output ];
at: #REG add: #(negi4 REG ) do: [:op :gen | gen neglR: op output ];
- at: #REG add: #(calli4 REG ) do: [:op :gen | gen calli4: op ];
+ at: #REG add: #(calli4 REG ) do: [:op :gen | gen calli4: op];
at: #REG add: #(asgni1 REG REG) do: [:op :gen | gen movlR: op lhs output R: gen ecx;
movbR: gen cl Mb: op rhs output ];
at: #REG add: #(asgni2 REG REG) do: [:op :gen | gen movlR: op lhs output R: gen ecx;
@@ -452,7 +583,7 @@ StaticIntel32CodeGenerator generate: tre
StaticIntel32CodeGenerator generate: tree
[
self finaliseFrame.
- tree printOn: StdOut indent: 0. StdOut cr.
+ "tree printOn: StdOut indent: 0. StdOut cr."
tree generate: self.
^Array with: 0 with: 0.
]
diff -r 1e71558180f0 function/jolt2/CodeGenerator-ppc.st
--- a/function/jolt2/CodeGenerator-ppc.st Thu Apr 24 23:17:10 2008 -0600
+++ b/function/jolt2/CodeGenerator-ppc.st Fri Apr 25 16:12:05 2008 -0600
@@ -39,9 +39,9 @@ PowerPCRegister location [ ^location ]
PowerPCCodeGenerator : CodeGenerator ( r0 r1 r2 r3 r11 r12 )
-PowerPCCodeGenerator new
-[
- self := super new.
+PowerPCCodeGenerator newScope
+[
+ self := super newScope.
r0 := PowerPCRegister withClass: I4 name: 'r0' encoding: 0.
r1 := PowerPCRegister withClass: I4 name: 'r1' encoding: 1.
r2 := PowerPCRegister withClass: I4 name: 'r2' encoding: 2.
diff -r 1e71558180f0 function/jolt2/CodeGenerator.st
--- a/function/jolt2/CodeGenerator.st Thu Apr 24 23:17:10 2008 -0600
+++ b/function/jolt2/CodeGenerator.st Fri Apr 25 16:12:05 2008 -0600
@@ -28,11 +28,16 @@ CodeGenerator : Object ( ccrs csrs spill
CodeGenerator withLabels: labelCollection
[
- self := self new.
+ self := self newScope.
labels := labelCollection.
]
CodeGenerator new
+[
+ self := self newScope
+]
+
+CodeGenerator newScope
[
self := super new.
ccrs := RegisterSet new.
@@ -111,6 +116,36 @@ CodeGenerator relocateLabels_: _addr
labels do: [:label | label relocate_: _addr]
]
+CodeGenerator slinkVariable: name []
+CodeGenerator slinkImport: name [^name _dlsym]
+CodeGenerator slinkExport: name translate: aForm with: aCompiler
+[
+ | entry value |
+ aForm isSymbol ifTrue: [aForm := Expression with: #addrof with: aForm].
+ entry := aCompiler compile: aForm.
+ value := entry call.
+ entry free.
+ ^value
+]
+
+CodeGenerator compileLambda: form with: aCompiler
+[
+ ^ADDRJP4 new arg: (aCompiler compileLambda: form)
+]
+
+CodeGenerator translateData_: _bytes length: aLength
+[
+ | _mem |
+ {
+ size_t size= ((long)v_aLength) >> 1;
+ char *mem= malloc(size + 1);
+ memcpy(mem, v__bytes, size);
+ mem[size]= '\0';
+ v__mem= (oop)mem;
+ }.
+ ^CNSTP4 new arg: _mem
+]
+
CodeGenerator enter :e [ self emitPrologue ]
CodeGenerator parami4 :s []
CodeGenerator drop :s []
diff -r 1e71558180f0 function/jolt2/Compiler.st
--- a/function/jolt2/Compiler.st Thu Apr 24 23:17:10 2008 -0600
+++ b/function/jolt2/Compiler.st Fri Apr 25 16:12:05 2008 -0600
@@ -37,6 +37,7 @@ Variable withName: nameSymbol
]
Variable translateRvalue: compiler [ ^INDIRI4 new lhs: (self translateLvalue: compiler) ]
+Variable name [ ^name ]
GlobalVariable : Variable ( _storage )
@@ -61,6 +62,30 @@ GlobalVariable translateLvalue: compiler
GlobalVariable printOn: aStream [ aStream print: name; nextPut: $=; print_x: _storage ]
+
+SlinkConstant : Variable ()
+
+SlinkConstant translateLvalue: compiler
+[
+ compiler error: 'cannot write: ', name.
+]
+SlinkConstant translateRvalue: compiler
+[
+ ^SLINK new arg: name asString
+]
+
+SlinkVariable : Variable ()
+
+SlinkVariable translateLvalue: compiler
+[
+ ^SLINK new arg: name asString
+]
+SlinkVariable translateRvalue: compiler
+[
+ ^SLINKI new arg: name asString
+]
+
+SlinkVariable printOn: aStream [ aStream print: name ]
LocalVariable : Variable ( location )
@@ -115,6 +140,8 @@ Environment : SlotDictionary ( syntax ac
Environment new [ ^super basicNew ]
+Environment isGlobal [ ^false ]
+
Environment lookupVariable: name [ ^(active ifTrue: [active at: name ifAbsent: []]) ifNil: [self at: name ifAbsent: []] ]
Environment lookupSyntax: name [ ^ syntax ifTrue: [syntax at: name ifAbsent: []] ]
@@ -132,9 +159,16 @@ Environment defineActive: name
GlobalEnvironment : Environment ()
+GlobalEnvironment isGlobal [ ^true ]
GlobalEnvironment defineVariable: name [ ^self at: name put: (GlobalVariable withName: name) ]
GlobalEnvironment defineVariable: name value_: _value [ ^self at: name put: (GlobalVariable withName: name value_: _value) ]
-
+GlobalEnvironment defineSlink: name value_: _value [ ^self defineVariable: name value_: _value ]
+
+SlinkEnvironment : Environment ()
+
+SlinkEnvironment isGlobal [ ^true ]
+SlinkEnvironment defineVariable: name [ ^self at: name put: (SlinkVariable withName: name) ]
+SlinkEnvironment defineSlink: name value_: _value [ ^self at: name put: (SlinkConstant withName: name) ]
LocalEnvironment : Environment ( parent )
@@ -151,6 +185,7 @@ LocalEnvironment lookupSyntax: name [ ^(
LocalEnvironment defineVariable: name [ ^self at: name put: (LocalVariable withName: name) ]
LocalEnvironment defineParameter: name [ ^self at: name put: (ParameterVariable withName: name) ]
+LocalEnvironment defineSlink: name value_: _value [ ^parent defineSlink: name value_: _value ]
TheGlobalEnvironment := [ GlobalEnvironment new ]
@@ -171,10 +206,10 @@ Symbol _dlsym_: _string { _return (oop)_
Compiler : Object ( environment allLabels generatorType breaks continues postProcessors labels )
-Compiler withGeneratorType: genType
+Compiler withGeneratorType: genType withEnvironment: theEnv
[
self := super new.
- environment := TheGlobalEnvironment.
+ environment := theEnv.
allLabels := OrderedCollection new.
generatorType := genType.
breaks := OrderedCollection new.
@@ -204,6 +239,7 @@ Compiler lookupVariable: name
Compiler defineActive: name [ ^environment defineActive: name ]
Compiler defineVariable: name [ ^environment defineVariable: name ]
+Compiler defineSlink: name value_: _value [ ^environment defineSlink: name value_: _value ]
Compiler defineParameter: name [ ^environment defineParameter: name ]
Compiler defineSyntax: name [ ^environment defineSyntax: name ]
@@ -262,7 +298,7 @@ SyntaxTable := [
at: #return put: #xReturn:;
at: #label put: #xLabel:;
at: #goto put: #xGoto:;
- at: #extern put: #xExtern:;
+ at: #'define-slink' put: #xDefineSlink:;
yourself
]
@@ -282,12 +318,12 @@ Compiler translateInteger: anInteger
Compiler translateFloat: aFloat
[
- ^CNSTP4 new arg: aFloat
+ ^generatorType translateData_: aFloat length: (SmallInteger value_: aFloat _sizeof)
]
Compiler translateString: aString
[
- ^CNSTP4 new arg: aString _strdup
+ ^generatorType translateData_: aString _stringValue length: aString size + 1
]
Compiler translateSymbol: aSymbol
@@ -628,7 +664,7 @@ Compiler xQuote: expr
Compiler xQuote: expr
[
| literal |
- expr size == 2 ifFalse: [self errorAgumentCount: expr].
+ expr size == 2 ifFalse: [self errorArgumentCount: expr].
literal := expr second.
(literal isSmallInteger or: [literal isNil]) ifFalse: [CompilerLiterals addLast: literal].
^CNSTP4 new arg: literal
@@ -671,7 +707,7 @@ Compiler defineVariable: name from: form
[
| var value |
(form size <= 3) ifFalse: [self errorSyntax: form].
- var := self lookupVariable: name ifAbsent: [self defineVariable: name].
+ var := self lookupVariable: name ifAbsent: [generatorType slinkVariable: name. self defineVariable: name].
value := form size == 3
ifTrue: [form third translate: self]
ifFalse: [CNSTI4 new arg: nil].
@@ -680,7 +716,7 @@ Compiler defineVariable: name from: form
^ASGNI4 new lhs: value; rhs: (var translateLvalue: self).
]
-Compiler defineAccessor: accessor from: expr "(define (foo bar...) baz) -> (set-foo bar... baz)"
+Compiler defineAccessor: accessor from: expr "(define (foo bar...) baz) -> (define-foo bar... baz)"
[
| setter syntax |
(accessor isArray and: [accessor size > 0 and: [accessor first isSymbol]]) ifFalse: [self errorSyntax: accessor].
@@ -830,13 +866,15 @@ Compiler xLet: form
Compiler xLambda: form
[
- ^ADDRJP4 new arg: (self compileLambda: form)
+ ^generatorType compileLambda: form with: self
]
Compiler compileLambda: form
[
- | block entry last gen stats |
- self := self withGeneratorType: generatorType.
+ | block entry last gen stats topEnv |
+ topEnv := environment.
+ [ topEnv isGlobal not ] whileTrue: [ topEnv := topEnv parent ].
+ self := self withGeneratorType: generatorType withEnvironment: topEnv.
(block := Block new)
scope: self beginScope;
add: (entry := self newLabel);
@@ -889,14 +927,16 @@ Compiler xGoto: form
^BRA new destination: label
]
-Compiler xExtern: form
-[
- | name var |
- (form size == 2 and: [(name := form second) isSymbol]) ifFalse: [self errorSyntax: form].
- var := self lookupVariable: name ifAbsent: [self defineVariable: name].
- var value_: name _dlsym.
- generatorType defineVariable: name.
- ^CNSTP4 new arg: var _value
+"(define-slink SYMBOL): Import SYMBOL from the system linker
+ (define-slink SYMBOL EXPRESSION): Export SYMBOL to the system linker, with value EXPRESSION"
+Compiler xDefineSlink: form
+[
+ | name addr |
+ (form size <= 3 and: [(name := form second) isSymbol]) ifFalse: [self errorSyntax: form].
+ form size == 2
+ ifTrue: [ addr := generatorType slinkImport: name ]
+ ifFalse: [ addr := generatorType slinkExport: name translate: form third with: self ].
+ ^(self defineSlink: name value_: addr) translateRvalue: self.
]
Compiler xCompile: form
@@ -952,10 +992,15 @@ Compiler postProcess: aFunction [ pos
"----------------------------------------------------------------"
-Compiler compile: anObject for: codeGeneratorType
+Compiler compile: anObject
+[
+ ^self compile: anObject for: generatorType with: environment
+]
+
+Compiler compile: anObject for: codeGeneratorType with: anEnvironment
[
| block entry tree gen |
- self := self withGeneratorType: codeGeneratorType.
+ self := self withGeneratorType: codeGeneratorType withEnvironment: anEnvironment.
(block := Block new)
add: (entry := self newLabel);
add: ENTER new.
@@ -981,7 +1026,12 @@ Compiler compile: anObject for: codeGene
Object compile
[
- Compiler compile: self for: CodeGenerator default static
+ ^self compileWith: SlinkEnvironment new
+]
+
+Object compileWith: anEnvironment
+[
+ Compiler compile: self for: CodeGenerator default static with: anEnvironment
]
Object eval
@@ -993,7 +1043,7 @@ Object _eval
[
| entry value |
CompilerOptions verboseList ifTrue: [self compile].
- entry := Compiler compile: self for: CodeGenerator default dynamic.
+ entry := Compiler compile: self for: CodeGenerator default dynamic with: TheGlobalEnvironment.
value := entry call.
entry free.
^value
diff -r 1e71558180f0 function/jolt2/Instruction.st
--- a/function/jolt2/Instruction.st Thu Apr 24 23:17:10 2008 -0600
+++ b/function/jolt2/Instruction.st Fri Apr 25 16:12:06 2008 -0600
@@ -511,6 +511,8 @@ INDIRI2 : Unary () INDIRI2 name [ ^#ind
INDIRI2 : Unary () INDIRI2 name [ ^#indiri2 ]
INDIRI4 : Unary () INDIRI4 name [ ^#indiri4 ]
LEI4 : Binary () LEI4 name [ ^#lei4 ]
+SLINK : Leaf () SLINK name [ ^#slink ]
+SLINKI : Leaf () SLINKI name [ ^#slinki ]
LTI4 : Binary () LTI4 name [ ^#lti4 ]
MODI4 : Binary () MODI4 name [ ^#modi4 ]
MULI4 : Binary () MULI4 name [ ^#muli4 ]
diff -r 1e71558180f0 function/jolt2/boot.k
--- a/function/jolt2/boot.k Thu Apr 24 23:17:10 2008 -0600
+++ b/function/jolt2/boot.k Fri Apr 25 16:12:06 2008 -0600
@@ -157,6 +157,7 @@
(lambda (path)
(let ((file [File openIfPresent: [String value_: path]]))
(or file (set file [File openIfPresent: [[[Options libdir] , '"/"] , [String value_: path]]]))
+ (or file (set file [File openIfPresent: [[[Options progdir] , '"/"] , [String value_: path]]]))
(if file
(let ()
(herald path)
@@ -227,6 +228,10 @@
(load "object.k")
(define *package-list* [IdentitySet new])
+[*package-list* add: 'syntax]
+[*package-list* add: 'debug]
+[*package-list* add: 'object]
+[*package-list* add: 'boot]
(define %require
(lambda (package)
diff -r 1e71558180f0 function/objects/File.st
--- a/function/objects/File.st Thu Apr 24 23:17:10 2008 -0600
+++ b/function/objects/File.st Fri Apr 25 16:12:06 2008 -0600
@@ -22,6 +22,8 @@
{ include "tag.h" }
+{ include <errno.h> }
+
File : Object ( _fd name )
File isFile [ ^true ]
@@ -54,6 +56,7 @@ File println: anObject [ self print:
File println: anObject [ self print: anObject; cr ]
File print: aNumber base: base [ aNumber printOn: self base: base ]
File print: aNumber base: base width: width [ aNumber printOn: self base: base width: width ]
+File print_x: o [ self print: (Integer value_: o) base: 16 ]
File cr [ self nextPut: $\n ]
File cr: n [ n timesRepeat: [self cr] ]
File space [ self nextPut: $ ]
@@ -77,15 +80,23 @@ File next: size putAll: aString
| _bytes _size |
_bytes := aString _bytes.
_size := size _integerValue.
- { _return _O(write((int)self->v__fd, (void *)v__bytes, (size_t)v__size)); }.
-]
-
-File print_x: _pointer
-{
- char buf[1024];
- int size= sprintf(buf, "%x", (int)v__pointer);
- _return _O(write((int)self->v__fd, (void *)buf, (size_t)size));
-}
+ {
+ size_t position= 0;
+ size_t remaining= (size_t)v__size;
+ while (remaining)
+ {
+ int count= write((int)self->v__fd, ((char *)v__bytes) + position, remaining);
+ if (count >= 0)
+ {
+ position += count;
+ remaining -= count;
+ }
+ else if (errno != EINTR)
+ break;
+ }
+ _return _O(position);
+ }
+]
File read: aCollection [ ^self read: aCollection size: aCollection size ]
File read: aCollection size: size [ ^self read: aCollection at: 0 size: size ]
_______________________________________________
fonc mailing list
[email protected]
http://vpri.org/mailman/listinfo/fonc
