[svn:languages] r54 - bf bf/branches bf/tags bf/trunk bf/trunk/config bf/trunk/config/makefiles bf/trunk/t chitchat chitchat/branches chitchat/tags chitchat/trunk chitchat/trunk/config chitchat/trunk/config/makefiles chitchat/trunk/src chitchat/trunk/src/builtins chitchat/trunk/src/parser chitchat/trunk/t forth forth/branches forth/tags forth/trunk forth/trunk/config forth/trunk/config/makefiles forth/trunk/t jako jako/branches jako/tags jako/trunk jako/trunk/antlr jako/trunk/config jako/trunk/config/makefiles jako/trunk/docs jako/trunk/examples jako/trunk/lib jako/trunk/lib/Jako jako/trunk/lib/Jako/Construct jako/trunk/lib/Jako/Construct/Block jako/trunk/lib/Jako/Construct/Block/Conditional jako/trunk/lib/Jako/Construct/Block/Loop jako/trunk/lib/Jako/Construct/Declaration jako/trunk/lib/Jako/Construct/Expression jako/trunk/lib/Jako/Construct/Expression/Value jako/trunk/lib/Jako/Construct/Statement jako/trunk/lib/Jako/Construct/Type jako/trunk/t lisp lisp/branches li sp/tags lisp/trunk lisp/trunk/config lisp/trunk/config/makefiles lisp/trunk/include lisp/trunk/include/macros lisp/trunk/lib lisp/trunk/lib/Parrot lisp/trunk/lib/Parrot/Test lisp/trunk/lisp lisp/trunk/t ook ook/branches ook/tags ook/trunk ook/trunk/config ook/trunk/config/makefiles ook/trunk/t scheme scheme/branches scheme/tags scheme/trunk scheme/trunk/config scheme/trunk/config/makefiles scheme/trunk/lib scheme/trunk/lib/Parrot scheme/trunk/lib/Parrot/Test scheme/trunk/lib/Scheme scheme/trunk/t scheme/trunk/t/arith scheme/trunk/t/io scheme/trunk/t/logic scheme/trunk/t/syn urm urm/branches urm/tags urm/trunk urm/trunk/config urm/trunk/config/makefiles urm/trunk/examples urm/trunk/lib urm/trunk/lib/URM urm/trunk/t
fperrad at svn.parrot.org
fperrad at svn.parrot.org
Sun Mar 15 11:23:38 UTC 2009
Author: fperrad
Date: Sun Mar 15 11:23:30 2009
New Revision: 54
URL: https://trac.parrot.org/languages/changeset/54
Log:
import following languages : bf, chitchat, forth, jako, lisp, ook, scheme & urm
Added:
bf/
bf/branches/
bf/tags/
bf/trunk/
bf/trunk/MAINTAINER (contents, props changed)
bf/trunk/README (contents, props changed)
bf/trunk/bench.bf (contents, props changed)
bf/trunk/bf.pasm (contents, props changed)
bf/trunk/bfc.pir (contents, props changed)
bf/trunk/bfco.pir (contents, props changed)
bf/trunk/config/
bf/trunk/config/makefiles/
bf/trunk/config/makefiles/root.in (contents, props changed)
bf/trunk/countdown.bf (contents, props changed)
bf/trunk/cw.bf (contents, props changed)
bf/trunk/cw.txt (contents, props changed)
bf/trunk/helloworld.bf (contents, props changed)
bf/trunk/t/
bf/trunk/t/harness (contents, props changed)
bf/trunk/t/test_bf.t (contents, props changed)
bf/trunk/t/test_bfc.t (contents, props changed)
bf/trunk/t/test_bfco.t (contents, props changed)
bf/trunk/test.bf (contents, props changed)
chitchat/
chitchat/branches/
chitchat/tags/
chitchat/trunk/
chitchat/trunk/MAINTAINER (contents, props changed)
chitchat/trunk/chitchat.pir (contents, props changed)
chitchat/trunk/config/
chitchat/trunk/config/makefiles/
chitchat/trunk/config/makefiles/root.in (contents, props changed)
chitchat/trunk/src/
chitchat/trunk/src/builtins/
chitchat/trunk/src/builtins/say.pir (contents, props changed)
chitchat/trunk/src/parser/
chitchat/trunk/src/parser/actions.pm (contents, props changed)
chitchat/trunk/src/parser/grammar.pg (contents, props changed)
chitchat/trunk/t/
chitchat/trunk/t/00-sanity.t (contents, props changed)
chitchat/trunk/t/harness (contents, props changed)
forth/
forth/branches/
forth/tags/
forth/trunk/
forth/trunk/MAINTAINER (contents, props changed)
forth/trunk/config/
forth/trunk/config/makefiles/
forth/trunk/config/makefiles/root.in (contents, props changed)
forth/trunk/forth.pir (contents, props changed)
forth/trunk/t/
forth/trunk/t/comparison.t (contents, props changed)
forth/trunk/t/conditionals.t (contents, props changed)
forth/trunk/t/harness (contents, props changed)
forth/trunk/t/loop.t (contents, props changed)
forth/trunk/t/math.t (contents, props changed)
forth/trunk/t/new_words.t (contents, props changed)
forth/trunk/t/output.t (contents, props changed)
forth/trunk/t/stack.t (contents, props changed)
forth/trunk/t/variables.t (contents, props changed)
forth/trunk/test.pir (contents, props changed)
forth/trunk/tokenstream.pir (contents, props changed)
forth/trunk/variablestack.pir (contents, props changed)
forth/trunk/virtualstack.pir (contents, props changed)
forth/trunk/words.pir (contents, props changed)
jako/
jako/branches/
jako/tags/
jako/trunk/
jako/trunk/Curses.jako (contents, props changed)
jako/trunk/MAINTAINER (contents, props changed)
jako/trunk/README (contents, props changed)
jako/trunk/SDL.jako (contents, props changed)
jako/trunk/antlr/
jako/trunk/antlr/Main.java (contents, props changed)
jako/trunk/antlr/Makefile (contents, props changed)
jako/trunk/antlr/jako.g (contents, props changed)
jako/trunk/antlr/jakop (contents, props changed)
jako/trunk/config/
jako/trunk/config/makefiles/
jako/trunk/config/makefiles/root.in (contents, props changed)
jako/trunk/docs/
jako/trunk/docs/jako.pod (contents, props changed)
jako/trunk/elem.jako (contents, props changed)
jako/trunk/examples/
jako/trunk/examples/bench.jako (contents, props changed)
jako/trunk/examples/board.jako (contents, props changed)
jako/trunk/examples/euclid.jako (contents, props changed)
jako/trunk/examples/fact.jako (contents, props changed)
jako/trunk/examples/fib.jako (contents, props changed)
jako/trunk/examples/hello.jako (contents, props changed)
jako/trunk/examples/leibniz.jako (contents, props changed)
jako/trunk/examples/life.jako (contents, props changed)
jako/trunk/examples/mandelbrot.jako (contents, props changed)
jako/trunk/examples/mandelzoom.jako (contents, props changed)
jako/trunk/examples/mops.jako (contents, props changed)
jako/trunk/examples/nci.jako (contents, props changed)
jako/trunk/examples/pmc.jako (contents, props changed)
jako/trunk/examples/primes.jako (contents, props changed)
jako/trunk/examples/python.jako (contents, props changed)
jako/trunk/examples/queens.jako (contents, props changed)
jako/trunk/examples/queens_array.jako (contents, props changed)
jako/trunk/examples/sub.jako (contents, props changed)
jako/trunk/io.jako (contents, props changed)
jako/trunk/jako (contents, props changed)
jako/trunk/jakoc (contents, props changed)
jako/trunk/lib/
jako/trunk/lib/Jako/
jako/trunk/lib/Jako/Compiler.pm (contents, props changed)
jako/trunk/lib/Jako/Construct/
jako/trunk/lib/Jako/Construct.pm (contents, props changed)
jako/trunk/lib/Jako/Construct/Block/
jako/trunk/lib/Jako/Construct/Block.pm (contents, props changed)
jako/trunk/lib/Jako/Construct/Block/Bare.pm (contents, props changed)
jako/trunk/lib/Jako/Construct/Block/Conditional/
jako/trunk/lib/Jako/Construct/Block/Conditional.pm (contents, props changed)
jako/trunk/lib/Jako/Construct/Block/Conditional/Else.pm (contents, props changed)
jako/trunk/lib/Jako/Construct/Block/Conditional/If.pm (contents, props changed)
jako/trunk/lib/Jako/Construct/Block/Conditional/Unless.pm (contents, props changed)
jako/trunk/lib/Jako/Construct/Block/File.pm (contents, props changed)
jako/trunk/lib/Jako/Construct/Block/Loop/
jako/trunk/lib/Jako/Construct/Block/Loop.pm (contents, props changed)
jako/trunk/lib/Jako/Construct/Block/Loop/Continue.pm (contents, props changed)
jako/trunk/lib/Jako/Construct/Block/Loop/Until.pm (contents, props changed)
jako/trunk/lib/Jako/Construct/Block/Loop/While.pm (contents, props changed)
jako/trunk/lib/Jako/Construct/Block/Module.pm (contents, props changed)
jako/trunk/lib/Jako/Construct/Block/Sub.pm (contents, props changed)
jako/trunk/lib/Jako/Construct/Declaration/
jako/trunk/lib/Jako/Construct/Declaration.pm (contents, props changed)
jako/trunk/lib/Jako/Construct/Declaration/Constant.pm (contents, props changed)
jako/trunk/lib/Jako/Construct/Declaration/Sub.pm (contents, props changed)
jako/trunk/lib/Jako/Construct/Declaration/Variable.pm (contents, props changed)
jako/trunk/lib/Jako/Construct/Expression/
jako/trunk/lib/Jako/Construct/Expression.pm (contents, props changed)
jako/trunk/lib/Jako/Construct/Expression/Call.pm (contents, props changed)
jako/trunk/lib/Jako/Construct/Expression/Infix.pm (contents, props changed)
jako/trunk/lib/Jako/Construct/Expression/Prefix.pm (contents, props changed)
jako/trunk/lib/Jako/Construct/Expression/Suffix.pm (contents, props changed)
jako/trunk/lib/Jako/Construct/Expression/Value/
jako/trunk/lib/Jako/Construct/Expression/Value.pm (contents, props changed)
jako/trunk/lib/Jako/Construct/Expression/Value/Identifier.pm (contents, props changed)
jako/trunk/lib/Jako/Construct/Expression/Value/Literal.pm (contents, props changed)
jako/trunk/lib/Jako/Construct/Label.pm (contents, props changed)
jako/trunk/lib/Jako/Construct/Statement/
jako/trunk/lib/Jako/Construct/Statement.pm (contents, props changed)
jako/trunk/lib/Jako/Construct/Statement/Arithmetic.pm (contents, props changed)
jako/trunk/lib/Jako/Construct/Statement/Assign.pm (contents, props changed)
jako/trunk/lib/Jako/Construct/Statement/Bitwise.pm (contents, props changed)
jako/trunk/lib/Jako/Construct/Statement/Call.pm (contents, props changed)
jako/trunk/lib/Jako/Construct/Statement/Concat.pm (contents, props changed)
jako/trunk/lib/Jako/Construct/Statement/Decrement.pm (contents, props changed)
jako/trunk/lib/Jako/Construct/Statement/Goto.pm (contents, props changed)
jako/trunk/lib/Jako/Construct/Statement/Increment.pm (contents, props changed)
jako/trunk/lib/Jako/Construct/Statement/LoopControl.pm (contents, props changed)
jako/trunk/lib/Jako/Construct/Statement/New.pm (contents, props changed)
jako/trunk/lib/Jako/Construct/Statement/Return.pm (contents, props changed)
jako/trunk/lib/Jako/Construct/Type/
jako/trunk/lib/Jako/Construct/Type.pm (contents, props changed)
jako/trunk/lib/Jako/Construct/Type/Integer.pm (contents, props changed)
jako/trunk/lib/Jako/Construct/Type/Number.pm (contents, props changed)
jako/trunk/lib/Jako/Construct/Type/PMC.pm (contents, props changed)
jako/trunk/lib/Jako/Construct/Type/String.pm (contents, props changed)
jako/trunk/lib/Jako/Lexer.pm (contents, props changed)
jako/trunk/lib/Jako/Parser.pm (contents, props changed)
jako/trunk/lib/Jako/Processor.pm (contents, props changed)
jako/trunk/lib/Jako/Symbol.pm (contents, props changed)
jako/trunk/lib/Jako/Token.pm (contents, props changed)
jako/trunk/string.jako (contents, props changed)
jako/trunk/sys.jako (contents, props changed)
jako/trunk/t/
jako/trunk/t/assign.jako (contents, props changed)
jako/trunk/t/data_decl.jako (contents, props changed)
jako/trunk/t/examples.t (contents, props changed)
jako/trunk/t/harness (contents, props changed)
lisp/
lisp/branches/
lisp/tags/
lisp/trunk/
lisp/trunk/CHANGES (contents, props changed)
lisp/trunk/KNOWN_BUGS (contents, props changed)
lisp/trunk/LICENSE (contents, props changed)
lisp/trunk/MAINTAINER (contents, props changed)
lisp/trunk/README (contents, props changed)
lisp/trunk/cl.pir (contents, props changed)
lisp/trunk/config/
lisp/trunk/config/makefiles/
lisp/trunk/config/makefiles/root.in (contents, props changed)
lisp/trunk/eval.pir (contents, props changed)
lisp/trunk/include/
lisp/trunk/include/macros/
lisp/trunk/include/macros.pir (contents, props changed)
lisp/trunk/include/macros/assert.pir (contents, props changed)
lisp/trunk/include/macros/error.pir (contents, props changed)
lisp/trunk/include/macros/list.pir (contents, props changed)
lisp/trunk/include/macros/standard.pir (contents, props changed)
lisp/trunk/include/macros/types.pir (contents, props changed)
lisp/trunk/internals.pir (contents, props changed)
lisp/trunk/lib/
lisp/trunk/lib/Parrot/
lisp/trunk/lib/Parrot/Test/
lisp/trunk/lib/Parrot/Test/Lisp.pm (contents, props changed)
lisp/trunk/lisp/
lisp/trunk/lisp.pir (contents, props changed)
lisp/trunk/lisp/bootstrap.l (contents, props changed)
lisp/trunk/lisp/core.l (contents, props changed)
lisp/trunk/lisp/list.l (contents, props changed)
lisp/trunk/lisp/logic.l (contents, props changed)
lisp/trunk/lisp/math.l (contents, props changed)
lisp/trunk/lisp/objects.l (contents, props changed)
lisp/trunk/lisp/pred.l (contents, props changed)
lisp/trunk/read.pir (contents, props changed)
lisp/trunk/system.pir (contents, props changed)
lisp/trunk/t/
lisp/trunk/t/arithmetics.t (contents, props changed)
lisp/trunk/t/atoms.t (contents, props changed)
lisp/trunk/t/cl.t (contents, props changed)
lisp/trunk/t/function.t (contents, props changed)
lisp/trunk/t/harness (contents, props changed)
lisp/trunk/t/hello.t (contents, props changed)
lisp/trunk/t/lexicals.t (contents, props changed)
lisp/trunk/t/read.t (contents, props changed)
lisp/trunk/t/system.t (contents, props changed)
lisp/trunk/types.pir (contents, props changed)
lisp/trunk/validate.pir (contents, props changed)
ook/
ook/branches/
ook/tags/
ook/trunk/
ook/trunk/Changes (contents, props changed)
ook/trunk/MAINTAINER (contents, props changed)
ook/trunk/README (contents, props changed)
ook/trunk/config/
ook/trunk/config/makefiles/
ook/trunk/config/makefiles/root.in (contents, props changed)
ook/trunk/hello.ook (contents, props changed)
ook/trunk/ook.pasm (contents, props changed)
ook/trunk/t/
ook/trunk/t/basic.t (contents, props changed)
ook/trunk/t/harness (contents, props changed)
ook/trunk/test.ook (contents, props changed)
scheme/
scheme/branches/
scheme/tags/
scheme/trunk/
scheme/trunk/MAINTAINER (contents, props changed)
scheme/trunk/README (contents, props changed)
scheme/trunk/config/
scheme/trunk/config/makefiles/
scheme/trunk/config/makefiles/root.in (contents, props changed)
scheme/trunk/lib/
scheme/trunk/lib/Parrot/
scheme/trunk/lib/Parrot/Test/
scheme/trunk/lib/Parrot/Test/Scheme.pm (contents, props changed)
scheme/trunk/lib/Scheme/
scheme/trunk/lib/Scheme.pm (contents, props changed)
scheme/trunk/lib/Scheme/Builtins.pm (contents, props changed)
scheme/trunk/lib/Scheme/Generator.pm (contents, props changed)
scheme/trunk/lib/Scheme/Parser.pm (contents, props changed)
scheme/trunk/lib/Scheme/Tokenizer.pm (contents, props changed)
scheme/trunk/schemec (contents, props changed)
scheme/trunk/t/
scheme/trunk/t/arith/
scheme/trunk/t/arith/basic.t (contents, props changed)
scheme/trunk/t/arith/logic.t (contents, props changed)
scheme/trunk/t/arith/nested.t (contents, props changed)
scheme/trunk/t/harness (contents, props changed)
scheme/trunk/t/io/
scheme/trunk/t/io/basic.t (contents, props changed)
scheme/trunk/t/logic/
scheme/trunk/t/logic/basic.t (contents, props changed)
scheme/trunk/t/logic/defines.t (contents, props changed)
scheme/trunk/t/logic/lists.t (contents, props changed)
scheme/trunk/t/syn/
scheme/trunk/t/syn/basic.t (contents, props changed)
scheme/trunk/t/syn/begin.t (contents, props changed)
urm/
urm/branches/
urm/tags/
urm/trunk/
urm/trunk/INSTALL (contents, props changed)
urm/trunk/LICENSE (contents, props changed)
urm/trunk/MAINTAINER (contents, props changed)
urm/trunk/README (contents, props changed)
urm/trunk/config/
urm/trunk/config/makefiles/
urm/trunk/config/makefiles/root.in (contents, props changed)
urm/trunk/examples/
urm/trunk/examples/biggerzero.urm (contents, props changed)
urm/trunk/examples/distance.urm (contents, props changed)
urm/trunk/examples/div.urm (contents, props changed)
urm/trunk/examples/mult.urm (contents, props changed)
urm/trunk/examples/sim.urm (contents, props changed)
urm/trunk/examples/sub.urm (contents, props changed)
urm/trunk/lib/
urm/trunk/lib/URM/
urm/trunk/lib/URM/Test.pm (contents, props changed)
urm/trunk/t/
urm/trunk/t/harness (contents, props changed)
urm/trunk/t/in_out.t (contents, props changed)
urm/trunk/t/mmu.t (contents, props changed)
urm/trunk/t/syn.t (contents, props changed)
urm/trunk/urm-old.pl (contents, props changed)
urm/trunk/urmc (contents, props changed)
Added: bf/trunk/MAINTAINER
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ bf/trunk/MAINTAINER Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,4 @@
+# $Id$
+
+N: Leon Brocard
+E: acme at astray.com
Added: bf/trunk/README
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ bf/trunk/README Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,38 @@
+DESCRIPTION
+
+This is a Brainfuck interpreter for Parrot. Brainfuck is a full
+computer programming language with only eight commands. For more
+information, see http://www.catseye.mb.ca/esoteric/bf/ or
+http://en.wikipedia.org/wiki/Brainfuck.
+
+To compile the files:
+
+ $ make
+
+To check that the compiler is working:
+
+ $ make test
+
+To run an example Brainfuck program:
+
+ $ ../../parrot bf.pasm helloworld.bf
+
+There is also a compiler:
+
+ $ ../../parrot bfc.pir helloworld.bf
+
+Clifford Wolf <clifford (at) clifford.at> contributed a nice bf
+program:
+
+ $ cat cw.txt
+ $ ../../parrot bf.pasm cw.bf < cw.txt > cw.c
+ $ cc -o cw cw.c
+ $ ./cw
+
+If you want to run it faster, use the bf compiler:
+
+ $ ../../parrot -j bfc.pir cw.bf < cw.txt > cw.c
+
+AUTHOR
+
+Leon Brocard <acme at astray.com>
Added: bf/trunk/bench.bf
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ bf/trunk/bench.bf Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,6 @@
+*LL*LH*FF*01
+>++[<+++++++++++++>-]<[[>+>+<<-]>[<+>-]++++++++
+[>++++++++<-]>.[-]<<>++++++++++[>++++++++++[>++
+++++++++[>++++++++++[>++++++++++[>++++++++++[>+
++++++++++[-]<-]<-]<-]<-]<-]<-]<-]++++++++++.
+*00
Added: bf/trunk/bf.pasm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ bf/trunk/bf.pasm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,135 @@
+# $Id$
+# A Brainfuck interpreter
+# By Leon Brocard <acme at astray.com>
+#
+# See http://www.catseye.mb.ca/esoteric/bf/
+# for more information on this silly language
+
+ get_params '0', P5 # P5 = @ARGV
+ # Get the brainfuck source file into S0
+ set S0, P5[1]
+ if S0, SOURCE
+usage:
+ set S0, P5[0]
+ print "usage: ./parrot "
+ print S0
+ print " file.bf\n"
+ end
+
+ # Read the file into S1
+SOURCE:
+ null I3
+ ne S0, "-O", no_o
+ set I3, 1 # optimize switch
+ set S0, P5[2]
+no_o:
+ open P1, S0, 'r'
+ defined I0, P1
+ unless I0, usage
+SOURCE_LOOP:
+ readline S2, P1
+ concat S1, S2
+ if S2, SOURCE_LOOP
+ close P1
+
+ length I30, S1
+
+ # Initialise
+
+ set I0, 0 # Our program counter
+ new P0, 'ResizableIntegerArray' # Our memory
+ set I1, 0 # Our pointer
+ getstdin P30
+
+ # The main interpreter loop
+INTERP:
+ substr S0, S1, I0, 1
+ ne S0, "+", NOTPLUS
+ set I2, P0[I1]
+ inc I2
+ band I2, 0xff
+ set P0[I1], I2
+ branch NEXT
+
+NOTPLUS:
+ ne S0, "-", NOTMINUS
+ set I2, P0[I1]
+ dec I2
+ band I2, 0xff
+ set P0[I1], I2
+ branch NEXT
+
+NOTMINUS:
+ ne S0, ">", NOTGT
+ inc I1
+ branch NEXT
+
+NOTGT:
+ ne S0, "<", NOTLT
+ dec I1
+ branch NEXT
+
+NOTLT:
+ ne S0, "[", NOTOPEN
+
+ set I2, P0[I1]
+ if I2, NEXT
+ set I2, 0 # "depth"
+
+OPEN_LOOP:
+ inc I0
+ substr S2, S1, I0, 1
+ ne S2, "[", OPEN_NOTOPEN
+ inc I2
+ branch OPEN_LOOP
+OPEN_NOTOPEN:
+ ne S2, "]", OPEN_LOOP
+ eq I2, 0, NEXT
+ dec I2
+ branch OPEN_LOOP
+
+NOTOPEN:
+ ne S0, "]", NOTCLOSE
+ unless I3, no_opt
+ set I2, P0[I1]
+ unless I2, NEXT
+no_opt:
+ set I2, 0 # "height"
+
+CLOSE_LOOP:
+ dec I0
+ substr S2, S1, I0, 1
+ ne S2, "]", CLOSE_NOTCLOSE
+ inc I2
+ branch CLOSE_LOOP
+CLOSE_NOTCLOSE:
+ ne S2, "[", CLOSE_LOOP
+ eq I2, 0, INTERP
+ dec I2
+ branch CLOSE_LOOP
+
+NOTCLOSE:
+ ne S0, ".", NOTDOT
+ set I2, P0[I1]
+ chr S31, I2
+ print S31
+ branch NEXT
+
+NOTDOT:
+ ne S0, ",", NEXT
+ read S31, P30, 1
+ if S31, no_eof
+ null I2 # some return -1, some don't change data
+ branch eof
+no_eof:
+ ord I2, S31
+eof:
+ set P0[I1], I2
+ branch NEXT
+
+NEXT:
+ inc I0
+ lt I0, I30, INTERP
+ end
+
+
Added: bf/trunk/bfc.pir
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ bf/trunk/bfc.pir Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,262 @@
+# $Id$
+# A Brainfuck compiler
+# By Leon Brocard <acme at astray.com>
+#
+# See http://www.catseye.mb.ca/esoteric/bf/
+# for more information on this silly language
+.sub _main
+ .param pmc argv
+ .local int pc
+ .local int maxpc
+ .local int label
+ .local string labelstr
+ .local string code
+ .local string filename
+ .local string file
+ .local string line
+ .local string program
+ .local string char
+
+ program = argv[0]
+ # check argc
+ $I0 = argv
+ if $I0 < 2 goto usage
+ # Get the filename
+ filename = argv[1]
+ if filename goto SOURCE
+usage:
+ print "usage: ../../parrot "
+ print program
+ print " file.bf\n"
+ end
+
+ # Read the file into S1
+SOURCE:
+ open $P1, filename, 'r'
+ defined $I0, $P1
+ if $I0, SOURCE_LOOP
+ print filename
+ print " not found\n"
+ branch usage
+SOURCE_LOOP:
+ read line, $P1, 1024
+ file = file . line
+ if line goto SOURCE_LOOP
+ close $P1
+
+ length maxpc, file
+
+ # Initialise
+ code = "set I0, 0 # pc\n"
+ # concat code, "trace 1\n"
+ concat code, "new P0, .ResizableIntegerArray # memory\n"
+ # this array doesn't support negative indices properly
+ # start with some offset
+ concat code, "set I1, 256 # pointer\n"
+ concat code, "getstdout P30\n"
+ concat code, "pop S0, P30\n # unbuffer\n"
+ concat code, "getstdin P30\n"
+
+ pc = 0 # pc
+ label = 0 # label count
+
+ # The main compiler loop
+INTERP:
+ substr_r char, file, pc, 1
+ concat code, "\nSTEP"
+ labelstr = pc
+ concat code, labelstr
+ concat code, ": # "
+ concat code, char
+ concat code, "\n"
+
+ if char != "+" goto NOTPLUS
+ .local int n_plus
+ null n_plus
+ $I0 = pc + 1
+plus_loop:
+ inc n_plus
+ if $I0 == maxpc goto emit_plus
+ substr_r char, file, $I0, 1
+ if char != "+" goto emit_plus
+ inc $I0
+ goto plus_loop
+emit_plus:
+ pc = $I0 - 1
+ concat code, "set I2, P0[I1]\n"
+ concat code, "add I2, "
+ $S0 = n_plus
+ concat code, $S0
+ concat code, "\n"
+ concat code, "band I2, 0xff\n"
+ concat code, "set P0[I1], I2\n"
+ goto NEXT
+
+NOTPLUS:
+ if char != "-" goto NOTMINUS
+ .local int n_minus
+ null n_minus
+ $I0 = pc + 1
+minus_loop:
+ inc n_minus
+ if $I0 == maxpc goto emit_minus
+ substr_r char, file, $I0, 1
+ if char != "-" goto emit_minus
+ inc $I0
+ goto minus_loop
+emit_minus:
+ pc = $I0 - 1
+ concat code, "set I2, P0[I1]\n"
+ concat code, "sub I2, "
+ $S0 = n_minus
+ concat code, $S0
+ concat code, "\n"
+ concat code, "band I2, 0xff\n"
+ concat code, "set P0[I1], I2\n"
+ goto NEXT
+
+NOTMINUS:
+ if char != ">" goto NOTGT
+ .local int n_gt
+ null n_gt
+ $I0 = pc + 1
+gt_loop:
+ inc n_gt
+ if $I0 == maxpc goto emit_gt
+ substr_r char, file, $I0, 1
+ if char != ">" goto emit_gt
+ inc $I0
+ goto gt_loop
+emit_gt:
+ pc = $I0 - 1
+ concat code, "add I1, "
+ $S0 = n_gt
+ concat code, $S0
+ concat code, "\n"
+ goto NEXT
+
+NOTGT:
+ if char != "<" goto NOTLT
+ .local int n_lt
+ null n_lt
+ $I0 = pc + 1
+lt_loop:
+ inc n_lt
+ if $I0 == maxpc goto emit_lt
+ substr_r char, file, $I0, 1
+ if char != "<" goto emit_lt
+ inc $I0
+ goto lt_loop
+emit_lt:
+ pc = $I0 - 1
+ concat code, "sub I1, "
+ $S0 = n_lt
+ concat code, $S0
+ concat code, "\n"
+ goto NEXT
+
+NOTLT:
+ if char != "[" goto NOTOPEN
+
+ .local int depth
+
+ label = pc
+OPEN_LOOP:
+ inc label
+ substr $S2, file, label, 1
+ if $S2 != "[" goto OPEN_NOTOPEN
+ inc depth
+ goto OPEN_LOOP
+OPEN_NOTOPEN:
+ if $S2 != "]" goto OPEN_LOOP
+ if depth == 0 goto OPEN_NEXT
+ dec depth
+ goto OPEN_LOOP
+OPEN_NEXT:
+ inc label
+ labelstr = label
+ concat code, "set I2, P0[I1]\n"
+ concat code, "unless I2, STEP"
+ concat code, labelstr
+ concat code, "\n"
+
+ goto NEXT
+
+NOTOPEN:
+ if char != "]" goto NOTCLOSE
+
+ label = pc
+ depth = 0 # "height"
+
+CLOSE_LOOP:
+ dec label
+ substr $S2, file, label, 1
+ if $S2 != "]" goto CLOSE_NOTCLOSE
+ inc depth
+ goto CLOSE_LOOP
+CLOSE_NOTCLOSE:
+ if $S2 != "[" goto CLOSE_LOOP
+ if depth == 0 goto CLOSE_NEXT
+ dec depth
+ goto CLOSE_LOOP
+
+CLOSE_NEXT:
+ labelstr = label
+ concat code, "branch STEP"
+ concat code, labelstr
+ concat code, "\n"
+
+ goto NEXT
+
+NOTCLOSE:
+ if char != "." goto NOTDOT
+ concat code, "set I2, P0[I1]\n"
+ concat code, "chr S31, I2\n"
+ concat code, "print S31\n"
+ goto NEXT
+
+NOTDOT:
+ if char != "," goto NEXT
+ labelstr = pc
+ concat code, "read S31, P30, 1\n"
+ concat code, "if S31, no_eof"
+ concat code, labelstr
+ concat code, "\n"
+ concat code, "null I2\n"
+ concat code, "branch eof"
+ concat code, labelstr
+ concat code, "\n"
+ concat code, "no_eof"
+ concat code, labelstr
+ concat code, ":\n"
+ concat code, "ord I2, S31\n"
+ concat code, "eof"
+ concat code, labelstr
+ concat code, ":\n"
+ concat code, "set P0[I1], I2\n"
+ goto NEXT
+
+NEXT:
+ inc pc
+
+ if pc < maxpc goto INTERP
+ labelstr = pc
+ concat code, "STEP"
+ concat code, labelstr
+ concat code, ":\n"
+ concat code, "end\n"
+
+ # printerr code
+ # printerr "\n"
+
+ # Now actually run it
+ compreg $P1, "PASM"
+ $P0 = $P1( code )
+ $P0()
+.end
+
+# Local Variables:
+# mode: pir
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:
Added: bf/trunk/bfco.pir
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ bf/trunk/bfco.pir Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,284 @@
+# $Id$
+#
+# An Optimizing Brainfuck compiler
+# By Leo based on bfc.imc by Leon
+
+# emit register-only code
+# XXX does no register range checking
+# it runs the bench.bf 15 times faster then bfc.imc
+
+.sub main :main
+ .param pmc argv
+
+ .local int pc
+ .local int maxpc
+ .local int label
+ .local string labelstr
+ .local string code
+ .local string filename
+ .local string file
+ .local string line
+ .local string program
+ .local string char
+
+ program = argv[0]
+ # check argc
+ $I0 = argv
+ if $I0 < 2 goto usage
+ # Get the filename
+ filename = argv[1]
+ if filename goto SOURCE
+usage:
+ print "usage: ../../parrot "
+ print program
+ print " file.bf\n"
+ end
+
+ # Read the file into S1
+SOURCE:
+ open $P1, filename, 'r'
+ defined $I0, $P1
+ if $I0, SOURCE_LOOP
+ print filename
+ print " not found\n"
+ branch usage
+SOURCE_LOOP:
+ read line, $P1, 1024
+ file = file . line
+ if line goto SOURCE_LOOP
+ close $P1
+
+ maxpc = length file
+
+ # Initialise
+ code = "# Code generated by bfco.pir\n"
+ # concat code, "trace 1\n"
+ concat code, "new P0, 'ResizableIntegerArray' # memory\n"
+ # this array doesn't support negative indices properly
+ # start with some offset
+ concat code, "getstdout P30\n"
+ concat code, "pop S0, P30\n # unbuffer\n"
+ concat code, "getstdin P30\n"
+
+ pc = 0 # pc
+ label = 0 # label count
+ .local int depth, n_lt, n_gt, reg
+ reg = 0
+ concat code, " cleari\n"
+
+ # The main compiler loop
+INTERP:
+ substr_r char, file, pc, 1
+ concat code, "\nSTEP"
+ labelstr = pc
+ concat code, labelstr
+ concat code, ": # "
+ concat code, char
+ concat code, "\n"
+
+ if char != "+" goto NOTPLUS
+ .local int n_plus
+ null n_plus
+ $I0 = pc + 1
+plus_loop:
+ inc n_plus
+ if $I0 == maxpc goto emit_plus
+ substr_r char, file, $I0, 1
+ if char != "+" goto emit_plus
+ inc $I0
+ goto plus_loop
+emit_plus:
+ pc = $I0 - 1
+ concat code, " add I"
+ set $S1, reg
+ concat code, $S1
+ concat code, ", "
+ $S0 = n_plus
+ concat code, $S0
+ concat code, "\n"
+ concat code, " band I"
+ concat code, $S1
+ concat code, ", 0xff\n"
+ goto NEXT
+
+NOTPLUS:
+ if char != "-" goto NOTMINUS
+ .local int n_minus
+ null n_minus
+ $I0 = pc + 1
+minus_loop:
+ inc n_minus
+ if $I0 == maxpc goto emit_minus
+ substr_r char, file, $I0, 1
+ if char != "-" goto emit_minus
+ inc $I0
+ goto minus_loop
+emit_minus:
+ pc = $I0 - 1
+ concat code, " sub I"
+ set $S1, reg
+ concat code, $S1
+ concat code, ", "
+ $S0 = n_minus
+ concat code, $S0
+ concat code, "\n"
+ concat code, " band I"
+ concat code, $S1
+ concat code, ", 0xff\n"
+ goto NEXT
+
+NOTMINUS:
+ if char != ">" goto NOTGT
+
+ null n_gt
+ $I0 = pc + 1
+gt_loop:
+ inc n_gt
+ if $I0 == maxpc goto emit_gt
+ substr_r char, file, $I0, 1
+ if char != ">" goto emit_gt
+ inc $I0
+ goto gt_loop
+emit_gt:
+ reg += n_gt
+ bsr debug
+ pc = $I0 - 1
+ goto NEXT
+
+NOTGT:
+ if char != "<" goto NOTLT
+ null n_lt
+ $I0 = pc + 1
+lt_loop:
+ inc n_lt
+ if $I0 == maxpc goto emit_lt
+ substr_r char, file, $I0, 1
+ if char != "<" goto emit_lt
+ inc $I0
+ goto lt_loop
+emit_lt:
+ reg -= n_lt
+ bsr debug
+ pc = $I0 - 1
+ goto NEXT
+
+NOTLT:
+ if char != "[" goto NOTOPEN
+
+ label = pc
+ depth = 0
+OPEN_LOOP:
+ inc label
+ substr $S2, file, label, 1
+ if $S2 != "[" goto OPEN_NOTOPEN
+ inc depth
+ goto OPEN_LOOP
+OPEN_NOTOPEN:
+ if $S2 != "]" goto OPEN_LOOP
+ if depth == 0 goto OPEN_NEXT
+ dec depth
+ goto OPEN_LOOP
+OPEN_NEXT:
+ inc label
+ labelstr = label
+ concat code, " unless I"
+ set $S0, reg
+ concat code, $S0
+ concat code, ", STEP"
+ concat code, labelstr
+ concat code, "\n"
+
+ goto NEXT
+
+NOTOPEN:
+ if char != "]" goto NOTCLOSE
+
+ label = pc
+ depth = 0 # "height"
+
+CLOSE_LOOP:
+ dec label
+ substr $S2, file, label, 1
+ if $S2 != "]" goto CLOSE_NOTCLOSE
+ inc depth
+ goto CLOSE_LOOP
+CLOSE_NOTCLOSE:
+ if $S2 != "[" goto CLOSE_LOOP
+ if depth == 0 goto CLOSE_NEXT
+ dec depth
+ goto CLOSE_LOOP
+
+CLOSE_NEXT:
+ labelstr = label
+ concat code, " branch STEP"
+ concat code, labelstr
+ concat code, "\n"
+
+ goto NEXT
+
+NOTCLOSE:
+ if char != "." goto NOTDOT
+ concat code, " chr S31, I"
+ $S0 = reg
+ concat code, $S0
+ concat code, "\n"
+ concat code, " print S31\n"
+ goto NEXT
+
+NOTDOT:
+ if char != "," goto NEXT
+ labelstr = pc
+ concat code, " read S31, P30, 1\n"
+ concat code, " if S31, no_eof"
+ concat code, labelstr
+ concat code, "\n"
+ concat code, " null I31\n"
+ concat code, " branch eof"
+ concat code, labelstr
+ concat code, "\n"
+ concat code, "no_eof"
+ concat code, labelstr
+ concat code, ":\n"
+ concat code, " ord I31, S31\n"
+ concat code, "eof"
+ concat code, labelstr
+ concat code, ":\n"
+ $S0 = reg
+ concat code, " set I"
+ concat code, $S0
+ concat code, ", I31\n"
+ goto NEXT
+
+NEXT:
+ inc pc
+
+ if pc < maxpc goto INTERP
+ labelstr = pc
+ concat code, "STEP"
+ concat code, labelstr
+ concat code, ":\n"
+ concat code, "end\n"
+
+ # Now actually run it
+ $P1 = compreg "PASM"
+ $P0 = $P1( code )
+ $P0()
+ end
+
+debug:
+ ret
+ concat code, "# depth "
+ $S0 = depth
+ concat code, $S0
+ concat code, " reg "
+ $S0 = reg
+ concat code, $S0
+ concat code, "\n"
+ ret
+.end
+
+# Local Variables:
+# mode: pir
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:
Added: bf/trunk/config/makefiles/root.in
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ bf/trunk/config/makefiles/root.in Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,51 @@
+# Copyright (C) 2002-2009, Parrot Foundation.
+# $Id$
+
+RM_F = @rm_f@
+PERL = @perl@
+PARROT=../../parrot
+#CONDITIONED_LINE(darwin):
+#CONDITIONED_LINE(darwin):# MACOSX_DEPLOYMENT_TARGET must be defined for OS X compilation/linking
+#CONDITIONED_LINE(darwin):export MACOSX_DEPLOYMENT_TARGET := @osx_version@
+
+default: build
+
+help :
+ @echo ""
+ @echo "Following targets are available for the user:"
+ @echo ""
+ @echo " build: build bf.pbc and bfc.pir"
+ @echo " This is the default."
+ @echo ""
+ @echo " test: run the test suite,"
+ @echo ""
+ @echo " clean: clean up temporary files"
+ @echo ""
+ @echo " realclean: clean up generated files"
+ @echo ""
+ @echo " help: print this help message"
+
+test: build
+ $(PERL) -Ilib -I../../lib t/harness
+
+build: bf.pbc bfc.pbc bfco.pbc
+
+bf.pbc: bf.pasm
+ $(PARROT) -o bf.pbc bf.pasm
+
+bfc.pbc: bfc.pir
+ $(PARROT) -o bfc.pbc bfc.pir
+
+bfco.pbc: bfco.pir
+ $(PARROT) -o bfco.pbc bfco.pir
+
+clean:
+ $(RM_F) core "*.pbc" "*~"
+
+realclean: clean
+ $(RM_F) Makefile
+
+# Local variables:
+# mode: makefile
+# End:
+# vim: ft=make:
Added: bf/trunk/countdown.bf
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ bf/trunk/countdown.bf Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,3 @@
+++++++++++++++++++++++++++++++++[>+>+<<-]
+>>+++++++++++++++++++++++++<<
+++++++++++[>>.-<.<-]
\ No newline at end of file
Added: bf/trunk/cw.bf
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ bf/trunk/cw.bf Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,46 @@
+>>+++[<+++++[<+++++++>-]>-]<<.>>>+++++[<+++++++++++[<++>-]>-]<<.>++++>
+>++++[<++++[<+++++++>-]>-]<<.>++>+++++[<++++++>-]<.>+>>++++[<+++++++++
+[<+++>-]>-]<<.>+>>++++[<++++[<++++++>-]>-]<<.<<<<<.>.>>>>>+>++++++++++
++++[<+++>-]<.>++>+++++++++++++[<+++>-]<.>++>+++++++++++[<+++++++++++>-
+]<.>>+++++++++[<+++++++++++>-]<.>++>+++++++++++++++++[<++++++>-]<.<<<<
+<.>>>>>>++>>++++[<++++[<+++++++>-]>-]<<.>>+++++++[<++++++>-]<.<<<<<<<.
+>>>>>>>>+>>++++[<+++++[<+++>-]>-]<<.>+>+++++++++++[<+++>-]<.>+[[-]>,[>
++>[-]+>+<<<-]>>[[-]>+[<[-]+>-]<[<<<+>>>[-]]]>[-]<<[>+>+<<-]>[<+>-]+>--
+--------[<[-]>[-]]<[-<<+>>]<[>+>+<<-]>[<+>-]+>-->+++++[<------>-]<[<[-
+]>[-]]<[-<<++>>]<[>+>+<<-]>[<+>-]+>-->+++++++++[<----->-]<[<[-]>[-]]<[
+-<<+++>>]<[>+>+<<-]>[<+>-]+>>+++++[<------------------->-]<[<[-]>[-]]<
+[-<<++++>>]<[>+>+<<-]>[<+>-]+>->+++++++[<------------->-]<[<[-]>[-]]<[
+-<<+++++>>]<[>+>+<<-]>[<+>-]+>--->+++++++++++[<----------->-]<[<[-]>[-
+]]<[-<<++++++>>]<[-]>[-],[>+>+<<-]>[<+>-]+>----------[<[-]>[-]]<[-<<+>
+>]<[>+>+<<-]>[<+>-]+>-->+++++[<------>-]<[<[-]>[-]]<[-<<++>>]<[>+>+<<-
+]>[<+>-]+>-->+++++++++[<----->-]<[<[-]>[-]]<[-<<+++>>]<[>+>+<<-]>[<+>-
+]+>>+++++[<------------------->-]<[<[-]>[-]]<[-<<++++>>]<[>+>+<<-]>[<+
+>-]+>->+++++++[<------------->-]<[<[-]>[-]]<[-<<+++++>>]<[>+>+<<-]>[<+
+>-]+>--->+++++++++++[<----------->-]<[<[-]>[-]]<[-<<++++++>>]<[-]<[->+
+<]>[-<+++++++>]<[-<+>]<>+++++[<+++++++>-]<<[>.>+<<[-]]>[-]>[-<<+>>]<<]
+<.>>>>>++++[<+++++++++++>-]<.<<<<<<.>>>>>>>>>+++++++[<+++++++[<++>-]>-
+]<<.<<<<<<.>.>>>>>>>+++++++++[<+++++++>-]<.>+>+++++++[<+++++++++++++>-
+]<.<<<<<<<<<<<<<<<<<<<<.>>.>>>>>>>>>>>>>>>>>>>++>+++++++++[<+++++>-]<.
+>>+++++[<+++++++++++++++++++>-]<.<<..>>>+++>+++++++++++[<+++++++++++>-
+]<.<<<<<<<<<<.>>>>>>>>>>>++++>+++++[<+++++++++++>-]<.>>+++++++[<++++++
++++++++++++>-]<.<<<<<<<<<<<<<<<<.<<<<<<<<<<.>>>>>>>>>>>>>>>>>>>>>>>>>>
+>>>++++[<+++++++++[<+++>-]>-]<<.>+>>++++[<+++++[<+++++>-]>-]<<.<<<<<<<
+<<<<<<<<<<<<<<<.>>>>>>.<<<<<<<.>>.>.>>>>>>>>>>>>>>>>>>>>>>>++++[<++++[
+<+++++++>-]>-]<<.>>+++++++++[<+++++++++++++>-]<.<<<<<<<<<<<<<<<<<<<<<<
+<<<<<<.>>>>>>>.>.<<<<<.>>>>>>.<<<<<.>>>>>>>>>>>>>.>>>>>>>>>>>>>+++++++
+[<+++++++++++++>-]<.<<<<<<<<<<<<<<<<<<<<<<<<<.>>>>>>.<<<<<<<.>>>>>>>>>
+>>>>>>>>>>>>>>>>>>>+++++++++[<+++++>-]<.>>+++++++++++++[<+++>-]<.>>+++
+++[<+++++++>-]<.<.<<<<<<<<<<<<<<<<<<<<<<<<<<.>>>>>>>>>>>>>>>>>>>>>>>>>
+>>>+>++++[<+++++++++>-]<.>>+++++[<+++++++++++>-]<.>++>+++++++[<+++++++
+++++++>-]<.<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<.>>>>>>>>>>>>>>>>>>.>>>>.>.<<
+<<<<<<<<<<<<<<<<<<<<<<<<<<.>>>>>>>.>.<<<<<.>>>>>>.<<<<<.>>>>>>>>>>>>>.
+>>>>>>>>>>>>.<<<<<<<<<<<<<<<<<<<<<<<<<.>>>>>>.<<<<<<.<.>>>>>>>>>>>>>>>
+>>>>>>>>>>>>>>>>>>+>+++++++[<++++++>-]<..<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+<<.>>>>>>>>>>>>>>>>>>>>>>>>>.>>>>>>>++>+++++++[<+++++++>-]<.>+>++++[<+
+++++++++++++>-]<.<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<.>>>>>>>>>>>>>>>.>>>
+>>>>>>>>>>>.>.<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<.>>>>>>>>>>>>>>>>>>.>>>>>>
+>>>>>>>>>>>>+++++[<+++++[<+++++>-]>-]<<.<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+.>>>>>>>>>>>>>>>>>.<<<<<<<<<<<<<<<<<<<<<<<<<<.>>>>>>>>>>>>>>>>>>>>>>>>
+>>>>.<<<<<<<<<<<<<<<<<<<.<<<<<<<<<<.>>.>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+>>>>>>>>+++>+++++++++[<+++++>-]<.<<<<<<<<<<<<<<<<<.>>>>>>>>>>>>>>>>.>>
+++++++++++.
Added: bf/trunk/cw.txt
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ bf/trunk/cw.txt Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,6 @@
+ ____ _ _ __ __ _ _ _ _ ___ _____
+ / ___| |__ __ _ ___ ___| |_ _ __ ___ / _|/ _| / / | / / | / _ \___ /
+| | | _ \ / _| |/ _ \/ __| __| |__/ _ \ |_| |_ | | | | | || | | ||_ \
+| |___| | | | |_| | |_| \__ \ |_| | | __/ _| _| | | |_| | || |_| |__| |
+ \____|_| |_|\__|_|\___/|___/\__|_| \___|_| |_| |_|_|_|_|_|_\___/____/
+
Added: bf/trunk/helloworld.bf
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ bf/trunk/helloworld.bf Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,3 @@
+>+++++++++[<++++++++>-]<.>+++++++[<++++>-]<+.+++++++..+++.[-]>++++++++[<++++>-]
+<.>+++++++++++[<+++++>-]<.>++++++++[<+++>-]<.+++.------.--------.[-]>++++++++[
+<++++>-]<+.[-]++++++++++.
Added: bf/trunk/t/harness
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ bf/trunk/t/harness Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,31 @@
+#! perl
+
+# $Id$
+
+=head1 NAME
+
+languages/bf/t/harness - A harness for bf
+
+=head1 SYNOPSIS
+
+ cd languages && perl -I../lib bf/t/harness --files
+
+ cd languages && perl -I../lib bf/t/harness
+
+ cd languages && perl -I../lib bf/t/harness \
+ bf/t/test_bf.t \
+ bf/t/test_bfc.t
+
+=head1 DESCRIPTION
+
+If I'm called with a single
+argument of "--files", I just return a list of files to process.
+This list is one per line, and is relative to the languages dir.
+
+If I'm called with no args, I run the complete suite.
+
+Otherwise I run the tests that were passed on the command line.
+
+=cut
+
+use Parrot::Test::Harness language => 'bf';
Added: bf/trunk/t/test_bf.t
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ bf/trunk/t/test_bf.t Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,6 @@
+# $Id$
+
+# Test bf compiler
+# Print TAP, Test Anything Protocol
+
+system( "../parrot -r bf/bf.pbc bf/test.bf" );
Added: bf/trunk/t/test_bfc.t
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ bf/trunk/t/test_bfc.t Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,6 @@
+# $Id$
+
+# Test bf interpreter
+# Print TAP, Test Anything Protocol
+
+system( "../parrot -r bf/bfc.pbc bf/test.bf" );
Added: bf/trunk/t/test_bfco.t
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ bf/trunk/t/test_bfco.t Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,6 @@
+# $Id$
+
+# Test bf interpreter
+# Print TAP, Test Anything Protocol
+
+system( "../parrot -r bf/bfco.pbc bf/test.bf" );
Added: bf/trunk/test.bf
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ bf/trunk/test.bf Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,11 @@
+Simple TAP style test script by Leon Brocard acme at astray DOT com
++++++++++++++++++++++++++++++++++++++++++++++++++.
+---.
+.
++++.
+---------------------------------------.
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++.
+----.
+---------------------------------------------------------------------------.
++++++++++++++++++.
+---------------------------------------.
Added: chitchat/trunk/MAINTAINER
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ chitchat/trunk/MAINTAINER Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1 @@
+N: Stephen Weeks
Added: chitchat/trunk/chitchat.pir
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ chitchat/trunk/chitchat.pir Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,81 @@
+=head1 TITLE
+
+chitchat.pir - A ChitChat compiler.
+
+=head2 Description
+
+This is the base file for the ChitChat compiler.
+
+This file includes the parsing and grammar rules from
+the src/ directory, loads the relevant PGE libraries,
+and registers the compiler under the name 'ChitChat'.
+
+=head2 Functions
+
+=over 4
+
+=item onload()
+
+Creates the ChitChat compiler using a C<PCT::HLLCompiler>
+object.
+
+=cut
+
+.namespace [ 'Transcript' ]
+
+.sub 'show:' :method
+ .param pmc arg
+ say arg
+.end
+
+.namespace []
+
+.sub 'onload' :anon :load :init
+ $P0 = newclass 'Transcript'
+ $P0 = new 'Transcript'
+ set_hll_global 'Transcript', $P0
+.end
+
+.namespace [ 'ChitChat::Compiler' ]
+
+.loadlib 'chitchat_group'
+
+.sub 'onload' :anon :load :init
+ load_bytecode 'PCT.pbc'
+
+ $P0 = get_hll_global ['PCT'], 'HLLCompiler'
+ $P1 = $P0.'new'()
+ $P1.'language'('ChitChat')
+ $P1.'parsegrammar'('ChitChat::Grammar')
+ $P1.'parseactions'('ChitChat::Grammar::Actions')
+.end
+
+=item main(args :slurpy) :main
+
+Start compilation by passing any command line C<args>
+to the ChitChat compiler.
+
+=cut
+
+.sub 'main' :main
+ .param pmc args
+
+ $P0 = compreg 'ChitChat'
+ $P1 = $P0.'command_line'(args)
+.end
+
+
+.include 'src/gen_builtins.pir'
+.include 'src/gen_grammar.pir'
+.include 'src/gen_actions.pir'
+
+=back
+
+=cut
+
+# Local Variables:
+# mode: pir
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:
+
Added: chitchat/trunk/config/makefiles/root.in
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ chitchat/trunk/config/makefiles/root.in Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,130 @@
+# Copyright (C) 2008-2009, Parrot Foundation.
+## $Id$
+
+## arguments we want to run parrot with
+PARROT_ARGS =
+
+## configuration settings
+BUILD_DIR = @build_dir@
+LOAD_EXT = @load_ext@
+O = @o@
+
+## Setup some commands
+LN_S = @lns@
+PERL = @perl@
+RM_RF = @rm_rf@
+CP = @cp@
+PARROT = ../../parrot at exe@
+CAT = @cat@
+BUILD_DYNPMC = $(PERL) $(BUILD_DIR)/tools/build/dynpmc.pl
+RECONFIGURE = $(PERL) $(BUILD_DIR)/tools/dev/reconfigure.pl
+#CONDITIONED_LINE(darwin):
+#CONDITIONED_LINE(darwin):# MACOSX_DEPLOYMENT_TARGET must be defined for OS X compilation/linking
+#CONDITIONED_LINE(darwin):export MACOSX_DEPLOYMENT_TARGET := @osx_version@
+
+## places to look for things
+PARROT_DYNEXT = $(BUILD_DIR)/runtime/parrot/dynext
+PGE_LIBRARY = $(BUILD_DIR)/runtime/parrot/library/PGE
+PERL6GRAMMAR = $(PGE_LIBRARY)/Perl6Grammar.pbc
+NQP = $(BUILD_DIR)/compilers/nqp/nqp.pbc
+PCT = $(BUILD_DIR)/runtime/parrot/library/PCT.pbc
+
+PMC_DIR = src/pmc
+
+all: chitchat.pbc
+
+CHITCHAT_GROUP = $(PMC_DIR)/chitchat_group$(LOAD_EXT)
+
+SOURCES = chitchat.pir \
+ src/gen_grammar.pir \
+ src/gen_actions.pir \
+ src/gen_builtins.pir \
+# $(CHITCHAT_GROUP)
+
+BUILTINS_PIR = \
+ src/builtins/say.pir \
+
+# PMCS = chitchat
+# PMC_SOURCES = $(PMC_DIR)/chitchat.pmc
+
+# the default target
+chitchat.pbc: $(PARROT) $(SOURCES)
+ $(PARROT) $(PARROT_ARGS) -o chitchat.pbc chitchat.pir
+
+src/gen_grammar.pir: $(PERL6GRAMMAR) src/parser/grammar.pg
+ $(PARROT) $(PARROT_ARGS) $(PERL6GRAMMAR) \
+ --output=src/gen_grammar.pir \
+ src/parser/grammar.pg
+
+src/gen_actions.pir: $(NQP) $(PCT) src/parser/actions.pm
+ $(PARROT) $(PARROT_ARGS) $(NQP) --output=src/gen_actions.pir \
+ --target=pir src/parser/actions.pm
+
+src/gen_builtins.pir: $(BUILTINS_PIR)
+ $(CAT) $(BUILTINS_PIR) >src/gen_builtins.pir
+
+$(CHITCHAT_GROUP): $(PARROT) $(PMC_SOURCES)
+ cd $(PMC_DIR) && $(BUILD_DYNPMC) generate $(PMCS)
+ cd $(PMC_DIR) && $(BUILD_DYNPMC) compile $(PMCS)
+ cd $(PMC_DIR) && $(BUILD_DYNPMC) linklibs $(PMCS)
+ cd $(PMC_DIR) && $(BUILD_DYNPMC) copy --destination=$(PARROT_DYNEXT) $(PMCS)
+
+# regenerate the Makefile
+Makefile: config/makefiles/root.in
+ cd $(BUILD_DIR) && $(RECONFIGURE) --step=gen::languages --languages=chitchat
+
+# This is a listing of all targets, that are meant to be called by users
+help:
+ @echo ""
+ @echo "Following targets are available for the user:"
+ @echo ""
+ @echo " all: chitchat.pbc"
+ @echo " This is the default."
+ @echo "Testing:"
+ @echo " test: Run the test suite."
+ @echo " testclean: Clean up test results."
+ @echo ""
+ @echo "Cleaning:"
+ @echo " clean: Basic cleaning up."
+ @echo " realclean: Removes also files generated by 'Configure.pl'"
+ @echo " distclean: Removes also anything built, in theory"
+ @echo ""
+ @echo "Misc:"
+ @echo " help: Print this help message."
+ @echo ""
+
+test: all
+ $(PERL) t/harness
+
+# this target has nothing to do
+testclean:
+
+CLEANUPS = \
+ chitchat.pbc \
+ src/gen_grammar.pir \
+ src/gen_actions.pir \
+ src/gen_builtins.pir \
+ $(PMC_DIR)/*.h \
+ $(PMC_DIR)/*.c \
+ $(PMC_DIR)/*.dump \
+ $(PMC_DIR)/*$(O) \
+ $(PMC_DIR)/*$(LOAD_EXT) \
+ $(PMC_DIR)/*.exp \
+ $(PMC_DIR)/*.ilk \
+ $(PMC_DIR)/*.manifest \
+ $(PMC_DIR)/*.pdb \
+ $(PMC_DIR)/*.lib \
+
+
+clean:
+ $(RM_RF) $(CLEANUPS)
+
+realclean: clean
+ $(RM_RF) Makefile
+
+distclean: realclean
+
+# Local variables:
+# mode: makefile
+# End:
+# vim: ft=make:
Added: chitchat/trunk/src/builtins/say.pir
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ chitchat/trunk/src/builtins/say.pir Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,31 @@
+# $Id$
+
+=head1
+
+say.pir -- simple implementation of a say function
+
+=cut
+
+.namespace []
+
+.sub 'say'
+ .param pmc args :slurpy
+ .local pmc iter
+ iter = new 'Iterator', args
+ iter_loop:
+ unless iter goto iter_end
+ $P0 = shift iter
+ print $P0
+ goto iter_loop
+ iter_end:
+ print "\n"
+ .return ()
+.end
+
+
+# Local Variables:
+# mode: pir
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:
+
Added: chitchat/trunk/src/parser/actions.pm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ chitchat/trunk/src/parser/actions.pm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,219 @@
+# $Id$
+
+# Copyright (C) 2008, Parrot Foundation.
+
+=begin comments
+
+ChitChat::Grammar::Actions - ast transformations for ChitChat
+
+This file contains the methods that are used by the parse grammar
+to build the PAST representation of an ChitChat program.
+Each method below corresponds to a rule in F<src/parser/grammar.pg>,
+and is invoked at the point where C<{*}> appears in the rule,
+with the current match object as the first argument. If the
+line containing C<{*}> also has a C<#= key> comment, then the
+value of the comment is passed as the second argument to the method.
+
+=end comments
+
+class ChitChat::Grammar::Actions;
+
+method TOP($/) {
+ my $past := PAST::Block.new( :blocktype('declaration'), :node( $/ ) );
+ for $<exprs> {
+ $past.push( $( $_ ) );
+ }
+ make $past;
+}
+
+method block($/) {
+ my $past := PAST::Block.new( :blocktype('declaration'), :node($/) );
+ for $<id> {
+ my $param := $( $_ );
+ $param.isdecl(1);
+ $param.scope('parameter');
+ $past.push($param);
+ }
+ if $<temps> {
+ my $temps := $( $<temps>[0] );
+ $past.push($temps);
+ }
+
+ $past.push( $( $<exprs> ) );
+
+ make $past;
+}
+
+method method($/) {
+ my $past := $( $<message> );
+ ## todo: pragma
+
+ if $<temps> {
+ $past.push( $( $<temps>[0] ) );
+ }
+ $past.push( $( $<exprs> ) );
+ make $past;
+}
+
+method message($/, $key) {
+ if $key eq 'id' {
+ my $name := $( $<id> );
+ make PAST::Block.new( :name($name), :node($/) );
+ }
+ elsif $key eq 'binsel' {
+ ## create a new block for a binary operator; stick to
+ ## naming habit in other languages ('infix:...').
+ make PAST::Block.new( :name('infix:' ~ ~$<binsel>), :node($/) );
+ }
+ elsif $key eq 'keysel' {
+ my $name := "";
+ for $<keysel> {
+ $name := $name ~ ~$_;
+ }
+ my $past := PAST::Block.new( :name($name), :node($/) );
+
+ for $<id> {
+ my $param := $( $_ );
+ $param.scope('parameter');
+ $past.push($param);
+ }
+ make $past;
+ }
+}
+
+method temps($/) {
+ my $past := PAST::Stmts.new( :node($/) );
+ for $<id> {
+ my $temp := $( $_ );
+ $temp.scope('lexical');
+ $temp.isdecl(1);
+ $past.push( $temp );
+ }
+ make $past;
+}
+
+method exprs($/) {
+ my $past := PAST::Stmts.new();
+ for $<expr> {
+ $past.push( $( $_ ) );
+ }
+ make $past;
+}
+
+method expr($/) {
+ # for $<id> {
+ # $( $_ );
+ # }
+ make $( $<expr2> );
+}
+
+method expr2($/,$key) {
+ my $past := $( $/{$key} );
+ if $key eq 'msgexpr' {
+ #my $statlist := PAST::Stmts.new();
+ #for $<cascade> {
+ # my $stat := $( $_ );
+ # $stat.unshift($past);
+ # $statlist.push($stat);
+ #}
+ #make $statlist;
+ make $past;
+ }
+ else {
+ make $past;
+ }
+}
+
+
+method cascade($/,$key) {
+ make $( $/{$key} );
+}
+
+method msgexpr($/,$key) {
+ make $( $/{$key} );
+}
+
+method keyexpr($/) {
+ my $past := PAST::Op.new( :pasttype('callmethod') );
+ $past.push( PAST::Var.new( :name( $( $<keyexpr2>).name() ), :scope('package') ) );
+ my @args := $( $<keymsg> );
+ my $name := '';
+ while + at args {
+ $name := $name ~ ~@args.shift();
+ $past.push( @args.shift() );
+ }
+ $past.name($name);
+ make $past;
+}
+
+method keyexpr2($/, $key) {
+ make $( $/{$key} );
+}
+
+method keymsg($/) {
+ my @past;
+ my $num := +$<keysel>;
+ my $i := 0;
+ while $i < $num {
+ @past.push( ~$<keysel>[$i] );
+ @past.push( $($<keyexpr2>[$i]) );
+ $i++;
+ }
+ make @past;
+}
+
+method binexpr($/) {
+ my $past := $( $<primary> );
+ for $<binmsg> {
+ my $call := $( $_ );
+ $call.unshift($past);
+ $past := $call;
+ }
+ make $past;
+}
+
+method binmsg($/) {
+ my $past := PAST::Op.new( :name('infix:' ~ ~$<binsel>), :pasttype('call') );
+ $past.push( $( $<primary> ) );
+ make $past;
+}
+
+method unaryexpr($/) {
+ make $( $<unit> );
+}
+
+method primary($/,$key) {
+ make $( $<unit> );
+}
+
+method unit($/,$key) {
+ make $( $/{$key} );
+}
+
+method literal($/,$key) {
+ make $( $/{$key} );
+}
+
+method arrayelem($/,$key) {
+ make $( $/{$key} );
+}
+
+method number($/) {
+ make PAST::Val.new( :value(~$/), :returns('Float') );
+}
+
+method string($/) {
+ make PAST::Val.new( :value(~$<text>), :returns('String') );
+}
+
+method id($/) {
+ make PAST::Var.new( :name(~$/), :scope('package'), :node($/) );
+}
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
+
Added: chitchat/trunk/src/parser/grammar.pg
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ chitchat/trunk/src/parser/grammar.pg Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,212 @@
+# $Id$
+
+=begin overview
+
+This is the grammar for ChitChat written as a sequence of Perl 6 rules.
+
+=end overview
+
+grammar ChitChat::Grammar is PCT::Grammar;
+
+token TOP {
+ <.ws>
+ [ | <exprs>
+ | <methods>
+ | '!'
+ ]+
+ <.ws>
+ [ $ || <.panic: 'Syntax error'> ]
+ {*}
+}
+
+token whitespace { \h | \v | <comment> }
+
+token ws { <.whitespace>* }
+
+token comment { '"' <-["]>* '"' }
+
+rule methods {
+ '!' <id> 'class'? 'methodsFor:' <string>
+ '!' [<method> '!']?
+ '!'
+}
+
+rule method {
+ <message> <pragma>? <temps>? <exprs>
+ {*}
+}
+
+token message {
+ | <id> {*} #= id
+ | <binsel> <.ws> <id> {*} #= binsel
+ | [<keysel> <.ws> <id>]+ {*} #= keysel
+}
+
+token pragma { '<' <keymsg> '>' }
+
+rule temps {
+ '|' [<id> ]* '|'
+ {*}
+}
+
+token unit {
+ | <id> {*} #= id
+ | <literal> {*} #= literal
+ | <block> {*} #= block
+ | <arrayconstructor> {*} #= arrayconstructor
+ | '(' <expr> ')' {*} #= expr
+}
+
+rule unaryexpr {
+ <unit> [<!keysel><id> ]+
+ {*}
+}
+
+token primary {
+ | <!unaryexpr> <unit> {*} #= unit
+ | <unaryexpr> {*} #= unaryexpr
+}
+
+rule exprs {
+ [
+ | <expr> [ '.' <expr>]* ['.' '^' <expr>]? '.'?
+ | '^' <expr> '.'?
+ ]
+ {*}
+}
+
+rule expr {
+ [<id> [':='|'_']]* <expr2>
+ {*}
+}
+
+rule expr2 {
+ | <msgexpr> [ ';' <cascade> ]* {*} #= msgexpr
+ | <primary> {*} #= primary
+}
+
+token msgexpr {
+ | <binexpr> {*} #= binexpr
+ | <keyexpr> {*} #= keyexpr
+ | <unaryexpr> {*} #= unaryexpr
+}
+
+token cascade {
+ | <id> {*} #= id
+ | <binmsg> {*} #= binmsg
+ | <keymsg> {*} #= keymsg
+}
+
+rule binexpr {
+ <primary> <binmsg>+
+ {*}
+}
+
+rule binmsg {
+ <binsel> <primary>
+ {*}
+}
+
+token binsel { <binchar>**{1..2} }
+
+rule keyexpr {
+ <keyexpr2> <keymsg>
+ {*}
+}
+
+token keyexpr2 {
+ | <!binexpr> <primary> {*} #= primary
+ | <binexpr> {*} #= binexpr
+}
+
+rule keymsg {
+ [<keysel> <keyexpr2> ]+
+ {*}
+}
+
+token keysel { <id> ':' }
+
+rule block {
+ '[' [[':' <id>]* '|']? <temps>? <exprs> ']'
+ {*}
+}
+
+token arrayconstructor {
+ '{' <exprs> '}'
+}
+
+token literal {
+ | <number> {*} #= number
+ | <string> {*} #= string
+ | <charconst> {*} #= charconst
+ | <symconst> {*} #= symconst
+ | <arrayconst> {*} #= arrayconst
+ | <binding> {*} #= binding
+ | <eval> {*} #= eval
+}
+
+token arrayconst {
+ | '#' <array>
+ | '#' <bytearray>
+}
+
+token bytearray {
+ '[' <number>* ']'
+}
+
+rule array {
+ '(' <arrayelem>* ')'
+}
+
+rule arrayelem {
+ | <literal> {*} #= literal
+ | <array> {*} #= array
+ | <bytearray> {*} #= bytearray
+ | <arraysym> {*} #= arraysym
+}
+
+token number {
+ [<.digit>+ 'r']? '-'? <.alnum>+ ['.' <.alnum>+]? [<exp> '-'? <dig>+]?
+ {*}
+}
+
+token string {
+ \' $<text>:=<-[']>* \'
+ {*}
+}
+
+token charconst { '$' . }
+
+token symconst {
+ | '#'<symbol>
+ | '#'<string>
+}
+
+token arraysym {
+ [<id> | ':']*
+}
+
+token exp {
+ <[deqs]>
+}
+
+token binding {
+ '#{' [<id> '.']* <id> '}'
+}
+
+token symbol {
+ | <id>
+ | <binsel>
+ | <keysel>**{1..2}
+}
+
+rule eval {
+ '##(' <temps>? <exprs> ')'
+}
+
+token id {
+ <alpha> [ <alpha> | <digit> ]*
+ {*}
+}
+
+token binchar { <[+\-*/~,<>=&´?\\%]> }
Added: chitchat/trunk/t/00-sanity.t
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ chitchat/trunk/t/00-sanity.t Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,3 @@
+Transcript show: '1..2'.
+Transcript show: 'ok 1'.
+Transcript show: 'ok 2'.
Added: chitchat/trunk/t/harness
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ chitchat/trunk/t/harness Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,8 @@
+#! perl
+
+# $Id$
+
+use FindBin;
+use lib qw( . lib ../lib ../../lib );
+use Parrot::Test::Harness language => 'ChitChat', compiler => 'chitchat.pbc';
+
Added: forth/trunk/MAINTAINER
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ forth/trunk/MAINTAINER Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,4 @@
+# $Id$
+
+N: Matt Diephouse
+E: matt at diephouse dot com
Added: forth/trunk/config/makefiles/root.in
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ forth/trunk/config/makefiles/root.in Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,55 @@
+# Copyright (C) 2006-2009, Parrot Foundation.
+# $Id$
+
+PARROT = ../../parrot at exe@
+PERL = @perl@
+RM_RF = @rm_rf@
+RECONFIGURE = $(PERL) @build_dir@/tools/dev/reconfigure.pl
+#CONDITIONED_LINE(darwin):
+#CONDITIONED_LINE(darwin):# MACOSX_DEPLOYMENT_TARGET must be defined for OS X compilation/linking
+#CONDITIONED_LINE(darwin):export MACOSX_DEPLOYMENT_TARGET := @osx_version@
+
+BUILD_DIR = @build_dir@
+
+DEPENDENCIES = \
+ forth.pbc \
+ tokenstream.pbc \
+ variablestack.pbc \
+ virtualstack.pbc
+
+
+all: $(DEPENDENCIES)
+
+# regenerate the Makefile
+Makefile: config/makefiles/root.in
+ cd $(BUILD_DIR) && $(RECONFIGURE) --step=gen::languages --languages=forth
+
+prompt: all
+ $(PARROT) forth.pbc
+
+clean:
+ $(RM_RF) $(DEPENDENCIES)
+
+realclean: clean
+ $(RM_RF) Makefile
+
+
+forth.pbc: forth.pir words.pir
+ $(PARROT) -o forth.pbc forth.pir
+
+tokenstream.pbc: tokenstream.pir
+ $(PARROT) -o tokenstream.pbc tokenstream.pir
+
+variablestack.pbc: variablestack.pir
+ $(PARROT) -o variablestack.pbc variablestack.pir
+
+virtualstack.pbc: virtualstack.pir
+ $(PARROT) -o virtualstack.pbc virtualstack.pir
+
+test: all
+ $(PERL) t/harness
+
+# Local variables:
+# mode: makefile
+# End:
+# vim: ft=make:
Added: forth/trunk/forth.pir
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ forth/trunk/forth.pir Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,180 @@
+
+.HLL 'Forth'
+.namespace []
+
+.include 'languages/forth/words.pir'
+
+.sub ' init' :load
+ # load the libraries we depend on
+ load_bytecode 'languages/forth/tokenstream.pbc'
+ load_bytecode 'languages/forth/variablestack.pbc'
+ load_bytecode 'languages/forth/virtualstack.pbc'
+
+ # initialize the rstack
+ .local pmc stack
+ stack = new 'ResizablePMCArray'
+ set_hll_global ' stack', stack
+
+ # word dictionary - used for compilation
+ .local pmc dict
+ dict = new 'Hash'
+ set_hll_global ' dict', dict
+
+ .local pmc vars, vstack
+ vars = new 'Hash'
+ vstack = new 'VariableStack'
+ set_hll_global ' variables', vars
+ set_hll_global ' vstack', vstack
+
+ # register the actual compiler
+ .local pmc compiler
+ compiler = get_hll_global ' compile'
+ compreg 'forth', compiler
+.end
+
+.sub main :main :anon
+ .param pmc args
+ .local int argc
+ argc = elements args
+
+ ' init'()
+ if argc == 0 goto prompt
+
+prompt:
+ ' prompt'()
+ end
+.end
+
+
+.sub ' prompt'
+ .local pmc stdin, stdout, forth
+ stdin = getstdin
+ stdout = getstdout
+ forth = compreg 'forth'
+
+ $S0 = pop stdout
+ print "Parrot Forth\n"
+
+loop:
+ print "> "
+ $S0 = readline stdin
+ unless stdin goto end
+
+ push_eh exception
+ $P0 = forth($S0)
+ $P0()
+ pop_eh
+
+ print " ok\n"
+ goto loop
+end:
+ .return()
+
+exception:
+ .get_results ($P0)
+ $S0 = $P0
+ print $S0
+ print "\n"
+ goto loop
+.end
+
+
+.sub ' compile'
+ .param string input
+
+ .local pmc code, stream, stack
+ code = new 'CodeString'
+ stream = new 'TokenStream'
+ set stream, input
+ stack = new 'VirtualStack'
+
+ code.'emit'(<<"END_PIR")
+.sub code :anon
+ .local pmc stack
+ stack = get_hll_global " stack"
+END_PIR
+
+ .local pmc token
+next_token:
+ unless stream goto done
+ token = shift stream
+
+ ' dispatch'(code, stream, stack, token)
+
+ goto next_token
+
+done:
+ $S0 = stack.'consolidate_to_cstack'()
+ code .= $S0
+ code.'emit'(<<"END_PIR")
+ .return(stack)
+.end
+END_PIR
+
+ $P0 = compreg "PIR"
+ .tailcall $P0(code)
+.end
+
+.sub ' dispatch'
+ .param pmc code
+ .param pmc stream
+ .param pmc stack
+ .param pmc token
+
+ $I0 = isa token, 'Integer'
+ if $I0 goto numeric
+
+ .local pmc dict, vars
+ dict = get_hll_global ' dict'
+ vars = get_hll_global ' variables'
+
+ $S0 = token
+ $I0 = exists dict[$S0]
+ if $I0 goto user_word
+ $I0 = exists vars[$S0]
+ if $I0 goto user_var
+
+ $P0 = get_hll_global $S0
+ if null $P0 goto undefined
+ $P0(code, stream, stack)
+ .return()
+
+user_word:
+ $S1 = stack.'consolidate_to_cstack'()
+ code .= $S1
+ $S0 = dict[$S0]
+ code.'emit'(" '%0'(stack)", $S0)
+ .return()
+
+user_var:
+ $I0 = vars[$S0]
+ $S0 = code.'unique'('$P')
+ code.'emit'(<<'END_PIR', $S0, $I0)
+ %0 = new 'Integer'
+ %0 = %1
+END_PIR
+ push stack, $S0
+ .return()
+
+undefined:
+ $S0 = token
+ $S0 = "undefined symbol: " . $S0
+ $P0 = new 'Exception'
+ $P0[0] = $S0
+ throw $P0
+
+numeric:
+ $S0 = code.'unique'('$P')
+ code.'emit'(<<"END_PIR", $S0, token)
+ %0 = new 'Integer'
+ %0 = %1
+END_PIR
+ push stack, $S0
+ .return()
+.end
+
+# Local Variables:
+# mode: pir
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:
Added: forth/trunk/t/comparison.t
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ forth/trunk/t/comparison.t Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,10 @@
+#!../../parrot test.pir
+
+0SP 1 0<
+0
+
+0SP 0 0<
+0
+
+0SP 0 1 - 0<
+1
Added: forth/trunk/t/conditionals.t
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ forth/trunk/t/conditionals.t Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,10 @@
+#!../../parrot test.pir
+
+1 IF ." true" ELSE ." false" THEN
+true
+
+0 IF ." true" ELSE ." false" THEN
+false
+
+4 0 IF 1 - ELSE 2 4 + - THEN
+-2
Added: forth/trunk/t/harness
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ forth/trunk/t/harness Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,8 @@
+#!/usr/bin/perl
+
+# $Id$
+
+use FindBin;
+use lib qw( . lib ../lib ../../lib ../../lib );
+use Parrot::Test::Harness language => 'forth';
+
Added: forth/trunk/t/loop.t
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ forth/trunk/t/loop.t Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,4 @@
+#!../../parrot test.pir
+
+5 BEGIN DUP 1 - DUP 0< UNTIL
+5 4 3 2 1 0 -1
Added: forth/trunk/t/math.t
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ forth/trunk/t/math.t Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,13 @@
+#!../../parrot test.pir
+
+# addition
+3 4 +
+7
+
+# <1> 7
+3 + 5 +
+15
+
+# <0>
+5 -
+10
Added: forth/trunk/t/new_words.t
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ forth/trunk/t/new_words.t Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,17 @@
+#!../../parrot test.pir
+
+# function to add 2
+: add2 2 + ; 15 add2
+17
+
+# function within a function
+: add3 add2 1 + ; add3
+20
+
+# change definition of add2 and make sure add3 doesn't change
+: add2 2 - ; add3
+23
+
+# make sure parsing happens correctly in new words
+: GREET ." Hello, World!" ; GREET
+Hello, World!
Added: forth/trunk/t/output.t
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ forth/trunk/t/output.t Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,12 @@
+#!../../parrot test.pir
+
+# .S
+4 5 .S
+<2> 4 5
+
+# . (make sure it removes the top element too)
+. .S
+5 <1> 4
+
+." Hello, World!".S
+Hello, World!<1> 4
Added: forth/trunk/t/stack.t
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ forth/trunk/t/stack.t Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,22 @@
+#!../../parrot test.pir
+
+# non-empty stack
+1 2 3 4 5
+1 2 3 4 5
+
+DROP
+1 2 3 4
+
+OVER
+1 2 3 4 3
+
+SWAP
+1 2 3 3 4
+
+DUP
+1 2 3 3 4 4
+
+3 0SP
+
+1 2 3 ROT
+2 3 1
Added: forth/trunk/t/variables.t
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ forth/trunk/t/variables.t Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1 @@
+#!../../parrot test.pir
Added: forth/trunk/test.pir
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ forth/trunk/test.pir Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,145 @@
+
+# this is the test program for the forth implementation targeting parrot.
+# this script can be passed the names of any number of test files. each test is
+# a series of input/output pairs, with optional comments that start with #s.
+#
+# the first non-blank, non-comment line is considered the first input. the line
+# immediately following that is the first output line. the output can be either
+# the stack (where the elements are joined by a space) or the message of a
+# thrown exception.
+
+.sub main :main
+ .param pmc args
+ .local int argc
+ $P0 = shift args
+ argc = elements args
+
+ load_bytecode 'languages/forth/forth.pir'
+
+ .local pmc iter
+ iter = new 'Iterator', args
+next_file:
+ unless iter goto done
+ $S0 = shift iter
+ test($S0)
+ goto next_file
+done:
+ end
+.end
+
+#
+# test(filename)
+#
+# Test a particular filename: read it, parse it, compare the input/output.
+#
+.sub test
+ .param string filename
+
+ .local pmc file
+ file = open filename
+
+ .local string line, input, expected
+ .local int num_of_tests
+ num_of_tests = 0
+next_test:
+ bsr next_line
+ if null line goto done
+ if line == "" goto next_test
+ input = line
+
+ bsr next_line
+ if null line goto missing_output
+ expected = line
+
+ inc num_of_tests
+ is(input, expected, num_of_tests)
+ goto next_test
+
+next_line:
+ line = readline file
+ if line == '' goto end_of_file
+ $S0 = substr line, 0, 1
+ if $S0 == "#" goto next_line
+ chopn line, 1
+ ret
+end_of_file:
+ null line
+ ret
+
+done:
+ print "1.."
+ print num_of_tests
+ print "\n"
+ close file
+ .return()
+
+missing_output:
+ print "Missing test output for test #"
+ inc num_of_tests
+ print num_of_tests
+ print "\n"
+ exit 1
+.end
+
+#
+# is(forth code, expected output, test number)
+#
+# An individual test. Execute the forth code and compare one of the following:
+# 1) the first line of stdout
+# 2) the stack
+# 3) the exception message
+#
+.sub is
+ .param string input
+ .param string expected
+ .param int test_num
+
+ .local pmc forth
+ forth = compreg 'forth'
+
+ .local pmc stack, stdout
+ .local string output
+ stdout = getstdout
+ push stdout, "string"
+ push_eh exception
+ $P0 = forth(input)
+ stack = $P0()
+ pop_eh
+ output = readline stdout
+ $S0 = pop stdout
+ if output != "" goto compare
+ output = join " ", stack
+ goto compare
+
+exception:
+ .local pmc except
+ .get_results (except)
+ output = except
+
+compare:
+ if output == expected goto ok
+ print "not ok "
+ print test_num
+ print "\n"
+
+ print "# Failed test\n"
+ print "# got: '"
+ print output
+ print "'\n"
+ print "# expected: '"
+ print expected
+ print "'\n"
+ .return()
+
+ok:
+ print "ok "
+ print test_num
+ print "\n"
+ .return()
+.end
+
+# Local Variables:
+# mode: pir
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:
Added: forth/trunk/tokenstream.pir
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ forth/trunk/tokenstream.pir Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,117 @@
+
+.HLL 'Forth'
+.namespace ['TokenStream']
+
+.sub init :anon :load
+ .local pmc class
+ class = newclass 'TokenStream'
+
+ addattribute class, '$code'
+ addattribute class, '$pos'
+.end
+
+
+.sub 'set_string_native' :vtable :method
+ .param string str
+
+ .local pmc code
+ code = new 'String'
+ code = str
+
+ .local pmc pos
+ pos = new 'Integer'
+ pos = 0
+
+ setattribute self, '$code', code
+ setattribute self, '$pos', pos
+.end
+
+
+.sub 'get_bool' :vtable :method
+ .local string code
+ .local pmc pos
+ pos = getattribute self, '$pos'
+ $P0 = getattribute self, '$code'
+ code = $P0
+
+ .local int len
+ len = length code
+
+ .include 'cclass.pasm'
+ $I0 = pos
+ $I0 = find_not_cclass .CCLASS_WHITESPACE, code, $I0, len
+ if $I0 == len goto false
+
+ pos = $I0
+ .return(1)
+
+false:
+ .return(0)
+.end
+
+.sub 'shift_pmc' :vtable :method
+ .local pmc token, pos
+ .local string code, str
+ null token
+ pos = getattribute self, '$pos'
+ $P0 = getattribute self, '$code'
+ code = $P0
+
+ .local int len
+ len = length code
+
+ .include 'cclass.pasm'
+ $I0 = pos
+ $I0 = find_not_cclass .CCLASS_WHITESPACE, code, $I0, len
+ $I1 = find_cclass .CCLASS_WHITESPACE, code, $I0, len
+ if $I0 == len goto return
+
+ $I2 = $I1 - $I0
+ str = substr code, $I0, $I2
+ str = downcase str
+ pos = $I1
+
+ $I0 = length str
+ $I1 = find_not_cclass .CCLASS_NUMERIC, str, 0, $I0
+ if $I1 == $I0 goto numeric
+
+ token = new 'String'
+ token = str
+ goto return
+
+numeric:
+ $I0 = str
+ token = new 'Integer'
+ token = $I0
+
+return:
+ .return(token)
+.end
+
+
+.sub remove_upto :method
+ .param string str
+
+ .local pmc code, pos
+ code = getattribute self, '$code'
+ pos = getattribute self, '$pos'
+
+ $S0 = code
+ $I0 = pos
+ inc $I0 # skip a space
+ $I1 = index $S0, str, $I0
+
+ $I2 = $I1 - $I0
+ $S1 = substr $S0, $I0, $I2
+
+ inc $I1
+ pos = $I1
+
+ .return($S1)
+.end
+
+# Local Variables:
+# mode: pir
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:
Added: forth/trunk/variablestack.pir
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ forth/trunk/variablestack.pir Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,53 @@
+
+.HLL 'Forth'
+.namespace ['VariableStack']
+
+.sub init :anon :load
+ .local pmc class
+ class = newclass 'VariableStack'
+
+ addattribute class, '@stack'
+ addattribute class, '$next'
+.end
+
+.sub init :vtable :method
+ .local pmc stack, cell
+ stack = new 'ResizableIntegerArray'
+ cell = new 'Integer'
+ cell = 0
+
+ setattribute self, '@stack', stack
+ setattribute self, '$next', cell
+.end
+
+.sub get_integer :vtable :method
+ .local pmc next
+ next = getattribute self, '$next'
+ $I0 = next
+ inc next
+ .return($I0)
+.end
+
+.sub get_pmc_keyed_int :vtable :method
+ .param int key
+ .local pmc stack
+ stack = getattribute self, '@stack'
+
+ $P0 = stack[key]
+ .return($P0)
+.end
+
+.sub set_pmc_keyed_int :vtable :method
+ .param int key
+ .param pmc value
+
+ .local pmc stack
+ stack = getattribute self, '@stack'
+ stack[key] = value
+.end
+
+# Local Variables:
+# mode: pir
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:
Added: forth/trunk/virtualstack.pir
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ forth/trunk/virtualstack.pir Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,81 @@
+
+.HLL 'Forth'
+.namespace ['VirtualStack']
+
+.sub init :anon :load
+ .local pmc class
+ class = newclass 'VirtualStack'
+
+ addattribute class, '@cstack'
+.end
+
+.sub init :vtable :method
+ .local pmc cstack
+ cstack = new 'ResizableStringArray'
+ setattribute self, '@cstack', cstack
+.end
+
+.sub elements :vtable :method
+ $P0 = getattribute self, '@cstack'
+ $I0 = elements $P0
+ .return($I0)
+.end
+
+.sub get_bool :vtable :method
+ $P0 = getattribute self, '@cstack'
+ $I0 = elements $P0
+ .return($I0)
+.end
+
+.sub get_string_keyed_int :vtable :method
+ .param int key
+ $P0 = getattribute self, '@cstack'
+ $S0 = $P0[key]
+ .return($S0)
+.end
+
+.sub pop_string :vtable :method
+ .local pmc cstack
+ cstack = getattribute self, '@cstack'
+
+ $I0 = elements cstack
+ if $I0 == 0 goto rstack
+
+ $S0 = pop cstack
+ .return($S0)
+
+rstack:
+ .return("pop stack")
+.end
+
+.sub push_string :vtable :method
+ .param string elem
+
+ .local pmc cstack
+ cstack = getattribute self, '@cstack'
+ push cstack, elem
+
+ .return()
+.end
+
+.sub consolidate_to_cstack :method
+ .local pmc cstack, iter
+ cstack = getattribute self, '@cstack'
+ .local string code
+ code = ""
+loop:
+ unless cstack goto done
+ $S0 = shift cstack
+ code .= " push stack, "
+ code .= $S0
+ code .= "\n"
+ goto loop
+done:
+ .return(code)
+.end
+
+# Local Variables:
+# mode: pir
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:
Added: forth/trunk/words.pir
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ forth/trunk/words.pir Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,448 @@
+
+.HLL 'Forth'
+
+.sub 'variable'
+ .param pmc code
+ .param pmc stream
+ .param pmc stack
+
+ .local pmc token
+ .local string name
+ token = shift stream
+ name = token
+
+ .local pmc variables, vstack
+ variables = get_hll_global ' variables'
+ vstack = get_hll_global ' vstack'
+
+ $P0 = new 'Integer'
+ $I0 = vstack
+ $P0 = $I0
+
+ variables[name] = $P0
+.end
+
+.sub ':'
+ .param pmc code
+ .param pmc stream
+ .param pmc stack
+
+ .local string name, subname
+ .local pmc token, dict, nstack, nword
+ token = shift stream
+ name = token
+ dict = get_hll_global ' dict'
+ nstack = new 'VirtualStack'
+ nword = new 'CodeString'
+
+ subname = ' ' . name
+ subname = nword.'unique'(subname)
+ nword.'emit'(<<"END_PIR", subname)
+.sub '%0'
+ .param pmc stack
+END_PIR
+
+loop:
+ unless stream goto done
+ token = shift stream
+
+ $S0 = token
+ if $S0 == ";" goto done
+
+ ' dispatch'(nword, stream, nstack, token)
+ goto loop
+
+done:
+ $S0 = nstack.'consolidate_to_cstack'()
+ nword .= $S0
+ nword.'emit'(<<"END_PIR")
+ .return()
+.end
+END_PIR
+
+ $P0 = compreg "PIR"
+ $P0(nword)
+
+ dict[name] = subname
+ .return()
+.end
+
+# print the last element on the stack (destructive)
+.sub '.'
+ .param pmc code
+ .param pmc stream
+ .param pmc stack
+
+ $S0 = pop stack
+ code.'emit'(<<"END_PIR", $S0)
+ $P0 = %0
+ print $P0
+ print " "
+END_PIR
+
+ .return()
+.end
+
+# print the stack (non-destructive)
+.sub '.s'
+ .param pmc code
+ .param pmc stream
+ .param pmc stack
+
+ if stack goto compiletime
+
+ code.'emit'(<<"END_PIR")
+ print "<"
+ $I0 = elements stack
+ print $I0
+ print "> "
+
+ $S0 = join " ", stack
+ print $S0
+ print " "
+END_PIR
+ .return()
+
+compiletime:
+ $I0 = elements stack
+ $S0 = $I0
+ $S1 = join "\nprint ' '\nprint ", stack
+ $S2 = code.'unique'('empty')
+
+ code.'emit'(<<"END_PIR", $S0, $S1, $S2)
+ print "<"
+ $I0 = elements stack
+ $I1 = $I0 + %0
+ print $I1
+ print "> "
+
+ unless $I0 goto %2
+ $S0 = join " ", stack
+ print $S0
+ print " "
+%2:
+ print %1
+ print " "
+END_PIR
+
+ .return()
+.end
+
+# clear the stack
+.sub '0sp'
+ .param pmc code
+ .param pmc stream
+ .param pmc stack
+
+loop:
+ unless stack goto done
+ $S0 = pop stack
+ goto loop
+done:
+
+ $S0 = code.'unique'('loop')
+ $S1 = code.'unique'('done')
+ code.'emit'(<<"END_PIR", $S0, $S1)
+%0:
+ unless stack goto %1
+ $S0 = pop stack
+ goto %0
+%1:
+END_PIR
+.end
+
+# print what's on the stream upto the next "
+.sub '."'
+ .param pmc code
+ .param pmc stream
+ .param pmc stack
+
+ $S0 = stream.'remove_upto'('"')
+ $S0 = code.'escape'($S0)
+ code.'emit'("print %0", $S0)
+
+ .return()
+.end
+
+# remove the top element
+.sub 'drop'
+ .param pmc code
+ .param pmc stream
+ .param pmc stack
+
+ if stack goto compiletime
+
+ code.'emit'('$P0 = pop stack')
+ .return()
+
+compiletime:
+ $P0 = pop stack
+ .return()
+.end
+
+# copy the item below the top
+.sub 'over'
+ .param pmc code
+ .param pmc stream
+ .param pmc stack
+
+ code.'emit'(<<'END_PIR')
+ $P0 = stack[-2]
+ push stack, $P0
+END_PIR
+
+ .return()
+.end
+
+# swap the top 2 elements
+.sub 'swap'
+ .param pmc code
+ .param pmc stream
+ .param pmc stack
+
+ code.'emit'(<<'END_PIR')
+ $P0 = pop stack
+ $P1 = pop stack
+ push stack, $P0
+ push stack, $P1
+END_PIR
+
+ .return()
+.end
+
+# copy the top element
+.sub 'dup'
+ .param pmc code
+ .param pmc stream
+ .param pmc stack
+
+ if stack goto compiletime
+
+ code.'emit'(<<'END_PIR')
+ $P0 = stack[-1]
+ push stack, $P0
+END_PIR
+ .return()
+
+compiletime:
+ $I0 = elements stack
+ $S0 = stack[-1]
+ push stack, $S0
+ .return()
+.end
+
+# move top - 2 to top
+.sub 'rot'
+ .param pmc code
+ .param pmc stream
+ .param pmc stack
+
+ .local string a, b, c
+ c = pop stack
+ b = pop stack
+ a = pop stack
+
+ $S0 = code.'unique'("$P")
+ $S1 = code.'unique'("$P")
+ $S2 = code.'unique'("$P")
+
+ code.'emit'(<<"END_PIR", a, b, c, $S0, $S1, $S2)
+ %3 = %0
+ %4 = %1
+ %5 = %2
+END_PIR
+ push stack, $S1
+ push stack, $S2
+ push stack, $S0
+
+ .return()
+.end
+
+.sub 'begin'
+ .param pmc code
+ .param pmc stream
+ .param pmc stack
+
+ $S0 = stack.'consolidate_to_cstack'()
+ code .= $S0
+
+ .local string label
+ label = code.'unique'('loop')
+ code.'emit'(<<"END_PIR", label)
+%0:
+END_PIR
+
+ .local pmc token
+next_token:
+ unless stream goto error
+ token = shift stream
+
+ $S0 = token
+ if $S0 == "until" goto until
+
+ ' dispatch'(code, stream, stack, token)
+
+ goto next_token
+
+until:
+ $S1 = pop stack
+ $S2 = code.'unique'("$P")
+ $S0 = stack.'consolidate_to_cstack'()
+ code .= $S0
+ code.'emit'(<<"END_PIR", label, $S1, $S2)
+ %2 = %1
+ unless %2 goto %0
+END_PIR
+
+ .return()
+
+error:
+ say "error in BEGIN"
+ exit 0
+.end
+
+.sub 'if'
+ .param pmc code
+ .param pmc stream
+ .param pmc stack
+
+ $S4 = pop stack
+ $S1 = code.'unique'('$P')
+ $S2 = code.'unique'('else')
+ $S3 = code.'unique'('done')
+
+ $S0 = stack.'consolidate_to_cstack'()
+ code .= $S0
+ code.'emit'(<<"END_PIR", $S4, $S1, $S2, $S3)
+ %1 = %0
+ unless %1 goto %2
+END_PIR
+
+ .local pmc token
+if_loop:
+ unless stream goto error
+ token = shift stream
+
+ $S0 = token
+ if $S0 == "else" goto else
+ if $S0 == "then" goto done
+ ' dispatch'(code, stream, stack, token)
+
+ goto if_loop
+
+else:
+ $S0 = stack.'consolidate_to_cstack'()
+ code .= $S0
+ code.'emit'(<<"END_PIR", $S2, $S3)
+ goto %1
+%0:
+END_PIR
+
+else_loop:
+ unless stream goto error
+ token = shift stream
+
+ $S0 = token
+ if $S0 == "then" goto done
+ ' dispatch'(code, stream, stack, token)
+
+ goto else_loop
+
+if_done:
+ code.'emit'("%0:", $S2)
+done:
+ code.'emit'("%0:", $S3)
+ $S0 = stack.'consolidate_to_cstack'()
+ code .= $S0
+ .return()
+
+error:
+ print "error in IF!"
+ exit 0
+.end
+
+# print a carriage-return
+.sub 'cr'
+ .param pmc code
+ .param pmc stream
+ .param pmc stack
+
+ code.'emit'('print "\n"')
+
+ .return()
+.end
+
+# is less than 0?
+.sub '0<'
+ .param pmc code
+ .param pmc stream
+ .param pmc stack
+
+ .local string a
+ a = pop stack
+ $S0 = code.'unique'("$P")
+
+ code.'emit'(<<"END_PIR", a, $S0)
+ $I0 = %0
+ $I0 = islt $I0, 0
+ %1 = new 'Integer'
+ %1 = $I0
+END_PIR
+ push stack, $S0
+
+ .return()
+.end
+
+# addition
+.sub '+'
+ .param pmc code
+ .param pmc stream
+ .param pmc stack
+
+ .local string a, b
+ b = pop stack
+ a = pop stack
+ $S0 = code.'unique'("$P")
+ $S1 = code.'unique'("$P")
+ $S2 = code.'unique'("$P")
+
+ code.'emit'(<<"END_PIR", b, a, $S0, $S1, $S2)
+ %2 = %0
+ %3 = %1
+ %4 = new 'Float'
+ %4 = %3 + %2
+END_PIR
+ push stack, $S2
+
+ .return()
+.end
+
+# subtraction
+.sub '-'
+ .param pmc code
+ .param pmc stream
+ .param pmc stack
+
+ .local string a, b
+ b = pop stack
+ a = pop stack
+ $S0 = code.'unique'("$P")
+ $S1 = code.'unique'("$P")
+ $S2 = code.'unique'("$P")
+
+ code.'emit'(<<"END_PIR", b, a, $S0, $S1, $S2)
+ %2 = %0
+ %3 = %1
+ %4 = new 'Float'
+ %4 = %3 - %2
+END_PIR
+ push stack, $S2
+
+ .return()
+.end
+
+# Local Variables:
+# mode: pir
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:
Added: jako/trunk/Curses.jako
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/Curses.jako Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,641 @@
+#
+# Curses.jako
+#
+# A Jako module for interfacing with the curses library.
+#
+# Copyright (C) 2003-2005, Parrot Foundation.
+# This program is free software. Its use is subject to the same
+# license as Parrot.
+#
+# $Id$
+#
+
+module Curses
+ :fnlib = "libcurses"
+{
+
+ #
+ # From curs_addch(3X):
+ #
+ # int addch(const chtype ch);
+ # int waddch(WINDOW * win, const chtype ch);
+ # int mvaddch(int y, int x, const chtype ch);
+ # int mvwaddch(WINDOW * win, int y, int x, const chtype ch);
+ # int echochar(const chtype ch);
+ # int wechochar(WINDOW * win, const chtype ch);
+ #
+
+
+ #
+ # From curs_addchstr(3X):
+ #
+ # int addchstr(const chtype * chstr);
+ # int addchnstr(const chtype * chstr, int n);
+ # int waddchstr(WINDOW * win, const chtype * chstr);
+ # int waddchnstr(WINDOW * win, const chtype * chstr, int n);
+ # int mvaddchstr(int y, int x, const chtype * chstr);
+ # int mvaddchnstr(int y, int x, const chtype * chstr, int n);
+ # int mvwaddchstr(WINDOW * win, int y, int x, const chtype * chstr);
+ # int mvwaddchnstr(WINDOW * win, int y, int x, const chtype * chstr,
+ # int n);
+ #
+
+
+ #
+ # From curs_addstr(3X):
+ #
+ # int addstr(const char * str);
+ # int addnstr(const char * str, int n);
+ # int waddstr(WINDOW * win, const char * str);
+ # int waddnstr(WINDOW * win, const char * str, int n);
+ # int mvaddstr(int y, int x, const char * str);
+ # int mvaddnstr(int y, int x, const char * str, int n);
+ # int mvwaddstr(WINDOW * win, int y, int x, const char * str);
+ # int mvwaddnstr(WINDOW * win, int y, int x, const char * str, int n);
+ #
+
+ sub int addstr :fn (str s);
+# sub int addnstr :fn (str s, int n);
+# sub int waddstr :fn (int win, str s);
+# sub int waddnstr :fn (int win, str s, int n);
+# sub int mvaddstr :fn (int y, int x, str s);
+# sub int mvaddnstr :fn (int y, int x, str s, int n);
+# sub int mvwaddstr :fn (int win, int y, int x, str s);
+# sub int mvwaddnstr :fn (int win, int y, int x, str s, int n);
+
+
+ #
+ # From curs_addwstr(3X):
+ #
+ # int addwstr(const wchar_t * wstr);
+ # int addnwstr(const wchar_t * wstr, int n);
+ # int waddwstr(WINDOW * win, const wchar_t * wstr);
+ # int waddnwstr(WINDOW * win, const wchar_t * wstr, int n);
+ # int mvaddwstr(int y, int x, const wchar_t * wstr);
+ # int mvaddnwstr(int y, int x, const wchar_t * wstr, int n);
+ # int mvwaddwstr(WINDOW * win, int y, int x, const wchar_t * wstr);
+ # int mvwaddnwstr(WINDOW * win, int y, int x, const wchar_t * wstr,
+ # int n);
+ #
+
+
+ #
+ # From curs_attr(3X):
+ #
+ # int attroff(int attrs);
+ # int wattroff(WINDOW * win, int attrs);
+ # int attron(int attrs);
+ # int wattron(WINDOW * win, int attrs);
+ # int attrset(int attrs);
+ # int wattrset(WINDOW * win, int attrs);
+ # int color_set(short color_pair_number, void * opts);
+ # int wcolor_set(WINDOW * win, short color_pair_number,
+ # void * opts);
+ # int standend(void);
+ # int wstandend(WINDOW * win);
+ # int standout(void);
+ # int wstandout(WINDOW * win);
+ # int attr_get(attr_t * attrs, short * pair, void * opts);
+ # int wattr_get(WINDOW * win, attr_t * attrs, short * pair,
+ # void * opts);
+ # int attr_off(attr_t attrs, void * opts);
+ # int wattr_off(WINDOW * win, attr_t attrs, void * opts);
+ # int attr_on(attr_t attrs, void * opts);
+ # int wattr_on(WINDOW * win, attr_t attrs, void * opts);
+ # int attr_set(attr_t attrs, short pair, void * opts);
+ # int wattr_set(WINDOW * win, attr_t attrs, short pair, void * opts);
+ # int chgat(int n, attr_t attr, short color,
+ # const void * opts)
+ # int wchgat(WINDOW * win, int n, attr_t attr,
+ # short color, const void * opts)
+ # int mvchgat(int y, int x, int n, attr_t attr,
+ # short color, const void * opts)
+ # int mvwchgat(WINDOW * win, int y, int x, int n,
+ # attr_t attr, short color, const void * opts)
+ #
+
+
+ #
+ # From curs_bkgd(3X):
+ #
+ # void bkgdset(chtype ch);
+ # void wbkgdset(WINDOW * win, chtype ch);
+ # int bkgd(chtype ch);
+ # int wbkgd(WINDOW * win, chtype ch);
+ # chtype getbkgd(WINDOW * win);
+ #
+
+
+ #
+ # From curs_border(3X):
+ #
+ # int border(chtype ls, chtype rs, chtype ts, chtype bs,
+ # chtype tl, chtype tr, chtype bl, chtype br);
+ # int wborder(WINDOW * win, chtype ls, chtype rs,
+ # chtype ts, chtype bs, chtype tl, chtype tr,
+ # chtype bl, chtype br);
+ # int box(WINDOW * win, chtype verch, chtype horch);
+ # int hline(chtype ch, int n);
+ # int whline(WINDOW * win, chtype ch, int n);
+ # int vline(chtype ch, int n);
+ # int wvline(WINDOW * win, chtype ch, int n);
+ # mvhline(int y, int x, chtype ch, int n);
+ # mvwhline(WINDOW * win, int y, int x, chtype ch, int n);
+ # int mvvline(int y, int x, chtype ch, int n);
+ # int mvwvline(WINDOW * win, int y, int x, chtype ch, int n);
+ #
+
+ sub int box :fn (int screen, int v, int h);
+ sub int hline :fn (int ch, int n);
+
+
+ #
+ # From curs_border_set(3X):
+ #
+ # int border_set(
+ # const cchar_t * ls, const cchar_t * rs,
+ # const cchar_t * ts, const cchar_t * bs,
+ # const cchar_t * tl, const cchar_t * tr,
+ # const cchar_t * bl, const cchar_t * br );
+ # int wborder_set(
+ # WINDOW * win,
+ # const cchar_t * ls, const cchar_t * rs,
+ # const cchar_t * ts, const cchar_t * bs,
+ # const cchar_t * tl, const cchar_t * tr,
+ # const cchar_t * bl, const cchar_t * br);
+ # int box_set(
+ # WINDOW * win,
+ # const cchar_t * verch,
+ # const cchar_t * horch);
+ # int hline_set(
+ # const cchar_t * wch, int n);
+ # int whline_set(
+ # WINDOW * win,
+ # const cchar_t * wch, int n);
+ # int mvhline_set(
+ # int y, int x,
+ # const cchar_t * wch, int n);
+ # int mvwhline_set(
+ # WINDOW * win,
+ # int y, int x,
+ # const cchar_t * wch, int n);
+ # int vline_set(
+ # const cchar_t * wch, int n);
+ # int wvline_set(
+ # WINDOW * win,
+ # const cchar_t * wch, int n);
+ # int mvvline_set(
+ # int y, int x,
+ # const cchar_t * wch, int n);
+ # int mvwvline_set(
+ # WINDOW * win,
+ # int y, int x,
+ # const cchar_t * wch, int n);
+ #
+
+
+ #
+ # From curs_clear(3X):
+ #
+ # int erase(void);
+ # int werase(WINDOW * win);
+ # int clear(void);
+ # int wclear(WINDOW * win);
+ # int clrtobot(void);
+ # int wclrtobot(WINDOW * win);
+ # int clrtoeol(void);
+ # int wclrtoeol(WINDOW * win);
+ #
+
+
+ #
+ # From curs_get_wch(3X):
+ #
+ # int get_wch(wint_t * wch);
+ # int wget_wch(WINDOW * win, wint_t * wch);
+ # int mvget_wch(int y, int x, wint_t * wch);
+ # int mvwget_wch(WINDOW * win, int y, int x, wint_t * wch);
+ # int unget_wch(const wchar_t wch);
+ #
+
+
+ #
+ # From curs_getch(3X): [[ ncurses ]]
+ #
+ # int getch(void);
+ # int wgetch(WINDOW * win);
+ # int mvgetch(int y, int x);
+ # int mvwgetch(WINDOW * win, int y, int x);
+ # int ungetch(int ch);
+ # int has_key(int ch);
+ #
+
+ sub int getch :fn ();
+# sub int wgetch :fn (int win);
+# sub int mvgetch :fn (int y, int x);
+# sub int mvwgetch :fn (int win, int y, int x);
+# sub int ungetch :fn (int ch);
+# sub int has_key :fn (int ch);
+
+
+ #
+ # From curs_in_wch(3X):
+ #
+ # int in_wch(cchar_t * wcval);
+ # int mvin_wch(int y, int x, cchar_t * wcval);
+ # int mvwin_wch(WINDOW * win, int y, int x, cchar_t * wcval);
+ # int win_wch(WINDOW * win, cchar_t * wcval);
+ #
+
+
+ #
+ # From curs_in_wchstr(3X):
+ #
+ # int in_wchstr(cchar_t * wchstr);
+ # int in_wchnstr(cchar_t * wchstr, int n);
+ # int win_wchstr(WINDOW * win, cchar_t * wchstr);
+ # int win_wchnstr(WINDOW * win, cchar_t * wchstr, int n);
+ # int mvin_wchstr(int y, int x, cchar_t * wchstr);
+ # int mvin_wchnstr(int y, int x, cchar_t * wchstr, int n);
+ # int mvwin_wchstr(WINDOW * win, int y, int x, cchar_t * wchstr);
+ # int mvwin_wchnstr(WINDOW * win, int y, int x, cchar_t * wchstr, int n);
+ #
+
+
+ #
+ # From curs_inch(3X):
+ #
+ # chtype inch(void);
+ # chtype winch(WINDOW * win);
+ # chtype mvinch(int y, int x);
+ # chtype mvwinch(WINDOW * win, int y, int x);
+ #
+
+
+ #
+ # From curs_initscr(3X):
+ #
+ # WINDOW * initscr(void);
+ # int endwin(void);
+ # bool isendwin(void);
+ # SCREEN * newterm(char * type, FILE * outfd, FILE * infd);
+ # SCREEN * set_term(SCREEN * new);
+ # void delscreen(SCREEN * sp);
+ #
+
+ sub int initscr :fn ();
+ sub int endwin :fn ();
+# sub int isendwin :fn ();
+# sub int newterm :fn (str type, int outfd, int infd);
+# sub int set_term :fn (int new);
+# sub delscreen :fn (int sp);
+
+
+ #
+ # From curs_kernel(3X):
+ #
+ # int def_prog_mode(void);
+ # int defshell_mode(void);
+ # int reset_prog_mode(void);
+ # int reset_shell_mode(void);
+ # int resetty(void);
+ # int savetty(void);
+ # void getsyx(int y, int x);
+ # void setsyx(int y, int x);
+ # int ripoffline(int line, int (*init)(WINDOW *, int));
+ # int curs_set(int visibility);
+ # int napms(int ms);
+ #
+
+# sub int def_prog_mode :fn ();
+# sub int def_shell_mode :fn ();
+# sub int reset_prog_mode :fn ();
+# sub int reset_shell_mode :fn ();
+# sub int resetty :fn ();
+# sub int savetty :fn ();
+# sub getsyx :fn (int y, int x);
+# sub setsyx :fn (int y, int x);
+# sub int ripoffline :fn (int line, ...);
+ sub int curs_set :fn (int visibility);
+# sub int napms :fn (int ms);
+
+
+ #
+ # From curs_move(3X):
+ #
+ # int move(int y, int x);
+ # int wmove(WINDOW *win, int y, int x);
+ #
+
+ sub int move :fn (int y, int x);
+# sub int wmove :fn (int win, int y, int x);
+
+
+ #
+ # From curs_outopts(3X):
+ #
+ # int clearok(WINDOW * win, bool bf);
+ # int idlok(WINDOW * win, bool bf);
+ # void idcok(WINDOW * win, bool bf);
+ # void immedok(WINDOW * win, bool bf);
+ # int leaveok(WINDOW * win, bool bf);
+ # int setscrreg(int top, int bot);
+ # int wsetscrreg(WINDOW * win, int top, int bot);
+ # int scrollok(WINDOW * win, bool bf);
+ # int nl(void);
+ # int nonl(void);
+ #
+
+
+ #
+ # From curs_printw(3X):
+ #
+ # int printw(const char * fmt, ...);
+ # int wprintw(WINDOW * win, const char * fmt, ...);
+ # int mvprintw(int y, int x, const char * fmt, ...);
+ # int mvwprintw(WINDOW * win, int y, int x, const char * fmt, ...);
+ # int vwprintw(WINDOW * win, const char * fmt, va_list varglist);
+ # int vw_printw(WINDOW * win, const char * fmt, va_list varglist);
+ #
+
+
+ #
+ # From curs_refresh(3X):
+ #
+ # int refresh(void);
+ # int wrefresh(WINDOW * win);
+ # int wnoutrefresh(WINDOW * win);
+ # int doupdate(void);
+ # int redrawwin(WINDOW * win);
+ # int wredrawln(WINDOW * win, int beg_line, int num_lines);
+
+ sub int refresh :fn ();
+# sub int wrefresh :fn (int win);
+# sub int wnoutrefresh :fn (int win);
+# sub int doupdate :fn ();
+# sub int redrawwin :fn (int win);
+# sub int wredrawln :fn (int win, int beg_line, int num_lines);
+
+
+ #
+ # From curs_scroll(3X):
+ #
+ # int scroll(WINDOW * win);
+ # int scrl(int n);
+ # int wscrl(WINDOW * win, int n);
+ #
+
+
+ #
+ # From curs_termcap(3X):
+ #
+ # extern char PC;
+ # extern char * UP;
+ # extern char * BC;
+ # extern unsigned ospeed;
+ #
+ # int tgetent(char * bp, const char * name);
+ # int tgetflag(char * id);
+ # int tgetnum(char * id);
+ # char * tgetstr(char * id, char ** area);
+ # char * tgoto(const char *cap, int col, int row);
+ # int tputs(const char * str, int affcnt, int (*putc)(int));
+ #
+
+
+ #
+ # From curs_window(3X):
+ #
+ # WINDOW * newwin(int nlines, int ncols, int begin_y,
+ # int begin_x);
+ # int delwin(WINDOW * win);
+ # int mvwin(WINDOW * win, int y, int x);
+ # WINDOW * subwin(WINDOW * orig, int nlines, int ncols,
+ # int begin_y, int begin_x);
+ # WINDOW * derwin(WINDOW * orig, int nlines, int ncols,
+ # int begin_y, int begin_x);
+ # int mvderwin(WINDOW * win, int par_y, int par_x);
+ # WINDOW * dupwin(WINDOW * win);
+ # void wsyncup(WINDOW * win);
+ # int syncok(WINDOW * win, bool bf);
+ # void wcursyncup(WINDOW * win);
+ # void wsyncdown(WINDOW * win);
+ #
+
+
+
+
+
+
+
+
+
+
+#####################################################################
+
+
+
+ #
+ # From curs_addchstr(3X):
+ #
+
+
+
+ #
+ # From curs_overlay(3X):
+ #
+
+
+ #
+ # From curs_color(3X):
+ #
+
+
+ #
+ # From curs_inopts(3X):
+ #
+
+
+
+ #
+ # From curs_inchstr(3X):
+ #
+
+
+ #
+ # From curs_instr(3X):
+ #
+
+
+ #
+ # From curs_inwstr(3X):
+ #
+
+
+ #
+ # From curs_touch(3X):
+ #
+
+
+ #
+ # From curs_ins_wstr(3X):
+ #
+
+
+ #
+ # From curs_ins_wch(3X):
+ #
+
+
+ #
+ # From curs_insch(3X):
+ #
+
+
+ #
+ # From curs_print(3X): [[ ncurses ]]
+ #
+
+
+ #
+ # From curs_scanw(3X):
+ #
+
+
+ #
+ # From curs_pad(3X):
+ #
+
+
+
+
+ #
+ # From curs_bkgrnd(3X):
+ #
+
+
+ #
+ # From curs_getcchar(3X):
+ #
+
+
+ #
+ # From curs_mouse(3X): [[ ncurses ]]
+ #
+
+
+ #
+ # From curs_get_wstr(3X):
+ #
+
+
+ #
+ # From curs_getstr(3X):
+ #
+
+
+ #
+ # From curs_beep(3X):
+ #
+
+
+ #
+ # From curs_add_wch(3X):
+ #
+
+
+ #
+ # From curs_add_wchstr(3X):
+ #
+
+
+ #
+ # From curs_termattrs(3X):
+ #
+
+
+ #
+ # From curs_terminfo(3X):
+ #
+
+
+ #
+ # From curs_util(3X):
+ #
+
+
+ #
+ # From curs_delch(3X):
+ #
+
+ #
+ # From curs_deleteln(3X):
+ #
+
+
+ #
+ # From curs_insstr(3X):
+ #
+
+
+ #
+ # From define_key(3X):
+ #
+
+
+ #
+ # From key_defined(3X): [[ ncurses ]]
+ #
+
+
+ #
+ # From curs_getyx(3X):
+ #
+
+
+ #
+ # From curs_scr_dump(3X):
+ #
+
+
+ #
+ # From curs_trace(3X): [[ ncurses ]]
+ #
+
+
+ #
+ # From default_colors(3X): [[ ncurses ]]
+ #
+
+
+ #
+ # From curs_extend(3X): [[ ncurses ]]
+ #
+
+
+ #
+ # From keybound(3X): [[ ncurses ]]
+ #
+
+
+ #
+ # From keyok(3X): [[ ncurses ]]
+ #
+
+
+ #
+ # From resizeterm(3X): [[ ncurses ]]
+ #
+
+
+ #
+ # From curs_slk(3X): [[ ncurses ]]
+ #
+
+
+ #
+ # From wresize(3X): [[ ncurses ]]
+ #
+
+}
+
Added: jako/trunk/MAINTAINER
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/MAINTAINER Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,4 @@
+# $Id$
+
+N: Gregor N. Purdy
+E: gregor at focusresearch.com
Added: jako/trunk/README
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/README Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,200 @@
+NAME
+ jako - No frills programming for Parrot
+
+SYNOPSIS
+ Jako is a simple programming language that targets the Parrot virtual
+ machine.
+
+DESCRIPTION
+ Jako should be familiar to those who have seen C and Perl.
+
+ Lexical Structure
+ Jako's lexical structure is similar to its relative: Perl. Whitespace
+ between tokens is not significant, and comments are introduced with an
+ octothorp ('#') and continue to the end of the line.
+
+ * Labels
+ An identifier followed by a colon at the beginning of a line is a
+ label. Labels can be the targets of goto statements, and can also
+ provide a way to refer to specific loops when using the loop control
+ statements (see below).
+
+ * Literals
+
+ * Integers
+
+ * Binary
+ "0b" followed by any number of binary digits ("0" or "1").
+
+ * Octal
+ "0" followed by any number of octal digita ("0" to "7").
+
+ * Decimal
+ Starting with a non-zero decimal digit, with any number of
+ decimal digits following. Optional prefixed "-" for negative
+ integers.
+
+ * Hexadecimal
+ "0x" followed by any number of hexadecimal digits ("0" to
+ "9", "a", "b", "c", "d", "e", or "f").
+
+ * Numbers
+ One or more decimal digits, a decimal point, and one ore more
+ decimal digits. Optional prefixed "-" for negative numbers.
+
+ * Strings
+ A double-quote character, followed by the contents of the
+ string, and another double-quote character. Inside the string
+ literal, double quotes are to be escaped with "\" (back slash,
+ a.k.a. "whack"). To include a back slash in the string, precede
+ it with another back slash.
+
+ * Identifiers
+ Start with a letter, followed by any combination of letters, decimal
+ digits and underscores.
+
+ * Types
+ The built-in types are recognized as keywords: int, num, pmc, str.
+
+ Syntax
+ * Blocks
+ A block is a sequence of statements and declarations between a
+ matching pair of open and close braces ("{" and "}"). Each block
+ represents a scope for lexical symbols (variables and constants).
+ There is an implicit block which represents the entire compilation
+ unit (usually a file). Subroutines may only appear at this level.
+
+ * Constant Declarations
+ const introduces a constant declaration. What follows must be a
+ type, a list of identifiers, "=", and a value of an appropriate
+ type.
+
+ const int a, b, c = 2;
+ const int pi_in = 3; # Indiana
+ const num pi = 3.141592; # Everywhere else
+ const str d = "Como estas?";
+
+ * Variable Declarations
+ var introduces a variable declaration. What follows must be a type
+ and a list of identifiers, optionally followed by "=" and an
+ expression.
+
+ var int a, b, c;
+ var num d, e, f = 42.0;
+ var str g = "Howdy";
+
+ * Subroutines
+ sub introduces a subroutine declaration (and possibly definition).
+ What follows is an optional type, and identifier (the name of the
+ subroutine), an optional set of properties, and a list of formal
+ arguments in parenthesis. The formal arguments are written as a
+ comma-separated list of type-name pairs. Finally, there must be a
+ block which contains the implementation of the subroutine.
+
+ Simple cases of subroutine definitions are:
+
+ sub foo() { ... }
+ sub int bar(int x, int y) { ... }
+
+ NOTE: This assumes some sort of Jako include mechanism.
+
+ NOTE: The below requires "jakoc" to be able to determine the best
+ match among a number of alternatives with the same name, but
+ different signatures.
+
+ The op property can have a string value that gives the op name, if
+ it is different from the sub name. There is also an oplib property
+ that gives the oplib, if the op is not core.
+
+ Presumably, there would be an implicit "use 'core'", that would pull
+ in the definitions of the core ops as subs (if any).
+
+ One wonders if this mechanism could be expanded to account for the
+ arithmetic operators, etc.
+
+ Also, if the Parrot .ops files could be processed to automatically
+ produce the include files for the various categories of ops and
+ subs.
+
+ sub num coversine { oplib = "obscure", op = "covers" } (num);
+
+ sub int BlitSurface { fnlib = "libsdl", fn = "SDL_BlitSurface" } (
+ pmc { nat = "p" } src,
+ pmc { nat = "p" } srcrect,
+ pmc { nat = "p" } dst,
+ pmc { nat = "p" } dstrect
+ );
+
+ NOTE: The oplib, fnlib and fn sub properties are not implemented
+ yet.
+
+ NOTE: Type properties are not implemented yet.
+
+ * Assignments
+ Following tradition, basic assignments are written as
+
+ left = right;
+
+ Conversions between int and num values are implicit.
+
+ * Conditionals
+ There are two kinds of conditional block: if and unless, with the
+ latter being short for the more familiar if, but with the condition
+ inverted. In both cases, what follows the keyword is a parenthesized
+ boolean expression and a block.
+
+ if (happy) { smile(); }
+ unless (raining) { play(); }
+
+ Even though each is redundant given the presence of the other, both
+ are retained in the language for the same reason as in Perl:
+ allowing more natural expression.
+
+ Further, there can be a subsequent block, introduced with else:
+
+ if (paid) { work(); } else { complain(); }
+ unless (paid) { complain(); } else { work(); }
+
+ * Loops
+ There are two kinds of loop: while and until, with the same reversal
+ of sense as exists between if and unless.
+
+ while (1) {
+ while (overdue != 0.0) { work(); invoice(); }
+ until (overdue == 0.0) { send_dunning_letter(); }
+ }
+
+ You can control loops with the next, last and redo loop control
+ statements. next jumps immediately to the next iteration of the
+ loop, without executing the intervening statements, last jumps
+ immediately out of the loop, again without executing the intervening
+ statements. And, redo jumps back to the beginning of the current
+ iteration.
+
+ Loops can be followed by an optional continue block, which provides
+
+ Semantics
+ * String interpolation
+ An unescaped dollar sign ("$") in a string causes Jako to
+ interpolate variables into a final string before the string is used
+ in an expression. In case the text to follow the interpolated value
+ starts with identifier characters that would interfere with the
+ correct determination of the variable to interpolate, use the form
+ "${...}".
+
+HISTORY
+ Jako was the first language to target the Parrot virtual machine. It was
+ also the first language to support subroutines (although in a
+ rudimentary, hackish way) for Parrot.
+
+AUTHOR
+ You can blame gregor <gregor at focusresearch.com> for the Jako language
+ and its compiler.
+
+COPYRIGHT
+ Copyright (C) 2001-2005, Parrot Foundation.
+
+LICENSE
+ The Jako compiler is free software. It is subject to the same license as
+ the Parrot interpreter.
+
Added: jako/trunk/SDL.jako
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/SDL.jako Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,340 @@
+#
+# SDL.jako
+#
+# A Jako module for interfacing with the SDL library.
+#
+# Copyright (C) 2004-2007, Parrot Foundation.
+# This program is free software. Its use is subject to the same
+# license as Parrot.
+#
+# $Id$
+#
+
+module SDL
+ :fnlib = "libSDL"
+{
+
+
+ #
+ # Basic Functions:
+ #
+ # SDL_Surface * SDL_DisplayFormat(SDL_Surface * surface)
+ # int SDL_FillRect(SDL_Surface * dst, SDL_Rect * dstrect, Uint32 color)
+ # int SDL_Flip(SDL_Surface * screen)
+ # void SDL_FreeSurface(SDL_Surface * surface)
+ # char * SDL_GetKeyName(SDLKey key)
+ # int SDL_Init(Uint32 flags)
+ # SDL_Surface * SDL_LoadBMP(const char * file)
+ # int SDL_PollEvent(SDL_Event * event)
+ # void SDL_Quit(void)
+ # SDL_Surface * SDL_SetVideoMode(int width, int height, int bpp,
+ # Uint32 flags)
+ # void SDL_UpdateRect(SDL_Surface * screen, Sint32 x, Sint32 y,
+ # Sint32 w, Sint32 h)
+ # int SDL_WaitEvent(SDL_Event * event)
+ #
+ # TODO: What about SDL_LoadBMP_RW?
+ #
+ # From /usr/include/SDL/SDL_video.h:
+ #
+ # int SDL_UpperBlit(SDL_Surface * src, SDL_Rect * srcrect,
+ # SDL_Surface * dst, SDL_Rect * dstrect)
+ #
+
+ sub int DisplayFormat :fn = "SDL_DisplayFormat" (int surface);
+ sub int FillRect :fn = "SDL_FillRect" (int dst, int dstrect, int color);
+ sub int Flip :fn = "SDL_Flip" (int screen);
+ sub FreeSurface :fn = "SDL_FreeSurface" (int surface);
+ sub str GetKeyName :fn = "SDL_GetKeyName" (int key);
+ sub int Init :fn = "SDL_Init" (int flags);
+ sub int LoadBMP :fn = "SDL_LoadBMP" (str file);
+ sub int PollEvent :fn = "SDL_PollEvent" (int event);
+ sub Quit :fn = "SDL_Quit" ();
+ sub int SetVideoMode :fn = "SDL_SetVideoMode" (int width, int height, int bpp, int flags);
+ sub int WaitEvent :fn = "SDL_WaitEvent" (int event);
+ sub UpdateRect :fn = "SDL_UpdateRect" (int screen, int x, int y, int w, int h);
+ sub int UpperBlit :fn = "SDL_UpperBlit" (int src, int srcrect, int dst, int dstrect);
+
+
+ #
+ # Image functions:
+ #
+ # SDL_Surface * IMG_Load(const char * file)
+ #
+
+ sub int IMG_Load :fn = "IMG_Load" :fnlib = "libSDL_image" (str file);
+
+
+ #
+ # SDL Init Flags:
+
+
+ const int SDL_INIT_TIMER = 0x00000001;
+ const int SDL_INIT_AUDIO = 0x00000010;
+ const int SDL_INIT_VIDEO = 0x00000020;
+ const int SDL_INIT_CDROM = 0x00000100;
+ const int SDL_INIT_JOYSTICK = 0x00000200;
+ const int SDL_INIT_NOPARACHUTE = 0x00100000;
+ const int SDL_INIT_EVENTTHREAD = 0x01000000;
+ const int SDL_INIT_EVERYTHING = 0x0000ffff;
+
+ #
+ # Event type constants:
+ #
+
+ const int SDL_KEYDOWN = 2;
+ const int SDL_KEYUP = 3;
+ const int SDL_QUIT = 12;
+
+ #
+ # Key symbol constants:
+ #
+
+ const int SDLK_UNKNOWN = 0;
+
+ const int SDLK_FIRST = 0;
+ # 1 - 7?
+ const int SDLK_BACKSPACE = 8;
+ const int SDLK_TAB = 9;
+ # 10 - 11?
+ const int SDLK_CLEAR = 12;
+ const int SDLK_RETURN = 13;
+ # 14 - 18?
+ const int SDLK_PAUSE = 19;
+ # 20 - 26?
+ const int SDLK_ESCAPE = 27;
+ # 28 - 31?
+ const int SDLK_SPACE = 32;
+ const int SDLK_EXCLAIM = 33;
+ const int SDLK_QUOTEDBL = 34;
+ const int SDLK_HASH = 35;
+ const int SDLK_DOLLAR = 36;
+ # 37?
+ const int SDLK_AMPERSAND = 38;
+ const int SDLK_QUOTE = 39;
+ const int SDLK_LEFTPAREN = 40;
+ const int SDLK_RIGHTPAREN = 41;
+ const int SDLK_ASTERISK = 42;
+ const int SDLK_PLUS = 43;
+ const int SDLK_COMMA = 44;
+ const int SDLK_MINUS = 45;
+ const int SDLK_PERIOD = 46;
+ const int SDLK_SLASH = 47;
+ const int SDLK_0 = 48;
+ const int SDLK_1 = 49;
+ const int SDLK_2 = 50;
+ const int SDLK_3 = 51;
+ const int SDLK_4 = 52;
+ const int SDLK_5 = 53;
+ const int SDLK_6 = 54;
+ const int SDLK_7 = 55;
+ const int SDLK_8 = 56;
+ const int SDLK_9 = 57;
+ const int SDLK_COLON = 58;
+ const int SDLK_SEMICOLON = 59;
+ const int SDLK_LESS = 60;
+ const int SDLK_EQUALS = 61;
+ const int SDLK_GREATER = 62;
+ const int SDLK_QUESTION = 63;
+ const int SDLK_AT = 64;
+ # 65 - 90?
+ const int SDLK_LEFTBRACKET = 91;
+ const int SDLK_BACKSLASH = 92;
+ const int SDLK_RIGHTBRACKET = 93;
+ const int SDLK_CARET = 94;
+ const int SDLK_UNDERSCORE = 95;
+ const int SDLK_BACKQUOTE = 96;
+ const int SDLK_a = 97;
+ const int SDLK_b = 98;
+ const int SDLK_c = 99;
+ const int SDLK_d = 100;
+ const int SDLK_e = 101;
+ const int SDLK_f = 102;
+ const int SDLK_g = 103;
+ const int SDLK_h = 104;
+ const int SDLK_i = 105;
+ const int SDLK_j = 106;
+ const int SDLK_k = 107;
+ const int SDLK_l = 108;
+ const int SDLK_m = 109;
+ const int SDLK_n = 110;
+ const int SDLK_o = 111;
+ const int SDLK_p = 112;
+ const int SDLK_q = 113;
+ const int SDLK_r = 114;
+ const int SDLK_s = 115;
+ const int SDLK_t = 116;
+ const int SDLK_u = 117;
+ const int SDLK_v = 118;
+ const int SDLK_w = 119;
+ const int SDLK_x = 120;
+ const int SDLK_y = 121;
+ const int SDLK_z = 122;
+ # 123 - 126?
+ const int SDLK_DELETE = 127;
+ # 128 - 159?
+ const int SDLK_WORLD_0 = 160;
+ const int SDLK_WORLD_1 = 161;
+ const int SDLK_WORLD_2 = 162;
+ const int SDLK_WORLD_3 = 163;
+ const int SDLK_WORLD_4 = 164;
+ const int SDLK_WORLD_5 = 165;
+ const int SDLK_WORLD_6 = 166;
+ const int SDLK_WORLD_7 = 167;
+ const int SDLK_WORLD_8 = 168;
+ const int SDLK_WORLD_9 = 169;
+ const int SDLK_WORLD_10 = 170;
+ const int SDLK_WORLD_11 = 171;
+ const int SDLK_WORLD_12 = 172;
+ const int SDLK_WORLD_13 = 173;
+ const int SDLK_WORLD_14 = 174;
+ const int SDLK_WORLD_15 = 175;
+ const int SDLK_WORLD_16 = 176;
+ const int SDLK_WORLD_17 = 177;
+ const int SDLK_WORLD_18 = 178;
+ const int SDLK_WORLD_19 = 179;
+ const int SDLK_WORLD_20 = 180;
+ const int SDLK_WORLD_21 = 181;
+ const int SDLK_WORLD_22 = 182;
+ const int SDLK_WORLD_23 = 183;
+ const int SDLK_WORLD_24 = 184;
+ const int SDLK_WORLD_25 = 185;
+ const int SDLK_WORLD_26 = 186;
+ const int SDLK_WORLD_27 = 187;
+ const int SDLK_WORLD_28 = 188;
+ const int SDLK_WORLD_29 = 189;
+ const int SDLK_WORLD_30 = 190;
+ const int SDLK_WORLD_31 = 191;
+ const int SDLK_WORLD_32 = 192;
+ const int SDLK_WORLD_33 = 193;
+ const int SDLK_WORLD_34 = 194;
+ const int SDLK_WORLD_35 = 195;
+ const int SDLK_WORLD_36 = 196;
+ const int SDLK_WORLD_37 = 197;
+ const int SDLK_WORLD_38 = 198;
+ const int SDLK_WORLD_39 = 199;
+ const int SDLK_WORLD_40 = 200;
+ const int SDLK_WORLD_41 = 201;
+ const int SDLK_WORLD_42 = 202;
+ const int SDLK_WORLD_43 = 203;
+ const int SDLK_WORLD_44 = 204;
+ const int SDLK_WORLD_45 = 205;
+ const int SDLK_WORLD_46 = 206;
+ const int SDLK_WORLD_47 = 207;
+ const int SDLK_WORLD_48 = 208;
+ const int SDLK_WORLD_49 = 209;
+ const int SDLK_WORLD_50 = 210;
+ const int SDLK_WORLD_51 = 211;
+ const int SDLK_WORLD_52 = 212;
+ const int SDLK_WORLD_53 = 213;
+ const int SDLK_WORLD_54 = 214;
+ const int SDLK_WORLD_55 = 215;
+ const int SDLK_WORLD_56 = 216;
+ const int SDLK_WORLD_57 = 217;
+ const int SDLK_WORLD_58 = 218;
+ const int SDLK_WORLD_59 = 219;
+ const int SDLK_WORLD_60 = 220;
+ const int SDLK_WORLD_61 = 221;
+ const int SDLK_WORLD_62 = 222;
+ const int SDLK_WORLD_63 = 223;
+ const int SDLK_WORLD_64 = 224;
+ const int SDLK_WORLD_65 = 225;
+ const int SDLK_WORLD_66 = 226;
+ const int SDLK_WORLD_67 = 227;
+ const int SDLK_WORLD_68 = 228;
+ const int SDLK_WORLD_69 = 229;
+ const int SDLK_WORLD_70 = 230;
+ const int SDLK_WORLD_71 = 231;
+ const int SDLK_WORLD_72 = 232;
+ const int SDLK_WORLD_73 = 233;
+ const int SDLK_WORLD_74 = 234;
+ const int SDLK_WORLD_75 = 235;
+ const int SDLK_WORLD_76 = 236;
+ const int SDLK_WORLD_77 = 237;
+ const int SDLK_WORLD_78 = 238;
+ const int SDLK_WORLD_79 = 239;
+ const int SDLK_WORLD_80 = 240;
+ const int SDLK_WORLD_81 = 241;
+ const int SDLK_WORLD_82 = 242;
+ const int SDLK_WORLD_83 = 243;
+ const int SDLK_WORLD_84 = 244;
+ const int SDLK_WORLD_85 = 245;
+ const int SDLK_WORLD_86 = 246;
+ const int SDLK_WORLD_87 = 247;
+ const int SDLK_WORLD_88 = 248;
+ const int SDLK_WORLD_89 = 249;
+ const int SDLK_WORLD_90 = 250;
+ const int SDLK_WORLD_91 = 251;
+ const int SDLK_WORLD_92 = 252;
+ const int SDLK_WORLD_93 = 253;
+ const int SDLK_WORLD_94 = 254;
+ const int SDLK_WORLD_95 = 255;
+ const int SDLK_KP0 = 256;
+ const int SDLK_KP1 = 257;
+ const int SDLK_KP2 = 258;
+ const int SDLK_KP3 = 259;
+ const int SDLK_KP4 = 260;
+ const int SDLK_KP5 = 261;
+ const int SDLK_KP6 = 262;
+ const int SDLK_KP7 = 263;
+ const int SDLK_KP8 = 264;
+ const int SDLK_KP9 = 265;
+ const int SDLK_KP_PERIOD = 266;
+ const int SDLK_KP_DIVIDE = 267;
+ const int SDLK_KP_MULTIPLY = 268;
+ const int SDLK_KP_MINUS = 269;
+ const int SDLK_KP_PLUS = 270;
+ const int SDLK_KP_ENTER = 271;
+ const int SDLK_KP_EQUALS = 272;
+ const int SDLK_UP = 273;
+ const int SDLK_DOWN = 274;
+ const int SDLK_RIGHT = 275;
+ const int SDLK_LEFT = 276;
+ const int SDLK_INSERT = 277;
+ const int SDLK_HOME = 278;
+ const int SDLK_END = 279;
+ const int SDLK_PAGEUP = 280;
+ const int SDLK_PAGEDOWN = 281;
+ const int SDLK_F1 = 282;
+ const int SDLK_F2 = 283;
+ const int SDLK_F3 = 284;
+ const int SDLK_F4 = 285;
+ const int SDLK_F5 = 286;
+ const int SDLK_F6 = 287;
+ const int SDLK_F7 = 288;
+ const int SDLK_F8 = 289;
+ const int SDLK_F9 = 290;
+ const int SDLK_F10 = 291;
+ const int SDLK_F11 = 292;
+ const int SDLK_F12 = 293;
+ const int SDLK_F13 = 294;
+ const int SDLK_F14 = 295;
+ const int SDLK_F15 = 296;
+ # 297 - 299?
+ const int SDLK_NUMLOCK = 300;
+ const int SDLK_CAPSLOCK = 301;
+ const int SDLK_SCROLLOCK = 302;
+ const int SDLK_RSHIFT = 303;
+ const int SDLK_LSHIFT = 304;
+ const int SDLK_RCTRL = 305;
+ const int SDLK_LCTRL = 306;
+ const int SDLK_RALT = 307;
+ const int SDLK_LALT = 308;
+ const int SDLK_RMETA = 309;
+ const int SDLK_LMETA = 310;
+ const int SDLK_LSUPER = 311;
+ const int SDLK_RSUPER = 312;
+ const int SDLK_MODE = 313;
+ const int SDLK_COMPOSE = 314;
+ const int SDLK_HELP = 315;
+ const int SDLK_PRINT = 316;
+ const int SDLK_SYSREQ = 317;
+ const int SDLK_BREAK = 318;
+ const int SDLK_MENU = 319;
+ const int SDLK_POWER = 320;
+ const int SDLK_EURO = 321;
+ const int SDLK_UNDO = 322;
+ const int SDLK_LAST = 323;
+
+}
+
Added: jako/trunk/antlr/Main.java
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/antlr/Main.java Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,26 @@
+import java.io.*;
+import org.antlr.runtime.*;
+
+public class Main {
+ private static void parse(String fileName) throws Exception {
+ JakoParserLexer lex = new JakoParserLexer(new ANTLRFileStream(fileName));
+ CommonTokenStream tokens = new CommonTokenStream(lex);
+
+ JakoParser g = new JakoParser(tokens);
+
+ try {
+ g.semantic_unit();
+ } catch (RecognitionException e) {
+ e.printStackTrace();
+ }
+ }
+
+ public static void main(String args[]) throws Exception {
+ for (String fileName: args) {
+ System.out.println();
+ System.out.println(fileName + ": ");
+ System.out.flush();
+ parse(fileName);
+ }
+ }
+}
Added: jako/trunk/antlr/Makefile
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/antlr/Makefile Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,27 @@
+
+ANTLR_HOME=/usr/local/antlr-3.0b3
+CLASSPATH=.:$(ANTLR_HOME)/lib/antlr-3.0b3.jar:$(ANTLR_HOME)/lib/stringtemplate-2.3b9.jar:$(ANTLR_HOME)/lib/antlr-2.7.6.jar
+
+JAVAC=javac -classpath $(CLASSPATH)
+ANTLR=java -classpath $(CLASSPATH) org.antlr.Tool
+
+all: Main.class JakoParserLexer.class JakoParser.lexer.g JakoParserLexer.tokens
+
+JakoParser.java JakoParser.tokens JakoParser.lexer.g JakoParserLexer.java JakoParserLexer.tokens: jako.g
+ $(ANTLR) jako.g && test -e JakoParser.java || false
+
+Main.class: Main.java JakoParser.class
+ $(JAVAC) Main.java
+
+JakoParser.class: JakoParser.java
+ $(JAVAC) JakoParser.java
+
+JakoParserLexer.class: JakoParserLexer.java
+ $(JAVAC) JakoParserLexer.java
+
+test:
+ ./jakop ../*.jako ../examples/*.jako
+
+clean:
+ rm -f *.class JakoParser.java JakoParser.tokens JakoParserLexer.java JakoParserLexer.class JakoParserLexer.tokens JakoParser.lexer.g
+
Added: jako/trunk/antlr/jako.g
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/antlr/jako.g Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,263 @@
+//
+// jako.g
+//
+// Jako Grammar for ANTLR v3.0b3.
+//
+// Expressions, comments, and literals taken from or patterned after the c.g ANSI C ANTLR v3 grammar
+// in the set of example grammars available from antlr.org on or about 2006-07-30.
+//
+
+grammar JakoParser;
+
+options {
+ backtrack=true;
+ memoize=true;
+// k=2;
+}
+
+semantic_unit
+ : (directive | module_definition | deferred | statement)+ ;
+
+deferred
+ : declaration | definition ;
+
+definition
+ : subroutine_definition;
+
+subroutine_header
+ : 'sub' type_name? plain_identifier option* '(' formal_argument_list ')' ;
+
+subroutine_declaration
+ : subroutine_header ';' ;
+
+subroutine_definition
+ : subroutine_header block ;
+
+//
+// Declarations:
+//
+
+declaration
+ : data_declaration
+ | subroutine_declaration
+ ;
+
+data_declaration
+ : 'const' type_name plain_identifier '=' literal ';'
+ | 'var' type_name plain_identifier_list ( '=' expression )? ';'
+ ;
+
+plain_identifier_list
+ : plain_identifier ( ',' plain_identifier )*
+ ;
+
+//
+// Definitions:
+//
+
+option
+ : ':' plain_identifier ( '=' STRING_LITERAL )?
+ ;
+
+formal_argument_list
+ :
+ | type_name plain_identifier ( ',' type_name plain_identifier )*
+ ;
+
+module_definition
+ : 'module' identifier option* '{' deferred+ '}'
+ ;
+
+//
+// Directives:
+//
+
+directive
+ : use_directive
+ ;
+
+use_directive
+ : 'use' identifier ';'
+ ;
+
+//
+// Statements:
+//
+
+statement
+ : basic_statement statement_modifier? ';'
+ | while_statement
+ | if_statement
+ ;
+
+basic_statement
+ : side_effect_statement
+ | return_statement
+ | loop_control_statement
+ | goto_statement
+ ;
+
+statement_modifier
+ : 'if' '(' expression ')'
+ | 'unless' '(' expression ')'
+ ;
+
+side_effect_statement
+ : primary_expression assignment_operator expression
+ | primary_expression ( '++' | '--' )
+ | expression
+ ;
+
+assignment_operator
+ : '='
+ | '*='
+ | '/='
+ | '%='
+ | '+='
+ | '-='
+ | '~='
+ ;
+
+goto_statement
+ : 'goto' plain_identifier ;
+
+while_statement : 'while' expression block ( 'continue' block )? ;
+
+if_statement
+ : 'if' '(' expression ')' block ( 'else' block )? ;
+
+return_statement
+ : 'return' expression? ;
+
+loop_control_statement
+ : ( 'last' | 'next' ) plain_identifier? ;
+
+//
+// Expressions:
+//
+
+expression
+ : primary_expression
+ | '!' expression
+ | '-' expression
+ | '(' expression ( '||' | '&&' | '==' | '!=' | '<' | '>' | '<=' | '>=' | '+' | '-' | '*' | '/' | '%' ) expression ')'
+ ;
+
+primary_expression
+ : ( identifier | literal | '(' expression ')' | 'new' identifier )
+ ( '[' expression ']'
+ | '(' ')'
+ | '(' argument_expression_list ')'
+ | '.' plain_identifier
+ )*
+ ;
+
+argument_expression_list
+ : expression ( ',' expression )*
+ ;
+
+//
+// Basics:
+//
+
+label : LABEL ;
+
+type_name
+ : 'int' | 'str' | 'num' | 'pmc';
+
+literal
+ : HEX_LITERAL
+ | OCTAL_LITERAL
+ | DECIMAL_LITERAL
+ | STRING_LITERAL
+ | FLOATING_POINT_LITERAL
+ ;
+
+block : '{' ( data_declaration | statement )* '}' ;
+
+scoped_identifier
+ : NAME
+ ;
+
+plain_identifier
+ : WORD
+ ;
+
+identifier
+ : scoped_identifier
+ | plain_identifier
+ ;
+
+//
+// Tokens:
+//
+
+NAME : WORD ( '::' WORD )+ ;
+
+WORD : LETTER (LETTER|'0'..'9')* ;
+
+LABEL : WORD ':' ;
+
+STRING_LITERAL
+ : '"' ( EscapeSequence | ~('\\'|'"') )* '"'
+ ;
+
+fragment
+LETTER
+ : '$'
+ | 'A'..'Z'
+ | 'a'..'z'
+ | '_'
+ ;
+
+HEX_LITERAL : '0' ('x'|'X') HexDigit+ ;
+
+DECIMAL_LITERAL : '-'? ('0' | '1'..'9' '0'..'9'*) ;
+
+OCTAL_LITERAL : '0' ('0'..'7')+ ;
+
+fragment
+HexDigit : ('0'..'9'|'a'..'f'|'A'..'F') ;
+
+FLOATING_POINT_LITERAL
+ : '-'? ('0'..'9')+ '.' ('0'..'9')* Exponent?
+ | '-'? '.' ('0'..'9')+ Exponent?
+ | '-'? ('0'..'9')+ Exponent
+ ;
+
+fragment
+Exponent : ('e'|'E') ('+'|'-')? ('0'..'9')+ ;
+
+fragment
+EscapeSequence
+ : '\\' ('b'|'t'|'n'|'f'|'r'|'\"'|'\''|'\\')
+ | OctalEscape
+ ;
+
+fragment
+OctalEscape
+ : '\\' ('0'..'3') ('0'..'7') ('0'..'7')
+ | '\\' ('0'..'7') ('0'..'7')
+ | '\\' ('0'..'7')
+ ;
+
+fragment
+UnicodeEscape
+ : '\\' 'u' HexDigit HexDigit HexDigit HexDigit
+ ;
+
+WS : (' '|'\r'|'\t'|'\u000C'|'\n') {channel=99;}
+ ;
+
+COMMENT
+ : '/*' ( options {greedy=false;} : . )* '*/' {channel=99;}
+ ;
+
+LINE_COMMENT
+ : '//' ~('\n'|'\r')* '\r'? '\n' {channel=99;}
+ ;
+
+// ignore #line info for now
+LINE_COMMENT_2
+ : '#' ~('\n'|'\r')* '\r'? '\n' {channel=99;}
+ ;
Added: jako/trunk/antlr/jakop
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/antlr/jakop Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,7 @@
+#!/bin/bash
+
+export ANTLR=/usr/local/antlr-3.0b3
+export CLASSPATH=.:$ANTLR/lib/antlr-3.0b3.jar:$ANTLR/lib/stringtemplate-2.3b9.jar:$ANTLR/lib/antlr-2.7.6.jar
+
+java Main $@
+
Added: jako/trunk/config/makefiles/root.in
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/config/makefiles/root.in Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,113 @@
+# Copyright (C) 2002-2009, Parrot Foundation.
+# $Id$
+#
+
+PERL = @perl@
+RM_F = @rm_f@
+JAKOC = $(PERL) -I lib jakoc
+INTERP = ../../@test_prog@
+BUILD_DIR = @build_dir@
+RECONFIGURE = $(PERL) @build_dir@/tools/dev/reconfigure.pl
+#CONDITIONED_LINE(darwin):
+#CONDITIONED_LINE(darwin):# MACOSX_DEPLOYMENT_TARGET must be defined for OS X compilation/linking
+#CONDITIONED_LINE(darwin):export MACOSX_DEPLOYMENT_TARGET := @osx_version@
+
+.SUFFIXES: .jako .pir
+
+
+# default target
+all: \
+ examples/bench.pir \
+ examples/board.pir \
+ examples/euclid.pir \
+ examples/fact.pir \
+ examples/fib.pir \
+ examples/hello.pir \
+ examples/leibniz.pir \
+ examples/life.pir \
+ examples/mandelbrot.pir \
+ examples/mandelzoom.pir \
+ examples/mops.pir \
+ examples/nci.pir \
+ examples/primes.pir \
+ examples/queens.pir \
+ examples/sub.pir
+
+help :
+ @echo ""
+ @echo "Following targets are available for the user:"
+ @echo ""
+ @echo " all : Compile the example scripts"
+ @echo " This is the default."
+ @echo ""
+ @echo " over: clean and build again"
+ @echo ""
+ @echo " test: run the test suite"
+ @echo ""
+ @echo " clean: clean up temporary files"
+ @echo ""
+ @echo " realclean: clean up generated files"
+ @echo ""
+ @echo " help: print this help message"
+
+
+# regenerate the Makefile
+Makefile: config/makefiles/root.in
+ cd $(BUILD_DIR) && $(RECONFIGURE) --step=gen::languages --languages=jako
+
+
+# Compilation:
+.jako.pir:
+ $(JAKOC) $< > $@ || (rm -f $@ && false)
+
+examples/bench.pir: examples/bench.jako jakoc
+examples/board.pir: examples/board.jako jakoc
+examples/euclid.pir: examples/euclid.jako jakoc
+examples/fact.pir: examples/fact.jako jakoc
+examples/fib.pir: examples/fib.jako jakoc
+examples/hello.pir: examples/hello.jako jakoc
+examples/leibniz.pir: examples/leibniz.jako jakoc
+examples/life.pir: examples/life.jako jakoc
+examples/mandelbrot.pir: examples/mandelbrot.jako jakoc
+examples/mandelzoom.pir: examples/mandelzoom.jako jakoc
+examples/mops.pir: examples/mops.jako jakoc
+examples/nci.pir: examples/nci.jako jakoc
+examples/primes.pir: examples/primes.jako jakoc
+examples/queens.pir: examples/queens.jako jakoc
+examples/sub.pir: examples/sub.jako jakoc
+
+
+# Other targets:
+
+clean:
+ $(RM_F) "examples/*.pir" "examples/*.list" "t/*.pir"
+
+realclean: clean
+ $(RM_F) Makefile
+
+
+over:
+ @$(MAKE) clean
+ @$(MAKE) all
+
+test: all
+ $(INTERP) examples/bench.pir
+ $(INTERP) examples/board.pir
+ $(INTERP) examples/euclid.pir
+ $(INTERP) examples/fact.pir
+ $(INTERP) examples/fib.pir
+ $(INTERP) examples/hello.pir
+ $(INTERP) examples/leibniz.pir
+ $(INTERP) examples/life.pir
+ $(INTERP) examples/mandelbrot.pir
+ $(INTERP) examples/mandelzoom.pir
+ $(INTERP) examples/mops.pir
+ $(INTERP) examples/nci.pir
+ $(INTERP) examples/primes.pir
+ $(INTERP) examples/queens.pir
+ $(INTERP) examples/sub.pir
+
+# Local variables:
+# mode: makefile
+# End:
+# vim: ft=make:
Added: jako/trunk/docs/jako.pod
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/docs/jako.pod Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,235 @@
+=head1 NAME
+
+jako - No frills programming for Parrot
+
+=head1 SYNOPSIS
+
+Jako is a simple programming language that targets the Parrot
+virtual machine.
+
+=head1 DESCRIPTION
+
+Jako should be familiar to those who have seen C and Perl.
+
+=head2 Lexical Structure
+
+Jako's lexical structure is similar to its relative: Perl. Whitespace between
+tokens is not significant, and comments are introduced with an octothorp
+('#') and continue to the end of the line.
+
+=over 4
+
+=item * Labels
+
+An identifier followed by a colon at the beginning of a line is a label.
+Labels can be the targets of B<goto> statements, and can also provide a
+way to refer to specific loops when using the loop control statements
+(see below).
+
+=item * Literals
+
+=over 4
+
+=item * Integers
+
+=over 4
+
+=item * Binary
+
+"0b" followed by any number of binary digits ("0" or "1").
+
+=item * Octal
+
+"0" followed by any number of octal digits ("0" to "7").
+
+=item * Decimal
+
+Starting with a non-zero decimal digit, with any number of decimal digits
+following. Optional prefixed "-" for negative integers.
+
+=item * Hexadecimal
+
+"0x" followed by any number of hexadecimal digits ("0" to "9", "a", "b", "c", "d", "e", or "f").
+
+=back
+
+=item * Numbers
+
+One or more decimal digits, a decimal point, and one ore more decimal digits.
+Optional prefixed "-" for negative numbers.
+
+=item * Strings
+
+A double-quote character, followed by the contents of the string, and another double-quote
+character. Inside the string literal, double quotes are to be escaped with "\" (back slash,
+a.k.a. "whack"). To include a back slash in the string, precede it with another back slash.
+
+=back
+
+=item * Identifiers
+
+Start with a letter, followed by any combination of letters, decimal digits and underscores.
+
+=item * Types
+
+The built-in types are recognized as keywords: B<int>, B<num>, B<pmc>, B<str>.
+
+=back
+
+=head2 Syntax
+
+=over 4
+
+=item * Blocks
+
+A block is a sequence of statements and declarations between a matching pair
+of open and close braces ("B<{>" and "B<}>"). Each block represents a scope for
+lexical symbols (variables and constants). There is an implicit block which
+represents the entire compilation unit (usually a file). Subroutines may
+only appear at this level.
+
+=item * Constant Declarations
+
+B<const> introduces a constant declaration. What follows must be a type, a
+list of identifiers, "B<=>", and a value of an appropriate type.
+
+ const int a, b, c = 2;
+ const int pi_in = 3; # Indiana
+ const num pi = 3.141592; # Everywhere else
+ const str d = "Como estas?";
+
+=item * Variable Declarations
+
+B<var> introduces a variable declaration. What follows must be a type and
+a list of identifiers, optionally followed by "B<=>" and an expression.
+
+ var int a, b, c;
+ var num d, e, f = 42.0;
+ var str g = "Howdy";
+
+=item * Subroutines
+
+B<sub> introduces a subroutine declaration (and possibly definition). What
+follows is an optional type, and identifier (the name of the subroutine), an
+optional set of properties, and a list of formal arguments in parenthesis.
+The formal arguments are written as a comma-separated list of type-name pairs.
+Finally, there must be a block which contains the implementation of the
+subroutine.
+
+Simple cases of subroutine definitions are:
+
+ sub foo() { ... }
+ sub int bar(int x, int y) { ... }
+
+NOTE: The below requires C<jakoc> to be able to determine the best match among
+a number of alternatives with the same name, but different signatures.
+
+The B<op> property can have a string value that gives the op name, if it is
+different from the sub name. There is also an B<oplib> property that gives
+the oplib, if the op is not core.
+
+TODO: Presumably, there should be an implicit "use 'core'", that would pull in
+the definitions of the core ops as subs (if any).
+
+One wonders if this mechanism could be expanded to account for the
+arithmetic operators, etc.
+
+Also, if the Parrot .ops files could be processed to automatically
+produce the include files for the various categories of ops and subs.
+
+ sub num coversine { oplib = "obscure", op = "covers" } (num);
+
+ sub int BlitSurface { fnlib = "libsdl", fn = "SDL_BlitSurface" } (
+ pmc { nat = "p" } src,
+ pmc { nat = "p" } srcrect,
+ pmc { nat = "p" } dst,
+ pmc { nat = "p" } dstrect
+ );
+
+NOTE: The B<oplib> sub property is not implemented yet.
+
+NOTE: Type properties are not implemented yet.
+
+=item * Assignments
+
+Following tradition, basic assignments are written as
+
+ left = right;
+
+Conversions between B<int> and B<num> values are implicit.
+
+=item * Conditionals
+
+There are two kinds of conditional block: B<if> and B<unless>, with the latter
+being short for the more familiar B<if>, but with the condition inverted. In
+both cases, what follows the keyword is a parenthesized boolean expression and
+a block.
+
+ if (happy) { smile(); }
+ unless (raining) { play(); }
+
+Even though each is redundant given the presence of the other, both are
+retained in the language for the same reason as in Perl: allowing more natural
+expression.
+
+Further, there can be a subsequent block, introduced with B<else>:
+
+ if (paid) { work(); } else { complain(); }
+ unless (paid) { complain(); } else { work(); }
+
+=item * Loops
+
+There are two kinds of loop: B<while> and B<until>, with the same reversal of
+sense as exists between B<if> and B<unless>.
+
+ while (1) {
+ while (overdue != 0.0) { work(); invoice(); }
+ until (overdue == 0.0) { send_dunning_letter(); }
+ }
+
+You can control loops with the B<next>, B<last> and B<redo> loop control
+statements. B<next> jumps immediately to the next iteration of the loop,
+without executing the intervening statements, B<last> jumps immediately
+out of the loop, again without executing the intervening statements. And,
+B<redo> jumps back to the beginning of the current iteration.
+
+Loops can be followed by an optional B<continue> block, which provides
+code to be executed between iterations.
+
+=back
+
+=head2 Semantics
+
+=over 4
+
+=item * String interpolation
+
+An unescaped dollar sign ("$") in a string causes Jako to interpolate variables
+into a final string before the string is used in an expression. In case the
+text to follow the interpolated value starts with identifier characters that
+would interfere with the correct determination of the variable to interpolate,
+use the form "${...}".
+
+=back
+
+=head1 HISTORY
+
+Jako was the first language to target the Parrot virtual machine. It was also
+the first language to support subroutines (although in a rudimentary, hackish
+way) for Parrot. It has since grown up a bit and now uses PIR to get real
+subroutine support.
+
+=head1 AUTHOR
+
+You can blame gregor <gregor at focusresearch.com> for the Jako language and its
+compiler.
+
+=head1 COPYRIGHT
+
+Copyright (C) 2001-2007, Parrot Foundation.
+
+=head1 LICENSE
+
+The Jako compiler is free software. It is subject to the same license as the
+Parrot interpreter.
+
Added: jako/trunk/elem.jako
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/elem.jako Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,48 @@
+#
+# elem.jako
+#
+# Elementary Function ops.
+#
+# Copyright (C) 2003-2005, Parrot Foundation.
+# This program is free software. Its use is subject to the same
+# license as Parrot.
+#
+# $Id$
+#
+
+module elem
+{
+ sub num acos :op (int x);
+ sub num acos :op (num x);
+ sub num asec :op (int x);
+ sub num asec :op (num x);
+ sub num atan :op (num x);
+ sub num atan :op (num x);
+ sub num atan2 :op (int x, int y);
+ sub num atan2 :op (int x, num y);
+ sub num atan2 :op (num x, int y);
+ sub num atan2 :op (num x, num y);
+ sub num cos :op (int x);
+ sub num cos :op (num x);
+ sub num cosh :op (int x);
+ sub num cosh :op (num x);
+ sub num exp :op (int x);
+ sub num exp :op (num x);
+ sub num ln :op (int x);
+ sub num ln :op (num x);
+ sub num log10 :op (int x);
+ sub num log10 :op (num x);
+ sub num log2 :op (int x);
+ sub num log2 :op (num x);
+ sub num sec :op (int x);
+ sub num sec :op (num x);
+ sub num sech :op (int x);
+ sub num sech :op (num x);
+ sub num sin :op (int x);
+ sub num sin :op (num x);
+ sub num sinh :op (int x);
+ sub num sinh :op (num x);
+ sub num tanh :op (int x);
+ sub num tanh :op (num x);
+}
+
Added: jako/trunk/examples/bench.jako
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/examples/bench.jako Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,60 @@
+#
+# bench.jako
+#
+# Based on Bench.java posted to perl6-internals at perl.org by
+# Leon Brocard <acme at astray.com> on 2001-09-15. Note that the
+# only substantive differences between the Java version and the
+# Jako version are:
+#
+# * 'var int ...' vs 'int ...' for variable declaration.
+#
+# * The commented-out print line (which is simpler in Jako).
+#
+# * The use of the named constant N (value 100) instead of
+# the literal constant 10000 in the conditions of the while
+# loops.
+#
+# Copyright (C) 2001-2005, Parrot Foundation
+# This program is free software. It is subject to the same
+# license as the Parrot interpreter.
+#
+# $Id$
+#
+
+use sys;
+
+const int N = 1000;
+
+sub bench() {
+ var int q = 1;
+
+ var num start_time;
+
+ start_time = sys::timen();
+
+ while (q < N) {
+ var int i, j, w = 1;
+
+ while (w < N) {
+ i++;
+ j += i;
+ w++;
+# sys::print("$q, $w\n");
+ }
+
+ q++;
+ }
+
+ var num end_time;
+
+ end_time = sys::timen();
+
+ var num elapsed;
+
+ elapsed = end_time - start_time;
+
+ sys::print("Elapsed: $elapsed\n");
+}
+
+bench();
+
Added: jako/trunk/examples/board.jako
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/examples/board.jako Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,47 @@
+#
+# board.jako
+#
+# An example that prints a Chess board using simple looping constructs.
+#
+# Copyright (C) 2001-2005, Parrot Foundation
+# This program is free software. It is subject to the same
+# license as the Parrot interpreter.
+#
+# $Id$
+#
+
+use sys;
+
+var int rank, file;
+var int temp;
+
+rank = 7;
+
+sys::print(" +---+---+---+---+---+---+---+---+\n");
+
+while(rank >= 0) {
+ temp = rank + 1;
+ file = 0;
+
+ sys::print("$temp |");
+
+ while(file < 8) {
+ temp = rank + file;
+ temp %= 2;
+
+ if (temp == 1) {
+ sys::print(" |");
+ } else {
+ sys::print(" * |");
+ }
+
+ file++;
+ }
+
+ sys::print("\n");
+ sys::print(" +---+---+---+---+---+---+---+---+\n");
+ rank--;
+}
+
+sys::print(" A B C D E F G H \n");
+
Added: jako/trunk/examples/euclid.jako
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/examples/euclid.jako Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,38 @@
+#
+# euclid.jako
+#
+# Knuth, Donald E.
+# The Art of Computer Programming
+# Volume 1: Fundamental Algorithms
+# Third Edition
+#
+# Section 1.1
+# Algorithm E (Euclid's algorithm)
+# Page 2
+#
+# Copyright (C) 2001-2005, Parrot Foundation
+# This program is free software. It is subject to the same
+# license as the Parrot interpreter.
+#
+# $Id$
+#
+
+use sys;
+
+var int m, n, r;
+
+m = 96;
+n = 64;
+
+sys::print("Algorithm E (Euclid's algorithm)\n");
+sys::print(" Calculating gcd($m, $n) = ...\n");
+
+r = m % n;
+while (r != 0) {
+ m = n;
+ n = r;
+ r = m % n;
+}
+
+sys::print(" ... = $n\n");
+
Added: jako/trunk/examples/fact.jako
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/examples/fact.jako Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,49 @@
+#
+# fact.jako
+#
+# Some simple code to print some factorials
+#
+# Based on fact.pasm originally be Leon Brocard <acme at astray.com> 2001-09-14.
+#
+# Copyright (C) 2001-2005, Parrot Foundation.
+# This program is free software. It is subject to the same
+# license as the Parrot interpreter.
+#
+# $Id$
+#
+
+use sys;
+
+const int N = 15;
+
+
+#
+# fact()
+#
+
+sub int fact(int n) {
+ var int i = 0;
+ var int f = 1;
+
+ while(i < n) {
+ i++;
+ f *= i;
+ }
+
+ return f;
+}
+
+
+#
+# MAIN PROGRAM:
+#
+
+var int f;
+
+sys::print("Algorithm F1 (The factorial function)\n");
+sys::print(" Calculating fact($N) = ...\n");
+
+f = fact(N);
+
+sys::print(" ... = $f\n");
+
Added: jako/trunk/examples/fib.jako
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/examples/fib.jako Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,33 @@
+#
+# fib.jako
+#
+# Adapted from fibo.pasm by lars at kultunaut.dk.
+#
+# Copyright (C) 2001-2005, Parrot Foundation.
+# This program is free software. It is subject to the same
+# license as the Parrot interpreter.
+#
+# $Id$
+#
+
+use sys;
+
+const int n = 24;
+
+var int a = 1;
+var int b = 1;
+var int f = 1;
+var int i = 3;
+
+sys::print("Algorithm F2 (Fibonacci's function)\n");
+sys::print(" Calculating fib($n) = ...\n");
+
+while (i <= n) {
+ f = a + b;
+ a = b;
+ b = f;
+ i++;
+}
+
+sys::print(" ... = $f\n");
+
Added: jako/trunk/examples/hello.jako
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/examples/hello.jako Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,16 @@
+#
+# hello.jako
+#
+# ObHW
+#
+# Copyright (C) 2001-2005, Parrot Foundation.
+# This program is free software. It is subject to the same
+# license as the Parrot interpreter.
+#
+# $Id$
+#
+
+use sys;
+
+sys::print("Hello, world!\n");
+
Added: jako/trunk/examples/leibniz.jako
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/examples/leibniz.jako Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,48 @@
+#
+# leibniz.jako
+#
+# Simple code to calculate the Leibniz summation for
+# PI, which is:
+#
+# PI/4 = 1/1 - 1/3 + 1/5 - 1/7 + 1/9 ....
+#
+# (The summation isn't a very good one)
+#
+# Based on a Parrot assembly language example by Greg McCarroll.,
+# which can be found at http://www.parrotcode.org/examples/
+#
+# Copyright (C) 2001-2005, Parrot Foundation.
+# This program is free software. It is subject to the same
+# license as the Parrot interpreter.
+#
+
+use sys;
+
+const num first_den = 1.0;
+const num last_den = 1000000.0;
+
+sub leibniz() {
+ var num flag = 1.0;
+ var num cur_frac = 0.0;
+
+ var num this_den;
+
+ this_den = first_den;
+
+ while (this_den <= last_den) {
+ var num new_frac;
+ new_frac = flag / this_den;
+ cur_frac += new_frac;
+ } continue {
+ flag *= -1.0;
+ this_den += 2.0;
+ }
+
+ var num pi;
+ pi = 4.0 * cur_frac;
+
+ sys::print("PI is (very) approximately: $pi\n");
+}
+
+leibniz();
+
Added: jako/trunk/examples/life.jako
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/examples/life.jako Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,226 @@
+#
+# life.jako
+#
+# Play Conway's (no, not *him*. The other Conway) game of life.
+#
+# Based on life.pasm, Hacked by Leon Brocard <acme at astray.com> to use curses.
+#
+# The original version of 2002-12-05 can be found here:
+#
+# http://archive.develooper.com/perl6-internals@perl.org/msg13935.html
+#
+
+use sys;
+use string;
+use Curses;
+
+var int foo; # Store result from above functions here.
+
+const int G = 100; # Generation count.
+
+const int WIDTH = 15;
+const int HEIGHT = 15;
+var int ARRAY_SIZE;
+
+ARRAY_SIZE = WIDTH * HEIGHT;
+
+const str r00 = " ";
+const str r01 = " ";
+const str r02 = " ";
+const str r03 = " ";
+const str r04 = " ** ";
+const str r05 = " * * ";
+const str r06 = " * ";
+const str r07 = " * * ";
+const str r08 = " ****** ";
+const str r09 = " ";
+const str r10 = " ";
+const str r11 = " ";
+const str r12 = " ";
+const str r13 = " ";
+const str r14 = " ";
+
+#const str r00 = " * ";
+#const str r01 = " * ";
+#const str r02 = " *** ";
+#const str r03 = " ";
+#const str r04 = " ";
+#const str r05 = " ";
+#const str r06 = " ";
+#const str r07 = " ";
+#const str r08 = " ";
+#const str r09 = " ";
+#const str r10 = " ";
+#const str r11 = " ";
+#const str r12 = " ";
+#const str r13 = " ";
+#const str r14 = " ";
+
+
+#
+# at()
+#
+# Return 1 if the cell at row, col is alive, otherwise 0.
+#
+
+sub int at (str cells, int row, int col)
+{
+ var str temp;
+ var int offset;
+
+ row += HEIGHT; # In case they are slightly negative.
+ col += WIDTH;
+
+ row %= HEIGHT;
+ col %= WIDTH;
+
+ offset = row * WIDTH;
+ offset += col;
+
+ temp = string::substr(cells, offset, 1);
+
+ return 1 if (temp == "*");
+ return 0;
+}
+
+
+#
+# generate()
+#
+
+sub str generate (str cells)
+{
+ var str temp = "";
+
+ var int row = 0;
+
+ while (row < HEIGHT) {
+ var int col = 0;
+
+ while (col < WIDTH) {
+ var int count;
+ var int r;
+ var int c;
+ var int cell;
+
+ count = 0;
+
+ r = row - 1; c = col - 1; cell = at(cells, r, c); count += cell; # NW
+ r = row - 1; c = col ; cell = at(cells, r, c); count += cell; # N
+ r = row - 1; c = col + 1; cell = at(cells, r, c); count += cell; # NE
+
+ r = row ; c = col - 1; cell = at(cells, r, c); count += cell; # W
+ r = row ; c = col + 1; cell = at(cells, r, c); count += cell; # E
+
+ r = row + 1; c = col - 1; cell = at(cells, r, c); count += cell; # SW
+ r = row + 1; c = col ; cell = at(cells, r, c); count += cell; # S
+ r = row + 1; c = col + 1; cell = at(cells, r, c); count += cell; # SE
+
+ var int current;
+ current = at(cells, row, col);
+
+ var str ch;
+ if (current == 0) {
+ ch = string::substr(" * ", count, 1);
+ }
+ else {
+ ch = string::substr(" ** ", count, 1);
+ }
+
+ temp ~= ch;
+
+ col++;
+ }
+
+ row++;
+ }
+
+ return temp;
+}
+
+
+#
+# dump()
+#
+
+sub dump(str cells, int g)
+{
+ foo = Curses::move(0, 0);
+ foo = Curses::addstr("Generation $g of $G:");
+ foo = Curses::move(1, 0);
+
+ var int row = 0;
+ while (row < HEIGHT) {
+ var int col = 0;
+ while (col < WIDTH) {
+ var int current;
+ current = at(cells, row, col);
+
+ if (current == 1) {
+ Curses::addstr("*");
+ }
+ else {
+ Curses::addstr(" ");
+ }
+ col++;
+ }
+ Curses::addstr("\n");
+ row++;
+ }
+
+ foo = Curses::move(0, 25);
+ foo = Curses::refresh();
+}
+
+#
+# Main program:
+#
+
+var str cells = "";
+
+cells ~= r00;
+cells ~= r01;
+cells ~= r02;
+cells ~= r03;
+cells ~= r04;
+cells ~= r05;
+cells ~= r06;
+cells ~= r07;
+cells ~= r08;
+cells ~= r09;
+cells ~= r10;
+cells ~= r11;
+cells ~= r12;
+cells ~= r13;
+cells ~= r14;
+
+var int len;
+len = string::length(cells);
+
+if (len != ARRAY_SIZE) {
+ sys::print("ERROR! Cell array size is $len instead of $ARRAY_SIZE!\n");
+ sys::exit(1);
+}
+
+foo = Curses::initscr();
+foo = Curses::curs_set(0);
+
+dump(cells, 0);
+
+var int g = 0; # Number of generations so far.
+
+while (g <= G) {
+ cells = generate(cells);
+ dump(cells, g);
+ g++;
+}
+
+foo = Curses::move(16, 0);
+foo = Curses::addstr("(Press any key to exit)");
+foo = Curses::refresh();
+
+foo = Curses::getch();
+
+foo = Curses::curs_set(1);
+foo = Curses::endwin();
+
Added: jako/trunk/examples/mandelbrot.jako
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/examples/mandelbrot.jako Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,120 @@
+#
+# mandelbrot.jako
+#
+# Print the Mandlebrot set.
+#
+# Translated from Parrot assembler to Jako by Gregor Purdy <gregor at focusresearch.com>.
+# Translated from C to Parrot assembler by Leon Brocard <acme at astray.com>.
+# Original C version by Glenn Rhodes.
+#
+# The C code is:
+#
+# main(){
+# int x, y, k;
+# char *b = " .:,;!/>)|&IH%*#";
+# float r, i, z, Z, t, c, C;
+#
+# for (y=30; puts(""), C = y*0.1 - 1.5, y--;){
+# for (x=0; c = x*0.04 - 2, z=0, Z=0, x++ < 75;){
+# for (r=c, i=C, k=0; t = z*z - Z*Z + r, Z = 2*z*Z + i, z=t, k<112; k++)
+# if (z*z + Z*Z > 10) break;
+# printf ("%c", b[k%16]);
+# }
+# }
+# }
+#
+# Copyright (C) 2001-2005, Parrot Foundation.
+# This program is free software. It is subject to the same
+# license as the Parrot interpreter.
+#
+
+use sys;
+use string;
+
+var str b = " .:,;!/>)|&IH%*#";
+
+var int x, y, k;
+var num r, i, z, Z, t, c, C;
+
+y = 30;
+
+YREDO:
+
+goto END if (y == 0);
+
+C = y;
+C *= 0.1;
+C -= 1.5;
+
+y--;
+x = 0;
+
+XREDO:
+
+goto YLOOP if (x == 75);
+
+c = x;
+c *= 0.04;
+c -= 2.0;
+
+z = 0.0;
+Z = 0.0;
+x++;
+
+r = c;
+i = C;
+k = 0;
+
+KREDO:
+
+goto PRINT if (k == 112);
+
+var num temp_8;
+var num temp_9;
+
+temp_8 = z * z;
+temp_9 = Z * Z;
+t = temp_8 - temp_9;
+t += r;
+
+Z *= 2.0;
+Z *= z;
+Z += i;
+
+z = t;
+
+temp_8 = z * z;
+temp_9 = Z * Z;
+temp_8 += temp_9;
+
+goto PRINT if (temp_8 > 10.0);
+
+KLOOP:
+
+k++;
+goto KREDO;
+
+PRINT:
+
+var int temp_int_4;
+var int temp_int_5;
+
+temp_int_4 = k % 16;
+temp_int_5 = 1;
+
+var str ch;
+
+ch = string::substr(b, temp_int_4, temp_int_5);
+sys::print(ch);
+
+XLOOP:
+
+goto XREDO;
+
+YLOOP:
+
+sys::print("\n");
+goto YREDO;
+
+END:
+
Added: jako/trunk/examples/mandelzoom.jako
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/examples/mandelzoom.jako Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,194 @@
+#
+# mandelzoom.jako
+#
+# Print the Mandlebrot set.
+#
+# Translated from Parrot assembler to Jako by Gregor Purdy <gregor at focusresearch.com>.
+# Translated from C to Parrot assembler by Leon Brocard <acme at astray.com>.
+# Original C version by Glenn Rhodes.
+#
+# The C code is:
+#
+# main(){
+# int x, y, k;
+# char *b = " .:,;!/>)|&IH%*#";
+# float r, i, z, Z, t, c, C;
+#
+# for (y=30; puts(""), C = y*0.1 - 1.5, y--;){
+# for (x=0; c = x*0.04 - 2, z=0, Z=0, x++ < 75;){
+# for (r=c, i=C, k=0; t = z*z - Z*Z + r, Z = 2*z*Z + i, z=t, k<112; k++)
+# if (z*z + Z*Z > 10) break;
+# printf ("%c", b[k%16]);
+# }
+# }
+# }
+#
+# Copyright (C) 2001-2005, Parrot Foundation.
+# This program is free software. It is subject to the same
+# license as the Parrot interpreter.
+#
+
+use sys;
+use string;
+
+const str CHARS = " .:,;!/>)|&IH%*#";
+const int DEPTH = 112;
+const str CLS = "\033[H\033[2J\0";
+
+
+#
+# print_mandel()
+#
+# width - Width in 'pixels'
+# height - Height in 'pixels'
+# cx - Center X coordinate
+# cy - Center Y coordinate
+# sx - Scale in X direction
+# sy - Scale in Y direction
+#
+
+sub print_mandel(int width, int height, num cx, num cy, num sx, num sy) {
+ var num x, y;
+ var int k;
+ var num r, i, z, Z, t;
+
+ var num width2;
+ var num height2;
+
+ width2 = width;
+ height2 = height;
+
+ #
+ # Calculate the image boundaries:
+ #
+
+ var num hx;
+ var num min_x;
+ var num max_x;
+ var num inc_x;
+
+ hx = sx / 2.0;
+ min_x = cx - hx;
+ max_x = cx + hx;
+ inc_x = sx / width2;
+
+ var num hy;
+ var num min_y;
+ var num max_y;
+ var num inc_y;
+
+ hy = sy / 2.0;
+ min_y = cy - hy;
+ max_y = cy + hy;
+ inc_y = sy / height2;
+
+ #
+ # Y Loop:
+ #
+
+ y = max_y;
+
+ while (y > min_y) {
+ x = min_x;
+
+ while (x < max_x) {
+ z = 0.0;
+ Z = 0.0;
+
+ r = x;
+ i = y;
+ k = 0;
+
+ while (k < DEPTH) {
+ var num temp;
+ var num temp2;
+
+ t = z * z;
+ temp = Z * Z;
+ t -= temp;
+ t += r;
+
+ Z *= 2.0;
+ Z *= z;
+ Z += i;
+
+ z = t;
+
+ temp = z * z;
+ temp2 = Z * Z;
+ temp += temp2;
+
+ last if (temp > 10.0);
+ } continue {
+ k++;
+ }
+
+ var int temp_int_4;
+ var int temp_int_5;
+
+ temp_int_4 = k % 16;
+ temp_int_5 = 1;
+
+ var str ch;
+
+ ch = string::substr(CHARS, temp_int_4, temp_int_5);
+ sys::print(ch);
+ } continue {
+ x += inc_x;
+ }
+
+ sys::print("\n");
+ } continue {
+ y -= inc_y;
+ }
+}
+
+
+#
+# MAIN PROGRAM:
+#
+
+const int WIDTH = 75;
+const int HEIGHT = 30;
+
+const int N = 20;
+
+const num cx = 0.12249;
+const num cy = 0.659;
+
+const num start_sx = 2.0;
+const num start_sy = 1.5;
+
+const num RATE = 0.8;
+
+
+#
+# MAIN LOOP:
+#
+
+
+var num sx, sy;
+sx = start_sx;
+sy = start_sy;
+
+var int i = 1;
+while (i <= N) {
+ sys::print(CLS);
+
+ sys::print("ITER: $i of $N\n");
+ sys::print("WIDTH: $WIDTH\n");
+ sys::print("HEIGHT: $HEIGHT\n");
+ sys::print("cx: $cx\n");
+ sys::print("cy: $cy\n");
+ sys::print("sx: $sx\n");
+ sys::print("sy: $sy\n");
+ sys::print("\n");
+
+ print_mandel(WIDTH, HEIGHT, cx, cy, sx, sy);
+
+ sx *= RATE;
+ sy *= RATE;
+ i++;
+# sys::sleep(1);
+}
+
Added: jako/trunk/examples/mops.jako
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/examples/mops.jako Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,49 @@
+#
+# mops.jako
+#
+# Copyright (C) 2001-2005, Parrot Foundation.
+# This program is free software. It is subject to the same
+# license as the Parrot interpreter.
+#
+# $Id$
+#
+
+use sys;
+
+const int num_iter = 10000000;
+const int loop_increment = 1;
+const int ops_per_iter = 3;
+
+sub calc_mops() {
+ var num start_time;
+ var num end_time;
+ var num elapsed_time;
+ var int num_ops;
+ var num ops_per_sec;
+ var num mops;
+
+ var int loop_counter = 0;
+
+ start_time = sys::timen();
+ while (loop_counter != num_iter) {
+ loop_counter += loop_increment;
+ }
+ end_time = sys::timen();
+
+ elapsed_time = end_time - start_time;
+ num_ops = num_iter * ops_per_iter;
+ ops_per_sec = num_ops / elapsed_time;
+ mops = ops_per_sec / 1000000.0;
+
+ sys::print("Iterations: $num_iter\n");
+ sys::print("Start time: $start_time\n");
+ sys::print("End time: $end_time\n");
+ sys::print("Elapsed time: $elapsed_time\n");
+ sys::print("Count: $loop_counter\n");
+ sys::print("Estimated ops: $num_ops\n");
+ sys::print("op/s: $ops_per_sec\n");
+ sys::print("Mop/s: $mops\n");
+}
+
+calc_mops();
+
Added: jako/trunk/examples/nci.jako
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/examples/nci.jako Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,39 @@
+#
+# nci.jako
+#
+# Test out the Jako wrapping of Parrot's Native Call Interface
+# facility.
+#
+# Copyright (C) 2003-2005, Parrot Foundation.
+# This program is free software. Its use is subject to the same
+# license as Parrot.
+#
+
+use Curses;
+
+var int foo; # Store result from above functions here.
+
+var int screen;
+
+screen = Curses::initscr();
+
+foo = Curses::curs_set(0);
+foo = Curses::box(screen, 42, 42);
+foo = Curses::move(10, 20);
+foo = Curses::addstr("Hello, world!");
+foo = Curses::move(12, 15);
+foo = Curses::addstr("(Press any key to exit)");
+
+foo = Curses::move(8, 10);
+foo = Curses::hline(42, 33);
+
+foo = Curses::move(14, 10);
+foo = Curses::hline(42, 33);
+
+foo = Curses::refresh();
+
+foo = Curses::getch();
+
+foo = Curses::curs_set(1);
+foo = Curses::endwin();
+
Added: jako/trunk/examples/pmc.jako
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/examples/pmc.jako Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,10 @@
+# $Id$
+
+use sys;
+
+var pmc foo, bar;
+bar = new Undef;
+foo = new String;
+foo = "Hello, world!\n";
+sys::print(foo);
+
Added: jako/trunk/examples/primes.jako
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/examples/primes.jako Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,46 @@
+#
+# primes.jako
+#
+# A simple program to print out the primes up to 100.
+#
+# Based on a Parrot assembly example by Leon Brocard <acme at astray.com>
+#
+# Copyright (C) 2001-2005, Parrot Foundation.
+# This program is free software. It is subject to the same
+# license as the Parrot interpreter.
+#
+# $Id$
+#
+
+use sys;
+
+const int n = 100;
+
+var int i = 2;
+
+sys::print("Algorithm P (Naiive primality test)\n");
+sys::print(" Printing primes up to $n...\n");
+
+NUMBER: while (i <= n) {
+ var int m;
+ var int j = 2;
+
+ m = i / 2;
+
+ FACTOR: while (j <= m) {
+ var int x;
+
+ x = i % j;
+
+ next NUMBER if (x == 0);
+
+ j++;
+ }
+
+ sys::print("$i ");
+} continue {
+ i++;
+}
+
+sys::print("\n");
+
Added: jako/trunk/examples/python.jako
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/examples/python.jako Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,40 @@
+#
+# python.jako
+#
+# A python lexer written in Jako.
+#
+# TODO: Doesn't do much yet. Sure would be nice if it did...
+#
+# Copyright (C) 2001-2005, Parrot Foundation.
+# This program is free software. Its use is subject to the
+# same license as Parrot.
+#
+
+use sys;
+use string;
+
+sub split (str pat, str input)
+{
+ var int pos = 0;
+ var int found = 0;
+ var int pat_len;
+
+ pat_len = string::length(pat);
+
+ while (1 == 1) {
+ var str temp;
+ var int match_len;
+
+ found = string::index(input, pat, pos);
+ last unless (found >= 0);
+ match_len = found - pos;
+ temp = string::substr(input, pos, match_len);
+ sys::print("MATCH: '$temp'\n");
+ pos = found + pat_len;
+ }
+}
+
+var str input = "if 1:\n print 'Hello, world!\n";
+
+split("\n", input);
+
Added: jako/trunk/examples/queens.jako
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/examples/queens.jako Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,357 @@
+#
+# queens.jako
+#
+# A program to find solutions to the 8-queens problem.
+#
+# Copyright (C) 2001-2005, Parrot Foundation.
+# This program is free software. It is subject to the same
+# license as the Parrot interpreter.
+#
+# $Id$
+#
+
+use sys;
+use string;
+
+const int NUM_FILES = 8;
+const int NUM_RANKS = 8;
+
+
+#
+# remove_queen()
+#
+
+sub str remove_queen (str board, int rank, int file)
+{
+
+ var int i;
+ i = rank * NUM_FILES;
+ i += file;
+
+ var int x;
+ x = i;
+
+ var int y;
+ y = i + 1;
+
+ var int z;
+ z = string::length(board);
+ z = z - y;
+
+ var str prefix;
+ prefix = string::substr(board, 0, x);
+ var str suffix;
+ suffix = string::substr(board, y, z);
+
+ var str temp;
+ temp = prefix;
+ temp = string::concat(temp, " ");
+ temp = string::concat(temp, suffix);
+
+ return temp;
+}
+
+
+#
+# clear_file()
+#
+# Clears the queen from the current file. Makes no assumption about current
+# nybble contents.
+#
+
+sub str clear_file (str board, int file)
+{
+ var int rank = 0;
+
+ while (rank < NUM_RANKS) {
+ board = remove_queen(board, rank, file);
+ rank++;
+ }
+
+ return board;
+}
+
+
+#
+# place_queen()
+#
+# Places a queen at the given rank and file, removing any other queen from the
+# file.
+#
+
+sub str place_queen (str board, int rank, int file)
+{
+ board = clear_file(board, file);
+
+ var int i;
+ i = rank * NUM_FILES;
+ i += file;
+
+ var int x;
+ x = i;
+
+ var int y;
+ y = i + 1;
+
+ var int z;
+ z = string::length(board);
+ z = z - y;
+
+ var str prefix;
+ prefix = string::substr(board, 0, x);
+ var str suffix;
+ suffix = string::substr(board, y, z);
+
+ var str temp;
+ temp = prefix;
+ temp = string::concat(temp, "Q");
+ temp = string::concat(temp, suffix);
+
+ return temp;
+}
+
+
+#
+# queen_rank()
+#
+# Fetches the queen's rank.
+#
+# Input: file
+# Ouptut: rank = queen's rank in that file
+#
+
+sub int queen_rank (str board, int file)
+{
+ var int rank = 0;
+
+ while (rank < NUM_RANKS) {
+ var int temp;
+ temp = queen_at(board, rank, file);
+ return rank if (temp == 1);
+ rank++;
+ }
+
+ return -1;
+}
+
+
+#
+# at()
+#
+# Determines whether or not there is a queen at a given location.
+#
+# Input: rank, file
+# Output: 1 (queen) or 0 (empty)
+#
+
+sub str at (str board, int rank, int file) {
+ var str temp;
+
+# print("Fetching contents of square at $rank, $file...\n");
+
+ return 0 if (rank < 0);
+ return 0 if (rank >= NUM_RANKS);
+ return 0 if (file < 0);
+ return 0 if (file >= NUM_FILES);
+
+ var int i;
+ i = rank * NUM_FILES;
+ i += file;
+
+ var int l;
+ l = string::length(board);
+
+# print("Board is $l characters long. Fetching character at index $i.\n");
+
+ temp = string::substr(board, i, 1);
+
+ return temp;
+}
+
+
+#
+# queen_at()
+#
+# Determines whether or not there is a queen at a given location.
+#
+# Input: rank, file
+# Output: 1 (queen) or 0 (empty)
+#
+
+sub int queen_at (str board, int rank, int file) {
+ var str temp;
+
+# print("Looking for queen at $rank, $file...\n");
+
+ temp = at(board, rank, file);
+
+ return 1 if (temp == "Q");
+ return 0;
+}
+
+
+#
+# free_space()
+#
+# Determines whether or not a space is free for placing a queen.
+#
+
+sub int free_space (str board, int rank, int file) {
+ var int i = 1;
+
+ while (i <= file) {
+ var int temp_file;
+ var int temp_rank;
+ var int result;
+
+ temp_file = file - i;
+
+ temp_rank = rank;
+ result = queen_at(board, temp_rank, temp_file);
+ return 0 if (result == 1);
+
+ temp_rank = rank + i;
+ result = queen_at(board, temp_rank, temp_file);
+ return 0 if (result == 1);
+
+ temp_rank = rank - i;
+ result = queen_at(board, temp_rank, temp_file);
+ return 0 if (result == 1);
+
+ i++;
+ }
+
+ return 1;
+}
+
+
+#
+# print_board()
+#
+
+sub print_board (str board) {
+ var int rank, file;
+ var int temp;
+
+ rank = 7;
+
+ sys::print(" +---+---+---+---+---+---+---+---+\n");
+
+ while(rank >= 0) {
+ temp = rank + 1;
+
+ sys::print("$temp |");
+
+ file = 0;
+ while(file < 8) {
+ var int result;
+
+ result = queen_at(board, rank, file);
+
+ if (result == 1) {
+ sys::print(" Q |");
+ } else {
+ temp = rank + file;
+ temp %= 2;
+
+ if (temp == 1) {
+ sys::print(" |");
+ } else {
+ sys::print(" * |");
+ }
+ }
+ file++;
+ }
+
+ sys::print("\n");
+ sys::print(" +---+---+---+---+---+---+---+---+\n");
+ rank--;
+ }
+
+ sys::print(" A B C D E F G H \n");
+}
+
+
+#
+# new_board()
+#
+
+sub str new_board()
+{
+ var str board = "";
+ var int rank = 0;
+ var int file = 0;
+
+ sys::print("Making new board with $NUM_RANKS ranks and $NUM_FILES files...\n");
+
+ while (rank < NUM_RANKS) {
+ file = 0;
+ while (file < NUM_FILES) {
+ board = string::concat(board, " ");
+ file++;
+ }
+ rank++;
+ }
+
+ var int l;
+ l = string::length(board);
+ sys::print("Board length is $l.\n");
+
+ return board;
+}
+
+
+#
+# main()
+#
+
+sub main() {
+ var str board;
+ var int rank;
+ var int file;
+
+ board = new_board();
+
+ #
+ # Scan over the files, placing queens:
+ #
+
+ file = 0;
+ rank = 0;
+
+ while (file < NUM_FILES) {
+ while (rank < NUM_RANKS) {
+ var int result;
+ result = free_space(board, rank, file);
+ last if (result == 1);
+ rank++;
+ }
+
+ if (rank == NUM_RANKS) {
+ file--;
+ rank = queen_rank(board, file);
+ board = clear_file(board, file);
+ rank++;
+ } else {
+ board = place_queen(board, rank, file);
+ file++;
+ rank = 0;
+ }
+
+ last if (file < 0);
+ }
+
+ #
+ # Print the result:
+ #
+
+ print_board(board);
+}
+
+
+#
+# MAIN PROGRAM:
+#
+
+main();
+
Added: jako/trunk/examples/queens_array.jako
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/examples/queens_array.jako Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,161 @@
+#
+# queens.jako
+#
+# A program to find solutions to the 8-queens problem.
+#
+# Copyright (C) 2001-2006, Parrot Foundation.
+# This program is free software. It is subject to the same
+# license as the Parrot interpreter.
+#
+# $Id$
+#
+
+use sys;
+
+const int NO_QUEEN = -1;
+
+const int NUM_FILES = 8;
+const int NUM_RANKS = 8;
+
+var pmc board;
+board = new Array;
+
+
+#
+# free_space()
+#
+# Determines whether or not the current space is free for placing a queen.
+#
+
+sub int free_space (int board, int rank, int file) {
+ var int i = 1;
+
+ while (i <= file) {
+ var int temp_file;
+ var int temp_rank;
+
+ temp_file = file - i;
+
+ temp_rank = rank;
+ return 0 if (board[temp_file] == temp_rank);
+
+ temp_rank = rank + i;
+ return 0 if (board[temp_file] == temp_rank);
+
+ temp_rank = rank - i;
+ return 0 if (board[temp_file] == temp_rank);
+
+ i++;
+ }
+
+ return 1;
+}
+
+
+#
+# print_board()
+#
+
+sub print_board (int board) {
+ var int rank, file;
+ var int temp;
+
+ rank = 7;
+
+ sys::print(" +---+---+---+---+---+---+---+---+\n");
+
+ while(rank >= 0) {
+ temp = rank + 1;
+ file = 0;
+
+ sys::print("$temp |");
+
+ while(file < 8) {
+ if (board[file] == rank) {
+ sys::print(" Q |");
+ } else {
+ temp = rank + file;
+ temp %= 2;
+
+ if (temp == 1) {
+ sys::print(" |");
+ } else {
+ sys::print(" * |");
+ }
+ }
+ file++;
+ }
+
+ sys::print("\n");
+ sys::print(" +---+---+---+---+---+---+---+---+\n");
+ rank--;
+ }
+
+ sys::print(" A B C D E F G H \n");
+}
+
+
+#
+# main()
+#
+
+sub main() {
+ var int board;
+ var int rank;
+ var int file;
+
+ #
+ # Clear the files:
+ #
+
+ file = 0;
+
+ while(file < NUM_FILES) {
+ board[file] = NO_QUEEN;
+ file++;
+ }
+
+ #
+ # Scan over the files, placing queens:
+ #
+
+ file = 0;
+ rank = 0;
+
+ while (file < NUM_FILES) {
+ while (rank < NUM_RANKS) {
+ var int result;
+ result = free_space(board, rank, file);
+ last if (result == 1);
+ rank++;
+ }
+
+ if (rank == NUM_RANKS) {
+ file--;
+ rank = board[file];
+ board[file] = NO_QUEEN;
+ rank++
+ } else {
+ board[file] = rank;
+ file++;
+ rank = 0;
+ }
+
+ last if (file < 0);
+ }
+
+ #
+ # Print the result:
+ #
+
+ print_board(board);
+}
+
+
+#
+# MAIN PROGRAM:
+#
+
+main();
+end;
+
Added: jako/trunk/examples/sub.jako
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/examples/sub.jako Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,42 @@
+#
+# sub.jako
+#
+# A program to demonstrate macros and poor-man's subroutine
+# calls.
+#
+# Copyright (C) 2001-2005, Parrot Foundation.
+# This program is free software. It is subject to the same
+# license as the Parrot interpreter.
+#
+# $Id$
+#
+
+use sys;
+
+const int X = 42; # These test integer global constants
+const int Y = 137;
+
+const num A = 3.14; # These test the non-integer global constant types
+const str B = "Howdy!";
+
+var int x; # These test integer global variables
+var int y;
+
+var num a; # These test the non-integer global variable types
+var str b;
+
+x = X;
+y = Y;
+
+a = A;
+b = B;
+
+sub printit (int x, int y) {
+ sys::print("x = $x; y = $y\n");
+}
+
+printit(x, y);
+
+x = 1234;
+printit(x, y);
+
Added: jako/trunk/io.jako
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/io.jako Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,31 @@
+#
+# io.jako
+#
+# Input/Output ops.
+#
+# Copyright (C) 2003-2005, Parrot Foundation.
+# This program is free software. Its use is subject to the same
+# license as Parrot.
+#
+# $Id$
+#
+
+module io
+{
+ sub pmc open :op (str name, str mode);
+ sub pmc fdopen :op (int fd, str mode);
+ sub close :op (pmc io);
+
+ sub print :op (pmc io, str s);
+ sub printerr :op (str s);
+ sub puts :op (str s);
+ sub puts :op (int i);
+ sub puts :op (num n);
+
+ sub str read :op (int l);
+ sub str read :op (pmc io, int l);
+
+ sub int seek :op (pmc io, int offset, int whence);
+ sub int seek :op (pmc io, int high, int low, int whence);
+}
+
Added: jako/trunk/jako
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/jako Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,2 @@
+#!/bin/sh
+perl -I lib jakoc $@ | ../../parrot -
Added: jako/trunk/jakoc
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/jakoc Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,97 @@
+#! perl -w
+#
+# jakoc - compile a Jako source file Parrot assembly file.
+#
+# by Gregor N. Purdy <gregor at focusresearch.com>
+#
+# Copyright (C) 2001-2005, Parrot Foundation.
+# This program is free software. It is subject to the same license
+# as Perl itself.
+#
+# $Id$
+#
+
+use strict;
+
+# perl5.005 complains:
+# Can't locate object method "block" via package
+# "Jako::Construct::Block::File" at lib/Jako/Construct/Block.pm line 243.
+
+use Carp;
+use Data::Dumper;
+
+$Data::Dumper::Terse = 1;
+$Data::Dumper::Indent = 1;
+$Data::Dumper::Quotekeys = 0;
+
+use Jako::Lexer;
+use Jako::Parser;
+use Jako::Compiler;
+
+use FileHandle;
+
+my $lexer = Jako::Lexer->new;
+my $parser = Jako::Parser->new;
+my $compiler = Jako::Compiler->new;
+
+$lexer->debug(1);
+$parser->debug(1);
+$compiler->debug(1);
+
+use Getopt::Std;
+
+my %opts;
+getopts('ctTx', \%opts);
+
+die "$0: usage: $0 <source>\n" unless @ARGV == 1;
+$compiler->file(shift @ARGV);
+
+#
+# Tokenize the input, and possibly dump the tokens.
+#
+
+$lexer->scan_file($compiler->file);
+
+if ($opts{t}) {
+ $lexer->dump;
+ exit 0;
+}
+
+$parser->tokens($lexer->tokens);
+my $root = $parser->parse();
+
+if ($opts{T}) {
+ print Dumper $root;
+ exit 0;
+}
+
+if ($opts{x}) { # -x means "XML"
+ eval "use XML::Handler::YAWriter";
+ die "Could not find XML::Handler::YAWriter!" if $@;
+ my $handler = XML::Handler::YAWriter->new(
+ Output => IO::File->new('>-'),
+ Pretty => {
+ PrettyWhiteIndent => 1,
+ PrettyWhiteNewline => 1,
+ CatchEmptyElement => 1,
+ CompactAttrIndent => 1
+ }
+ );
+
+ $handler->start_document;
+ $root->sax($handler);
+ $handler->end_document;
+}
+elsif ($opts{c}) { # -c means "Check", like with Perl.
+ # DO NOTHING
+}
+else {
+ my $fh = FileHandle->new('>-');
+ $compiler->compile($root, $fh);
+}
+
+exit 0;
+
+#
+# End of file.
+#
Added: jako/trunk/lib/Jako/Compiler.pm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/lib/Jako/Compiler.pm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,164 @@
+#
+# Compiler.pm
+#
+# Copyright (C) 2002-2005, Parrot Foundation.
+# This program is free software. It is subject to the same license
+# as the Parrot interpreter.
+#
+# $Id$
+#
+
+use strict;
+use warnings;
+
+package Jako::Compiler;
+
+use Carp;
+use FileHandle;
+
+use base qw(Jako::Processor);
+
+#
+# block_label()
+#
+
+sub block_label {
+ my $self = shift;
+ my ($kind) = @_;
+
+ return sprintf( "_%s_%d", uc $kind, ++$self->{BLOCK_COUNT} );
+}
+
+#
+# temp_reg()
+#
+
+sub temp_reg {
+ my $self = shift;
+ my ($type) = @_;
+
+ $type = shift->code if ref $type;
+
+ return '$' . $type . $self->{REG_COUNT}{$type}++;
+}
+
+sub temp_int { return shift->temp_reg('I'); }
+sub temp_num { return shift->temp_reg('N'); }
+sub temp_pmc { return shift->temp_reg('P'); }
+sub temp_str { return shift->temp_reg('S'); }
+
+#
+# anon_lbl()
+#
+
+my $anon_lbl_count = 0;
+
+sub anon_lbl {
+ my $self = shift;
+ return '_ANON_LABEL_' . ++$self->{ANON_LBL_COUNT};
+}
+
+#
+# invert_relop()
+#
+
+my %inverted_ops = (
+ '==' => '!=',
+ '!=' => '==',
+ '<=' => '>',
+ '<' => '>=',
+ '>=' => '<',
+ '>' => '<='
+);
+
+sub invert_relop {
+ my $self = shift;
+ my $op = shift;
+
+ confess "Undefined op!" unless defined $op;
+
+ my $new_op = $inverted_ops{$op};
+
+ confess "Unrecognized op '$op'!" unless defined $new_op;
+
+ return $new_op;
+}
+
+#
+# new()
+#
+
+sub new {
+ my $class = shift;
+
+ return bless {
+ FILE => undef,
+ LINE => undef,
+ LABELS => [],
+ COMMENTS => [],
+ LAST_OP => 'noop',
+ INDENT => 0,
+ REG_COUNT => { 'I' => 0, 'N' => 0, 'P' => 0, 'S' => 0 },
+ ANON_LBL_COUNT => 0,
+ BLOCK_COUNT => 0
+ }, $class;
+}
+
+#
+# indent()
+#
+
+sub indent {
+ my $self = shift;
+ $self->{INDENT} += 4;
+}
+
+#
+# outdent()
+#
+
+sub outdent {
+ my $self = shift;
+ $self->{INDENT} -= 4;
+
+ confess "Unbalanced indent/outdent!" if $self->{INDENT} < 0;
+}
+
+#
+# emit()
+#
+
+sub emit {
+ my $self = shift;
+
+ unshift( @_, " " x $self->{INDENT} );
+
+ my $fh = $self->{FH};
+
+ print $fh @_, "\n";
+}
+
+#
+# compile()
+#
+
+sub compile {
+ my $self = shift;
+
+ my ( $root, $fh ) = @_;
+
+ $fh = FileHandle->new(">-") unless defined $fh;
+
+ $self->{FH} = $fh;
+
+ $root->compile($self);
+}
+
+1;
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: jako/trunk/lib/Jako/Construct.pm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/lib/Jako/Construct.pm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,30 @@
+#
+# Construct.pm
+#
+# Abstract base class for parsed constructs (blocks, etc.).
+#
+# Copyright (C) 2002-2005, Parrot Foundation.
+# This program is free software. It is subject to the same license
+# as the Parrot interpreter.
+#
+# $Id$
+#
+
+use strict;
+use warnings;
+
+package Jako::Construct;
+
+use base qw(Jako::Processor);
+
+sub block { return shift->{BLOCK}; }
+
+1;
+
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: jako/trunk/lib/Jako/Construct/Block.pm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/lib/Jako/Construct/Block.pm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,452 @@
+
+=head1 NAME
+
+Jako::Construct::Block - Abstract superclass for Jako Blocks.
+
+=head1 SYNOPSIS
+
+TODO
+
+=head1 DESCRIPTION
+
+A subclass of Jako::Construct.
+
+Maintains a symbol table, a reference to its parent block, and a list of
+content Constructs.
+
+=cut
+
+###############################################################################
+
+use strict;
+use warnings qw(all);
+
+package Jako::Construct::Block;
+
+use base qw(Jako::Construct);
+
+use Carp;
+
+###############################################################################
+
+=head2 CLASS->new(BLOCK, KIND, TYPE, PREFIX)
+
+If BLOCK is defined, it is the new Block's parent.
+
+The KIND tells what kind of block we are dealing with (sub, while, bare, etc.).
+
+The TYPE tells the return type of the block.
+
+The PREFIX tells the prefix that will be used for block-related labels. For
+example, B<while> loops have labels related to the loop control statements,
+and these are kept distinct by applying the prefix to the labels. Of course,
+the prefix could come explicitly from the source code if the loop was labeled.
+
+TODO: Do we really need KIND, since we have subclasses?
+
+=cut
+
+sub new {
+ my $class = shift; # Required: string
+ my $block = shift; # Optional: Jako::Construct::Block
+ my $kind = shift; # Required: string (TODO: domain?)
+ my $type = shift; # Optional: TODO: type?
+ my $prefix = shift; # Optional: string
+
+ confess "Use Jako::Construct::Block::Bare, not Jako::Construct::Block"
+ if $class eq 'Jako::Construct::Block';
+
+ confess "Bad block!"
+ if defined $block and not( ref $block and $block->isa("Jako::Construct::Block") );
+ confess "Extra arguments!" if @_;
+
+ return bless {
+ BLOCK => $block, # Parent block
+
+ PEER => undef, # Peer block (if any).
+ KIND => $kind, # One of file, sub, if, else, while, etc.
+ TYPE => $type, # Return type, if any.
+ PREFIX => $prefix, # Prefix, if given in source code.
+ SYMBOLS => {}, # Identifiers
+ CONTENT => [] # Constructs
+ }, $class;
+}
+
+###############################################################################
+
+#
+# ACCESSORS:
+#
+
+sub peer { return shift->{PEER}; }
+sub kind { return shift->{KIND}; }
+sub type { return shift->{TYPE}; }
+
+sub left { return shift->{LEFT}; }
+sub op { return shift->{OP}; }
+sub right { return shift->{RIGHT}; }
+
+sub prefix {
+ my $self = shift;
+ $self->{PREFIX} = shift if @_;
+ return $self->{PREFIX};
+}
+
+###############################################################################
+
+=head2 BLOCK->set_symbol(NAME, VALUE)
+
+Set a symbol in this block's symbol table. If the symbol already exists,
+we throw an error.
+
+TODO: We should generate real compiler errors and warnings instead of using
+confess() and warn().
+
+=cut
+
+sub set_symbol {
+ my $self = shift; # Required: Jako::Construct::Block
+ my $name = shift; # Required: string (TODO: domain)
+ my $sym = shift; # Required: TODO: type
+
+ confess "No symbol name!" unless defined $name;
+ confess "No symbol value!" unless defined $sym;
+ confess "Bad symbol value!" unless ref $sym and $sym->isa("Jako::Symbol");
+ confess "Extra arguments!" if @_;
+
+ die "Redefinition of symbol '$name', which was defined earlier in this block!"
+ if $self->get_symbol($name);
+
+# warn "Definition of symbol '$name' shadows definition in parent block!" if $self->find_symbol($name);
+
+ $self->{SYMBOLS}{$name} = $sym;
+}
+
+###############################################################################
+
+=head2 BLOCK->get_symbol(NAME)
+
+Attempt to get a symbol from this block's symbol table only. If there is no
+locally defined symbol with that name, then we return undef.
+
+See also: find_symbol(), which will also search (recursively) parent blocks'
+symbol tables.
+
+TODO: We should generate real compiler errors and warnings instead of using
+die() and warn().
+
+=cut
+
+sub get_symbol {
+ my $self = shift; # Required: Jako::Construct::Block
+ my $name = shift; # Required: string (TODO: domain)
+
+ confess "No block!" unless defined $self and ref $self and $self->isa("Jako::Construct::Block");
+ confess "No symbol name!" unless defined $name;
+ confess "Extra arguments!" if @_;
+
+ return $self->{SYMBOLS}{$name};
+}
+
+###############################################################################
+
+=head2 BLOCK->symbol_names()
+
+Returns the names of the symbols defined locally in this block.
+
+=cut
+
+sub symbol_names {
+ my $self = shift; # Required: Jako::Construct::Block
+
+ confess "No block!" unless defined $self and ref $self and $self->isa("Jako::Construct::Block");
+ confess "Extra arguments!" if @_;
+
+ return keys %{ $self->{SYMBOLS} };
+}
+
+###############################################################################
+
+=head2 BLOCK->dump_symbols()
+
+FOR DEBUGGING ONLY.
+
+Dumps the complete list of symbols visible from this block, including those
+from the symbol tables of parent blocks.
+
+=cut
+
+sub dump_symbols {
+ my $self = shift; # Required: Jako::Construct::Block
+
+ confess "No block!" unless defined $self and ref $self and $self->isa("Jako::Construct::Block");
+ confess "Extra arguments!" if @_;
+
+ my $block = $self; # Start collecting symbols here
+
+ my %table = ();
+
+ my $level = 0;
+
+ while ($block) {
+ foreach my $symbol ( $block->symbol_names ) {
+ next if exists $table{$symbol};
+ $table{$symbol} = $level;
+ }
+
+ $block = $block->block; # Collect symbols from the parent block next
+ $level++;
+ }
+
+ printf STDERR "%-30s %s\n", "SYMBOL", "LEVEL";
+ printf STDERR "%-30s %s\n", ( "-" x 30 ), "-----";
+
+ foreach my $symbol ( sort keys %table ) {
+ printf STDERR "%-30s: %d\n", $symbol, $table{$symbol};
+ }
+}
+
+###############################################################################
+
+=head2 BLOCK->find_symbol(NAME)
+
+Search for a symbol, starting with this block, but also checking parent
+blocks recursively until a matching symbol is found or the root block is
+encountered without a match (in which case we return undef).
+
+See also: get_symbol(), which searches only locally.
+
+=cut
+
+sub find_symbol {
+ my $self = shift; # Required: Jako::Construct::Block
+ my $name = shift; # Required: (TODO: domain)
+
+ confess "No block!" unless defined $self and ref $self and $self->isa("Jako::Construct::Block");
+ confess "No symbol name!" unless defined $name;
+ confess "Extra arguments!" if @_;
+
+ my $sym = $self->get_symbol($name); # Return the identifier if defined here.
+ return $sym if defined $sym;
+
+ return undef unless defined $self->block; # Terminate recursion
+
+ return $self->block->find_symbol($name); # Recurse
+}
+
+###############################################################################
+
+=head2 BLOCK->find_block(KIND [, LABEL])
+
+Search this block and recursively through parent Blocks for a Block with the
+specified kind (such as a while loop) and label (if given).
+
+This is used to find the target blocks for loop control statements.
+
+=cut
+
+sub find_block {
+ my $self = shift; # Required: Jako::Construct::Block
+ my $kind = shift; # Required: string (TODO: domain)
+ my $label = shift; # Optional: string (TODO: domain)
+
+ confess "No block!" unless defined $self and ref $self and $self->isa("Jako::Construct::Block");
+ confess "No block kind!" unless defined $kind;
+ confess "Extra arguments!" if @_;
+
+ if ( $self->kind eq $kind ) {
+ if ( defined $label ) {
+ return $self if $self->prefix eq $label;
+ }
+ else {
+ return $self;
+ }
+ }
+
+ return undef unless $self->block;
+
+ return $self->block->find_block( $kind, $label );
+}
+
+###############################################################################
+
+=head2 BLOCK->type_of_ident(NAME)
+
+This is a shortcut method that uses find_symbol() to locate a matching
+symbol, and then returns that symbol's type.
+
+=cut
+
+sub type_of_ident {
+ my $self = shift; # Required: Jako::Construct::Block
+ my $name = shift; # Required: string (TODO: domain)
+
+ confess "No block!" unless defined $self and ref $self and $self->isa("Jako::Construct::Block");
+ confess "No identifier name!" unless defined $name;
+ confess "Extra arguments!" if @_;
+
+ my $found = $self->find_symbol($name);
+
+ return $found ? $found->type : undef;
+}
+
+###############################################################################
+
+=head2 BLOCK->kind_of_ident(NAME)
+
+This is a shortcut method that uses find_symbol() to locate a matching
+symbol, and then returns that symbol's kind.
+
+=cut
+
+sub kind_of_ident {
+ my $self = shift; # Required: Jako::Construct::Block
+ my $name = shift; # Required: string (TODO: domain)
+
+ confess "No block!" unless defined $self and ref $self and $self->isa("Jako::Construct::Block");
+ confess "No identifier name!" unless defined $name;
+ confess "Extra arguments!" if @_;
+
+ my $found = $self->find_symbol($name);
+
+ return $found ? $found->kind : undef;
+}
+
+###############################################################################
+
+=head2 BLOCK->scope_of_ident(NAME)
+
+This is a shortcut method that uses find_symbol() to locate a matching
+symbol, and then returns that symbol's scope (global or local).
+
+=cut
+
+sub scope_of_ident {
+ my $self = shift; # Required: Jako::Construct::Block
+ my $name = shift; # Required: string (TODO: domain)
+
+ confess "No block!" unless defined $self and ref $self and $self->isa("Jako::Construct::Block");
+ confess "No identifier name!" unless defined $name;
+ confess "Extra arguments!" if @_;
+
+ my $found = $self->find_symbol($name);
+
+ return $found ? $found->scope : undef;
+}
+
+###############################################################################
+
+=head2 BLOCK->access_of_ident(NAME)
+
+This is a shortcut method that uses find_symbol() to locate a matching
+symbol, and then returns that symbol's access (const or not).
+
+=cut
+
+sub access_of_ident {
+ my $self = shift; # Required: Jako::Construct::Block
+ my $name = shift; # Required: string (TODO: domain)
+
+ confess "No block!" unless defined $self and ref $self and $self->isa("Jako::Construct::Block");
+ confess "No identifier name!" unless defined $name;
+ confess "Extra arguments!" if @_;
+
+ my $found = $self->find_symbol($name);
+
+ return $found ? $found->kind : undef;
+}
+
+###############################################################################
+
+=head2 BLOCK->content()
+
+Return the content list for the Block.
+
+=cut
+
+sub content {
+ my $self = shift; # Required: Jako::Construct::Block
+
+ confess "No block!" unless defined $self and ref $self and $self->isa("Jako::Construct::Block");
+ confess "Extra arguments!" if @_;
+
+ return @{ $self->{CONTENT} };
+}
+
+###############################################################################
+
+=head2 BLOCK->push_content(LIST)
+
+Append Constructs to the Block's content list.
+
+=cut
+
+sub push_content {
+ my $self = shift; # Required: Jako::Construct::Block
+
+ confess "No block!" unless defined $self and ref $self and $self->isa("Jako::Construct::Block");
+ confess "No content!" unless @_;
+ confess "Illegal content!" if grep { not $_->isa("Jako::Construct") } @_;
+
+ push @{ $self->{CONTENT} }, @_;
+}
+
+###############################################################################
+
+=head2 BLOCK->compile(COMPILER, FILTER)
+
+Compile the block's content using COMPILER. If FILTER is provided, only
+those Constructs in the content for which FILTER returns a true value
+will be compiled.
+
+The FILTER feature is used to arrange for two passes over the root block.
+The first pass compiles all subroutine declarations and definitions, while
+the second pass compiles any other content. This is how we collect all the
+non-sub stuff into the main sub at the end of the script's compiled code.
+
+=cut
+
+sub compile {
+ my $self = shift; # Required: Jako::Construct::Block
+ my $compiler = shift; # Required: Jako::Compiler
+ my $options = shift; # Optional: Hashref
+
+ confess "No block!" unless defined $self and ref $self and $self->isa("Jako::Construct::Block");
+ confess "No compiler!"
+ unless defined $compiler
+ and ref $compiler
+ and $compiler->isa("Jako::Compiler");
+ confess "Bad options!" if defined $options and not( ref $options and ref $options eq 'HASH' );
+ confess "Extra arguments!" if @_;
+
+ foreach my $construct ( $self->content ) {
+ $construct->compile( $compiler, $options );
+ }
+}
+
+1;
+
+__END__
+
+###############################################################################
+###############################################################################
+
+=head1 VERSION
+
+$Id$
+
+=head1 AUTHOR
+
+Gregor N. Purdy E<lt>gregor at focusresearch.comE<gt>
+
+=head1 COPYRIGHT
+
+Copyright (C) 2002-2005, Parrot Foundation.
+
+=head1 LICENSE
+
+THIS PROGRAM IS FREE SOFTWARE. ITS USE IS SUBJECT TO THE SAME LICENSE AS
+THE PARROT VIRTUAL MACHINE.
+
+=cut
+
Added: jako/trunk/lib/Jako/Construct/Block/Bare.pm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/lib/Jako/Construct/Block/Bare.pm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,61 @@
+#
+# Bare.pm
+#
+# Copyright (C) 2002-2005, Parrot Foundation.
+# This program is free software. It is subject to the same license
+# as the Parrot interpreter.
+#
+# $Id$
+#
+
+use strict;
+use warnings;
+
+package Jako::Construct::Block::Bare;
+
+use Carp;
+
+use Jako::Compiler;
+
+use base qw(Jako::Construct::Block);
+
+#
+# compile()
+#
+
+sub compile {
+ my $self = shift;
+ my ($compiler) = @_;
+
+ my $namespace = "BARE"; # TODO: Don't we need to do better than this?
+
+ if ( $self->content ) {
+ $compiler->indent;
+ $self->SUPER::compile($compiler);
+ $compiler->outdent;
+ }
+
+ return 1;
+}
+
+#
+# sax()
+#
+
+sub sax {
+ my $self = shift;
+ my ($handler) = @_;
+
+ $handler->start_element( { Name => 'block', Attributes => { kind => $self->kind } } );
+ $_->sax($handler) foreach $self->content;
+ $handler->end_element( { Name => 'block' } );
+}
+
+1;
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: jako/trunk/lib/Jako/Construct/Block/Conditional.pm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/lib/Jako/Construct/Block/Conditional.pm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,135 @@
+#
+# Conditional.pm
+#
+# Copyright (C) 2002-2005, Parrot Foundation.
+# This program is free software. It is subject to the same license
+# as the Parrot interpreter.
+#
+# $Id$
+#
+
+use strict;
+use warnings;
+
+package Jako::Construct::Block::Conditional;
+
+use Carp;
+use Jako::Compiler;
+
+use base qw(Jako::Construct::Block);
+
+#
+# compile()
+#
+
+sub compile {
+ my $self = shift;
+ my ($compiler) = @_;
+
+ my $kind = $self->kind;
+ my $peer = $self->peer;
+
+ my $prefix;
+
+ if ( $self->prefix ) {
+ $prefix = $self->prefix;
+ }
+ else {
+ $prefix = $self->peer ? $peer->prefix : $compiler->block_label($kind);
+ $self->prefix($prefix);
+ }
+
+ my $namespace = $prefix;
+
+ my $left;
+ my $op;
+ my $right;
+
+ if ( $kind eq 'if' or $kind eq 'unless' ) {
+ $left = $self->left->compile($compiler);
+ $op = $self->op;
+ $right = $self->right->compile($compiler);
+ }
+
+ if ( $kind eq 'if' ) {
+ $op =
+ $compiler->invert_relop($op)
+ ; # Invert the test, since we jump *unless* the condition is true
+ }
+ elsif ( $kind eq 'unless' ) {
+ $kind = 'if';
+ }
+
+ if ( $kind eq 'if' ) {
+ $compiler->emit("${prefix}_TEST:");
+ $compiler->emit(" if $left $op $right goto ${prefix}_ELSE");
+ $compiler->emit("${prefix}_THEN:");
+
+ if ( $self->content ) {
+ $compiler->indent;
+ $self->SUPER::compile($compiler);
+ $compiler->outdent;
+ }
+
+ $compiler->emit(" goto ${prefix}_LAST");
+ }
+ elsif ( $kind eq 'else' ) {
+ $compiler->emit("${prefix}_ELSE:");
+
+ if ( $self->content ) {
+ $compiler->indent;
+ $self->SUPER::compile($compiler);
+ $compiler->outdent;
+ }
+
+ $compiler->emit("${prefix}_LAST:");
+ }
+
+ return 1;
+}
+
+#
+# sax()
+#
+
+sub sax {
+ my $self = shift;
+ my ($handler) = @_;
+
+ if ( not $self->prefix and $self->peer and $self->peer->prefix ) {
+ $self->prefix( $self->peer->prefix );
+ }
+
+ if ( $self->prefix ) {
+ $handler->start_element(
+ { Name => 'cond', Attributes => { kind => $self->kind, name => $self->prefix } } );
+ }
+ else {
+ $handler->start_element( { Name => 'cond', Attributes => { kind => $self->kind } } );
+ }
+
+ if ( $self->op ) {
+ $handler->start_element( { Name => 'block', Attributes => { kind => 'test' } } );
+ $handler->start_element(
+ { Name => 'op', Attributes => { kind => 'infix', name => $self->op } } );
+ $self->left->sax($handler);
+ $self->right->sax($handler);
+ $handler->end_element( { Name => 'op' } );
+ $handler->end_element( { Name => 'block' } );
+ }
+
+ $handler->start_element( { Name => 'block', Attributes => { kind => 'then' } } );
+ $_->sax($handler) foreach $self->content;
+ $handler->end_element( { Name => 'block' } );
+
+ $handler->end_element( { Name => $self->kind } );
+}
+
+1;
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: jako/trunk/lib/Jako/Construct/Block/Conditional/Else.pm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/lib/Jako/Construct/Block/Conditional/Else.pm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,55 @@
+#
+# Else.pm
+#
+# Copyright (C) 2002-2005, Parrot Foundation.
+# This program is free software. It is subject to the same license
+# as the Parrot interpreter.
+#
+# $Id$
+#
+
+use strict;
+use warnings;
+
+package Jako::Construct::Block::Conditional::Else;
+
+use Carp;
+
+use base qw(Jako::Construct::Block::Conditional);
+
+#
+# new()
+#
+
+sub new {
+ my $class = shift;
+
+ confess "Expected parent block and peer block!" unless @_ == 2;
+
+ my ( $block, $peer ) = @_;
+
+ my $self = bless {
+ BLOCK => $block,
+ PEER => $peer,
+
+ KIND => 'else',
+
+ CONTENT => []
+ }, $class;
+
+ $block->push_content($self);
+
+ return $self;
+}
+
+sub peer { return shift->{PEER}; }
+
+1;
+
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: jako/trunk/lib/Jako/Construct/Block/Conditional/If.pm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/lib/Jako/Construct/Block/Conditional/If.pm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,63 @@
+#
+# If.pm
+#
+# Copyright (C) 2002-2005, Parrot Foundation.
+# This program is free software. It is subject to the same license
+# as the Parrot interpreter.
+#
+# $Id$
+#
+
+use strict;
+use warnings;
+
+package Jako::Construct::Block::Conditional::If;
+
+use Carp;
+
+use base qw(Jako::Construct::Block::Conditional);
+
+#
+# new()
+#
+
+sub new {
+ my $class = shift;
+ my ( $block, $left, $op, $right ) = @_;
+
+ confess "Block is not defined!" unless defined $block;
+ confess "Left is not defined!" unless defined $left;
+ confess "Op is not defined!" unless defined $op;
+ confess "Right is not defined!" unless defined $right;
+
+ confess "Block is not!" unless UNIVERSAL::isa( $block, 'Jako::Construct::Block' );
+ confess "Left is not Value!"
+ unless UNIVERSAL::isa( $left, 'Jako::Construct::Expression::Value' );
+ confess "Op is not scalar!" if ref $op;
+ confess "Right is not Value!"
+ unless UNIVERSAL::isa( $right, 'Jako::Construct::Expression::Value' );
+
+ my $self = bless {
+ BLOCK => $block,
+
+ KIND => 'if',
+ LEFT => $left,
+ OP => $op,
+ RIGHT => $right,
+
+ CONTENT => []
+ }, $class;
+
+ $block->push_content($self);
+
+ return $self;
+}
+
+1;
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: jako/trunk/lib/Jako/Construct/Block/Conditional/Unless.pm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/lib/Jako/Construct/Block/Conditional/Unless.pm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,64 @@
+#
+# Unless.pm
+#
+# Copyright (C) 2002-2005, Parrot Foundation.
+# This program is free software. It is subject to the same license
+# as the Parrot interpreter.
+#
+# $Id$
+#
+
+use strict;
+use warnings;
+
+package Jako::Construct::Block::Conditional::Unless;
+
+use Carp;
+
+use base qw(Jako::Construct::Block::Conditional);
+
+#
+# new()
+#
+
+sub new {
+ my $class = shift;
+ my ( $block, $left, $op, $right ) = @_;
+
+ confess "Block is not defined!" unless defined $block;
+ confess "Left is not defined!" unless defined $left;
+ confess "Op is not defined!" unless defined $op;
+ confess "Right is not defined!" unless defined $right;
+
+ confess "Block is not!" unless UNIVERSAL::isa( $block, 'Jako::Construct::Block' );
+ confess "Left is not Value!"
+ unless UNIVERSAL::isa( $left, 'Jako::Construct::Expression::Value' );
+ confess "Op is not scalar!" if ref $op;
+ confess "Right is not Value!"
+ unless UNIVERSAL::isa( $right, 'Jako::Construct::Expression::Value' );
+
+ my $self = bless {
+ BLOCK => $block,
+
+ KIND => 'unless',
+ LEFT => $left,
+ OP => $op,
+ RIGHT => $right,
+
+ CONTENT => []
+ }, $class;
+
+ $block->push_content($self);
+
+ return $self;
+}
+
+1;
+
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: jako/trunk/lib/Jako/Construct/Block/File.pm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/lib/Jako/Construct/Block/File.pm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,102 @@
+#
+# File.pm
+#
+# Copyright (C) 2003-2005, Parrot Foundation.
+# This program is free software. It is subject to the same license
+# as the Parrot interpreter.
+#
+# $Id$
+#
+
+use strict;
+use warnings;
+
+package Jako::Construct::Block::File;
+
+use Carp;
+
+use Jako::Compiler;
+
+use base qw(Jako::Construct::Block);
+
+#
+# compile()
+#
+
+sub compile {
+ my $self = shift; # Required:
+ my $compiler = shift; # Required
+
+ # my $namespace = "FILE"; # TODO: Don't we need to do better than this?
+
+ return 1 unless $self->content;
+
+ my $inline = 0;
+ my $last_seen = 'sub';
+
+ $compiler->emit(".sub ___MAIN");
+ $compiler->indent;
+ $compiler->emit("__INLINE_0()");
+ $compiler->emit("end");
+ $compiler->outdent;
+ $compiler->emit(".end");
+
+ foreach my $construct ( $self->content ) {
+ if ( $construct->isa("Jako::Construct::Block::Sub")
+ or $construct->isa("Jako::Construct::Block::Module")
+ or $construct->isa("Jako::Construct::Declaration::Sub") )
+ {
+ if ( $last_seen ne 'sub' ) {
+ $compiler->emit( "__INLINE_" . $inline . "()" ); # $inline is already the next one.
+ $compiler->emit(".return()"); # Return to the previous inline chunk.
+ $compiler->outdent;
+ $compiler->emit(".end");
+
+ $last_seen = 'sub';
+ }
+ }
+ else {
+ if ( $last_seen ne 'inline' ) {
+ $compiler->emit( ".sub __INLINE_" . $inline++ );
+ $compiler->indent;
+
+ $last_seen = 'inline';
+ }
+ }
+
+ $construct->compile($compiler);
+ }
+
+ if ( $last_seen ne 'inline' ) {
+ $compiler->emit( ".sub __INLINE_" . $inline++ );
+ $compiler->indent;
+ }
+
+ $compiler->emit(".return()");
+ $compiler->outdent;
+ $compiler->emit(".end");
+
+ return 1;
+}
+
+#
+# sax()
+#
+
+sub sax {
+ my $self = shift;
+ my ($handler) = @_;
+
+ $handler->start_element( { Name => 'block', Attributes => { kind => $self->kind } } );
+ $_->sax($handler) foreach $self->content;
+ $handler->end_element( { Name => 'block' } );
+}
+
+1;
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: jako/trunk/lib/Jako/Construct/Block/Loop.pm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/lib/Jako/Construct/Block/Loop.pm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,126 @@
+#
+# Loop.pm
+#
+# Copyright (C) 2002-2005, Parrot Foundation.
+# This program is free software. It is subject to the same license
+# as the Parrot interpreter.
+#
+# $Id$
+#
+
+use strict;
+use warnings;
+
+package Jako::Construct::Block::Loop;
+
+use Carp;
+
+use Jako::Compiler;
+
+use base qw(Jako::Construct::Block);
+
+#
+# compile()
+#
+
+sub compile {
+ my $self = shift;
+ my ($compiler) = @_;
+
+ my $kind = $self->kind;
+ my $peer = $self->peer;
+
+ my $prefix;
+
+ if ( $self->prefix ) {
+ $prefix = $self->prefix;
+ }
+ else {
+ $prefix = $self->peer ? $peer->prefix : $compiler->block_label($kind);
+ $self->prefix($prefix);
+ }
+
+ my $namespace = $prefix;
+
+ if ( $kind eq 'while' or $kind eq 'until' ) {
+ my $test = ( $kind eq 'while' ) ? 'unless' : 'if';
+
+ $compiler->emit("${prefix}_NEXT:");
+
+ my $op = $self->op;
+ my $left = $self->left->compile($compiler);
+ my $right = $self->right->compile($compiler);
+ $compiler->emit(" $test $left $op $right goto ${prefix}_LAST");
+
+ $compiler->emit("${prefix}_REDO:");
+
+ if ( $self->content ) {
+ $compiler->indent;
+ $self->SUPER::compile($compiler);
+ $compiler->outdent;
+ }
+ }
+ elsif ( $kind eq 'continue' ) {
+ $compiler->emit("${prefix}_CONT:");
+
+ if ( $self->content ) {
+ $compiler->indent;
+ $self->SUPER::compile($compiler);
+ $compiler->outdent;
+ }
+
+ $compiler->emit(" goto ${prefix}_NEXT");
+ $compiler->emit("${prefix}_LAST:");
+ }
+ else {
+ $self->INTERNAL_ERROR( "Unrecognized kind of block '%s'", $kind );
+ }
+
+ return 1;
+}
+
+#
+# sax()
+#
+
+sub sax {
+ my $self = shift;
+ my ($handler) = @_;
+
+ if ( not $self->prefix and $self->peer and $self->peer->prefix ) {
+ $self->prefix( $self->peer->prefix );
+ }
+
+ if ( $self->prefix ) {
+ $handler->start_element(
+ { Name => 'loop', Attributes => { kind => $self->kind, name => $self->prefix } } );
+ }
+ else {
+ $handler->start_element( { Name => 'loop', Attributes => { kind => $self->kind } } );
+ }
+
+ if ( $self->op ) {
+ $handler->start_element( { Name => 'block', Attributes => { kind => 'test' } } );
+ $handler->start_element(
+ { Name => 'op', Attributes => { kind => 'infix', name => $self->op } } );
+ $self->left->sax($handler);
+ $self->right->sax($handler);
+ $handler->end_element( { Name => 'op' } );
+ $handler->end_element( { Name => 'block' } );
+ }
+
+ $handler->start_element( { Name => 'block', Attributes => { kind => $self->kind } } );
+ $_->sax($handler) foreach $self->content;
+ $handler->end_element( { Name => 'block' } );
+
+ $handler->end_element( { Name => $self->kind } );
+}
+
+1;
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: jako/trunk/lib/Jako/Construct/Block/Loop/Continue.pm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/lib/Jako/Construct/Block/Loop/Continue.pm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,55 @@
+#
+# Continue.pm
+#
+# Copyright (C) 2002-2005, Parrot Foundation.
+# This program is free software. It is subject to the same license
+# as the Parrot interpreter.
+#
+# $Id$
+#
+
+use strict;
+use warnings;
+
+package Jako::Construct::Block::Loop::Continue;
+
+use Carp;
+
+use base qw(Jako::Construct::Block::Loop);
+
+#
+# new()
+#
+
+sub new {
+ my $class = shift;
+
+ confess "Expected parent and peer blocks." unless @_ == 2;
+
+ my ( $block, $peer ) = @_;
+
+ my $self = bless {
+ BLOCK => $block,
+
+ KIND => 'continue',
+ PEER => $peer,
+
+ CONTENT => []
+ }, $class;
+
+ $block->push_content($self);
+
+ return $self;
+}
+
+sub peer { return shift->{PEER}; }
+
+1;
+
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: jako/trunk/lib/Jako/Construct/Block/Loop/Until.pm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/lib/Jako/Construct/Block/Loop/Until.pm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,55 @@
+#
+# Until.pm
+#
+# Copyright (C) 2002-2005, Parrot Foundation.
+# This program is free software. It is subject to the same license
+# as the Parrot interpreter.
+#
+# $Id$
+#
+
+use strict;
+use warnings;
+
+package Jako::Construct::Block::Loop::Until;
+
+use Carp;
+
+use base qw(Jako::Construct::Block::Loop);
+
+#
+# new()
+#
+
+sub new {
+ my $class = shift;
+
+ confess "Expected 5 args!" unless @_ == 5;
+
+ my ( $block, $prefix, $left, $op, $right ) = @_;
+
+ my $self = bless {
+ BLOCK => $block,
+
+ PREFIX => $prefix,
+ KIND => 'until',
+ LEFT => $left,
+ OP => $op,
+ RIGHT => $right,
+
+ CONTENT => []
+ }, $class;
+
+ $block->push_content($self);
+
+ return $self;
+}
+
+1;
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: jako/trunk/lib/Jako/Construct/Block/Loop/While.pm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/lib/Jako/Construct/Block/Loop/While.pm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,55 @@
+#
+# While.pm
+#
+# Copyright (C) 2002-2005, Parrot Foundation.
+# This program is free software. It is subject to the same license
+# as the Parrot interpreter.
+#
+# $Id$
+#
+
+use strict;
+use warnings;
+
+package Jako::Construct::Block::Loop::While;
+
+use Carp;
+
+use base qw(Jako::Construct::Block::Loop);
+
+#
+# new()
+#
+
+sub new {
+ my $class = shift;
+
+ confess "Expected 5 args!" unless @_ == 5;
+
+ my ( $block, $prefix, $left, $op, $right ) = @_;
+
+ my $self = bless {
+ BLOCK => $block,
+
+ PREFIX => $prefix,
+ KIND => 'while',
+ LEFT => $left,
+ OP => $op,
+ RIGHT => $right,
+
+ CONTENT => []
+ }, $class;
+
+ $block->push_content($self);
+
+ return $self;
+}
+
+1;
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: jako/trunk/lib/Jako/Construct/Block/Module.pm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/lib/Jako/Construct/Block/Module.pm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,130 @@
+#
+# Module.pm
+#
+# Copyright (C) 2003-2005, Parrot Foundation.
+# This program is free software. It is subject to the same license
+# as the Parrot interpreter.
+#
+# $Id$
+#
+
+use strict;
+use warnings;
+
+package Jako::Construct::Block::Module;
+
+use Carp;
+
+use Jako::Compiler;
+
+use base qw(Jako::Construct::Block);
+
+sub kind { return 'module'; }
+
+sub new {
+ my $class = shift;
+
+ confess "Expected 3 args!" unless @_ == 3;
+ my ( $block, $ident, $props ) = @_;
+
+ confess "Block is not!" unless UNIVERSAL::isa( $block, 'Jako::Construct::Block' );
+ confess "Ident is not!"
+ unless UNIVERSAL::isa( $ident, 'Jako::Construct::Expression::Value::Identifier' );
+ confess "Props are not hash!" if defined $props and ref($props) ne "HASH";
+
+ my $self = bless {
+ BLOCK => $block,
+
+ TYPE => undef,
+ NAME => $ident->value,
+ PROPS => $props,
+ ARGS => undef,
+
+ DEBUG => 1,
+ FILE => $ident->file,
+ LINE => $ident->line
+ }, $class;
+
+ $block->push_content($self);
+
+ # printf STDERR "%s: Created new module '%s'.\n", __PACKAGE__, $ident->value;
+
+ return $self;
+}
+
+#
+# ACCESSORS:
+#
+
+sub type { return shift->{TYPE}; }
+sub name { return shift->{NAME}; }
+sub props { return %{ shift->{PROPS} }; }
+
+#
+# compile()
+#
+
+sub compile {
+ my $self = shift;
+ my $compiler = shift; # Required
+ my $options = shift; # Optional
+
+ my $namespace = "MODULE"; # TODO: Don't we need to do better than this?
+
+ # printf STDERR "%s: Compiling module '%s'.\n", __PACKAGE__, $self->name;
+
+ #
+ # Import our symbols into our parent block:
+ #
+
+ my $name = $self->name;
+
+ # printf STDERR "%s: About to copy symbol table to parent block.\n", __PACKAGE__;
+
+ foreach my $symbol_name ( $self->symbol_names ) {
+
+ # TODO: Warn here that we are skipping one already in the parent block?
+ next if $self->block->get_symbol($symbol_name);
+
+ my $new_name = $name . "::" . $symbol_name;
+
+ $self->block->set_symbol( $new_name, $self->get_symbol($symbol_name) );
+ }
+
+ # printf STDERR "%s: Finished copying symbol table to parent block.\n", __PACKAGE__;
+
+ return 1 unless $self->content;
+
+ # if ($options->{PACKAGE}) {
+ # $options->{PACKAGE} .= "::" . $self->name;
+ # }
+ # else {
+ # $options->{PACKAGE} = $self->name;
+ # }
+
+ return $self->SUPER::compile( $compiler, $options );
+
+ return 1;
+}
+
+#
+# sax()
+#
+
+sub sax {
+ my $self = shift;
+ my ($handler) = @_;
+
+ $handler->start_element( { Name => 'module', Attributes => { name => $self->name } } );
+ $_->sax($handler) foreach $self->content;
+ $handler->end_element( { Name => 'module' } );
+}
+
+1;
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: jako/trunk/lib/Jako/Construct/Block/Sub.pm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/lib/Jako/Construct/Block/Sub.pm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,152 @@
+#
+# Sub.pm
+#
+# Copyright (C) 2002-2005, Parrot Foundation.
+# This program is free software. It is subject to the same license
+# as the Parrot interpreter.
+#
+# $Id$
+#
+
+use strict;
+use warnings;
+
+package Jako::Construct::Block::Sub;
+
+use Carp;
+
+use base qw(Jako::Construct::Block);
+
+sub kind { return 'sub'; }
+
+sub new {
+ my $class = shift;
+
+ confess "Expected 5 args!" unless @_ == 5;
+ my ( $block, $type, $ident, $props, $args ) = @_;
+
+ confess "Block is not!" unless UNIVERSAL::isa( $block, 'Jako::Construct::Block' );
+ confess "Type is not!"
+ if defined $type and not UNIVERSAL::isa( $type, 'Jako::Construct::Type' );
+ confess "Ident is not!"
+ unless UNIVERSAL::isa( $ident, 'Jako::Construct::Expression::Value::Identifier' );
+ confess "Props are not hash!" if defined $props and ref($props) ne "HASH";
+ confess "Args are not hash!" if defined $args and ref($args) ne "ARRAY";
+
+ my $self = bless {
+ BLOCK => $block,
+
+ TYPE => $type,
+ NAME => $ident->value,
+ PROPS => $props,
+ ARGS => $args,
+
+ DEBUG => 1,
+ FILE => $ident->file,
+ LINE => $ident->line
+ }, $class;
+
+ $block->push_content($self);
+
+ foreach my $arg (@$args) {
+ my ( $arg_type, $arg_name, $arg_token ) = @$arg;
+ my $sym =
+ Jako::Symbol->new( $self, 'local', 'arg', $arg_type, $arg_name, undef, undef, undef,
+ $arg_token->file, $arg_token->line );
+ $self->set_symbol( $arg_name, $sym );
+ }
+
+ return $self;
+}
+
+#
+# ACCESSORS:
+#
+
+sub type { return shift->{TYPE}; }
+sub name { return shift->{NAME}; }
+sub props { return %{ shift->{PROPS} }; }
+sub args { return @{ shift->{ARGS} }; }
+
+#
+# compile()
+#
+
+sub compile {
+ my $self = shift;
+ my ($compiler) = @_;
+
+ my $type = $self->type;
+ my $name = $self->name;
+ my %props = $self->props;
+ my @args = $self->args;
+
+ my $subname = $name;
+
+ $subname =~ s/::/__/g;
+
+ $compiler->emit(".sub _${subname}");
+
+ foreach my $arg (@args) {
+ my ( $arg_type, $arg_name ) = @$arg;
+ my $imcc_type = $arg_type->imcc;
+
+ $compiler->emit(" .param $imcc_type $arg_name");
+ }
+
+ $compiler->indent;
+ $self->SUPER::compile($compiler);
+ $compiler->outdent;
+
+ $compiler->emit("_${name}_LEAVE:");
+ $compiler->emit(" .return()")
+ ; # Fallthrough return() in case the code in the sub doesn't return anything
+ $compiler->emit(".end");
+
+ return 1;
+}
+
+#
+# sax()
+#
+
+sub sax {
+ my $self = shift;
+ my ($handler) = @_;
+
+ my $type = $self->type;
+ my $name = $self->name;
+ my @args = $self->args;
+
+ if ($type) {
+ $handler->start_element(
+ { Name => 'sub', Attributes => { name => $name, type => $type } } );
+ }
+ else {
+ $handler->start_element( { Name => 'sub', Attributes => { name => $name } } );
+ }
+
+ foreach my $arg (@args) {
+ my ( $arg_type, $arg_name ) = @$arg;
+
+ $handler->start_element(
+ { Name => 'arg', Attributes => { name => $arg_name, type => $arg_type } } );
+ $handler->end_element( { Name => 'arg' } );
+ }
+
+ foreach my $content ( $self->content ) {
+ $content->sax($handler);
+ }
+
+ $handler->end_element( { Name => 'sub' } );
+}
+
+1;
+
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: jako/trunk/lib/Jako/Construct/Declaration.pm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/lib/Jako/Construct/Declaration.pm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,28 @@
+#
+# Declaration.pm
+#
+# Copyright (C) 2002-2005, Parrot Foundation.
+# This program is free software. It is subject to the same license
+# as the Parrot interpreter.
+#
+# $Id$
+#
+
+use strict;
+use warnings;
+
+package Jako::Construct::Declaration;
+
+use base qw(Jako::Construct);
+
+sub access { return shift->{ACCESS}; }
+
+1;
+
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: jako/trunk/lib/Jako/Construct/Declaration/Constant.pm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/lib/Jako/Construct/Declaration/Constant.pm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,181 @@
+#
+# Constant.pm
+#
+# Copyright (C) 2002-2005, Parrot Foundation.
+# This program is free software. It is subject to the same license
+# as the Parrot interpreter.
+#
+# $Id$
+#
+
+use strict;
+use warnings;
+
+package Jako::Construct::Declaration::Constant;
+
+use Carp;
+
+use base qw(Jako::Construct::Declaration);
+
+use Jako::Construct::Type;
+
+#
+# new()
+#
+
+sub new {
+ my $class = shift;
+
+ my ( $block, $type, $ident, $value ) = @_;
+
+ confess "Block (" . ref($block) . ") is not!"
+ unless UNIVERSAL::isa( $block, qw(Jako::Construct::Block) );
+ confess "Type (" . ref($type) . ") is not!"
+ unless UNIVERSAL::isa( $type, qw(Jako::Construct::Type) );
+ confess "Identifier (" . ref($ident) . ") is not!"
+ unless UNIVERSAL::isa( $ident, qw(Jako::Construct::Expression::Value::Identifier) );
+ confess "Value (" . ref($value) . ") is not!"
+ unless UNIVERSAL::isa( $value, qw(Jako::Construct::Expression::Value) );
+
+ my $self = bless {
+ BLOCK => $block,
+ ACCESS => 'const',
+ TYPE => $type,
+ NAME => $ident->value,
+ FILE => $ident->file,
+ LINE => $ident->line,
+ VALUE => $value
+ }, $class;
+
+ #
+ # Check for a few bad conditions.
+ #
+ # NOTE: These are compiler internal consistency checks. They really should not be
+ # triggered in normal operation, even with bad source code as input.
+ #
+
+ $self->INTERNAL_ERROR("Undefined block!")
+ unless defined $block;
+
+ $self->INTERNAL_ERROR("Undefined type!")
+ unless defined $type;
+
+ $self->INTERNAL_ERROR("Type is not a Jako::Construct::Type instance!")
+ unless UNIVERSAL::isa( $type, "Jako::Construct::Type" );
+
+ my $type_name = $type->name;
+
+ $self->INTERNAL_ERROR("Constant definition involves undefined type name!")
+ unless defined $type_name;
+
+ $self->INTERNAL_ERROR("Constant definition involves undefined value!")
+ unless defined $value;
+
+ #
+ # Lookup the identifier:
+ #
+
+ my $sym = $block->find_symbol( $self->name );
+
+ #
+ # If the identifier is already defined at this lexical scope, we want to complain
+ # about the redefinition. Otherwise, we assume the programmer wanted to shadow the
+ # previous definition.
+ #
+
+ if ( defined $sym and $sym->block eq $block ) {
+ $self->EXCEPTION_SYNTAX_ERROR(
+"Redeclaration of identifier '%s' within same block. Previous declaration on line %d of file '%s'.",
+ $self->name, $sym->line, $sym->file );
+ }
+
+ #
+ # Now that we've decided to actually declare the constant, we will place its
+ # definition into the block at the top of the block stack. We fill in the
+ # IDENT entry within the block.
+ #
+
+ $sym = Jako::Symbol->new( # TODO: Just point at the Declaration?
+ $self->block,
+ ( $self->is_global ? 'global' : 'local' ),
+ $self->access,
+ $self->type,
+ $self->name,
+ $self->value,
+ undef, # No properties
+ undef, # No args
+ $self->file,
+ $self->line
+ );
+
+ $block->set_symbol( $self->name, $sym );
+
+ $block->push_content($self);
+
+ return $self;
+}
+
+#
+# ACCESSORS:
+#
+
+# block handled by superclass?
+# access handled by superclass?
+sub type { return shift->{TYPE}; }
+sub name { return shift->{NAME}; }
+sub value { return shift->{VALUE}; }
+
+# file handled by superclass?
+# line handled by superclass?
+
+sub is_global {
+ my $self = shift;
+
+ return defined $self->block and not defined $self->block->block;
+}
+
+#
+# compile()
+#
+
+sub compile {
+ my $self = shift;
+ my ($compiler) = @_;
+
+ my $type = $self->type->imcc;
+ my $name = $self->name;
+ my $value = $self->value->value;
+
+ if ( $self->is_global ) {
+ $compiler->emit(" .globalconst $type $name = $value");
+ }
+ else {
+ $compiler->emit(" .const $type $name = $value");
+ }
+
+ return 1;
+}
+
+#
+# sax()
+#
+
+sub sax {
+ my $self = shift;
+ my ($handler) = @_;
+
+ $handler->start_element(
+ { Name => 'const', Attributes => { type => $self->type->name, name => $self->name } } );
+ $self->value->sax($handler);
+ $handler->end_element( { Name => 'const' } );
+}
+
+1;
+
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: jako/trunk/lib/Jako/Construct/Declaration/Sub.pm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/lib/Jako/Construct/Declaration/Sub.pm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,348 @@
+#
+# Sub.pm
+#
+# Copyright (C) 2002-2005, Parrot Foundation.
+# This program is free software. It is subject to the same license
+# as the Parrot interpreter.
+#
+# $Id$
+#
+
+use strict;
+use warnings;
+
+package Jako::Construct::Declaration::Sub;
+
+use Carp;
+
+use base qw(Jako::Construct::Declaration);
+
+use Jako::Symbol;
+use Jako::Construct::Type;
+
+#
+# new()
+#
+
+sub new {
+ my $class = shift;
+
+ my ( $block, $type, $ident, $props, $args ) = @_;
+
+ confess "Block (" . ref($block) . ") is not!"
+ unless UNIVERSAL::isa( $block, qw(Jako::Construct::Block) );
+ confess "Type (" . ref($type) . ") is not!"
+ if defined $type and not UNIVERSAL::isa( $type, qw(Jako::Construct::Type) );
+ confess "Identifier (" . ref($ident) . ") is not!"
+ unless UNIVERSAL::isa( $ident, qw(Jako::Construct::Expression::Value::Identifier) );
+
+ my $self = bless {
+ BLOCK => $block,
+
+ KIND => 'sub',
+ TYPE => $type,
+ NAME => $ident->value,
+ PROPS => $props,
+ ARGS => $args,
+
+ DEBUG => 1,
+ FILE => $ident->file,
+ LINE => $ident->line,
+ }, $class;
+
+ #
+ # Check for a few bad conditions.
+ #
+ # NOTE: These are compiler internal consistency checks. They really should not be
+ # triggered in normal operation, even with bad source code as input.
+ #
+
+ $self->INTERNAL_ERROR("Undefined block!")
+ unless defined $block;
+
+ #
+ # Lookup the identifier:
+ #
+
+ my $name = $self->name;
+
+ my $sym = $block->find_symbol($name);
+
+ #
+ # If the identifier is already defined at ANY lexical scope, we want to complain
+ # about the redefinition. Otherwise, we assume the programmer wanted to shadow the
+ # previous definition.
+ #
+
+ if ( defined $sym ) {
+ $self->EXCEPTION_SYNTAX_ERROR(
+ "Redeclaration of identifier '%s'. Previous declaration on line %d of file '%s'.",
+ $name, $sym->line, $sym->file );
+ }
+
+ #
+ # Now that we've decided to actually declare the sub, we will place its
+ # definition into the block at the top of the block stack (which is supposed
+ # to always be the file block at the time subs are declared). We fill in the
+ # IDENT entry within the block.
+ #
+
+ $sym = Jako::Symbol->new(
+ $self->block,
+ 'global', # TODO: Should we support non-global subs?
+ $self->kind,
+ $self->type,
+ $name,
+ undef, # No value
+ $props, # Parsed Properties
+ $args, # Parsed Properties
+ $self->file,
+ $self->line
+ );
+
+ # $self->DEBUG(0, "Remembering symbol '$name' as sub...");
+
+ $block->set_symbol( $name, $sym );
+
+ $block->push_content($self);
+
+ return $self;
+}
+
+# block handled by superclass?
+
+sub kind { return shift->{KIND}; }
+sub type { return shift->{TYPE}; }
+
+sub name {
+ my $self = shift;
+ my $name = $self->{NAME};
+
+ return $name;
+}
+
+sub props { return %{ shift->{PROPS} }; }
+sub args { return @{ shift->{ARGS} }; }
+
+sub file { return shift->{FILE}; }
+sub line { return shift->{LINE}; }
+
+#
+# compile()
+#
+
+sub compile {
+ my $self = shift; # Required
+ my $compiler = shift; # Required
+ my $options = shift; # Optional
+
+ my $name = $self->name;
+
+ if ( $self->block->kind eq 'module' ) {
+ $name = $self->block->name . "::" . $name;
+ }
+
+ my $sym = $self->block->find_symbol($name);
+
+ my %props = $sym->props;
+
+ if ( exists $props{fn} or exists $props{fnlib} ) {
+ my $fnlib;
+
+ if ( exists $props{fnlib} and $props{fnlib} ) {
+ $fnlib = $props{fnlib}->value; # TODO: We should make sure its a string, somewhere.
+ }
+ else {
+ $self->EXCEPTION_SYNTAX_ERROR(
+ "Sub declaration has no fnlib property, and parent block is not a module!")
+ unless $self->block->kind eq 'module';
+
+ my %module_props = $self->block->props;
+
+ $self->EXCEPTION_SYNTAX_ERROR(
+"Sub declaration has no fnlib property, and parent module has no fnlib property either!"
+ ) unless $module_props{fnlib};
+
+ $fnlib = $module_props{fnlib}->value;
+ }
+
+ my $fn = $props{fn} ? $props{fn}->value : "\"$name\"";
+
+ my $thunk = "_${name}_THUNK";
+ $thunk =~ s/::/__/g;
+
+ $compiler->emit(".sub $thunk");
+
+ my $sig = defined $self->type ? $self->type->code : 'v';
+
+ foreach my $arg ( $self->args ) {
+ my ( $arg_type, $arg_name ) = @$arg;
+ my $imcc_type = $arg_type->imcc;
+
+ $compiler->emit(" .param $imcc_type $arg_name");
+ $sig .= $arg_type->code;
+ }
+
+ $sig =~ tr[INPS][ifpt]; # Defaults.
+
+ my $fn_name = $fn;
+
+ $fn_name =~ s/^.*::/"/;
+
+ $compiler->emit(" .local pmc __lib");
+ $compiler->emit(" loadlib __lib, $fnlib");
+ $compiler->emit(" .local pmc __func");
+ $compiler->emit(" dlfunc __func, __lib, $fn_name, \"$sig\"");
+
+ if ( $self->type ) {
+ $compiler->emit( " .local " . $self->type . " __result" );
+ $compiler->emit(
+ " __result = __func(" . join( ", ", map( { $_->[1] } $self->args ) ) . ")" );
+ $compiler->emit(" .return(__result)");
+ }
+ else {
+ $compiler->emit( " __func(" . join( ", ", map( { $_->[1] } $self->args ) ) . ")" );
+ $compiler->emit(" .return()");
+ }
+
+ $compiler->emit(".end");
+ }
+
+ return 1;
+}
+
+#
+# sax()
+#
+
+sub sax {
+ my $self = shift;
+ my ($handler) = @_;
+
+ my $name = $self->name;
+ my $type = $self->type;
+
+ my $sym = $self->block->find_symbol($name);
+
+ my %props = $sym->props;
+
+ if ( exists $props{op} ) {
+ my $oplib =
+ $props{oplib}
+ ? $props{oplib}->value
+ : 'CORE'; # TODO: We should make sure its a string, somewhere.
+ my $op = $props{op} ? $props{op}->value : $name;
+
+ if ($type) {
+ $handler->start_element(
+ {
+ Name => 'sub',
+ Attributes => {
+ name => $name,
+ type => $type,
+ kind => 'op',
+ oplib => $oplib,
+ op => $op
+ }
+ }
+ );
+ }
+ else {
+ $handler->start_element(
+ {
+ Name => 'sub',
+ Attributes => {
+ name => $name,
+ kind => 'op',
+ oplib => $oplib,
+ op => $op
+ }
+ }
+ );
+ }
+ }
+ elsif ( exists $props{fn} or exists $props{fnlib} ) {
+ my $fnlib;
+
+ if ( exists $props{fnlib} and $props{fnlib} ) {
+ $fnlib = $props{fnlib}->value; # TODO: We should make sure its a string, somewhere.
+ }
+ else {
+ $self->EXCEPTION_SYNTAX_ERROR(
+ "Sub declaration has no fnlib property, and parent block is not a module!")
+ unless $self->block->kind eq 'module';
+
+ my %module_props = $self->block->props;
+
+ $self->EXCEPTION_SYNTAX_ERROR(
+"Sub declaration has no fnlib property, and parent module has no fnlib property either!"
+ ) unless $module_props{fnlib};
+
+ $fnlib = $module_props{fnlib}->value;
+ }
+
+ my $fn = $props{fn} ? $props{fn}->value : $name;
+
+ $fn =~ s{(^")|("$)}{}g;
+ $fnlib =~ s{(^")|("$)}{}g;
+ $name =~ s/^.*:://;
+
+ if ($type) {
+ $handler->start_element(
+ {
+ Name => 'sub',
+ Attributes => {
+ name => $name,
+ type => $type,
+ kind => 'fn',
+ fnlib => $fnlib,
+ fn => $fn
+ }
+ }
+ );
+ }
+ else {
+ $handler->start_element(
+ {
+ Name => 'sub',
+ Attributes => {
+ name => $name,
+ kind => 'fn',
+ fnlib => $fnlib,
+ fn => $fn
+ }
+ }
+ );
+ }
+ }
+ else {
+ return;
+ }
+
+ foreach my $arg ( $self->args ) {
+ my ( $arg_type_name, $arg_name ) = @$arg;
+
+ $handler->start_element(
+ {
+ Name => 'arg',
+ Attributes => {
+ type => $arg_type_name,
+ name => $arg_name
+ }
+ }
+ );
+ $handler->end_element( { Name => 'arg' } );
+ }
+
+ $handler->end_element( { Name => 'sub' } );
+}
+
+1;
+
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: jako/trunk/lib/Jako/Construct/Declaration/Variable.pm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/lib/Jako/Construct/Declaration/Variable.pm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,177 @@
+#
+# Variable.pm
+#
+# Copyright (C) 2002-2005, Parrot Foundation.
+# This program is free software. It is subject to the same license
+# as the Parrot interpreter.
+#
+# $Id$
+#
+
+use strict;
+use warnings;
+
+package Jako::Construct::Declaration::Variable;
+
+use Carp;
+
+use base qw(Jako::Construct::Declaration);
+
+use Jako::Construct::Type;
+
+#
+# new()
+#
+
+sub new {
+ my $class = shift;
+
+ my ( $block, $type, $ident ) = @_;
+
+ confess "Block (" . ref($block) . ") is not!"
+ unless UNIVERSAL::isa( $block, qw(Jako::Construct::Block) );
+ confess "Type (" . ref($type) . ") is not!"
+ unless UNIVERSAL::isa( $type, qw(Jako::Construct::Type) );
+ confess "Identifier (" . ref($ident) . ") is not!"
+ unless UNIVERSAL::isa( $ident, qw(Jako::Construct::Expression::Value::Identifier) );
+
+ my $self = bless {
+ BLOCK => $block,
+
+ KIND => 'var',
+ TYPE => $type,
+ NAME => $ident->value,
+ FILE => $ident->file,
+ LINE => $ident->line,
+ }, $class;
+
+ #
+ # Check for a few bad conditions.
+ #
+ # NOTE: These are compiler internal consistency checks. They really should not be
+ # triggered in normal operation, even with bad source code as input.
+ #
+
+ $self->INTERNAL_ERROR("Undefined block!")
+ unless defined $block;
+
+ $self->INTERNAL_ERROR("Undefined type!")
+ unless defined $type;
+
+ $self->INTERNAL_ERROR("Type is not a Jako::Construct::Type instance!")
+ unless UNIVERSAL::isa( $type, "Jako::Construct::Type" );
+
+ my $type_name = $type->name;
+
+ $self->INTERNAL_ERROR("Variable definition involves undefined type name!")
+ unless defined $type_name;
+
+ #
+ # Lookup the identifier:
+ #
+
+ my $sym = $block->find_symbol( $self->name );
+
+ #
+ # If the identifier is already defined at this lexical scope, we want to complain
+ # about the redefinition. Otherwise, we assume the programmer wanted to shadow the
+ # previous definition.
+ #
+
+ if ( defined $sym and $sym->block eq $block ) {
+ $self->EXCEPTION_SYNTAX_ERROR(
+"Redeclaration of identifier '%s' in the same block. Previous declaration on line %d of file '%s'.",
+ $self->name, $sym->line, $sym->file );
+ }
+
+ #
+ # Now that we've decided to actually declare the constant, we will place its
+ # definition into the block at the top of the block stack. We fill in the
+ # IDENT entry within the block.
+ #
+
+ $sym = Jako::Symbol->new(
+ $self->block,
+ ( $self->is_global ? 'global' : 'local' ),
+ $self->kind,
+ $self->type,
+ $self->name,
+ undef, # No value
+ undef, # No properties
+ undef, # No args
+ $self->file,
+ $self->line
+ );
+
+ $block->set_symbol( $self->name, $sym );
+
+ $block->push_content($self);
+
+ return $self;
+}
+
+# block handled by superclass?
+
+sub kind { return shift->{KIND}; }
+sub type { return shift->{TYPE}; }
+sub name { return shift->{NAME}; }
+
+sub file { return shift->{FILE}; }
+sub line { return shift->{LINE}; }
+
+sub is_global {
+ my $self = shift;
+
+ return defined( $self->block ) && not( defined( $self->block->block ) );
+}
+
+#
+# compile()
+#
+
+sub compile {
+ my $self = shift;
+ my ($compiler) = @_;
+
+ confess "No compiler!" unless $compiler;
+
+ my $type = $self->type->imcc;
+ my $name = $self->name;
+
+ if ( $self->is_global ) {
+ my $pmc_type = $self->type->imcc_pmc;
+
+ my $reg = $compiler->temp_pmc();
+
+ $compiler->emit(" $reg = new '$pmc_type'");
+ $compiler->emit(" set_global \"$name\", $reg");
+ }
+ else {
+ $compiler->emit(" .local $type $name");
+ }
+
+ return 1;
+}
+
+#
+# sax()
+#
+
+sub sax {
+ my $self = shift;
+ my ($handler) = @_;
+
+ $handler->start_element(
+ { Name => 'var', Attributes => { type => $self->type->name, name => $self->name } } );
+ $handler->end_element( { Name => 'var' } );
+}
+
+1;
+
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: jako/trunk/lib/Jako/Construct/Expression.pm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/lib/Jako/Construct/Expression.pm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,26 @@
+#
+# Expression.pm
+#
+# Copyright (C) 2002-2005, Parrot Foundation.
+# This program is free software. It is subject to the same license
+# as the Parrot interpreter.
+#
+# $Id$
+#
+
+use strict;
+use warnings;
+
+package Jako::Construct::Expression;
+
+use base qw(Jako::Construct);
+
+1;
+
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: jako/trunk/lib/Jako/Construct/Expression/Call.pm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/lib/Jako/Construct/Expression/Call.pm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,192 @@
+#
+# Call.pm
+#
+# Copyright (C) 2002-2005, Parrot Foundation.
+# This program is free software. It is subject to the same license
+# as the Parrot interpreter.
+#
+# $Id$
+#
+
+use strict;
+use warnings;
+
+package Jako::Construct::Expression::Call;
+
+use Carp;
+
+use base qw(Jako::Construct::Expression);
+
+sub new {
+ my $class = shift;
+ my ( $block, $dest, $ident, @args ) = @_;
+
+ confess( "Dest (" . ref($block) . ") not Identifier!" )
+ unless UNIVERSAL::isa( $dest, 'Jako::Construct::Expression::Value::Identifier' );
+ confess( "Ident (" . ref($block) . ") not Identifier!" )
+ unless UNIVERSAL::isa( $ident, 'Jako::Construct::Expression::Value::Identifier' );
+ confess( "Block (" . ref($block) . ") not!" )
+ unless UNIVERSAL::isa( $block, 'Jako::Construct::Block' );
+
+ my $self = bless {
+ BLOCK => $block,
+
+ DEST => $dest,
+ NAME => $ident,
+ ARGS => [@args],
+
+ DEBUG => 1,
+ FILE => $ident->file,
+ LINE => $ident->line
+ }, $class;
+
+ $block->push_content($self);
+
+ return $self;
+}
+
+sub dest { return shift->{DEST}; }
+sub name { return shift->{NAME}; }
+sub args { return @{ shift->{ARGS} }; }
+
+#
+# compile()
+#
+
+sub compile {
+ my $self = shift;
+ my ($compiler) = @_;
+
+ my $dest_ident = $self->dest;
+
+ my $dest = $self->dest->value;
+ my $name = $self->name->value;
+
+ # $self->DEBUG(0, "Searching for symbol '$name'...");
+
+ my $sym = $self->block->find_symbol($name);
+
+ unless ($sym) {
+
+ # $self->block->dump_symbols;
+ $self->EXCEPTION_SYNTAX_ERROR( "Call to unknown sub '%s'.", $name );
+ }
+
+ my %props = $sym->props;
+
+ my @args = $self->args;
+
+ my @formal_args = $sym->args;
+
+ $self->EXCEPTION_SYNTAX_ERROR( "Wrong number of arguments (expected %d, got %d) in call to '%s'.",
+ scalar(@formal_args), scalar(@args), $name )
+ unless @formal_args == @args;
+
+ for ( my $i = 0 ; $i < @args ; $i++ ) {
+ my ( $formal_arg_type, $formal_arg_name ) = @{ $formal_args[$i] };
+ my $actual_arg_type;
+
+ if ( UNIVERSAL::isa( $args[$i], 'Jako::Construct::Expression::Value::Identifier' ) ) {
+ my $arg_sym = $self->block->find_symbol( $args[$i]->value );
+ $self->EXCEPTION_SYNTAX_ERROR( "Undefined identifier '%s'.", $args[$i]->value ) unless $arg_sym;
+ $actual_arg_type = $arg_sym->type;
+ }
+ else {
+ $actual_arg_type = $args[$i]->type;
+ }
+
+ $self->INTERNAL_ERROR( "Can't determine type of formal argument (%s)!", $formal_arg_name )
+ unless defined $formal_arg_type;
+
+ $self->INTERNAL_ERROR( "Can't determine type of actual argument (%s)!", ref $args[$i] )
+ unless defined $actual_arg_type;
+
+ if ( $formal_arg_type->name ne $actual_arg_type->name ) {
+ my $temp = $compiler->temp_reg($formal_arg_type);
+ my $value = $args[$i]->compile($compiler);
+ $compiler->emit(" $temp = $value");
+ $args[$i] = $temp;
+ }
+ else {
+ $args[$i] = $args[$i]->compile($compiler);
+ }
+ }
+
+ if ( ( $dest_ident->kind eq 'var' ) and ( $dest_ident->scope eq 'global' ) ) {
+ $dest = $dest_ident->compile($compiler);
+ }
+
+ #
+ # For built-in subs (ops):
+ #
+
+ if ( exists $props{op} ) {
+ my $op = $props{op};
+
+ # $self->DEBUG(0, "Calling %s%s...", $name, ($op ? ' (op $op)' : ' as op'));
+
+ $name = $op->value if defined $op;
+ $name =~ s/(^")|("$)//g; # Delete leading and trailing quotes;
+
+ $name =~ s/^.*:://; # Delete namespaces from ops
+
+ $compiler->emit( " $name ", join( ", ", $dest, @args ) );
+ }
+
+ #
+ # For regular (user-defined) and NCI (Native Call Interface) subs:
+ #
+
+ else {
+
+ # $self->DEBUG(0, "Calling '%s' as regular sub (props = %s)...", $name, join(", ", %props));
+
+ $name =~ s/::/__/g;
+
+ if ( exists $props{fn} or exists $props{fnlib} ) {
+ $name .= "_THUNK";
+ }
+
+ $compiler->emit( " $dest = _${name}(" . join( ", ", @args ) . ")" );
+ }
+
+ if ( ( $dest_ident->kind eq 'var' ) and ( $dest_ident->scope eq 'global' ) ) {
+ my $pmc_type = $dest_ident->type->imcc_pmc();
+ my $temp_pmc = $compiler->temp_pmc();
+
+ $compiler->emit(" $temp_pmc = new '$pmc_type'");
+ $compiler->emit(" $temp_pmc = $dest");
+
+ my $dest_name = $dest_ident->value;
+ $compiler->emit(" set_global \"$dest_name\", $temp_pmc");
+ }
+
+ return 1;
+}
+
+#
+# sax()
+#
+
+sub sax {
+ my $self = shift;
+ my ($handler) = @_;
+
+ $handler->start_element( { Name => 'assign' } );
+ $self->dest->sax($handler);
+
+ $handler->start_element( { Name => 'call', Attributes => { name => $self->name->value } } );
+ $_->sax($handler) foreach $self->args;
+ $handler->end_element( { Name => 'call' } );
+
+ $handler->end_element( { Name => 'assign' } );
+}
+
+1;
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: jako/trunk/lib/Jako/Construct/Expression/Infix.pm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/lib/Jako/Construct/Expression/Infix.pm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,36 @@
+#
+# Infix.pm
+#
+# Copyright (C) 2002-2005, Parrot Foundation.
+# This program is free software. It is subject to the same license
+# as the Parrot interpreter.
+#
+# $Id$
+#
+
+use strict;
+use warnings;
+
+package Jako::Construct::Expression::Infix;
+
+use base qw(Jako::Construct::Expression);
+
+sub new {
+ my $class = shift;
+ my ( $left, $op, $right );
+
+ return bless {
+ LEFT => $left,
+ OP => $op,
+ RIGHT => $right,
+ }, $class;
+}
+
+1;
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: jako/trunk/lib/Jako/Construct/Expression/Prefix.pm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/lib/Jako/Construct/Expression/Prefix.pm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,35 @@
+#
+# Prefix.pm
+#
+# Copyright (C) 2002-2005, Parrot Foundation.
+# This program is free software. It is subject to the same license
+# as the Parrot interpreter.
+#
+# $Id$
+#
+
+use strict;
+use warnings;
+
+package Jako::Construct::Expression::Prefix;
+
+use base qw(Jako::Construct::Expression);
+
+sub new {
+ my $class = shift;
+ my ( $op, $right );
+
+ return bless {
+ OP => $op,
+ RIGHT => $right
+ }, $class;
+}
+
+1;
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: jako/trunk/lib/Jako/Construct/Expression/Suffix.pm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/lib/Jako/Construct/Expression/Suffix.pm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,35 @@
+#
+# Suffix.pm
+#
+# Copyright (C) 2002-2005, Parrot Foundation.
+# This program is free software. It is subject to the same license
+# as the Parrot interpreter.
+#
+# $Id$
+#
+
+use strict;
+use warnings;
+
+package Jako::Construct::Expression::Suffix;
+
+use base qw(Jako::Construct::Expression);
+
+sub new {
+ my $class = shift;
+ my ( $left, $op );
+
+ return bless {
+ LEFT => $left,
+ OP => $op
+ }, $class;
+}
+
+1;
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: jako/trunk/lib/Jako/Construct/Expression/Value.pm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/lib/Jako/Construct/Expression/Value.pm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,63 @@
+#
+# Value.pm
+#
+# Copyright (C) 2002-2005, Parrot Foundation.
+# This program is free software. It is subject to the same license
+# as the Parrot interpreter.
+#
+# $Id$
+#
+
+use strict;
+use warnings;
+
+package Jako::Construct::Expression::Value;
+
+use base qw(Jako::Construct::Expression);
+
+use Jako::Token;
+
+use Jako::Construct::Expression::Value::Literal;
+use Jako::Construct::Expression::Value::Identifier;
+
+sub new {
+ my $class = shift;
+ my ( $block, $token ) = @_;
+
+ confess "Block undefined." unless defined $block;
+ confess "Token undefined." unless defined $token;
+
+ return Jako::Construct::Expression::Value::Identifier->new( $block, $token )
+ if $token->kind eq 'ident';
+ return Jako::Construct::Expression::Value::Literal->new( $block, $token )
+ if $token->kind eq 'literal';
+
+ return undef;
+}
+
+sub block { return shift->{BLOCK}; }
+sub token { return shift->{TOKEN}; }
+sub type { return shift->{TYPE}; }
+sub value { return shift->{VALUE}; }
+
+#
+# compile()
+#
+# Essentially a no-op for values (except string literals... q.v.).
+#
+
+sub compile {
+ my $self = shift;
+ my ($compiler) = @_;
+
+ return $self->value;
+}
+
+1;
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: jako/trunk/lib/Jako/Construct/Expression/Value/Identifier.pm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/lib/Jako/Construct/Expression/Value/Identifier.pm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,112 @@
+#
+# Identifier.pm
+#
+# Copyright (C) 2002-2005, Parrot Foundation.
+# This program is free software. It is subject to the same license
+# as the Parrot interpreter.
+#
+# $Id$
+#
+
+use strict;
+use warnings;
+
+use Carp;
+
+package Jako::Construct::Expression::Value::Identifier;
+
+use Carp;
+
+use base qw(Jako::Construct::Expression::Value);
+
+sub new {
+ my $class = shift;
+ my ( $block, $token ) = @_;
+
+ confess "Block is not!" unless UNIVERSAL::isa( $block, 'Jako::Construct::Block' );
+ confess "Token is not!" unless UNIVERSAL::isa( $token, 'Jako::Token' );
+
+ return bless {
+ BLOCK => $block,
+
+ TOKEN => $token,
+ VALUE => $token->text,
+ SCOPE => $block->scope_of_ident( $token->text ),
+ ACCESS => $block->access_of_ident( $token->text ),
+ TYPE => $block->type_of_ident( $token->text ),
+ KIND => $block->kind_of_ident( $token->text ),
+
+ DEBUG => 1,
+ FILE => $token->file,
+ LINE => $token->line
+ }, $class;
+}
+
+sub kind { return shift->{KIND}; }
+sub scope { return shift->{SCOPE}; }
+
+#
+# compile2
+#
+
+sub compile2 {
+ my $class = shift;
+ my ( $compiler, $block, $ident_name, $kind, $scope, $type ) = @_;
+
+ confess "No \$compiler!" unless $compiler;
+
+ my $sym = $block->find_symbol($ident_name);
+
+ confess "No such symbol '$ident_name'!" unless defined $sym;
+
+ if ( ( $kind eq 'var' ) and ( $scope eq 'global' ) ) {
+ my $imcc_code = $type->code();
+ my $temp_reg = $compiler->temp_reg($imcc_code);
+
+ my $pmc_type = $type->imcc_pmc();
+ my $temp_pmc = $compiler->temp_pmc();
+
+ $compiler->emit(" $temp_pmc = new '$pmc_type'");
+ $compiler->emit(" $temp_pmc = get_global \"$ident_name\"");
+ $compiler->emit(" $temp_reg = $temp_pmc");
+
+ return $temp_reg;
+ }
+ else {
+ return $ident_name;
+ }
+}
+
+#
+# compile()
+#
+
+sub compile {
+ my $self = shift;
+ my ($compiler) = @_;
+
+ return Jako::Construct::Expression::Value::Identifier->compile2( $compiler, $self->block,
+ $self->value, $self->kind, $self->scope, $self->type );
+}
+
+#
+# sax()
+#
+
+sub sax {
+ my $self = shift;
+ my ($handler) = @_;
+
+ $handler->start_element( { Name => 'ident', Attributes => { name => $self->value } } );
+ $handler->end_element( { Name => 'ident' } );
+}
+
+1;
+
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: jako/trunk/lib/Jako/Construct/Expression/Value/Literal.pm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/lib/Jako/Construct/Expression/Value/Literal.pm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,200 @@
+#
+# Literal.pm
+#
+# Copyright (C) 2002-2005, Parrot Foundation.
+# This program is free software. It is subject to the same license
+# as the Parrot interpreter.
+#
+# $Id$
+#
+
+use strict;
+use warnings;
+
+package Jako::Construct::Expression::Value::Literal;
+
+use Carp;
+
+use base qw(Jako::Construct::Expression::Value);
+
+sub new {
+ my $class = shift;
+ my ( $block, $token ) = @_;
+
+ return bless {
+ BLOCK => $block,
+
+ TOKEN => $token,
+ TYPE => Jako::Construct::Type->new( $token->type ),
+ VALUE => $token->text,
+
+ DEBUG => 1,
+ FILE => $token->file,
+ LINE => $token->line
+ }, $class;
+}
+
+#
+# compile()
+#
+# By default, compiling a literal does nothing, returning you
+# the literal for you to use in other compilations. But, string
+# literals are subject to interpolation, and so they go through
+# compilation in such a way that a string register value results
+# for use by further compilations. This register value is
+# returned to the caller.
+#
+# Converts a single string argument:
+#
+# "Foo $a ${b}ar\n"
+#
+# to multiple arguments:
+#
+# "Foo ", a, " ", b, "ar ", b, "\n"
+#
+# to effect string interpolation.
+#
+
+sub compile {
+ my $self = shift;
+ my ($compiler) = @_;
+
+ confess "No Compiler!" unless defined $compiler;
+
+ my $type = $self->type;
+
+ # $self->DEBUG(0, "Compiling literal of type: '%s'...", ref $type);
+
+ if ( UNIVERSAL::isa( $type, 'Jako::Construct::Type::String' ) ) {
+ my $string = $self->value;
+
+ # $self->DEBUG(0, "Compiling string literal: '%s'...", $self->value);
+
+ return $string unless $string =~ m/(^"|^".*?[^\\])\$/; # Double-quote with an unescaped '$'.
+
+ $string = substr( $string, 1, -1 ); # Without the surrounding double quotes.
+
+ my $temp = $compiler->temp_str(); # Allocate and clear a temporary string register
+
+ $compiler->emit(" $temp = \"\"");
+
+ while (1) {
+ last
+ unless defined $string
+ and $string =~
+ m/(^|^.*?[^\\])\$((([A-Za-z][A-Za-z0-9_]*)\b)|({[A-Za-z][A-Za-z0-9_]*}))(.*)$/;
+
+ $compiler->emit(" concat $temp, \"$1\"")
+ if defined $1 and $1 ne '';
+
+ my $ident = $2;
+ $ident =~ s/^{(.*)}$/$1/; # Strip '{' and '}'.
+
+ my $sym = $self->block->find_symbol($ident);
+
+ $ident =
+ Jako::Construct::Expression::Value::Identifier->compile2( $compiler, $self->block,
+ $ident, $sym->kind, $sym->scope, $sym->type );
+
+ $self->EXCEPTION_SYNTAX_ERROR( "Cannot interpolate '%s': symbol not found!", $ident )
+ unless $sym;
+
+ if ( not UNIVERSAL::isa( $sym->type, 'Jako::Construct::Type::String' ) ) {
+ my $temp2 = $compiler->temp_str();
+ $compiler->emit(" $temp2 = $ident");
+ $ident = $temp2;
+ }
+
+ $compiler->emit(" concat $temp, $ident");
+
+ $string = $6;
+ }
+
+ $compiler->emit(" concat $temp, \"$string\"")
+ if defined $string and $string ne '';
+
+ return $temp;
+ }
+ else {
+
+ # $self->DEBUG(0, "Compiling non-string literal: '%s'...", $self->value);
+
+ return $self->value;
+ }
+}
+
+#
+# sax()
+#
+# TODO: Convert escapes. For example, "\n" should be an actual newline.
+#
+
+sub sax {
+ my $self = shift;
+ my ($handler) = @_;
+
+ my $type = $self->type;
+
+ if ( UNIVERSAL::isa( $type, 'Jako::Construct::Type::String' ) ) {
+ my $string = $self->value;
+
+ if ( $string =~ m/(^"|^".*?[^\\])\$/ ) { # Double-quote with an unescaped '$'.
+ $string = substr( $string, 1, -1 ); # Without the surrounding double quotes.
+
+ $handler->start_element( { Name => 'concat' } );
+
+ while (1) {
+ last
+ unless defined $string
+ and $string =~
+ m/(^|^.*?[^\\])\$((([A-Za-z][A-Za-z0-9_]*)\b)|({[A-Za-z][A-Za-z0-9_]*}))(.*)$/;
+
+ if ( defined $1 and $1 ne '' ) {
+ $handler->start_element(
+ { Name => 'literal', Attributes => { type => $type->name } } );
+ $handler->characters( { Data => $1 } );
+ $handler->end_element( { Name => 'literal' } );
+ }
+
+ my $ident = $2;
+ $ident =~ s/^{(.*)}$/$1/; # Strip '{' and '}'.
+
+ $handler->start_element( { Name => 'ident', Attributes => { name => $ident } } );
+ $handler->end_element( { Name => 'ident' } );
+
+ $string = $6;
+ }
+
+ if ( defined $string and $string ne '' ) {
+ $handler->start_element(
+ { Name => 'literal', Attributes => { type => $type->name } } );
+ $handler->characters( { Data => $string } );
+ $handler->end_element( { Name => 'literal' } );
+ }
+
+ $handler->end_element( { Name => 'concat' } );
+ }
+ else {
+ $string = substr( $string, 1, -1 ); # Without the surrounding quotes.
+
+ $handler->start_element( { Name => 'literal', Attributes => { type => $type->name } } );
+ $handler->characters( { Data => $string } );
+ $handler->end_element( { Name => 'literal' } );
+ }
+ }
+ else {
+ $handler->start_element( { Name => 'literal', Attributes => { type => $type->name } } );
+ $handler->characters( { Data => $self->value } );
+ $handler->end_element( { Name => 'literal' } );
+ }
+}
+
+1;
+
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: jako/trunk/lib/Jako/Construct/Label.pm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/lib/Jako/Construct/Label.pm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,90 @@
+#
+# Label.pm
+#
+# Copyright (C) 2002-2005, Parrot Foundation.
+# This program is free software. It is subject to the same license
+# as the Parrot interpreter.
+#
+# $Id$
+#
+
+use strict;
+use warnings;
+
+package Jako::Construct::Label;
+
+use Carp;
+
+use base qw(Jako::Construct);
+
+1;
+
+#
+# new()
+#
+
+sub new {
+ my $class = shift;
+ my ( $block, $ident ) = @_;
+
+ confess "Block is not!" unless UNIVERSAL::isa( $block, 'Jako::Construct::Block' );
+ confess "Ident is not!"
+ unless UNIVERSAL::isa( $ident, 'Jako::Construct::Expression::Value::Identifier' );
+
+ my $self = bless {
+ BLOCK => $block,
+
+ IDENT => $ident,
+
+ DEBUG => 1,
+ FILE => $ident->file,
+ LINE => $ident->line
+ }, $class;
+
+ $block->push_content($self);
+
+ return $self;
+}
+
+#
+# ACCESSOR:
+#
+
+sub ident { return shift->{IDENT}; }
+
+#
+# compile()
+#
+
+sub compile {
+ my $self = shift;
+ my ($compiler) = @_;
+
+ my $block = $self->block;
+ my $ident = $self->ident->value;
+
+ $compiler->emit("_LABEL_$ident:");
+
+ return;
+}
+
+#
+# sax()
+#
+
+sub sax {
+ my $self = shift;
+ my ($handler) = @_;
+
+ $handler->start_element( { Name => 'label', Attributes => { name => $self->ident->value } } );
+ $handler->end_element( { Name => 'label' } );
+}
+
+1;
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: jako/trunk/lib/Jako/Construct/Statement.pm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/lib/Jako/Construct/Statement.pm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,26 @@
+#
+# Statement.pm
+#
+# Copyright (C) 2002-2005, Parrot Foundation.
+# This program is free software. It is subject to the same license
+# as the Parrot interpreter.
+#
+# $Id$
+#
+
+use strict;
+use warnings;
+
+package Jako::Construct::Statement;
+
+use base qw(Jako::Construct);
+
+1;
+
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: jako/trunk/lib/Jako/Construct/Statement/Arithmetic.pm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/lib/Jako/Construct/Statement/Arithmetic.pm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,203 @@
+#
+# Arithmetic.pm
+#
+# Copyright (C) 2002-2005, Parrot Foundation.
+# This program is free software. It is subject to the same license
+# as the Parrot interpreter.
+#
+# $Id$
+#
+
+use strict;
+use warnings;
+
+package Jako::Construct::Statement::Arithmetic;
+
+use Carp;
+
+use base qw(Jako::Construct::Statement);
+
+sub new {
+ my $class = shift;
+ my ( $block, $dest, $left, $op, $right ) = @_;
+
+ confess( "Block (" . ref($block) . ") not!" )
+ unless UNIVERSAL::isa( $block, 'Jako::Construct::Block' );
+ confess( "Dest (" . ref($dest) . ") is not Identifier!" )
+ unless UNIVERSAL::isa( $dest, 'Jako::Construct::Expression::Value::Identifier' );
+ confess( "Left (" . ref($left) . ") is not Value" )
+ unless UNIVERSAL::isa( $left, 'Jako::Construct::Expression::Value' );
+ confess( "Right (" . ref($right) . ") is not Value" )
+ unless UNIVERSAL::isa( $right, 'Jako::Construct::Expression::Value' );
+
+ my $self = bless {
+ BLOCK => $block,
+
+ DEST => $dest,
+ LEFT => $left,
+ OP => $op,
+ RIGHT => $right,
+
+ DEBUG => 1,
+ FILE => $dest->file,
+ LINE => $dest->line
+ }, $class;
+
+ $block->push_content($self);
+
+ return $self;
+}
+
+sub dest { return shift->{DEST}; }
+sub left { return shift->{LEFT}; }
+sub op { return shift->{OP}; }
+sub right { return shift->{RIGHT}; }
+
+#
+# compile()
+#
+
+sub compile {
+ my $self = shift;
+ my ($compiler) = @_;
+
+ my $dest_ident = $self->dest;
+
+ my $block = $self->block;
+ my $dest = $self->dest;
+ my $left = $self->left;
+ my $op = $self->op;
+ my $right = $self->right;
+
+ my $dest_sym = $block->find_symbol( $dest->value );
+ $self->EXCEPTION_SYNTAX_ERROR( "Assigning to unknown variable %s.", $dest->value ) unless $dest_sym;
+ my $dest_type = $dest_sym->type;
+
+ my $left_type;
+ if ( UNIVERSAL::isa( $left, 'Jako::Construct::Expression::Value::Identifier' ) ) {
+ my $left_sym = $block->find_symbol( $left->value );
+ $self->EXCEPTION_SYNTAX_ERROR( "Expression involves unknown variable %s.", $left->value )
+ unless $left_sym;
+ $left_type = $left_sym->type;
+ }
+ else {
+ $left_type = $left->type;
+ }
+
+ my $right_type;
+ if ( UNIVERSAL::isa( $right, 'Jako::Construct::Expression::Value::Identifier' ) ) {
+ my $right_sym = $block->find_symbol( $right->value );
+ $self->EXCEPTION_SYNTAX_ERROR( "Expression involves unknown variable %s.", $right->value )
+ unless $right_sym;
+ $right_type = $right_sym->type;
+ }
+ else {
+ $right_type = $right->type;
+ }
+
+ # $self->DEBUG(0, "Arithmetic with dest type $dest_type...");
+ # $self->DEBUG(0, "Arithmetic with left type $left_type...");
+ # $self->DEBUG(0, "Arithmetic with right type $right_type...");
+
+ $self->INTERNAL_ERROR("No type for dest!") unless defined $dest_type;
+ $self->INTERNAL_ERROR("No type for left!") unless defined $left_type;
+ $self->INTERNAL_ERROR("No type for right!") unless defined $right_type;
+
+ $self->EXCEPTION_SYNTAX_ERROR("Can't do arithmetic on strings")
+ if UNIVERSAL::isa( $dest_type, 'Jako::Construct::Type::String' );
+ $self->EXCEPTION_SYNTAX_ERROR("Can't do arithmetic on strings")
+ if UNIVERSAL::isa( $left_type, 'Jako::Construct::Type::String' );
+ $self->EXCEPTION_SYNTAX_ERROR("Can't do arithmetic on strings")
+ if UNIVERSAL::isa( $right_type, 'Jako::Construct::Type::String' );
+
+ $self->EXCEPTION_SYNTAX_ERROR("Can't do arithmetic on PMCs")
+ if UNIVERSAL::isa( $dest_type, 'Jako::Construct::Type::PMC' );
+ $self->EXCEPTION_SYNTAX_ERROR("Can't do arithmetic on PMCs")
+ if UNIVERSAL::isa( $left_type, 'Jako::Construct::Type::PMC' );
+ $self->EXCEPTION_SYNTAX_ERROR("Can't do arithmetic on PMCs")
+ if UNIVERSAL::isa( $right_type, 'Jako::Construct::Type::PMC' );
+
+ my $calc_type = $left_type;
+ $calc_type = $right_type if UNIVERSAL::isa( $right_type, 'Jako::Construct::Type::Number' );
+
+ # $self->DEBUG(0, " ...calc type $calc_type...");
+
+ unless ( $left_type->name eq $calc_type->name ) {
+
+ # $self->DEBUG(0, " ...converting left...");
+ my $temp = $compiler->temp_reg($calc_type);
+ $left = $left->compile($compiler);
+ $compiler->emit(" $temp = $left");
+ $left = $temp;
+ }
+ else {
+ $left = $left->compile($compiler);
+ }
+
+ unless ( $right_type->name eq $calc_type->name ) {
+
+ # $self->DEBUG(0, " ...converting right...");
+ my $temp = $compiler->temp_reg($calc_type);
+ $right = $right->compile($compiler);
+ $compiler->emit(" $temp = $right");
+ $right = $temp;
+ }
+ else {
+ $right = $right->compile($compiler);
+ }
+
+ my $dest_name = $dest->value;
+ $dest = $dest->compile($compiler);
+
+ unless ( $dest_type->name eq $calc_type->name ) {
+ my $temp = $compiler->temp_reg($calc_type);
+ $compiler->emit(" $temp = $left $op $right");
+ $compiler->emit(" $dest = $temp");
+ }
+ else {
+ $compiler->emit(" $dest = $left $op $right");
+ }
+
+ if ( ( $dest_ident->kind eq 'var' ) and ( $dest_ident->scope eq 'global' ) ) {
+ my $pmc_type = $dest_ident->type->imcc_pmc;
+ my $pmc_reg = $compiler->temp_pmc();
+
+ $compiler->emit(" $pmc_reg = new '$pmc_type'");
+ $compiler->emit(" $pmc_reg = $dest");
+ $compiler->emit(" set_global \"$dest_name\", $pmc_reg");
+ }
+
+ return 1;
+}
+
+#
+# sax()
+#
+
+sub sax {
+ my $self = shift;
+ my ($handler) = @_;
+
+ my $block = $self->block;
+ my $dest = $self->dest;
+ my $left = $self->left;
+ my $op = $self->op;
+ my $right = $self->right;
+
+ $handler->start_element( { Name => 'assign' } );
+ $dest->sax($handler);
+ $handler->start_element( { Name => 'op', Attributes => { kind => 'infix', name => $op } } );
+ $left->sax($handler);
+ $right->sax($handler);
+ $handler->end_element( { Name => 'op' } );
+ $handler->end_element( { Name => 'assign' } );
+}
+
+1;
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: jako/trunk/lib/Jako/Construct/Statement/Assign.pm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/lib/Jako/Construct/Statement/Assign.pm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,93 @@
+#
+# Assign.pm
+#
+# Copyright (C) 2002-2005, Parrot Foundation.
+# This program is free software. It is subject to the same license
+# as the Parrot interpreter.
+#
+# $Id$
+#
+
+use strict;
+use warnings;
+
+package Jako::Construct::Statement::Assign;
+
+use Carp;
+
+use base qw(Jako::Construct::Statement);
+
+sub new {
+ my $class = shift;
+ my ( $block, $left, $right ) = @_;
+
+ confess( "Block (" . ref($block) . ") not!" )
+ unless UNIVERSAL::isa( $block, 'Jako::Construct::Block' );
+ confess( "Left (" . ref($left) . ") is not Value" )
+ unless UNIVERSAL::isa( $left, 'Jako::Construct::Expression::Value' );
+ confess( "Right (" . ref($right) . ") is not Value" )
+ unless UNIVERSAL::isa( $right, 'Jako::Construct::Expression::Value' );
+
+ my $self = bless {
+ BLOCK => $block,
+ LEFT => $left,
+ RIGHT => $right
+ }, $class;
+
+ $block->push_content($self);
+
+ return $self;
+}
+
+sub left { return shift->{LEFT}; }
+sub right { return shift->{RIGHT}; }
+
+#
+# compile()
+#
+
+sub compile {
+ my $self = shift;
+ my ($compiler) = @_;
+
+ my $left = $self->left->value;
+ my $right = $self->right->compile($compiler);
+
+ if ( $self->block->scope_of_ident($left) eq 'global' ) {
+ my $type = $self->block->type_of_ident($left);
+ my $pmc_type = $type->imcc_pmc;
+ my $temp_pmc = $compiler->temp_pmc();
+
+ $compiler->emit(" $temp_pmc = new '$pmc_type'");
+ $compiler->emit(" $temp_pmc = $right");
+ $compiler->emit(" set_global \"$left\", $temp_pmc");
+ }
+ else {
+ $compiler->emit(" $left = $right");
+ }
+
+ return 1;
+}
+
+#
+# sax()
+#
+
+sub sax {
+ my $self = shift;
+ my ($handler) = @_;
+
+ $handler->start_element( { Name => 'assign' } );
+ $self->left->sax($handler);
+ $self->right->sax($handler);
+ $handler->end_element( { Name => 'assign' } );
+}
+
+1;
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: jako/trunk/lib/Jako/Construct/Statement/Bitwise.pm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/lib/Jako/Construct/Statement/Bitwise.pm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,123 @@
+#
+# Bitwise.pm
+#
+# Copyright (C) 2002-2005, Parrot Foundation.
+# This program is free software. It is subject to the same license
+# as the Parrot interpreter.
+#
+# $Id$
+#
+
+use strict;
+use warnings;
+
+package Jako::Construct::Statement::Bitwise;
+
+use Carp;
+
+use base qw(Jako::Construct::Statement);
+
+sub new {
+ my $class = shift;
+ my ( $block, $dest, $left, $op, $right ) = @_;
+
+ confess( "Block (" . ref($block) . ") not!" )
+ unless UNIVERSAL::isa( $block, 'Jako::Construct::Block' );
+ confess( "Dest (" . ref($dest) . ") is not Identifier!" )
+ unless UNIVERSAL::isa( $dest, 'Jako::Construct::Expression::Value::Identifier' );
+ confess( "Left (" . ref($left) . ") is not Value" )
+ unless UNIVERSAL::isa( $left, 'Jako::Construct::Expression::Value' );
+ confess( "Right (" . ref($right) . ") is not Value" )
+ unless UNIVERSAL::isa( $right, 'Jako::Construct::Expression::Value' );
+
+ my $self = bless {
+ BLOCK => $block,
+
+ DEST => $dest,
+ LEFT => $left,
+ OP => $op,
+ RIGHT => $right,
+
+ DEBUG => 1,
+ FILE => $dest->file,
+ LINE => $dest->line
+ }, $class;
+
+ $block->push_content($self);
+
+ return $self;
+}
+
+sub dest { return shift->{DEST}; }
+sub left { return shift->{LEFT}; }
+sub op { return shift->{OP}; }
+sub right { return shift->{RIGHT}; }
+
+#
+# compile()
+#
+
+sub compile {
+ my $self = shift;
+ my ($compiler) = @_;
+
+ my $block = $self->block;
+ my $dest = $self->dest;
+ my $left = $self->left;
+ my $op = $self->op;
+ my $right = $self->right;
+
+ my $dest_sym = $block->find_symbol( $dest->value );
+ $self->EXCEPTION_SYNTAX_ERROR( "Assigning to unknown variable %s.", $dest->value ) unless $dest_sym;
+ my $dest_type = $dest_sym->type;
+
+ my $left_type;
+ if ( UNIVERSAL::isa( $left, 'Jako::Construct::Expression::Value::Identifier' ) ) {
+ my $left_sym = $block->find_symbol( $left->value );
+ $self->EXCEPTION_SYNTAX_ERROR( "Expression involves unknown variable %s.", $left->value )
+ unless $left_sym;
+ $left_type = $left_sym->type;
+ }
+ else {
+ $left_type = $left->type;
+ }
+
+ my $right_type;
+ if ( UNIVERSAL::isa( $right, 'Jako::Construct::Expression::Value::Identifier' ) ) {
+ my $right_sym = $block->find_symbol( $right->value );
+ $self->EXCEPTION_SYNTAX_ERROR( "Expression involves unknown variable %s.", $right->value )
+ unless $right_sym;
+ $right_type = $right_sym->type;
+ }
+ else {
+ $right_type = $right->type;
+ }
+
+ $self->INTERNAL_ERROR("No type for dest!") unless defined $dest_type;
+ $self->INTERNAL_ERROR("No type for left!") unless defined $left_type;
+ $self->INTERNAL_ERROR("No type for right!") unless defined $right_type;
+
+ $self->EXCEPTION_SYNTAX_ERROR("Can only do bitwise ops on integers")
+ unless UNIVERSAL::isa( $dest_type, 'Jako::Construct::Type::Integer' );
+ $self->EXCEPTION_SYNTAX_ERROR("Can only do bitwise ops on integers")
+ unless UNIVERSAL::isa( $left_type, 'Jako::Construct::Type::Integer' );
+ $self->EXCEPTION_SYNTAX_ERROR("Can only do bitwise ops on integers")
+ unless UNIVERSAL::isa( $right_type, 'Jako::Construct::Type::Integer' );
+
+ $dest = $dest->value;
+ $left = $left->compile($compiler);
+ $right = $right->compile($compiler);
+
+ $compiler->emit(" $dest = $left $op $right");
+
+ return 1;
+}
+
+1;
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: jako/trunk/lib/Jako/Construct/Statement/Call.pm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/lib/Jako/Construct/Statement/Call.pm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,156 @@
+#
+# Call.pm
+#
+# Copyright (C) 2002-2005, Parrot Foundation.
+# This program is free software. It is subject to the same license
+# as the Parrot interpreter.
+#
+# $Id$
+#
+
+use strict;
+use warnings;
+
+package Jako::Construct::Statement::Call;
+
+use Carp;
+
+use base qw(Jako::Construct::Statement);
+
+sub new {
+ my $class = shift;
+ my ( $block, $ident, @args ) = @_;
+
+ confess( "Block (" . ref($block) . ") is not!" )
+ unless UNIVERSAL::isa( $block, 'Jako::Construct::Block' );
+ confess( "Ident (" . ref($ident) . ") is not!" )
+ unless UNIVERSAL::isa( $ident, 'Jako::Construct::Expression::Value::Identifier' );
+
+ my $name = $ident->value;
+
+ my $self = bless {
+ BLOCK => $block,
+
+ NAME => $name,
+ ARGS => [@args],
+
+ DEBUG => 1,
+ LINE => $ident->line,
+ FILE => $ident->file
+ }, $class;
+
+ $block->push_content($self);
+
+ return $self;
+}
+
+sub name { return shift->{NAME}; }
+sub args { return @{ shift->{ARGS} }; }
+
+#
+# compile()
+#
+
+sub compile {
+ my $self = shift;
+ my ($compiler) = @_;
+
+ my $name = $self->name;
+
+ # $self->DEBUG(0, "Searching for symbol '$name'...");
+
+ my $sym = $self->block->find_symbol($name);
+
+ $self->EXCEPTION_SYNTAX_ERROR( "Call to unknown sub '%s'.", $name ) unless $sym;
+
+ my %props = $sym->props;
+
+ my @args = $self->args;
+
+ my @formal_args = $sym->args;
+
+ $self->EXCEPTION_SYNTAX_ERROR( "Wrong number of arguments (expected %d, got %d) in call to '%s'.",
+ scalar(@formal_args), scalar(@args), $name )
+ unless @formal_args == @args;
+
+ for ( my $i = 0 ; $i < @args ; $i++ ) {
+ my ( $formal_arg_type, $formal_arg_name ) = @{ $formal_args[$i] };
+ my $actual_arg_type;
+
+ if ( UNIVERSAL::isa( $args[$i], 'Jako::Construct::Expression::Value::Identifier' ) ) {
+ my $arg_sym = $self->block->find_symbol( $args[$i]->value );
+ $self->EXCEPTION_SYNTAX_ERROR( "Undefined identifier '%s'.", $args[$i]->value ) unless $arg_sym;
+ $actual_arg_type = $arg_sym->type;
+ }
+ else {
+ $actual_arg_type = $args[$i]->type;
+ }
+
+ $self->INTERNAL_ERROR( "Can't determine type of formal argument (%s)!", $formal_arg_name )
+ unless defined $formal_arg_type;
+
+ $self->INTERNAL_ERROR( "Can't determine type of actual argument (%s)!", ref $args[$i] )
+ unless defined $actual_arg_type;
+
+ if ( $formal_arg_type->name ne $actual_arg_type->name ) {
+ my $temp = $compiler->temp_reg($formal_arg_type);
+ my $value = $args[$i]->compile($compiler);
+ $compiler->emit(" $temp = $value");
+ $args[$i] = $temp;
+ }
+ else {
+ $args[$i] = $args[$i]->compile($compiler);
+ }
+ }
+
+ if ( exists $props{op} ) {
+ my $op = $props{op};
+
+ # $self->DEBUG(0, "Calling %s%s...", $name, ($op ? ' (op $op)' : ' as op'));
+
+ if ( defined $op ) {
+ $name = $op->value;
+ $name =~ s/(^"|"$)//g;
+ }
+
+ $name =~ s/^.*:://; # Strip namespaces off ops.
+
+ $compiler->emit( " $name ", join( ", ", @args ) );
+ }
+ else {
+
+# $self->DEBUG(0, "Calling '%s' as regular or NCI sub (props = %s)...", $name, join(", ", %props));
+
+ $name =~ s/::/__/g;
+
+ if ( exists $props{fn} or exists $props{fnlib} ) {
+ $name .= "_THUNK";
+ }
+
+ $compiler->emit( " _${name}(" . join( ", ", @args ) . ")" );
+ }
+
+ return 1;
+}
+
+#
+# sax()
+#
+
+sub sax {
+ my $self = shift;
+ my ($handler) = @_;
+
+ $handler->start_element( { Name => 'call', Attributes => { name => $self->name } } );
+ $_->sax($handler) foreach $self->args;
+ $handler->end_element( { Name => 'call' } );
+}
+
+1;
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: jako/trunk/lib/Jako/Construct/Statement/Concat.pm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/lib/Jako/Construct/Statement/Concat.pm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,152 @@
+#
+# Conct.pm
+#
+# Copyright (C) 2006-2007, Parrot Foundation.
+# This program is free software. It is subject to the same license
+# as the Parrot interpreter.
+#
+# $Id$
+#
+
+use strict;
+use warnings;
+
+package Jako::Construct::Statement::Concat;
+
+use Carp;
+
+use base qw(Jako::Construct::Statement);
+
+sub new {
+ my $class = shift;
+ my ( $block, $dest, $left, $op, $right ) = @_;
+
+ confess( "Block (" . ref($block) . ") not!" )
+ unless UNIVERSAL::isa( $block, 'Jako::Construct::Block' );
+ confess( "Dest (" . ref($dest) . ") is not Identifier!" )
+ unless UNIVERSAL::isa( $dest, 'Jako::Construct::Expression::Value::Identifier' );
+ confess( "Left (" . ref($left) . ") is not Value" )
+ unless UNIVERSAL::isa( $left, 'Jako::Construct::Expression::Value' );
+ confess( "Right (" . ref($right) . ") is not Value" )
+ unless UNIVERSAL::isa( $right, 'Jako::Construct::Expression::Value' );
+
+ my $self = bless {
+ BLOCK => $block,
+
+ DEST => $dest,
+ LEFT => $left,
+ OP => $op,
+ RIGHT => $right,
+
+ DEBUG => 1,
+ FILE => $dest->file,
+ LINE => $dest->line
+ }, $class;
+
+ $block->push_content($self);
+
+ return $self;
+}
+
+sub dest { return shift->{DEST}; }
+sub left { return shift->{LEFT}; }
+sub op { return shift->{OP}; }
+sub right { return shift->{RIGHT}; }
+
+#
+# compile()
+#
+
+sub compile {
+ my $self = shift;
+ my ($compiler) = @_;
+
+ my $dest_ident = $self->dest;
+
+ my $block = $self->block;
+ my $dest = $self->dest;
+ my $left = $self->left;
+ my $op = $self->op;
+ my $right = $self->right;
+
+ my $dest_sym = $block->find_symbol( $dest->value );
+ $self->EXCEPTION_SYNTAX_ERROR( "Assigning to unknown variable %s.", $dest->value ) unless $dest_sym;
+ my $dest_type = $dest_sym->type;
+
+ my $left_type;
+ if ( UNIVERSAL::isa( $left, 'Jako::Construct::Expression::Value::Identifier' ) ) {
+ my $left_sym = $block->find_symbol( $left->value );
+ $self->EXCEPTION_SYNTAX_ERROR( "Expression involves unknown variable %s.", $left->value )
+ unless $left_sym;
+ $left_type = $left_sym->type;
+ }
+ else {
+ $left_type = $left->type;
+ }
+
+ my $right_type;
+ if ( UNIVERSAL::isa( $right, 'Jako::Construct::Expression::Value::Identifier' ) ) {
+ my $right_sym = $block->find_symbol( $right->value );
+ $self->EXCEPTION_SYNTAX_ERROR( "Expression involves unknown variable %s.", $right->value )
+ unless $right_sym;
+ $right_type = $right_sym->type;
+ }
+ else {
+ $right_type = $right->type;
+ }
+
+ $self->INTERNAL_ERROR("No type for dest!") unless defined $dest_type;
+ $self->INTERNAL_ERROR("No type for left!") unless defined $left_type;
+ $self->INTERNAL_ERROR("No type for right!") unless defined $right_type;
+
+ $left = $left->compile($compiler);
+ $right = $right->compile($compiler);
+
+ my $dest_name = $dest->value;
+ $dest = $dest->compile($compiler);
+
+ $compiler->emit(" concat $dest, $left, $right");
+
+ if ( ( $dest_ident->kind eq 'var' ) and ( $dest_ident->scope eq 'global' ) ) {
+ my $pmc_type = $dest_ident->type->imcc_pmc;
+ my $pmc_reg = $compiler->temp_pmc();
+
+ $compiler->emit(" $pmc_reg = new '$pmc_type'");
+ $compiler->emit(" $pmc_reg = $dest");
+ $compiler->emit(" set_global \"$dest_name\", $pmc_reg");
+ }
+
+ return 1;
+}
+
+#
+# sax()
+#
+
+sub sax {
+ my $self = shift;
+ my ($handler) = @_;
+
+ my $block = $self->block;
+ my $dest = $self->dest;
+ my $left = $self->left;
+ my $op = $self->op;
+ my $right = $self->right;
+
+ $handler->start_element( { Name => 'assign' } );
+ $dest->sax($handler);
+ $handler->start_element( { Name => 'op', Attributes => { kind => 'infix', name => $op } } );
+ $left->sax($handler);
+ $right->sax($handler);
+ $handler->end_element( { Name => 'op' } );
+ $handler->end_element( { Name => 'assign' } );
+}
+
+1;
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: jako/trunk/lib/Jako/Construct/Statement/Decrement.pm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/lib/Jako/Construct/Statement/Decrement.pm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,86 @@
+#
+# Decrement.pm
+#
+# Copyright (C) 2002-2005, Parrot Foundation.
+# This program is free software. It is subject to the same license
+# as the Parrot interpreter.
+#
+# $Id$
+#
+
+use strict;
+use warnings;
+
+package Jako::Construct::Statement::Decrement;
+
+use Carp;
+
+use base qw(Jako::Construct::Statement);
+
+sub new {
+ my $class = shift;
+ my ( $block, $ident ) = @_;
+
+ confess( "Block (" . ref($block) . ") not!" )
+ unless UNIVERSAL::isa( $block, 'Jako::Construct::Block' );
+ confess( "Identifier (" . ref($ident) . ") is not!" )
+ unless UNIVERSAL::isa( $ident, 'Jako::Construct::Expression::Value::Identifier' );
+
+ my $self = bless {
+ BLOCK => $block,
+ IDENT => $ident
+ }, $class;
+
+ $block->push_content($self);
+
+ return $self;
+}
+
+sub ident { return shift->{IDENT}; }
+
+#
+# compile()
+#
+
+sub compile {
+ my $self = shift;
+ my ($compiler) = @_;
+
+ my $ident_name = $self->ident->value;
+
+ my $ident = $self->ident->compile($compiler);
+
+ $compiler->emit(" dec $ident");
+
+ if ( ( $self->ident->kind eq 'var' ) and ( $self->ident->scope eq 'global' ) ) {
+ my $pmc_type = $self->ident->type->imcc_pmc;
+ my $pmc_reg = $compiler->temp_pmc();
+ $compiler->emit(" $pmc_reg = new '$pmc_type'");
+ $compiler->emit(" $pmc_reg = $ident");
+ $compiler->emit(" set_global \"$ident_name\", $pmc_reg");
+ }
+
+ return 1;
+}
+
+#
+# sax()
+#
+
+sub sax {
+ my $self = shift;
+ my ($handler) = @_;
+
+ $handler->start_element( { Name => 'op', Attributes => { kind => 'postfix', name => '--' } } );
+ $self->ident->sax($handler);
+ $handler->end_element( { Name => 'op' } );
+}
+
+1;
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: jako/trunk/lib/Jako/Construct/Statement/Goto.pm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/lib/Jako/Construct/Statement/Goto.pm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,147 @@
+#
+# Goto.pm
+#
+# Copyright (C) 2002-2005, Parrot Foundation.
+# This program is free software. It is subject to the same license
+# as the Parrot interpreter.
+#
+# $Id$
+#
+
+use strict;
+use warnings;
+
+package Jako::Construct::Statement::Goto;
+
+use Carp;
+
+use base qw(Jako::Construct::Statement);
+
+my %block_types = (
+ 'while' => { PREFIX => "_W", NEXT => 'CONT', REDO => 'REDO', LAST => 'LAST' },
+ 'if' => { PREFIX => "_I", NEXT => 'TEST', REDO => 'THEN', LAST => 'ELSE' },
+ 'sub' => { PREFIX => "_S", NEXT => 'TEST', REDO => 'THEN', LAST => 'ELSE' }, # TODO: fix these
+);
+
+#
+# new()
+#
+
+sub new {
+ my $class = shift;
+ my ( $block, $ident, $cond, $left, $op, $right ) = @_;
+
+ confess "Block is not!" unless UNIVERSAL::isa( $block, 'Jako::Construct::Block' );
+ confess "Ident is not!"
+ if defined $ident
+ and not UNIVERSAL::isa( $ident, 'Jako::Construct::Expression::Value::Identifier' );
+ confess "Left is not Value!"
+ if defined $left and not UNIVERSAL::isa( $left, 'Jako::Construct::Expression::Value' );
+ confess "Right is not Value!"
+ if defined $right and not UNIVERSAL::isa( $right, 'Jako::Construct::Expression::Value' );
+
+ my $self = bless {
+ BLOCK => $block,
+
+ IDENT => $ident,
+ COND => $cond,
+ LEFT => $left,
+ OP => $op,
+ RIGHT => $right,
+
+ DEBUG => 1,
+ FILE => $ident->file,
+ LINE => $ident->line
+ }, $class;
+
+ $block->push_content($self);
+
+ return $self;
+}
+
+#
+# ACCESSORS:
+#
+
+sub ident { return shift->{IDENT}; }
+sub cond { return shift->{COND}; }
+sub left { return shift->{LEFT}; }
+sub op { return shift->{OP}; }
+sub right { return shift->{RIGHT}; }
+
+#
+# compile()
+#
+
+sub compile {
+ my $self = shift;
+ my ($compiler) = @_;
+
+ my $block = $self->block;
+ my $name = $self->ident ? $self->ident->value : undef;
+ my $cond = $self->cond;
+ my $left = $self->left;
+ my $op = $self->op;
+ my $right = $self->right;
+
+ if ( !defined $cond ) {
+ $compiler->emit(" goto _LABEL_$name");
+ }
+ else {
+ $left = $left->compile($compiler);
+ $right = $right->compile($compiler);
+
+ if ( $cond eq 'unless' ) {
+ $op = $compiler->invert_relop($op);
+ $cond = 'if';
+ }
+
+ $compiler->emit(" $cond $left $op $right goto _LABEL_$name");
+ }
+
+ return;
+}
+
+#
+# sax()
+#
+
+sub sax {
+ my $self = shift;
+ my ($handler) = @_;
+
+ my $block = $self->block;
+ my $name = $self->ident ? $self->ident->value : undef;
+ my $cond = $self->cond;
+ my $left = $self->left;
+ my $op = $self->op;
+ my $right = $self->right;
+
+ if ( defined $cond ) {
+ $handler->start_element( { Name => 'cond', Attributes => { kind => $cond } } );
+ $handler->start_element( { Name => 'block', Attributes => { kind => 'test' } } );
+ $handler->start_element( { Name => 'op', Attributes => { kind => 'infix', name => $op } } );
+ $left->sax($handler);
+ $right->sax($handler);
+ $handler->end_element( { Name => 'op' } );
+ $handler->end_element( { Name => 'block' } );
+ $handler->start_element( { Name => 'block', Attributes => { kind => 'then' } } );
+ }
+
+ $handler->start_element( { Name => 'goto', Attributes => { label => $name } } );
+ $handler->end_element( { Name => 'goto' } );
+
+ if ( defined $cond ) {
+ $handler->end_element( { Name => 'block' } );
+ $handler->end_element( { Name => 'cond' } );
+ }
+}
+
+1;
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: jako/trunk/lib/Jako/Construct/Statement/Increment.pm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/lib/Jako/Construct/Statement/Increment.pm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,86 @@
+#
+# Increment.pm
+#
+# Copyright (C) 2002-2005, Parrot Foundation.
+# This program is free software. It is subject to the same license
+# as the Parrot interpreter.
+#
+# $Id$
+#
+
+use strict;
+use warnings;
+
+package Jako::Construct::Statement::Increment;
+
+use Carp;
+
+use base qw(Jako::Construct::Statement);
+
+sub new {
+ my $class = shift;
+ my ( $block, $ident ) = @_;
+
+ confess( "Block (" . ref($block) . ") not!" )
+ unless UNIVERSAL::isa( $block, 'Jako::Construct::Block' );
+ confess( "Identifier (" . ref($ident) . ") is not!" )
+ unless UNIVERSAL::isa( $ident, 'Jako::Construct::Expression::Value::Identifier' );
+
+ my $self = bless {
+ BLOCK => $block,
+ IDENT => $ident
+ }, $class;
+
+ $block->push_content($self);
+
+ return $self;
+}
+
+sub ident { return shift->{IDENT}; }
+
+#
+# compile()
+#
+
+sub compile {
+ my $self = shift;
+ my ($compiler) = @_;
+
+ my $ident_name = $self->ident->value;
+
+ my $ident = $self->ident->compile($compiler);
+
+ $compiler->emit(" inc $ident");
+
+ if ( ( $self->ident->kind eq 'var' ) and ( $self->ident->scope eq 'global' ) ) {
+ my $pmc_type = $self->ident->type->imcc_pmc;
+ my $pmc_reg = $compiler->temp_pmc();
+ $compiler->emit(" $pmc_reg = new '$pmc_type'");
+ $compiler->emit(" $pmc_reg = $ident");
+ $compiler->emit(" set_global \"$ident_name\", $pmc_reg");
+ }
+
+ return 1;
+}
+
+#
+# sax()
+#
+
+sub sax {
+ my $self = shift;
+ my ($handler) = @_;
+
+ $handler->start_element( { Name => 'op', Attributes => { kind => 'postfix', name => '++' } } );
+ $self->ident->sax($handler);
+ $handler->end_element( { Name => 'op' } );
+}
+
+1;
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: jako/trunk/lib/Jako/Construct/Statement/LoopControl.pm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/lib/Jako/Construct/Statement/LoopControl.pm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,180 @@
+#
+# LoopControl.pm
+#
+# Copyright (C) 2002-2005, Parrot Foundation.
+# This program is free software. It is subject to the same license
+# as the Parrot interpreter.
+#
+# $Id$
+#
+
+use strict;
+use warnings;
+
+package Jako::Construct::Statement::LoopControl;
+
+use Carp;
+
+use base qw(Jako::Construct::Statement);
+
+my %block_types = (
+ 'while' => { PREFIX => "_W", NEXT => 'CONT', REDO => 'REDO', LAST => 'LAST' },
+ 'if' => { PREFIX => "_I", NEXT => 'TEST', REDO => 'THEN', LAST => 'ELSE' },
+ 'sub' => { PREFIX => "_S", NEXT => 'TEST', REDO => 'THEN', LAST => 'ELSE' }, # TODO: fix these
+);
+
+#
+# new()
+#
+
+sub new {
+ my $class = shift;
+ my ( $block, $kind, $ident, $cond, $left, $op, $right ) = @_;
+
+ confess "Block is not!" unless UNIVERSAL::isa( $block, 'Jako::Construct::Block' );
+ confess "Ident is not!"
+ if defined $ident
+ and not UNIVERSAL::isa( $ident, 'Jako::Construct::Expression::Value::Identifier' );
+ confess "Left is not Value!"
+ if defined $left and not UNIVERSAL::isa( $left, 'Jako::Construct::Expression::Value' );
+ confess "Right is not Value!"
+ if defined $right and not UNIVERSAL::isa( $right, 'Jako::Construct::Expression::Value' );
+
+ my $self = bless {
+ BLOCK => $block,
+
+ KIND => $kind,
+ IDENT => $ident,
+ COND => $cond,
+ LEFT => $left,
+ OP => $op,
+ RIGHT => $right,
+
+ DEBUG => 1,
+ FILE => $ident ? $ident->file : undef, # TODO: YUCK!!!
+ LINE => $ident ? $ident->line : undef
+ }, $class;
+
+ $block->push_content($self);
+
+ return $self;
+}
+
+#
+# ACCESSORS:
+#
+
+sub kind { return shift->{KIND}; }
+sub ident { return shift->{IDENT}; }
+sub cond { return shift->{COND}; }
+sub left { return shift->{LEFT}; }
+sub op { return shift->{OP}; }
+sub right { return shift->{RIGHT}; }
+
+#
+# compile()
+#
+
+sub compile {
+ my $self = shift;
+ my ($compiler) = @_;
+
+ my $block = $self->block;
+ my $kind = $self->kind;
+ my $name = $self->ident ? $self->ident->value : undef;
+ my $cond = $self->cond;
+ my $left = $self->left;
+ my $op = $self->op;
+ my $right = $self->right;
+
+ #
+ # Locate the block we'll be applying the control statement to:
+ #
+
+ my $loop_block = $block->find_block( 'while', $name );
+
+ unless ( defined $loop_block ) {
+ if ( defined $name ) {
+ $self->EXCEPTION_SYNTAX_ERROR( "No loop '%s' in loop control.", $name );
+ }
+ else {
+ $self->EXCEPTION_SYNTAX_ERROR("No loop active in loop control.");
+ }
+ }
+
+ #
+ # Generate the code:
+ #
+
+ my $prefix = $loop_block->prefix;
+ my $suffix = $block_types{'while'}{ uc $kind };
+
+ my $label = "${prefix}_${suffix}";
+
+ if ( !defined $cond ) {
+ $compiler->emit(" goto $label");
+ }
+ else {
+ if ( $cond eq 'unless' ) {
+ $op = $compiler->invert_relop($op);
+ $cond = 'if';
+ }
+
+ $left = $left->compile($compiler);
+ $right = $right->compile($compiler);
+
+ $compiler->emit(" $cond $left $op $right goto $label");
+ }
+
+ return;
+}
+
+#
+# sax()
+#
+
+sub sax {
+ my $self = shift;
+ my ($handler) = @_;
+
+ my $block = $self->block;
+ my $kind = $self->kind;
+ my $name = $self->ident ? $self->ident->value : undef;
+ my $cond = $self->cond;
+ my $left = $self->left;
+ my $op = $self->op;
+ my $right = $self->right;
+
+ if ( defined $cond ) {
+ $handler->start_element( { Name => 'cond', Attributes => { kind => $kind } } );
+ $handler->start_element( { Name => 'block', Attributes => { kind => 'test' } } );
+ $handler->start_element( { Name => 'op', Attributes => { kind => 'infix', name => $op } } );
+ $left->sax($handler);
+ $right->sax($handler);
+ $handler->end_element( { Name => 'op' } );
+ $handler->end_element( { Name => 'block' } );
+ $handler->start_element( { Name => 'block', Attributes => { kind => 'then' } } );
+ }
+
+ if ($name) {
+ $handler->start_element( { Name => $kind, Attributes => { loop => $name } } );
+ }
+ else {
+ $handler->start_element( { Name => $kind } );
+ }
+ $handler->end_element( { Name => $kind } );
+
+ if ( defined $cond ) {
+ $handler->end_element( { Name => 'block' } );
+ $handler->end_element( { Name => 'cond' } );
+ }
+}
+
+1;
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: jako/trunk/lib/Jako/Construct/Statement/New.pm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/lib/Jako/Construct/Statement/New.pm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,81 @@
+#
+# New.pm
+#
+# Copyright (C) 2002-2005, Parrot Foundation.
+# This program is free software. It is subject to the same license
+# as the Parrot interpreter.
+#
+# $Id$
+#
+
+use strict;
+use warnings;
+
+package Jako::Construct::Statement::New;
+
+use Carp;
+
+use base qw(Jako::Construct::Statement);
+
+sub new {
+ my $class = shift;
+ my ( $block, $left, $right ) = @_;
+
+ confess( "Block (" . ref($block) . ") not!" )
+ unless UNIVERSAL::isa( $block, 'Jako::Construct::Block' );
+ confess( "Left (" . ref($left) . ") is not Value" )
+ unless UNIVERSAL::isa( $left, 'Jako::Construct::Expression::Value' );
+ confess( "Right (" . ref($right) . ") is not Identifier" )
+ unless UNIVERSAL::isa( $right, 'Jako::Construct::Expression::Value::Identifier' );
+
+ my $self = bless {
+ BLOCK => $block,
+ LEFT => $left,
+ RIGHT => $right
+ }, $class;
+
+ $block->push_content($self);
+
+ return $self;
+}
+
+sub left { return shift->{LEFT}; }
+sub right { return shift->{RIGHT}; }
+
+#
+# compile()
+#
+
+sub compile {
+ my $self = shift;
+ my ($compiler) = @_;
+
+ my $left = $self->left->value;
+ my $right = $self->right->compile($compiler);
+
+ $compiler->emit(" new $left, .$right # asdf");
+
+ return 1;
+}
+
+#
+# sax()
+#
+
+sub sax {
+ my $self = shift;
+ my ($handler) = @_;
+
+ $handler->start_element( { Name => 'new' }, { class => $self->right->value } );
+ $self->left->sax($handler);
+ $handler->end_element( { Name => 'new' } );
+}
+
+1;
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: jako/trunk/lib/Jako/Construct/Statement/Return.pm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/lib/Jako/Construct/Statement/Return.pm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,190 @@
+#
+# Return.pm
+#
+# Copyright (C) 2002-2005, Parrot Foundation.
+# This program is free software. It is subject to the same license
+# as the Parrot interpreter.
+#
+# $Id$
+#
+
+use strict;
+use warnings;
+
+package Jako::Construct::Statement::Return;
+
+use Carp;
+
+use base qw(Jako::Construct::Statement);
+
+#
+# new()
+#
+
+sub new {
+ my $class = shift;
+ my ( $block, $value, $cond, $left, $op, $right ) = @_;
+
+ confess "Block is not!" unless UNIVERSAL::isa( $block, 'Jako::Construct::Block' );
+ confess "Value is not!"
+ if defined $value and not UNIVERSAL::isa( $value, 'Jako::Construct::Expression::Value' );
+ confess "Left is not Value!"
+ if defined $left and not UNIVERSAL::isa( $left, 'Jako::Construct::Expression::Value' );
+ confess "Right is not Value!"
+ if defined $right and not UNIVERSAL::isa( $right, 'Jako::Construct::Expression::Value' );
+
+ my $self = bless {
+ BLOCK => $block,
+
+ VALUE => $value,
+ COND => $cond,
+ LEFT => $left,
+ OP => $op,
+ RIGHT => $right,
+
+ DEBUG => 1,
+ FILE => defined $value ? $value->file : undef, # TODO: YUCK!
+ LINE => defined $value ? $value->line : undef, # TODO: YUCK!
+ }, $class;
+
+ $block->push_content($self);
+
+ return $self;
+}
+
+#
+# ACCESSORS:
+#
+
+sub value { return shift->{VALUE}; }
+sub cond { return shift->{COND}; }
+sub left { return shift->{LEFT}; }
+sub op { return shift->{OP}; }
+sub right { return shift->{RIGHT}; }
+
+#
+# compile()
+#
+
+sub compile {
+ my $self = shift;
+ my ($compiler) = @_;
+
+ my $block = $self->block;
+ my $value = $self->value;
+ my $cond = $self->cond;
+ my $left = $self->left;
+ my $op = $self->op;
+ my $right = $self->right;
+
+ #
+ # Find the enclosing sub block:
+ #
+
+ my $sub_block = $block->find_block('sub');
+
+ $self->EXCEPTION_SYNTAX_ERROR("Cannot use 'return' outside of subroutine.")
+ unless ( defined $sub_block );
+
+ my $sub_name = $sub_block->name;
+
+ my $return_type = $sub_block->type;
+
+ my $anon;
+
+ if ( defined $cond ) {
+ $left = $left->compile($compiler);
+ $right = $right->compile($compiler);
+
+ if ( $cond eq 'if' ) {
+ $op = $compiler->invert_relop($op);
+ }
+ else {
+ $cond = 'if';
+ }
+
+ $anon = $compiler->anon_lbl();
+
+ $compiler->emit(" $cond $left $op $right goto $anon");
+ }
+
+ #
+ # Compile the return value, if any:
+ #
+
+ if ( defined $value ) {
+ $self->EXCEPTION_SYNTAX_ERROR("'return' with argument in subroutine that does not return a value.")
+ unless defined $return_type;
+
+ my $arg_type = $value->type;
+ my $ret_val = $value->compile($compiler);
+
+ if ( $arg_type->name ne $return_type->name )
+ { # TODO: Yuck! should be able to compare directly.
+ my $temp = $compiler->temp_reg($return_type);
+ $compiler->emit(" $temp = $ret_val");
+ $ret_val = $temp;
+ }
+
+ $compiler->emit(" .return($ret_val)");
+ }
+
+ #
+ # Go to the subroutine exit point:
+ #
+ # TODO: Isn't this really a no-op, after doing a .return(...)?
+ #
+
+ $compiler->emit(" goto _${sub_name}_LEAVE");
+
+ if ( defined $cond ) {
+ $compiler->emit("$anon:");
+ }
+
+ return;
+}
+
+#
+# sax()
+#
+
+sub sax {
+ my $self = shift;
+ my ($handler) = @_;
+
+ my $block = $self->block;
+ my $value = $self->value;
+ my $cond = $self->cond;
+ my $left = $self->left;
+ my $op = $self->op;
+ my $right = $self->right;
+
+ if ( defined $cond ) {
+ $handler->start_element( { Name => 'cond', Attributes => { kind => $cond } } );
+ $handler->start_element( { Name => 'block', Attributes => { kind => 'test' } } );
+ $handler->start_element( { Name => 'op', Attributes => { kind => 'infix', name => $op } } );
+ $left->sax($handler);
+ $right->sax($handler);
+ $handler->end_element( { Name => 'op' } );
+ $handler->end_element( { Name => 'block' } );
+ $handler->start_element( { Name => 'block', Attributes => { kind => 'then' } } );
+ }
+
+ $handler->start_element( { Name => 'return' } );
+ $value->sax($handler) if defined $value;
+ $handler->end_element( { Name => 'return' } );
+
+ if ( defined $cond ) {
+ $handler->end_element( { Name => 'block' } );
+ $handler->end_element( { Name => 'cond' } );
+ }
+}
+
+1;
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: jako/trunk/lib/Jako/Construct/Type.pm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/lib/Jako/Construct/Type.pm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,89 @@
+#
+# Type.pm
+#
+# Copyright (C) 2002-2005, Parrot Foundation.
+# This program is free software. It is subject to the same license
+# as the Parrot interpreter.
+#
+# $Id$
+#
+
+use strict;
+use warnings;
+
+package Jako::Construct::Type;
+
+use Carp;
+
+use overload
+ "==" => sub { $_[0]->code eq $_[0]->code },
+ "!=" => sub { $_[0]->code ne $_[0]->code },
+ "eq" => sub { $_[0]->code eq $_[0]->code },
+ "ne" => sub { $_[0]->code ne $_[0]->code },
+ q{""} => sub { $_[0]->name };
+
+use Jako::Token;
+
+use Jako::Construct::Type::Integer;
+use Jako::Construct::Type::Number;
+use Jako::Construct::Type::PMC;
+use Jako::Construct::Type::String;
+
+my %types = ( 'I' => 'int', 'N' => 'num', 'P' => 'pmc', 'S' => 'str' );
+
+sub CODE_TO_NAME {
+ my ( $class, $code ) = @_;
+ return $types{ uc $code };
+}
+
+sub new {
+ my $class = shift;
+ my ($type) = @_;
+
+ my $token;
+
+ if ( UNIVERSAL::isa( $type, 'Jako::Token' ) ) {
+ $token = $type;
+ $type = $type->text;
+ }
+ else {
+ $type = $types{$type};
+ }
+
+ return Jako::Construct::Type::Integer->new($token) if $type eq 'int';
+ return Jako::Construct::Type::Number->new($token) if $type eq 'num';
+ return Jako::Construct::Type::PMC->new($token) if $type eq 'pmc';
+ return Jako::Construct::Type::String->new($token) if $type eq 'str';
+
+ confess "Unable to create object for type '$type'!";
+}
+
+sub token {
+ return shift->{TOKEN};
+}
+
+sub code {
+ return shift->{CODE};
+}
+
+sub name {
+ return shift->{NAME};
+}
+
+sub imcc {
+ return shift->{IMCC};
+}
+
+sub imcc_pmc {
+ return shift->{IMCC_PMC};
+}
+
+1;
+
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: jako/trunk/lib/Jako/Construct/Type/Integer.pm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/lib/Jako/Construct/Type/Integer.pm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,39 @@
+#
+# Integer.pm
+#
+# Copyright (C) 2002-2005, Parrot Foundation.
+# This program is free software. It is subject to the same license
+# as the Parrot interpreter.
+#
+# $Id$
+#
+
+use strict;
+use warnings;
+
+package Jako::Construct::Type::Integer;
+
+use base qw(Jako::Construct::Type);
+
+sub new {
+ my $class = shift;
+ my ($token) = @_;
+
+ return bless {
+ TOKEN => $token,
+ CODE => 'I',
+ NAME => 'int',
+ IMCC => 'int',
+ IMCC_PMC => 'Integer'
+ }, $class;
+}
+
+1;
+
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: jako/trunk/lib/Jako/Construct/Type/Number.pm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/lib/Jako/Construct/Type/Number.pm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,39 @@
+#
+# Number.pm
+#
+# Copyright (C) 2002-2005, Parrot Foundation.
+# This program is free software. It is subject to the same license
+# as the Parrot interpreter.
+#
+# $Id$
+#
+
+use strict;
+use warnings;
+
+package Jako::Construct::Type::Number;
+
+use base qw(Jako::Construct::Type);
+
+sub new {
+ my $class = shift;
+ my ($token) = @_;
+
+ return bless {
+ TOKEN => $token,
+ CODE => 'N',
+ NAME => 'num',
+ IMCC => 'num',
+ IMCC_PMC => 'Float'
+ }, $class;
+}
+
+1;
+
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: jako/trunk/lib/Jako/Construct/Type/PMC.pm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/lib/Jako/Construct/Type/PMC.pm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,38 @@
+#
+# PMC.pm
+#
+# Copyright (C) 2002-2005, Parrot Foundation.
+# This program is free software. It is subject to the same license
+# as the Parrot interpreter.
+#
+# $Id$
+#
+
+use strict;
+use warnings;
+
+package Jako::Construct::Type::PMC;
+
+use base qw(Jako::Construct::Type);
+
+sub new {
+ my $class = shift;
+ my ($token) = @_;
+
+ return bless {
+ TOKEN => $token,
+ CODE => 'P',
+ NAME => 'pmc',
+ IMCC => 'pmc',
+ IMCC_PMC => 'PMC'
+ }, $class;
+}
+
+1;
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: jako/trunk/lib/Jako/Construct/Type/String.pm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/lib/Jako/Construct/Type/String.pm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,38 @@
+#
+# String.pm
+#
+# Copyright (C) 2002-2005, Parrot Foundation.
+# This program is free software. It is subject to the same license
+# as the Parrot interpreter.
+#
+# $Id$
+#
+
+use strict;
+use warnings;
+
+package Jako::Construct::Type::String;
+
+use base qw(Jako::Construct::Type);
+
+sub new {
+ my $class = shift;
+ my ($token) = @_;
+
+ return bless {
+ TOKEN => $token,
+ CODE => 'S',
+ NAME => 'str',
+ IMCC => 'string',
+ IMCC_PMC => 'String'
+ }, $class;
+}
+
+1;
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: jako/trunk/lib/Jako/Lexer.pm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/lib/Jako/Lexer.pm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,388 @@
+#
+# Lexer.pm
+#
+# Copyright (C) 2001-2005, Parrot Foundation.
+# This program is free software. It is subject to the same license
+# as the Parrot interpreter.
+#
+# $Id$
+#
+
+use strict;
+use warnings;
+
+package Jako::Lexer;
+
+use Carp;
+use FileHandle;
+
+use Jako::Token;
+
+use base qw(Jako::Processor);
+
+#
+# CONSTRUCTOR:
+#
+
+sub new {
+ my $class = shift;
+ my ($compiler) = @_;
+
+ return bless {
+ FILE => undef,
+ LINE => undef,
+ TOKENS => [],
+ POS => -1
+ }, $class;
+}
+
+#
+# scan_line()
+#
+
+sub scan_line {
+ my $self = shift;
+ my ( $text, $file, $line ) = @_;
+
+ my $temp = $text;
+ chomp $temp;
+
+ # $self->DEBUG(0, "Scanning line %5d: %s", $line, $temp);
+
+ my @tokens;
+
+ if ( $text =~ m{^(\s*([a-zA-Z][a-zA-Z0-9_]*)\s*:(?!:))(.*)$} ) {
+ push @tokens, Jako::Token->new( $file, $line, 'label', 'N', $2 );
+ $text = $3; # The "(?!:)" is non-capturing!
+ }
+
+ while ( defined $text and $text ne '' ) {
+ next if $text =~ s{^\s+}{}; # Skip all whitespace between tokens
+ next if $text =~ s{^#.*?$}{}; # Skip comments between tokens
+
+ #
+ # Numeric literals:
+ #
+
+ if ( $text =~ m{^(-?[0-9]+\.[0-9]+)($|\W.*$)}x ) {
+ push @tokens, Jako::Token->new( $file, $line, 'literal', 'N', $1 );
+ $text = $2;
+ next;
+ }
+
+ #
+ # Integer literals:
+ #
+
+ if ( $text =~ m{^( 0 | (-?[1-9][0-9]*))($|\W.*$)}x ) {
+ push @tokens, Jako::Token->new( $file, $line, 'literal', 'I', $1 );
+ $text = $3;
+ next;
+ }
+
+ if ( $text =~ m{^( 0x[0-9a-fA-F]+ )($|\W.*$)}x ) {
+ push @tokens, Jako::Token->new( $file, $line, 'literal', 'I', $1 );
+ $text = $2;
+ next;
+ }
+
+ #
+ # String literals:
+ #
+
+=begin commented_out
+
+ if ($text =~ m{^((?:\'(?:\\\'|(?!\').)*\'))(.*)$}) {
+ push @tokens, Jako::Token->new(
+ $file, $line, 'literal', 'S', $1);
+ $text = $2;
+ next;
+ }
+
+=cut
+
+ if ( $text =~ m{^((?:\"(?:\\\"|(?!\").)*\"))(.*)$} ) {
+ push @tokens, Jako::Token->new( $file, $line, 'literal', 'S', $1 );
+ $text = $2;
+ next;
+ }
+
+ #
+ # Declarators:
+ #
+
+ if ( $text =~ m{^(module)(?!\w)(.*)$} ) {
+ push @tokens, Jako::Token->new( $file, $line, 'module', undef, $1 );
+ $text = $2;
+ next;
+ }
+
+ if ( $text =~ m{^(sub)(?!\w)(.*)$} ) {
+ push @tokens, Jako::Token->new( $file, $line, 'sub', undef, $1 );
+ $text = $2;
+ next;
+ }
+
+ if ( $text =~ m{^(var|const)(?!\w)(.*)$} ) {
+ push @tokens, Jako::Token->new( $file, $line, $1, undef, $1 );
+ $text = $2;
+ next;
+ }
+
+ #
+ # Type:
+ #
+
+ if ( $text =~ m{^(int|num|pmc|str)(?!\w)(.*)$} ) {
+ my $type = uc substr( $1, 0, 1 );
+ push @tokens, Jako::Token->new( $file, $line, 'type', $type, $1 );
+ $text = $2;
+ next;
+ }
+
+ #
+ # Separating:
+ #
+
+ if ( $text =~ m{^([,])(.*)$} ) {
+ push @tokens, Jako::Token->new( $file, $line, 'comma', undef, $1 );
+ $text = $2;
+ next;
+ }
+
+ if ( $text =~ m{^([:])(.*)$} ) {
+ push @tokens, Jako::Token->new( $file, $line, 'colon', undef, $1 );
+ $text = $2;
+ next;
+ }
+
+ if ( $text =~ m{^([;])(.*)$} ) {
+ push @tokens, Jako::Token->new( $file, $line, 'semicolon', undef, $1 );
+ $text = $2;
+ next;
+ }
+
+ #
+ # Grouping:
+ #
+
+ if ( $text =~ m{^([\(\)])(.*)$} ) {
+ push @tokens,
+ Jako::Token->new( $file, $line, $1 eq '(' ? 'open-paren' : 'close-paren',
+ undef, $1 );
+ $text = $2;
+ next;
+ }
+
+ if ( $text =~ m{^([\[\]])(.*)$} ) {
+ push @tokens,
+ Jako::Token->new( $file, $line, $1 eq '[' ? 'open-bracket' : 'close-bracket',
+ undef, $1 );
+ $text = $2;
+ next;
+ }
+
+ if ( $text =~ m{^([\{\}])(.*)$} ) {
+ push @tokens,
+ Jako::Token->new( $file, $line, $1 eq '{' ? 'open-brace' : 'close-brace',
+ undef, $1 );
+ $text = $2;
+ next;
+ }
+
+ #
+ # Control:
+ #
+
+ if ( $text =~ m{^(if|else|elsif|unless)(?!\w)(.*)$} ) {
+ push @tokens, Jako::Token->new( $file, $line, $1, undef, $1 );
+ $text = $2;
+ next;
+ }
+
+ if ( $text =~ m{^(while|until|for|continue)(?!\w)(.*)$} ) {
+ push @tokens, Jako::Token->new( $file, $line, $1, undef, $1 );
+ $text = $2;
+ next;
+ }
+
+ if ( $text =~ m{^(next|last|redo|goto|return)(?!\w)(.*)$} ) {
+ push @tokens, Jako::Token->new( $file, $line, $1, undef, $1 );
+ $text = $2;
+ next;
+ }
+
+ #
+ # (Prefix) Ops:
+ #
+
+ if ( $text =~ m{^(new)(?!\w)(.*)$} ) {
+ push @tokens, Jako::Token->new( $file, $line, 'new', 'pmc', $1 );
+ $text = $2;
+ next;
+ }
+
+ #
+ # (Infix) Ops:
+ #
+
+ if ( $text =~ m{^( \|= | &= | <<= | >>= )(.*)$}x ) {
+ push @tokens, Jako::Token->new( $file, $line, 'bit-assign', undef, $1 );
+ $text = $2;
+ next;
+ }
+
+ if ( $text =~ m{^( \| | & | << | >> )(.*)$}x ) {
+ push @tokens, Jako::Token->new( $file, $line, 'infix-bit', undef, $1 );
+ $text = $2;
+ next;
+ }
+
+ if ( $text =~ m{^( == | >= | <= | != | < | > )(.*)$}x ) {
+ push @tokens, Jako::Token->new( $file, $line, 'infix-rel', undef, $1 );
+ $text = $2;
+ next;
+ }
+
+ if ( $text =~ m{^( = )(.*)$}x ) {
+ push @tokens, Jako::Token->new( $file, $line, 'assign', undef, $1 );
+ $text = $2;
+ next;
+ }
+
+ if ( $text =~ m{^( \+\+ | -- )(.*)$}x ) {
+ push @tokens, Jako::Token->new( $file, $line, 'exfix-arith', undef, $1 );
+ $text = $2;
+ next;
+ }
+
+ if ( $text =~ m{^( \+= | \*= | -= | /= | %= )(.*)$}x ) {
+ push @tokens, Jako::Token->new( $file, $line, 'arith-assign', undef, $1 );
+ $text = $2;
+ next;
+ }
+
+ if ( $text =~ m{^( \+ | - | \* | / | % )(.*)$}x ) {
+ push @tokens, Jako::Token->new( $file, $line, 'infix-arith', undef, $1 );
+ $text = $2;
+ next;
+ }
+
+ if ( $text =~ m{^( ~= )(.*)$}x ) {
+ push @tokens, Jako::Token->new( $file, $line, 'concat-assign', undef, $1 );
+ $text = $2;
+ next;
+ }
+
+ if ( $text =~ m{^( ~ )(.*)$}x ) {
+ push @tokens, Jako::Token->new( $file, $line, 'infix-concat', undef, $1 );
+ $text = $2;
+ next;
+ }
+
+ #
+ # Identifiers:
+ #
+
+ if ( $text =~ m{^([a-zA-Z][a-zA-Z0-9_]*(::[a-zA-Z][a-zA-Z0-9_]*)*)(.*)$} ) {
+
+ #printf STDERR "IDENT [%s:%d]: '%s'\n", $file, $line, $1;
+ push @tokens, Jako::Token->new( $file, $line, 'ident', undef, $1 );
+ $text = $3;
+ next;
+ }
+
+ #
+ # Anything else is a syntax error:
+ #
+
+ $self->PARSE_ERROR("Unrecognized text '$text'.");
+ }
+
+ # $self->DEBUG(0, "Tokens: %s", join(", ", map { "'" . $_->text . "'" } @tokens))
+ # if @tokens;
+
+ push @{ $self->{TOKENS} }, @tokens;
+}
+
+#
+# slurp_file()
+#
+
+sub slurp_file {
+ my $self = shift;
+ my ($file) = @_;
+
+ my $fh = FileHandle->new($file);
+
+ die "$0: IO Error. Unable to open file '$file' for reading.\n"
+ unless $fh;
+
+ my @lines = <$fh>;
+
+ return @lines;
+}
+
+#
+# scan_file()
+#
+
+sub scan_file {
+ my $self = shift;
+ my ($file) = @_;
+
+ # $self->DEBUG(0, "Scanning file '$file'...");
+
+ my $line = 0;
+
+ my @lines = $self->slurp_file($file);
+ unshift @lines, "#line 1 \"$file\"\n";
+
+ while (@lines) {
+ $_ = shift @lines;
+
+ $line++;
+
+ last if m/^__EOF__\s*$/;
+
+ if (m/^\s*use\s+([a-zA-Z_][a-zA-Z0-9_]*(::[a-zA-Z_][a-zA-Z0-9_]*)*)\s*;\s*(.*?)\s*$/) {
+
+ my $use_file = $1;
+ my $leftover = $3;
+
+ #print STDERR "use $use_file;\n";
+
+ $use_file =~ s{::}{/}g;
+ $use_file .= ".jako";
+
+ my @use_lines = $self->slurp_file($use_file);
+
+ unshift @use_lines, "#line 1 \"$use_file\"\n";
+ push @use_lines, "#line $line \"$file\"\n";
+ push @use_lines, defined $leftover ? "$leftover\n" : "\n";
+
+ unshift @lines, @use_lines;
+ }
+ elsif (m/^#line\s+(\d+)(\s+"(.*?)")?\s*$/) {
+ $line = $1 - 1; # Will be incremented next iteration
+ $file = $3 if defined $3;
+ }
+ else {
+ $self->scan_line( $_, $file, $line );
+ }
+ }
+
+ push @{ $self->{TOKENS} }, Jako::Token->new_eof( $file, $line );
+
+ # $self->DEBUG(0, "Scanned %d tokens", scalar(@{$self->{TOKENS}}));
+}
+
+1;
+
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: jako/trunk/lib/Jako/Parser.pm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/lib/Jako/Parser.pm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,1088 @@
+#
+# Parser.pm
+#
+# Copyright (C) 2001-2005, Parrot Foundation.
+# This program is free software. It is subject to the same license
+# as Perl itself.
+#
+# $Id$
+#
+
+use strict;
+use warnings;
+
+package Jako::Parser;
+
+use Carp;
+
+use base qw(Jako::Processor);
+
+use Jako::Construct::Block;
+use Jako::Construct::Block::Bare;
+use Jako::Construct::Block::Conditional::Else;
+use Jako::Construct::Block::Conditional::If;
+use Jako::Construct::Block::Conditional::Unless;
+use Jako::Construct::Block::File;
+use Jako::Construct::Block::Module;
+use Jako::Construct::Block::Sub;
+use Jako::Construct::Block::Loop::Continue;
+use Jako::Construct::Block::Loop::Until;
+use Jako::Construct::Block::Loop::While;
+
+use Jako::Construct::Declaration::Constant;
+use Jako::Construct::Declaration::Sub;
+use Jako::Construct::Declaration::Variable;
+
+use Jako::Construct::Expression::Call;
+use Jako::Construct::Expression::Value;
+use Jako::Construct::Expression::Value::Identifier;
+
+use Jako::Construct::Label;
+
+use Jako::Construct::Statement::Arithmetic;
+use Jako::Construct::Statement::Assign;
+use Jako::Construct::Statement::Bitwise;
+use Jako::Construct::Statement::Call;
+use Jako::Construct::Statement::Concat;
+use Jako::Construct::Statement::Decrement;
+use Jako::Construct::Statement::Goto;
+use Jako::Construct::Statement::Increment;
+use Jako::Construct::Statement::LoopControl;
+use Jako::Construct::Statement::New;
+use Jako::Construct::Statement::Return;
+
+#
+# new()
+#
+
+sub new {
+ my $class = shift;
+
+ my $root = Jako::Construct::Block::File->new(
+ undef, # No parent
+ 'file', # File scope
+ undef, # No return type
+ undef # No prefix
+ );
+
+ return bless {
+ DEBUG => 1,
+ ANON_BLOCK_COUNT => 0,
+ BLOCK_COUNT => 0,
+ BLOCKS => [$root], # Block stack
+ ROOT => $root,
+ TOKENS => []
+ }, $class;
+}
+
+###############################################################################
+###############################################################################
+##
+## The Block Stack
+##
+## $block_count The total number of blocks begun (used for labels)
+## @block_stack The stack of active blocks. We keep a block on the
+## stack for the file scope.
+##
+## NOTE: Do NOT access the block stack directly. Access it via routines in
+## this section of code.
+##
+###############################################################################
+###############################################################################
+
+#
+# blocks()
+#
+
+sub blocks {
+ my $self = shift;
+
+ return @{ $self->{BLOCKS} };
+}
+
+#
+# block()
+#
+
+sub block {
+ my $self = shift;
+
+ return $self->{BLOCKS}[shift];
+}
+
+#
+# block_depth()
+#
+# Block depth zero is when the only block on the block stack is the file
+# scope block. Therefore, we return one less than the number of blocks on
+# the stack.
+#
+
+sub block_depth {
+ my $self = shift;
+
+ return scalar( $self->blocks ) - 1;
+}
+
+#
+# current_block()
+#
+# Returns the block on the top of the block stack.
+#
+
+sub current_block {
+ my $self = shift;
+
+ $self->INTERNAL_ERROR("Attempt to reference top block with empty block stack!")
+ if scalar( $self->blocks ) == 0;
+
+ return $self->block(-1);
+}
+
+#
+# push_block()
+#
+# Push a block on the top of the block stack.
+#
+
+sub push_block {
+ my $self = shift;
+
+ push @{ $self->{BLOCKS} }, shift;
+}
+
+#
+# pop_block()
+#
+# Pop the top block off the block stack and return it. Bounds checks the block
+# stack to make sure we don't pop off the file scope block.
+#
+
+sub pop_block {
+ my $self = shift;
+
+ $self->INTERNAL_ERROR("Attempt to pop file-scope block off block stack!")
+ if scalar( $self->blocks ) == 1;
+
+ return pop @{ $self->{BLOCKS} };
+}
+
+###############################################################################
+###############################################################################
+##
+## MAIN PROGRAM
+##
+###############################################################################
+###############################################################################
+
+#
+# Tokenize the input, and possibly dump the tokens.
+#
+
+sub parse {
+ my $self = shift;
+
+ my $root = $self->block(0);
+
+ my $last_token = $self->at(-1);
+ my $token = $self->at(-1);
+
+ while (1) {
+ $token = $self->forth;
+ $last_token = $self->get(-1);
+
+ last if $token->is_eof;
+
+ #
+ # Labels:
+ #
+ # <label>:
+ #
+
+ if ( $token->is_label ) {
+ my $block = $self->current_block();
+ my $ident = Jako::Construct::Expression::Value::Identifier->new( $block, $token );
+ my $label = Jako::Construct::Label->new( $block, $ident );
+ next;
+ }
+
+ #
+ # Modules:
+ #
+ # module <ident> [:<prop>[=<value] ...] {
+ #
+
+ if ( $token->is_module ) {
+ my $block = $self->current_block;
+
+ my $ident =
+ Jako::Construct::Expression::Value::Identifier->new( $block, $self->require_ident );
+ my $name = $ident->value;
+
+ #
+ # Allow there to be Properties:
+ #
+
+ my %props;
+
+ while ( $self->skip_colon ) {
+ my $prop = $self->require_ident->text;
+
+ my $value;
+
+ if ( $self->skip_assign ) {
+ $value =
+ Jako::Construct::Expression::Value::Literal->new( $block,
+ $self->require_literal );
+ }
+
+ $props{$prop} = $value;
+ }
+
+ $self->require_open_brace;
+
+ my $module = Jako::Construct::Block::Module->new( $block, $ident, {%props} );
+ push @{ $self->{BLOCKS} }, $module;
+
+ next;
+
+ }
+
+ #
+ # Variable declarations:
+ #
+ # var <type> <ident>;
+ # var <type> <ident> = <value>;
+ # var <type> <ident>, <ident>, ...;
+ # var <type> <ident>, <ident>, ... = <value>;
+ #
+ # const <type> <ident> = <value>; # TODO: SHOULD BE LIMITED TO LITERAL?
+ # const <type> <ident>, <ident>, ... = <value>; # TODO: SHOULD BE LIMITED TO LITERAL?
+ #
+
+ if ( $token->is_var or $token->is_const ) {
+ my $access = $token->text; # 'const' or 'var'.
+
+ my $type = Jako::Construct::Type->new( $self->require_type );
+
+ $self->INTERNAL_ERROR("Could not determine type.") unless defined $type;
+
+ $self->EXCEPTION_SYNTAX_ERROR( "Cannot declare constants of type '%s'.",
+ $type ) # TODO: This can happen later.
+ if ( $access eq 'const' and $type->isa("Jako::Construct::Type::PMC") );
+
+ my @identifiers = ();
+
+ my $block = $self->current_block();
+
+ while (1) {
+ my $ident =
+ Jako::Construct::Expression::Value::Identifier->new( $block,
+ $self->require_ident );
+ push @identifiers, $ident;
+ last unless $self->skip_comma;
+ }
+
+ my $value;
+
+ if ( $self->skip_assign ) {
+ $value = Jako::Construct::Expression::Value->new( $block, $self->require_literal );
+ }
+
+ $self->require_semicolon;
+
+ $self->EXCEPTION_SYNTAX_ERROR(
+ "Cannot declare constant without assigning a value.") # TODO: This can happen later.
+ if ( $access eq 'const' and not defined $value );
+
+ foreach my $ident (@identifiers) {
+ if ( $access eq 'var' ) {
+ my $var = Jako::Construct::Declaration::Variable->new( $block, $type, $ident );
+ my $assign = Jako::Construct::Statement::Assign->new( $block, $ident, $value )
+ if defined $value;
+ }
+ elsif ( $access eq 'const' ) {
+ my $const =
+ Jako::Construct::Declaration::Constant->new( $block, $type, $ident,
+ $value );
+ }
+ else {
+ $self->INTERNAL_ERROR("Unexpected access '$access'.");
+ }
+ }
+
+ next;
+ }
+
+ #
+ # Subroutines:
+ #
+ # sub [<type>] <ident> [:<prop>[=<value] ...] (<arg>, <arg>, ...) {
+ #
+
+ if ( $token->is_sub ) {
+ my $block = $self->current_block;
+
+ my $type_token = $self->skip_type;
+
+ my $type;
+ $type = Jako::Construct::Type->new( $type_token->type ) if $type_token;
+
+ my $ident =
+ Jako::Construct::Expression::Value::Identifier->new( $block, $self->require_ident );
+ my $name = $ident->value;
+
+ #
+ # Allow there to be Properties:
+ #
+
+ my %props;
+
+ while ( $self->skip_colon ) {
+ my $prop = $self->require_ident->text;
+
+ my $value;
+
+ if ( $self->skip_assign ) {
+ $value =
+ Jako::Construct::Expression::Value::Literal->new( $block,
+ $self->require_literal );
+ }
+
+ $props{$prop} = $value;
+ }
+
+ #
+ # Require there to be a formal arguments list:
+ #
+
+ $self->require_open_paren;
+
+ my @formal_args;
+
+ unless ( $self->skip_close_paren ) {
+ while (1) {
+ my $arg_type = Jako::Construct::Type->new( $self->require_type );
+ my $arg_token = $self->require_ident;
+ my $arg_name = $arg_token->text;
+
+ push @formal_args, [ $arg_type, $arg_name, $arg_token ];
+
+ last if $self->skip_close_paren;
+
+ $self->require_comma;
+ }
+ }
+
+ my $decl =
+ Jako::Construct::Declaration::Sub->new( $block, $type, $ident, {%props},
+ [@formal_args] );
+
+ unless ( $self->skip_open_brace ) { # DEFINITION
+ $self->require_semicolon;
+ }
+ else {
+ my $sub =
+ Jako::Construct::Block::Sub->new( $block, $type, $ident, {%props},
+ [@formal_args] );
+ push @{ $self->{BLOCKS} }, $sub;
+ }
+
+ next;
+ }
+
+ #
+ # Loops:
+ #
+ # <label>: until (<value> <op> <value>) {
+ # until (<value> <op> <value>) {
+ #
+ # <label>: while (<value> <op> <value>) {
+ # while (<value> <op> <value>) {
+ #
+
+ if ( $token->is_until or $token->is_while ) {
+ my $block = $self->current_block();
+ my $kind = $token->text;
+
+ my $prefix;
+
+ if ( $last_token->is_label ) {
+ $prefix = $last_token->text;
+ }
+
+ $self->require_open_paren;
+
+ my $left = Jako::Construct::Expression::Value->new( $block, $self->require_value );
+ my $op = $self->require_infix_rel->text;
+ my $right = Jako::Construct::Expression::Value->new( $block, $self->require_value );
+
+ $self->require_close_paren;
+ $self->require_open_brace;
+
+ my $loop;
+
+ my $namespace = sprintf( "_%s_%d", uc $kind, $self->{BLOCK_COUNT}++ );
+
+ $prefix = $namespace unless defined $prefix;
+
+ if ( $kind eq 'while' ) {
+ $loop =
+ Jako::Construct::Block::Loop::While->new( $block, $prefix, $left, $op, $right );
+ }
+ elsif ( $kind eq 'until' ) {
+ $loop =
+ Jako::Construct::Block::Loop::Until->new( $block, $prefix, $left, $op, $right );
+ }
+ else {
+ $self->INTERNAL_ERROR( "Unexpected loop kind %s!", $kind );
+ }
+
+ push @{ $self->{BLOCKS} }, $loop;
+
+ next;
+ }
+
+ #
+ # Increment and Decrement:
+ #
+ # <var> <op>;
+ #
+
+ if ( $token->is_ident and $self->get(1)->is_exfix_arith ) {
+ my $block = $self->current_block();
+ my $ident = Jako::Construct::Expression::Value::Identifier->new( $block, $token );
+ my $op = $self->forth->text;
+
+ $self->require_semicolon;
+
+ if ( $op eq '++' ) {
+ my $inc = Jako::Construct::Statement::Increment->new( $block, $ident );
+ }
+ else {
+ my $dec = Jako::Construct::Statement::Decrement->new( $block, $ident );
+ }
+
+ next;
+ }
+
+ #
+ # Arithmetic assigns:
+ #
+ # <var> <op> <value>;
+ #
+
+ if ( $token->is_ident and $self->get(1)->is_arith_assign ) {
+ my $block = $self->current_block;
+
+ my $ident = Jako::Construct::Expression::Value::Identifier->new( $block, $token );
+ my $op = substr( $self->forth->text, 0, -1 );
+ my $value = Jako::Construct::Expression::Value->new( $block, $self->forth );
+
+ $self->require_semicolon;
+
+ my $arith =
+ Jako::Construct::Statement::Arithmetic->new( $block, $ident, $ident, $op, $value );
+ next;
+ }
+
+ #
+ # Concat assign:
+ #
+ # <var> <op> <value>;
+ #
+
+ if ( $token->is_ident and $self->get(1)->is_concat_assign ) {
+ my $block = $self->current_block;
+
+ my $ident = Jako::Construct::Expression::Value::Identifier->new( $block, $token );
+ my $op = substr( $self->forth->text, 0, -1 );
+ my $value = Jako::Construct::Expression::Value->new( $block, $self->forth );
+
+ $self->require_semicolon;
+
+ my $concat =
+ Jako::Construct::Statement::Concat->new( $block, $ident, $ident, $op, $value );
+ next;
+ }
+
+ #
+ # Bitwise assigns:
+ #
+ # <var> <op> <value>;
+ #
+
+ if ( $token->is_ident and $self->get(1)->is_bit_assign ) {
+ my $block = $self->current_block;
+
+ my $ident = Jako::Construct::Expression::Value::Identifier->new( $block, $token );
+ my $op = substr( $self->forth->text, 0, -1 );
+ my $value = Jako::Construct::Expression::Value->new( $block, $self->forth );
+
+ $self->require_semicolon;
+
+ my $bitwise =
+ Jako::Construct::Statement::Bitwise->new( $block, $ident, $ident, $op, $value );
+ next;
+ }
+
+ #
+ # Block Termination:
+ #
+ # }
+ # } continue {
+ # }
+ # else {
+ #
+
+ if ( $token->is_close_brace ) {
+ my $cont;
+
+ if ( $self->get(1)->is_continue or $self->get(1)->is_else ) {
+ $cont = $self->forth->text;
+ $self->require_open_brace;
+ }
+
+ #
+ # If we are not currently 'inside' a block, then we've got no business
+ # seeing a close-brace.
+ #
+
+ $self->EXCEPTION_SYNTAX_ERROR("Closing brace without open block.")
+ unless $self->block_depth();
+
+ #
+ # Remember the block we just closed, in case its the peer of a continuation
+ # we are about to introduce.
+ #
+
+ my $peer_block = $self->pop_block;
+
+ #
+ # 'while' blocks:
+ #
+ # When we are ending the 'while' block, we might be beginning the 'continue'
+ # block, so we check for that case.
+ #
+ # We *always* create a continue block, even when there is none in the source,
+ # so that upon compilation all the appropriate labels can be generated for
+ # the loop control statements to function properly.
+ #
+ # Put on an empty continue block and then pop it back off. It will be in the
+ # parent block's content array, and it will have gotten its prefix, etc.
+ # correct by virtue of initializing itself based on its peer block's info
+ # (available by passing $block in as an argument).
+ #
+
+ if ( $peer_block->kind eq 'while' or $peer_block->kind eq 'until' ) {
+ my $parent_block = $peer_block->block;
+ my $loop =
+ Jako::Construct::Block::Loop::Continue->new( $parent_block, $peer_block );
+ $self->push_block($loop) if defined $cont;
+ }
+ elsif ( $peer_block->kind eq 'continue' ) {
+ if ( defined $cont ) {
+ $self->EXCEPTION_SYNTAX_ERROR("No more than one continue block allowed.");
+ }
+ }
+
+ #
+ # 'if' blocks:
+ #
+ # Continuation of 'if' blocks happens by $continue being 'else'.
+ #
+
+ elsif ( $peer_block->kind eq 'if' or $peer_block->kind eq 'unless' ) {
+ my $parent_block = $peer_block->block;
+ my $cond =
+ Jako::Construct::Block::Conditional::Else->new( $parent_block, $peer_block );
+ $self->push_block($cond) if defined $cont;
+ }
+ elsif ( $peer_block->kind eq 'else' ) {
+ if ( defined $cont ) {
+ $self->EXCEPTION_SYNTAX_ERROR("No more than one else block allowed.");
+ }
+ }
+
+ #
+ # Handle the ending of subroutine blocks:
+ #
+
+ elsif ( $peer_block->kind eq 'sub' ) {
+
+ # DO NOTHING
+ }
+
+ #
+ # Handle the ending of module blocks:
+ #
+
+ elsif ( $peer_block->kind eq 'module' ) {
+
+ # DO NOTHING
+ }
+
+ #
+ # If there is any other kind of block, we have an internal compiler error.
+ #
+
+ else {
+ $self->INTERNAL_ERROR( "End of unknown kind of block '%s'!", $peer_block->kind );
+ }
+
+ next;
+ }
+
+ #
+ # Arithmetic Operators:
+ #
+ # <var> = <value> <op> <value>;
+ #
+ # TODO: Can't really support shift amount as arg until sh[lr]_i_i ops are implemented.
+ # TODO: Should we really be allowing the shift constant to be negative?
+ #
+
+ if ( $token->is_ident
+ and $self->get(1)->is_assign
+ and $self->get(2)->is_value
+ and $self->get(3)->is_infix_arith
+ and $self->get(4)->is_value )
+ {
+ my $block = $self->current_block();
+ my $ident = Jako::Construct::Expression::Value::Identifier->new( $block, $token );
+
+ $self->require_assign;
+
+ my $left = Jako::Construct::Expression::Value->new( $block, $self->forth );
+ my $op = $self->forth->text;
+ my $right = Jako::Construct::Expression::Value->new( $block, $self->forth );
+
+ $self->require_semicolon;
+
+ my $arith =
+ Jako::Construct::Statement::Arithmetic->new( $block, $ident, $left, $op, $right );
+
+ next;
+ }
+
+ #
+ # Concat Operators:
+ #
+ # <var> = <value> <op> <value>;
+ #
+
+ if ( $token->is_ident
+ and $self->get(1)->is_assign
+ and $self->get(2)->is_value
+ and $self->get(3)->is_infix_concat
+ and $self->get(4)->is_value )
+ {
+ my $block = $self->current_block();
+ my $ident = Jako::Construct::Expression::Value::Identifier->new( $block, $token );
+
+ $self->require_assign;
+
+ my $left = Jako::Construct::Expression::Value->new( $block, $self->forth );
+ my $op = $self->forth->text;
+ my $right = Jako::Construct::Expression::Value->new( $block, $self->forth );
+
+ $self->require_semicolon;
+
+ my $arith =
+ Jako::Construct::Statement::Concat->new( $block, $ident, $left, $op, $right );
+
+ next;
+ }
+
+ #
+ # Bitwise Operators:
+ #
+ # a = b << 4;
+ # a = b >> 4;
+ # a = b & c;
+ # a = b | c;
+ #
+
+ if ( $token->is_ident
+ and $self->get(1)->is_assign
+ and $self->get(2)->is_value
+ and $self->get(3)->is_infix_bit
+ and $self->get(4)->is_value )
+ {
+ my $block = $self->current_block();
+ my $ident = Jako::Construct::Expression::Value::Identifier->new( $block, $token );
+
+ $self->require_assign;
+
+ my $left = Jako::Construct::Expression::Value->new( $block, $self->forth );
+ my $op = $self->forth->text;
+ my $right = Jako::Construct::Expression::Value->new( $block, $self->forth );
+
+ $self->require_semicolon;
+
+ my $arith =
+ Jako::Construct::Statement::Bitwise->new( $block, $ident, $left, $op, $right );
+
+ next;
+ }
+
+ #
+ # Subroutine Calls:
+ #
+ # <ident>(<arg>, <arg>, ...);
+ #
+
+ if ( $token->is_ident and $self->get(1)->is_open_paren ) {
+ my $block = $self->current_block();
+ my $sub_name = Jako::Construct::Expression::Value::Identifier->new( $block, $token );
+
+ $self->require_open_paren;
+
+ my @args = ();
+
+ unless ( $self->get(1)->is_close_paren ) {
+ while (1) {
+ push @args,
+ Jako::Construct::Expression::Value->new( $block, $self->require_value );
+ last if $self->get(1)->is_close_paren;
+ $self->require_comma;
+ }
+ }
+
+ $self->require_close_paren;
+ $self->require_semicolon;
+
+ # $self->DEBUG(0, "Assembling call to '%s()'...", $sub_name->value);
+
+ my $call = Jako::Construct::Statement::Call->new( $block, $sub_name, @args );
+ next;
+ }
+
+ #
+ # Function Calls:
+ #
+ # a = foo(...);
+ #
+
+ if ( $token->is_ident
+ and $self->get(1)->is_assign
+ and $self->get(2)->is_ident
+ and $self->get(3)->is_open_paren )
+ {
+ my $block = $self->current_block();
+ my $left = Jako::Construct::Expression::Value::Identifier->new( $block, $token );
+
+ $self->require_assign;
+
+ my $func_name =
+ Jako::Construct::Expression::Value::Identifier->new( $block, $self->require_ident );
+
+ $self->require_open_paren;
+
+ my @args = ();
+
+ unless ( $self->get(1)->is_close_paren ) {
+ while (1) {
+ push @args,
+ Jako::Construct::Expression::Value->new( $block, $self->require_value );
+ last if $self->get(1)->is_close_paren;
+ $self->require_comma;
+ }
+ }
+
+ $self->require_close_paren;
+ $self->require_semicolon;
+
+ #
+ # TODO: Call is really an expression, but here its treated as a statement with the assign.
+ #
+
+ my $call = Jako::Construct::Expression::Call->new( $block, $left, $func_name, @args );
+ next;
+ }
+
+ #
+ # Variable Assignments:
+ #
+ # <ident> = <value>;
+ # <ident> = <ident> = ... = <value>;
+ # <ident> = new <ident>;
+ #
+
+ if ( $token->is_ident and $self->get(1)->is_assign ) {
+ my $block = $self->current_block();
+ my $left = Jako::Construct::Expression::Value::Identifier->new( $block, $token );
+
+ my @left = ($left);
+
+ $self->require_assign;
+
+ while ( $self->get()->is_ident and $self->get(1)->is_assign ) {
+ my $left =
+ Jako::Construct::Expression::Value::Identifier->new( $block, $self->get() );
+ push @left, $left;
+ $self->require_assign;
+ }
+
+ my $constructing;
+ my $right;
+
+ if ( $self->skip_new ) {
+ $constructing = 1;
+ $right =
+ Jako::Construct::Expression::Value::Identifier->new( $block,
+ $self->require_ident );
+ }
+ else {
+ $constructing = 0;
+ $right = Jako::Construct::Expression::Value->new( $block, $self->require_value );
+ }
+
+ $self->require_semicolon;
+
+ foreach my $left (@left) {
+ if ($constructing) {
+ my $new = Jako::Construct::Statement::New->new( $block, $left, $right );
+ $constructing = 0;
+ }
+ else {
+ my $assign = Jako::Construct::Statement::Assign->new( $block, $left, $right );
+ }
+
+ $right = $left;
+ }
+
+ next;
+ }
+
+ #
+ # Subroutine Return Statements:
+ #
+ # return;
+ # return <value>;
+ #
+
+ if ( $token->is_return ) {
+ my $block = $self->current_block();
+
+ my $value_token = $self->skip_value;
+ my $value = Jako::Construct::Expression::Value->new( $block, $value_token )
+ if defined $value_token;
+
+ my ( $cond, $left, $op, $right );
+
+ if ( $self->get(1)->is_if or $self->get(1)->is_unless ) {
+ $cond = $self->forth->text;
+
+ $self->require_open_paren;
+
+ $left = Jako::Construct::Expression::Value->new( $block, $self->require_value );
+ $op = $self->require_infix_rel->text;
+ $right = Jako::Construct::Expression::Value->new( $block, $self->require_value );
+
+ $self->require_close_paren;
+ }
+
+ $self->require_semicolon;
+
+ my $return =
+ Jako::Construct::Statement::Return->new( $block, $value, $cond, $left, $op,
+ $right );
+ next;
+ }
+
+ #
+ # Goto Statements:
+ #
+ # goto <label>;
+ # goto <label> if (<value> <op> <value>);
+ # goto <label> unless (<value> <op> <value>);
+ #
+
+ if ( $token->is_goto ) {
+ my $block = $self->current_block;
+ my $ident =
+ Jako::Construct::Expression::Value::Identifier->new( $block, $self->require_ident );
+
+ my ( $cond, $left, $op, $right );
+
+ if ( $self->get(1)->is_if or $self->get(1)->is_unless ) {
+ $cond = $self->forth->text;
+
+ $self->require_open_paren;
+
+ $left = Jako::Construct::Expression::Value->new( $block, $self->require_value );
+ $op = $self->require_infix_rel->text;
+ $right = Jako::Construct::Expression::Value->new( $block, $self->require_value );
+
+ $self->require_close_paren;
+ }
+
+ $self->require_semicolon;
+
+ my $goto =
+ Jako::Construct::Statement::Goto->new( $block, $ident, $cond, $left, $op, $right );
+ next;
+ }
+
+ #
+ # Loop Control Statements:
+ #
+ # next;
+ # next if (<value> <op> <value>);
+ # next unless (<value> <op> <value>);
+ #
+ # next <label>;
+ # next <label> if (<value> <op> <value>);
+ # next <label> unless (<value> <op> <value>);
+ #
+ # last;
+ # last if (<value> <op> <value>);
+ # last unless (<value> <op> <value>);
+ #
+ # last <label>;
+ # last <label> if (<value> <op> <value>);
+ # last <label> unless (<value> <op> <value>);
+ #
+ # redo;
+ # redo if (<value> <op> <value>);
+ # redo unless (<value> <op> <value>);
+ #
+ # redo <label>;
+ # redo <label> if (<value> <op> <value>);
+ # redo <label> unless (<value> <op> <value>);
+ #
+
+ if ( $token->is_loop_control ) {
+ my $block = $self->current_block();
+ my $kind = $token->text;
+
+ my $target_token = $self->skip_ident;
+ my $target;
+ $target = Jako::Construct::Expression::Value::Identifier->new( $block, $target_token )
+ if $target_token;
+
+ my ( $cond, $left, $op, $right );
+
+ if ( $self->get(1)->is_if or $self->get(1)->is_unless ) {
+ $cond = $self->forth->text;
+
+ $self->require_open_paren;
+ $left = Jako::Construct::Expression::Value->new( $block, $self->require_value );
+ $op = $self->require_infix_rel->text;
+ $right = Jako::Construct::Expression::Value->new( $block, $self->require_value );
+ $self->require_close_paren;
+ }
+
+ $self->require_semicolon;
+
+ my $ctl =
+ Jako::Construct::Statement::LoopControl->new( $block, $kind, $target, $cond, $left,
+ $op, $right );
+ next;
+ }
+
+ #
+ # Conditional Blocks:
+ #
+ # if (<value> <op> <value>) {
+ # unless (<value> <op> <value>) {
+ #
+
+ if ( $token->is_if or $token->is_unless ) {
+ my $block = $self->current_block();
+ my $kind = $token->text;
+
+ $self->require_open_paren;
+
+ my $left = Jako::Construct::Expression::Value->new( $block, $self->require_value );
+ my $op = $self->require_infix_rel->text;
+ my $right = Jako::Construct::Expression::Value->new( $block, $self->require_value );
+
+ $self->require_close_paren;
+ $self->require_open_brace;
+
+ my $cond;
+
+ if ( $kind eq 'if' ) {
+ $cond = Jako::Construct::Block::Conditional::If->new( $block, $left, $op, $right );
+ }
+ elsif ( $kind eq 'unless' ) {
+ $cond =
+ Jako::Construct::Block::Conditional::Unless->new( $block, $left, $op, $right );
+ }
+
+ push @{ $self->{BLOCKS} }, $cond;
+ next;
+ }
+
+=begin commented_out
+
+ #
+ # Bare Blocks:
+ #
+ # <label>: {
+ # {
+ #
+
+ if ($token->is_open_brace) {
+ my $label = $last_token->text
+ if $last_token->is_label;
+
+ $self->begin_block($label, 'bare', undef);
+
+ next;
+ }
+
+ #
+ # Conditional Continuations:
+ #
+ # } elsif (<value> <op> <value>) {
+ #
+
+ if (m/^}\s*(elsif)\s*\(\s*(.*)\s*\)\s*{$/) {
+ $self->begin_block(undef, $1, $2);
+ # TODO
+ next;
+ }
+
+ #
+ # PMC Construction:
+ #
+ # a = new Foo;
+ #
+
+ if (m/^([A-Za-z][A-Za-z0-9_]*)\s*=\s*new\s+([A-Za-z][A-Za-z0-9_]*)$/) {
+ new_pmc($1, $2);
+ next;
+ }
+
+ #
+ # Miscellany:
+ #
+
+ if (m/^end$/) {
+ $self->emit_code('end');
+ next;
+ }
+
+=cut
+
+ #
+ # TODO: Implement other stuff and put it before this.
+ #
+
+ $self->EXCEPTION_SYNTAX_ERROR( "Don't know what to do with token '%s'.", $token->text );
+ }
+
+ return $root;
+}
+
+1;
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: jako/trunk/lib/Jako/Processor.pm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/lib/Jako/Processor.pm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,441 @@
+#
+# Processor.pm
+#
+# Copyright (C) 2002-2005, Parrot Foundation.
+# This program is free software. It is subject to the same license
+# as the Parrot interpreter.
+#
+# $Id$
+#
+
+use strict;
+use warnings;
+
+package Jako::Processor;
+
+use Carp;
+
+#
+# new()
+#
+
+sub new {
+ confess "Subclass responsibility";
+}
+
+#
+# debug()
+#
+
+sub debug {
+ my $self = shift;
+
+ if (@_) {
+ $self->{DEBUG} = shift;
+ }
+
+ return $self->{DEBUG};
+}
+
+#
+# file()
+#
+
+sub file {
+ my $self = shift;
+
+ if (@_) { $self->{FILE} = shift; }
+
+ return defined $self->{FILE} ? $self->{FILE} : '<NO FILE>';
+}
+
+#
+# line()
+#
+
+sub line {
+ my $self = shift;
+
+ if (@_) { $self->{LINE} = shift; }
+
+ return defined $self->{LINE} ? $self->{LINE} : '';
+}
+
+###############################################################################
+###############################################################################
+##
+## TOKEN PROCESSING:
+##
+###############################################################################
+###############################################################################
+
+#
+# tokens()
+#
+
+sub tokens {
+ my $self = shift;
+
+ if (@_) {
+ $self->{TOKENS} = [@_];
+ }
+ else {
+ return @{ $self->{TOKENS} };
+ }
+}
+
+#
+# token_count()
+#
+# Returns the number of tokens.
+#
+
+sub count {
+ my $self = shift;
+
+ return scalar( @{ $self->{TOKENS} } );
+}
+
+#
+# pos()
+#
+# Returns (or sets) the abolute position.
+#
+
+sub pos {
+ my $self = shift;
+ my ($pos) = @_;
+
+ if ( defined $pos ) {
+ my $count = scalar( @{ $self->{TOKENS} } );
+
+ $pos = -1 if $pos < 0; # Just before the beginning
+ $pos = $count if $pos > $count; # Just past the end (in case we get more tokens)
+
+ $self->{POS} = $pos;
+
+ $self->file( $self->at($pos)->file );
+ $self->line( $self->at($pos)->line );
+ }
+
+ return defined $self->{POS} ? $self->{POS} : -1;
+}
+
+#
+# at()
+#
+# Without an argument, gives the current token. With an argument, gives the
+# token at that absolute position. If a count is given, then that many tokens
+# (at most, given the possibility of running off the end) are returned. If
+# a count is not given, 1 is inferred.
+#
+
+sub at {
+ my $self = shift;
+ my ( $index, $count ) = @_;
+
+ $index = $self->pos unless defined $index;
+
+ $count = 1 unless defined $count;
+
+ $self->INTERNAL_ERROR( "Attempt to get fewer than 1 token (%s)!", $count )
+ if $count < 1;
+
+ if ( $count > 1 ) {
+ return map { $self->at( $index + $_ ) } ( 0 .. $count );
+ }
+
+ my $pos = $self->pos;
+
+ $self->INTERNAL_ERROR("Position is not defined") unless defined $pos;
+
+ return Jako::Token->BOF if $index < 0;
+ return Jako::Token->EOF if $index >= @{ $self->{TOKENS} };
+
+ return $self->{TOKENS}[$index];
+}
+
+#
+# get()
+#
+# Without an argument, gives the current token. With an argument, gives the
+# token at that offset from the current one. If a count is given, then that
+# many tokens (at most, given the possibility of running of the end) are
+# returned. If a count is not given, 1 is inferred.
+#
+
+sub get {
+ my $self = shift;
+ my ( $offset, $count ) = @_;
+
+ $offset = 0 unless defined $offset;
+
+ my $pos = $self->pos;
+
+ $self->INTERNAL_ERROR("Position is not defined") unless defined $pos;
+ $self->INTERNAL_ERROR("Offset is not defined") unless defined $offset;
+
+ # DEBUG(0, "Current position is $pos");
+ $pos += $offset;
+
+ # DEBUG(0, "Getting token at $pos");
+
+ return $self->at( $pos, $count );
+}
+
+#
+# forth()
+#
+# Moves the current token position $offset tokens forward. Returns the
+# token at the new absolute position.
+#
+
+sub forth {
+ my $self = shift;
+ my ($offset) = @_;
+
+ $offset = 1 unless defined $offset;
+
+ my $pos = $self->pos;
+
+ $self->INTERNAL_ERROR("Position is undefined") unless defined $pos;
+
+ # DEBUG(0, "Position starts as $pos");
+
+ $pos += $offset;
+
+ # DEBUG(0, "Setting position to $pos");
+ $self->pos($pos);
+
+ # DEBUG(0, "forth(): Position is now %d", $self->pos);
+
+ my $token = $self->get;
+
+ $self->file( $token->file );
+ $self->line( $token->line );
+
+ return $token;
+}
+
+#
+# back()
+#
+# Moves the current token position $offset tokens backward. Returns the new
+# absolute position.
+#
+
+sub back {
+ my $self = shift;
+ my ($offset) = @_;
+
+ $offset = 1 unless defined $offset;
+
+ return $self->forth( -$offset );
+}
+
+#
+# dump()
+#
+# Dump the tokens.
+#
+
+sub dump {
+ my $self = shift;
+
+ while (1) {
+ my $tok = $self->forth;
+
+ printf STDERR "%6d : %-30s : %5s : %-15s: %1s : %s\n", $self->pos, $tok->file, $tok->line,
+ $tok->kind, $tok->type || '', $tok->text;
+
+ last if $tok->is_eof;
+ }
+
+=begin commented_out
+
+ foreach (my $i = 0; $i < scalar(@{$self->{TOKENS}}); $i++) {
+ my $tok = $self->at($i);
+
+ printf STDERR "%6d : %-30s : %5s : %-15s: %1s : %s\n",
+ $i,
+ $tok->file,
+ $tok->line,
+ $tok->kind,
+ $tok->type || '',
+ $tok->text;
+
+ last if $tok->is_eof;
+ }
+
+=cut
+
+}
+
+#
+# require()
+#
+# Require consumes and returns the token if the requirement is met, otherwise
+# a Syntax Error is raised.
+#
+# If more than one type is specified, the semantics are "or".
+#
+
+sub require {
+ my $self = shift;
+
+ # DEBUG(0, "Requiring '$kind'");
+
+ $self->EXCEPTION_SYNTAX_ERROR(
+ "Expected %s, but found '%s'.",
+ @_ > 1 ? "one of (" . join( ", ", @_ ) . ")" : $_[0],
+ $self->get(1)->text
+ ) unless grep { $self->get(1)->kind eq $_ } @_;
+
+ return $self->forth;
+}
+
+#
+# REQUIRES:
+#
+
+sub require_assign { return shift->require('assign'); }
+sub require_close_brace { return shift->require('close-brace'); }
+sub require_close_bracket { return shift->require('close-bracket'); }
+sub require_close_paren { return shift->require('close-paren'); }
+sub require_comma { return shift->require('comma'); }
+sub require_ident { return shift->require('ident'); }
+sub require_literal { return shift->require('literal'); }
+sub require_open_brace { return shift->require('open-brace'); }
+sub require_open_bracket { return shift->require('open-bracket'); }
+sub require_open_paren { return shift->require('open-paren'); }
+sub require_infix_rel { return shift->require('infix-rel'); }
+sub require_semicolon { return shift->require('semicolon'); }
+sub require_type { return shift->require('type'); }
+
+sub require_value { return shift->require( 'ident', 'literal' ); }
+
+#
+# skip()
+#
+# Skips the token type specified if it is present. Returns undef if nothing
+# was skipped, otherwise returns the token skipped.
+#
+# If more than one type is specified, the semantics are "or".
+#
+
+sub skip {
+ my $self = shift;
+ my ($kind) = @_;
+
+ return undef unless grep { $self->get(1)->kind eq $_ } @_;
+
+ return $self->forth;
+}
+
+#
+# SKIPS:
+#
+
+sub skip_assign { return shift->skip('assign'); }
+sub skip_colon { return shift->skip('colon'); }
+sub skip_comma { return shift->skip('comma'); }
+sub skip_close_brace { return shift->skip('close-brace'); }
+sub skip_close_bracket { return shift->skip('close-bracket'); }
+sub skip_close_paren { return shift->skip('close-paren'); }
+sub skip_ident { return shift->skip('ident'); }
+sub skip_literal { return shift->skip('literal'); }
+sub skip_new { return shift->skip('new'); }
+sub skip_open_brace { return shift->skip('open-brace'); }
+sub skip_open_bracket { return shift->skip('open-bracket'); }
+sub skip_open_paren { return shift->skip('open-paren'); }
+sub skip_infix_rel { return shift->skip('infix-rel'); }
+sub skip_semicolon { return shift->skip('semicolon'); }
+sub skip_type { return shift->skip('type'); }
+
+sub skip_value { return shift->skip( 'ident', 'literal' ); }
+
+###############################################################################
+###############################################################################
+##
+## MESSAGES:
+##
+###############################################################################
+###############################################################################
+
+#
+# DEBUG()
+#
+
+sub DEBUG {
+ my ( $self, $level, $format, @args ) = @_;
+
+ return unless defined $self->debug and $self->debug >= $level;
+
+ my $message = $format ? sprintf( $format, @args ) : '<no message>';
+
+ printf STDERR "%s [%s]: Debug message: %s\n", $self->file, $self->line, $message;
+}
+
+#
+# WARNING()
+#
+
+sub WARNING {
+ my ( $self, $format, @args ) = @_;
+
+ my $message = sprintf( $format, @args );
+
+ print STDERR "%s [%s]: Warning: %s", $self->file, $self->line, $message;
+}
+
+#
+# ERROR()
+#
+
+sub ERROR {
+ my ( $self, $kind, $format, @args ) = @_;
+
+ my $message = sprintf( $format, @args );
+
+ $message = sprintf( "%s [%s]: %s error: %s", $self->file, $self->line, $kind, $message );
+
+ if ( $self->debug ) { confess $message; }
+ else { die "$message\n"; }
+}
+
+#
+# PARSE_ERROR()
+#
+
+sub PARSE_ERROR {
+ my ( $self, $format, @args ) = @_;
+ $self->ERROR( 'Parse', $format, @args );
+}
+
+#
+# EXCEPTION_SYNTAX_ERROR()
+#
+
+sub EXCEPTION_SYNTAX_ERROR {
+ my ( $self, $format, @args ) = @_;
+ $self->ERROR( 'Syntax', $format, @args );
+}
+
+#
+# INTERNAL_ERROR()
+#
+
+sub INTERNAL_ERROR {
+ my ( $self, $format, @args ) = @_;
+ $self->ERROR( 'Internal', $format, @args );
+}
+
+1;
+
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: jako/trunk/lib/Jako/Symbol.pm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/lib/Jako/Symbol.pm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,107 @@
+#
+# Symbol.pm
+#
+# Copyright (C) 2002-2005, Parrot Foundation.
+# This program is free software. It is subject to the same license
+# as the Parrot interpreter.
+#
+# $Id$
+#
+
+use strict;
+use warnings qw(all);
+
+package Jako::Symbol;
+
+use Carp;
+
+#
+# CONSTRUCTOR:
+#
+
+sub new {
+ my $class = shift;
+
+ confess "Expected 10 args" unless @_ == 10;
+
+ my ( $block, $scope, $kind, $type, $name, $value, $props, $args, $file, $line ) = @_;
+
+ $props = {} unless defined $props;
+ $args = [] unless defined $args;
+
+ confess("Undefined identifier block.")
+ unless defined $block;
+
+ confess "Block (" . ref($block) . ") is not!"
+ unless UNIVERSAL::isa( $block, qw(Jako::Construct::Block) );
+ confess "Type (" . ref($type) . ") is not!"
+ if defined $type and not UNIVERSAL::isa( $type, qw(Jako::Construct::Type) );
+ confess "Value (" . ref($value) . ") is not!"
+ if defined $value and not UNIVERSAL::isa( $value, qw(Jako::Construct::Expression::Value) );
+
+ confess("Undefined identifier kind attribute.")
+ unless defined $kind;
+
+ confess( "Unrecognized identifier scope attribute '" . $scope . "'." )
+ unless $scope eq 'global'
+ or $scope eq 'local';
+
+ confess( "Unrecognized identifier kind attribute '" . $kind . "'." )
+ unless $kind eq 'module'
+ or $kind eq 'sub'
+ or $kind eq 'var'
+ or $kind eq 'arg'
+ or $kind eq 'const';
+
+ my $self = bless {
+ BLOCK => $block,
+
+ SCOPE => $scope,
+ KIND => $kind,
+ TYPE => $type,
+ NAME => $name,
+ VALUE => $value, # For constants (undef for variables)
+ PROPS => $props,
+ ARGS => $args,
+
+ DEBUG => 1,
+ FILE => $file,
+ LINE => $line
+ }, $class;
+
+ return $self;
+}
+
+#
+# ACCESSORS:
+#
+
+sub block { return shift->{BLOCK}; }
+
+sub scope { return shift->{SCOPE} }
+sub kind { return shift->{KIND}; }
+sub type { return shift->{TYPE}; }
+sub name { return shift->{NAME}; }
+sub value { return shift->{VALUE}; }
+sub props { return %{ shift->{PROPS} }; }
+sub args { return @{ shift->{ARGS} }; }
+
+sub file { return shift->{FILE}; }
+sub line { return shift->{LINE}; }
+
+sub is_global { return shift->scope eq 'global'; }
+sub is_local { return shift->scope eq 'local'; }
+sub is_constant { return shift->kind eq 'const'; }
+sub is_variable { my $self = shift; return ( $self->kind eq 'var' ) or ( $self->kind eq 'arg' ); }
+sub is_sub { my $self = shift; return $self->kind eq 'sub'; }
+sub is_module { my $self = shift; return $self->kind eq 'module'; }
+
+1;
+
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: jako/trunk/lib/Jako/Token.pm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/lib/Jako/Token.pm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,143 @@
+#
+# Token.pm
+#
+# Copyright (C) 2001-2005, Parrot Foundation.
+# This program is free software. It is subject to the same license
+# as the Parrot interpreter.
+#
+# $Id$
+#
+#
+
+use strict;
+use warnings;
+
+package Jako::Token;
+
+#
+# CONSTRUCTOR:
+#
+
+sub new {
+ my $class = shift;
+ my ( $file, $line, $kind, $type, $text ) = @_;
+
+ return bless {
+ FILE => $file,
+ LINE => $line,
+ KIND => $kind, # op,
+ TYPE => $type,
+ TEXT => $text
+ }, $class;
+}
+
+sub new_bof {
+ my $class = shift;
+ my ( $file, $line ) = @_;
+
+ return $class->new( $file, $line, 'bof', undef, '__BOF__' );
+}
+
+sub new_eof {
+ my $class = shift;
+ my ( $file, $line ) = @_;
+
+ return $class->new( $file, $line, 'eof', undef, '__EOF__' );
+}
+
+my $BOF = Jako::Token->new_bof( undef, undef );
+sub BOF { return $BOF }
+
+my $EOF = Jako::Token->new_eof( undef, undef );
+sub EOF { return $EOF }
+
+#
+# ACCESSORS:
+#
+
+sub file {
+ my $self = shift;
+ return defined $self->{FILE} ? $self->{FILE} : '<NO FILE>';
+}
+
+sub line {
+ my $self = shift;
+ return defined $self->{LINE} ? $self->{LINE} : '';
+}
+
+sub kind { return shift->{KIND}; }
+sub type { return shift->{TYPE}; }
+sub text { return shift->{TEXT}; }
+
+#
+# dump()
+#
+
+sub dump {
+ my $self = shift;
+
+ print STDERR "{\n";
+ foreach my $key ( sort keys %$self ) {
+ printf STDERR "%10s => %s\n", $key, $self->{$key};
+ }
+ print STDERR "}\n";
+}
+
+#
+# PREDICATES:
+#
+
+sub is {
+ my $self = shift;
+ return grep { $self->kind eq $_ } @_;
+}
+
+sub is_arith_assign { return shift->is('arith-assign'); }
+sub is_assign { return shift->is('assign'); }
+sub is_bit_assign { return shift->is('bit-assign'); }
+sub is_bof { return shift->is('bof'); }
+sub is_close_brace { return shift->is('close-brace'); }
+sub is_close_bracket { return shift->is('close-bracket'); }
+sub is_close_paren { return shift->is('close-paren'); }
+sub is_colon { return shift->is('colon'); }
+sub is_concat_assign { return shift->is('concat-assign'); }
+sub is_const { return shift->is('const'); }
+sub is_continue { return shift->is('continue'); }
+sub is_else { return shift->is('else'); }
+sub is_eof { return shift->is('eof'); }
+sub is_exfix_arith { return shift->is('exfix-arith'); }
+sub is_goto { return shift->is('goto'); }
+sub is_ident { return shift->is('ident'); }
+sub is_if { return shift->is('if'); }
+sub is_infix_arith { return shift->is('infix-arith'); }
+sub is_infix_bit { return shift->is('infix-bit'); }
+sub is_infix_concat { return shift->is('infix-concat'); }
+sub is_infix_rel { return shift->is('infix-rel'); }
+sub is_label { return shift->is('label'); }
+sub is_last { return shift->is('last'); }
+sub is_literal { return shift->is('literal'); }
+sub is_module { return shift->is('module'); }
+sub is_next { return shift->is('next'); }
+sub is_open_brace { return shift->is('open-brace'); }
+sub is_open_bracket { return shift->is('open-bracket'); }
+sub is_open_paren { return shift->is('open-paren'); }
+sub is_redo { return shift->is('redo'); }
+sub is_return { return shift->is('return'); }
+sub is_sub { return shift->is('sub'); }
+sub is_unless { return shift->is('unless'); }
+sub is_until { return shift->is('until'); }
+sub is_var { return shift->is('var'); }
+sub is_while { return shift->is('while'); }
+
+sub is_loop_control { return shift->is( 'next', 'last', 'redo' ); }
+sub is_value { return shift->is( 'ident', 'literal' ); }
+
+1;
+
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: jako/trunk/string.jako
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/string.jako Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,18 @@
+#
+# string.jako
+#
+# Copyright (C) 2003-2005, Parrot Foundation.
+# This program is free software. Its use is subject to the
+# same license as Parrot.
+#
+# $Id$
+#
+
+module string
+{
+ sub concat :op (str dest, str s);
+ sub int index :op (str input, str pattern, int start);
+ sub int length :op (str dest);
+ sub str substr :op (str s, int i, int l);
+}
+
Added: jako/trunk/sys.jako
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/sys.jako Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,21 @@
+#
+# sys.jako
+#
+# System ops.
+#
+# Copyright (C) 2003-2005, Parrot Foundation.
+# This program is free software. Its use is subject to the same
+# license as Parrot.
+#
+# $Id$
+#
+
+module sys
+{
+ sub print :op (str a);
+ sub int time :op ();
+ sub num timen :op="time" (); # TODO: Really want to allow overloads in Jako
+ sub sleep :op (int n);
+ sub exit :op (int s);
+}
+
Added: jako/trunk/t/assign.jako
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/t/assign.jako Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,21 @@
+var int a, b, c;
+var num d, e;
+var str f, g;
+
+a = 5;
+a = b = c = 5;
+
+d = 3.14;
+d = e = 3.14;
+
+f = "Howdy";
+f = g = "Howdy";
+
+a = b;
+a = b = c;
+
+var int w, x, y, z;
+y = 42;
+z = 137;
+w, x = y, z;
+
Added: jako/trunk/t/data_decl.jako
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/t/data_decl.jako Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,25 @@
+var int foo1;
+var int foo2 = 5;
+
+var num bar1;
+var num bar2 = 3.14;
+
+var str splee1;
+var str splee2 = "Howdy";
+
+var pmc quux1;
+
+var int foo3, bar3;
+var int foo4, bar4 = 5;
+
+var num bar5, splee3;
+var num bar6, splee4 = 3.14;
+
+var str splee5, quux2;
+var str splee6, quux3 = "Howdy";
+
+var pmc quux4, baz1;
+
+const int foo5 = 5;
+const num bar7 = 3.14;
+const str splee7 = "Howdy";
Added: jako/trunk/t/examples.t
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/t/examples.t Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,177 @@
+#! perl
+# Copyright (C) 2005-2007, Parrot Foundation.
+# $Id$
+
+use strict;
+use warnings;
+use lib qw( . lib ../lib ../../lib );
+use Test::More;
+use Parrot::Test tests => 15;
+use Parrot::Config;
+
+=head1 NAME
+
+jako/t/examples.t - Test examples in F<jako/examples>
+
+=head1 SYNOPSIS
+
+ % prove languages/jako/t/examples.t
+
+=head1 DESCRIPTION
+
+Test the examples in F<jako/examples>.
+
+=head1 SEE ALSO
+
+F<t/examples/pir.t>
+
+=head1 AUTHOR
+
+Bernhard Schmalhofer - <Bernhard.Schmalhofer at gmx.de>
+
+=cut
+
+# Set up expected output for examples
+my $fact15 = eval join '*', (1 .. 15);
+if ($PConfig{intvalsize} == 4) {
+ $fact15 = hex(substr(sprintf('%x',$fact15),-8,8));
+}
+
+my %expected = (
+ 'board.pir' => << 'END_EXPECTED',
+ +---+---+---+---+---+---+---+---+
+8 | | * | | * | | * | | * |
+ +---+---+---+---+---+---+---+---+
+7 | * | | * | | * | | * | |
+ +---+---+---+---+---+---+---+---+
+6 | | * | | * | | * | | * |
+ +---+---+---+---+---+---+---+---+
+5 | * | | * | | * | | * | |
+ +---+---+---+---+---+---+---+---+
+4 | | * | | * | | * | | * |
+ +---+---+---+---+---+---+---+---+
+3 | * | | * | | * | | * | |
+ +---+---+---+---+---+---+---+---+
+2 | | * | | * | | * | | * |
+ +---+---+---+---+---+---+---+---+
+1 | * | | * | | * | | * | |
+ +---+---+---+---+---+---+---+---+
+ A B C D E F G H
+END_EXPECTED
+
+ 'euclid.pir' => << 'END_EXPECTED',
+Algorithm E (Euclid's algorithm)
+ Calculating gcd(96, 64) = ...
+ ... = 32
+END_EXPECTED
+
+ 'fact.pir' => << "END_EXPECTED",
+Algorithm F1 (The factorial function)
+ Calculating fact(15) = ...
+ ... = $fact15
+END_EXPECTED
+
+ 'fib.pir' => << 'END_EXPECTED',
+Algorithm F2 (Fibonacci's function)
+ Calculating fib(24) = ...
+ ... = 46368
+END_EXPECTED
+
+ 'hello.pir' => << 'END_EXPECTED',
+Hello, world!
+END_EXPECTED
+
+ 'leibniz.pir' => << 'END_EXPECTED',
+PI is (very) approximately: 3.14159
+END_EXPECTED
+
+ 'mandelbrot.pir' => << 'END_EXPECTED',
+................::::::::::::::::::::::::::::::::::::::::::::...............
+...........::::::::::::::::::::::::::::::::::::::::::::::::::::::..........
+........::::::::::::::::::::::::::::::::::,,,,,,,:::::::::::::::::::.......
+.....:::::::::::::::::::::::::::::,,,,,,,,,,,,,,,,,,,,,,:::::::::::::::....
+...::::::::::::::::::::::::::,,,,,,,,,,,,;;;!:H!!;;;,,,,,,,,:::::::::::::..
+:::::::::::::::::::::::::,,,,,,,,,,,,,;;;;!!/>&*|& !;;;,,,,,,,:::::::::::::
+::::::::::::::::::::::,,,,,,,,,,,,,;;;;;!!//)|.*#|>/!;;;;;,,,,,,:::::::::::
+::::::::::::::::::,,,,,,,,,,,,;;;;;;!!!!//>|: !:|//!!;;;;;,,,,,:::::::::
+:::::::::::::::,,,,,,,,,,;;;;;;;!!/>>I>>)||I# H&))>////*!;;,,,,::::::::
+::::::::::,,,,,,,,,,;;;;;;;;;!!!!/>H: #| IH&*I#/;;,,,,:::::::
+::::::,,,,,,,,,;;;;;!!!!!!!!!!//>|.H: #I>!!;;,,,,::::::
+:::,,,,,,,,,;;;;!/||>///>>///>>)|H %|&/;;,,,,,:::::
+:,,,,,,,,;;;;;!!//)& :;I*,H#&||&/ *)/!;;,,,,,::::
+,,,,,,;;;;;!!!//>)IH:, ## #&!!;;,,,,,::::
+,;;;;!!!!!///>)H%.** * )/!;;;,,,,,::::
+ &)/!!;;;,,,,,::::
+,;;;;!!!!!///>)H%.** * )/!;;;,,,,,::::
+,,,,,,;;;;;!!!//>)IH:, ## #&!!;;,,,,,::::
+:,,,,,,,,;;;;;!!//)& :;I*,H#&||&/ *)/!;;,,,,,::::
+:::,,,,,,,,,;;;;!/||>///>>///>>)|H %|&/;;,,,,,:::::
+::::::,,,,,,,,,;;;;;!!!!!!!!!!//>|.H: #I>!!;;,,,,::::::
+::::::::::,,,,,,,,,,;;;;;;;;;!!!!/>H: #| IH&*I#/;;,,,,:::::::
+:::::::::::::::,,,,,,,,,,;;;;;;;!!/>>I>>)||I# H&))>////*!;;,,,,::::::::
+::::::::::::::::::,,,,,,,,,,,,;;;;;;!!!!//>|: !:|//!!;;;;;,,,,,:::::::::
+::::::::::::::::::::::,,,,,,,,,,,,,;;;;;!!//)|.*#|>/!;;;;;,,,,,,:::::::::::
+:::::::::::::::::::::::::,,,,,,,,,,,,,;;;;!!/>&*|& !;;;,,,,,,,:::::::::::::
+...::::::::::::::::::::::::::,,,,,,,,,,,,;;;!:H!!;;;,,,,,,,,:::::::::::::..
+.....:::::::::::::::::::::::::::::,,,,,,,,,,,,,,,,,,,,,,:::::::::::::::....
+........::::::::::::::::::::::::::::::::::,,,,,,,:::::::::::::::::::.......
+...........::::::::::::::::::::::::::::::::::::::::::::::::::::::..........
+END_EXPECTED
+
+ 'primes.pir' => << 'END_EXPECTED',
+Algorithm P (Naiive primality test)
+ Printing primes up to 100...
+2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71 73 79 83 89 97
+END_EXPECTED
+
+ 'queens.pir' => << 'END_EXPECTED',
+Making new board with 8 ranks and 8 files...
+Board length is 64.
+ +---+---+---+---+---+---+---+---+
+8 | | * | Q | * | | * | | * |
+ +---+---+---+---+---+---+---+---+
+7 | * | | * | | * | Q | * | |
+ +---+---+---+---+---+---+---+---+
+6 | | * | | Q | | * | | * |
+ +---+---+---+---+---+---+---+---+
+5 | * | Q | * | | * | | * | |
+ +---+---+---+---+---+---+---+---+
+4 | | * | | * | | * | | Q |
+ +---+---+---+---+---+---+---+---+
+3 | * | | * | | Q | | * | |
+ +---+---+---+---+---+---+---+---+
+2 | | * | | * | | * | Q | * |
+ +---+---+---+---+---+---+---+---+
+1 | Q | | * | | * | | * | |
+ +---+---+---+---+---+---+---+---+
+ A B C D E F G H
+END_EXPECTED
+
+ 'sub.pir' => << 'END_EXPECTED',
+x = 42; y = 137
+x = 1234; y = 137
+END_EXPECTED
+
+);
+
+while ( my ( $example, $expected ) = each %expected ) {
+ example_output_is( "jako/examples/$example", $expected );
+}
+
+TODO:
+{
+ local $TODO = 'some examples not testable yet';
+
+ fail('bench.pir');
+ fail('life.pir');
+ fail('mandelzoom.pir');
+ fail('mops.pir');
+ fail('nci.pir');
+}
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: jako/trunk/t/harness
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ jako/trunk/t/harness Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,21 @@
+#! perl
+
+# $Id$
+
+=head1 NAME
+
+languages/jako/t/harness - A harness for Jako
+
+=head1 SYNOPSIS
+
+ cd languages && perl -I../lib jako/t/harness --files
+
+=head1 DESCRIPTION
+
+If I'm called with a single
+argument of "--files", I just return a list of files to process.
+This list is one per line, and is relative to the languages dir.
+
+=cut
+
+use Parrot::Test::Harness language => 'jako';
Added: lisp/trunk/CHANGES
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ lisp/trunk/CHANGES Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,28 @@
+Changes for version 0.4.13
+--------------------------
+ * Change LICENSE to Artistic License 2.0
+ * Start with a test suite
+
+Changes for version 0.4.12
+--------------------------
+ * Make languages/lisp compile again, as it was broken due to changes in Parrot
+
+Changes for version 0.1.2
+-------------------------
+ * Added basic macro support
+ * Added a basic DEFUN macro
+ * Added support for loading a file off the command line (based on a patch
+ from Leo)
+ * Speed ups in checking list lengths (courtesy Leo)
+ * Rewrote Lisp functions to use DEFUN
+
+Changes for version 0.1.1
+-------------------------
+ * Added BOUNDP function
+ * Added COPY-TREE function
+ * Added IDENTITY function
+ * Added ACONS function
+ * Added ZEROP function
+ * Added an EXPORT function stub
+ * Added an IN-PACKAGE function stub
+ * Split related functions out into separate files in lisp/
Added: lisp/trunk/KNOWN_BUGS
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ lisp/trunk/KNOWN_BUGS Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,8 @@
+# $Id$
+
+Known deficencies in Parrot Common Lisp:
+
+Some broken features.
+
+( print "asdf" ) print asdf and not "asdf"
+
Added: lisp/trunk/LICENSE
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ lisp/trunk/LICENSE Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,201 @@
+ The Artistic License 2.0
+
+ Copyright (c) 2000-2006, The Perl Foundation.
+
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+Preamble
+
+This license establishes the terms under which a given free software
+Package may be copied, modified, distributed, and/or redistributed.
+The intent is that the Copyright Holder maintains some artistic
+control over the development of that Package while still keeping the
+Package available as open source and free software.
+
+You are always permitted to make arrangements wholly outside of this
+license directly with the Copyright Holder of a given Package. If the
+terms of this license do not permit the full use that you propose to
+make of the Package, you should contact the Copyright Holder and seek
+a different licensing arrangement.
+
+Definitions
+
+ "Copyright Holder" means the individual(s) or organization(s)
+ named in the copyright notice for the entire Package.
+
+ "Contributor" means any party that has contributed code or other
+ material to the Package, in accordance with the Copyright Holder's
+ procedures.
+
+ "You" and "your" means any person who would like to copy,
+ distribute, or modify the Package.
+
+ "Package" means the collection of files distributed by the
+ Copyright Holder, and derivatives of that collection and/or of
+ those files. A given Package may consist of either the Standard
+ Version, or a Modified Version.
+
+ "Distribute" means providing a copy of the Package or making it
+ accessible to anyone else, or in the case of a company or
+ organization, to others outside of your company or organization.
+
+ "Distributor Fee" means any fee that you charge for Distributing
+ this Package or providing support for this Package to another
+ party. It does not mean licensing fees.
+
+ "Standard Version" refers to the Package if it has not been
+ modified, or has been modified only in ways explicitly requested
+ by the Copyright Holder.
+
+ "Modified Version" means the Package, if it has been changed, and
+ such changes were not explicitly requested by the Copyright
+ Holder.
+
+ "Original License" means this Artistic License as Distributed with
+ the Standard Version of the Package, in its current version or as
+ it may be modified by The Perl Foundation in the future.
+
+ "Source" form means the source code, documentation source, and
+ configuration files for the Package.
+
+ "Compiled" form means the compiled bytecode, object code, binary,
+ or any other form resulting from mechanical transformation or
+ translation of the Source form.
+
+
+Permission for Use and Modification Without Distribution
+
+(1) You are permitted to use the Standard Version and create and use
+Modified Versions for any purpose without restriction, provided that
+you do not Distribute the Modified Version.
+
+
+Permissions for Redistribution of the Standard Version
+
+(2) You may Distribute verbatim copies of the Source form of the
+Standard Version of this Package in any medium without restriction,
+either gratis or for a Distributor Fee, provided that you duplicate
+all of the original copyright notices and associated disclaimers. At
+your discretion, such verbatim copies may or may not include a
+Compiled form of the Package.
+
+(3) You may apply any bug fixes, portability changes, and other
+modifications made available from the Copyright Holder. The resulting
+Package will still be considered the Standard Version, and as such
+will be subject to the Original License.
+
+
+Distribution of Modified Versions of the Package as Source
+
+(4) You may Distribute your Modified Version as Source (either gratis
+or for a Distributor Fee, and with or without a Compiled form of the
+Modified Version) provided that you clearly document how it differs
+from the Standard Version, including, but not limited to, documenting
+any non-standard features, executables, or modules, and provided that
+you do at least ONE of the following:
+
+ (a) make the Modified Version available to the Copyright Holder
+ of the Standard Version, under the Original License, so that the
+ Copyright Holder may include your modifications in the Standard
+ Version.
+
+ (b) ensure that installation of your Modified Version does not
+ prevent the user installing or running the Standard Version. In
+ addition, the Modified Version must bear a name that is different
+ from the name of the Standard Version.
+
+ (c) allow anyone who receives a copy of the Modified Version to
+ make the Source form of the Modified Version available to others
+ under
+
+ (i) the Original License or
+
+ (ii) a license that permits the licensee to freely copy,
+ modify and redistribute the Modified Version using the same
+ licensing terms that apply to the copy that the licensee
+ received, and requires that the Source form of the Modified
+ Version, and of any works derived from it, be made freely
+ available in that license fees are prohibited but Distributor
+ Fees are allowed.
+
+
+Distribution of Compiled Forms of the Standard Version
+or Modified Versions without the Source
+
+(5) You may Distribute Compiled forms of the Standard Version without
+the Source, provided that you include complete instructions on how to
+get the Source of the Standard Version. Such instructions must be
+valid at the time of your distribution. If these instructions, at any
+time while you are carrying out such distribution, become invalid, you
+must provide new instructions on demand or cease further distribution.
+If you provide valid instructions or cease distribution within thirty
+days after you become aware that the instructions are invalid, then
+you do not forfeit any of your rights under this license.
+
+(6) You may Distribute a Modified Version in Compiled form without
+the Source, provided that you comply with Section 4 with respect to
+the Source of the Modified Version.
+
+
+Aggregating or Linking the Package
+
+(7) You may aggregate the Package (either the Standard Version or
+Modified Version) with other packages and Distribute the resulting
+aggregation provided that you do not charge a licensing fee for the
+Package. Distributor Fees are permitted, and licensing fees for other
+components in the aggregation are permitted. The terms of this license
+apply to the use and Distribution of the Standard or Modified Versions
+as included in the aggregation.
+
+(8) You are permitted to link Modified and Standard Versions with
+other works, to embed the Package in a larger work of your own, or to
+build stand-alone binary or bytecode versions of applications that
+include the Package, and Distribute the result without restriction,
+provided the result does not expose a direct interface to the Package.
+
+
+Items That are Not Considered Part of a Modified Version
+
+(9) Works (including, but not limited to, modules and scripts) that
+merely extend or make use of the Package, do not, by themselves, cause
+the Package to be a Modified Version. In addition, such works are not
+considered parts of the Package itself, and are not subject to the
+terms of this license.
+
+
+General Provisions
+
+(10) Any use, modification, and distribution of the Standard or
+Modified Versions is governed by this Artistic License. By using,
+modifying or distributing the Package, you accept this license. Do not
+use, modify, or distribute the Package, if you do not accept this
+license.
+
+(11) If your Modified Version has been derived from a Modified
+Version made by someone other than you, you are nevertheless required
+to ensure that your Modified Version complies with the requirements of
+this license.
+
+(12) This license does not grant you the right to use any trademark,
+service mark, tradename, or logo of the Copyright Holder.
+
+(13) This license includes the non-exclusive, worldwide,
+free-of-charge patent license to make, have made, use, offer to sell,
+sell, import and otherwise transfer the Package with respect to any
+patent claims licensable by the Copyright Holder that are necessarily
+infringed by the Package. If you institute patent litigation
+(including a cross-claim or counterclaim) against any party alleging
+that the Package constitutes direct or contributory patent
+infringement, then this Artistic License to you shall terminate on the
+date that such litigation is filed.
+
+(14) Disclaimer of Warranty:
+THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER AND CONTRIBUTORS "AS
+IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES. THE IMPLIED
+WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, OR
+NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY YOUR LOCAL
+LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR CONTRIBUTOR WILL
+BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL
+DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE, EVEN IF
+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Added: lisp/trunk/MAINTAINER
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ lisp/trunk/MAINTAINER Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,3 @@
+# $Id$
+
+N: Cory Spencer
Added: lisp/trunk/README
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ lisp/trunk/README Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,11 @@
+This is Parrot Common Lisp
+--------------------------
+
+Parrot Common Lisp is Copyright (C) 2004 - 2005 Cory Spencer. All
+Rights Reserved.
+
+LICENSE INFORMATION
+-------------------
+
+This code is distributed under the "Artistic License 2.0".
+The "Artistic License 2.0" can be found in the file "LICENSE".
Added: lisp/trunk/cl.pir
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ lisp/trunk/cl.pir Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,1334 @@
+# $Id$
+
+=head1 NAME
+
+cl.pir - Set up the package 'COMMON-LISP'
+
+=cut
+
+.sub _init_cl :init
+
+ .local pmc symbol
+ .local pmc value
+
+ .local pmc package
+ .PACKAGE(package, "COMMON-LISP")
+ set_global ["PACKAGES"], "COMMON-LISP", package
+ set_global ["PACKAGES"], "CL", package
+
+ .local pmc t
+ t = package.'_intern_symbol'("T") # Create the T symbol, T meaning true
+ t.'_set_value'(t)
+ t.'_set_package'(package)
+ t.'_set_special'(t)
+ set_global ["SYMBOLS"], "T", t # Quick alias to T
+
+ .local pmc nil
+ nil = package.'_intern_symbol'("NIL") # Create the NIL symbol
+ nil.'_set_value'(nil)
+ nil.'_set_package'(package)
+ nil.'_set_special'(t)
+ set_global ["SYMBOLS"], "NIL", nil # Quick alias to NIL
+
+ .INTEGER(value,1)
+ .DEFVAR(symbol, package, "*GENSYM-COUNTER*", value)
+
+ .DEFVAR(symbol, package, "*PACKAGE*", package)
+
+ .READTABLE(value)
+ .DEFVAR(symbol, package, "*READTABLE*", value)
+
+ .local pmc stream
+ getstdin stream
+ .STREAM(value,stream)
+ .DEFVAR(symbol, package, "*STANDARD-INPUT*", value)
+
+ getstdout stream
+ stream.'buffer_type'('unbuffered')
+ .STREAM(value,stream)
+ .DEFVAR(symbol, package, "*STANDARD-OUTPUT*", value)
+
+ .local pmc function # this is needed in r20641
+
+ # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "APPLY", _apply)
+ .DEFUN(symbol, package, "APPLY", "_apply")
+
+ # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "ATOM", _atom)
+ .DEFUN(symbol, package, "ATOM", "_atom")
+
+ # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "BOUNDP", _boundp)
+ .DEFUN(symbol, package, "BOUNDP", "_boundp")
+
+ # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "CAR", _car)
+ .DEFUN(symbol, package, "CAR", "_car")
+
+ # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "CDR", _cdr)
+ .DEFUN(symbol, package, "CDR", "_cdr")
+
+ # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "CHAR", _char)
+ .DEFUN(symbol, package, "CHAR", "_char")
+
+ # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "CONS", _cons)
+ .DEFUN(symbol, package, "CONS", "_cons")
+
+ # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "EQ", _eq)
+ .DEFUN(symbol, package, "EQ", "_eq")
+
+ # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "EVAL", _eval)
+ .DEFUN(symbol, package, "EVAL", "_eval")
+
+ .SPECIAL_FORM(symbol, package, "FUNCTION", '_function')
+
+ # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "GENSYM", _gensym)
+ .DEFUN(symbol, package, "GENSYM", "_gensym")
+
+ .SPECIAL_FORM(symbol, package, "IF", '_if')
+
+ .SPECIAL_FORM(symbol, package, "LET", '_let')
+
+ # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "LIST", _list)
+ .DEFUN(symbol, package, "LIST", "_list")
+
+ # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "MOD", _modulus)
+ .DEFUN(symbol, package, "MOD", "_modulus")
+
+ # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "NULL", _null)
+ .DEFUN(symbol, package, "NULL", "_null")
+
+ .DEFUN(symbol, package, "PRINT", "_print")
+
+ .SPECIAL_FORM(symbol, package, "PROGN", '_progn')
+
+ .SPECIAL_FORM(symbol, package, "QUOTE", '_quote')
+
+ # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "READ", _read)
+ .DEFUN(symbol, package, "READ", "_read")
+
+ # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "READ-DELIMITED-LIST",_read_delimited_list)
+ .DEFUN(symbol, package, "READ-DELIMITED-LIST","_read_delimited_list")
+
+ # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "RPLACA", _rplaca)
+ .DEFUN(symbol, package, "RPLACA", "_rplaca")
+
+ # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "RPLACD", _rplacd)
+ .DEFUN(symbol, package, "RPLACD", "_rplacd")
+
+ .SPECIAL_FORM(symbol, package, "SETQ", '_setq')
+
+ # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "TYPE-OF", _type_of)
+ .DEFUN(symbol, package, "TYPE-OF", "_type_of")
+
+ # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "VALUES", _values)
+ .DEFUN(symbol, package, "VALUES", "_values")
+
+ # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "QUIT", _quit)
+ .DEFUN(symbol, package, "QUIT", "_quit")
+
+ # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "/", _divide)
+ .DEFUN(symbol, package, "/", "_divide")
+
+ # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "-", _subtract)
+ .DEFUN(symbol, package, "-", "_subtract")
+
+ # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "*", _multiply)
+ .DEFUN(symbol, package, "*", "_multiply")
+
+ # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "+", _add)
+ .DEFUN(symbol, package, "+", "_add")
+
+ # VALID_IN_PARROT_0_2_0 .DEFUN(symbol, package, "=", _equal)
+ .DEFUN(symbol, package, "=", "_equal")
+
+ .return(1)
+.end
+
+.sub _apply
+ .param pmc args
+ .ASSERT_MINIMUM_LENGTH(args, 2, ERROR_NARGS)
+
+ .local pmc car
+ .CAR(car, args)
+
+ .local pmc args_of_func
+ .SECOND(args_of_func, args)
+ .ASSERT_TYPE(args_of_func, "list")
+
+ .local string type
+ type = typeof car
+ if type == "LispFunction" goto CAR_IS_FUNCTION
+ if type == "LispSymbol" goto CAR_IS_SYMBOL
+ goto INVALID_FUNCTION_NAME
+
+CAR_IS_FUNCTION:
+ .tailcall _FUNCTION_CALL(car, args_of_func)
+
+CAR_IS_SYMBOL:
+ .local pmc func
+ func = car.'_get_function'() # Get the function from symbol
+ if_null func, INVALID_FUNCTION_NAME # Throw an error if undefined
+ type = typeof func
+ # print type
+ # print ' for CAR_IS_SYMBOL'
+ .tailcall _FUNCTION_CALL(func,args_of_func)
+
+INVALID_FUNCTION_NAME:
+ .ERROR_1("undefined-function", "%s is not a function name", car)
+ goto DONE
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to APPLY")
+ goto DONE
+
+ERROR_NONLIST:
+ .ERROR_0("type-error", "second argument to APPLY must be a proper list")
+ goto DONE
+
+DONE:
+ .return() # Call the return continuation
+.end
+
+.sub _atom
+ .param pmc args
+ .local string type
+ .local pmc retv
+ .local pmc a
+
+ .ASSERT_LENGTH(args, 1, ERROR_NARGS)
+
+ .CAR(a, args)
+
+ type = typeof a # An atom is anything that is
+ if type != "LispCons" goto ATOM # not a cons.
+ goto CONS
+
+ATOM:
+ .TRUE(retv)
+ goto DONE
+
+CONS:
+ .NIL(retv)
+ goto DONE
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to ATOM")
+ goto DONE
+
+DONE:
+ .return(retv)
+.end
+
+.sub _boundp
+ .param pmc args
+ .local pmc symbol
+ .local pmc retv
+ .local pmc val
+
+ .ASSERT_LENGTH(args, 1, ERROR_NARGS)
+
+ .CAR(symbol, args)
+ .ASSERT_TYPE(symbol, "symbol")
+
+ val = symbol.'_get_value'()
+ if_null val, UNBOUND
+
+ .TRUE(retv)
+ goto DONE
+
+UNBOUND:
+ .NIL(retv)
+ goto DONE
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to BOUNDP")
+ goto DONE
+
+DONE:
+ .return(retv)
+.end
+
+.sub _car
+ .param pmc args
+ .local pmc retv
+ .local pmc a
+
+ .ASSERT_LENGTH(args, 1, ERROR_NARGS)
+
+ .CAR(a, args)
+ .ASSERT_TYPE(a, "list")
+
+ .CAR(retv, a)
+
+ goto DONE
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to CAR")
+ goto DONE
+
+DONE:
+ .return(retv)
+.end
+
+.sub _cdr
+ .param pmc args
+ .local pmc retv
+ .local pmc a
+
+ .ASSERT_LENGTH(args, 1, ERROR_NARGS)
+
+ .CAR(a, args)
+ .ASSERT_TYPE(a, "list")
+
+ .CDR(retv, a)
+
+ goto DONE
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to CDR")
+ goto DONE
+
+DONE:
+ .return(retv)
+.end
+
+.sub _char
+ .param pmc args
+
+ .local pmc retval
+ .local pmc ke
+ .local string str
+ .local string sstr
+ .local int k
+ .local int leng
+
+ .ASSERT_LENGTH(args, 2, ERROR_NARGS)
+
+ str = args[0]
+ ke = args[1]
+ k = ke[0]
+
+ length leng, str
+
+ if k > leng goto BOUNDS
+ if k < 0 goto BOUNDS
+
+ sstr = substr str, k, 1
+ retval = new 'LispString'
+ retval = sstr
+ goto DONE
+
+BOUNDS:
+ .NIL(retval)
+ goto DONE
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to CHAR")
+ goto DONE
+
+DONE:
+ .return(retval)
+.end
+
+.sub _cons
+ .param pmc args
+ .local pmc retv
+ .local pmc a
+ .local pmc b
+
+ .ASSERT_LENGTH(args, 2, ERROR_NARGS)
+
+ .CAR(a, args)
+ .SECOND(b, args)
+
+ .CONS(retv, a, b)
+ goto DONE
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to CONS")
+ goto DONE
+
+DONE:
+ .return(retv)
+.end
+
+.sub _eq
+ .param pmc args
+ .local pmc retv
+ .local pmc a
+ .local pmc b
+
+ .ASSERT_LENGTH(args, 2, ERROR_NARGS)
+
+ .CAR(a, args)
+ .SECOND(b, args)
+
+ eq_addr a, b, EQUAL
+ goto NOT_EQUAL
+
+EQUAL:
+ .TRUE(retv)
+ goto DONE
+
+NOT_EQUAL:
+ .NIL(retv)
+ goto DONE
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to EQ")
+ goto DONE
+
+DONE:
+ .return(retv)
+.end
+
+.sub _function
+ .param pmc args
+ .ASSERT_LENGTH(args, 1, ERROR_NARGS)
+
+ .local pmc form
+ .CAR(form, args)
+
+ .local pmc retv
+
+ .local string type
+ type = typeof form
+ if type == "LispSymbol" goto SYMBOL # Retrieve function from symbol
+
+ .local int is_lambda_list
+ is_lambda_list = _IS_ORDINARY_LAMBDA_LIST(form) # Check if it's a lambda form
+ if is_lambda_list goto LAMBDA_FORM # and build a closure if so
+
+ goto INVALID_FUNCTION_NAME
+
+SYMBOL:
+ .local string symname
+ symname = form.'_get_name_as_string'() # Retrieve the symbols name
+
+ .local pmc package
+ package = form.'_get_package'() # Retrieve the symbols package name
+ .local string pkgname
+ pkgname = package.'_get_name_as_string'()
+
+ .local pmc symbol
+ symbol = _LOOKUP_GLOBAL(pkgname, symname) # Lookup the symbol
+
+ .local int found
+ found = defined symbol # Ensure the symbol was found in
+ unless found goto FUNCTION_NOT_FOUND # the global namespace
+
+ retv = symbol.'_get_function'() # Ensure the symbol had a function
+ defined found, symbol # defined
+ unless found goto FUNCTION_NOT_FOUND
+
+ goto DONE
+
+LAMBDA_FORM:
+ retv = _MAKE_LAMBDA(form) # Create a closure PMC
+ goto DONE
+
+INVALID_FUNCTION_NAME:
+ .ERROR_1("undefined-function", "%s is not a function name", form)
+ goto DONE
+
+FUNCTION_NOT_FOUND:
+ .ERROR_1("undefined-function", "the function %s is undefined", symname)
+ goto DONE
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to FUNCTION")
+ goto DONE
+
+DONE:
+ .return(retv)
+.end
+
+.sub _gensym
+ .param pmc args
+ .local string prefix
+ .local string gname
+ .local pmc suffix
+ .local pmc symbol
+ .local pmc garg
+ .local pmc gcnt
+ .local pmc retv
+ .local pmc car
+
+ .ASSERT_LENGTH_BETWEEN(args, 0, 1, ERROR_NARGS)
+
+ symbol = _LOOKUP_GLOBAL("COMMON-LISP", "*GENSYM-COUNTER*")
+ gcnt = symbol.'_get_value'()
+
+ suffix = gcnt
+ prefix = "G"
+
+ .NULL(args, MAKE_SYMBOL)
+
+ .CAR(car, args)
+ goto CHECK_PREFIX
+
+CHECK_PREFIX:
+ .ASSERT_TYPE_AND_BRANCH(car, "string", CHECK_SUFFIX)
+ prefix = car
+ goto MAKE_SYMBOL
+
+CHECK_SUFFIX:
+ .ASSERT_TYPE(car, "integer")
+ if car < 0 goto ERROR_NEGINT
+ suffix = car
+ goto MAKE_SYMBOL
+
+MAKE_SYMBOL:
+ garg = new 'Array'
+ garg = 2
+ garg[0] = prefix
+ garg[1] = suffix
+
+ sprintf gname, "%s%0.6d", garg
+ retv = _SYMBOL(gname)
+
+ inc gcnt
+ goto DONE
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to GENSYM")
+ goto DONE
+
+ERROR_NEGINT:
+ .ERROR_1("program-error", "%d is negative", car)
+ goto DONE
+
+DONE:
+ .return(retv)
+.end
+
+.sub _if
+ .param pmc args
+ .local pmc retv
+ .local pmc form
+ .local pmc earg
+
+ .ASSERT_LENGTH_BETWEEN(args, 2, 3, ERROR_NARGS)
+
+ .CAR(form, args) # Get the test form
+
+ .LIST_1(earg,form)
+ retv = _eval(earg) # Evaluate the test form.
+
+ .NULL(retv, ELSE_CLAUSE) # If test was false, goto else clause
+ goto THEN_CLAUSE #else goto then clause
+
+THEN_CLAUSE:
+ .SECOND(form, args)
+
+ .LIST_1(earg, form)
+ retv = _eval(earg)
+ goto DONE
+
+ELSE_CLAUSE:
+ .THIRD(form, args)
+
+ .LIST_1(earg, form)
+ retv = _eval(earg)
+ goto DONE
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to IF")
+ goto DONE
+
+DONE:
+ .return(retv)
+.end
+
+.sub _list
+ .param pmc args
+ .local pmc lptr
+ .local pmc targ
+ .local pmc retv
+ .local pmc retp
+ .local pmc cons
+ .local pmc nil
+
+ .NIL(retv)
+ .NIL(nil)
+
+ lptr = args
+LOOP:
+ .NULL(lptr, DONE)
+
+ .CAR(targ, lptr)
+
+ .NULL(retv, EMPTY_LIST)
+
+ .CONS(cons, targ, nil)
+ retp[1] = cons
+ retp = cons
+
+EMPTY_LIST_RETURN:
+ .CDR(lptr, lptr)
+ goto LOOP
+
+EMPTY_LIST:
+ .CONS(retv, targ, nil)
+ retp = retv
+ goto EMPTY_LIST_RETURN
+
+DONE:
+ .return(retv)
+.end
+
+.sub _null
+ .param pmc args
+ .local pmc retv
+ .local pmc a
+
+ .ASSERT_LENGTH(args, 1, ERROR_NARGS)
+
+ .CAR(a, args)
+
+ .NULL(a, IS_NULL)
+
+ .NIL(retv)
+ goto DONE
+
+IS_NULL:
+ .TRUE(retv)
+ goto DONE
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to NULL")
+ goto DONE
+
+DONE:
+ .return(retv)
+.end
+
+.sub _let
+ .param pmc args
+ .ASSERT_MINIMUM_LENGTH(args, 1, ERROR_NARGS)
+
+ .local string name
+ .local string type
+ .local pmc package
+ .local pmc symbol
+ .local pmc value
+ .local pmc fargs
+ .local pmc init
+ .local pmc body
+ .local pmc lptr
+ .local pmc form
+ .local int test
+ .local int i
+
+ # VALID_IN_PARROT_0_2_0 new_pad -1 # Create new lexical scope
+
+ .CAR(init, args) # The variable bindings
+ .CDR(body, args) # The form to evaluate
+
+ .local pmc keyvals
+ keyvals = new 'ResizablePMCArray' # List for holding init values
+ .local pmc dynvars
+ dynvars = new 'ResizablePMCArray' # List for holding dynamic vars
+
+ # for exception handling, currently broken
+ .local pmc error
+ null error
+ push_eh CLEANUP_HANDLER # Set a handler for cleanup
+
+ .local pmc retv
+ .NIL(retv) # Initialize return value
+
+INIT_FORM: # Process the init form
+ type = typeof init
+ if type == "LispSymbol" goto INIT_SYMBOL
+ if type == "LispCons" goto INIT_LIST
+ goto EVAL_BODY
+
+INIT_SYMBOL:
+ push keyvals, init # Init form was just a symbol -
+ null value # no value is assigned to it
+ push keyvals, value
+
+ goto INIT_DONE
+
+INIT_LIST:
+ lptr = init
+ goto INIT_LIST_LOOP
+
+INIT_LIST_LOOP:
+ .NULL(lptr, INIT_DONE)
+
+ .CAR(form, lptr) # Get the next init form
+
+ .ASSERT_TYPE_AND_BRANCH(form, "list", ERROR_BAD_SPEC)
+ # VALID_IN_PARROT_0_2_0 .ASSERT_LENGTH(form, 2, ERROR_BADSPEC) # Ensure a valid init form
+ .ASSERT_LENGTH(form, 2, ERROR_BAD_SPEC) # Ensure a valid init form
+
+ .CAR(symbol, form) # The symbol we're assigning to
+ .SECOND(value, form) # The value being assigned
+
+ .ASSERT_TYPE_AND_BRANCH(symbol, "symbol", ERROR_BAD_SPEC)
+
+ .LIST_1(fargs, value) # Put value into an arg list
+ value = _eval(fargs) # Evaluate it
+
+ push keyvals, symbol # Push symbol onto key/val list
+ push keyvals, value # Push value onto key/val list
+
+ .CDR(lptr, lptr)
+ goto INIT_LIST_LOOP
+
+INIT_DONE:
+
+ # bind the variables in init
+ .local int nvar
+ nvar = keyvals
+ i = 0
+BIND_LOOP:
+ if i >= nvar goto BIND_DONE
+
+ symbol = keyvals[i] # Pop symbol of key/val list
+ inc i
+ value = keyvals[i] # Pop value of key/val list
+
+ name = symbol.'_get_name_as_string'()
+
+ test = _IS_SPECIAL(symbol)
+ if test == 0 goto BIND_LEXICAL
+ goto BIND_DYNAMIC
+
+BIND_LEXICAL:
+ # TODO: replace push_pad, pop_pad, do not worry about closures yet
+ symbol = _LEXICAL_SYMBOL(name, value) # Create a new lexical symbol
+ inc i
+ goto BIND_LOOP
+
+BIND_DYNAMIC:
+ package = symbol.'_get_package'() # Get dynamic symbols package
+
+ symbol = package.'_shadow_symbol'(name) # Shadow the symbol
+ symbol.'_set_value'(value) # Set the new value
+
+ push dynvars, symbol # Keep around for tracking
+
+ inc i
+ goto BIND_LOOP
+
+BIND_DONE:
+ goto EVAL_BODY
+
+
+EVAL_BODY:
+ lptr = body # Set pointer to the body form
+
+EVAL_LOOP: # Evaluate each form in order
+ .NULL(lptr, EVAL_DONE)
+
+ .CAR(form, lptr) # Get the next form in the body
+ .LIST_1(fargs, form) # Put it into an arg list
+ retv = _eval(fargs) # Evaluate it
+
+ .CDR(lptr, lptr) # Get a pointer to next form
+ goto EVAL_LOOP
+
+EVAL_DONE:
+ goto CLEANUP
+
+
+CLEANUP_HANDLER:
+ .get_results (error) # Caught an exception - save it
+ goto CLEANUP # and clean up before rethrow
+
+CLEANUP:
+ # VALID_IN_PARROT_0_2_0 pop_pad # Pop off the lexical scope
+
+ nvar = dynvars
+ i = 0
+
+CLEANUP_LOOP:
+ if i >= nvar goto CLEANUP_DONE
+
+ symbol = dynvars[i] # Symbol to be unshadowed
+ name = symbol.'_get_name_as_string'()
+ package = symbol.'_get_package'()
+
+ package.'_unshadow_symbol'(name) # Unshadow the symbol
+
+ inc i
+ goto CLEANUP_LOOP
+
+CLEANUP_DONE:
+ if_null error, DONE # Rethrow an exception if we
+ rethrow error # need to
+ goto DONE
+
+CLEANUP_RETHROW:
+ rethrow error
+ goto DONE
+
+# VALID_IN_PARROT_0_2_0 ERROR_BADSPEC:
+ERROR_BAD_SPEC:
+ .ERROR_1("program-error", "illegal variable specification %s", form)
+ goto CLEANUP
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to LET")
+ goto CLEANUP
+
+DONE:
+ .return(retv)
+.end
+
+.sub _print # This is just a temporary stand-in - it
+ .param pmc args # doesn't have near enough the amount of
+ # functionality required.
+ .local string strval
+ .local pmc retv
+ .local pmc obj
+
+ .ASSERT_LENGTH(args, 1, ERROR_NARGS)
+
+ .CAR(obj, args)
+
+ strval = obj
+ .STRING(retv, obj)
+ print retv
+ print "\n"
+
+ goto DONE
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to PRINT")
+ goto DONE
+
+DONE:
+ .return(retv)
+.end
+
+.sub _progn
+ .param pmc args
+ .local pmc eform
+ .local pmc eargs
+ .local pmc lptr
+ .local pmc retv
+
+ .NIL(retv)
+ lptr = args
+
+FORM_LOOP:
+ .NULL(lptr, DONE)
+
+ .CAR(eform, lptr) # Create the arg list for eval
+ .LIST_1(eargs, eform)
+
+ retv = _eval(eargs) # Evaluate form in list
+
+ .CDR(lptr, lptr) # Point to next form
+ goto FORM_LOOP
+
+DONE:
+ .return(retv)
+.end
+
+.sub _quit
+ .param pmc args
+
+ .ASSERT_LENGTH(args, 0, ERROR_NARGS)
+ goto DONE
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to QUIT")
+ goto DONE
+
+DONE:
+ end
+.end
+
+.sub _quote
+ .param pmc args
+ .local pmc retv
+
+ .ASSERT_LENGTH(args, 1, ERROR_NARGS)
+
+ .CAR(retv,args)
+ goto DONE
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to QUOTE")
+ goto DONE
+
+DONE:
+ .return(retv)
+.end
+
+.sub _rplaca
+ .param pmc args
+ .local pmc cons
+ .local pmc val
+
+ .ASSERT_LENGTH(args, 2, ERROR_NARGS)
+
+ .CAR(cons, args)
+ .SECOND(val, args)
+
+ .ASSERT_TYPE(cons, "cons")
+
+ cons[0] = val # Replace the car with val
+ goto DONE
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to RPLACA")
+ goto DONE
+
+DONE:
+ .return(cons)
+.end
+
+.sub _rplacd
+ .param pmc args
+ .local pmc cons
+ .local pmc val
+
+ .ASSERT_LENGTH(args, 2, ERROR_NARGS)
+
+ .CAR(cons, args)
+ .SECOND(val, args)
+
+ .ASSERT_TYPE(cons, "cons") # Ensure first arg is a cons
+
+ cons[1] = val # Replace the cdr with val
+ goto DONE
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to RPLACD")
+ goto DONE
+
+DONE:
+ .return(cons)
+.end
+
+.sub _setq
+ .param pmc args
+
+ .local string name
+ .local pmc lexical
+ .local pmc symbol
+ .local pmc value
+ .local pmc retv
+ .local pmc lptr
+ .local pmc earg
+
+ .ASSERT_EVEN_LENGTH(args, ERROR_NARGS)
+
+ lptr = args # Pointer to the arguments
+ .NIL(retv) # Initialize return value
+
+LOOP:
+ .NULL(lptr, DONE) # If we're at the EOL goto DONE
+
+ .CAR(symbol, lptr) # Get the variable to assign to
+ .SECOND(value, lptr) # Get the value being assigned
+
+ .ASSERT_TYPE(symbol, "symbol") # Ensure variable is a symbol
+
+ name = symbol.'_get_name_as_string'() # Get the symbols name
+ lexical = _LOOKUP_LEXICAL(name) # Look for it in lexical env
+ if_null lexical, SET_SYMBOL_VALUE
+
+ symbol = lexical # Lexical variable was found
+
+SET_SYMBOL_VALUE:
+ .LIST_1(earg, value) # Evaluate the value form
+ retv = _eval(earg)
+
+ symbol.'_set_value'(retv)
+
+ .CDR(lptr, lptr)
+ .CDR(lptr, lptr)
+
+ goto LOOP
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "odd number of arguments to SETQ")
+ goto DONE
+
+DONE:
+ .return(retv)
+.end
+
+.sub _type_of
+ .param pmc args
+ .local string type
+ .local string name
+ .local pmc form
+ .local pmc retv
+ .local pmc nil
+
+ .ASSERT_LENGTH(args, 1, ERROR_NARGS)
+
+ .CAR(form, args)
+
+ null nil
+
+ type = typeof form
+
+ if type == "LispCons" goto CONS
+ if type == "LispFloat" goto FLOAT
+ if type == "LispFunction" goto FUNCTION
+ if type == "LispHash" goto HASH
+ if type == "LispInteger" goto INTEGER
+ if type == "LispMacro" goto MACRO
+ if type == "LispPackage" goto PACKAGE
+ if type == "LispStream" goto STREAM
+ if type == "LispString" goto STRING
+ if type == "LispSymbol" goto SYMBOL
+
+ goto UNKNOWN_TYPE
+
+CONS:
+ name = "CONS"
+ goto LOOKUP_SYMBOL
+
+FLOAT:
+ name = "FLOAT"
+ goto LOOKUP_SYMBOL
+
+FUNCTION:
+ name = "FUNCTON"
+ goto LOOKUP_SYMBOL
+
+HASH:
+ name = "HASH-TABLE"
+ goto LOOKUP_SYMBOL
+
+INTEGER:
+ name = "INTEGER"
+ goto LOOKUP_SYMBOL
+
+MACRO:
+ name = "MACRO"
+ goto LOOKUP_SYMBOL
+
+PACKAGE:
+ name = "PACKAGE"
+ goto LOOKUP_SYMBOL
+
+STREAM:
+ name = "STREAM"
+ goto LOOKUP_SYMBOL
+
+STRING:
+ name = "STRING"
+ goto LOOKUP_SYMBOL
+
+SYMBOL:
+ name = "SYMBOL"
+ goto LOOKUP_SYMBOL
+
+UNKNOWN_TYPE:
+ name = "UNKNOWN"
+ goto LOOKUP_SYMBOL
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "odd number of arguments to TYPE-OF")
+ goto DONE
+
+LOOKUP_SYMBOL:
+ retv = _GLOBAL_SYMBOL("COMMON-LISP", name, nil, nil)
+ goto DONE
+
+DONE:
+ .return(retv)
+.end
+
+.sub _values
+ .param pmc args
+ .local int size
+ .local int llen
+
+ llen = _LIST_LENGTH(args) # Get # values we're returning
+
+ $P16 = args # Pointer to argument list
+
+ if llen == 0 goto DONE
+
+ $P5 = $P16[0]
+ $P16 = $P16[1]
+ if llen == 1 goto DONE
+
+ $P6 = $P16[0]
+ $P16 = $P16[1]
+ if llen == 2 goto DONE
+
+ $P7 = $P16[0]
+ $P16 = $P16[1]
+ if llen == 3 goto DONE
+
+ $P8 = $P16[0]
+ $P16 = $P16[1]
+ if llen == 4 goto DONE
+
+ $P9 = $P16[0]
+ $P16 = $P16[1]
+ if llen == 5 goto DONE
+
+ $P10 = $P16[0]
+ $P16 = $P16[1]
+ if llen == 6 goto DONE
+
+ $P11 = $P16[0]
+ $P16 = $P16[1]
+ if llen == 7 goto DONE
+
+ $P12 = $P16[0]
+ $P16 = $P16[1]
+ if llen == 8 goto DONE
+
+ $P13 = $P16[0]
+ $P16 = $P16[1]
+ if llen == 9 goto DONE
+
+ $P14 = $P16[0]
+ $P16 = $P16[1]
+ if llen == 10 goto DONE
+
+ $P15 = $P16[0]
+ $P16 = $P16[1]
+ if llen == 11 goto DONE
+
+ size = llen - 11 # Size of the overflow array
+
+ $P3 = new 'Array' # Allocate overflow array
+ $P3 = size
+
+ .local pmc elem
+ .local int indx
+
+ indx = 0 # Initial index into overflow
+OVERFLOW_LOOP:
+ if indx == size goto DONE_OVERFLOW
+
+ elem = $P16[0]
+
+ $P3[indx] = elem # Set next overflow element
+ inc indx
+
+ $P16 = $P16[1] # Set next element in list
+ goto OVERFLOW_LOOP
+
+DONE_OVERFLOW:
+ llen = 11 # Only report # retv's in regs
+ goto DONE
+
+DONE:
+ # VALID_IN_PARROT_0_2_0 is_prototyped = 0 # Set up return registers
+
+ # VALID_IN_PARROT_0_2_0 argcI = 0
+ # VALID_IN_PARROT_0_2_0 argcN = 0
+ # VALID_IN_PARROT_0_2_0 argcP = llen
+ # VALID_IN_PARROT_0_2_0 argcS = 0
+
+ # VALID_IN_PARROT_0_2_0 returncc
+ .return()
+.end
+
+.sub _add
+ .param pmc args
+ .local pmc lptr
+ .local pmc targ
+ .local pmc retv
+
+ .INTEGER(retv, "0") # + with no args should give 0
+
+ lptr = args
+
+LOOP:
+ .NULL(lptr, DONE)
+
+ .CAR(targ,lptr) # Get the next arg and ensure
+ .ASSERT_TYPE(targ, "number") # it is numeric.
+
+ retv = retv + targ # Add to the running total.
+
+ .CDR(lptr,lptr)
+ goto LOOP
+
+DONE:
+ .return(retv)
+.end
+
+.sub _subtract
+ .param pmc args
+ .local pmc lptr
+ .local pmc targ
+ .local pmc retv
+ .local int narg
+
+ .ASSERT_MINIMUM_LENGTH(args,1,ERROR_NARGS)
+
+ .CAR(retv,args) # Get the first argument and
+ .ASSERT_TYPE(retv, "number") # ensure it is numeric.
+
+ .CDR(lptr,args) # Get a pointer to rest of args
+ narg = 1 # Number of args encountered
+
+LOOP:
+ .NULL(lptr,DONE_LOOP)
+
+ .CAR(targ, lptr) # Get the next arg and ensure
+ .ASSERT_TYPE(targ, "number") # it is numeric.
+
+ retv = retv - targ # Subtract from running total.
+
+ .CDR(lptr,lptr)
+ inc narg # Increment # args processed
+ goto LOOP
+
+DONE_LOOP:
+ if narg > 1 goto DONE # If we only had one arg return
+ neg retv # its negative value
+ goto DONE
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to -")
+ goto DONE
+
+DONE:
+ .return(retv)
+.end
+
+.sub _multiply
+ .param pmc args
+ .local pmc lptr
+ .local pmc targ
+ .local pmc retv
+
+ .INTEGER(retv, "1") # + with no args should give 0
+
+ lptr = args
+
+LOOP:
+ .NULL(lptr,DONE)
+
+ .CAR(targ,lptr) # Get the next arg and ensure
+ .ASSERT_TYPE(targ, "number") # it is numeric.
+
+ retv = retv * targ # Multiply the running product.
+
+ .CDR(lptr,lptr)
+ goto LOOP
+
+DONE:
+ .return(retv)
+.end
+
+.sub _divide
+ .param pmc args
+ .local pmc lptr
+ .local pmc targ
+ .local pmc retv
+ .local int narg
+
+ .ASSERT_MINIMUM_LENGTH(args,1,ERROR_NARGS)
+
+ .CAR(retv,args) # Get the first argument and
+ .ASSERT_TYPE(retv, "number") # ensure it is numeric.
+
+ .CDR(lptr,args) # Get a pointer to rest of args
+ narg = 1 # Number of args encountered
+
+LOOP:
+ .NULL(lptr,DONE_LOOP)
+
+ .CAR(targ,lptr) # Get the next arg and ensure
+ .ASSERT_TYPE(targ, "number") # it is numeric.
+
+ retv = retv / targ # Divide the running total.
+
+ .CDR(lptr,lptr)
+ inc narg # Increment # args processed
+ goto LOOP
+
+DONE_LOOP:
+ if narg > 1 goto DONE # If we only had one arg, return
+ .INTEGER(targ, 1) # its inverse
+ retv = targ / retv
+ goto DONE
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to /")
+ goto DONE
+
+DONE:
+ .return(retv)
+.end
+
+.sub _modulus
+ .param pmc args
+ .local pmc retv
+ .local pmc numb
+ .local pmc div
+
+ .ASSERT_LENGTH(args, 2, ERROR_NARGS)
+
+ .CAR(numb,args)
+ .SECOND(div,args)
+
+ .ASSERT_TYPE(numb, "number") # Ensure both of the args are
+ .ASSERT_TYPE(div, "number") # numeric.
+
+ .INTEGER(retv,0)
+
+ mod retv, numb, div # Compute the modulus
+ goto DONE
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to MOD")
+ goto DONE
+
+DONE:
+ .return(retv)
+.end
+
+.sub _equal
+ .param pmc args
+ .local pmc lptr
+ .local pmc arg1
+ .local pmc arg2
+ .local pmc retv
+
+ .ASSERT_MINIMUM_LENGTH(args, 1, ERROR_NARGS)
+
+ .CAR(arg1, args) # Get the first argument and
+ .ASSERT_TYPE(arg1, "number") # ensure it is numeric.
+
+ .CDR(lptr,args) # Get a pointer to rest of args
+
+ .TRUE(retv)
+
+LOOP:
+ .NULL(lptr, DONE)
+
+ .CAR(arg2, lptr) # Get the next arg and ensure
+ .ASSERT_TYPE(arg2, "number") # it is numeric.
+
+ if arg1 != arg2 goto NOT_EQUAL
+
+ .CDR(lptr, lptr)
+ goto LOOP
+
+NOT_EQUAL:
+ .NIL(retv)
+ goto DONE
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to =")
+ goto DONE
+
+DONE:
+ .return(retv)
+.end
+
+# Local Variables:
+# mode: pir
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:
Added: lisp/trunk/config/makefiles/root.in
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ lisp/trunk/config/makefiles/root.in Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,53 @@
+# Copyright (C) 2005-2009, Parrot Foundation.
+# $Id$
+
+# Setup some commands
+RM_F = @rm_f@
+PERL = @perl@
+PARROT = ../../parrot at exe@
+BUILD_DIR = @build_dir@
+RECONFIGURE = $(PERL) @build_dir@/tools/dev/reconfigure.pl
+#CONDITIONED_LINE(darwin):
+#CONDITIONED_LINE(darwin):# MACOSX_DEPLOYMENT_TARGET must be defined for OS X compilation/linking
+#CONDITIONED_LINE(darwin):export MACOSX_DEPLOYMENT_TARGET := @osx_version@
+
+all: build
+
+# This is a listing of all targets, that are meant to be called by users
+help :
+ @echo ""
+ @echo "Following targets are available for the user:"
+ @echo ""
+ @echo " all: 'lisp.pbc'"
+ @echo " This is the default."
+ @echo ""
+ @echo " help: Print this help message."
+ @echo ""
+ @echo " test: Run the test suite."
+ @echo ""
+ @echo " clean: Cleaning up."
+ @echo ""
+
+# regenerate the Makefile
+Makefile: config/makefiles/root.in
+ cd $(BUILD_DIR) && $(RECONFIGURE) --step=gen::languages --languages=lisp
+
+test: build
+ $(PERL) -Ilib -I../../lib t/harness
+
+build: lisp.pir
+ $(PARROT) -o lisp.pbc lisp.pir
+
+clean: testclean
+ $(RM_F) core "*.pbc" "*~"
+
+testclean:
+ $(RM_F) t/*.out t/*.l
+
+realclean: clean
+ $(RM_F) Makefile
+
+# Local variables:
+# mode: makefile
+# End:
+# vim: ft=make:
Added: lisp/trunk/eval.pir
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ lisp/trunk/eval.pir Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,191 @@
+# $Id$
+
+=head1 NAME
+
+eval.pir - evaluate forms
+
+=cut
+
+.sub _eval
+ .param pmc args
+
+ .ASSERT_LENGTH(args, 1, ERROR_NARGS)
+
+ .local string symname
+ .local string type
+ .local pmc symbol
+ .local int found
+ .local pmc body
+ .local pmc retv
+
+ # switch based on the type of the first arg
+ .local pmc form
+ .CAR(form, args)
+ type = typeof form
+ if type == "LispSymbol" goto SYMBOL
+ if type == "LispCons" goto FUNCTION_FORM
+ if type == "LispInteger" goto SELF_EVALUATING_OBJECT
+ if type == "LispString" goto SELF_EVALUATING_OBJECT
+ if type == "LispFloat" goto SELF_EVALUATING_OBJECT
+
+ .ERROR_1("internal", "Unknown object type in eval: %s", type)
+
+
+FUNCTION_FORM:
+ .local pmc function
+ .local pmc funcargs
+ .local pmc funcptr
+ .local pmc funcarg
+ .local pmc test
+
+ .CAR(symbol, form)
+ .CDR(body, form)
+
+ .ASSERT_TYPE_AND_BRANCH(symbol, "symbol", FUNCTION_NOT_FOUND)
+
+ # Retrieve the function from the symbol.
+ function = symbol.'_get_function'()
+
+ # If the function wasn't set for the symbol, throw an error.
+ defined found, function
+ unless found goto FUNCTION_NOT_FOUND
+
+ # Check to see if the function is a special form (which aren't subject to
+ # normal function evaluation rules).
+ type = typeof function
+ if type == "LispSpecialForm" goto SPECIAL_FORMS
+ if type == "LispMacro" goto MACRO_FORM
+
+ # Normal function - evaluate all arguments being passed into the function.
+ .NIL(funcargs)
+
+ funcptr = body
+
+FUNCTION_LOOP:
+ .NULL(funcptr, FUNCTION_CALL) # Call the function if no args left.
+
+ .CAR(funcarg, funcptr) # Pop the next arg off the list.
+
+ .local pmc evalarg # Evaluate the argument.
+ .LIST_1(evalarg, funcarg)
+ funcarg = _eval(evalarg)
+
+ .APPEND(funcargs,funcargs,funcarg) # Add the result to the args list.
+
+ .CDR(funcptr,funcptr) # Move to the next arg in the list.
+
+ goto FUNCTION_LOOP
+
+FUNCTION_CALL:
+ .tailcall _FUNCTION_CALL(function,funcargs)
+ # VALID_IN_PARROT_0_2_0 goto DONE
+
+FUNCTION_NOT_FOUND:
+ .ERROR_1("undefined-function", "%s is not a function name", symbol)
+ # VALID_IN_PARROT_0_2_0 goto DONE
+ .return(retv)
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to EVAL")
+ # VALID_IN_PARROT_0_2_0 goto DONE
+ .return(retv)
+
+SPECIAL_FORMS:
+ # Special forms aren't subject to normal evaluation rules - keep the
+ # arguments as is and call the function.
+ funcargs = body
+ goto FUNCTION_CALL
+
+MACRO_FORM:
+ .local pmc macroexp
+ .local pmc macrosym
+ .local pmc macroenv
+ .local pmc macroarg
+
+ macrosym = _LOOKUP_SYMBOL("*MACROEXPAND-HOOK*")
+ if_null macrosym, MACRO_NOT_INITIALIZED
+
+ macroexp = macrosym.'_get_value'() # Get the expander function
+ .ASSERT_TYPE_AND_BRANCH(macroexp, "function", MACRO_NOT_INITIALIZED)
+
+ # VALID_IN_PARROT_0_2_0 peek_pad macroenv # Get current lexical scope
+
+ .LIST_3(funcargs, symbol, body, macroenv)
+ retv = _FUNCTION_CALL(macroexp, funcargs) # Call the macroexpand hook
+
+ .LIST_1(macroarg, retv)
+ _eval(macroarg)
+
+ # VALID_IN_PARROT_0_2_0 goto DONE
+ .return(retv)
+
+SYMBOL:
+ symbol = form
+ symname = symbol.'_get_name_as_string'()
+
+ .local int is_special
+ is_special = _IS_SPECIAL(symbol) # Check if we're a dynamic
+ unless is_special goto LEXICAL_SYMBOL # variable
+ goto DYNAMIC_SYMBOL
+
+DYNAMIC_SYMBOL:
+ .local pmc package
+ .local string pkgname
+ package = symbol.'_get_package'()
+ pkgname = package.'_get_name_as_string'()
+
+ symbol = _LOOKUP_GLOBAL(pkgname, symname)
+ goto CHECK_VALUE
+
+LEXICAL_SYMBOL:
+ retv = _LOOKUP_LEXICAL(symname) # Check for a lexical shadow
+ if_null retv, CHECK_VALUE # If not found, assume global
+ symbol = retv # Use the lexical value
+ goto CHECK_VALUE
+
+CHECK_VALUE:
+ retv = symbol.'_get_value'() # Check for symbol's value
+
+ defined found, retv
+ unless found goto SYMBOL_NOT_FOUND
+
+DONE_SYMBOL:
+ # VALID_IN_PARROT_0_2_0 argcP = 1 # One value returned
+ # VALID_IN_PARROT_0_2_0 P5 = retv # Return value
+ # VALID_IN_PARROT_0_2_0
+ # VALID_IN_PARROT_0_2_0 goto DONE
+ .return(retv)
+
+SYMBOL_NOT_FOUND:
+ .ERROR_1("unbound-variable", "variable %s has no value", form)
+ # VALID_IN_PARROT_0_2_0 goto DONE
+ .return(retv)
+
+SELF_EVALUATING_OBJECT:
+ # Object is a primitive type (ie. a string, integer or float).
+ # VALID_IN_PARROT_0_2_0 argcP = 1 # One value returned
+ # VALID_IN_PARROT_0_2_0 P5 = retv # Return value
+
+ # VALID_IN_PARROT_0_2_0 goto DONE
+ .return(form)
+
+MACRO_NOT_INITIALIZED:
+ .ERROR_0("internal","the macro system has not been initialized")
+# VALID_IN_PARROT_0_2_0 goto DONE
+# VALID_IN_PARROT_0_2_0
+# VALID_IN_PARROT_0_2_0 DONE:
+# VALID_IN_PARROT_0_2_0 is_prototyped = 0 # Nonprototyped return
+# VALID_IN_PARROT_0_2_0 argcI = 0 # No integer values returned
+# VALID_IN_PARROT_0_2_0 argcN = 0 # No float values returned
+# VALID_IN_PARROT_0_2_0 argcS = 0 # No string values returned
+# VALID_IN_PARROT_0_2_0
+# VALID_IN_PARROT_0_2_0 returncc # Call the return continuation
+
+ .return()
+.end
+
+# Local Variables:
+# mode: pir
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:
Added: lisp/trunk/include/macros.pir
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ lisp/trunk/include/macros.pir Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,19 @@
+# $Id$
+
+=head1 NAME
+
+include/macros.pir - include PIR file in F<include/macros>.
+
+=cut
+
+.include "include/macros/assert.pir"
+.include "include/macros/error.pir"
+.include "include/macros/list.pir"
+.include "include/macros/standard.pir"
+.include "include/macros/types.pir"
+
+# Local Variables:
+# mode: pir
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:
Added: lisp/trunk/include/macros/assert.pir
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ lisp/trunk/include/macros/assert.pir Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,118 @@
+# $Id$
+
+=head1 NAME
+
+include/macros/assert.pir - macros for checking assumptions
+
+=head1 Macros
+
+=head2 ASSERT_TYPE(A,T)
+
+Asserts that A is of type T, throwing a error of type "type-error" on failure
+
+=cut
+
+.macro ASSERT_TYPE(A,T)
+ .local string _atypes
+ .local int _testi
+
+ _testi = _IS_TYPE(.A, .T)
+ if _testi == 1 goto .$DONE
+ goto .$WRONG_TYPE
+
+.label $WRONG_TYPE:
+ .ERROR_2("type-error", "%s is not of type %s", .A, .T)
+ goto .$DONE
+
+.label $DONE:
+.endm
+
+=head2 ASSERT_TYPE_AND_BRANCH(A,T,B)
+
+Asserts that A is of type T, branching to B on failure.
+
+=cut
+
+.macro ASSERT_TYPE_AND_BRANCH(A,T,B)
+ .local string _atypes
+ .local int _testi
+
+ _testi = _IS_TYPE(.A, .T)
+ if _testi == 1 goto .$DONE
+ goto .B
+
+.label $DONE:
+.endm
+
+=head2 ASSERT_LENGTH(A,L,B)
+
+Asserts that list A is of length L, branching to B on failure.
+
+=cut
+
+.macro ASSERT_LENGTH(A,L,B)
+ .local int _leni
+
+ _leni = _LIST_LENGTH(.A) # Get the length of the list
+ if _leni == .L goto .$DONE # Branch on success
+ goto .B # Branch on failure
+
+.label $DONE:
+.endm
+
+=head2 ASSERT_MINIMUM_LENGTH(A,L,B)
+
+Asserts that list A is at least of length L, branching to B on failure.
+
+=cut
+
+.macro ASSERT_MINIMUM_LENGTH(A,L,B)
+ .local int _leni
+
+ _leni = _LIST_LENGTH(.A) # Get the length of the list
+ if _leni >= .L goto .$DONE # Branch on success
+ goto .B # Branch on failure
+
+.label $DONE:
+.endm
+
+=head2 ASSERT_LENGTH_BETWEEN(A,L,M,B)
+
+Asserts that list A is at least of length L and at most of length M, branching to B on failure.
+
+=cut
+
+.macro ASSERT_LENGTH_BETWEEN(A,L,M,B)
+ .local int _leni
+
+ _leni = _LIST_LENGTH(.A) # Get the length of the list
+ if _leni >= .L goto .$DONE # Branch on success (min bound)
+ if _leni <= .M goto .$DONE # Branch on success (max bound)
+ goto .B # Branch on failure
+
+.label $DONE:
+.endm
+
+=head2 ASSERT_EVEN_LENGTH(A,B)
+
+Asserts that list A is composed of an even number of elements, branching to B on failure.
+
+=cut
+
+.macro ASSERT_EVEN_LENGTH(A,B)
+ .local int _leni
+ .local int _modi
+
+ _leni = _LIST_LENGTH(.A) # Get the length of the list
+ mod _modi, _leni, 2
+ if _modi == 0 goto .$DONE # Branch on success
+ goto .B # Branch on failure
+
+.label $DONE:
+.endm
+
+# Local Variables:
+# mode: pir
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:
Added: lisp/trunk/include/macros/error.pir
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ lisp/trunk/include/macros/error.pir Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,44 @@
+# $Id$
+
+=head1 NAME
+
+include/macros/error.pir - macros for reporting errors
+
+=head1 Macros
+
+=cut
+
+.macro ERROR_0(T,M)
+ _error(.T, .M)
+.endm
+
+.macro ERROR_1(T,M,A)
+ .local string _errmsgs
+ .local pmc _errargp
+
+ _errargp = new 'Array'
+ _errargp = 1
+ _errargp[0] = .A
+
+ sprintf _errmsgs, .M, _errargp
+ _error(.T, _errmsgs)
+.endm
+
+.macro ERROR_2(T,M,A,B)
+ .local string _errmsgs
+ .local pmc _errargp
+
+ _errargp = new 'Array'
+ _errargp = 2
+ _errargp[0] = .A
+ _errargp[1] = .B
+
+ sprintf _errmsgs, .M, _errargp
+ _error(.T, _errmsgs)
+.endm
+
+# Local Variables:
+# mode: pir
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:
Added: lisp/trunk/include/macros/list.pir
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ lisp/trunk/include/macros/list.pir Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,180 @@
+# $Id$
+
+=head1 NAME
+
+include/macros/list.pir - list processing macros
+
+This file contains various list processing macros.
+All macro arguments are assumed to be PMC types unless otherwise noted.
+
+=head1 Macros
+
+=head2 .NULL(L,B)
+
+Branch to B if L is an empty list.
+
+=cut
+
+.macro NULL (L,B)
+ .local pmc _nilp
+
+ .NIL(_nilp)
+ eq_addr .L, _nilp, .B
+.endm
+
+=head2 .CAR(R,A)
+
+Puts the car of A into R. A is assumed to be a valid list.
+
+=cut
+
+.macro CAR (R,A)
+ .NULL(.A, .$IS_NULL)
+
+ .R = .A[0]
+
+ goto .$DONE
+
+.label $IS_NULL:
+ .NIL(.R)
+ goto .$DONE
+
+.label $DONE:
+.endm
+
+=head2 .APPEND(R,A,B)
+
+Appends B to list A, placing the result into R. A is assumed to be a valid list.
+
+=cut
+
+.macro APPEND (R,A,B)
+ .local pmc _listptr1p
+ .local pmc _listptr2p
+ .local pmc _listtmpp
+
+ .NULL(.A, .$EMPTY_LIST) # Special case if A is an empty list.
+
+ _listptr1p = .A
+
+.label $APPEND_LOOP: # Loop until we reach the end of the list.
+ .NULL(_listptr1p,.$DONE_LOOP)
+
+ _listptr2p = _listptr1p
+
+ .CDR(_listptr1p,_listptr1p)
+ goto .$APPEND_LOOP
+
+.label $DONE_LOOP: # At the EOL, replace the list end (NIL)
+ .LIST_1(_listtmpp, .B) # with a new cons containing the new element.
+ _listptr2p[1] = _listtmpp
+ goto .$DONE
+
+.label $EMPTY_LIST:
+ .LIST_1(.R,.B)
+
+.label $DONE:
+.endm
+
+=head2 .CDR(R,A)
+
+Puts the cdr of A into R. A is assumed to be a valid list.
+
+=cut
+
+.macro CDR (R,A)
+
+ .NULL(.A, .$IS_NULL)
+ .R = .A[1]
+ goto .$DONE
+
+.label $IS_NULL:
+ .NIL(.R)
+ goto .$DONE
+
+.label $DONE:
+.endm
+
+=head2 .SECOND(R,A)
+
+Puts the second element of A into R. A is assumed to be a valid list.
+
+=cut
+
+.macro SECOND (R,A)
+ .local pmc _cdrp
+
+ .CDR(_cdrp, .A)
+ .CAR(.R, _cdrp)
+.endm
+
+=head2 .THIRD(R,A)
+
+Puts the third element of A into R. A is assumed to be a valid list.
+
+=cut
+
+.macro THIRD (R,A)
+ .local pmc _cdrp
+
+ .CDR(_cdrp, .A)
+ .CDR(_cdrp, _cdrp)
+ .CAR(.R, _cdrp)
+.endm
+
+=head2 .FOURTH(R,A)
+
+Puts the fourth element of A into R. A is assumed to be a valid list.
+
+=cut
+
+.macro FOURTH (R,A)
+ .local pmc _cdrp
+
+ .CDR(_cdrp, .A)
+ .CDR(_cdrp, _cdrp)
+ .CDR(_cdrp, _cdrp)
+ .CAR(.R, _cdrp)
+.endm
+
+=head2 .LIST_1(R,A)
+
+Creates a one element list containing A, placing the result in R.
+
+=cut
+
+.macro LIST_1 (R,A)
+ .local pmc _bp
+
+ .NIL(_bp)
+ .CONS(.R, .A, _bp)
+.endm
+
+
+=head2 .LIST_2(R,A,B)
+
+Creates a two element list containing A and B, placing the result in R.
+
+=cut
+
+.macro LIST_2 (R,A,B)
+ .local pmc _cp
+
+ .LIST_1(_cp, .B)
+ .CONS(.R, .A, _cp)
+.endm
+
+.macro LIST_3 (R,A,B,C)
+ .local pmc _cp
+
+ .LIST_2(_cp, .B, .C)
+ .CONS(.R, .A, _cp)
+.endm
+
+
+
+# Local Variables:
+# mode: pir
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:
Added: lisp/trunk/include/macros/standard.pir
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ lisp/trunk/include/macros/standard.pir Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,114 @@
+# $Id$
+
+=head1 NAME
+
+include/macros/standard.pir - miscellaneous macros
+
+=head1 DESCRITPTION
+
+This file contains miscellaneous macros.
+
+=head1 Macros
+
+=head2 .NIL(R)
+
+Sets R to the empty list (the NIL symbol).
+
+=cut
+
+.macro NIL (R)
+ get_global .R, ["SYMBOLS"], "NIL"
+.endm
+
+=head2 .TRUE(R)
+
+Sets R to true (the TRUE symbol).
+
+=cut
+
+.macro TRUE (R)
+ get_global .R, ["SYMBOLS"], "T"
+.endm
+
+.macro CONSTANT (P)
+ .local Boolean _const
+
+ _const = new 'Boolean'
+ _const = 1
+
+ setprop .P, "constant", _const
+.endm
+
+.macro CONSTANTP (R,P)
+ .local pmc _const
+
+ getprop .R, "constant", .P
+.endm
+
+.macro SPECIAL_FORM (S,P,N,L)
+ .local pmc _specialformp
+ # VALID_IN_PARROT_0_2_0 .local pmc _funcp
+ .local pmc _namep
+
+ # VALID_IN_PARROT_0_2_0 newsub _funcp, .Sub, .L
+
+ _specialformp = new "LispSpecialForm"
+ # VALID_IN_PARROT_0_2_0 _specialformp._set_body(.L)
+ .const 'Sub' _special_func = .L
+ _specialformp.'_set_body'(_special_func)
+
+ _namep = new "LispString"
+ _namep = .N
+ _specialformp.'_set_name'(_namep)
+
+ .S = .P.'_intern_symbol'(.N)
+ .S.'_set_function'(_specialformp)
+ .S.'_set_package'(.P)
+.endm
+
+.macro DEFUN (S,P,N,L)
+ .local pmc _functionp
+ .local pmc _namep
+
+ .FUNCTION(_functionp, .L)
+
+ _namep = new "LispString"
+ _namep = .N
+ _functionp.'_set_name'(_namep)
+
+ .S = .P.'_intern_symbol'(.N)
+ .S.'_set_function'(_functionp)
+ .S.'_set_package'(.P)
+.endm
+
+.macro DEFMACRO (S,P,N,L)
+ .local pmc _macrop
+ .local pmc _namep
+
+ .MACRO(_macrop, .L)
+
+ _namep = new "LispString"
+ _namep = .N
+ _macrop.'_set_name'(_namep)
+
+ .S = .P.'_intern_symbol'(.N)
+ .S.'_set_function'(_macrop)
+ .S.'_set_package'(.P)
+.endm
+
+.macro DEFVAR (S,P,N,V)
+ .local pmc _specialp
+
+ .TRUE(_specialp)
+
+ .S = .P.'_intern_symbol'(.N)
+ .S.'_set_value'(.V)
+ .S.'_set_package'(.P)
+ .S.'_set_special'(_specialp)
+.endm
+
+# Local Variables:
+# mode: pir
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:
Added: lisp/trunk/include/macros/types.pir
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ lisp/trunk/include/macros/types.pir Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,150 @@
+# $Id$
+
+=head1 NAME
+
+include/macros/types.pir
+
+=head1 Macros
+
+=head2 .CONS(R,A,B)
+
+Creates a new cons with car A and cdr B, placing the result in R.
+
+=cut
+
+.macro CONS (R,A,B)
+ .local pmc _consp
+
+
+ _consp = new "LispCons"
+
+ _consp[0] = .A
+ _consp[1] = .B
+
+ .R = _consp
+.endm
+
+=head2 .STRING(R,S)
+
+Creates a new string with value S, placing the result in R.
+
+=cut
+
+.macro STRING (R,S)
+ .R = new "LispString"
+ .R = .S
+.endm
+
+=head2 .STREAM(R,S)
+
+Create a new stream object from ParrotIO object S, placing the result in R.
+
+=cut
+
+.macro STREAM(R,S)
+ .R = new "LispStream"
+ .R.'_set_io'(.S)
+.endm
+
+=head2 .READTABLE(R)
+
+Create a new readtable object and places it in R.
+
+=cut
+
+.macro READTABLE(R)
+ .R = new "LispReadtable"
+.endm
+
+=head2 .FLOAT(R,F)
+
+Creates a new float with value F, placing the result in R.
+
+=cut
+
+.macro FLOAT (R,F)
+ .R = new "LispFloat"
+ .R = .F
+.endm
+
+=head2 .INTEGER(R,I)
+
+Creates a new integer with value I, placing the result in R.
+
+=cut
+
+.macro INTEGER (R,I)
+ .R = new "LispInteger"
+ .R = .I
+.endm
+
+=head2 .HASH(R)
+
+Creates a new hash table, placing the result in R.
+
+=cut
+
+.macro HASH (R)
+ .R = new "LispHash"
+.endm
+
+=head2 .PACKAGE(P,N)
+
+Create a new package with name N, placing the result in P.
+
+=cut
+
+.macro PACKAGE (P,N)
+ .local string _ucname
+ .local pmc _packagesp
+ .local pmc _name
+
+ .P = new "LispPackage"
+
+ _ucname = .N
+ upcase _ucname, _ucname
+ .STRING(_name, _ucname)
+
+ setattribute .P, "name", _name
+.endm
+
+=head2 .FUNCTION(F,L)
+
+Create a new function object with label L, placing the result in F.
+
+=cut
+
+.macro FUNCTION(F,L)
+
+ .F = new "LispFunction"
+ # VALID_IN_PARROT_0_2_0 newsub _func, .Sub, .L
+ # VALID_IN_PARROT_0_2_0 setattribute .F, "LispFunction\0body", .L
+
+ .local pmc _func
+ .const 'Sub' _func = .L
+ setattribute .F, "body", _func
+
+.endm
+
+=head2 .MACRO(F,L)
+
+Create a new macro object with label L, placing the result in F.
+
+=cut
+
+.macro MACRO(F,L)
+ .local pmc _func
+
+ .F = new "LispMacro"
+ newsub _func, .Sub, .L
+
+ # VALID_IN_PARROT_0_2_0 setattribute .F, "LispMacro\0body", _func
+ setattribute .F, "body", _func
+.endm
+
+
+# Local Variables:
+# mode: pir
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:
Added: lisp/trunk/internals.pir
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ lisp/trunk/internals.pir Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,555 @@
+# $Id$
+
+=head1 NAME
+
+internals.pir - lexical and global variables, function call
+
+=head1 Functions
+
+=head2 _LOOKUP_GLOBAL(pkgname, symname)
+
+=cut
+
+.sub _LOOKUP_GLOBAL
+ .param string pkgname
+ .param string symname
+
+ .local pmc package
+ .local pmc retv
+
+ upcase pkgname, pkgname # Convert names to all upcase
+ upcase symname, symname
+
+ push_eh PACKAGE_NOT_FOUND # Set an error handler
+ get_global package, ["PACKAGES"], pkgname # Look for the package
+ pop_eh
+
+ retv = package.'_lookup_symbol'(symname) # Lookup the symbol
+
+ goto DONE
+
+PACKAGE_NOT_FOUND:
+ .ERROR_1("package-error", "there is no package with name \"%s\"", pkgname)
+ goto DONE
+
+DONE:
+ .return(retv)
+.end
+
+
+=head2 _LOOKUP_LEXICAL(symname)
+
+=cut
+
+.sub _LOOKUP_LEXICAL
+ .param string symname
+
+ push_eh LEXICAL_NOT_FOUND # Set an error handler
+ .local pmc retv
+ find_lex retv, symname # Look for the lexical symbol
+ pop_eh
+
+ goto DONE
+
+LEXICAL_NOT_FOUND: # Return null if not found
+ null retv
+ goto DONE
+
+DONE:
+ .return(retv)
+.end
+
+
+=head2 _LOOKUP_SYMBOL(symname)
+
+=cut
+
+.sub _LOOKUP_SYMBOL
+ .param string symname
+
+ .local string pkgname
+ .local pmc package
+ .local pmc symbol
+ .local pmc retv
+
+LEXICAL_SYMBOL:
+ symbol = _LOOKUP_LEXICAL(symname)
+ if_null retv, GLOBAL_SYMBOL
+ goto DONE
+
+GLOBAL_SYMBOL:
+ symbol = _LOOKUP_GLOBAL("COMMON-LISP", "*PACKAGE*")
+ if_null symbol, PACKAGE_NOT_FOUND
+
+ package = symbol.'_get_value'()
+ if_null package, PACKAGE_NOT_FOUND
+
+ pkgname = package.'_get_name_as_string'()
+
+ retv = _LOOKUP_GLOBAL(pkgname, symname)
+ goto DONE
+
+PACKAGE_NOT_FOUND:
+ .ERROR_0("internal", "current package not found")
+ goto DONE
+
+DONE:
+ .return(retv)
+.end
+
+
+=head2 _INTERN_GLOBAL(symbol, pkgname)
+
+=cut
+
+.sub _INTERN_GLOBAL
+ .param pmc symbol
+ .param string pkgname
+
+ .local string symname
+
+ symname = symbol.'_get_name_as_string'()
+
+ set_global pkgname, symname, symbol
+.end
+
+
+=head2 .INTERN_LEXICAL(symbol)
+
+=cut
+
+.sub _INTERN_LEXICAL
+ .param pmc symbol
+
+ .local string symname
+
+ symname = symbol.'_get_name_as_string'()
+
+ # VALID_IN_PARROT_0_2_0 store_lex -1, symname, symbol
+ store_lex symname, symbol
+.end
+
+
+=head2 _LEXICAL_SYMBOL
+
+=cut
+
+.sub _LEXICAL_SYMBOL
+ .param string symname
+ .param pmc value
+
+ .local pmc package
+ .local pmc symbol
+ .local int test
+
+ symbol = _LOOKUP_GLOBAL("COMMON-LISP", "*PACKAGE*")
+ package = symbol.'_get_value'()
+
+ symbol = _SYMBOL(symname) # Create a new symbol
+ symbol.'_set_package'(package) # Set the home package
+
+ defined test, value # Set a value if provided
+ if test == 0 goto DONE
+
+ symbol.'_set_value'(value)
+ goto DONE
+
+DONE:
+ # VALID_IN_PARROT_0_2_0 store_lex -1, symname, symbol
+ store_lex symname, symbol
+
+ .return(symbol)
+.end
+
+
+=head2 _SYMBOL
+
+=cut
+
+.sub _SYMBOL
+ .param string symname
+
+ .local pmc symbol
+ .local pmc name
+
+ symbol = new "LispSymbol"
+
+ name = new "LispString"
+ name = symname
+ symbol.'_set_name'(name)
+
+ .return(symbol)
+.end
+
+
+=head2 _GLOBAL_SYMBOL
+
+=cut
+
+.sub _GLOBAL_SYMBOL
+ .param string pkgname
+ .param string symname
+ .param pmc value
+ .param pmc function
+
+ .local pmc packages
+ .local pmc package
+ .local pmc symbol
+ .local int test
+
+ upcase pkgname, pkgname
+ upcase symname, symname
+
+ push_eh PACKAGE_NOT_CREATED
+ get_global [package], "PACKAGES", pkgname
+ pop_eh
+
+ symbol = package.'_intern_symbol'(symname)
+ symbol.'_set_package'(package) # Set the home package
+
+ defined test, value # Set a value if provided
+ if test == 0 goto FUNCTION
+
+ symbol.'_set_value'(value)
+ goto FUNCTION
+
+FUNCTION: # Set a function if provided
+ defined test, function
+ if test == 0 goto DONE
+
+ function.'_set_name'(symname)
+ symbol.'_set_function'(function)
+ goto DONE
+
+PACKAGE_NOT_CREATED:
+ .ERROR_1("package-error", "there is no package with name \"%s\"", pkgname)
+ goto DONE
+
+DONE:
+ .return(symbol)
+.end
+
+=head2 _FUNCTION_CALL
+
+Call a function.
+
+=cut
+
+.sub _FUNCTION_CALL
+ .param pmc function
+ .param pmc args
+
+ .local pmc proto
+ proto = function.'_get_args'()
+ .local pmc body
+ body = function.'_get_body'()
+
+ .local string type
+ type = typeof function # Get the function type
+ # print function
+ # print " of type "
+ # print type
+ type = typeof body # Get the function type
+ # print " with body "
+ # print body
+ # print " with bodytype "
+ # print type
+ # print " in _FUNCTION_CALL\n"
+ type = typeof body # Get the function type
+
+ # print type
+ # print " is the type\n"
+ if type != 'Sub' goto NOT_A_COMPILED_FUNCTION
+ .tailcall body( args )
+ NOT_A_COMPILED_FUNCTION:
+
+ if type != 'LispCons' goto NOT_A_LISP_CONS
+ .local pmc scope
+ scope = function.'_get_scope'()
+
+ # 1st arg - the code to evaluate
+ # 2nd arg - the arg prototype
+ # 3rd arg - the args to evaluate
+ # The closure
+ # set_args "0,0,0", body, proto, args
+ .tailcall scope( body, proto, args )
+ # VALID_IN_PARROT_0_2_0 pushtopp # Save the upper registers
+ # VALID_IN_PARROT_0_2_0 invokecc # Call the closure
+ # VALID_IN_PARROT_0_2_0 poptopp # Restore the upper registers
+
+ # VALID_IN_PARROT_0_2_0 returncc
+ NOT_A_LISP_CONS:
+
+ .return ()
+
+DONE:
+ .return()
+.end
+
+.sub _IS_SPECIAL
+ .param pmc symbol
+
+ .local int retv
+ retv = 1
+
+ .local pmc special
+ special = getattribute symbol, "special"
+ if_null special, NOT_SPECIAL
+
+ goto DONE
+
+NOT_SPECIAL:
+ retv = 0
+ goto DONE
+
+DONE:
+ .return(retv)
+.end
+
+.sub _IS_ORDINARY_LAMBDA_LIST
+ .param pmc form
+
+ .local string type
+ .local pmc symbol
+ .local pmc args
+ .local int test
+ .local int retv
+
+ .CAR(symbol,form) # Ensure first element is a LAMBDA
+ if symbol != "LAMBDA" goto NON_LAMBDA_LIST
+
+ .SECOND(args,form) # Ensure second element is a lambda-list
+ .ASSERT_TYPE_AND_BRANCH(args, "list", MISSING_LAMBDA_LIST)
+ goto LAMBDA_LIST
+
+LAMBDA_LIST:
+ retv = 1
+ goto DONE
+
+NON_LAMBDA_LIST:
+ retv = 0
+ goto DONE
+
+MISSING_LAMBDA_LIST:
+ _error("invalid-function", "The lambda-list for LAMBDA is missing")
+ goto DONE
+
+DONE:
+ .return(retv)
+.end
+
+.sub _MAKE_LAMBDA
+ .param pmc form
+
+ # .FIRST is 'lambda'
+
+ # check the parameter declaration
+ .local pmc args
+ .SECOND(args, form)
+ .local pmc lptr
+ lptr = args
+ .local pmc symbol
+ARG_LOOP_BEGIN:
+ .NULL(lptr, ARG_LOOP_END)
+
+ .CAR(symbol, lptr) # Ensure all the arguments are
+ .ASSERT_TYPE(symbol, "symbol") # symbol types.
+
+ .CDR(lptr, lptr)
+ goto ARG_LOOP_BEGIN
+ARG_LOOP_END:
+
+ .local pmc body
+ .THIRD(body, form)
+
+ .const 'Sub' sub_that_calls_eval = 'sub_that_calls_eval'
+ .local pmc closure
+ closure = newclosure sub_that_calls_eval # Capture the scope the closure
+
+ .local pmc lisp_function
+ lisp_function = new "LispFunction"
+ lisp_function.'_set_args'(args)
+ lisp_function.'_set_body'(body)
+ lisp_function.'_set_scope'(closure)
+
+ .return(lisp_function)
+.end
+
+.sub sub_that_calls_eval :outer('_MAKE_LAMBDA') # TODO: what is really :outer ???
+ .param pmc clbody
+ .param pmc clprot
+ .param pmc clargs
+
+ # print "sub_that_calls_eval\n body: "
+ # print clbody
+ # print "\nproto: "
+ # print clprot
+ # print "\nargs: "
+ # print clargs
+ .local string clsymname
+ .local pmc clargsptr
+ .local pmc clprotptr
+ .local pmc clbody
+ .local pmc clprot
+ .local pmc clargs
+ .local pmc clarg
+ .local pmc clval
+ .local pmc clsym
+
+ clargsptr = clargs
+ clprotptr = clprot
+
+ # VALID_IN_PARROT_0_2_0 new_pad -1
+
+ goto CLOSURE_ARGS
+
+CLOSURE_ARGS:
+ .NULL(clprotptr, CLOSURE_CHECK_ARGS)
+ .NULL(clargsptr, CLOSURE_TOO_FEW_ARGS)
+
+ .CAR(clval, clargsptr) # The lexical value
+ .CAR(clarg, clprotptr) # The lexical arg prototype
+
+ clsymname = clarg.'_get_name_as_string'()
+ clsym = _LEXICAL_SYMBOL(clsymname, clval) # Create a new lexical symbol
+
+ .CDR(clargsptr, clargsptr)
+ .CDR(clprotptr, clprotptr)
+
+ goto CLOSURE_ARGS
+
+CLOSURE_CHECK_ARGS:
+ .NULL(clargsptr, CLOSURE_BODY) # Ensure we didn't have too
+ goto CLOSURE_TOO_MANY_ARGS # many args
+
+CLOSURE_BODY:
+ .local pmc clearg
+ .local pmc clretv
+
+ .LIST_1(clearg, clbody)
+ # VALID_IN_PARROT_0_2_0 pop_pad
+ .tailcall _eval(clearg)
+
+CLOSURE_TOO_FEW_ARGS:
+ # VALID_IN_PARROT_0_2_0 pop_pad
+
+ .ERROR_0("program-error", "Too few arguments given to LAMBDA")
+ goto CLOSURE_DONE
+
+CLOSURE_TOO_MANY_ARGS:
+ # VALID_IN_PARROT_0_2_0 pop_pad
+
+ .ERROR_0("program-error", "Too many arguments given to LAMBDA")
+ goto CLOSURE_DONE
+
+CLOSURE_DONE:
+ .return()
+.end
+
+.sub _LIST_LENGTH
+ .param pmc args
+
+ .local pmc lptr
+ lptr = args
+
+ .local int alen
+ alen = 0
+ .local pmc _nilp
+
+ .NIL(_nilp)
+
+LOOP:
+ eq_addr lptr, _nilp, DONE
+ inc alen
+ .CDR(lptr, lptr)
+ goto LOOP
+
+DONE:
+ .return(alen)
+.end
+
+.sub _IS_TYPE
+ .param pmc args
+ .param string rtype
+
+ .local string atype
+ .local int retv
+
+ atype = typeof args
+ retv = 1
+
+ if rtype == "cons" goto CONS_TYPE
+ if rtype == "hash" goto HASH_TYPE
+ if rtype == "integer" goto INTEGER_TYPE
+ if rtype == "float" goto FLOAT_TYPE
+ if rtype == "function" goto FUNCTION_TYPE
+ if rtype == "list" goto LIST_TYPE
+ if rtype == "number" goto NUMBER_TYPE
+ if rtype == "package" goto PACKAGE_TYPE
+ if rtype == "stream" goto STREAM_TYPE
+ if rtype == "string" goto STRING_TYPE
+ if rtype == "symbol" goto SYMBOL_TYPE
+
+ goto WRONG_TYPE
+
+CONS_TYPE:
+ if atype != "LispCons" goto WRONG_TYPE
+ goto DONE
+
+HASH_TYPE:
+ if atype != "LispHash" goto WRONG_TYPE
+ goto DONE
+
+INTEGER_TYPE:
+ if atype != "LispInteger" goto WRONG_TYPE
+ goto DONE
+
+FLOAT_TYPE:
+ if atype != "LispFloat" goto WRONG_TYPE
+ goto DONE
+
+FUNCTION_TYPE:
+ if atype != "LispFunction" goto WRONG_TYPE
+ goto DONE
+
+LIST_TYPE:
+ if atype != "LispSymbol" goto NONEMPTY_LIST
+ .NULL(args, DONE)
+NONEMPTY_LIST:
+ if atype != "LispCons" goto WRONG_TYPE
+ goto DONE
+
+NUMBER_TYPE:
+ if atype == "LispInteger" goto DONE
+ if atype != "LispFloat" goto WRONG_TYPE
+ goto DONE
+
+PACKAGE_TYPE:
+ if atype != "LispPackage" goto WRONG_TYPE
+ goto DONE
+
+STREAM_TYPE:
+ if atype != "LispStream" goto WRONG_TYPE
+ goto DONE
+
+STRING_TYPE:
+ if atype != "LispString" goto WRONG_TYPE
+ goto DONE
+
+SYMBOL_TYPE:
+ if atype != "LispSymbol" goto WRONG_TYPE
+ goto DONE
+
+WRONG_TYPE:
+ retv = 0
+ goto DONE
+
+DONE:
+ .return(retv)
+.end
+
+# Local Variables:
+# mode: pir
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:
Added: lisp/trunk/lib/Parrot/Test/Lisp.pm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ lisp/trunk/lib/Parrot/Test/Lisp.pm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,84 @@
+# $Id$
+
+package Parrot::Test::Lisp;
+
+# Copyright (C) 2007, Parrot Foundation.
+
+use strict;
+use warnings;
+
+use File::Basename;
+
+=head1 NAME
+
+Parrot::Test::Lisp -- testing routines for languages/lisp
+
+This is largely a copy of Parrot::Test::Punie.
+
+=cut
+
+# Generate output_is(), output_isnt() and output_like() in current package.
+Parrot::Test::generate_languages_functions();
+
+sub new {
+ return bless {};
+}
+
+
+sub get_lang_fn {
+ my $self = shift;
+ my ( $count, $options ) = @_;
+
+ return File::Spec->rel2abs(Parrot::Test::per_test( '.l', $count ));
+}
+
+sub get_out_fn {
+ my $self = shift;
+ my ( $count, $options ) = @_;
+
+ return File::Spec->rel2abs(Parrot::Test::per_test( '.out', $count ));
+}
+
+sub get_cd {
+ my $self = shift;
+ my ( $options ) = @_;
+
+ return "$self->{relpath}/languages/lisp";
+}
+
+# never skip
+sub skip_why {
+ my $self = shift;
+ my ($options) = @_;
+
+ return;
+}
+
+sub get_test_prog {
+ my $self = shift;
+ my ( $count, $options ) = @_;
+
+ my $lang_fn = Parrot::Test::per_test( '.l', $count );
+ ( undef, undef, my $current_dir ) = File::Spec->splitpath( Cwd::getcwd() );
+ if ( $current_dir eq 'languages' ) {
+ $lang_fn = File::Spec->catdir( '..', $lang_fn );
+ }
+
+ my $test_prog_args = $ENV{TEST_PROG_ARGS} || q{};
+
+ return
+ join( ' ',
+ "../../$self->{parrot}",
+ 'lisp.pbc',
+ $test_prog_args,
+ $lang_fn );
+}
+
+1;
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: lisp/trunk/lisp.pir
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ lisp/trunk/lisp.pir Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,155 @@
+# $Id$
+
+=head1 NAME
+
+lisp.pir - main function of Parrot Common Lisp
+
+=head1 Description
+
+The C<main> sub is provided here.
+Some constants are defined
+Needed PIR code is included.
+
+=cut
+
+# standard libs
+.include "library/dumper.pir"
+
+.const int INVALID_CHAR = 0
+.const int CONSTITUENT_CHAR = 1
+.const int WHITESPACE_CHAR = 2
+.const int TERM_MACRO_CHAR = 3
+.const int NTERM_MACRO_CHAR = 4
+.const int SESCAPE_CHAR = 5
+.const int MESCAPE_CHAR = 6
+
+.sub _init_common_lisp :init
+ $P1 = loadlib 'rational' # The rational PMC is needed for 'LispRational'
+.end
+
+
+.include 'include/macros.pir'
+.include 'types.pir'
+.include 'read.pir'
+.include 'eval.pir'
+.include 'system.pir'
+.include 'validate.pir'
+.include 'cl.pir'
+.include 'internals.pir'
+
+.sub _common_lisp :main
+ .param pmc argv
+
+ .local pmc args # piece together args of function
+ .local pmc retv # return value of function calls
+ .local int res
+
+ load_bytecode 'PGE.pbc' # Parrot Grammar engine
+
+ # compile a couple of regexes that are needed in validate.pir
+ .local pmc p6rule
+ p6rule = compreg "PGE::Perl6Regex"
+
+ .local pmc is_integer
+ is_integer = p6rule( '^<[+\-]>?\d+\.?$' )
+ set_global 'is_integer', is_integer
+
+ .local pmc is_float
+ is_float = p6rule( '^<[+\-]>?\d+\.\d+$' )
+ set_global 'is_float', is_float
+
+ .local pmc is_qualified
+ # todo keyword, split into qualifier, package and symbol
+ is_qualified = p6rule( '(<[abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789]>*)\:(<[abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789%\-]>*)' )
+ set_global 'is_qualified', is_qualified
+
+ # TODO: initialize the null lexical environment.
+
+ # bootstrapping
+ .local pmc bootstrap_filename
+ .STRING(bootstrap_filename, "lisp/bootstrap.l")
+ .LIST_1(args, bootstrap_filename)
+ _load(args)
+
+ # check the commandline whether we should read STDIN or load from file
+ .local int argc
+ argc = argv
+ if argc <= 1 goto READ_STDIN
+
+ # interpret a file
+ .local pmc infile_name # name of the inputfile from the commandline
+ .STRING(infile_name, argv[1])
+ .LIST_1(args, infile_name)
+ retv = _load(args) # Load the specified file.
+
+ end
+
+READ_STDIN:
+ # Read-Eval-Print-Loop
+
+ .local pmc symbol
+ symbol = _LOOKUP_GLOBAL("COMMON-LISP", "*STANDARD-INPUT*")
+ .local pmc stdin
+ stdin = symbol.'_get_value'()
+
+ push_eh DEBUGGER # Setup error handler for debug loop.
+
+REP_LOOP:
+ print "-> " # Display the top level prompt.
+
+ .LIST_1(args, stdin) # Read!
+ retv = _read(args)
+
+ .LIST_1(args, retv) # Eval!
+ # VALID_IN_PARROT_0_2_0 retv = _eval(args)
+
+ # VALID_IN_PARROT_0_2_0 foldup retv
+ ( retv :slurpy) = _eval(args)
+
+ .local int nretv
+ nretv = retv
+
+ .local pmc tmpval
+ .local int i
+ i = 0
+
+PRINT_LOOP:
+ tmpval = retv[i]
+
+ print tmpval
+
+ inc i
+ if i == nretv goto PRINT_DONE
+
+ print " ;\n"
+
+ goto PRINT_LOOP
+
+PRINT_DONE:
+ print "\n"
+
+ goto REP_LOOP
+
+DEBUGGER:
+ .local string message
+ .local string msgtype
+ .local pmc e
+
+ .get_results (e)
+
+ message = e
+
+ print "*** ERROR: "
+ print message
+ print "\n"
+
+ push_eh DEBUGGER
+
+ goto REP_LOOP
+.end
+
+# Local Variables:
+# mode: pir
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:
Added: lisp/trunk/lisp/bootstrap.l
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ lisp/trunk/lisp/bootstrap.l Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,109 @@
+;; Export external symbols from the COMMON-LISP package
+(sys:%export (sys:%find-package "COMMON-LISP")
+ ;; List related functions
+ "APPEND" "CAAR" "CADR" "CDAR" "CDDR" "CAAAR" "CAADR" "CADAR"
+ "CADDR" "CDAAR" "CDADR" "CDDAR" "CDDDR" "CAAAAR" "CAAADR" "CAADAR"
+ "CAADDR" "CADAAR" "CADADR" "CADDAR" "CDAAAR" "CDAADR" "CDADAR"
+ "CDADDR" "CDDAAR" "CDDADR" "CDDDAR" "CDDDDR"
+
+ "FIRST" "SECOND" "THIRD" "FOURTH" "FIFTH" "SIXTH" "SEVENTH"
+ "EIGHTH" "NINTH" "TENTH"
+
+ "ACONS" "CONS" "LIST"
+
+ "COPY-TREE" "IDENTITY"
+
+ ;; Math functions
+ "*" "+" "-" "/" "=" "1+" "1-" "EVENP" "MOD" "ODDP" "ZEROP"
+
+ ;; Predicate functions
+ "BOUNDP" "CHARACTERP" "CONSP" "ENDP" "FLOATP" "FUNCTIONP"
+ "HASH-TABLE-P" "INTEGERP" "KEYWORDP" "LISTP" "NUMBERP" "PACKAGEP"
+ "STREAMP" "STRINGP" "SYMBOLP"
+
+ ;; Macros
+ "DEFUN"
+
+ ;; Miscellaneous functions
+ "APPLY" "ATOM" "CHAR" "EQ" "EQL" "EVAL" "FUNCTION" "GENSYM" "LET"
+ "NOT" "NULL" "PACKAGE-NAME" "PRINT" "PROGN" "QUOTE" "READ"
+ "READ-DELIMITED-LIST" "RPLACA" "RPLACD" "SETQ" "SYMBOL-FUNCTION"
+ "SYMBOL-NAME" "SYMBOL-PACKAGE" "TYPE-OF" "VALUES"
+ "IN-PACKAGE"
+
+ ;; Miscellaneous symbols
+ "*GENSYM-COUNTER*" "*MACROEXPAND-HOOK*" "*PACKAGE*" "*READ-EVAL*"
+ "*READTABLE*" "*STANDARD-INPUT*" "*STANDARD-OUTPUT*" "BASE-CHAR"
+ "FLOAT" "HASH-TABLE" "INTEGER" "MACRO" "NIL" "PACKAGE" "STREAM"
+ "STRING" "SYMBOL" "T")
+
+;; Set the current package to SYSTEM so we don't have to prefix symbols.
+(cl:setq *package* (sys:%find-package "SYSTEM"))
+(%use-package (%find-package "SYSTEM") (%find-package "COMMON-LISP"))
+
+;; Create a hash table used to store all the dispatching macros.
+(setq *dispatching-macros* (%make-hash-table))
+
+;;;;; ;; #'xxx macro. See CLtL section 2.4.8.2 for details.
+;;;;; (%set-hash *dispatching-macros*
+;;;;; "'"
+;;;;; (function
+;;;;; (lambda (stream char)
+;;;;; (list 'function (read stream)))))
+;;;;;
+;;;;; ;; #.xxx macro. See CLtL section 2.4.8.6 for details.
+;;;;; (setq *read-eval* t)
+;;;;; (%set-hash *dispatching-macros*
+;;;;; "."
+;;;;; (function
+;;;;; (lambda (stream char)
+;;;;; (if *read-eval*
+;;;;; (eval (read stream))
+;;;;; (error "reader-error" "*READ-EVAL* is NIL")))))
+;;;;;
+;;;;; ;; #< macro. See CLtL section 2.4.8.20 for details.
+;;;;; (%set-hash *dispatching-macros*
+;;;;; "<"
+;;;;; (function
+;;;;; (lambda (stream char)
+;;;;; (error "reader-error" "#< is invalid syntax"))))
+;;;;;
+;;;;; ;; ##<Space> macro. See CLtL section 2.4.8.21 for details.
+;;;;; (%set-hash *dispatching-macros*
+;;;;; " "
+;;;;; (function
+;;;;; (lambda (stream char)
+;;;;; (error "reader-error" "#| | is invalid syntax"))))
+;;;;;
+;;;;; ;; #) macro. See CLtL section 2.4.8.22 for details.
+;;;;; (%set-hash *dispatching-macros*
+;;;;; ")"
+;;;;; (function
+;;;;; (lambda (stream char)
+;;;;; (error "reader-error" "#) is invalid syntax"))))
+;;;;;
+;;;;; ; (setq *macroexpand-hook* #'(lambda (fn form env)
+;;;;; ; (apply fn (list form env))))
+;;;;; (setq *macroexpand-hook* ( function(lambda (fn form env)
+;;;;; (apply fn (list form env)))))
+;;;;;
+;;;;; ;; Create the KEYWORD package.
+;;;;; (sys:%make-package "KEYWORD")
+;;;;;
+;;;;; (sys:load "lisp/objects.l")
+;;;;; (sys:load "lisp/core.l")
+;;;;; (sys:load "lisp/logic.l")
+;;;;; (sys:load "lisp/pred.l")
+;;;;; (sys:load "lisp/list.l")
+;;;;; (sys:load "lisp/math.l")
+;;;;;
+;;;;; ;; Create and alias the COMMON-LISP-USER package.
+;;;;; (sys:%make-package "COMMON-LISP-USER")
+;;;;; (sys:%alias-package (sys:%find-package "COMMON-LISP-USER") "CL-USER")
+;;;;;
+;;;;; (cl:setq *package* (sys:%find-package "CL-USER"))
+;;;;; (sys:%use-package (sys:%find-package "CL-USER")
+;;;;; (sys:%find-package "COMMON-LISP"))
+
+; (in-package "COMMON-LISP-USER")
+(cl:setq *package* (sys:%find-package "CL"))
Added: lisp/trunk/lisp/core.l
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ lisp/trunk/lisp/core.l Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,18 @@
+(setq cl:*package* (sys:%find-package "COMMON-LISP"))
+
+;; Define a temporary, primitive version of the defun macro.
+(sys:set-symbol-function 'defun
+ (sys:%make-macro
+ (function (lambda (form env)
+ (let ((name (car form)) (body (cdr form)))
+ (list 'progn
+ (list 'sys:set-symbol-function
+ (list 'quote name)
+ (list 'function (cons 'lambda body)))
+ (list 'sys:set-function-name
+ (list 'sys:get-symbol-function (list 'quote name))
+ (list 'symbol-name (list 'quote name)))
+ (list 'sys:get-symbol-function (list 'quote name))))))))
+
+; (defun in-package (pkg)
+; (setq *package* (sys:%find-package pkg)))
Added: lisp/trunk/lisp/list.l
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ lisp/trunk/lisp/list.l Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,68 @@
+; (in-package "COMMON-LISP")
+;
+; ;; Define some list accessing functions.
+; (defun caar (x) (car (car x)))
+; (defun cadr (x) (car (cdr x)))
+; (defun cdar (x) (cdr (car x)))
+; (defun cddr (x) (cdr (cdr x)))
+;
+; (defun caaar (x) (car (car (car x))))
+; (defun caadr (x) (car (car (cdr x))))
+; (defun cadar (x) (car (cdr (car x))))
+; (defun caddr (x) (car (cdr (cdr x))))
+; (defun cdaar (x) (cdr (car (car x))))
+; (defun cdadr (x) (cdr (car (cdr x))))
+; (defun cddar (x) (cdr (cdr (car x))))
+; (defun cdddr (x) (cdr (cdr (cdr x))))
+;
+; (defun caaaar (x) (car (car (car (car x)))))
+; (defun caaadr (x) (car (car (car (cdr x)))))
+; (defun caadar (x) (car (car (cdr (car x)))))
+; (defun caaddr (x) (car (car (cdr (cdr x)))))
+; (defun cadaar (x) (car (cdr (car (car x)))))
+; (defun cadadr (x) (car (cdr (car (cdr x)))))
+; (defun caddar (x) (car (cdr (cdr (car x)))))
+; (defun cadddr (x) (car (cdr (cdr (cdr x)))))
+; (defun cdaaar (x) (cdr (car (car (car x)))))
+; (defun cdaadr (x) (cdr (car (car (cdr x)))))
+; (defun cdadar (x) (cdr (car (cdr (car x)))))
+; (defun cdaddr (x) (cdr (car (cdr (cdr x)))))
+; (defun cddaar (x) (cdr (cdr (car (car x)))))
+; (defun cddadr (x) (cdr (cdr (car (cdr x)))))
+; (defun cdddar (x) (cdr (cdr (cdr (car x)))))
+; (defun cddddr (x) (cdr (cdr (cdr (cdr x)))))
+;
+; (defun endp (x) (eq x nil))
+;
+; (defun first (x) (car x))
+; (defun second (x) (cadr x))
+; (defun third (x) (caddr x))
+; (defun fourth (x) (cadddr x))
+; (defun fifth (x) (car (cddddr x)))
+; (defun sixth (x) (cadr (cddddr x)))
+; (defun seventh (x) (caddr (cddddr x)))
+; (defun eighth (x) (cadddr (cddddr x)))
+; (defun ninth (x) (car (cddddr (cddddr x))))
+; (defun tenth (x) (cadr (cddddr (cddddr x))))
+;
+; ;; Appends list A to list B
+; (sys:set-symbol-function 'append
+; #'(lambda (a b)
+; (if (null a)
+; b
+; (cons (car a) (append (cdr a) b)))))
+;
+; ;; Copies and returns the passed tree.
+; (defun copy-tree (tree)
+; (if (consp tree)
+; (cons (copy-tree (car tree))
+; (copy-tree (cdr tree)))
+; tree))
+;
+; ;; Identity returns whatever was passed to the function
+; (defun identity (object) object)
+;
+; ;; For working with association lists.
+; (defun acons (key val list)
+; (cons (cons key val) list))
+;
Added: lisp/trunk/lisp/logic.l
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ lisp/trunk/lisp/logic.l Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,5 @@
+; (in-package "COMMON-LISP")
+;
+; ;; Define some logical functions
+; (defun not (x) (null x))
+;
Added: lisp/trunk/lisp/math.l
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ lisp/trunk/lisp/math.l Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,7 @@
+; (in-package "COMMON-LISP")
+;
+; (defun 1+ (x) (+ x 1))
+; (defun 1- (x) (- x 1))
+; (defun evenp (x) (eql (mod x 2) 0))
+; (defun oddp (x) (eql (mod x 2) 1))
+; (defun zerop (x) (eql x 0))
Added: lisp/trunk/lisp/objects.l
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ lisp/trunk/lisp/objects.l Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,90 @@
+(cl:setq cl:*package* (sys:%find-package "SYSTEM"))
+
+;; Set up some of the accessors for the LispSymbol class attributes.
+(%set-object-attribute 'set-symbol-function
+ "LispSymbol"
+ "function"
+ (function (lambda (s f)
+ (%set-object-attribute s "LispSymbol" "function" f))))
+
+; (set-symbol-function 'get-symbol:% s/^/; /-function
+; (function (lambda (s)
+; (%get-object-attribute s "LispSymbol" "function"))))
+;
+(set-symbol-function 'set-symbol-documentation
+ (function (lambda (s d)
+ (%set-object-attribute s "LispSymbol" "documentation" d))))
+
+(set-symbol-function 'get-symbol-documentation
+ (function (lambda (s)
+ (%get-object-attribute s "LispSymbol" "documentation"))))
+
+(set-symbol-function 'set-symbol-name
+ (function (lambda (s n)
+ (%set-object-attribute s "LispSymbol" "name" n))))
+
+(set-symbol-function 'get-symbol-name
+ (function (lambda (s)
+ (%get-object-attribute s "LispSymbol" "name"))))
+
+(set-symbol-function 'set-symbol-package
+ (function (lambda (s p)
+ (%set-object-attribute s "LispSymbol" "package" p))))
+
+(set-symbol-function 'get-symbol-package
+ (function (lambda (s)
+ (%get-object-attribute s "LispSymbol" "package"))))
+
+(set-symbol-function 'set-symbol-value
+ (function (lambda (s v)
+ (%set-object-attribute s "LispSymbol" "value" v))))
+
+(set-symbol-function 'get-symbol-value
+ (function (lambda (s)
+ (%get-object-attribute s "LispSymbol" "value"))))
+
+;; Set up some of the accessors for the LispPackage class attributes.
+(set-symbol-function 'set-package-name
+ (function (lambda (p n)
+ (%set-object-attribute p "LispPackage" "name" n))))
+
+(set-symbol-function 'get-package-name
+ (function (lambda (p)
+ (%get-object-attribute p "LispPackage" "name"))))
+
+;; Set up some of the accessors for the LispFunction class attributes.
+(set-symbol-function 'set-function-documentation
+ (function (lambda (f d)
+ (%set-object-attribute f "LispFunction" "documentation" d))))
+
+(set-symbol-function 'get-function-documentation
+ (function (lambda (f)
+ (%get-object-attribute f "LispFunction" "documentation"))))
+
+(set-symbol-function 'get-function-name
+ (function (lambda (f)
+ (%get-object-attribute f "LispFunction" "name"))))
+
+(set-symbol-function 'set-function-name
+ (function (lambda (f n)
+ (%set-object-attribute f "LispFunction" "name" n))))
+
+
+;; The following functions should be created in the COMMON-LISP package.
+(setq *package* (%find-package "COMMON-LISP"))
+
+(sys:set-symbol-function 'symbol-function
+ (function (lambda (s)
+ (sys:get-symbol-function s))))
+
+(sys:set-symbol-function 'symbol-name
+ (function (lambda (s)
+ (sys:get-symbol-name s))))
+
+(sys:set-symbol-function 'symbol-package
+ (function (lambda (s)
+ (sys:get-symbol-package s))))
+
+(sys:set-symbol-function 'package-name
+ (function (lambda (p)
+ (sys:get-package-name p))))
Added: lisp/trunk/lisp/pred.l
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ lisp/trunk/lisp/pred.l Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,51 @@
+; (in-package "COMMON-LISP")
+;
+; ;; XXX - This should also compare characters (which we don't have yet).
+; (defun eql (x y)
+; (if (eq x y)
+; t
+; (if (numberp x)
+; (if (numberp y)
+; (if (eq (type-of x) (type-of y))
+; (= x y))))))
+;
+; ;; Define some predicate functions.
+; (defun characterp (x) (eq (type-of x) 'base-char))
+;
+; (defun consp (x) (eq (type-of x) 'cons))
+;
+; (defun floatp (x) (eq (type-of x) 'float))
+;
+; (defun functionp (x) (eq (type-of x) 'function))
+;
+; (defun hash-table-p (x) (eq (type-of x) 'hash-table))
+;
+; (defun integerp (x) (eq (type-of x) 'integer))
+;
+; (defun keywordp (x)
+; (if (symbolp x)
+; (eq (symbol-package x) (sys:%find-package "KEYWORD"))
+; nil))
+;
+; (defun listp (x)
+; (if (eq x 'nil)
+; t
+; (eq (type-of x) 'cons)))
+;
+; (defun numberp (x)
+; (if (eq (type-of x) 'integer)
+; t
+; (eq (type-of x) 'float)))
+;
+; (defun packagep (x)
+; (eq (type-of x) 'package))
+;
+; (defun streamp (x)
+; (eq (type-of x) 'stream))
+;
+; (defun stringp (x)
+; (eq (type-of x) 'string))
+;
+; (defun symbolp (x)
+; (eq (type-of x) 'symbol))
+;
Added: lisp/trunk/read.pir
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ lisp/trunk/read.pir Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,550 @@
+# $Id$
+
+=head1 NAME
+
+read.pir - lexing and parsing, reader macros
+
+=head1 DESCRIPTION
+
+The Lisp reader is implemented here.
+See CLtL section 23.1 .
+
+=head1 SUBROUTINES
+
+=cut
+
+=head2 _read
+
+The function that implements the Lisp reader CLtL 2.2.
+
+=cut
+
+.sub _read
+ .param pmc args
+
+ .local pmc readmacros
+ .local pmc readtable
+ .local pmc readcase
+ .local pmc readobj
+ .local pmc symbol
+ .local pmc istream
+ .local pmc stream
+ .local string token
+ .local pmc retv
+ .local int nretv
+
+ .ASSERT_LENGTH(args,1,ERROR_NARGS) # We should have received one argument -
+ # the input stream to read from.
+
+ .CAR(istream, args)
+ stream = istream.'_get_io'()
+
+ symbol = _LOOKUP_GLOBAL("SYSTEM", "*READER-MACROS*")
+ readmacros = symbol.'_get_value'()
+
+ symbol = _LOOKUP_GLOBAL("COMMON-LISP", "*READTABLE*")
+ readobj = symbol.'_get_value'()
+
+ readtable = readobj.'_get_table'()
+ readcase = readobj.'_get_case'()
+
+ .local string char
+ .local int ordv
+ .local int type
+
+STEP_1:
+ read char, stream, 1 # Read a character from the stream
+ if char == "" goto EOF
+
+ ord ordv, char # Figure out what kind of character
+ type = readtable[ordv] # it represents
+
+ if type == INVALID_CHAR goto READER_ERROR
+ if type == WHITESPACE_CHAR goto STEP_1
+ if type == TERM_MACRO_CHAR goto STEP_4
+ if type == NTERM_MACRO_CHAR goto STEP_4
+ if type == SESCAPE_CHAR goto STEP_5
+ if type == MESCAPE_CHAR goto STEP_6
+ if type == CONSTITUENT_CHAR goto STEP_7
+ goto READER_ERROR
+
+STEP_4:
+ .local pmc macro
+ .local pmc margs
+ .local pmc mchar
+
+ macro = readmacros[char] # Get the readmacro we're calling
+
+ .STRING(mchar, char)
+
+ .LIST_2(margs, istream, mchar) # Create a list of args to pass in
+ # VALID_IN_PARROT_0_2_0 retv = _FUNCTION_CALL(macro, margs) # Call the readmacro
+
+ null retv
+ retv = _FUNCTION_CALL(macro, margs) # Call the readmacro
+ # VALID_IN_PARROT_0_2_0 if argcP == 0 goto STEP_1
+ if_null retv, STEP_1
+ goto DONE
+
+STEP_5:
+ read char, stream, 1
+ if char == "" goto EOF
+
+ token = char
+
+ goto STEP_9
+
+STEP_6:
+ token = ""
+ goto STEP_9
+
+STEP_7:
+ token = char
+
+STEP_8:
+ peek char, stream # A bit of a workaround until a
+ ord ordv, char # unget opcode is implemented
+ type = readtable[ordv] # to push chars back on the stream.
+
+ if char == "" goto STEP_10
+
+ if type == WHITESPACE_CHAR goto STEP_10
+ if type == TERM_MACRO_CHAR goto STEP_10
+
+ read char, stream, 1
+
+ if type == CONSTITUENT_CHAR goto STEP_8a
+ if type == NTERM_MACRO_CHAR goto STEP_8a
+ if type == SESCAPE_CHAR goto STEP_8c
+ if type == MESCAPE_CHAR goto STEP_9
+ if type == INVALID_CHAR goto READER_ERROR
+ goto READER_ERROR
+
+STEP_8a:
+ if readcase == 0 goto STEP_8b
+ upcase char
+
+STEP_8b:
+ concat token, char
+ goto STEP_8
+
+STEP_8c:
+ read char, stream, 1
+ if char == "" goto EOF
+
+ concat token, char
+ goto STEP_8
+
+STEP_9:
+ read char, stream, 1
+ if char == "" goto EOF
+
+ if type == CONSTITUENT_CHAR goto STEP_9a
+ if type == WHITESPACE_CHAR goto STEP_9a
+ if type == TERM_MACRO_CHAR goto STEP_9a
+ if type == NTERM_MACRO_CHAR goto STEP_9a
+ if type == SESCAPE_CHAR goto STEP_9b
+ if type == MESCAPE_CHAR goto STEP_8
+ if type == INVALID_CHAR goto READER_ERROR
+ goto READER_ERROR
+
+STEP_9a:
+ concat token, char
+ goto STEP_9
+
+STEP_9b:
+ read char, stream, 1
+ if char == "" goto EOF
+
+ concat token, char
+ goto STEP_9
+
+STEP_10:
+ retv = _VALIDATE_TOKEN(token)
+ if_null retv, READER_ERROR
+
+ goto DONE
+
+READER_ERROR:
+ .ERROR_0("reader-error", "Invalid character found in input stream.")
+ goto DONE
+
+EOF:
+ .NIL(retv)
+ goto DONE
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to READ")
+ goto DONE
+
+DONE:
+ .return(retv)
+.end
+
+.sub _error
+ .param string type # There's current no way to add more
+ .param string mesg # than just a message to the exception.
+
+ .local pmc e
+
+ e = new 'Exception'
+ e = mesg
+
+ throw e
+.end
+
+.sub _read_delimited_list
+ .param pmc args
+
+ .local string dchar
+ .local string char
+ .local pmc readmacros
+ .local pmc readtable
+ .local pmc readobj
+ .local pmc delimit
+ .local pmc istream
+ .local pmc stream
+ .local pmc symbol
+ .local pmc tretv
+ .local pmc retv
+ .local pmc lptr
+ .local int ordv
+ .local int type
+
+ .ASSERT_LENGTH_BETWEEN(args, 1, 2, ERROR_NARGS)
+
+ .CAR(delimit, args) # First arg is the delimit character
+ .ASSERT_TYPE_AND_BRANCH(delimit, "string", ERROR_NONSTRING)
+ dchar = delimit
+
+ .SECOND(istream, args) # Second arg is the input stream
+ .NULL(istream, GET_STDIN) # If we don't have a stream get stdin
+ goto DONE_ARGS
+
+GET_STDIN:
+ symbol = _LOOKUP_GLOBAL("COMMON-LISP", "*STANDARD-INPUT*")
+ istream = symbol.'_get_value'()
+ goto DONE_ARGS
+
+DONE_ARGS:
+ .ASSERT_TYPE_AND_BRANCH(istream, "stream", ERROR_NONSTREAM)
+ stream = istream.'_get_io'()
+
+ symbol = _LOOKUP_GLOBAL("SYSTEM", "*READER-MACROS*")
+ readmacros = symbol.'_get_value'()
+
+ symbol = _LOOKUP_GLOBAL("COMMON-LISP", "*READTABLE*")
+ readobj = symbol.'_get_value'()
+
+ readtable = readobj.'_get_table'()
+
+ .NIL(retv) # Initialize the return to NIL
+ lptr = retv
+
+LOOP:
+ peek char, stream # Read a character from the stream
+ if char == "" goto EOF
+
+ ord ordv, char # Figure out what kind of character
+ type = readtable[ordv] # it represents
+
+ if type == INVALID_CHAR goto READER_ERROR
+ if type == WHITESPACE_CHAR goto WHITESPACE
+ if char == dchar goto DELIMIT_CHAR
+ if type == SESCAPE_CHAR goto READ_OBJECT
+ if type == MESCAPE_CHAR goto READ_OBJECT
+ if type == CONSTITUENT_CHAR goto READ_OBJECT
+ if type == TERM_MACRO_CHAR goto CALL_MACRO
+ if type == NTERM_MACRO_CHAR goto CALL_MACRO
+ goto READER_ERROR
+
+READ_OBJECT: # We've found a constituent char -
+ .local pmc rargs # use _read to read in an object
+
+ .LIST_1(rargs, istream) # Create the arg list for _read
+ tretv = _read(rargs) # Read in the object
+ goto APPEND_TO_LIST
+
+APPEND_TO_LIST:
+ .APPEND(retv, retv, tretv)
+ goto LOOP
+
+WHITESPACE:
+ read char, stream, 1 # Whitespace chars get consumed
+ goto LOOP
+
+CALL_MACRO:
+ .local pmc macro
+ .local pmc margs
+ .local pmc mchar
+
+ read char, stream, 1 # Consume the macro character
+
+ macro = readmacros[char] # Get the readmacro we're calling
+
+ .STRING(mchar, char)
+ .LIST_2(margs, istream, mchar) # Create a list of args to pass in
+
+ null tretv
+ tretv = _FUNCTION_CALL(macro, margs) # Call the readmacro
+ if_null tretv, LOOP
+
+ # VALID_IN_PARROT_0_2_0 if argcP == 0 goto LOOP # If macro is NULL, start loop again
+ # VALID_IN_PARROT_0_2_0 ntretv = tretv
+ # VALID_IN_PARROT_0_2_0 if ntretv == 0 goto LOOP # If macro is NULL, start loop again
+ goto APPEND_TO_LIST # else add the return value to list
+
+DELIMIT_CHAR: # We've hit the delimiter char -
+ read char, stream, 1 # consume it, and return the list
+ goto DONE
+
+READER_ERROR:
+ .ERROR_0("reader-error", "invalid character found in input stream.")
+ goto DONE
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to READ-DELIMITED-LIST")
+ goto DONE
+
+ERROR_NONSTRING:
+ .ERROR_1("type-error", "argument %s is not a character", delimit)
+ goto DONE
+
+ERROR_NONSTREAM:
+ .ERROR_1("type-error", "argument %s is not a stream", istream)
+ goto DONE
+
+EOF:
+ .ERROR_0("end-of-file", "EOF on input stream reached.")
+ goto DONE
+
+DONE:
+ .return(retv)
+.end
+
+=head2 _left_paren_macro
+
+CLtL section 2.4.1.
+
+=cut
+
+.sub _left_paren_macro
+ .param pmc args
+
+ .local pmc stream
+ .CAR(stream, args) # Get the input stream off the args
+
+ .local pmc delimit
+ .STRING(delimit, ")") # ')' is the delimiter for this macro
+
+ .local pmc rargs
+ .LIST_2(rargs, delimit, stream) # Package it up for the call
+
+ .local pmc retv
+ retv = _read_delimited_list(rargs) # Read the delimited list in.
+
+ .return(retv)
+.end
+
+=head2 _right_paren_macro
+
+As described in CLtL section 2.4.2
+
+=cut
+
+.sub _right_paren_macro
+ .param pmc args
+
+ .ERROR_0("reader-error", "An object cannot start with #\\)")
+.end
+
+=head2 _single_quote_macro
+
+As described in CLtL section 2.4.3
+
+=cut
+
+.sub _single_quote_macro
+ .param pmc args
+
+ .local pmc stream
+ .CAR(stream, args) # Get the input stream off the args
+
+ .local pmc rargs
+ .LIST_1(rargs, stream) # Package it up for the call to _read
+
+ .local pmc form
+ form = _read(rargs) # Read in a new object
+
+ .local pmc symbol
+ symbol = _LOOKUP_GLOBAL("COMMON-LISP", "QUOTE")
+
+ .local pmc retv
+ .LIST_2(retv, symbol, form) # Create a list equiv to (quote token)
+
+RETURN:
+ .return(retv)
+.end
+
+=head2 _semicolon_macro
+
+A comment. Skip everything till the end of line
+or the end of file.
+
+As described in CLtL section 2.4.4
+
+=cut
+
+.sub _semicolon_macro
+ .param pmc args
+
+
+ .local pmc stream
+ .CAR(stream, args) # Get the input stream off the args
+ .local pmc istream
+ istream = stream.'_get_io'()
+
+ .local string char
+LOOP:
+ read char, istream, 1
+ if char == "\n" goto RETURN
+ if char == "" goto RETURN
+ goto LOOP
+
+RETURN:
+.end
+
+=head2
+
+As described in CLtL section 2.4.5.
+
+=cut
+
+.sub _double_quote_macro
+ .param pmc args
+
+ .local pmc stream
+ .CAR(stream, args) # Get the input stream off the args
+ .local pmc istream
+ istream = stream.'_get_io'()
+
+ .local pmc symbol
+ symbol = _LOOKUP_GLOBAL("COMMON-LISP", "*READTABLE*")
+ .local pmc readtable
+ readtable = symbol.'_get_value'()
+ .local pmc table
+ table = readtable.'_get_table'()
+
+ .local string strtok
+ strtok = ""
+
+ .local string char
+ .local int ordval
+ .local int chtype
+
+ goto STEP_1
+
+STEP_1:
+ read char, istream, 1
+ if char == "" goto EOF_ERROR
+
+ ord ordval, char
+ chtype = table[ordval]
+
+ if chtype == SESCAPE_CHAR goto STEP_1a
+ if char == "\"" goto RETURN
+ goto STEP_1b
+
+STEP_1a:
+ read char, istream, 1
+ if char == "" goto EOF_ERROR
+
+ goto STEP_1b
+
+STEP_1b:
+ concat strtok, char
+ goto STEP_1
+
+EOF_ERROR:
+ .ERROR_0("end-of-file", "EOF on input stream reached.")
+ goto RETURN
+
+RETURN:
+ .local pmc token
+ .STRING(token, strtok)
+
+ .return(token)
+.end
+
+=head2 _backquote_macro
+
+As described in CLtL section 2.4.6
+
+=cut
+
+.sub _backquote_macro
+
+ .ERROR_0("reader-error", "The backquote macro has not yet been implemented.")
+.end
+
+=head2 _comma_macro
+
+As described in CLtL section 2.4.7
+
+=cut
+
+.sub _comma_macro
+
+ .ERROR_0("reader-error", "Comma is illegal outside of backquote.")
+.end
+
+.sub _sharpsign_macro # As described in CLtL section 2.4.8
+ .param pmc args
+
+ .local string char
+ .local pmc istream
+ .local pmc stream
+ .local pmc symbol
+ .local pmc macros
+ .local pmc macro
+ .local pmc retv
+ .local pmc func
+
+ .CAR(stream,args)
+ istream = stream.'_get_io'()
+
+ read char, istream, 1
+
+ symbol = _LOOKUP_GLOBAL("SYSTEM", "*DISPATCHING-MACROS*")
+ .ASSERT_TYPE_AND_BRANCH(symbol, "symbol", MACRO_NOT_INITIALIZED)
+
+ macros = symbol.'_get_value'()
+ .ASSERT_TYPE_AND_BRANCH(macros, "hash", MACRO_NOT_INITIALIZED)
+
+ macro = macros[char]
+
+ if_null macro, MACRO_NOT_DEFINED
+
+ .ASSERT_TYPE(macro, "function")
+ _FUNCTION_CALL(macro,args)
+
+ goto DONE
+
+MACRO_NOT_INITIALIZED:
+ .ERROR_0("reader-error","the dispatching macro table has not been created")
+ goto DONE
+
+MACRO_NOT_DEFINED:
+ .ERROR_1("reader-error","\"%s\" dispatching macro has not been defined",char)
+ goto DONE
+
+DONE:
+ returncc
+.end
+
+
+# Local Variables:
+# mode: pir
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:
Added: lisp/trunk/system.pir
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ lisp/trunk/system.pir Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,696 @@
+# $Id$
+
+=head1 NAME
+
+system.pir - implementation specific package SYSTEM
+
+=head1 DESCRIPTION
+
+Used in bootstrapping.
+
+=cut
+
+.sub _init_system :init
+
+ .local pmc package
+
+ .PACKAGE(package, "SYSTEM")
+
+ set_global ["PACKAGES"], "SYSTEM", package
+ set_global ["PACKAGES"], "SYS", package
+
+ _init_reader_macros( package )
+
+ .local pmc symbol, nil
+ .NIL(nil)
+
+ .DEFVAR(symbol, package, "*INSIDE-BACKQUOTE*", nil) # not used yet
+ .DEFVAR(symbol, package, "*INSIDE-BACKQUOTE-LIST*", nil) # not used yet
+
+ .DEFUN(symbol, package, "%GET-OBJECT-ATTRIBUTE", "_get_object_attr")
+ .DEFUN(symbol, package, "%SET-OBJECT-ATTRIBUTE", "_set_object_attr")
+
+ .DEFUN(symbol, package, "%MAKE-HASH-TABLE", "_make_hash_table")
+ .DEFUN(symbol, package, "%SET-HASH", "_set_hash")
+ .DEFUN(symbol, package, "%GET-HASH", "_get_hash")
+
+ .DEFUN(symbol, package, "%ALIAS-PACKAGE", "_alias_package")
+ .DEFUN(symbol, package, "%FIND-PACKAGE", "_find_package")
+ .DEFUN(symbol, package, "%PACKAGE-NAME", "_package_name")
+ .DEFUN(symbol, package, "%MAKE-PACKAGE", "_make_package")
+ .DEFUN(symbol, package, "%USE-PACKAGE", "_use_package")
+ .DEFUN(symbol, package, "%EXPORT", "_export")
+
+ .DEFUN(symbol, package, "%OPEN-FILE", "_open_file")
+ .DEFUN(symbol, package, "%PEEK", "_peek")
+ .DEFUN(symbol, package, "%CLOSE", "_close")
+
+ .DEFUN(symbol, package, "%STRING-EQUAL", "_string_equal")
+
+ .DEFUN(symbol, package, "%MAKE-MACRO", "_make_macro")
+
+ # XXX - THESE SHOULD BE REMOVED AND CONVERTED TO PROPER LISP FUNCTIONS
+ .DEFUN(symbol, package, "ERROR", "_raise_error")
+
+ .DEFUN(symbol, package, "LOAD", "_load")
+
+ .return(1)
+.end
+
+
+.sub _init_reader_macros
+
+ .param pmc package
+
+ .local pmc function, reader_macros
+ .HASH(reader_macros)
+
+ .FUNCTION(function, "_left_paren_macro" )
+ reader_macros["("] = function
+
+ .FUNCTION(function, "_right_paren_macro" )
+ reader_macros[")"] = function
+
+ .FUNCTION(function, "_single_quote_macro" )
+ reader_macros["'"] = function
+
+ .FUNCTION(function, "_semicolon_macro" )
+ reader_macros[";"] = function
+
+ .FUNCTION(function, "_double_quote_macro" )
+ reader_macros['"'] = function
+
+ .FUNCTION(function, "_backquote_macro" )
+ reader_macros["`"] = function
+
+ .FUNCTION(function, "_comma_macro" )
+ reader_macros[","] = function
+
+ .FUNCTION(function, "_sharpsign_macro" )
+ reader_macros["#"] = function
+
+ .local pmc symbol
+ .DEFVAR(symbol, package, "*READER-MACROS*", reader_macros)
+
+ .return(1)
+.end
+
+.sub _set_hash
+ .param pmc args
+ .ASSERT_LENGTH(args,3,ERROR_NARGS)
+
+ .local pmc hash
+ .CAR(hash,args)
+ .ASSERT_TYPE(hash, "hash")
+
+ .local pmc key
+ .SECOND(key,args)
+ .ASSERT_TYPE(key, "string")
+
+ .local pmc val
+ .THIRD(val,args)
+
+ .local string key_str
+ key_str = key
+ hash[key_str] = val
+
+ goto DONE
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to %SET-HASH")
+ goto DONE
+
+DONE:
+ .return(val)
+.end
+
+.sub _get_hash
+ .param pmc args
+ .ASSERT_LENGTH(args,2,ERROR_NARGS)
+
+ .local pmc hash
+ .CAR(hash,args)
+ .ASSERT_TYPE(hash, "hash")
+
+ .local pmc key
+ .SECOND(key,args)
+ .ASSERT_TYPE(key, "string")
+
+ .local string key_str
+ key_str = key # Convert the key to a string
+ .local pmc val
+ val = hash[key_str]
+
+ if_null val, NO_VALUE_SET
+
+ goto DONE
+
+NO_VALUE_SET:
+ .NIL(val)
+ goto DONE
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to %GET-HASH")
+ goto DONE
+
+DONE:
+ .return(val)
+.end
+
+.sub _package_name
+ .param pmc args
+ .ASSERT_LENGTH(args, 1, ERROR_NARGS)
+
+ .local pmc pkg
+ .CAR(pkg, args)
+ .ASSERT_TYPE(pkg, "package")
+
+ .local pmc pkgname
+ pkgname = pkg.'_get_name'()
+
+ goto DONE
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to SYS:%PACKAGE-NAME")
+ goto DONE
+
+DONE:
+ .return(pkgname)
+.end
+
+
+.sub _find_package
+ .param pmc args
+ .ASSERT_LENGTH(args, 1, ERROR_NARGS)
+
+ .local pmc pkgname
+ .CAR(pkgname, args)
+ .ASSERT_TYPE(pkgname, "string")
+
+ .local string pkgname_str
+ pkgname_str = pkgname
+ upcase pkgname_str
+
+ push_eh PACKAGE_NOT_FOUND
+ .local pmc retv
+ retv = get_global ["PACKAGES"], pkgname_str
+ if_null retv, PACKAGE_NOT_FOUND
+ pop_eh
+
+ goto DONE
+
+PACKAGE_NOT_FOUND:
+ .NIL(retv)
+ goto DONE
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to %FIND-PACKAGE")
+ goto DONE
+
+DONE:
+ .return(retv)
+.end
+
+.sub _alias_package
+ .param pmc args
+ .ASSERT_LENGTH(args, 2, ERROR_NARGS)
+
+ .local pmc package
+ .CAR(package, args)
+ .ASSERT_TYPE(package, "package")
+
+ .local pmc pkgname
+ .SECOND(pkgname, args)
+ .ASSERT_TYPE(pkgname, "string")
+
+ .local string pkgname_str
+ pkgname_str = pkgname
+ upcase pkgname_str
+
+ set_global ["PACKAGES"], pkgname_str, package
+
+ .local pmc retv
+ .TRUE(retv)
+ goto DONE
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to %ALIAS-PACKAGE")
+ goto DONE
+
+DONE:
+ .return(retv)
+.end
+
+.sub _make_package
+ .param pmc args
+ .ASSERT_LENGTH(args, 1, ERROR_NARGS)
+
+ .local pmc pkgname
+ .CAR(pkgname, args)
+ .ASSERT_TYPE(pkgname, "string")
+
+ .local pmc package
+ .PACKAGE(package, pkgname)
+
+ .local string pkgname_str
+ pkgname_str = pkgname
+ upcase pkgname_str
+
+ set_global ["PACKAGES"], pkgname_str, package
+
+ goto DONE
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to %MAKE-PACKAGE")
+ goto DONE
+
+DONE:
+ .return(package)
+.end
+
+.sub _use_package
+ .param pmc args
+ .local string symnames
+ .local pmc frompkg
+ .local pmc intopkg
+ .local pmc exports
+ .local pmc symname
+ .local pmc symbol
+ .local pmc retv
+ .local pmc i
+
+ .ASSERT_LENGTH(args, 2, ERROR_NARGS)
+
+ .CAR(intopkg, args)
+ .SECOND(frompkg, args)
+
+ .ASSERT_TYPE(intopkg, "package")
+ .ASSERT_TYPE(frompkg, "package")
+
+ exports = frompkg.'_get_exports'()
+
+ iter i, exports
+
+ push_eh DONE
+
+LOOP:
+ shift symname, i
+ symnames = symname
+
+ symbol = frompkg.'_lookup_symbol'(symnames)
+ intopkg.'_import_symbol'(symbol)
+
+ goto LOOP
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to %USE-PACKAGE")
+ goto DONE
+
+DONE:
+ .TRUE(retv)
+ .return(retv)
+.end
+
+.sub _export
+ .param pmc args
+
+ .local string symname
+ .local pmc package
+ .local pmc symbols
+ .local pmc symbol
+ .local pmc retv
+
+ .ASSERT_MINIMUM_LENGTH(args, 1, ERROR_NARGS)
+
+ .CAR(package, args)
+ .ASSERT_TYPE(package, "package")
+
+ .CDR(symbols, args)
+ # TODO: looks like find-package is called twice, problem in eval.pir ?
+ .CDR(symbols, symbols)
+
+LOOP:
+ .NULL(symbols, DONE)
+
+ .CAR(symbol, symbols)
+ .ASSERT_TYPE(symbol, "string")
+
+ symname = symbol
+ package.'_export_symbol'(symname)
+
+ .CDR(symbols, symbols)
+ goto LOOP
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to %EXPORT")
+ goto DONE
+
+DONE:
+ .TRUE(retv)
+ .return(retv)
+.end
+
+.sub _make_hash_table
+ .param pmc args
+ .ASSERT_LENGTH(args,0,ERROR_NARGS)
+
+ .local pmc retv
+ .HASH(retv)
+ goto DONE
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to %MAKE-HASH-TABLE")
+ goto DONE
+
+DONE:
+ .return(retv)
+.end
+
+.sub _raise_error
+ .param pmc args
+ .local string types
+ .local string mesgs
+ .local pmc type
+ .local pmc mesg
+ .local pmc retv
+
+ .ASSERT_LENGTH(args,2,ERROR_NARGS)
+
+ .CAR(type,args)
+ .SECOND(mesg,args)
+
+ .NIL(retv)
+
+ types = type
+ mesgs = mesg
+
+ .ERROR_0(types, mesgs)
+
+ goto DONE
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to %ERROR")
+ goto DONE
+
+DONE:
+ .return(retv)
+.end
+
+.sub _load
+ .param pmc args
+
+ .local string fname1
+ .local pmc stream
+ .local pmc fname2
+ .local pmc farg
+ .local pmc rretv
+ .local pmc eretv
+ .local pmc retv
+ .local pmc fd
+
+ .ASSERT_LENGTH(args, 1,ERROR_NARGS)
+
+ .CAR(fname2,args)
+ fname1 = fname2
+
+ open fd, fname1, "r"
+ unless fd, OPEN_FAILED
+
+ .STREAM(stream, fd)
+ .TRUE(retv)
+
+LOAD_LOOP:
+ .LIST_1(farg,stream)
+ rretv = _read(farg)
+
+ .NULL(rretv, CLEANUP)
+
+ .LIST_1(farg,rretv)
+
+ eretv = _eval(farg)
+
+
+ goto LOAD_LOOP
+
+OPEN_FAILED:
+ .NIL(retv)
+ goto DONE
+
+CLEANUP:
+ close fd
+ .TRUE(retv)
+ goto DONE
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to %LOAD")
+ goto DONE
+
+DONE:
+ .return(retv)
+.end
+
+.sub _get_object_attr
+ .param pmc args
+ .ASSERT_LENGTH(args,3,ERROR_NARGS)
+
+ .local pmc symbol
+ .CAR(symbol,args)
+
+ .local pmc obj_type
+ .SECOND(obj_type,args)
+ .ASSERT_TYPE(obj_type, "string")
+ # TODO: check type of symbol
+
+ .local pmc attr_name
+ .THIRD(attr_name,args)
+ .ASSERT_TYPE(attr_name, "string")
+ .local string attr_name_str
+ attr_name_str = attr_name
+
+ .local pmc retv
+ retv = getattribute symbol, attr_name_str
+ if_null retv, NO_VALUE
+ goto DONE
+
+NO_VALUE:
+ .NIL(retv)
+ goto DONE
+
+ERROR_NARGS:
+ .ERROR_0("program-error","wrong number of arguments to %GET-OBJECT-ATTRIBUTE")
+ goto DONE
+
+DONE:
+ .return(retv)
+.end
+
+.sub _set_object_attr
+ .param pmc args
+ .ASSERT_LENGTH(args,4,ERROR_NARGS)
+
+ .local pmc symbol
+ .CAR(symbol,args)
+
+ .local pmc obj_type
+ .SECOND(obj_type,args)
+ .ASSERT_TYPE(obj_type, "string")
+ # TODO: check type of symbol
+
+ .local pmc attr_name
+ .THIRD(attr_name,args)
+ .ASSERT_TYPE(attr_name, "string")
+ .local string attr_name_str
+ attr_name_str = attr_name
+
+ .local pmc value
+ .FOURTH(value,args)
+
+ setattribute symbol, attr_name_str, value
+ goto DONE
+
+ERROR_NARGS:
+ .ERROR_0("program-error","wrong number of arguments to %SET-SYMBOL-ATTRIBUTE")
+ goto DONE
+
+DONE:
+ .return(value)
+.end
+
+.sub _open_file
+ .param pmc args
+
+ .local string modes
+ .local string names
+ .local pmc stream
+ .local pmc name
+ .local pmc mode
+ .local pmc retv
+ .local int test
+
+ .ASSERT_LENGTH(args,2,ERROR_NARGS)
+
+ .CAR(name, args)
+ .SECOND(mode, args)
+
+ .ASSERT_TYPE(name, "string")
+ .ASSERT_TYPE(mode, "string")
+
+ names = name
+ modes = mode
+
+ open stream, names, modes
+
+ defined test, stream
+ if test != 1 goto FILE_NOT_FOUND
+
+ .STREAM(retv, stream)
+
+ goto DONE
+
+FILE_NOT_FOUND:
+ .ERROR_1("file-error", "error opening file %s", name)
+ goto DONE
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to %OPEN-FILE")
+ goto DONE
+
+DONE:
+ .return(retv)
+.end
+
+.sub _peek
+ .param pmc args
+ .local string char
+ .local pmc stream
+ .local pmc retv
+ .local pmc io
+
+ .ASSERT_LENGTH(args, 1, ERROR_NARGS)
+
+ .CAR(stream, args)
+ .ASSERT_TYPE(stream, "stream")
+
+ io = stream.'_get_io'()
+
+ peek char, io
+ if char == "" goto ERROR_EOF
+
+ .STRING(retv, char)
+
+ goto DONE
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to %PEEK")
+ goto DONE
+
+ERROR_EOF:
+ .ERROR_0("end-of-file", "EOF on input stream reached.")
+ goto DONE
+
+DONE:
+ .return(retv)
+.end
+
+.sub _close
+ .param pmc args
+ .local pmc stream
+ .local pmc retv
+ .local pmc io
+
+ .ASSERT_LENGTH(args, 1, ERROR_NARGS)
+
+ .CAR(stream, args)
+ .ASSERT_TYPE(stream, "stream")
+
+ io = stream.'_get_io'()
+ close io
+
+ .TRUE(retv)
+
+ goto DONE
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to %CLOSE")
+ goto DONE
+
+DONE:
+ .return(retv)
+.end
+
+.sub _string_equal
+ .param pmc args
+ .local string val1
+ .local string val2
+ .local pmc str1
+ .local pmc str2
+ .local pmc retv
+
+ .ASSERT_LENGTH(args, 2, ERROR_NARGS)
+
+ .CAR(str1, args)
+ .SECOND(str2, args)
+
+ .ASSERT_TYPE(str1, "string")
+ .ASSERT_TYPE(str2, "string")
+
+ val1 = str1
+ val2 = str2
+
+ if val1 == val2 goto STRING_EQUAL
+
+ .NIL(retv)
+ goto DONE
+
+STRING_EQUAL:
+ .TRUE(retv)
+ goto DONE
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to %STRING-EQUAL")
+ goto DONE
+
+DONE:
+ .return(retv)
+.end
+
+.sub _make_macro
+ .param pmc args
+ .local int type
+ .local pmc macro
+ .local pmc val
+ .local pmc form
+ .local pmc retv
+
+ .ASSERT_LENGTH(args, 1, ERROR_NARGS)
+
+ .CAR(form, args)
+
+ # XXX - This is pretty hackish - should probably use the __morph method
+
+ macro = new "LispMacro"
+
+ val = form.'_get_args'()
+ macro.'_set_args'(val)
+
+ val = form.'_get_scope'()
+ macro.'_set_scope'(val)
+
+ val = form.'_get_body'()
+ macro.'_set_body'(val)
+
+ goto DONE
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to %MAKE-MACRO")
+ goto DONE
+
+DONE:
+ .return(macro)
+.end
+
+# Local Variables:
+# mode: pir
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:
Added: lisp/trunk/t/arithmetics.t
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ lisp/trunk/t/arithmetics.t Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,60 @@
+# $Id$
+
+=head1 NAME
+
+lisp/t/arithmetics.t - tests for Parrot Common Lisp
+
+=head1 DESCRIPTION
+
+Basic math.
+
+=cut
+
+# pragmata
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/../lib", "$FindBin::Bin/../../../lib";
+
+# core Perl modules
+use Test::More tests => 6;
+
+# Parrot modules
+use Parrot::Test;
+
+language_output_is( 'Lisp', <<'END_CODE', <<'END_OUT', 'addition' );
+( print ( + 1 3 ) )
+END_CODE
+4
+END_OUT
+
+language_output_is( 'Lisp', <<'END_CODE', <<'END_OUT', 'negation' );
+( print ( - 3 ) )
+END_CODE
+-3
+END_OUT
+
+language_output_is( 'Lisp', <<'END_CODE', <<'END_OUT', '1 equals 1' );
+( print ( = 1 1 ) )
+END_CODE
+T
+END_OUT
+
+language_output_is( 'Lisp', <<'END_CODE', <<'END_OUT', '1 does not equal 2' );
+( print ( = 1 2 ) )
+END_CODE
+NIL
+END_OUT
+
+language_output_is( 'Lisp', <<'END_CODE', <<'END_OUT', '2 equals 1+1' );
+( print ( = 2 ( + 1 1 ) ) )
+END_CODE
+T
+END_OUT
+
+language_output_is( 'Lisp', <<'END_CODE', <<'END_OUT', '2 equals 1+1' );
+( print ( mod 11 3 ) )
+END_CODE
+2
+END_OUT
Added: lisp/trunk/t/atoms.t
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ lisp/trunk/t/atoms.t Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,159 @@
+# $Id$
+
+=head1 NAME
+
+lisp/t/atoms.t - tests for atoms in Parrot Common Lisp
+
+=head1 DESCRIPTION
+
+Atoms.
+
+=cut
+
+# pragmata
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/../lib", "$FindBin::Bin/../../../lib";
+
+# core Perl modules
+use Test::More;
+
+# Parrot modules
+use Parrot::Test;
+
+my @test_cases = (
+ [ q{ 0 },
+ 0,
+ q{T},
+ 'integer 0',
+ todo => '0 is still strange',
+ ],
+ [ q{ -0 },
+ -0,
+ q{T},
+ 'integer negative 0',
+ todo => '0 is still strange',
+ ],
+ [ q{ 1 },
+ 1,
+ q{T},
+ 'integer 1'
+ ],
+ [ q{ -1 },
+ -1,
+ q{T},
+ 'integer -1'
+ ],
+ [ q{ 2 },
+ 2,
+ q{T},
+ 'integer 2'
+ ],
+ [ q{ 2 },
+ 2,
+ q{T},
+ 'integer 2'
+ ],
+ [ q{ 123456789 },
+ 123456789,
+ q{T},
+ 'integer 123456789'
+ ],
+ [ q{ -123456789 },
+ -123456789,
+ q{T},
+ 'integer -123456789'
+ ],
+ [ q{ nil },
+ 'NIL',
+ q{T},
+ 'false'
+ ],
+ [ q{ NIL },
+ 'NIL',
+ q{T},
+ 'NIL'
+ ],
+ [ q{ Nil },
+ 'NIL',
+ q{T},
+ 'Nil'
+ ],
+ [ q{ t },
+ 'T',
+ q{T},
+ 'true'
+ ],
+ [ q{ T },
+ 'T',
+ q{T},
+ 'true'
+ ],
+ [ q{ () },
+ 'NIL',
+ q{T},
+ 'empty list is NIL'
+ ],
+ [ q{ (atom 999) },
+ 'T',
+ q{T},
+ 'integer 999 is an atom'
+ ],
+ [ q{ "neunhundertneunundneunzig" },
+ 'neunhundertneunundneunzig',
+ q{T},
+ 'string in double quotes'
+ ],
+ [ q{ " single quote '" },
+ q{ single quote '},
+ q{T},
+ 'string with single quote'
+ ],
+ [ q{ " double quote \"" },
+ q{ double quote "},
+ q{T},
+ 'string with double quote'
+ ],
+ [ q{ " backslash \\\\" },
+ q{ backslash \\},
+ q{T},
+ 'string with backslash'
+ ],
+ [ q{ "" },
+ '',
+ q{T},
+ 'empty string'
+ ],
+ [ q{ " " },
+ ' ',
+ q{T},
+ 'single space'
+ ],
+ [ q{ " a s d f " },
+ ' a s d f ',
+ q{T},
+ 'string with spaces'
+ ],
+ [ q{ (atom ( + 1 2 )) },
+ 'T',
+ q{T},
+ 'result of an addition is an atom'
+ ],
+ [ q{ (atom '( + 1 2 )) },
+ 'NIL',
+ q{T},
+ 'a quoted addition is not an atom'
+ ],
+);
+
+Test::More::plan( tests => 2 * scalar( @test_cases ) );
+
+foreach ( @test_cases )
+{
+ my ( $code, $out, $is_atom, $desc, @other ) = @{ $_ };
+
+ language_output_is( 'Lisp', "( print $code )", $out . "\n", "print $desc", @other );
+ language_output_is( 'Lisp', "( print ( atom $code ))", $is_atom . "\n", "atom: $desc", @other );
+}
Added: lisp/trunk/t/cl.t
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ lisp/trunk/t/cl.t Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,206 @@
+# $Id$
+
+=head1 NAME
+
+lisp/t/cl.t - tests function in COMMON-LISP
+
+=head1 DESCRIPTION
+
+Functions defined in cl.pir.
+
+=cut
+
+# pragmata
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/../lib", "$FindBin::Bin/../../../lib";
+
+# core Perl modules
+use Test::More;
+
+# Parrot modules
+use Parrot::Test;
+
+my @test_cases = (
+ [ q{ ( print *gensym-counter* )
+ },
+ q{1},
+ q{defined var *gensym-counter*},
+ ],
+ [ q{ ( print *package* )
+ },
+ q{#<PACKAGE COMMON-LISP>},
+ q{*package* stringified},
+ ],
+ [ q{ ( print *readtable* )
+ },
+ q{#<READTABLE 0x????????>},
+ q{*readtable* stringified},
+ ],
+ [ q{ ( print *standard-input* )
+ },
+ q{#<IO STREAM>},
+ q{*standard-input* stringified},
+ ],
+ [ q{ ( print *standard-output* )
+ },
+ q{#<IO STREAM>},
+ q{*standard-output* stringified},
+ ],
+ [ q{ (print '(1 2)) },
+ q{(1 . (2 . NIL))},
+ q{quoting a list},
+ ],
+ [ q{ ( setq my_function '+) ( print (boundp 'my_function) ) },
+ q{T},
+ q{boundp on a bound variable},
+ ],
+ [ q{ ( setq my_function '+) ( print (boundp 'your_function) ) },
+ q{NIL},
+ q{boundp on an unbound variable},
+ ],
+ [ q{ ( print ( car ( list 1 2 )) ) },
+ q{1},
+ ],
+ [ q{ ( print ( car ( cons 1 2 )) ) },
+ q{1},
+ ],
+ [ q{( print ( cdr ( list 1 2 )) ) },
+ q{(2 . NIL)},
+ ],
+ [ q{ ( print ( cdr ( cons 1 2 )) ) },
+ q{2},
+ ],
+ [ q{ ( print ( char "asdf" 0 ) ) },
+ q{a},
+ q{first character},
+ todo => 'still cannot pass 0',
+ ],
+ [ q{ ( print ( char "asdf" 1 ) ) },
+ q{s},
+ ],
+ [ q{ ( print ( char "asdf" 3 ) ) },
+ q{f},
+ ],
+ [ q{ ( print ( cons 1 2 ) ) },
+ q{(1 . 2)},
+ ],
+ [ q{ ( print ( cons 1 ( cons 2 3 ) ) ) },
+ q{(1 . (2 . 3))},
+ ],
+ [ q{ ( print ( eq 1 1 ) ) },
+ q{T},
+ q{function eq},
+ todo => 'eq is broken',
+ ],
+ [ q{ ( print ( eval '( + 1 1 ) ) ) },
+ q{2},
+ q{eval an addition},
+ ],
+ [ q{ ( print "How does function work?" ) },
+ q{},
+ q{function},
+ todo => 'test the function function'
+ ],
+ [ q{ ( print ( gensym ) ) },
+ q{G000001},
+ ],
+ [ q{ ( gensym ) ( print *gensym-counter* ) },
+ q{2},
+ ],
+ [ q{ ( gensym )( gensym )( gensym ) ( print *gensym-counter* ) },
+ q{4},
+ ],
+ [ q{ ( if T ( print "T is true" ) ( print "T is false" ) ) },
+ q{T is true},
+ ],
+ [ q{ ( if NIL ( print "NIL is true" ) ( print "NIL is false" ) ) },
+ q{NIL is false},
+ ],
+ [ q{ ( if ( - 3 3 ) ( print "3-3 is true" ) ( print "3-3 is false" ) ) },
+ q{3-3 is true},
+ ],
+ [ q{ ( if ( + 3 3 ) ( print "3+3 is true" ) ( print "3+3 is false" ) ) },
+ q{3+3 is true},
+ ],
+ [ q{ ( "let" ) },
+ q{NIL},
+ q{let not tested yet},
+ todo => 'understand let'
+ ],
+ [ q{ ( print ( list 1 2 ) ) },
+ q{(1 . (2 . NIL))},
+ ],
+ [ q{ ( print ( null nil ) ) },
+ q{T},
+ ],
+ [ q{ ( print ( null 1 ) ) },
+ q{NIL},
+ ],
+ [ q{ ( print ( null ' ( ) ) ) },
+ q{T},
+ ],
+ [ q{ ( print ( null T ) ) },
+ q{NIL},
+ ],
+ [ q{ ( print ( progn 1 ( + 1 1 ) ( + 1 1 1 ) ) ) },
+ q{3},
+ ],
+ [ q{ ( setq asdf 1234 ) ( print asdf ) },
+ q{1234},
+ ],
+ [ q{ ( print ( quote ( + 1 1 ) ) ) },
+ q{(+ . (1 . (1 . NIL)))},
+ ],
+ [ q{ ( print ( quote '1 ) ) },
+ q{(QUOTE . (1 . NIL))},
+ ],
+ [ q{ ( print ( rplaca ( cons 1 2 ) 3 ) ) },
+ q{(3 . 2)},
+ ],
+ [ q{ ( print ( rplacd ( cons 1 2 ) 3 ) ) },
+ q{(1 . 3)},
+ ],
+ [ q{ ( setq asdf 1234 ) ( print asdf ) },
+ q{1234},
+ ],
+ [ q{ ( setq asdf 1234 ) ( print ( type-of asdf ) ) },
+ q{INTEGER},
+ ],
+ [ q{ ( setq asdf 1234 ) ( print ( type-of 'asdf ) ) },
+ q{SYMBOL},
+ ],
+ [ q{ ( print ( type-of ( cons 1 2 ) ) ) },
+ q{CONS},
+ ],
+ [ q{ ( print ( type-of '( cons 1 2 ) ) ) },
+ q{CONS},
+ ],
+ [ q{ ( print ( type-of T ) ) },
+ q{BOOLEAN},
+ q{type-of T},
+ todo => q{sbcl says T is a BOOLEAN}
+ ],
+ [ q{ ( print ( type-of NIL ) ) },
+ q{NULL},
+ q{type-of NIL},
+ todo => q{sbcl says NIL is a NULL}
+ ],
+ [ q{ ( print (values 3 4 5 ) ) },
+ q{3},
+ q{values},
+ todo => 'values is not evaluated',
+ ],
+);
+
+Test::More::plan( tests => scalar @test_cases );
+
+foreach ( @test_cases )
+{
+ my ( $code, $out, $desc, @other ) = @{ $_ };
+
+ $desc ||= substr( $code, 0, 32 );
+ language_output_is( 'Lisp', $code, $out . "\n", $desc, @other );
+}
Added: lisp/trunk/t/function.t
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ lisp/trunk/t/function.t Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,100 @@
+# $Id$
+
+=head1 NAME
+
+lisp/t/function.t - tests the function 'function'
+
+=head1 DESCRIPTION
+
+Needed for 'defun'.
+
+=cut
+
+# pragmata
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/../lib", "$FindBin::Bin/../../../lib";
+
+# core Perl modules
+use Test::More;
+
+# Parrot modules
+use Parrot::Test;
+
+my @test_cases_without_exit_code = (
+ [ q{ ( print (apply ( function +) ( list 1 2)) ) },
+ q{3},
+ q{apply of builtin function},
+ ],
+ [ q{ ( print (funcall ( function +) 1 2) ) },
+ q{3},
+ q{funcall of builtin function},
+ todo => 'no FUNCALL yet'
+ ],
+ [ q{ ( setq my_function '+) ( print (apply my_function ( list 1 2)) ) },
+ q{3},
+ q{apply of setq'd builtin function},
+ ],
+ [ q{ ( setq my_function '+) ( print (funcall my_function 1 2) ) },
+ q{3},
+ q{funcall of setq'd builtin function},
+ todo => 'no FUNCALL yet'
+ ],
+ [ q{ ( print ( function (lambda () ( + 1 5 ) ) ))
+ },
+ q{#<FUNCTION ANONYMOUS>},
+ q{stringification of a function with 0 params },
+ ],
+ [ q{ ( print ( funcall ( function (lambda () ( + 1 5 ) ) ) ) )
+ },
+ q{6},
+ q{funcall a function with 0 params },
+ todo => 'funcall does not work yet'
+ ],
+ [ q{ ( print ( apply ( function (lambda () ( + 1 5 ) ) ) () ) )
+ },
+ q{6},
+ q{apply a function with 0 params },
+ ],
+ [ q{ ( print ( function (lambda ( a b ) ( + a b ) ) ))
+ },
+ q{#<FUNCTION ANONYMOUS>},
+ q{stringification of a function with two params },
+ ],
+ [ q{ ( print ( funcall ( function (lambda (a b) ( + a b ) ) ) 2 40 ) )
+ },
+ q{42},
+ q{funcall a function with 2 params },
+ todo => 'funcall does not work yet'
+ ],
+ [ q{ ( print ( apply ( function (lambda (a b) ( + a b ) ) ) ( list 2 40 ) ) )
+ },
+ q{42},
+ q{apply a function with 2 params },
+ todo => 'apply does not work yet'
+ ],
+);
+
+my @test_cases_with_exit_code = (
+);
+
+Test::More::plan( tests => scalar @test_cases_without_exit_code
+ + scalar @test_cases_with_exit_code );
+
+foreach ( @test_cases_without_exit_code )
+{
+ my ( $code, $out, $desc, @other ) = @{ $_ };
+
+ $desc ||= substr( $code, 0, 32 );
+ language_output_is( 'Lisp', $code, $out . "\n", $desc, @other );
+}
+
+foreach ( @test_cases_with_exit_code )
+{
+ my ( $code, $regex, $desc, @other ) = @{ $_ };
+
+ $desc ||= substr( $code, 0, 32 );
+ language_error_output_like( 'Lisp', $code, $regex, $desc, @other );
+}
Added: lisp/trunk/t/harness
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ lisp/trunk/t/harness Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,10 @@
+#! perl
+
+# $Id$
+
+use strict;
+use warnings;
+
+use lib 'lib', '../../lib';
+
+use Parrot::Test::Harness language => 'lisp';
Added: lisp/trunk/t/hello.t
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ lisp/trunk/t/hello.t Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,30 @@
+# $Id$
+
+=head1 NAME
+
+lisp/t/hello.t - tests for Parrot Common Lisp
+
+=head1 DESCRIPTION
+
+A couple of 'Hello World' tests.
+
+=cut
+
+# pragmata
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/../lib", "$FindBin::Bin/../../../lib";
+
+# core Perl modules
+use Test::More tests => 1;
+
+# Parrot modules
+use Parrot::Test;
+
+language_output_is( 'Lisp', <<'END_CODE', <<'END_OUT', 'hello 1' );
+( print "Hello, World!" )
+END_CODE
+Hello, World!
+END_OUT
Added: lisp/trunk/t/lexicals.t
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ lisp/trunk/t/lexicals.t Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,59 @@
+# $Id$
+
+=head1 NAME
+
+lisp/t/lexicals.t - test lexical variables
+
+=head1 DESCRIPTION
+
+PDD20 compatibility.
+
+=cut
+
+# pragmata
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/../lib", "$FindBin::Bin/../../../lib";
+
+# core Perl modules
+use Test::More;
+
+# Parrot modules
+use Parrot::Test;
+
+my @test_cases_without_exit_code = (
+ [ q{ ( setq a 42 ) ( print a ) },
+ q{42},
+ q{not a lexical},
+ ],
+ # infinity lurking here
+ #[ q{ ( let (( x 2 )) ( print x ) )
+ #},
+ #qr{has no value},
+ #q{no lexicals yet}
+ #],
+);
+
+my @test_cases_with_exit_code = (
+);
+
+Test::More::plan( tests => scalar @test_cases_without_exit_code
+ + scalar @test_cases_with_exit_code );
+
+foreach ( @test_cases_without_exit_code )
+{
+ my ( $code, $out, $desc, @other ) = @{ $_ };
+
+ $desc ||= substr( $code, 0, 32 );
+ language_output_is( 'Lisp', $code, $out . "\n", $desc, @other );
+}
+
+foreach ( @test_cases_with_exit_code )
+{
+ my ( $code, $regex, $desc, @other ) = @{ $_ };
+
+ $desc ||= substr( $code, 0, 32 );
+ language_error_output_like( 'Lisp', $code, $regex, $desc, @other );
+}
Added: lisp/trunk/t/read.t
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ lisp/trunk/t/read.t Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,76 @@
+# $Id$
+
+=head1 NAME
+
+lisp/t/read.t - test reader macros
+
+=head1 DESCRIPTION
+
+Reader macros and their error reporting.
+
+=cut
+
+# pragmata
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/../lib", "$FindBin::Bin/../../../lib";
+
+# core Perl modules
+use Test::More;
+
+# Parrot modules
+use Parrot::Test tests => 7;
+
+language_error_output_like(
+ 'Lisp',
+ " ( \n",
+ qr/EOF on input stream reached\./,
+ '_left_paren_macro() with missing right parenthesis'
+);
+
+language_error_output_like(
+ 'Lisp',
+ " ) something else \n",
+ qr/An object cannot start with/,
+ '_right_paren_macro() without a left paren'
+);
+
+language_output_is(
+ 'Lisp',
+ "(print '( + 2 3 ))",
+ "(+ . (2 . (3 . NIL)))\n",
+ '_single_quote_macro'
+);
+
+language_output_is(
+ 'Lisp',
+ "(print ; Servus \n 1 \n ); comment till end of file",
+ "1\n",
+ '_semicolon_macro'
+);
+
+language_error_output_like(
+ 'Lisp',
+ ' " something else \n',
+ qr/EOF on input stream reached\./,
+ '_double_quote_macro(), no closing double quote'
+);
+
+language_error_output_like(
+ 'Lisp',
+ ' ` something else after backquote',
+ qr/The backquote macro has not yet been implemented\./,
+ '_backquote_macro(), not yet implemented'
+);
+
+language_error_output_like(
+ 'Lisp',
+ ' , something else after comma',
+ qr/Comma is illegal outside of backquote\./,
+ '_comma_macro(), illegal almost everywhere'
+);
+
+
+
Added: lisp/trunk/t/system.t
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ lisp/trunk/t/system.t Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,127 @@
+# $Id$
+
+=head1 NAME
+
+lisp/t/system.t - tests functions in SYSTEM
+
+=head1 DESCRIPTION
+
+Implementations specific functions.
+
+=cut
+
+# pragmata
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/../lib", "$FindBin::Bin/../../../lib";
+
+# core Perl modules
+use Test::More;
+
+# Parrot modules
+use Parrot::Test;
+
+my @test_cases_without_exit_code = (
+ [ q{ ( print (sys:%get-object-attribute '*gensym-counter* "LispSymbol" "name"))
+ },
+ q{*GENSYM-COUNTER*},
+ q{get-object-attribute name},
+ ],
+ [ q{ ( print ( sys:%package-name (sys:%get-object-attribute '*gensym-counter* "LispSymbol" "package")))
+ },
+ q{COMMON-LISP},
+ q{get-object-attribute package},
+ ],
+ [ q{ ( print (sys:%get-object-attribute '*gensym-counter* "LispSymbol" "value"))
+ },
+ q{1},
+ q{get-object-attribute value},
+ ],
+ [ q{ ( sys:%set-object-attribute '*gensym-counter* "LispSymbol" "value" (* 42 2) )
+ ( print (sys:%get-object-attribute '*gensym-counter* "LispSymbol" "value"))
+ },
+ q{84},
+ q{get-object-attribute value},
+ ],
+ [ q{ (setq english_to_german (sys:%make-hash-table))
+ (sys:%set-hash english_to_german "House" "Haus")
+ ( print (sys:%get-hash english_to_german "House" ))
+ },
+ q{Haus},
+ q{make-hash-table set-hash get-hash},
+ ],
+ [ q{ (setq english_to_german (sys:%make-hash-table))
+ (setf (sys:%get-hash "House" table) "Haus")
+ ( print (sys:%get-hash "House" table))
+ },
+ q{Haus},
+ q{hash-table},
+ todo => 'setf not implemented yet'
+ ],
+ [ q{ ( print (sys:%package-name (sys:%find-package "common-lisp")))
+ },
+ q{COMMON-LISP},
+ q{package-name of 'common-lisp' package},
+ ],
+ [ q{ ( print (sys:%package-name (sys:%find-package "cl")))
+ },
+ q{COMMON-LISP},
+ q{package-name of 'cl' package},
+ ],
+ [ q{ ( print ( null (sys:%find-package "common-lisp")))
+ },
+ q{NIL},
+ q{null of find-package "common-lisp"},
+ ],
+ [ q{ ( print ( null (sys:%find-package "un-common-lisp")))
+ },
+ q{T},
+ q{null of find-package "uncommon-lisp"},
+ ],
+ [ q{( sys:%alias-package (sys:%find-package "common-lisp") "un-common-lisp")
+ ( print ( null ( sys:%find-package "un-common-lisp")) )
+ },
+ q{NIL},
+ q{null of find-package "uncommon-lisp" after alias-package},
+ ],
+ [ q{( sys:%alias-package (sys:%find-package "common-lisp") "un-common-lisp")
+ ( print ( sys:%package-name ( sys:%find-package "un-common-lisp")) )
+ },
+ q{COMMON-LISP},
+ q{package-name of find-package "uncommon-lisp" after alias-package},
+ ],
+);
+
+my @test_cases_with_exit_code = (
+ [ q{ ( print SYS:*INSIDE-BACKQUOTE* )
+ },
+ qr{has no value},
+ q{undefined var *INSIDE-BACKQUOTE*},
+ ],
+ [ q{ ( print sys:*inside-backquote-list*)
+ },
+ qr{has no value},
+ q{undefined var *INSIDE-BACKQUOTE-LIST*},
+ ],
+);
+
+Test::More::plan( tests => scalar @test_cases_without_exit_code
+ + scalar @test_cases_with_exit_code );
+
+foreach ( @test_cases_without_exit_code )
+{
+ my ( $code, $out, $desc, @other ) = @{ $_ };
+
+ $desc ||= substr( $code, 0, 32 );
+ language_output_is( 'Lisp', $code, $out . "\n", $desc, @other );
+}
+
+foreach ( @test_cases_with_exit_code )
+{
+ my ( $code, $regex, $desc, @other ) = @{ $_ };
+
+ $desc ||= substr( $code, 0, 32 );
+ language_error_output_like( 'Lisp', $code, $regex, $desc, @other );
+}
Added: lisp/trunk/types.pir
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ lisp/trunk/types.pir Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,771 @@
+# $Id$
+
+=head1 NAME
+
+types.pir - Lisp data types
+
+=head1 subs
+
+=cut
+
+=head2 _init_types
+
+Set up the types.
+
+=cut
+
+.sub _init_types :init
+
+ .local pmc class
+
+ class = subclass "FixedPMCArray", "LispCons"
+
+ class = subclass "Float", "LispFloat"
+
+ class = newclass "LispFunction"
+ addattribute class, "documentation"
+ addattribute class, "args"
+ addattribute class, "body"
+ addattribute class, "name"
+ addattribute class, "scope"
+
+ class = subclass "LispFunction", "LispMacro"
+
+ class = subclass "LispFunction", "LispSpecialForm"
+
+ class = subclass "Hash", "LispHash"
+
+ class = subclass "Integer", "LispInteger"
+
+ class = newclass "LispPackage"
+ addattribute class, "external"
+ addattribute class, "internal"
+ addattribute class, "name"
+
+ class = subclass "Rational", "LispRational"
+
+ class = newclass "LispReadtable"
+ addattribute class, "table"
+ addattribute class, "case"
+
+ class = newclass "LispStream"
+ addattribute class, "stream"
+
+ class = subclass "String", "LispString"
+
+ class = newclass "LispSymbol"
+ addattribute class, "documentation"
+ addattribute class, "function"
+ addattribute class, "name"
+ addattribute class, "package"
+ addattribute class, "special"
+ addattribute class, "value"
+
+ .return ()
+.end
+
+.namespace ["LispCons"]
+
+.sub __init :method
+ self = 2 # a cons cell has two fields, car and cdr
+.end
+
+.sub __get_string :method
+
+ .local pmc retv
+ retv = new 'String'
+ retv = "("
+
+ .local string car
+ car = self[0]
+ concat retv, retv, car
+
+ concat retv, retv, " . "
+
+ .local string cdr
+ cdr = self[1]
+ concat retv, retv, cdr
+
+ concat retv, retv, ")"
+
+ .return(retv)
+.end
+
+.namespace ["LispFunction"]
+
+.sub _get_args :method
+ .local pmc retv
+ retv = getattribute self, "args"
+
+ .return(retv)
+.end
+
+.sub _set_args :method
+ .param pmc args
+
+ setattribute self, "args", args
+
+ .return(args)
+.end
+
+.sub _get_body :method
+ .local pmc retv
+ retv = getattribute self, "body"
+
+ .return(retv)
+.end
+
+.sub _set_body :method
+ .param pmc body
+
+ setattribute self, "body", body
+
+ .return(body)
+.end
+
+.sub _get_name :method
+ .local pmc retv
+ retv = getattribute self, "name"
+
+ .return(retv)
+.end
+
+.sub _set_name :method
+ .param pmc name
+
+ setattribute self, "name", name
+
+ .return(name)
+.end
+
+.sub _get_scope :method
+ .local pmc retv
+
+ retv = getattribute self, "scope"
+
+ .return(retv)
+.end
+
+.sub _set_scope :method
+ .param pmc scope
+
+ setattribute self, "scope", scope
+
+ .return(scope)
+.end
+
+.sub __get_string :method
+ .local pmc retv
+ .local pmc tmps
+
+ .local pmc name
+ name = self.'_get_name'()
+
+ .local int test
+ defined test, name
+ if test goto NAMED_FUNCTION
+
+ name = new 'String'
+ name = "ANONYMOUS"
+
+NAMED_FUNCTION:
+ retv = new 'String'
+ retv = "#<FUNCTION "
+
+ concat retv, retv, name
+
+ tmps = new 'String'
+ tmps = ">"
+ concat retv, retv, tmps
+
+ .return(retv)
+.end
+
+.namespace ["LispHash"]
+
+.sub __get_string :method
+ .local pmc name
+
+ name = new 'String'
+ name = "#S(HASH-TABLE)"
+
+ .return(name)
+.end
+
+.namespace ["LispMacro"]
+
+.sub __get_string :method
+ .local pmc tmps
+
+ .local pmc retv
+ retv = new "LispString"
+ retv = "#<MACRO>"
+
+ .return(retv)
+.end
+
+.namespace ["LispPackage"]
+
+.sub __init :method
+ .local pmc value
+
+ value = new 'Hash'
+ setattribute self, "external", value
+
+ value = new 'Hash'
+ setattribute self, "internal", value
+.end
+
+.sub _lookup_symbol :method
+ .param string name
+
+ .local pmc symbol
+
+ .local pmc hash
+ hash = getattribute self, "internal"
+
+ .local pmc stack
+ stack = hash[name]
+ if_null stack, SYMBOL_NOT_FOUND
+
+ symbol = stack[-1]
+ goto DONE
+
+SYMBOL_NOT_FOUND:
+ null symbol
+ goto DONE
+
+DONE:
+ .return(symbol)
+.end
+
+.sub _import_symbol :method
+ .param pmc symbol
+
+ .local string symname
+ .local pmc stack
+ .local pmc hash
+
+ symname = symbol.'_get_name_as_string'()
+
+ hash = getattribute self, "internal"
+
+ stack = hash[symname]
+
+ if_null stack, CREATE_STACK
+ goto PUSH_SYMBOL
+
+CREATE_STACK:
+ stack = new 'ResizablePMCArray'
+ hash[symname] = stack
+ goto PUSH_SYMBOL
+
+PUSH_SYMBOL:
+ push stack, symbol
+ goto DONE
+
+DONE:
+ .return(symbol)
+.end
+
+.sub _shadow_symbol :method
+ .param string name
+
+ .local pmc symbol
+ .local pmc stack
+ .local pmc hash
+
+ hash = getattribute self, "internal"
+ stack = hash[name]
+
+ symbol = _SYMBOL(name)
+ symbol.'_set_package'(self)
+
+ push stack, symbol
+
+ .return(symbol)
+.end
+
+.sub _unshadow_symbol :method
+ .param string name
+
+ .local pmc hash
+ hash = getattribute self, "internal"
+ .local pmc stack
+ stack = hash[name]
+
+ # delete the currently active symbol
+ .local int size
+ size = stack
+ dec size
+ stack = size
+
+ .return ()
+.end
+
+.sub _get_exports :method
+ .local string keyval
+ .local pmc exports
+ .local pmc hash
+ .local pmc key
+ .local pmc val
+ .local pmc i
+
+ exports = new 'ResizablePMCArray'
+ hash = getattribute self, "external"
+
+ iter i, hash
+ push_eh DONE
+
+LOOP:
+ shift key, i
+
+ keyval = key
+ .STRING(val, keyval)
+
+ push exports, val
+
+ goto LOOP
+
+DONE:
+ .return(exports)
+.end
+
+.sub _export_symbol :method
+ .param string name
+
+ .local pmc external
+ .local pmc internal
+ .local pmc symbol
+ .local pmc stack
+ .local int top
+
+ internal = getattribute self, "internal"
+ external = getattribute self, "external"
+
+ stack = internal[name]
+
+ if_null stack, SYMBOL_NOT_FOUND
+
+ external[name] = stack
+
+ goto DONE
+
+SYMBOL_NOT_FOUND:
+ symbol = self.'_intern_symbol'(name)
+
+ stack = internal[name]
+ external[name] = stack
+
+ goto DONE
+
+DONE:
+ symbol = stack[-1]
+
+ .return(symbol)
+.end
+
+.sub _intern_symbol :method
+ .param string name
+
+ .local pmc symbol
+ .local pmc status
+ .local pmc stack
+ .local pmc hash
+ .local int top
+
+ # the attribute internal has been set up in _init_types
+ hash = getattribute self, "internal"
+ stack = hash[name]
+
+ unless_null stack, DONE
+
+ symbol = _SYMBOL(name)
+
+ stack = new 'ResizablePMCArray'
+ push stack, symbol
+ hash[name] = stack
+
+ goto DONE
+
+DONE:
+ top = stack
+ top = top - 1
+
+ symbol = stack[top]
+
+ .return(symbol)
+.end
+
+.sub _get_name :method
+ .local pmc retv
+ retv = getattribute self, "name"
+
+ .return(retv)
+.end
+
+.sub _set_name :method
+ .param pmc name
+
+ setattribute self, "name", name
+
+ .return(name)
+.end
+
+.sub _get_name_as_string :method
+ .local pmc name
+ name = getattribute self, "name"
+ .local string retv
+ retv = name
+
+ .return(retv)
+.end
+
+.sub __get_string :method
+ .local pmc name
+ name = getattribute self, "name"
+
+ .local pmc retv
+ retv = new 'String'
+
+ .local pmc tmps
+ tmps = new 'String'
+ tmps = "#<PACKAGE "
+ concat retv, tmps, name
+
+ tmps = ">"
+ concat retv, retv, tmps
+
+ .return(retv)
+.end
+
+.namespace ["LispReadtable"]
+
+.sub _get_table :method
+ .local pmc retv
+ retv = getattribute self, "table"
+
+ .return(retv)
+.end
+
+.sub _set_table :method
+ .param pmc table
+
+ setattribute self, "table", table
+
+ .return(table)
+.end
+
+.sub _get_case :method
+ .local pmc retv
+ retv = getattribute self, "case"
+
+ .return(retv)
+.end
+
+.sub _set_case :method
+ .param pmc case
+ setattribute self, "case", case
+
+ .return(case)
+.end
+
+.sub __init :method
+ .local pmc table
+ .local pmc case
+
+ table = new 'Array'
+ table = 128
+
+ table[0] = INVALID_CHAR
+ table[1] = INVALID_CHAR
+ table[2] = INVALID_CHAR
+ table[3] = INVALID_CHAR
+ table[4] = INVALID_CHAR
+ table[5] = INVALID_CHAR
+ table[6] = INVALID_CHAR
+ table[7] = INVALID_CHAR
+ table[8] = CONSTITUENT_CHAR # Backspace
+ table[9] = WHITESPACE_CHAR # Tab
+ table[10] = WHITESPACE_CHAR # Newline
+ table[11] = INVALID_CHAR
+ table[12] = WHITESPACE_CHAR # Page
+ table[13] = WHITESPACE_CHAR # Return
+ table[14] = INVALID_CHAR
+ table[15] = INVALID_CHAR
+ table[16] = INVALID_CHAR
+ table[17] = INVALID_CHAR
+ table[18] = INVALID_CHAR
+ table[19] = INVALID_CHAR
+ table[20] = INVALID_CHAR
+ table[21] = INVALID_CHAR
+ table[22] = INVALID_CHAR
+ table[23] = INVALID_CHAR
+ table[24] = INVALID_CHAR
+ table[25] = INVALID_CHAR
+ table[26] = INVALID_CHAR
+ table[27] = INVALID_CHAR
+ table[28] = INVALID_CHAR
+ table[29] = INVALID_CHAR
+ table[30] = INVALID_CHAR
+ table[31] = INVALID_CHAR
+ table[32] = WHITESPACE_CHAR # Space
+ table[33] = CONSTITUENT_CHAR # !
+ table[34] = TERM_MACRO_CHAR # "
+ table[35] = NTERM_MACRO_CHAR # #
+ table[36] = CONSTITUENT_CHAR # $
+ table[37] = CONSTITUENT_CHAR # %
+ table[38] = CONSTITUENT_CHAR # &
+ table[39] = TERM_MACRO_CHAR # '
+ table[40] = TERM_MACRO_CHAR # (
+ table[41] = TERM_MACRO_CHAR # )
+ table[42] = CONSTITUENT_CHAR # *
+ table[43] = CONSTITUENT_CHAR # +
+ table[44] = TERM_MACRO_CHAR # ,
+ table[45] = CONSTITUENT_CHAR # -
+ table[46] = CONSTITUENT_CHAR # .
+ table[47] = CONSTITUENT_CHAR # /
+ table[48] = CONSTITUENT_CHAR # 0
+ table[49] = CONSTITUENT_CHAR # 1
+ table[50] = CONSTITUENT_CHAR # 2
+ table[51] = CONSTITUENT_CHAR # 3
+ table[52] = CONSTITUENT_CHAR # 4
+ table[53] = CONSTITUENT_CHAR # 5
+ table[54] = CONSTITUENT_CHAR # 6
+ table[55] = CONSTITUENT_CHAR # 7
+ table[56] = CONSTITUENT_CHAR # 8
+ table[57] = CONSTITUENT_CHAR # 9
+ table[58] = CONSTITUENT_CHAR # :
+ table[59] = TERM_MACRO_CHAR # ;
+ table[60] = CONSTITUENT_CHAR # <
+ table[61] = CONSTITUENT_CHAR # =
+ table[62] = CONSTITUENT_CHAR # >
+ table[63] = CONSTITUENT_CHAR # ?
+ table[64] = CONSTITUENT_CHAR # @
+ table[65] = CONSTITUENT_CHAR # A
+ table[66] = CONSTITUENT_CHAR # B
+ table[67] = CONSTITUENT_CHAR # C
+ table[68] = CONSTITUENT_CHAR # D
+ table[69] = CONSTITUENT_CHAR # E
+ table[70] = CONSTITUENT_CHAR # F
+ table[71] = CONSTITUENT_CHAR # G
+ table[72] = CONSTITUENT_CHAR # H
+ table[73] = CONSTITUENT_CHAR # I
+ table[74] = CONSTITUENT_CHAR # J
+ table[75] = CONSTITUENT_CHAR # K
+ table[76] = CONSTITUENT_CHAR # L
+ table[77] = CONSTITUENT_CHAR # M
+ table[78] = CONSTITUENT_CHAR # N
+ table[79] = CONSTITUENT_CHAR # O
+ table[80] = CONSTITUENT_CHAR # P
+ table[81] = CONSTITUENT_CHAR # Q
+ table[82] = CONSTITUENT_CHAR # R
+ table[83] = CONSTITUENT_CHAR # S
+ table[84] = CONSTITUENT_CHAR # T
+ table[85] = CONSTITUENT_CHAR # U
+ table[86] = CONSTITUENT_CHAR # V
+ table[87] = CONSTITUENT_CHAR # W
+ table[88] = CONSTITUENT_CHAR # X
+ table[89] = CONSTITUENT_CHAR # Y
+ table[90] = CONSTITUENT_CHAR # Z
+ table[91] = CONSTITUENT_CHAR # [
+ table[92] = SESCAPE_CHAR # \
+ table[93] = CONSTITUENT_CHAR # ]
+ table[94] = CONSTITUENT_CHAR # ^
+ table[95] = CONSTITUENT_CHAR # _
+ table[96] = TERM_MACRO_CHAR # `
+ table[97] = CONSTITUENT_CHAR # a
+ table[98] = CONSTITUENT_CHAR # b
+ table[99] = CONSTITUENT_CHAR # c
+ table[100] = CONSTITUENT_CHAR # d
+ table[101] = CONSTITUENT_CHAR # e
+ table[102] = CONSTITUENT_CHAR # f
+ table[103] = CONSTITUENT_CHAR # g
+ table[104] = CONSTITUENT_CHAR # h
+ table[105] = CONSTITUENT_CHAR # i
+ table[106] = CONSTITUENT_CHAR # j
+ table[107] = CONSTITUENT_CHAR # k
+ table[108] = CONSTITUENT_CHAR # l
+ table[109] = CONSTITUENT_CHAR # m
+ table[110] = CONSTITUENT_CHAR # n
+ table[111] = CONSTITUENT_CHAR # o
+ table[112] = CONSTITUENT_CHAR # p
+ table[113] = CONSTITUENT_CHAR # q
+ table[114] = CONSTITUENT_CHAR # r
+ table[115] = CONSTITUENT_CHAR # s
+ table[116] = CONSTITUENT_CHAR # t
+ table[117] = CONSTITUENT_CHAR # u
+ table[118] = CONSTITUENT_CHAR # v
+ table[119] = CONSTITUENT_CHAR # w
+ table[120] = CONSTITUENT_CHAR # x
+ table[121] = CONSTITUENT_CHAR # y
+ table[122] = CONSTITUENT_CHAR # z
+ table[123] = CONSTITUENT_CHAR # {
+ table[124] = MESCAPE_CHAR # |
+ table[125] = CONSTITUENT_CHAR # }
+ table[126] = CONSTITUENT_CHAR # ~
+ table[127] = CONSTITUENT_CHAR # Rubout
+
+ case = new 'Boolean'
+ case = 0
+
+ setattribute self, "table", table
+ setattribute self, "case", case
+.end
+
+.sub __get_string :method
+ .local pmc name
+ .local pmc tmps
+ .local pmc retv
+
+ retv = new 'String'
+ retv = "#<READTABLE 0x????????>"
+
+ .return(retv)
+.end
+
+.namespace ["LispStream"]
+
+.sub _get_io :method
+ .local pmc retv
+ retv = getattribute self, "stream"
+
+ .return(retv)
+.end
+
+.sub _set_io :method
+ .param pmc io
+
+ setattribute self, "stream", io
+
+ .return(io)
+.end
+
+.sub __get_string :method
+ .local pmc name
+ name = new 'String'
+ name = "#<IO STREAM>"
+
+ .return(name)
+.end
+
+.namespace ["LispSymbol"]
+
+.sub _get_documentation :method
+ .local pmc retv
+ retv = getattribute self, "documentation"
+
+ .return(retv)
+.end
+
+.sub _set_documentation :method
+ .param pmc docs
+
+ setattribute self, 'documentation', docs
+
+ .return(docs)
+.end
+
+.sub _get_function :method
+ .local pmc retv
+ retv = getattribute self, "function"
+
+ .return(retv)
+.end
+
+.sub _set_function :method
+ .param pmc function
+ setattribute self, 'function', function
+
+ .return(function)
+.end
+
+.sub _get_name :method
+ .local pmc retv
+ retv = getattribute self, 'name'
+
+ .return(retv)
+.end
+
+.sub _set_name :method
+ .param pmc name
+
+ setattribute self, "name", name
+
+ .return(name)
+.end
+
+.sub _get_name_as_string :method
+ .local pmc name
+ name = getattribute self, "name"
+
+ .local string retv
+ retv = name
+
+ .return(retv)
+.end
+
+.sub _get_package :method
+ .local pmc retv
+ retv = getattribute self, "package"
+
+ .return(retv)
+.end
+
+.sub _set_package :method
+ .param pmc package
+ setattribute self, "package", package
+
+ .return(package)
+.end
+
+.sub _get_special :method
+ .local pmc retv
+ retv = getattribute self, "special"
+
+ .return(retv)
+.end
+
+.sub _set_special :method
+ .param pmc special
+ setattribute self, "special", special
+
+ .return(special)
+.end
+
+.sub _get_value :method
+ .local pmc retv
+ retv = getattribute self, "value"
+
+ .return(retv)
+.end
+
+.sub _set_value :method
+ .param pmc value
+
+ setattribute self, "value", value
+
+ .return(value)
+.end
+
+.sub __get_string :method
+ .local pmc name
+ name = getattribute self, "name"
+
+ .return(name)
+.end
+
+.sub __get_bool :method
+ .local pmc retv
+ retv = getprop "defined", self
+
+ .return(retv)
+.end
+
+.namespace []
+
+# Local Variables:
+# mode: pir
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:
Added: lisp/trunk/validate.pir
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ lisp/trunk/validate.pir Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,246 @@
+# $Id$
+
+=head1 NAME
+
+validate.pir - lexing
+
+=cut
+
+.sub _VALIDATE_TOKEN
+ .param string token
+
+ .local string pkgname
+ .local string symname
+ .local pmc package
+ .local pmc symbol
+ .local pmc retv
+ .local int capture
+ .local pmc nil
+
+ # VALID_IN_PARROT_0_2_0 flag = _IS_INTEGER(token)
+ .local pmc is_integer
+ is_integer = get_global 'is_integer'
+ capture = is_integer(token) # attempt to parse token as an integer
+ if capture goto INTEGER
+
+ # VALID_IN_PARROT_0_2_0 flag = _IS_FLOAT(token)
+ .local pmc is_float
+ is_float = get_global 'is_float'
+ capture = is_float(token) # attempt to parse token as a float
+ if capture goto FLOAT
+
+ goto QUALIFIED_SYMBOL # else interpret it as a symbol
+
+INTEGER:
+ .INTEGER(retv,token) # create a LispInteger object
+ goto DONE
+
+FLOAT:
+ .FLOAT(retv,token) # create a ListFloat object
+ goto DONE
+
+QUALIFIED_SYMBOL:
+ # VALID_IN_PARROT_0_2_0 (flag,pkgname,symname) = _IS_QUALIFIED(token)
+ .local pmc is_qualified, capture
+ is_qualified = get_global 'is_qualified'
+ capture = is_qualified(token)
+ unless capture goto SYMBOL
+
+ pkgname = capture[0]
+ symname = capture[1]
+ retv = _LOOKUP_GLOBAL(pkgname, symname)
+ if_null retv, SYMBOL_NOT_FOUND
+ goto DONE
+
+SYMBOL:
+ symbol = _LOOKUP_GLOBAL("COMMON-LISP", "*PACKAGE*")
+ if_null symbol, PACKAGE_NOT_FOUND
+
+ package = symbol.'_get_value'() # Get the current package
+ if_null package, PACKAGE_NOT_FOUND
+
+ pkgname = package.'_get_name_as_string'()
+ symname = token
+
+ retv = _LOOKUP_GLOBAL(pkgname, symname)
+ if_null retv, SYMBOL_NOT_FOUND # If not found, intern a new symbol
+
+ goto DONE
+
+SYMBOL_NOT_FOUND:
+ null nil # Intern a new global symbol
+ retv = _GLOBAL_SYMBOL(pkgname, symname, nil, nil)
+
+ goto DONE
+
+PACKAGE_NOT_FOUND:
+ .ERROR_0("internal-error", "the *PACKAGE* symbol could not be located")
+ goto DONE
+
+DONE:
+ .return(retv)
+.end
+
+# VALID_IN_PARROT_0_2_0 .sub _IS_INTEGER
+# VALID_IN_PARROT_0_2_0 .param string token
+# VALID_IN_PARROT_0_2_0
+# VALID_IN_PARROT_0_2_0 .local int retv
+# VALID_IN_PARROT_0_2_0 .local int ndig
+# VALID_IN_PARROT_0_2_0 .local int idx
+# VALID_IN_PARROT_0_2_0
+# VALID_IN_PARROT_0_2_0 ndig = 0
+# VALID_IN_PARROT_0_2_0 idx = 0
+# VALID_IN_PARROT_0_2_0
+# VALID_IN_PARROT_0_2_0 SIGNS:
+# VALID_IN_PARROT_0_2_0 rx_oneof token, idx, '+-', DIGIT # check for +/- signs (optional)
+# VALID_IN_PARROT_0_2_0 goto DIGIT
+# VALID_IN_PARROT_0_2_0
+# VALID_IN_PARROT_0_2_0 DIGIT: # ensure the rest is all digits
+# VALID_IN_PARROT_0_2_0 rx_is_d token, idx, DECIMAL
+# VALID_IN_PARROT_0_2_0 ndig = ndig + 1
+# VALID_IN_PARROT_0_2_0 goto DIGIT
+# VALID_IN_PARROT_0_2_0
+# VALID_IN_PARROT_0_2_0 DECIMAL:
+# VALID_IN_PARROT_0_2_0 rx_literal token, idx, '.', EOS # Check for an optional decimal point
+# VALID_IN_PARROT_0_2_0 goto EOS
+# VALID_IN_PARROT_0_2_0
+# VALID_IN_PARROT_0_2_0 EOS: # check to see if we're at string end
+# VALID_IN_PARROT_0_2_0 rx_zwa_atend token, idx, FAIL
+# VALID_IN_PARROT_0_2_0 goto MATCH
+# VALID_IN_PARROT_0_2_0
+# VALID_IN_PARROT_0_2_0 MATCH:
+# VALID_IN_PARROT_0_2_0 if ndig == 0 goto FAIL # ensure we had at least one digit
+# VALID_IN_PARROT_0_2_0 retv = 1
+# VALID_IN_PARROT_0_2_0 goto DONE
+# VALID_IN_PARROT_0_2_0
+# VALID_IN_PARROT_0_2_0 FAIL:
+# VALID_IN_PARROT_0_2_0 retv = 0
+# VALID_IN_PARROT_0_2_0 goto DONE
+# VALID_IN_PARROT_0_2_0
+# VALID_IN_PARROT_0_2_0 DONE:
+# VALID_IN_PARROT_0_2_0 .return(retv)
+# VALID_IN_PARROT_0_2_0 .end
+# VALID_IN_PARROT_0_2_0
+# VALID_IN_PARROT_0_2_0 .sub _IS_FLOAT
+# VALID_IN_PARROT_0_2_0 .param string token
+# VALID_IN_PARROT_0_2_0
+# VALID_IN_PARROT_0_2_0 .local int retv
+# VALID_IN_PARROT_0_2_0 .local int idx
+# VALID_IN_PARROT_0_2_0
+# VALID_IN_PARROT_0_2_0 idx = 0
+# VALID_IN_PARROT_0_2_0
+# VALID_IN_PARROT_0_2_0 SIGNS:
+# VALID_IN_PARROT_0_2_0 rx_oneof token, idx, '+-', PREDIGITS # check for +/- signs (optional)
+# VALID_IN_PARROT_0_2_0 goto PREDIGITS
+# VALID_IN_PARROT_0_2_0
+# VALID_IN_PARROT_0_2_0 PREDIGITS: # check for pre-decimal digits
+# VALID_IN_PARROT_0_2_0 rx_is_d token, idx, DECIMAL
+# VALID_IN_PARROT_0_2_0 goto PREDIGITS
+# VALID_IN_PARROT_0_2_0
+# VALID_IN_PARROT_0_2_0 DECIMAL:
+# VALID_IN_PARROT_0_2_0 rx_literal token, idx, '.', FAIL # check for a decimal point
+# VALID_IN_PARROT_0_2_0 goto POSTDIGIT
+# VALID_IN_PARROT_0_2_0
+# VALID_IN_PARROT_0_2_0 POSTDIGIT:
+# VALID_IN_PARROT_0_2_0 rx_is_d token, idx, FAIL # check for at least one required digit
+# VALID_IN_PARROT_0_2_0 goto POSTDIGITS
+# VALID_IN_PARROT_0_2_0
+# VALID_IN_PARROT_0_2_0 POSTDIGITS: # check for option post-decimal digits
+# VALID_IN_PARROT_0_2_0 rx_is_d token, idx, EOS
+# VALID_IN_PARROT_0_2_0 goto POSTDIGITS
+# VALID_IN_PARROT_0_2_0
+# VALID_IN_PARROT_0_2_0 EOS: # check to see if we're at string end
+# VALID_IN_PARROT_0_2_0 rx_zwa_atend token, idx, FAIL
+# VALID_IN_PARROT_0_2_0 goto MATCH
+# VALID_IN_PARROT_0_2_0
+# VALID_IN_PARROT_0_2_0 MATCH:
+# VALID_IN_PARROT_0_2_0 retv = 1
+# VALID_IN_PARROT_0_2_0 goto DONE
+# VALID_IN_PARROT_0_2_0
+# VALID_IN_PARROT_0_2_0 FAIL:
+# VALID_IN_PARROT_0_2_0 retv = 0
+# VALID_IN_PARROT_0_2_0 goto DONE
+# VALID_IN_PARROT_0_2_0
+# VALID_IN_PARROT_0_2_0 DONE:
+# VALID_IN_PARROT_0_2_0 .return(retv)
+# VALID_IN_PARROT_0_2_0 .end
+# VALID_IN_PARROT_0_2_0
+# VALID_IN_PARROT_0_2_0 .sub _IS_QUALIFIED
+# VALID_IN_PARROT_0_2_0 .param string token
+# VALID_IN_PARROT_0_2_0
+# VALID_IN_PARROT_0_2_0 .local string package
+# VALID_IN_PARROT_0_2_0 .local string symbol
+# VALID_IN_PARROT_0_2_0 .local string vchar
+# VALID_IN_PARROT_0_2_0 .local int retv
+# VALID_IN_PARROT_0_2_0 .local int idx1
+# VALID_IN_PARROT_0_2_0 .local int idx2
+# VALID_IN_PARROT_0_2_0 .local int idx3
+# VALID_IN_PARROT_0_2_0 .local int type
+# VALID_IN_PARROT_0_2_0
+# VALID_IN_PARROT_0_2_0 vchar = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789!$%&*<=>?@^_~-./+"
+# VALID_IN_PARROT_0_2_0 idx1 = 0
+# VALID_IN_PARROT_0_2_0
+# VALID_IN_PARROT_0_2_0 PACKAGE:
+# VALID_IN_PARROT_0_2_0 rx_oneof token, idx1, vchar, COLON
+# VALID_IN_PARROT_0_2_0 goto PACKAGE
+# VALID_IN_PARROT_0_2_0
+# VALID_IN_PARROT_0_2_0 COLON:
+# VALID_IN_PARROT_0_2_0 idx2 = idx1 # Index of last valid symbol character
+# VALID_IN_PARROT_0_2_0
+# VALID_IN_PARROT_0_2_0 rx_literal token, idx1, ':', FAIL # If we don't have this -> not qualified
+# VALID_IN_PARROT_0_2_0
+# VALID_IN_PARROT_0_2_0 idx3 = idx1 # Start of symbol character
+# VALID_IN_PARROT_0_2_0 type = 0 # External symbol
+# VALID_IN_PARROT_0_2_0
+# VALID_IN_PARROT_0_2_0 rx_literal token, idx1, ':', SYMBOL # If we don't have this -> not external
+# VALID_IN_PARROT_0_2_0
+# VALID_IN_PARROT_0_2_0 idx3 = idx1 # Start of symbol character
+# VALID_IN_PARROT_0_2_0 type = 1 # Internal symbol
+# VALID_IN_PARROT_0_2_0
+# VALID_IN_PARROT_0_2_0 goto SYMBOL
+# VALID_IN_PARROT_0_2_0
+# VALID_IN_PARROT_0_2_0 SYMBOL:
+# VALID_IN_PARROT_0_2_0 rx_oneof token, idx1, vchar, EOS
+# VALID_IN_PARROT_0_2_0 goto SYMBOL
+# VALID_IN_PARROT_0_2_0
+# VALID_IN_PARROT_0_2_0 EOS:
+# VALID_IN_PARROT_0_2_0 rx_zwa_atend token, idx1, FAIL # check to see if we're at string end
+# VALID_IN_PARROT_0_2_0 goto MATCH
+# VALID_IN_PARROT_0_2_0
+# VALID_IN_PARROT_0_2_0 KEYWORD:
+# VALID_IN_PARROT_0_2_0 package = "KEYWORD"
+# VALID_IN_PARROT_0_2_0 goto KEYWORD_RETURN
+# VALID_IN_PARROT_0_2_0
+# VALID_IN_PARROT_0_2_0 MATCH:
+# VALID_IN_PARROT_0_2_0 idx3 = idx3
+# VALID_IN_PARROT_0_2_0
+# VALID_IN_PARROT_0_2_0 KEYWORD_CHECK1:
+# VALID_IN_PARROT_0_2_0 if idx2 != 0 goto NOT_KEYWORD
+# VALID_IN_PARROT_0_2_0 if idx3 <= 2 goto KEYWORD
+# VALID_IN_PARROT_0_2_0 goto NOT_KEYWORD
+# VALID_IN_PARROT_0_2_0
+# VALID_IN_PARROT_0_2_0 NOT_KEYWORD:
+# VALID_IN_PARROT_0_2_0 substr package, token, 0, idx2
+# VALID_IN_PARROT_0_2_0
+# VALID_IN_PARROT_0_2_0 KEYWORD_RETURN:
+# VALID_IN_PARROT_0_2_0 substr symbol, token, idx3, idx1
+# VALID_IN_PARROT_0_2_0
+# VALID_IN_PARROT_0_2_0 retv = 1
+# VALID_IN_PARROT_0_2_0 goto DONE
+# VALID_IN_PARROT_0_2_0
+# VALID_IN_PARROT_0_2_0 FAIL:
+# VALID_IN_PARROT_0_2_0 package = ""
+# VALID_IN_PARROT_0_2_0 symbol = ""
+# VALID_IN_PARROT_0_2_0 type = 0
+# VALID_IN_PARROT_0_2_0 retv = 0
+# VALID_IN_PARROT_0_2_0 goto DONE
+# VALID_IN_PARROT_0_2_0
+# VALID_IN_PARROT_0_2_0 DONE:
+# VALID_IN_PARROT_0_2_0 .return(retv,package,symbol,type)
+# VALID_IN_PARROT_0_2_0 .end
+
+# Local Variables:
+# mode: pir
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:
Added: ook/trunk/Changes
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ ook/trunk/Changes Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,31 @@
+# $Id$
+
+Revision history for a Ook! compiler written in Parrot and targeting Parrot.
+
+0.2.1 Mi Okt 26 22:59:41 CEST 2005
+ - Make it work on Parrot 0.3.0
+
+0.2.0 Tue Apr 5 20:35:49 CEST 2005
+ - fixed register usage to leave bottom half of register (0->15)
+ for parrot internal use.
+ - make test no longer core dumps.
+
+0.1.0 Thu Feb 19 21:31:28 CET 2004
+ - use of eval to avoid temp file (courtesy of Leopold Toetsch)
+ - updated (after 1 year...) the README to reflect this use of eval
+
+0.0.2 Tue Dec 31 18:02:01 CET 2002
+ - Nicholas Clark reported a bug when there's a complex nesting
+ of while instructions in the ook source. This version fixes
+ it with a brand new scheme of naming the labels in the
+ generated Parrot assembly.
+ - added a test.ook file that illustrates the old bug, and
+ works as Test::Harness expects.
+
+0.0.1 Mon Dec 30 23:46:32 CET 2002
+ - thanks to a silly idea of Nicholas Clark, first draft of this
+ Ook! compiler written in Parrot.
+ - every Ook! instruction is implemented but the "Ook. Ook!"
+ one.
+ - currently spitting Parrot assembly on stdout.
+
Added: ook/trunk/MAINTAINER
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ ook/trunk/MAINTAINER Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,4 @@
+# $Id$
+
+N: Jerome Quelin
+E: jquelin at cpan.org
Added: ook/trunk/README
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ ook/trunk/README Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,59 @@
+# $Id$
+
+DESCRIPTION
+-----------
+This is an Ook! compiler written in Parrot assembly, version 0.1.0
+
+This is a compiler and not an interpreter. This means that the code
+is read, then compiled into Parrot assembly (yes, the target language
+is also Parrot). Then you can fetch the Parrot assembly generated,
+assemble it and interpret it with Parrot just as you would with any
+other Parrot assembly file.
+
+You should compile and test the files with (this will run a hello
+world program):
+
+ $ make test
+
+Then you can compile your Ook! program with:
+
+ $ ../../parrot ook.pbc program.ook
+
+
+FILES
+-----
+The files are the following:
+ ook.pasm well, that's pretty much the whole stuff
+ hello.ook a ook script that greets the world!
+
+
+TODO
+----
+* implement the "Ook. Ook!" instruction
+
+
+AUTHOR
+------
+Jerome Quelin, <jquelin at cpan.org>
+
+
+ACKNOWLEDGEMENTS
+----------------
+I would like to thank:
+* Nicholas Clark for gaving me this crazy idea. He's the one to take
+ the blame for it. Really. :-)
+* Piers Cawley who unwittingly lead me to write it.
+* Dan Sugalski and all the parrot folks (you know who you are) for
+ providing such a nice toy to play with.
+
+
+COPYRIGHT
+---------
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+
+SEE ALSO
+--------
+* http://www.parrotcode.org
+* http://www.dangermouse.net/esoteric/ook.html
Added: ook/trunk/config/makefiles/root.in
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ ook/trunk/config/makefiles/root.in Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,60 @@
+# Copyright (C) 2003-2009, Parrot Foundation.
+# $Id$
+
+# Makefile for languages/ook
+
+# Set up of commands
+PARROT = ../../parrot
+PERL = @perl@
+RM_F = @rm_f@
+RECONFIGURE = $(PERL) @build_dir@/tools/dev/reconfigure.pl
+#CONDITIONED_LINE(darwin):
+#CONDITIONED_LINE(darwin):# MACOSX_DEPLOYMENT_TARGET must be defined for OS X compilation/linking
+#CONDITIONED_LINE(darwin):export MACOSX_DEPLOYMENT_TARGET := @osx_version@
+
+# Set up directories
+BUILD_DIR = @build_dir@
+
+default: all
+
+help :
+ @echo ""
+ @echo "Following targets are available for the user:"
+ @echo ""
+ @echo " build: Create ook.pbc"
+ @echo " This is the default."
+ @echo ""
+ @echo " test: run the test suite,"
+ @echo ""
+ @echo " clean: clean up temporary files"
+ @echo ""
+ @echo " realclean: clean up generated files"
+ @echo ""
+ @echo " help: print this help message"
+
+# regenerate the Makefile
+Makefile: config/makefiles/root.in
+ cd $(BUILD_DIR) && $(RECONFIGURE) --step=gen::languages --languages=ook
+
+all: build
+
+test: build
+ $(PERL) -I../../lib t/harness
+
+build: ook.pasm
+ $(PARROT) -o ook.pbc ook.pasm
+
+clean:
+ $(RM_F) core \
+ "*.pbc" \
+ "*~" \
+ "hello.out" \
+ "foo.p*"
+
+realclean: clean
+ $(RM_F) Makefile
+
+# Local variables:
+# mode: makefile
+# End:
+# vim: ft=make:
Added: ook/trunk/hello.ook
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ ook/trunk/hello.ook Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,20 @@
+Ook. Ook? Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook.
+Ook. Ook. Ook. Ook. Ook! Ook? Ook? Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook.
+Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook? Ook! Ook! Ook? Ook! Ook? Ook.
+Ook! Ook. Ook. Ook? Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook.
+Ook. Ook. Ook! Ook? Ook? Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook?
+Ook! Ook! Ook? Ook! Ook? Ook. Ook. Ook. Ook! Ook. Ook. Ook. Ook. Ook. Ook. Ook.
+Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook! Ook. Ook! Ook. Ook. Ook. Ook. Ook.
+Ook. Ook. Ook! Ook. Ook. Ook? Ook. Ook? Ook. Ook? Ook. Ook. Ook. Ook. Ook. Ook.
+Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook! Ook? Ook? Ook. Ook. Ook.
+Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook? Ook! Ook! Ook? Ook! Ook? Ook. Ook! Ook.
+Ook. Ook? Ook. Ook? Ook. Ook? Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook.
+Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook! Ook? Ook? Ook. Ook. Ook.
+Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook.
+Ook. Ook? Ook! Ook! Ook? Ook! Ook? Ook. Ook! Ook! Ook! Ook! Ook! Ook! Ook! Ook.
+Ook? Ook. Ook? Ook. Ook? Ook. Ook? Ook. Ook! Ook. Ook. Ook. Ook. Ook. Ook. Ook.
+Ook! Ook. Ook! Ook! Ook! Ook! Ook! Ook! Ook! Ook! Ook! Ook! Ook! Ook! Ook! Ook.
+Ook! Ook! Ook! Ook! Ook! Ook! Ook! Ook! Ook! Ook! Ook! Ook! Ook! Ook! Ook! Ook!
+Ook! Ook. Ook. Ook? Ook. Ook? Ook. Ook. Ook! Ook. Ook! Ook? Ook! Ook! Ook? Ook!
+Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook.
+Ook. Ook. Ook. Ook. Ook! Ook.
Added: ook/trunk/ook.pasm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ ook/trunk/ook.pasm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,137 @@
+# $Id$
+
+=head1 NAME
+
+ook.pasm - An implementation of ook in PASM
+
+=cut
+
+# First, read the file.
+ get_params "0", P5
+ set S20, P5[1] # Name of the Ook source.
+ open P20, S20, "r" # P20 = file descriptor
+ set S21, "" # S21 = accumulator
+READ:
+ read S22, P20, 256
+ length I20, S22
+ le I20, 0, EOF
+ concat S21, S22
+ branch READ
+EOF:
+ close P20
+
+# Then, parse it to translate it.
+ length I20, S21 # Total length of file.
+ set I21, 0 # Char number in the file.
+ set I22, 1 # Line number (for error reporting).
+ new P21, 'ResizablePMCArray' # While-level.
+ push P21, 0
+ set S22, "" # Current char.
+ set S23, "" # Current instruction.
+ set S24, "\tnew P20, 'ResizablePMCArray'\n\tset I20,0\n" # Code generated.
+ branch LOOP_END
+LOOP:
+ length I24, S23
+ eq I24, 8, LOOP_CHECK_INSTRUCTION
+ substr S22, S21, I21, 1
+ inc I21
+ eq S22, "\n", LOOP_LINEFEED
+ eq S22, "\t", LOOP_END
+ eq S22, " ", LOOP_END
+ concat S23, S22
+ branch LOOP_END
+
+LOOP_CHECK_INSTRUCTION:
+ ne S23, "Ook.Ook?", LOOP_NOT_MOVER
+ concat S24, "\tinc I20\n"
+ set S23, ""
+ branch LOOP_END
+LOOP_NOT_MOVER:
+ ne S23, "Ook?Ook.", LOOP_NOT_MOVEL
+ concat S24, "\tdec I20\n"
+ set S23, ""
+ branch LOOP_END
+LOOP_NOT_MOVEL:
+ ne S23, "Ook.Ook.", LOOP_NOT_INC
+ concat S24, "\tset I21,P20[I20]\n\tinc I21\n\tset P20[I20],I21\n"
+ set S23, ""
+ branch LOOP_END
+LOOP_NOT_INC:
+ ne S23, "Ook!Ook!", LOOP_NOT_DEC
+ concat S24, "\tset I21,P20[I20]\n\tdec I21\n\tset P20[I20],I21\n"
+ set S23, ""
+ branch LOOP_END
+LOOP_NOT_DEC:
+ ne S23, "Ook!Ook?", LOOP_NOT_WHILE
+ bsr MAKE_LABEL
+ concat S24, "\tbranch OOK"
+ concat S24, S26
+ concat S24, "\nKOO"
+ concat S24, S26
+ concat S24, ":\n"
+ push P21, 0
+ set S23, ""
+ branch LOOP_END
+LOOP_NOT_WHILE:
+ ne S23, "Ook?Ook!", LOOP_NOT_ELIHW
+ pop I25, P21
+ bsr MAKE_LABEL
+ concat S24, "OOK"
+ concat S24, S26
+ concat S24, ":\n\tset I21,P20[I20]\n\tne I21,0,KOO"
+ concat S24, S26
+ concat S24, "\n"
+ pop I27, P21
+ inc I27
+ push P21, I27
+ set S23, ""
+ branch LOOP_END
+LOOP_NOT_ELIHW:
+ ne S23, "Ook!Ook.", LOOP_NOT_PRINT
+ concat S24, "\tset I21,P20[I20]\n\tchr S21,I21\n\tprint S21\n"
+ set S23, ""
+ branch LOOP_END
+LOOP_NOT_PRINT:
+ ne S23, "Ook.Ook!", LOOP_NOT_READ
+ set S23, ""
+ branch LOOP_END
+LOOP_NOT_READ:
+ print "OOK? "
+ print S20
+ print ":"
+ print I22
+ print " "
+ print S23
+ print "\n"
+ end
+LOOP_LINEFEED:
+ inc I22
+ # Fallthru.
+LOOP_END:
+ le I21, I20, LOOP
+ concat S24, "\tset_returns \"()\"\n"
+ concat S24, "\treturncc\n"
+
+# Execute the generated code in S24
+ compreg P1, "PASM"
+ set_args "0", S24
+ get_results "0", P0
+ invokecc P1
+ invokecc P0
+ end
+
+# Given the content of P21, create a label of integers concatenated in S26.
+MAKE_LABEL:
+ set I25, P21
+ set I26, 0
+ set S26, ""
+ branch LABEL_END
+LABEL_LOOP:
+ concat S26, "_"
+ set I27, P21[I26]
+ set S27, I27
+ concat S26, S27
+ inc I26
+LABEL_END:
+ lt I26, I25, LABEL_LOOP
+ ret
Added: ook/trunk/t/basic.t
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ ook/trunk/t/basic.t Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,61 @@
+#! perl
+# $Id$
+
+# Copyright (C) 2005-2007, Parrot Foundation.
+
+=head1 NAME
+
+ook/t/basic.t - testing ook
+
+=head1 SYNOPSIS
+
+ % cd languages && perl ook/t/basic.t
+
+=head1 DESCRIPTION
+
+Test hello.ook.
+
+head1 TODO
+
+test executing test.ook
+
+=cut
+
+use strict;
+use warnings;
+use FindBin;
+use lib "$FindBin::Bin/../../../lib";
+
+use Test::More tests => 1;
+use Parrot::Test ();
+use Parrot::Config qw(%PConfig);
+use File::Spec;
+
+# execute hello.ook
+my $parrot = File::Spec->catfile( File::Spec->updir(), File::Spec->updir(), $PConfig{test_prog} );
+my $ook = $parrot . q{ } . File::Spec->catfile( 'ook.pbc' );
+my $hello_ook = File::Spec->catfile( 'hello.ook' );
+
+# Test running hello.ook
+
+my $out_fn = File::Spec->catfile( 'hello.out' );
+my $cmd = "$ook $hello_ook";
+
+# STDERR is written into same output file
+my $exit_code = Parrot::Test::run_command(
+ $cmd,
+ STDOUT => $out_fn,
+ STDERR => $out_fn,
+);
+
+my $out = Parrot::Test::slurp_file($out_fn );
+is( $out, << 'OUT', 'output from hello.ook' );
+Hello World!
+OUT
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: ook/trunk/t/harness
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ ook/trunk/t/harness Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,30 @@
+# $Id$
+
+=head1 NAME
+
+languages/ook/t/harness - A harness for ook
+
+=head1 SYNOPSIS
+
+ cd languages && perl -I../lib ook/t/harness --files
+
+ cd languages && perl -I../lib ook/t/harness
+
+ cd languages && perl -I../lib ook/t/harness \
+ ook/t/basic.t
+
+=head1 DESCRIPTION
+
+If I'm called with a single
+argument of "--files", I just return a list of files to process.
+This list is one per line, and is relative to the languages dir.
+
+If I'm called with no args, I run the complete suite.
+
+Otherwise I run the tests that were passed on the command line.
+
+=cut
+
+use Parrot::Test::Harness
+ language => 'ook',
+ files => [ 't/*.t' ];
Added: ook/trunk/test.ook
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ ook/trunk/test.ook Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,28 @@
+Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook.
+Ook! Ook? Ook. Ook? Ook. Ook. Ook. Ook? Ook. Ook. Ook? Ook. Ook? Ook.
+Ook! Ook! Ook? Ook! Ook. Ook? Ook! Ook? Ook. Ook? Ook! Ook? Ook. Ook?
+Ook. Ook. Ook. Ook? Ook. Ook. Ook? Ook. Ook? Ook. Ook! Ook! Ook? Ook!
+Ook. Ook? Ook! Ook? Ook? Ook. Ook. Ook. Ook. Ook? Ook! Ook! Ook? Ook!
+Ook? Ook. Ook? Ook. Ook! Ook! Ook? Ook! Ook. Ook? Ook. Ook? Ook. Ook?
+Ook! Ook? Ook? Ook. Ook. Ook. Ook. Ook? Ook. Ook? Ook. Ook. Ook? Ook.
+Ook! Ook! Ook? Ook! Ook. Ook? Ook! Ook! Ook! Ook! Ook! Ook! Ook? Ook.
+Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook.
+Ook. Ook. Ook? Ook. Ook? Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook?
+Ook! Ook. Ook. Ook? Ook. Ook? Ook! Ook. Ook! Ook. Ook? Ook. Ook? Ook.
+Ook! Ook. Ook? Ook. Ook! Ook. Ook. Ook? Ook. Ook? Ook! Ook? Ook. Ook?
+Ook! Ook? Ook. Ook? Ook. Ook. Ook. Ook? Ook. Ook. Ook? Ook. Ook? Ook.
+Ook! Ook! Ook? Ook! Ook. Ook? Ook! Ook? Ook? Ook. Ook. Ook. Ook. Ook?
+Ook! Ook! Ook? Ook! Ook? Ook. Ook? Ook. Ook! Ook! Ook? Ook! Ook. Ook?
+Ook. Ook? Ook. Ook? Ook! Ook! Ook! Ook? Ook? Ook. Ook. Ook. Ook? Ook.
+Ook? Ook. Ook. Ook. Ook. Ook? Ook. Ook? Ook. Ook? Ook! Ook! Ook? Ook!
+Ook? Ook. Ook! Ook. Ook? Ook. Ook? Ook. Ook! Ook! Ook! Ook! Ook! Ook!
+Ook! Ook! Ook! Ook. Ook. Ook? Ook. Ook? Ook. Ook? Ook. Ook. Ook. Ook.
+Ook. Ook. Ook. Ook. Ook. Ook? Ook. Ook. Ook. Ook. Ook. Ook? Ook. Ook.
+Ook. Ook. Ook? Ook. Ook? Ook. Ook! Ook? Ook. Ook? Ook! Ook? Ook. Ook?
+Ook! Ook? Ook. Ook? Ook. Ook. Ook. Ook? Ook. Ook. Ook? Ook. Ook? Ook.
+Ook! Ook! Ook? Ook! Ook. Ook? Ook! Ook? Ook? Ook. Ook. Ook. Ook. Ook?
+Ook! Ook! Ook? Ook! Ook? Ook. Ook? Ook. Ook! Ook! Ook? Ook! Ook. Ook?
+Ook. Ook? Ook. Ook? Ook! Ook? Ook? Ook. Ook? Ook. Ook? Ook. Ook. Ook.
+Ook. Ook? Ook. Ook? Ook. Ook? Ook! Ook! Ook? Ook! Ook? Ook. Ook? Ook.
+Ook? Ook. Ook? Ook. Ook! Ook! Ook? Ook! Ook. Ook? Ook! Ook. Ook? Ook.
+Ook? Ook. Ook? Ook. Ook? Ook. Ook? Ook. Ook! Ook. Ook? Ook. Ook! Ook.
Added: scheme/trunk/MAINTAINER
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ scheme/trunk/MAINTAINER Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,6 @@
+# $Id$
+
+N: Jeffrey Goff
+E: drforr at hargray.com
+
+N: Juergen Boemmels
Added: scheme/trunk/README
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ scheme/trunk/README Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,32 @@
+# $Id$
+
+=head1 NAME
+
+Scheme - an implementation of Scheme on Parrot
+
+=head1 Description
+
+Compile Scheme to PASM.
+
+=head1 Implementation
+
+Lexing is done in Scheme::Tokenizer.
+Parsing is done Scheme::Parser,
+PIR is generated in Scheme::Generator.
+Scheme.pm pulls it all together.
+
+=head1 SEE ALSO
+
+=over 4
+
+=item L<https://trac.parrot.org/parrot/wiki/Languages>
+
+=item L<http://www.schemers.org/>
+
+=item L<http://www.schemers.org/Documents/Standards/R5RS/>
+
+=item L<http://en.wikipedia.org/wiki/Scheme_%28programming_language%29>
+
+=item L<http://www.ccs.neu.edu/home/dorai/t-y-scheme/t-y-scheme.html>
+
+=back
Added: scheme/trunk/config/makefiles/root.in
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ scheme/trunk/config/makefiles/root.in Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,67 @@
+# Copyright (C) 2005-2007, Parrot Foundation.
+# $Id$
+
+# Makefile for languages/scheme
+
+# Set up commands
+PERL = @perl@
+RM_F = @rm_f@
+RECONFIGURE = $(PERL) @build_dir@/tools/dev/reconfigure.pl
+#CONDITIONED_LINE(darwin):
+#CONDITIONED_LINE(darwin):# MACOSX_DEPLOYMENT_TARGET must be defined for OS X compilation/linking
+#CONDITIONED_LINE(darwin):export MACOSX_DEPLOYMENT_TARGET := @osx_version@
+
+# Set up directories
+BUILD_DIR = @build_dir@
+
+# The default target
+default: build
+
+help :
+ @echo ""
+ @echo "Following targets are available for the user:"
+ @echo ""
+ @echo " build: Just check whether 'schemec' compiles"
+ @echo " This is the default."
+ @echo ""
+ @echo " test: run the test suite,"
+ @echo ""
+ @echo " clean: clean up temporary files"
+ @echo ""
+ @echo " realclean: clean up generated files"
+ @echo ""
+ @echo " help: print this help message"
+
+# regenerate the Makefile
+Makefile: config/makefiles/root.in
+ cd $(BUILD_DIR) && $(RECONFIGURE) --step=gen::languages --languages=scheme
+
+# Compilation:
+build:
+ $(PERL) -c schemec
+
+# cleaning up
+
+clean:
+ $(RM_F) foo.pasm foo.pbc \
+ "t/*/*.pasm" \
+ "t/*/*.pir" \
+ "t/*/*.pbc" \
+ "t/*/*.scheme" \
+ "t/*/*.out"
+
+realclean: clean
+ $(RM_F) Makefile
+
+over:
+ @$(MAKE) clean
+ @$(MAKE) all
+
+# testing
+test:
+ cd .. && $(PERL) scheme/t/harness
+
+# Local variables:
+# mode: makefile
+# End:
+# vim: ft=make:
Added: scheme/trunk/lib/Parrot/Test/Scheme.pm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ scheme/trunk/lib/Parrot/Test/Scheme.pm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,72 @@
+# $Id$
+# Copyright (C) 2001-2007, Parrot Foundation.
+
+package Parrot::Test::Scheme;
+
+# pragmata
+use strict;
+use warnings;
+use 5.008;
+
+use Parrot::Config;
+use Parrot::Test;
+
+# Generate output_is(), output_isnt() and output_like() in current package.
+Parrot::Test::generate_languages_functions();
+
+sub new {
+ my $class = shift;
+
+ return bless {}, $class;
+}
+
+
+sub get_cd {
+ my $self = shift;
+ my ( $options ) = @_;
+
+ return $self->{relpath};
+}
+
+sub get_lang_fn {
+ my $self = shift;
+ my ( $count, $options ) = @_;
+
+ return Parrot::Test::per_test( '.scheme', $count );
+}
+
+
+sub get_out_fn {
+ my $self = shift;
+ my ( $count, $options ) = @_;
+
+ return Parrot::Test::per_test( '.out', $count );
+}
+
+sub get_test_prog {
+ my $self = shift;
+ my ( $count, $options ) = @_;
+
+ my $lang_fn = Parrot::Test::per_test( '.scheme', $count );
+ my $pir_fn = Parrot::Test::per_test( '.pir', $count );
+
+ #return "mzscheme -r languages/$lang_fn";
+ return "$PConfig{perl} languages/scheme/schemec languages/$lang_fn > languages/$pir_fn && $self->{parrot} languages/$pir_fn";
+}
+
+# never skip the reference implementation
+sub skip_why {
+ my $self = shift;
+ my ($options) = @_;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: scheme/trunk/lib/Scheme.pm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ scheme/trunk/lib/Scheme.pm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,165 @@
+# $Id$
+# Copyright (C) 2001-2007, Parrot Foundation.
+
+=head1 NAME
+
+Scheme - compile Scheme to PIR
+
+=head1 DESCRIPTION
+
+Compile Scheme.
+
+=head1 SUBROUTINES
+
+=cut
+
+package Scheme;
+
+# pragmata
+use strict;
+use warnings;
+use 5.008;
+
+# core Perl modules
+use Data::Dumper;
+
+# custom modules
+use Scheme::Tokenizer ();
+use Scheme::Parser ();
+use Scheme::Generator ();
+use Scheme::Builtins ();
+
+=head2 new
+
+A constructor.
+
+=cut
+
+sub new {
+ my ( $class, $file ) = @_;
+
+ return bless { file => $file }, $class;
+}
+
+=head2 slurp_source
+
+Read a scheme source file.
+
+=cut
+
+sub slurp_source {
+ my ( $fn ) = @_;
+
+ open my $fh, '<', $fn or die "Can't open $fn: $!";
+ local $/; # Set filehandles to "slurp" mode.
+ my $source = <$fh>;
+ close $fh or die "Can't close $fn: $!";
+
+ return $source;
+
+}
+
+=head2 wrap_source
+
+Put source into an envelope.
+
+ (begin init source)'
+
+=cut
+
+sub wrap_source {
+ my ( $source ) = @_;
+
+ return <<"END_SCHEME";
+(begin
+ (define (newline)
+ (display "\\n"))
+ $source )
+END_SCHEME
+}
+
+=head2 link_functions
+
+Generate PIR.
+Make sure that the used functions end up in the PIR.
+
+=cut
+
+sub link_functions {
+ my ($main) = @_;
+
+ my @function = ($main);
+ my @missing = @{ $main->{functions} };
+ my @provides = keys %{ $main->{scope} };
+
+ my $code = $main->{code};
+ my $header = <<'END_HEADER';
+# PIR generated by schemec.
+
+# for development only
+.include 'library/dumper.pir'
+
+# the .loadlib directive gets run, before the .HLL_map below
+# is parsed, therefore the .DynLexPad constant is already available
+.loadlib "dynlexpad"
+.HLL "SomethingWithScheme", "dynlexpad"
+.HLL_map 'LexPad' = 'DynLexPad'
+
+.sub init__scheme_types :init
+
+ .local pmc class
+ class = subclass "String", "SchemeSymbol"
+.end
+
+
+# builtin functions used by this program:
+END_HEADER
+
+ while (@missing) {
+ my $miss = shift @missing;
+
+ my $link = Scheme::Builtins->generate($miss);
+ $header .= <<"END";
+ # $miss
+END
+
+ push @function, $miss;
+
+ if ( $link->{functions} ) {
+ push @missing, $link->{functions};
+ }
+
+ # XXX: Move Generator::_format_columns to own class
+ Scheme::Generator::_format_columns($link);
+ $code .= $link->{code};
+ }
+
+ return $header . $code;
+}
+
+=head2 compile
+
+This is called in schemec.
+
+=cut
+
+sub compile {
+ my $self = shift;
+
+ my $source = slurp_source( $self->{file} );
+ my $wrapped_source = wrap_source( $source );
+ my $tokenizer = Scheme::Tokenizer->new( $wrapped_source );
+ my $tree = Scheme::Parser::parse( $tokenizer );
+ my $main = Scheme::Generator::generate( $tree );
+
+ return link_functions( $main );
+}
+
+1;
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: scheme/trunk/lib/Scheme/Builtins.pm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ scheme/trunk/lib/Scheme/Builtins.pm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,213 @@
+# $Id$
+# Copyright (C) 2002-2007, Parrot Foundation.
+
+package Scheme::Builtins;
+
+# pragmata
+use strict;
+use warnings;
+use 5.008;
+
+# nice for debugging
+use Data::Dumper;
+
+my %built_ins = (
+ # TODO: reunify 'display' with 'write'
+ display => [
+ [ '', '#', 'Write function' ],
+ [ '', '.sub', 'display' ],
+ [ '', '.param pmc', 'arg1' ],
+ [ '', '.local pmc', 'elem' ],
+ [ '', qw( typeof S0 arg1 ) ],
+ [ '', qw( ne S0 'Undef' IS_NOT_UNDEF ) ],
+ [ '', 'print', '"()"' ],
+ [ '', 'branch', 'write_FINISHED' ],
+ [ 'IS_NOT_UNDEF', 'ne', 'S0', q{'Integer'}, 'IS_NOT_INTEGER' ],
+ [ '', 'print', 'arg1' ],
+ [ '', 'branch', 'write_FINISHED' ],
+ [ 'IS_NOT_INTEGER', 'ne', 'S0', q{'Array'}, 'IS_NOT_ARRAY' ],
+ [ '', '#', '_dumper( arg1 )' ],
+ [ '', 'print', '"("' ],
+ [ 'write_NEXT', qw( set P6 arg1 ) ],
+ [ '', qw( set arg1 P6[0] ) ],
+ [ '', 'write( arg1 )' ],
+ [ '', '#', q{} ],
+ [ '', qw( set arg1 P6[1] ) ],
+ [ '', qw( typeof S0 arg1 ) ],
+ [ '', 'eq', 'S0', q{'Undef'}, 'write_KET' ],
+ [ '', 'ne', 'S0', q{'Array'}, 'write_DOT' ],
+ [ '', 'print', '" "' ],
+ [ '', 'branch', 'write_NEXT' ],
+ [ 'write_DOT', 'print', q{" . "} ],
+ [ '', 'write( arg1 )' ],
+ [ 'write_KET', 'print', '")"' ],
+ [ '', 'branch', 'write_FINISHED' ],
+ [ 'IS_NOT_ARRAY', 'ne', 'S0', q{'Boolean'}, 'IS_NOT_BOOLEAN' ],
+ [ '', 'if', 'arg1', 'write_TRUE' ],
+ [ 'write_FALSE', 'print', q{'#f'} ],
+ [ '', 'branch', 'write_FINISHED' ],
+ [ 'write_TRUE', 'print', q{'#t'} ],
+ [ '', 'branch', 'write_FINISHED' ],
+ [ 'IS_NOT_BOOLEAN', 'ne', 'S0', q{'String'}, 'IS_NOT_STRING' ],
+ [ '', 'print', 'arg1' ],
+ [ '', 'branch', 'write_FINISHED' ],
+ [ 'IS_NOT_STRING', 'ne', 'S0', q{'SchemeSymbol'}, 'IS_NOT_SYMBOL' ],
+ [ '', 'print', 'arg1' ],
+ [ '', 'branch', 'write_FINISHED' ],
+ [ 'IS_NOT_SYMBOL', '' ],
+ [ '', 'print', 'arg1' ],
+ [ '', 'branch', 'write_FINISHED' ],
+ [ 'write_FINISHED', '' ],
+ [ '', '.end' ],
+ ],
+ write => [
+ [ '', '#', 'Write function' ],
+ [ '', '.sub', 'write' ],
+ [ '', '.param pmc', 'arg1' ],
+ [ '', '.local pmc', 'elem' ],
+ [ '', qw( typeof S0 arg1 ) ],
+ [ '', qw( ne S0 'Undef' IS_NOT_UNDEF ) ],
+ [ '', 'print', '"()"' ],
+ [ '', 'branch', 'write_FINISHED' ],
+ [ 'IS_NOT_UNDEF', 'ne', 'S0', q{'Integer'}, 'IS_NOT_INTEGER' ],
+ [ '', 'print', 'arg1' ],
+ [ '', 'branch', 'write_FINISHED' ],
+ [ 'IS_NOT_INTEGER', 'ne', 'S0', q{'Array'}, 'IS_NOT_ARRAY' ],
+ [ '', '#', '_dumper( arg1 )' ],
+ [ '', 'print', '"("' ],
+ [ 'write_NEXT', qw( set P6 arg1 ) ],
+ [ '', qw( set arg1 P6[0] ) ],
+ [ '', 'write( arg1 )' ],
+ [ '', '#', q{} ],
+ [ '', qw( set arg1 P6[1] ) ],
+ [ '', qw( typeof S0 arg1 ) ],
+ [ '', 'eq', 'S0', q{'Undef'}, 'write_KET' ],
+ [ '', 'ne', 'S0', q{'Array'}, 'write_DOT' ],
+ [ '', 'print', '" "' ],
+ [ '', 'branch', 'write_NEXT' ],
+ [ 'write_DOT', 'print', q{" . "} ],
+ [ '', 'write( arg1 )' ],
+ [ 'write_KET', 'print', '")"' ],
+ [ '', 'branch', 'write_FINISHED' ],
+ [ 'IS_NOT_ARRAY', 'ne', 'S0', q{'Boolean'}, 'IS_NOT_BOOLEAN' ],
+ [ '', 'if', 'arg1', 'write_TRUE' ],
+ [ 'write_FALSE', 'print', q{'#f'} ],
+ [ '', 'branch', 'write_FINISHED' ],
+ [ 'write_TRUE', 'print', q{'#t'} ],
+ [ '', 'branch', 'write_FINISHED' ],
+ [ 'IS_NOT_BOOLEAN', 'ne', 'S0', q{'String'}, 'IS_NOT_STRING' ],
+ [ '', 'print', q{'"'} ],
+ [ '', 'print', 'arg1' ],
+ [ '', 'print', q{'"'} ],
+ [ '', 'branch', 'write_FINISHED' ],
+ [ 'IS_NOT_STRING', 'ne', 'S0', q{'SchemeSymbol'}, 'IS_NOT_SYMBOL' ],
+ [ '', 'print', 'arg1' ],
+ [ '', 'branch', 'write_FINISHED' ],
+ [ 'IS_NOT_SYMBOL', '' ],
+ [ '', 'print', 'arg1' ],
+ [ '', 'branch', 'write_FINISHED' ],
+ [ 'write_FINISHED', '' ],
+ [ '', '.end' ],
+ ],
+ apply => [
+ ['# Apply function'],
+ [ 'apply_ENTRY', 'set', 'P0', 'P5' ],
+ [ '', 'set', 'P16', 'P6' ],
+ [ '', 'typeof', 'S16', 'P16' ],
+ [ '', 'set', 'I1', 0 ],
+ [ '', 'set', 'I2', 0 ],
+ [ '', 'eq', 'S16', q{'Undef'}, 'apply_CALL' ],
+ [ '', 'set', 'P5', 'P16[0]' ],
+ [ '', 'bsr', 'apply_HELP' ],
+ [ '', 'eq', 'S16', q{'Undef'}, 'apply_CALL' ],
+ [ '', 'set', 'P6', 'P16[0]' ],
+ [ '', 'bsr', 'apply_HELP' ],
+ [ '', 'eq', 'S16', q{'Undef'}, 'apply_CALL' ],
+ [ '', 'set', 'P7', 'P16[0]' ],
+ [ '', 'bsr', 'apply_HELP' ],
+ [ '', 'eq', 'S16', q{'Undef'}, 'apply_CALL' ],
+ [ '', 'set', 'P8', 'P16[0]' ],
+ [ '', 'bsr', 'apply_HELP' ],
+ [ '', 'eq', 'S16', q{'Undef'}, 'apply_CALL' ],
+ [ '', 'set', 'P9', 'P16[0]' ],
+ [ '', 'bsr', 'apply_HELP' ],
+ [ '', 'eq', 'S16', q{'Undef'}, 'apply_CALL' ],
+ [ '', 'set', 'P10', 'P16[0]' ],
+ [ '', 'bsr', 'apply_HELP' ],
+ [ '', 'eq', 'S16', q{'Undef'}, 'apply_CALL' ],
+ [ '', 'set', 'P11', 'P16[0]' ],
+ [ '', 'bsr', 'apply_HELP' ],
+ [ '', 'eq', 'S16', q{'Undef'}, 'apply_CALL' ],
+ [ '', 'set', 'P12', 'P16[0]' ],
+ [ '', 'bsr', 'apply_HELP' ],
+ [ '', 'eq', 'S16', q{'Undef'}, 'apply_CALL' ],
+ [ '', 'set', 'P13', 'P16[0]' ],
+ [ '', 'bsr', 'apply_HELP' ],
+ [ '', 'eq', 'S16', q{'Undef'}, 'apply_CALL' ],
+ [ '', 'set', 'P14', 'P16[0]' ],
+ [ '', 'bsr', 'apply_HELP' ],
+ [ '', 'eq', 'S16', q{'Undef'}, 'apply_CALL' ],
+ [ '', 'set', 'P15', 'P16[0]' ],
+ [ '', 'bsr', 'apply_HELP' ],
+ [ '', 'eq', 'S16', q{'Undef'}, 'apply_CALL' ],
+ [ '', 'set', 'P17', 'P16' ],
+ [ 'apply_COUNT', 'ne', 'S16', q{'Undef'}, 'apply_ARRAY' ],
+ [ '', 'inc', 'I2' ],
+ [ '', 'set', 'P17', 'P17[1]' ],
+ [ '', 'typeof', 'S16', 'P17' ],
+ [ '', 'branch', 'apply_COUNT' ],
+ [ 'apply_ARRAY', qw( new P3 'Array' ) ],
+ [ '', 'set', 'P3', 'I2' ],
+ [ '', 'set', 'I16', 0 ],
+ [ 'apply_ITER', 'set', 'P3[I16]', 'P16[0]' ],
+ [ '', 'set', 'P16', 'P16[1]' ],
+ [ '', 'inc', 'I16' ],
+ [ '', 'ne', 'I16', 'I2', 'apply_ITER' ],
+ [ 'apply_CALL', 'set', 'I0', 0 ],
+ [ '', 'invoke' ],
+ [ 'apply_HELP', 'P16', 'P16[1]' ],
+ [ '', 'inc', 'I1' ],
+ [ '', 'typeof', 'S16', 'P16' ],
+ [ '', 'ret' ],
+ ],
+);
+
+sub new {
+ my $class = shift;
+
+ my $self = { instruction => [] };
+
+ return bless $self, $class;
+}
+
+sub _add_inst {
+ my $self = shift;
+
+ push @{ $self->{instruction} }, [@_];
+
+ return;
+}
+
+sub generate {
+ my ( $code, $name ) = @_;
+
+ die "$name: Unknown builtin\n" unless exists $built_ins{$name};
+
+ my $self = Scheme::Builtins->new();
+
+ foreach ( @{ $built_ins{$name} } ) {
+ my ( $label, $op, @args ) = @{$_};
+ $self->_add_inst( $label, $op, [@args] );
+ }
+
+ return $self;
+}
+
+1;
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: scheme/trunk/lib/Scheme/Generator.pm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ scheme/trunk/lib/Scheme/Generator.pm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,2279 @@
+# $Id$
+# Copyright (C) 2001-2007, Parrot Foundation.
+
+package Scheme::Generator;
+
+# pragmata
+use strict;
+use warnings;
+use 5.008;
+
+use Carp;
+use Data::Dumper;
+use Scheme::Builtins;
+
+our $VERSION = '0.01';
+
+sub _gensym {
+ return sprintf "G%04d", shift->{gensym}++;
+}
+
+sub _add_inst {
+ my $self = shift;
+
+ push @{ $self->{instruction} }, [@_];
+
+ return;
+}
+
+sub _add_comment {
+ my $self = shift;
+ my $comment = shift;
+
+ return
+ $self->_add_inst( '', '#', [ $comment ] );
+}
+
+sub _new_regs {
+ return [ (0) x 32 ];
+}
+
+sub _save_set {
+ my $self = shift;
+
+ $self->_add_comment( 'start of _save_set()' );
+
+ foreach ( grep { $self->{regs}->[$_] } ( 0 .. 31 ) ) {
+ $self->_add_inst( '', 'save', ["P$_"] )
+ }
+
+ $self->_add_comment( 'end of _save_set()' );
+
+ return;
+}
+
+# Save a single PMC register on the stack.
+# Mark it only in $self->{regs}, let _save_set() emit the PIR
+sub _save_1 {
+ my $self = shift;
+
+ my $temp;
+ for ( 0 .. 31 ) {
+ next if $self->{regs}->[$_]; # find first unsaved register
+
+ $temp = "P$_";
+ $self->{regs}->[$_] = 1;
+ last;
+ }
+
+ return $temp;
+}
+
+# say that a register should not be saved by _save_set()
+sub _restore {
+ my $self = shift;
+
+ foreach ( grep { $_ ne 'none' } @_ ) {
+ my ( $reg_num ) = m/^P(\d+)/;
+ die 'Missing register type' unless defined $reg_num;
+
+ $self->{regs}->[$reg_num] = 0;
+ }
+
+ return;
+}
+
+sub _restore_set {
+ my $self = shift;
+
+ $self->_add_comment( 'start of _restore_set()' );
+
+ foreach ( grep { $self->{regs}->[$_] } ( 31 .. 0 ) ) {
+ $self->_add_inst( '', 'restore', [ "P$_" ] );
+ }
+
+ $self->_add_comment( 'end of _restore_set()' );
+
+ return;
+}
+
+sub _check_num_args {
+ my ( $node, $expected, $name ) = @_;
+
+ my $num_args = _get_num_args( $node );
+
+ if ( my ( $min ) = $expected =~ m/ \A \s* >= \s* (\d+) /xms ) {
+ my $plural = $min == 1 ? q{} : 's';
+ confess "$name: expects at least $min argument$plural, given $num_args\n"
+ unless $num_args >= $min;
+ }
+ else {
+ confess "$name: Wrong number of arguments (expected $expected, got $num_args).\n"
+ unless $num_args == $expected;
+ }
+}
+
+sub _get_num_args {
+ my ( $node ) = @_;
+
+ return
+ defined $node->{children} ? @{ $node->{children} } - 1 : 0;
+}
+
+sub _get_arg {
+ my ( $node, $num ) = @_;
+
+ return $node->{children}->[$num];
+}
+
+# first child is the function, the args are after that
+sub _get_args {
+ my ( $node, $num ) = @_;
+ $num = 1 unless defined $num;
+
+ return splice @{ $node->{children} }, $num;
+}
+
+# until there is a working find_lex/store_lex
+sub _find_lex {
+ my ( $self, $symbol ) = @_;
+
+ my $return_reg = $self->_save_1();
+ $self->_add_inst( '', 'find_lex', [ $return_reg, qq{"$symbol"} ] );
+
+ return $return_reg;
+}
+
+sub _find_name {
+ my ( $self, $symbol ) = @_;
+
+ my $return = $self->_save_1();
+ $self->_add_inst( '', 'find_name', [ $return, qq{"$symbol"} ] );
+
+ return $return;
+}
+
+sub _store_lex {
+ my ( $self, $symbol, $value ) = @_;
+
+ return $self->_add_inst( '', 'store_lex', [ qq{"$symbol"}, $value ] );
+}
+
+sub _new_lex {
+ my ( $self, $symbol, $value ) = @_;
+
+ $self->_add_comment( 'start of _new_lex' );
+
+ $self->_add_inst( '', 'store_lex', [ qq{"$symbol"}, $value ] );
+ $self->{scope}->{$symbol} = $value;
+
+ $self->_add_comment( 'end of _new_lex' );
+
+ return;
+}
+
+sub _new_pair {
+ my ($self) = @_;
+
+ my $return = $self->_save_1();
+
+ $self->_add_inst( '', 'new', [ $return, q{'Array'} ] );
+ $self->_add_inst( '', 'set', [ $return, 2 ] );
+
+ return $return;
+}
+
+sub _constant {
+ my ( $self, $value, $type ) = @_;
+
+ $self->_add_comment( 'start of _constant()' );
+ my ( $pmc_type );
+
+ my %type_mapping = (
+ COMPLEX => 'Complex',
+ INTEGER => 'Integer',
+ REAL => 'Float',
+ STRING => 'String',
+ );
+
+ if ( ! defined $value ) { # an empty list
+ $pmc_type = 'Undef';
+ }
+ elsif ( defined $type
+ && exists $type_mapping{$type} ) {
+ # type info from lexer
+ $pmc_type = $type_mapping{$type};
+ if ( $pmc_type eq 'Complex' ) {
+ $value = qq{"$value"};
+ }
+ }
+ elsif ( $value eq '#t' || $value eq '#f' ) {
+ $pmc_type = 'Boolean';
+ $value = $value eq '#t' ? '1' : '0';
+ }
+ else { # default 0
+ $pmc_type = 'Integer';
+ $value = 0;
+ }
+
+ my $return = $self->_save_1();
+ $self->_add_inst( '', 'new', [ $return, qq{'$pmc_type'} ] );
+ $self->_add_inst( '', 'set', [ $return, $value ] ) if defined $value;
+
+ $self->_add_comment( "returning $return from _constant()" );
+
+ return $return;
+}
+
+sub _morph {
+ my ( $self, $to, $from ) = @_;
+
+ $self->_add_comment( 'start of _morph' );
+
+ if ( $to && $from && $to =~ m/ \A P /xms && $from =~ m/ \A P /xms ) {
+ $self->_add_inst( '', 'clone', [ $to, $from ] );
+ }
+ else {
+ die "Only PMCs can be morphed";
+ }
+
+ $self->_add_comment( 'end of _morph' );
+
+ return;
+}
+
+#---- Section 4 ----
+
+sub __quoted {
+ my ( $self, $node, $return, $special ) = @_;
+
+ if ( exists $node->{value} ) {
+ my $value = $node->{value};
+ if ( ! defined $value ) {
+ $self->_add_inst( '', 'new', [ $return, q{'Undef'} ] );
+ }
+ elsif ( $value =~ m/ \A [-+]? \d+ \z/xms ) {
+ $self->_add_inst( '', 'new', [ $return, q{'Integer'} ] );
+ $self->_add_inst( '', 'set', [ $return, $value ] );
+ }
+ elsif ( $value =~ /^[-+]?((\d+\.\d*)|(\.d+))([eE][-+]?\d+)?$/ ) {
+ $self->_add_inst( '', 'new', [ $return, q{'Float'} ] );
+ $self->_add_inst( '', 'set', [ $return, $value ] );
+ }
+ else { # assume its a symbol
+ $self->_add_inst( '', 'new', [ $return, q{'SchemeSymbol'} ] );
+ $self->_add_inst( '', 'set', [ $return, qq{"$value"} ] );
+ }
+ }
+ elsif ( exists $node->{children} ) {
+ my $children = $node->{children};
+
+ $self->_add_inst( '', 'new', [ $return, q{'Undef'} ] );
+ for ( reverse @$children ) {
+ if ( exists $_->{children} ) {
+ my $arg0 = _get_arg( $_, 0 );
+ if ( exists $arg0->{value} ) {
+ my $value = $arg0->{value};
+ if ( exists $special->{$value} ) {
+ _check_num_args( $_, 1 );
+ $special->{$value}->( $self, _get_arg( $_, 1 ), $return );
+ next;
+ }
+ }
+ }
+ my $item = $self->_save_1();
+
+ __quoted( $self, $_, $item, $special );
+
+ my $pair = $self->_new_pair();
+
+ $self->_add_inst( '', 'set', [ $pair . '[0]', $item ] );
+ $self->_add_inst( '', 'set', [ $pair . '[1]', $return ] );
+ $self->_add_inst( '', 'set', [ $return, $pair ] );
+ $self->_restore( $item, $pair );
+ }
+ }
+
+ return $return;
+}
+
+sub _op_quote {
+ my ( $self, $node ) = @_;
+
+ my $return = $self->_save_1();
+
+ _check_num_args( $node, 1, 'quote' );
+
+ my $item = _get_arg( $node, 1 );
+
+ return __quoted( $self, $item, $return, {} );
+}
+
+sub _op_quasiquote {
+ my ( $self, $node ) = @_;
+
+ my $return = $self->_save_1();
+ my $special = {
+ unquote => \&_qq_unquote,
+ 'unquote-splicing' => \&_qq_unquote_splicing
+ };
+
+ _check_num_args( $node, 1, 'quote' );
+
+ my $item = _get_arg( $node, 1 );
+
+ return __quoted( $self, $item, $return, $special );
+}
+
+# helper functions for quasiquote
+
+sub _qq_unquote {
+ my ( $self, $node, $return ) = @_;
+
+ my $item = $self->_generate($node);
+
+ my $pair = $self->_new_pair();
+ $self->_add_inst( '', 'set', [ $pair . '[0]', $item ] );
+ $self->_add_inst( '', 'set', [ $pair . '[1]', $return ] );
+ $self->_add_inst( '', 'set', [ $return, $pair ] );
+ $self->_restore( $item, $pair );
+
+ return $return;
+}
+
+sub _qq_unquote_splicing {
+ my ( $self, $node, $return ) = @_;
+
+ my $list = $self->_generate($node);
+
+ my $head = $self->_save_1();
+ my $label = $self->_gensym;
+
+ # check for empty list
+ $self->_branch_if_type( $list, 'Undef', "DONE_$label" );
+
+ my $copy = $self->_new_pair();
+
+ $self->_add_inst( '', 'set', [ $head, $copy ] );
+
+ # maybe ensure that $type is a pair here
+ my $temp = $self->_save_1();
+ $self->_add_inst( "ITER_$label", 'set', [ $temp, $list . '[0]' ] );
+ $self->_add_inst( '', 'set', [ $copy . '[0]', $temp ] );
+ $self->_restore($temp);
+
+ $self->_add_inst( '', 'set', [ $list, $list . '[1]' ] );
+ $self->_branch_if_type( $list, 'Undef', "FINISH_$label" );
+
+ $temp = $self->_new_pair();
+ $self->_add_inst( '', 'set', [ $copy . '[1]', $temp ] );
+ $self->_add_inst( '', 'set', [ $copy, $temp ] );
+ $self->_add_inst( '', 'branch', ["ITER_$label"] );
+ $self->_restore($temp);
+
+ # append the rest to the end of list
+ $self->_add_inst( "FINISH_$label", 'set', [ $copy . '[1]', $return ] );
+ $self->_add_inst( '', 'set', [ $return, $head ] );
+ $self->_add_inst("DONE_$label");
+
+ $self->_restore( $list, $copy, $head );
+
+ return $return;
+}
+
+sub _op_lambda {
+ my ( $self, $node ) = @_;
+
+ $self->_add_comment( 'start of _op_lambda()' );
+
+ my $sub_name
+ = join( q{_}, 'LAMBDA', $self->_gensym() );
+
+ my $sub_reg = $self->_save_1();
+ my $return = $self->_save_1();
+
+ $self->_add_inst( '', '.const', [ qq{.Sub $sub_reg = "$sub_name"} ] );
+ $self->_add_inst( '', 'newclosure', [ $return, $sub_reg ] );
+
+ # caller saved => start a new frame
+ push @{ $self->{frames} }, $self->{regs};
+ $self->{regs} = _new_regs();
+
+ # expand the lexical scope
+ my $oldscope = $self->{scope};
+ $self->{scope} = { '*UP*' => $oldscope };
+
+ # lambda body
+ # Another ugly hack. Move the generated code to 'lambda_instructions'
+ $self->_add_comment( "start: body of lambda is in $sub_name" );
+ my $ins_count = scalar @{ $self->{instruction} };
+ $self->_add_inst( '', '' );
+
+ $self->_add_comment( 'generated for lambda' );
+ my $outer = $self->{outer}->[-1];
+ $self->_add_inst( '', '.sub', [ qq{$sub_name :outer('$outer') :lex} ] );
+ push @{ $self->{outer} }, $sub_name;
+
+ # loop over parameters
+ my $cnt = 0;
+ my @store_lex;
+ for ( @{ _get_arg( $node, 1 )->{children} } ) {
+ my $param_name = "param_$cnt";
+ $self->_add_inst( '', '.param pmc', [ $param_name ] );
+ push @store_lex, [ '', '.lex', [ "\"$_->{value}\"", $param_name ]];
+ $cnt++;
+ }
+ foreach ( @store_lex ) {
+ $self->_add_inst( @{$_} );
+ }
+
+ # generate code for the body
+ my $temp = 'none';
+ for ( _get_args( $node, 2 ) ) {
+ $self->_restore($temp);
+ $temp = $self->_generate($_);
+ }
+
+ $self->_add_inst( '', 'set_returns', [ q{"0"}, $temp ] );
+
+ $self->_add_inst( '', '.end' );
+ unshift @{ $self->{lambda_instructions} }, splice @{ $self->{instruction} }, $ins_count;
+ $self->_add_comment( "end: body of lambda is in $sub_name" );
+
+ $self->{regs} = pop @{ $self->{frames} };
+ $self->{scope} = $self->{scope}->{'*UP*'};
+ pop @{ $self->{outer} };
+
+ $self->_add_comment( 'end of _op_lambda()' );
+
+ return $return;
+}
+
+sub _op_if {
+ my ( $self, $node ) = @_;
+
+ $self->_add_comment( 'start of _op_if()' );
+
+ my $label = $self->_gensym();
+
+ my $cond = $self->_generate( _get_arg( $node, 1 ) );
+ $self->_branch_unless_type( $cond, 'Boolean', "TRUE_$label" );
+ $self->_add_inst( '', "unless $cond goto FALSE_$label" );
+ $self->_add_inst("TRUE_$label");
+ $self->_restore($cond);
+ my $return = $self->_save_1();
+
+ my $true = $self->_generate( _get_arg( $node, 2 ) );
+ $self->_morph( $return, $true );
+ $self->_add_inst( '', 'branch', ["DONE_$label"] );
+ $self->_restore($true);
+
+ $self->_add_inst("FALSE_$label");
+ my $false = $self->_generate( _get_arg( $node, 3 ) );
+ $self->_morph( $return, $false );
+ $self->_restore($false);
+
+ $self->_add_inst("DONE_$label");
+ $self->_add_comment( "returning $return from _op_if()" );
+
+ return $return;
+}
+
+sub _op_define {
+ my ( $self, $node ) = @_;
+
+ $self->_add_comment( 'start of _op_define()' );
+
+ _check_num_args( $node, 2, 'define' );
+
+ my ( $symbol, $lambda );
+
+ if ( exists _get_arg( $node, 1 )->{children} ) {
+ ( $symbol, my @formals ) = @{ _get_arg( $node, 1 )->{children} };
+ $symbol = $symbol->{value};
+ $lambda =
+ { children =>
+ [ { value => 'lambda' }, { children => [@formals] }, _get_args( $node, 2 ) ] };
+ }
+ else {
+ $symbol = _get_arg( $node, 1 )->{value};
+ $lambda = _get_arg( $node, 2 );
+ }
+
+ if ( exists $self->{scope}->{$symbol} ) {
+ die "define: $symbol is already defined\n";
+ }
+ else {
+ $self->{scope}->{$symbol} = '*unknown*';
+ }
+
+ my $value = $self->_generate($lambda);
+
+ if ( $value !~ m/^P/ ) {
+ my $pmc = $self->_save_1();
+ $self->_morph( $pmc, $value );
+ $self->_restore($value);
+ $value = $pmc;
+ }
+
+ $self->_new_lex( $symbol, $value );
+
+ $self->_add_comment( 'end of _op_define()' );
+
+ return $value;
+}
+
+sub _op_set_bang {
+ my ( $self, $node ) = @_;
+
+ _check_num_args( $node, 2, 'set!' );
+
+ my $symbol = _get_arg( $node, 1 )->{value};
+ my $temp = $self->_generate( _get_arg( $node, 2 ) );
+ if ( $temp !~ /^P/ ) {
+ my $pmc = $self->_save_1();
+ $self->_morph( $pmc, $temp );
+ $self->_restore($temp);
+ $temp = $pmc;
+ }
+ $self->_store_lex( $symbol, $temp );
+
+ return $temp;
+}
+
+sub _op_cond {
+ my ( $self, $node ) = @_;
+
+ my @clauses = _get_args($node);
+
+ my $transnode;
+
+ if ( $clauses[-1]->{children}->[0]->{value} eq 'else' ) {
+ my $elseclause = pop @clauses;
+ $transnode = { children => [ { value => 'begin' }, _get_args($elseclause) ] };
+ }
+ else {
+ $transnode = { value => '#f' };
+ }
+
+ for my $clause ( reverse @clauses ) {
+ $transnode = {
+ children => [
+ { value => 'if' },
+ _get_arg( $clause, 0 ),
+ { children => [ { value => 'begin' }, _get_args( $clause, 1 ) ] }, $transnode
+ ]
+ };
+ }
+
+ return $self->_generate($transnode);
+}
+
+sub _op_case {
+}
+
+sub _op_and {
+ my ( $self, $node ) = @_;
+
+ my $true_label = $self->_gensym();
+ my $temp;
+ my $return = $self->_save_1();
+ for ( _get_args($node) ) {
+ my $label = $self->_gensym();
+ $temp = $self->_generate($_);
+ $self->_branch_unless_type( $temp, 'Boolean', "NOT_YET_DONE_$label" );
+ $self->_add_inst( '', "unless $temp goto FALSE_$true_label" );
+ $self->_add_inst("NOT_YET_DONE_$label");
+ }
+ $self->_add_inst( '', 'new', [ $return, q{'Undef'} ] );
+ $self->_add_inst( '', 'set', [ $return, $temp ] );
+ $self->_add_inst( '', 'branch', [ "TRUE_$true_label" ] );
+ $self->_add_inst("FALSE_$true_label");
+ $self->_add_inst( '', 'new', [ $return, q{'Boolean'} ] );
+ $self->_add_inst( '', 'set', [ $return, 0 ] );
+ $self->_add_inst("TRUE_$true_label");
+
+ return $return;
+}
+
+sub _op_or {
+ my ( $self, $node ) = @_;
+
+ my $return;
+ my $label = $self->_gensym();
+
+ $return = $self->_constant( 1, 'INTEGER' );
+ for ( _get_args($node) ) {
+ my $temp = $self->_generate($_);
+ $self->_add_inst( '', 'eq', [ $temp, 1, "DONE_$label" ] );
+ $self->_restore($temp);
+ }
+ $self->_add_inst( '', 'set', [ $return, 0 ] );
+ $self->_add_inst("DONE_$label");
+
+ return $return;
+}
+
+sub _op_let {
+ my ( $self, $node ) = @_;
+
+ $self->_add_comment( 'start of _op_let()' );
+
+ my ( $locals, @body ) = _get_args( $node, 1 );
+ my ( @variables, @values );
+ for ( @{ $locals->{children} } ) {
+ _check_num_args( $_, 1, 'let locals' );
+ my ( $var, $val ) = _get_args( $_, 0 );
+ push @variables, $var;
+ push @values, $val;
+ }
+
+ my $let = {
+ children => [ { children => [ { value => 'lambda' },
+ { children => [@variables] },
+ @body
+ ]
+ },
+ @values
+ ]
+ };
+
+ my $return = $self->_generate($let);
+
+ $self->_add_comment( 'end of _op_let()' );
+
+ return $return;
+}
+
+sub _op_let_star {
+}
+
+sub _op_letrec {
+}
+
+sub _op_begin {
+ my ( $self, $node ) = @_;
+
+ my $temp = 'none';
+
+ foreach ( _get_args($node) ) {
+ $self->_restore($temp);
+ $temp = $self->_generate($_);
+ }
+
+ return $temp;
+}
+
+sub _op_do {
+}
+
+sub _op_delay {
+}
+
+#---- Section 6 ----
+
+sub _op_not {
+ my ( $self, $node ) = @_;
+
+ $self->_add_comment( 'start of _op_not()' );
+ my $return = $self->_generate(
+ { children => [ { value => 'if' },
+ _get_arg( $node, 1 ),
+ { value => '#f' },
+ { value => '#t' },
+ ]
+ }
+ );
+
+ $self->_add_comment( 'end of _op_not()' );
+
+ return $return;
+}
+
+sub _op_boolean_p {
+ my ( $self, $node ) = @_;
+
+ return $self->_type_predicate( 'boolean?', $node );
+}
+
+sub _op_eqv_p {
+}
+
+sub _op_eq_p {
+}
+
+sub _op_equal_p {
+}
+
+sub _op_pair_p {
+ my ( $self, $node ) = @_;
+
+ return $self->_type_predicate( 'pair?', $node );
+}
+
+sub _op_cons {
+ my ( $self, $node ) = @_;
+
+ my $return;
+
+ _check_num_args( $node, 2, 'cons' );
+
+ my $car = $self->_generate( _get_arg( $node, 1 ) );
+ $return = $self->_save_1();
+
+ $self->_add_inst( '', 'new', [ $return, q{'Array'} ] );
+ $self->_add_inst( '', 'set', [ $return, 2 ] );
+ $self->_add_inst( '', 'set', [ $return . '[0]', $car ] );
+ $self->_restore($car);
+
+ my $cdr = $self->_generate( _get_arg( $node, 2 ) );
+ $self->_add_inst( '', 'set', [ $return . '[1]', $cdr ] );
+ $self->_restore($cdr);
+
+ return $return;
+}
+
+sub _op_car {
+ my ( $self, $node ) = @_;
+
+ _check_num_args( $node, 1, 'car' );
+
+ my $return = $self->_generate( _get_arg( $node, 1 ) );
+ die "car: Element not pair\n" unless $return =~ /^P/;
+ $self->_add_inst( '', 'set', [ $return, $return . '[0]' ] );
+
+ return $return;
+}
+
+sub _op_cdr {
+ my ( $self, $node ) = @_;
+
+ _check_num_args( $node, 1, 'cdr' );
+
+ my $return = $self->_generate( _get_arg( $node, 1 ) );
+ die "cdr: Element not pair\n" unless $return =~ /^P/;
+ $self->_add_inst( '', 'set', [ $return, $return . '[1]' ] );
+
+ return $return;
+}
+
+sub _op_set_car_bang {
+ my ( $self, $node ) = @_;
+
+ _check_num_args( $node, 2, 'set-car!' );
+
+ my $return = $self->_generate( _get_arg( $node, 1 ) );
+ die "set-car!: Element not pair\n" unless $return =~ /^P/;
+ my $value = $self->_generate( _get_arg( $node, 2 ) );
+ $self->_add_inst( '', 'set', [ $return . '[0]', $value ] );
+ $self->_restore($value);
+
+ return $return;
+}
+
+sub _op_set_cdr_bang {
+ my ( $self, $node ) = @_;
+
+ _check_num_args( $node, 2, 'set-cdr!' );
+
+ my $return = $self->_generate( _get_arg( $node, 1 ) );
+ die "set-cdr!: Element not pair\n" unless $return =~ /^P/;
+ my $value = $self->_generate( _get_arg( $node, 2 ) );
+ $self->_add_inst( '', 'set', [ $return . '[1]', $value ] );
+ $self->_restore($value);
+
+ return $return;
+}
+
+sub _op_null_p {
+ my ( $self, $node ) = @_;
+
+ return $self->_type_predicate( 'null?', $node );
+}
+
+sub _op_list_p {
+}
+
+sub _op_list {
+ my ( $self, $node ) = @_;
+
+ $self->_add_comment( 'start of _op_list()' );
+
+ my $return = $self->_constant(undef);
+
+ # build up the list in reverse order
+ foreach ( reverse _get_args($node) ) {
+ my $item = $self->_generate($_);
+ my $pair = $self->_save_1();
+
+ $self->_add_inst( '', 'new', [ $pair, q{'Array'} ] );
+ $self->_add_inst( '', 'set', [ $pair, 2 ] );
+ $self->_add_inst( '', 'set', [ $pair . '[0]', $item ] );
+ $self->_add_inst( '', 'set', [ $pair . '[1]', $return ] );
+ $self->_add_inst( '', 'set', [ $return, $pair ] );
+
+ $self->_restore( $item, $pair );
+ }
+
+ $self->_add_comment( "returning $return from _op_list()" );
+
+ return $return;
+}
+
+sub _op_length {
+ my ( $self, $node ) = @_;
+
+ my $label = $self->_gensym();
+ my $return = $self->_constant( 0, 'INTEGER' );
+
+ _check_num_args( $node, 1, 'length' );
+
+ my $list = $self->_generate( _get_arg( $node, 1 ) );
+
+ $self->_add_inst( '', 'set', [ $return, '0' ] );
+ $self->_add_inst( "NEXT_$label" );
+ $self->_branch_if_type( $list, 'Undef', "DONE_$label" );
+ $self->_branch_unless_type( $list, 'Array', "ERR_$label" );
+ $self->_add_inst( '', inc => [$return] );
+ $self->_add_inst( '', set => [ $list, $list . '[1]' ] );
+ $self->_add_inst( '', branch => [ "NEXT_$label" ] );
+
+ # XXX Use exceptions here
+ $self->_add_inst( "ERR_$label", 'print', ['"Object is not a list\n"'] );
+
+ $self->_add_inst("DONE_$label");
+
+ return $return;
+}
+
+sub _op_append {
+}
+
+sub _op_reverse {
+}
+
+sub _op_list_ref {
+}
+
+sub _op_memq {
+}
+
+sub _op_memv {
+}
+
+sub _op_member {
+}
+
+sub _op_assq {
+}
+
+sub _op_assv {
+}
+
+sub _op_assoc {
+}
+
+sub _op_symbol_p {
+}
+
+sub _op_symbol_string {
+}
+
+sub _op_string_symbol {
+}
+
+sub _op_number_p {
+ my ( $self, $node ) = @_;
+
+ return $self->_type_predicate( 'number?', $node );
+}
+
+sub _op_complex_p {
+ my ( $self, $node ) = @_;
+
+ return $self->_type_predicate( 'number?', $node );
+}
+
+sub _op_real_p {
+ my ( $self, $node ) = @_;
+
+ return $self->_type_predicate( 'real?', $node );
+}
+
+sub _op_rational_p {
+ my ( $self, $node ) = @_;
+
+ return $self->_type_predicate( 'rational?', $node );
+}
+
+sub _op_integer_p {
+ my ( $self, $node ) = @_;
+
+ return $self->_type_predicate( 'integer?', $node );
+}
+
+sub _op_exact_p {
+}
+
+sub _op_inexact_p {
+}
+
+sub _compare {
+ my ( $self, $node, $inverse_cmp_op ) = @_;
+
+ my $label = $self->_gensym();
+
+ my $return = $self->_constant('#f');
+ my $lhs = $self->_generate( _get_arg( $node, 1 ) );
+ for ( 2 .. $#{ $node->{children} } ) {
+ my $rhs = $self->_generate( _get_arg( $node, $_ ) );
+ $self->_add_inst( '', $inverse_cmp_op => [ $lhs, $rhs, "DONE_$label" ] );
+ $self->_restore($lhs);
+ $lhs = $rhs;
+ }
+ $self->_add_inst( '', 'set', [ $return, 1 ] );
+ $self->_add_inst("DONE_$label");
+
+ return $return;
+}
+
+sub _op_eq {
+ my ( $self, $node ) = @_;
+
+ my $label = $self->_gensym();
+
+ my $return = $self->_constant('#f');
+ my $lhs = $self->_generate( _get_arg( $node, 1 ) );
+ for ( 2 .. $#{ $node->{children} } ) {
+ my $temp_1 = $self->_generate( _get_arg( $node, $_ ) );
+ if ( substr( $lhs, 0, 1 ) ne substr( $temp_1, 0, 1 ) ) {
+ my $temp_2 = $self->_save_1( substr( $lhs, 0, 1 ) );
+ $self->_morph( $temp_2, $temp_1 );
+ $self->_restore($temp_1);
+ $temp_1 = $temp_2;
+ }
+ $self->_add_inst( '', 'ne', [ $lhs, $temp_1, "DONE_$label" ] );
+ $self->_restore($temp_1);
+ }
+ $self->_add_inst( '', 'set', [ $return, 1 ] );
+ $self->_add_inst("DONE_$label");
+ $self->_restore($lhs);
+
+ return $return;
+}
+
+sub _op_lt {
+ my ( $self, $node ) = @_;
+
+ return $self->_compare( $node, 'ge' );
+}
+
+sub _op_gt {
+ my ( $self, $node ) = @_;
+
+ return $self->_compare( $node, 'le' );
+}
+
+sub _op_leq {
+ my ( $self, $node ) = @_;
+
+ return $self->_compare( $node, 'gt' );
+}
+
+sub _op_geq {
+ my ( $self, $node ) = @_;
+
+ return $self->_compare( $node, 'lt' );
+}
+
+sub _op_zero_p {
+ my ( $self, $node ) = @_;
+
+ my $label = $self->_gensym();
+
+ my $return = $self->_constant('#t');
+
+ my $temp = $self->_generate( _get_arg( $node, 1 ) );
+ $self->_add_inst( '', 'eq', [ $temp, 0, "DONE_$label" ] );
+ $self->_restore($temp);
+ $self->_add_inst( '', 'set', [ $return, 0 ] );
+ $self->_add_inst("DONE_$label");
+
+ return $return;
+}
+
+sub _op_positive_p {
+ my ( $self, $node ) = @_;
+
+ my $label = $self->_gensym();
+
+ my $return = $self->_constant('#t');
+ my $temp = $self->_generate( _get_arg( $node, 1 ) );
+ $self->_add_inst( '', 'gt', [ $temp, 0, "DONE_$label" ] );
+ $self->_restore($temp);
+ $self->_add_inst( '', 'set', [ $return, 0 ] );
+ $self->_add_inst("DONE_$label");
+
+ return $return;
+}
+
+sub _op_negative_p {
+ my ( $self, $node ) = @_;
+
+ my $label = $self->_gensym();
+
+ my $return = $self->_constant('#t');
+ my $temp = $self->_generate( _get_arg( $node, 1 ) );
+ $self->_add_inst( '', 'lt', [ $temp, 0, "DONE_$label" ] );
+ $self->_restore($temp);
+ $self->_add_inst( '', 'set', [ $return, 0 ] );
+ $self->_add_inst("DONE_$label");
+
+ return $return;
+}
+
+sub _op_odd_p {
+ my ( $self, $node ) = @_;
+
+ my $label = $self->_gensym();
+
+ my $temp_0 = $self->_generate( _get_arg( $node, 1 ) );
+ my $return = $self->_constant('#t');
+ my $temp_1 = $self->_constant( 2, 'INTEGER' );
+ $self->_add_inst( '', 'mod', [ $temp_0, $temp_0, $temp_1 ] );
+ $self->_add_inst( '', 'eq', [ $temp_0, 1, "DONE_$label" ] );
+ $self->_add_inst( '', 'set', [ $return, 0 ] );
+ $self->_add_inst("DONE_$label");
+ $self->_restore( $temp_0, $temp_1 );
+
+ return $return;
+}
+
+sub _op_even_p {
+ my ( $self, $node ) = @_;
+
+ my $label = $self->_gensym();
+
+ my $temp_0 = $self->_generate( _get_arg( $node, 1 ) );
+ my $return = $self->_constant('#t');
+ my $temp_1 = $self->_constant( 2, 'INTEGER' );
+ $self->_add_inst( '', 'mod', [ $temp_0, $temp_0, $temp_1 ] );
+ $self->_add_inst( '', 'eq', [ $temp_0, 0, "DONE_$label" ] );
+ $self->_add_inst( '', 'set', [ $return, 0 ] );
+ $self->_add_inst("DONE_$label");
+ $self->_restore( $temp_0, $temp_1 );
+
+ return $return;
+}
+
+sub _op_max {
+ my ( $self, $node ) = @_;
+
+ my $label = $self->_gensym();
+
+ my $return = $self->_generate( _get_arg( $node, 1 ) );
+ for ( 2 .. $#{ $node->{children} } ) {
+ my $temp = $self->_generate( _get_arg( $node, $_ ) );
+ my $label = $self->_gensym();
+ $self->_add_inst( '', 'gt', [ $return, $temp, "NEXT_$label" ] );
+ $self->_add_inst( '', 'set', [ $return, $temp ] );
+ $self->_add_inst("NEXT_$label");
+ $self->_restore($temp);
+ }
+
+ return $return;
+}
+
+sub _op_min {
+ my ( $self, $node ) = @_;
+
+ my $return;
+ my $label = $self->_gensym();
+
+ $return = $self->_generate( _get_arg( $node, 1 ) );
+ for ( 2 .. $#{ $node->{children} } ) {
+ my $temp = $self->_generate( _get_arg( $node, $_ ) );
+ my $label = $self->_gensym();
+ $self->_add_inst( '', 'lt', [ $return, $temp, "NEXT_$label" ] );
+ $self->_add_inst( '', 'set', [ $return, $temp ] );
+ $self->_add_inst("NEXT_$label");
+ $self->_restore($temp);
+ }
+
+ return $return;
+}
+
+sub _op_plus {
+ my ( $self, $node ) = @_;
+
+ my $return;
+ my $num_args = _get_num_args( $node );
+ if ( $num_args == 0 ) {
+ $return = $self->_constant( 0, 'INTEGER' );
+ }
+ elsif ( $num_args == 1 ) {
+ $return = $self->_generate( _get_arg( $node, 1 ) );
+ if ( $return =~ /^P/ ) {
+ my $temp = $self->_save_1();
+ $self->_morph( $temp, $return );
+ $self->_restore($return);
+ $return = $temp;
+ }
+ }
+ else {
+ $return = $self->_generate( _get_arg( $node, 1 ) );
+ if ( $return =~ /^P/ ) {
+ my $temp = $self->_save_1();
+ $self->_morph( $temp, $return );
+ $self->_restore($return);
+ $return = $temp;
+ }
+ for ( 2 .. $#{ $node->{children} } ) {
+ my $temp = $self->_generate( _get_arg( $node, $_ ) );
+ $self->_add_inst( '', 'add', [ $return, $return, $temp ] );
+ $self->_restore($temp);
+ }
+ }
+
+ return $return;
+}
+
+sub _op_minus {
+ my ( $self, $node ) = @_;
+
+ $self->_add_comment( 'start of _op_minus' );
+
+ _check_num_args( $node, '>= 1', '-' );
+
+ my $return;
+ my $num_args = _get_num_args( $node );
+
+ if ( $num_args == 1 ) {
+ $return = $self->_generate( _get_arg( $node, 1 ) );
+ if ( $return =~ /^P/ ) {
+ my $temp = $self->_save_1();
+ $self->_morph( $temp, $return );
+ $self->_restore($return);
+ $return = $temp;
+ }
+ my $temp = $self->_constant( 0, 'INTEGER' );
+ $self->_add_inst( '', 'sub', [ $return, $temp, $return ] );
+ $self->_restore($temp);
+ }
+ else {
+ $return = $self->_generate( _get_arg( $node, 1 ) );
+ if ( $return =~ /^P/ ) {
+ my $temp = $self->_save_1();
+ $self->_morph( $temp, $return );
+ $self->_restore($return);
+ $return = $temp;
+ }
+ for ( 2 .. $#{ $node->{children} } ) {
+ my $temp = $self->_generate( _get_arg( $node, $_ ) );
+ $self->_add_inst( '', 'sub', [ $return, $return, $temp ] );
+ $self->_restore($temp);
+ }
+ }
+
+ return $return;
+}
+
+sub _op_times {
+ my ( $self, $node ) = @_;
+
+ my $return;
+ my $num_args = _get_num_args( $node );
+
+ if ( $num_args == 0 ) {
+ $return = $self->_constant( 1, 'INTEGER' );
+ }
+ elsif ( $num_args == 1 ) {
+ $return = $self->_generate( _get_arg( $node, 1 ) );
+ if ( $return =~ /^P/ ) {
+ my $temp = $self->_save_1();
+ $self->_morph( $temp, $return );
+ $self->_restore($return);
+ $return = $temp;
+ }
+ }
+ else {
+ $return = $self->_generate( _get_arg( $node, 1 ) );
+ if ( $return =~ /^P/ ) {
+ my $temp = $self->_save_1();
+ $self->_morph( $temp, $return );
+ $self->_restore($return);
+ $return = $temp;
+ }
+ for ( 2 .. $#{ $node->{children} } ) {
+ my $temp = $self->_generate( _get_arg( $node, $_ ) );
+ $self->_add_inst( '', 'mul', [ $return, $return, $temp ] );
+ $self->_restore($temp);
+ }
+ }
+
+ return $return;
+}
+
+sub _op_divide {
+ my ( $self, $node ) = @_;
+
+ my $return;
+ my $num_args = _get_num_args( $node );
+
+ if ( $num_args == 0 ) {
+ $return = $self->_constant( 0, 'INTEGER' );
+ }
+ elsif ( $num_args == 1 ) {
+ $return = $self->_generate( _get_arg( $node, 1 ) );
+ if ( $return =~ /^P/ ) {
+ my $temp = $self->_save_1();
+ $self->_morph( $temp, $return );
+ $self->_restore($return);
+ $return = $temp;
+ }
+ my $temp = $self->_constant( 1, 'INTEGER' );
+ $self->_add_inst( '', 'div', [ $return, $temp, $return ] );
+ $self->_restore($temp);
+ }
+ else {
+ $return = $self->_generate( _get_arg( $node, 1 ) );
+ if ( $return =~ /^P/ ) {
+ my $temp = $self->_save_1();
+ $self->_morph( $temp, $return );
+ $self->_restore($return);
+ $return = $temp;
+ }
+ for ( 2 .. $#{ $node->{children} } ) {
+ my $temp = $self->_generate( _get_arg( $node, $_ ) );
+ $self->_add_inst( '', 'div', [ $return, $return, $temp ] );
+ $self->_restore($temp);
+ }
+ }
+
+ return $return;
+}
+
+sub _op_abs {
+ my ( $self, $node ) = @_;
+
+ my $return;
+ my $label = $self->_gensym();
+
+ $return = $self->_generate( _get_arg( $node, 1 ) );
+ $self->_add_inst( '', 'gt', [ $return, 0, "DONE_$label" ] );
+ my $temp = $self->_constant( -1, 'INTEGER' );
+ $self->_add_inst( '', 'mul', [ $return, $return, $temp ] );
+ $self->_restore($temp);
+ $self->_add_inst("DONE_$label");
+
+ return $return;
+}
+
+sub _op_quotient {
+}
+
+sub _op_remainder {
+}
+
+sub _op_modulo {
+}
+
+sub _op_gcd {
+}
+
+sub _op_lcm {
+}
+
+sub _op_numerator {
+}
+
+sub _op_denominator {
+}
+
+sub _op_floor {
+}
+
+sub _op_ceiling {
+}
+
+sub _op_truncate {
+}
+
+sub _op_round {
+}
+
+sub _op_rationalize {
+}
+
+sub _op_exp {
+}
+
+sub _op_log {
+}
+
+sub _op_sin {
+}
+
+sub _op_cos {
+}
+
+sub _op_tan {
+}
+
+sub _op_asin {
+}
+
+sub _op_acos {
+}
+
+sub _op_atan {
+}
+
+sub _op_sqrt {
+}
+
+sub _op_expt {
+}
+
+sub _op_make_rectangular {
+}
+
+sub _op_make_point {
+}
+
+sub _op_real_part {
+ my ( $self, $node ) = @_;
+
+ my $is_real = $self->_op_real_p( $node );
+ my $item = $self->_generate( _get_arg( $node, 1 ) );
+}
+
+sub _op_imag_part {
+}
+
+sub _op_magnitude {
+}
+
+sub _op_angle {
+}
+
+sub _op_exact_inexact {
+}
+
+sub _op_inexact_exact {
+}
+
+sub _op_number_string {
+}
+
+sub _op_string_number {
+}
+
+sub _op_char_p {
+}
+
+sub _op_char_eq_p {
+}
+
+sub _op_char_lt_p {
+}
+
+sub _op_char_gt_p {
+}
+
+sub _op_char_le_p {
+}
+
+sub _op_char_ge_p {
+}
+
+sub _op_char_ci_eq_p {
+}
+
+sub _op_char_ci_lt_p {
+}
+
+sub _op_char_ci_gt_p {
+}
+
+sub _op_char_ci_le_p {
+}
+
+sub _op_char_ci_ge_p {
+}
+
+sub _op_char_alphabetic_p {
+}
+
+sub _op_char_numeric_p {
+}
+
+sub _op_char_whitespace_p {
+}
+
+sub _op_char_upper_case_p {
+}
+
+sub _op_char_lower_case_p {
+}
+
+sub _op_char_integer {
+}
+
+sub _op_integer_char {
+}
+
+sub _op_char_upcase {
+}
+
+sub _op_char_downcase {
+}
+
+sub _op_string_p {
+ my ( $self, $node ) = @_;
+
+ return $self->_type_predicate( 'string?', $node );
+}
+
+sub _op_make_string {
+}
+
+sub _op_string {
+}
+
+sub _op_string_length {
+}
+
+sub _op_string_ref {
+}
+
+sub _op_string_set_bang {
+}
+
+sub _op_string_eq_p {
+}
+
+sub _op_string_lt_p {
+}
+
+sub _op_string_gt_p {
+}
+
+sub _op_string_le_p {
+}
+
+sub _op_string_ge_p {
+}
+
+sub _op_string_ci_eq_p {
+}
+
+sub _op_string_ci_lt_p {
+}
+
+sub _op_string_ci_gt_p {
+}
+
+sub _op_string_ci_le_p {
+}
+
+sub _op_string_ci_ge_p {
+}
+
+sub _op_substring {
+}
+
+sub _op_string_append {
+}
+
+sub _op_string_list {
+}
+
+sub _op_list_string {
+}
+
+sub _op_string_copy {
+}
+
+sub _op_string_fill_bang {
+}
+
+sub _op_vector_p {
+}
+
+sub _op_make_vector {
+}
+
+sub _op_vector {
+}
+
+sub _op_vector_length {
+}
+
+sub _op_vector_ref {
+}
+
+sub _op_vector_set_bang {
+}
+
+sub _op_vector_list {
+}
+
+sub _op_list_vector {
+}
+
+sub _op_vector_fill_bang {
+}
+
+sub _op_procedure_p {
+ my ( $self, $node ) = @_;
+
+ my $return;
+
+ _check_num_args( $node, 1, 'procedure?' );
+
+ $return = $self->_constant( 0, 'INTEGER' );
+
+ my $temp = $self->_generate( _get_arg( $node, 1 ) );
+ if ( $temp =~ /^P/ ) {
+ }
+
+ return $return;
+}
+
+sub _op_apply {
+ my ( $self, $node ) = @_;
+
+ my $return;
+
+ my $func = $self->_generate( _get_arg( $node, 1 ) );
+ my @args = _get_args( $node, 2 );
+ die "apply: wrong number of args\n" unless @args;
+
+ $return = $self->_call_function_sym('apply');
+
+ return $return;
+}
+
+sub _op_map {
+}
+
+sub _op_for_each {
+}
+
+sub _op_force {
+}
+
+sub _op_call_with_current_continuation {
+}
+
+sub _op_call_with_input_file {
+}
+
+sub _op_call_with_output_file {
+}
+
+sub _op_input_port_p {
+}
+
+sub _op_output_port_p {
+}
+
+sub _op_current_input_port {
+}
+
+sub _op_current_output_port {
+}
+
+sub _op_with_input_to_file {
+}
+
+sub _op_with_output_from_file {
+}
+
+sub _op_open_input_file {
+}
+
+sub _op_open_output_file {
+}
+
+sub _op_close_input_port {
+}
+
+sub _op_close_output_port {
+}
+
+sub _op_read {
+}
+
+sub _op_read_char {
+}
+
+sub _op_peek_char {
+}
+
+sub _op_eof_object_p {
+}
+
+sub _op_char_ready_p {
+}
+
+sub _op_write {
+ my ( $self, $node ) = @_;
+
+ $self->_add_comment( 'start of _op_write' );
+
+ my $temp = 'none';
+
+ for ( _get_args($node) ) {
+ $self->_restore($temp);
+ $temp = $self->_generate($_);
+ $self->_call_function_sym( 'write', $temp );
+ }
+
+ $self->_add_comment( 'end of _op_write' );
+
+ return $temp; # We need to return something
+}
+
+sub _op_display {
+ my ( $self, $node ) = @_;
+
+ $self->_add_comment( 'start of _op_display' );
+
+ my $temp = 'none';
+
+ for ( _get_args($node) ) {
+ $self->_restore($temp);
+ $temp = $self->_generate($_);
+ $self->_call_function_sym( 'display', $temp );
+ }
+
+ $self->_add_comment( 'end of _op_display' );
+
+ return $temp; # We need to return something
+}
+
+sub _op_write_char {
+}
+
+sub _op_load {
+}
+
+sub _op_transcript_on {
+}
+
+sub _op_transcript_off {
+}
+
+sub _op_let_syntax {
+}
+
+sub _op_letrec_syntax {
+}
+
+sub _op_define_syntax {
+}
+
+sub _op_syntax_rules {
+}
+
+sub _op_syntax {
+}
+
+sub _op_identifier_p {
+}
+
+sub _op_unwrap_syntax {
+}
+
+sub _op_free_identifier_eq_p {
+}
+
+sub _op_bound_identifier_eq_p {
+}
+
+sub _op_identifier_symbol {
+}
+
+sub _op_generate_identifier {
+}
+
+sub _op_construct_identifier {
+}
+
+my %global_ops = (
+
+ #----------------------
+ #
+ # Section 4 Expressions
+ #
+ #----------------------
+
+ 'quote' => \&_op_quote,
+ 'lambda' => \&_op_lambda,
+ 'if' => \&_op_if,
+ 'define' => \&_op_define,
+ 'set!' => \&_op_set_bang,
+ 'cond' => \&_op_cond,
+ 'case' => \&_op_case,
+ 'and' => \&_op_and,
+ 'or' => \&_op_or,
+ 'let' => \&_op_let,
+ 'let*' => \&_op_let_star,
+ 'letrec' => \&_op_letrec,
+ 'begin' => \&_op_begin,
+ 'do' => \&_op_do,
+ 'delay' => \&_op_delay,
+ 'quasiquote' => \&_op_quasiquote,
+
+ #----------------------
+ #
+ # Section 6 Expressions
+ #
+ #----------------------
+
+###
+### Logical expression
+###
+
+ 'not' => \&_op_not,
+
+###
+### Equivalency
+###
+
+ 'boolean?' => \&_op_boolean_p,
+ 'eqv?' => \&_op_eqvp,
+ 'eq?' => \&_op_eqp,
+ 'equal?' => \&_op_equalp,
+
+###
+### Pairs and Lists
+###
+
+ 'pair?' => \&_op_pair_p,
+ 'cons' => \&_op_cons,
+ 'car' => \&_op_car,
+ 'cdr' => \&_op_cdr,
+ 'set-car!' => \&_op_set_car_bang,
+ 'set-cdr!' => \&_op_set_cdr_bang,
+
+ # Not adding caar/cadr/cdar/whatever
+ 'null?' => \&_op_null_p,
+ 'list?' => \&_op_list_p,
+ 'list' => \&_op_list,
+ 'length' => \&_op_length,
+ 'append' => \&_op_append,
+ 'reverse' => \&_op_reverse,
+ 'list-ref' => \&_op_list_ref,
+ 'memq' => \&_op_memq,
+ 'memv' => \&_op_memv,
+ 'member' => \&_op_member,
+ 'assq' => \&_op_assq,
+ 'assv' => \&_op_assv,
+ 'assoc' => \&_op_assoc,
+
+###
+### Symbols
+###
+
+ 'symbol?' => \&_op_symbol_p,
+ 'symbol->string' => \&_op_symbol_string,
+ 'string->symbol' => \&_op_string_symbol,
+
+###
+### Numerics
+###
+
+ 'number?' => \&_op_number_p,
+ 'complex?' => \&_op_complex_p,
+ 'real?' => \&_op_real_p,
+ 'rational?' => \&_op_rational_p,
+ 'integer?' => \&_op_integer_p,
+ 'exact?' => \&_op_exact_p,
+ 'inexact?' => \&_op_inexact_p,
+ '=' => \&_op_eq,
+ '<' => \&_op_lt,
+ '>' => \&_op_gt,
+ '<=' => \&_op_leq,
+ '>=' => \&_op_geq,
+ 'zero?' => \&_op_zero_p,
+ 'positive?' => \&_op_positive_p,
+ 'negative?' => \&_op_negative_p,
+ 'odd?' => \&_op_odd_p,
+ 'even?' => \&_op_even_p,
+ 'max' => \&_op_max,
+ 'min' => \&_op_min,
+ '+' => \&_op_plus,
+ '-' => \&_op_minus,
+ '*' => \&_op_times,
+ '/' => \&_op_divide,
+ 'abs' => \&_op_abs,
+ 'quotient' => \&_op_quotient,
+ 'remainder' => \&_op_remainder,
+ 'modulo' => \&_op_modulo,
+ 'gcd' => \&_op_gcd,
+ 'lcm' => \&_op_lcm,
+ 'numerator' => \&_op_numerator,
+ 'denominator' => \&_op_denominator,
+ 'floor' => \&_op_floor,
+ 'ceiling' => \&_op_ceiling,
+ 'truncate' => \&_op_truncate,
+ 'round' => \&_op_round,
+ 'rationalize' => \&_op_rationalize,
+ 'exp' => \&_op_exp,
+ 'log' => \&_op_log,
+ 'sin' => \&_op_sin,
+ 'cos' => \&_op_cos,
+ 'tan' => \&_op_tan,
+ 'asin' => \&_op_asin,
+ 'acos' => \&_op_acos,
+ 'atan' => \&_op_atan,
+ 'sqrt' => \&_op_sqrt,
+ 'expt' => \&_op_expt,
+ 'make-rectangular' => \&_op_make_rectangular,
+ 'make-polar' => \&_op_make_point,
+ 'real-part' => \&_op_real_part,
+ 'imag-part' => \&_op_imag_part,
+ 'magnitude' => \&_op_magnitude,
+ 'angle' => \&_op_angle,
+ 'exact->inexact' => \&_op_exact_inexact,
+ 'inexact->exact' => \&_op_inexact_exact,
+
+###
+### Numerical input and output
+###
+
+ 'number->string' => \&_op_number_string,
+ 'string->number' => \&_op_string_number,
+
+###
+### Character
+###
+
+ 'char?' => \&_op_char_p,
+ 'char=?' => \&_op_char_eq_p,
+ 'char<?' => \&_op_char_lt_p,
+ 'char>?' => \&_op_char_gt_p,
+ 'char<=?' => \&_op_char_le_p,
+ 'char>=?' => \&_op_char_ge_p,
+ 'char-ci=?' => \&_op_char_eq_p,
+ 'char-ci<?' => \&_op_char_ci_lt_p,
+ 'char-ci>?' => \&_op_char_ci_gt_p,
+ 'char-ci<=?' => \&_op_char_ci_le_p,
+ 'char-ci>=?' => \&_op_char_ci_ge_p,
+ 'char-alphabetic?' => \&_op_char_alphabetic_p,
+ 'char-numeric?' => \&_op_char_numeric_p,
+ 'char-whitespace?' => \&_op_char_whitespace_p,
+ 'char-upper-case?' => \&_op_char_upper_case_p,
+ 'char-lower-case?' => \&_op_char_lower_case_p,
+ 'char->integer' => \&_op_char_integer,
+ 'integer->char' => \&_op_integer_char,
+ 'char-upcase' => \&_op_char_upcase,
+ 'char-downcase' => \&_op_char_downcase,
+
+###
+### Strings
+###
+
+ 'string?' => \&_op_string_p,
+ 'make-string' => \&_op_make_string,
+ 'string' => \&_op_string,
+ 'string-length' => \&_op_string_length,
+ 'string-ref' => \&_op_string_ref,
+ 'string-set!' => \&_op_string_set_bang,
+ 'string=?' => \&_op_string_eq_p,
+ 'string<?' => \&_op_string_lt_p,
+ 'string>?' => \&_op_string_gt_p,
+ 'string<=?' => \&_op_string_le_p,
+ 'string>=?' => \&_op_string_ge_p,
+ 'string-ci=?' => \&_op_string_ci_eq_p,
+ 'string-ci<?' => \&_op_string_ci_lt_p,
+ 'string-ci>?' => \&_op_string_ci_gt_p,
+ 'string-ci<=?' => \&_op_string_ci_le_p,
+ 'string-ci>=?' => \&_op_string_ci_ge_p,
+ 'substring' => \&_op_substring,
+ 'string-append' => \&_op_string_append,
+ 'string->list' => \&_op_string_list,
+ 'list->string' => \&_op_list_string,
+ 'string-copy' => \&_op_string_copy,
+ 'string-fill!' => \&_op_string_fill_bang,
+
+###
+### Vector
+###
+
+ 'vector?' => \&_op_vector_p,
+ 'make-vector' => \&_op_make_vector,
+ 'vector' => \&_op_vector,
+ 'vector-length' => \&_op_vector_length,
+ 'vector-ref' => \&_op_vector_ref,
+ 'vector-set!' => \&_op_vector_set_bang,
+ 'vector->list' => \&_op_vector_list,
+ 'list->vector' => \&_op_list_vector,
+ 'vector-fill!' => \&_op_vector_fill_bang,
+
+###
+### Control features
+###
+
+ 'procedure?' => \&_op_procedure_p,
+ 'apply' => \&_op_apply,
+ 'map' => \&_op_map,
+ 'for-each' => \&_op_for_each,
+ 'force' => \&_op_force,
+ 'call-with-currrent-continuation' => \&_op_call_with_current_continuation,
+
+###
+### Input and Output
+###
+
+####
+#### Ports
+####
+
+ 'call-with-input-file' => \&_op_call_with_input_file,
+ 'call-with-output-file' => \&_op_call_with_output_file,
+ 'input-port?' => \&_op_input_port_p,
+ 'output-port?' => \&_op_output_port_p,
+ 'current-input-port' => \&_op_current_input_port,
+ 'current-output-port' => \&_op_current_output_port,
+ 'with-input-to-file' => \&_op_with_input_to_file,
+ 'with-output-from-file' => \&_op_with_output_from_file,
+ 'open-input-file' => \&_op_open_input_file,
+ 'open-output-file' => \&_op_open_output_file,
+ 'close-input-port' => \&_op_close_input_port,
+ 'close-output-port' => \&_op_close_output_port,
+
+####
+#### Input
+####
+
+ 'read' => \&_op_read,
+ 'read-char' => \&_op_read_char,
+ 'peek-char' => \&_op_peek_char,
+ 'eof-object?' => \&_op_eof_object_p,
+ 'char-ready?' => \&_op_char_ready_p,
+ 'write' => \&_op_write,
+ 'display' => \&_op_display,
+ # 'newline' => see Scheme::wrap_source()
+ 'write-char' => \&_op_write_char,
+
+####
+#### System Interface
+####
+
+ 'load' => \&_op_load,
+ 'transcript-on' => \&_op_transcript_on,
+ 'transcript-off' => \&_op_transcript_off,
+
+ #--------------------
+ #
+ # Macros
+ #
+ #--------------------
+
+ 'let-syntax' => \&_op_let_syntax,
+ 'letrec-syntax' => \&_op_letrec_syntax,
+ 'define-syntax' => \&_op_define_syntax,
+ 'syntax-rules' => \&_op_syntax_rules,
+ 'let-syntax' => \&_op_let_syntax,
+ 'syntax' => \&_op_syntax,
+ 'identifer?' => \&_op_identifier_p,
+ 'unwrap-syntax' => \&_op_unwrap_syntax,
+ 'bound-identfier=?' => \&_op_bound_identifier_eq_p,
+ 'identifier->symbol' => \&_op_identifier_symbol,
+ 'free-identfier=?' => \&_op_free_identifier_eq_p,
+ 'generate-identfier' => \&_op_generate_identifier,
+ 'construct-identfier' => \&_op_construct_identifier,
+);
+
+#------------------------------------------------------------------------------
+
+sub __max_lengths {
+ my $colref = shift;
+
+ my @max_len = (0) x 3;
+ foreach my $row (@{$colref}) {
+ for ( 0 .. $#{$row} ) {
+ $max_len[$_] = length( $row->[$_] ) if length $row->[$_] > $max_len[$_];
+ }
+ }
+
+ return @max_len;
+}
+
+sub _call_function_sym {
+ my $self = shift;
+ my $symbol = shift;
+
+ $self->_add_comment( 'start of _call_function_sym' );
+
+ my $func_obj = $self->_find_name($symbol);
+
+ my $scope = $self->{scope};
+
+ while ( $scope && !exists $scope->{$symbol} ) {
+ $scope = $scope->{'*UP*'};
+ }
+ if ( !$scope ) {
+ push @{ $self->{functions} }, $symbol
+ unless grep { $_ eq $symbol } @{ $self->{functions} };
+ }
+
+ my $return = $self->_call_function_obj( $func_obj, @_ );
+ $self->_restore($func_obj);
+
+ $self->_add_comment( 'end of _call_function_sym' );
+
+ return $return;
+}
+
+sub _call_function_obj {
+ my $self = shift;
+ my $func_obj = shift;
+
+ $self->_add_comment( 'start of _call_function_obj' );
+
+ my $return = $self->_save_1();
+ $self->_restore($return); # dont need to save this
+ $self->_save_set();
+
+ my $count = 10;
+ my $empty = $return;
+ my @args;
+ while ( my $arg = shift ) {
+ if ( $arg ne "P$count" ) {
+ # Check if any later argument needs the old value of P$count
+ my $moved;
+ for (@_) {
+ if ( $_ eq "P$count" ) {
+ $moved = $_;
+ $_ = $empty;
+ }
+ }
+ if ($moved) {
+ $empty = $moved;
+ }
+ $self->_add_inst( '', 'set', [ "P$count", $arg ] );
+
+ }
+ push @args, "P$count";
+ $count++;
+ }
+
+ {
+ my $spec = q{"} . join( q{,}, ( q{0} ) x scalar(@args) ) . q{"};
+ $self->_add_inst( '', 'set_args', [ $spec, @args ] );
+ }
+ $self->_add_inst( '', 'get_results', [ q{"0"}, $return ] );
+ $self->_add_inst( '', 'invokecc', [ $func_obj ] );
+ $self->_restore_set();
+
+ my ( $reg_num ) = $return =~ m/P(\d+)/;
+ $self->{regs}->[$reg_num] = 1;
+
+ $self->_add_comment( 'end of _call_function_obj' );
+
+ return $return;
+}
+
+sub _format_columns {
+ my $self = shift;
+
+ my @max_len = __max_lengths($self->{instruction});
+
+ $self->{code} = '';
+
+ for my $row (@{$self->{instruction}}) {
+ my $label;
+ $label = $row->[0];
+ $label .= ':' if $label;
+ $self->{code} .= $label . ' ' x ( $max_len[0] - length($label) + 2 );
+ if ( defined $row->[1] ) {
+ $label = $row->[1];
+ $self->{code} .= $label . ' ' x ( $max_len[1] - length($label) + 2 );
+ $label = $row->[2];
+ $self->{code} .= join ', ', @{$label} if $label;
+ }
+ $self->{code} .= "\n";
+ }
+
+ return;
+}
+
+sub _type_predicate {
+ my ( $self, $form, $node ) = @_;
+
+ $self->_add_comment( "start of _op_$form()" );
+
+ _check_num_args( $node, 1, $form );
+
+ my %types = (
+ 'boolean?' => [ qw( Boolean ) ],
+ 'complex?' => [ qw( Integer Rational Float Complex ) ],
+ 'integer?' => [ qw( Integer ) ],
+ 'null?' => [ qw( Undef ) ],
+ 'number?' => [ qw( Integer Rational Float Complex ) ],
+ 'pair?' => [ qw( Array ) ],
+ 'rational?' => [ qw( Integer Rational ) ],
+ 'real?' => [ qw( Integer Rational Float ) ],
+ 'string?' => [ qw( String ) ],
+ );
+
+ my $label = $self->_gensym();
+
+ my $return = $self->_constant('#f');
+ my $item = $self->_generate( _get_arg( $node, 1 ) );
+ foreach ( @{ $types{$form} } ) {
+ $self->_branch_if_type( $item, $_, "TRUE_$label" );
+ }
+ $self->_add_inst( '', 'branch', [ "FAIL_$label" ] );
+ $self->_add_inst( "TRUE_$label", 'set', [ $return, 1 ] );
+ $self->_add_inst("FAIL_$label");
+ $self->_add_comment( "returning $return from _op_$form()" );
+
+ return $return;
+}
+
+sub _branch_if_type {
+ my ( $self, $reg, $type, $label ) = @_;
+
+ $self->_add_inst( '', 'typeof', [ 'S17', $reg ] );
+ $self->_add_inst( '', 'eq', [ 'S17', qq{'$type'}, $label ] );
+
+ return;
+}
+
+sub _branch_unless_type {
+ my ( $self, $reg, $type, $label ) = @_;
+
+ $self->_add_inst( '', 'typeof', [ 'S18', $reg ] );
+ $self->_add_inst( '', 'ne', [ 'S18', qq{'$type'}, $label ] );
+
+ return;
+}
+
+sub new {
+ my $class = shift;
+
+ my $self = {
+ regs => _new_regs(),
+ frames => [],
+ gensym => 0, # used for creating unique labels and symbols
+ functions => [], # List of needed builtin functions
+ scope => {},
+ outer => ['main'], # a stack of the current outer sub
+ instruction => [],
+ lambda_instructions => [],
+ };
+
+ return bless $self, $class;
+}
+
+sub prettyprint {
+ my $node = shift;
+ my $depth = shift;
+
+ print ' ' x $depth;
+ print "($node->{value}\n";
+ if ( defined $node->{children} ) {
+ for ( @{ $node->{children} } ) {
+ prettyprint( $_, $depth + 1 );
+ }
+ }
+ print ' ' x $depth;
+ print ")\n";
+
+ return;
+}
+
+# generate PIR with recursive descent below $node
+sub _generate {
+ my ( $self, $node ) = @_;
+
+ my $return;
+
+ if ( exists $node->{children} ) { # $node is a list
+ my $func = _get_arg( $node, 0 );
+ if ( exists $func->{value} ) {
+ my $symbol = $func->{value};
+ if ( exists $global_ops{$symbol} ) {
+ $return = $global_ops{$symbol}->( $self, $node );
+ }
+ else {
+ my @args = map { $self->_generate($_); } _get_args($node);
+ $return = $self->_call_function_sym( $symbol, @args );
+ $self->_restore(@args);
+ }
+ }
+ else {
+ my @args = map { $self->_generate($_); } _get_args( $node, 0 );
+ $return = $self->_call_function_obj(@args);
+ $self->_restore(@args);
+ }
+ }
+ elsif ( defined $node->{value}
+ && $node->{value} =~ m/ \A [a-zA-Z] /xms ) {
+ $return = $self->_find_lex( $node->{value} );
+ }
+ else {
+ $return = $self->_constant( $node->{value}, $node->{type} );
+ }
+
+ return $return;
+}
+
+sub generate {
+ my $tree = shift;
+
+ my $self = Scheme::Generator->new( );
+
+ $self->{scope} = {};
+
+ $self->_add_inst( '', ".sub main :main :lex" );
+
+ my $temp = $self->_generate($tree);
+ $self->_restore($temp);
+
+ $self->_add_inst( '', '.end' );
+
+ push @{ $self->{instruction} }, @{ $self->{lambda_instructions} };
+ $self->_format_columns();
+
+ # not needed any more
+ undef $self->{instruction};
+ undef $self->{regs};
+
+ return $self;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Scheme::Generator - The Scheme code generator
+
+=head1 SYNOPSIS
+
+ use Scheme:Generator;
+
+ my @code = Scheme::Generator->new($code_tree)->generate();
+
+=head1 DESCRIPTION
+
+The code generator reads in a tree structure, and walks that to generate the
+output.
+
+=head1 AUTHOR
+
+Jeffrey Goff, drforr at hargray.com
+
+=head1 SEE ALSO
+
+L<Scheme>, L<Scheme::Tokenizer>
+
+=cut
Added: scheme/trunk/lib/Scheme/Parser.pm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ scheme/trunk/lib/Scheme/Parser.pm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,98 @@
+# $Id$
+# Copyright (C) 2001-2007, Parrot Foundation.
+
+package Scheme::Parser;
+
+# pragmata
+use strict;
+use warnings;
+use 5.008;
+
+our $VERSION = '0.01';
+
+use Data::Dumper;
+
+# walk over the tokens
+sub parse {
+ my ( $tokenizer ) = @_;
+
+ if ( wantarray() ) { # be greedy
+ my @trees;
+ while ( my $tree = parse( $tokenizer ) ) {
+ push @trees, $tree;
+ }
+
+ return @trees;
+ }
+
+ my $token = $tokenizer->(); # grap next token
+
+ return unless $token;
+
+ return if $token->[1] eq ')';
+
+ if ( $token->[1] eq '(' ) {
+ my @children = parse( $tokenizer );
+
+ if ( ! @children ) {
+ # special case: empty list
+ return { value => undef };
+ }
+ else {
+ return { children => \@children };
+ }
+ }
+
+ my %special_function = (
+ q{'} => 'quote',
+ q{`} => 'quasiquote',
+ q{,} => 'unquote',
+ q{,@} => 'unquote-splicing',
+ );
+ if ( exists $special_function{$token->[1]} ) {
+ my $child = parse( $tokenizer );
+
+ return { children => [ { value => $special_function{$token->[1]}
+ },
+ $child
+ ]
+ };
+
+ }
+
+ # the atomic case
+ return { type => $token->[0],
+ value => $token->[1],
+ };
+}
+
+
+1;
+
+__END__
+
+=head1 NAME
+
+Scheme::Parser - The Scheme token parser
+
+=head1 SYNOPSIS
+
+ use Scheme::Parser;
+
+ my $tree = Scheme::Parser::parse($tokenizer);
+
+=head1 DESCRIPTION
+
+The parser reads a list of tokens and turns it into a tree structure.
+The Nodes of the tree are hash references with either the attribute C<value>
+or the attribute C<children>. C<children> is an array reference with sub-nodes.
+
+=head1 AUTHOR
+
+Jeffrey Goff, drforr at hargray.com
+
+=head1 SEE ALSO
+
+L<Scheme>, L<Scheme::Tokenizer>, L<Scheme::Generator>
+
+=cut
Added: scheme/trunk/lib/Scheme/Tokenizer.pm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ scheme/trunk/lib/Scheme/Tokenizer.pm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,74 @@
+# $Id$
+# Copyright (C) 2001-2007, Parrot Foundation.
+
+package Scheme::Tokenizer;
+
+# pragmata
+use strict;
+use warnings;
+use 5.008;
+
+our $VERSION = '0.01';
+
+use Data::Dumper;
+
+sub new {
+ my $class = shift;
+ my $target = shift;
+
+ return
+ bless sub {
+ TOKEN:
+ {
+ return [ 'COMPLEX', $1 ] if $target =~ m/\G ([-+]? \d+ [-+] \d+ i ) /gcx;
+ return [ 'REAL', $1 ] if $target =~ m/\G
+ ( # capture all
+ [-+]? # optional sign
+ (?:\d+\.\d*) | (?:\.d+) # decimal point
+ (?:[eE][-+]?\d+)? # optional exponent
+ )
+ /gcx;
+ return [ 'INTEGER', $1 ] if $target =~ m/\G ([-+]? \d+) /gcx;
+ return [ 'STRING', $1 ] if $target =~ m/\G (".*?") # XXX: escaped quotes /gcx;
+ return [ 'PAREN_OPEN', $1 ] if $target =~ m/\G (\() /gcx;
+ return [ 'PAREN_CLOSE', $1 ] if $target =~ m/\G (\)) /gcx;
+ return [ 'IDENT', $1 ] if $target =~ m/\G ([a-z] [-a-zA-Z0-9]* [!?]?) /gcx;
+ return [ 'TRUE', $1 ] if $target =~ m/\G (\#t) /gcx;
+ return [ 'FALSE', $1 ] if $target =~ m/\G (\#f) /gcx;
+ return [ 'RELOP', $1 ] if $target =~ m/\G (<= | >= | = | < | > ) /gcx;
+ return [ 'WHATEVER', $1 ] if $target =~ m/\G (,@) /gcx;
+ redo TOKEN if $target =~ m/\G \s+ /gcx;
+ redo TOKEN if $target =~ m/\G ; .* /gcx;
+ return [ 'UNKNOWN', $1 ] if $target =~ m/\G (.) /gcx;
+ return;
+ }
+ }, $class;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Scheme::Tokenizer - The Scheme tokenizer
+
+=head1 SYNOPSIS
+
+ use Scheme:Tokenizer;
+
+ my $tokenizer = Scheme::Tokenizer->new($file_name);
+
+=head1 DESCRIPTION
+
+The tokenizer takes a file and splits it into tokens.
+
+=head1 AUTHOR
+
+Jeffrey Goff, drforr at hargray.com
+
+=head1 SEE ALSO
+
+L<Scheme>, L<Scheme::Parser>, L<Scheme::Generator>
+
+=cut
Added: scheme/trunk/schemec
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ scheme/trunk/schemec Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,23 @@
+#! perl
+# $Id$
+
+# pragmata
+use strict;
+use warnings;
+use 5.008;
+use lib qw( languages/scheme/lib lib );
+
+use Scheme;
+
+sub usage {
+ print <<"END_USAGE";
+usage: $0 <file.scheme>
+END_USAGE
+
+ exit;
+}
+
+defined $ARGV[0] or usage();
+$ARGV[0] =~ m/\.scheme$|\.scm$/i or usage();
+
+print Scheme->new($ARGV[0])->compile();
Added: scheme/trunk/t/arith/basic.t
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ scheme/trunk/t/arith/basic.t Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,137 @@
+#! perl
+# $Id$
+
+# Copyright (C) 2001-2007, Parrot Foundation.
+
+use strict;
+use warnings;
+use FindBin;
+use lib "$FindBin::Bin/../../lib";
+
+use Test::More tests => 23;
+
+use Parrot::Test;
+
+###
+### Add
+###
+
+language_output_is( 'Scheme', <<'CODE', 0, 'write (+)' );
+(write (+))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', 0, 'write (+ 0)' );
+(write (+ 0))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', 1, 'write (+ 1)' );
+(write (+ 1))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', 0, 'write (+ 0 0)' );
+(write (+ 0 0))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', 1, 'write (+ 0 1)' );
+(write (+ 0 1))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', 2, 'write (+ 0 1 1)' );
+(write (+ 0 1 1))
+CODE
+
+###
+### Subtract
+###
+
+language_error_output_like( 'Scheme', <<'CODE', qr{-: expects at least 1 argument, given 0}, 'write (-)' );
+(write (-))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', 0, 'write (- 0)' );
+(write (- 0))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', -1, 'write (- 1)' );
+(write (- 1))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', 0, 'write (- 0 0)' );
+(write (- 0 0))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', -1, 'write (- 0 1)' );
+(write (- 0 1))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', -2, 'write (- 0 1 1)' );
+(write (- 0 1 1))
+CODE
+
+###
+### Multiply
+###
+
+language_output_is( 'Scheme', <<'CODE', 1, 'neutral element of multiplication' );
+(write (*))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', 0, 'write (* 0)' );
+(write (* 0))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', 1, 'write (* 1)' );
+(write (* 1))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', 0, 'write (* 0 0)' );
+(write (* 0 0))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', 0, 'write (* 0 1)' );
+(write (* 0 1))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', 0, 'write (* 0 1 1)' );
+(write (* 0 1 1))
+CODE
+
+###
+### Divide
+###
+
+language_output_is( 'Scheme', <<'CODE', 1, 'reciprocal' );
+(write (/ 1))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', 1, '1/1' );
+(write (/ 1 1))
+CODE
+
+###
+### Abs
+###
+
+language_output_is( 'Scheme', <<'CODE', 5, 'abs 5' );
+(write (abs 5))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', 7, 'abs -7' );
+(write (abs -7))
+CODE
+
+###
+### complex arithmetics
+###
+
+language_output_is( 'Scheme', <<'CODE', '3+3i', 'adding two complex numbers' );
+(write (+ 1+1i 2+2i))
+CODE
+
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: scheme/trunk/t/arith/logic.t
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ scheme/trunk/t/arith/logic.t Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,133 @@
+#! perl
+# $Id$
+
+# Copyright (C) 2001-2007, Parrot Foundation.
+
+use strict;
+use warnings;
+use FindBin;
+use lib "$FindBin::Bin/../../lib";
+
+use Test::More tests => 82;
+use Parrot::Test;
+
+my @tests = (
+ # zero?
+ [ q{ (zero? 0) } => q{#t} ],
+ [ q{ (zero? -0) } => q{#t} ],
+ [ q{ (zero? +0) } => q{#t} ],
+ [ q{ (zero? 2) } => q{#f} ],
+ [ q{ (zero? -2) } => q{#f} ],
+ [ q{ (zero? +2) } => q{#f} ],
+ [ q{ (zero? 0.0) } => q{#t} ],
+ [ q{ (zero? -0.0) } => q{#t} ],
+ [ q{ (zero? +0.0) } => q{#t} ],
+ [ q{ (zero? 0.00000) } => q{#t} ],
+ [ q{ (zero? -0.00000) } => q{#t} ],
+ [ q{ (zero? +0.00000) } => q{#t} ],
+ [ q{ (zero? 0.000001) } => q{#f} ],
+ [ q{ (zero? -0.000001) } => q{#f} ],
+ [ q{ (zero? +0.000001) } => q{#f} ],
+
+ # positive?
+ [ q{ (positive? 0) } => q{#f} ],
+ [ q{ (positive? -0) } => q{#f} ],
+ [ q{ (positive? +0) } => q{#f} ],
+ [ q{ (positive? 2) } => q{#t} ],
+ [ q{ (positive? -2) } => q{#f} ],
+ [ q{ (positive? +2) } => q{#t} ],
+ [ q{ (positive? 0.0) } => q{#f} ],
+ [ q{ (positive? -0.0) } => q{#f} ],
+ [ q{ (positive? +0.0) } => q{#f} ],
+ [ q{ (positive? 0.00000) } => q{#f} ],
+ [ q{ (positive? -0.00000) } => q{#f} ],
+ [ q{ (positive? +0.00000) } => q{#f} ],
+ [ q{ (positive? 0.000001) } => q{#t} ],
+ [ q{ (positive? -0.000001) } => q{#f} ],
+ [ q{ (positive? +0.000001) } => q{#t} ],
+
+ # negative?
+ [ q{ (negative? 0) } => q{#f} ],
+ [ q{ (negative? -0) } => q{#f} ],
+ [ q{ (negative? +0) } => q{#f} ],
+ [ q{ (negative? 2) } => q{#f} ],
+ [ q{ (negative? -2) } => q{#t} ],
+ [ q{ (negative? +2) } => q{#f} ],
+ [ q{ (negative? 0.0) } => q{#f} ],
+ [ q{ (negative? -0.0) } => q{#f} ],
+ [ q{ (negative? +0.0) } => q{#f} ],
+ [ q{ (negative? 0.00000) } => q{#f} ],
+ [ q{ (negative? -0.00000) } => q{#f} ],
+ [ q{ (negative? +0.00000) } => q{#f} ],
+ [ q{ (negative? 0.000001) } => q{#f} ],
+ [ q{ (negative? -0.000001) } => q{#t} ],
+ [ q{ (negative? +0.000001) } => q{#f} ],
+
+ # odd?
+ [ q{ (odd? 0) } => q{#f} ],
+ [ q{ (odd? 1) } => q{#t} ],
+ [ q{ (odd? 2) } => q{#f} ],
+ [ q{ (odd? -3) } => q{#t} ],
+
+ # even?
+ [ q{ (even? 0) } => q{#t} ],
+ [ q{ (even? 1) } => q{#f} ],
+ [ q{ (even? 2) } => q{#t} ],
+ [ q{ (even? -3) } => q{#f} ],
+
+ # max
+ [ q{ (max 1 3) } => 3 ],
+ [ q{ (max 9 3 5) } => 9 ],
+ [ q{ (max 3 1) } => 3 ],
+ [ q{ (max 1 9 3) } => 9 ],
+
+ # min
+ [ q{ (min 1 3) } => 1 ],
+ [ q{ (min 9 3 5) } => 3 ],
+ [ q{ (min 3 1) } => 1 ],
+ [ q{ (min 1 9 3) } => 1 ],
+
+ # =
+ [ q{ (= 0 0) } => '#t' ],
+ [ q{ (= 1 0) } => '#f' ],
+ [ q{ (= 0 1) } => '#f' ],
+ [ q{ (= 0 0) } => '#t' ],
+ [ q{ (= 1 0) } => '#f' ],
+ [ q{ (= 0 1) } => '#f' ],
+
+ # <
+ [ q{ (< 0 1) } => '#t' ],
+ [ q{ (< 1 1) } => '#f' ],
+ [ q{ (< 0 1 2) } => '#t' ],
+ [ q{ (< 1 1 2) } => '#f' ],
+
+ # >
+ [ q{ (> 1 0) } => '#t' ],
+ [ q{ (> 1 1) } => '#f' ],
+ [ q{ (> 2 1 0) } => '#t' ],
+ [ q{ (> 2 1 1) } => '#f' ],
+
+ # <=
+ [ q{ (<= 0 0) } => '#t' ],
+ [ q{ (<= 1 0) } => '#f' ],
+ [ q{ (<= 1 2) } => '#t' ],
+ [ q{ (<= 2 1 0) } => '#f' ],
+ [ q{ (<= 2 1 1) } => '#f' ],
+
+ # >=
+ [ q{ (<= 2 3 3) } => '#t' ],
+ [ q{ (<= 2 3 2) } => '#f' ],
+);
+
+foreach ( @tests ) {
+ my ( $code, $expected ) = @{$_};
+
+ language_output_is( 'Scheme', qq{ (write $code) }, $expected, $code );
+}
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: scheme/trunk/t/arith/nested.t
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ scheme/trunk/t/arith/nested.t Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,71 @@
+#! perl
+# $Id$
+
+# Copyright (C) 2001-2007, Parrot Foundation.
+
+use strict;
+use warnings;
+use FindBin;
+use lib "$FindBin::Bin/../../lib";
+
+use Test::More tests => 8;
+use Parrot::Test;
+
+###
+### Add
+###
+
+language_output_is( 'Scheme', <<'CODE', 12, 'write (+ (+ 5 7))' );
+(write (+ (+ 5 7)))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', 11, 'write (+ (+ 3 -1) (+ 2 7))' );
+(write (+ (+ 3 -1) (+ 2 7)))
+CODE
+
+###
+### Subtract
+###
+
+language_output_is( 'Scheme', <<'CODE', 2, 'write (- (- 5 7))' );
+(write (- (- 5 7)))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', 9, 'write (- (- 3 -1) (- 2 7))' );
+(write (- (- 3 -1) (- 2 7)))
+CODE
+
+###
+### Multiply
+###
+
+language_output_is( 'Scheme', <<'CODE', 35, 'write (* (* 5 7))' );
+(write (* (* 5 7)))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', -42, 'write (* (* 3 -1) (* 2 7))' );
+(write (* (* 3 -1) (* 2 7)))
+CODE
+
+###
+### Divide
+###
+
+###
+### Abs
+###
+
+language_output_is( 'Scheme', <<'CODE', 8, 'abs (+ 3 5)' );
+(write (abs (+ 3 5)))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', 2, 'abs (- 3 5)' );
+(write (abs (- 3 5)))
+CODE
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: scheme/trunk/t/harness
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ scheme/trunk/t/harness Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,66 @@
+# $Id$
+
+=head1 NAME
+
+languages/scheme/t/harness - A harness for scheme
+
+=head1 SYNOPSIS
+
+ cd languages && perl -I../lib scheme/t/harness --files
+
+ cd languages && perl -I../lib scheme/t/harness
+
+ cd languages && perl -I../lib scheme/t/harness \
+ scheme/t/logic/basic.t \
+ scheme/t/logic/defines.t
+
+=head1 DESCRIPTION
+
+If I'm called with a single
+argument of "--files", I just return a list of files to process.
+This list is one per line, and is relative to the languages dir.
+
+If I'm called with no args, I run the complete suite.
+
+Otherwise I run the tests that were passed on the command line.
+
+=cut
+
+use strict;
+use FindBin;
+use lib "$FindBin::Bin/../../../lib", "$FindBin::Bin/..";;
+
+use Cwd();
+use File::Spec;
+use Test::Harness();
+
+my $language = 'scheme';
+
+if ( grep { m/^--files$/ } @ARGV ) {
+ # Only the Makefile in 'parrot/languages' uses --files
+ my $dir = File::Spec->catfile( $language, 't' );
+ my @files = glob( File::Spec->catfile( $dir, '*', '*.t' ) );
+ print join( "\n", @files );
+ print "\n" if scalar(@files);
+} else {
+ my @files;
+ if ( scalar(@ARGV) ) {
+ # Someone specified tests for me to run.
+ @files = grep { -f $_ } @ARGV
+ } else {
+ ( undef, undef, my $current_dir ) = File::Spec->splitpath( Cwd::getcwd() );
+ if ( $current_dir eq 'languages' ) {
+ @files = glob( File::Spec->catfile( $language, 't', '*', '*.t' ) );
+ }
+ elsif ( $current_dir eq $language ) {
+ @files = glob( File::Spec->catfile( 't', '*', '*.t' ) );
+ }
+ }
+ Test::Harness::runtests( @files ) if scalar( @files );
+}
+
+=head1 SEE ALSO
+
+F<languages/scheme/t/harness>, F<languages/python/t/harness>
+
+=cut
Added: scheme/trunk/t/io/basic.t
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ scheme/trunk/t/io/basic.t Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,95 @@
+#! perl
+# $Id$
+
+# Copyright (C) 2001-2007, Parrot Foundation.
+
+use strict;
+use warnings;
+use FindBin;
+use lib "$FindBin::Bin/../../lib";
+
+use Test::More tests => 17;
+use Parrot::Test;
+
+language_output_is( 'Scheme', <<'CODE', '0', 'write, one integer' );
+(write 0)
+CODE
+
+language_output_is( 'Scheme', <<'CODE', '01', 'write, two integers' );
+(write 0)
+(write 1)
+CODE
+
+language_output_is( 'Scheme', <<'CODE', q{"asdf"}, 'write, one string' );
+(write "asdf")
+CODE
+
+language_output_is( 'Scheme', <<'CODE', q{" hello world ! "}, 'write, with spaces' );
+(write " hello world ! ")
+CODE
+
+language_output_is( 'Scheme', <<'CODE', '0', 'display, one integer' );
+(display 0)
+CODE
+
+language_output_is( 'Scheme', <<'CODE', '01', 'display, two integers' );
+(display 0)
+(display 1)
+CODE
+
+language_output_is( 'Scheme', <<'CODE', 'asdf', 'display, one string' );
+(display "asdf")
+CODE
+
+language_output_is( 'Scheme', <<'CODE', 'Hello World ! ', 'display, with spaces' );
+(display "Hello World ! ")
+CODE
+
+language_output_is( 'Scheme', <<'CODE', "Hello World!\n", 'display, with newline' );
+(display "Hello World!\n")
+CODE
+
+language_output_is( 'Scheme', <<'CODE', "\n17\n", 'display, three strings' );
+(newline)
+(write 17)
+(newline)
+CODE
+
+##
+## Booleans
+##
+
+language_output_is( 'Scheme', <<'CODE', "#f", 'write #f' );
+(write #f)
+CODE
+
+language_output_is( 'Scheme', <<'CODE', "#f", 'display #f' );
+(display #f)
+CODE
+
+language_output_is( 'Scheme', <<'CODE', "#t", 'write #t' );
+(write #t)
+CODE
+
+language_output_is( 'Scheme', <<'CODE', "#t", 'display #t' );
+(display #t)
+CODE
+
+language_output_is( 'Scheme', <<'CODE', "#t", '(display ( = 12 ( + 6 6)))' );
+(display ( = 12 ( + 6 6)))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', "#f", '(display ( > 12 ( + 6 6)))' );
+(display ( > 12 ( + 6 6)))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', "#f", '(display ( < 12 ( + 6 6)))' );
+(display ( < 12 ( + 6 6)))
+CODE
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: scheme/trunk/t/logic/basic.t
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ scheme/trunk/t/logic/basic.t Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,232 @@
+#! perl
+# $Id$
+
+# Copyright (C) 2001-2007, Parrot Foundation.
+
+use strict;
+use warnings;
+use FindBin;
+use lib "$FindBin::Bin/../../lib";
+
+use Test::More tests => 416;
+
+use Parrot::Test;
+
+###
+### if
+###
+
+language_output_is( 'Scheme', <<'CODE', 1, 'basic if - Fail' );
+(write (if (= 1 1) 1 0))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', '"0 is true"', '0 is true' );
+(write (if 0 "0 is true" "0 is false" ))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', 1, 'basic if - Pass' );
+(write (if (= 0 1) 0 1))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', 7, 'slightly more complex if' );
+(write (if (= 9 9) 7 -23))
+CODE
+
+# base types
+# Every object is of exactly one base type
+{
+ # my @base_types
+ # = qw( boolean pair symbol char string vector procedure null );
+ my @base_types
+ = qw( boolean null number pair string );
+ my %object = (
+ boolean => [ q{#t},
+ q{#f},
+ q{(boolean? "hello")},
+ q{(= 42 42)},
+ q{(< 42 42)},
+ q{(> 42 42)},
+ ],
+ number => [ q{-1234567890},
+ q{-2},
+ q{-1},
+ q{-0},
+ q{0},
+ q{+0},
+ q{1},
+ q{+1},
+ q{2},
+ q{+2},
+ q{1234567890},
+ q{+1234567890},
+ q{-0.0},
+ q{-0.1},
+ q{0.0},
+ q{0.1},
+ q{+0.0},
+ q{+0.1},
+ q{(+ 1 1)},
+ q{(- 1 1)},
+ q{(if (= 1 1) 3 3)},
+ ],
+ null => [ q{(list)},
+ q{()},
+ ],
+ pair => [ q{(cons 1 3 )},
+ q{(cons 1 (cons 1 3 ) )},
+ q{(list 3 2 1)},
+ q{(list 1)},
+ ],
+ string => [ q{"hello"},
+ q{""},
+ ],
+ );
+
+ foreach my $predicate ( @base_types ) {
+ foreach my $expected_type ( @base_types ) {
+ foreach my $object ( @{ $object{$expected_type} } ) {
+ my ( $code, $expected );
+
+ $code = qq{ (write ($predicate? $object)) };
+ $expected = $predicate eq $expected_type ?
+ '#t'
+ :
+ '#f';
+ language_output_is( 'Scheme', $code, $expected, "expected_type: $code" );
+
+ $code = qq{ (write (if ($predicate? $object) "true" "false")) };
+ $expected = $predicate eq $expected_type ?
+ '"true"'
+ :
+ '"false"';
+ language_output_is( 'Scheme', $code, $expected, $code );
+ }
+ }
+ }
+}
+
+# numeric tower
+# Testing numeric types.
+# Tests for types that are higher than $lowest_type are true.
+# Tests for the $lowest_type are true.
+# Tests for types that are lower than $lowest_type are false.
+{
+ my @numeric_types = qw(number complex real rational integer ); # high to low
+ my %object = (
+ number => [
+ ],
+ complex => [ q{0+3i},
+ q{3+4i},
+ q{3+4i},
+ ],
+ real => [
+ ],
+ rational => [
+ ],
+ integer => [ -1,
+ -0,
+ 0,
+ +0,
+ +1,
+ 1
+ ]
+ );
+
+ foreach my $lowest_type ( @numeric_types ) {
+ my $expected = '#t';
+ foreach my $predicate ( @numeric_types ) {
+ foreach my $object ( @{ $object{$lowest_type} } ) {
+ my $code = qq{ (write ($predicate? $object)) };
+ language_output_is( 'Scheme', $code, $expected, "expected_type: $code" );
+ }
+ if ( $predicate eq $lowest_type ) { $expected = '#f'; }
+ }
+ }
+}
+
+###
+### and
+###
+
+language_output_is( 'Scheme', <<'CODE', 0, 'and 0' );
+(write (and 0))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', 1, 'and 1' );
+(write (and 1))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', '#t', 'and many #t' );
+(write (and #t #t #t #t #t #t 2 #t 1 #t))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', 3, 'basic and' );
+(write (and 1 3))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', 1, 'basic and' );
+(write (and 0 1))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', 0, 'basic and' );
+(write (and 3 2 1 0))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', 6, 'basic and' );
+(write (and 1 2 3 4 5 6))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', 4, 'and, 0 is true' );
+(write (and 0 4))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', '#f', 'and, 0 is true' );
+(write (and 1 2 #f 4))
+CODE
+
+###
+### or
+###
+
+language_output_is( 'Scheme', <<'CODE', 1, 'basic or - Pass' );
+(write (or 1 1))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', 0, 'basic or - Fail' );
+(write (or 0 0))
+CODE
+
+###
+### not
+###
+
+language_output_is( 'Scheme', <<'CODE', '#f', 'not 1' );
+(write (not 1))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', '#t', 'not #f' );
+(write (not #f))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', '#f', 'not 0' );
+(write (not 0))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', '#f', 'not #t' );
+(write (not #t))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', '#f', 'not true expression' );
+(write (not (= 42 (* 21 2))))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', '#t', 'not false expression' );
+(write (not (= 43 (* 21 2))))
+CODE
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: scheme/trunk/t/logic/defines.t
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ scheme/trunk/t/logic/defines.t Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,116 @@
+#! perl
+# $Id$
+
+# Copyright (C) 2002-2007, Parrot Foundation.
+
+use strict;
+use warnings;
+use FindBin;
+use lib "$FindBin::Bin/../../lib";
+
+use Test::More tests => 12;
+use Parrot::Test;
+
+language_output_is( 'Scheme', <<'CODE', 'a', 'a symbol' );
+(write 'a) ; for emacs ')
+CODE
+
+language_output_is( 'Scheme', <<'CODE', '5', 'define' );
+(define a 5)
+(write a)
+CODE
+
+language_output_is( 'Scheme', <<'CODE', '5', 'define II' );
+(define a 4)
+(define b (+ a 1))
+(write b)
+CODE
+
+language_output_is( 'Scheme', <<'CODE', '8', 'set!' );
+(define a 5)
+(set! a 8)
+(write a)
+CODE
+
+language_output_is( 'Scheme', <<'CODE', '13', 'set! II' );
+(define a 5)
+(set! a (+ a 8))
+(write a)
+CODE
+
+language_output_is( 'Scheme', <<'CODE', '(18 17)', 'define function' );
+(define (f a b) (list b a))
+(write (f 17 18))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', '3', 'define via lambda' );
+(define sum (lambda (a b) (+ a b)))
+(write (sum 1 2))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', '101', 'let' );
+(let ((a 1))
+ (write a)
+ (let ((a 0)
+ (b 0))
+ (write a))
+ (write a))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', '321', 'counter' );
+(define (make-counter val)
+ (lambda ()
+ (set! val (- val 1))
+ val)
+)
+(define counter (make-counter 4))
+(write (counter))
+(write (counter))
+(write (counter))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', '9837', '2 counter' );
+(define (make-counter val)
+ (lambda ()
+ (set! val (- val 1))
+ val)
+)
+(define ci (make-counter 10))
+(write (ci))
+(define cii (make-counter 4))
+(write (ci))
+(write (cii))
+(write (ci))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', '012023', 'yet another counter' );
+(define (make-counter incr)
+ (let ((val 0))
+ (lambda ()
+ (let ((ret val))
+ (set! val (+ incr val))
+ ret))))
+(define ci (make-counter 1))
+(write (ci))
+(write (ci))
+(define cii (make-counter 2))
+(write (ci))
+(write (cii))
+(write (cii))
+(write (ci))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', '120', 'fakultaet' );
+(define (fak n)
+ (if (= n 0)
+ 1
+ (* n (fak (- n 1)))))
+(write (fak 5))
+CODE
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: scheme/trunk/t/logic/lists.t
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ scheme/trunk/t/logic/lists.t Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,124 @@
+#! perl
+# $Id$
+
+# Copyright (C) 2002-2007, Parrot Foundation.
+
+use strict;
+use warnings;
+use FindBin;
+use lib "$FindBin::Bin/../../lib";
+
+use Test::More tests => 21;
+use Parrot::Test;
+
+language_output_is( 'Scheme', <<'CODE', '(2 . 5)', 'cons' );
+(write (cons 2 5))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', '((2 . 3) . 4)', 'cons car' );
+(write (cons (cons 2 3) 4))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', '(2 3 . 4)', 'cons cdr' );
+(write (cons 2 (cons 3 4)))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', '((1 . 2) 3 . 4)', 'complex cons' );
+(write
+ (cons
+ (cons 1 2)
+ (cons 3 4)))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', '(3 2 1 0)', 'list' );
+(write
+ (list 3 2 1 0))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', '(1 2 3)', 'lists the hard way' );
+(write
+ (cons 1
+ (cons 2
+ (cons 3
+ (list)))))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', '4', 'length' );
+(write
+ (length (list 3 2 1 0)))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', '2', 'car' );
+(write
+ (car (list 2 1 0)))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', '(1 0)', 'cdr' );
+(write
+ (cdr (list 2 1 0)))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', '(4 2 3)', 'set-car!' );
+(write
+ (set-car! (list 1 2 3) 4))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', '((4 . 2) 2 3)', 'set-car! II' );
+(write
+ (set-car! (list 1 2 3) (cons 4 2)))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', '(1 4 2)', 'set-cdr!' );
+(write
+ (set-cdr! (list 1 2 3) (list 4 2)))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', '(1 2 3 4)', 'quoted list' );
+(write '(1 2 3 4)) ; for emacs ')
+CODE
+
+language_output_is( 'Scheme', <<'CODE', '()', "'()" );
+(write '()) ; for emacs ')
+CODE
+
+language_output_is( 'Scheme', <<'CODE', '(1 2 (3 4))', 'complex list' );
+(write
+ '(1 2 (3 4))) ; for emacs ')
+CODE
+
+language_output_is( 'Scheme', <<'CODE', '(1 2 (3 4))', 'complex list II' );
+(write
+ (list 1 2 (list 3 4)))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', '(list 3 4)', 'quasiquote' );
+(write
+ `(list ,(+ 1 2) 4))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', '(quasiquote (list (unquote (+ 1 2)) 4))', 'quoted quasiquote' );
+(write
+ '`(list ,(+ 1 2) 4))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', '(list 1 2 3)', 'unquote-splicing' );
+(write
+ `(list ,@(list 1 2 3)))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', '(list)', 'splicing empty list' );
+(write
+ `(list ,@(list)))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', '(list 1 2 3 (4 5))', 'complex quasiquote' );
+(write
+ `(list ,@(list 1 2) ,(+ 1 2) ,(list 4 5)))
+CODE
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: scheme/trunk/t/syn/basic.t
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ scheme/trunk/t/syn/basic.t Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,44 @@
+#! perl
+# $Id$
+
+# Copyright (C) 2007, Parrot Foundation.
+
+use strict;
+use warnings;
+use FindBin;
+use lib "$FindBin::Bin/../../lib";
+
+use Parrot::Test tests => 6;
+
+# begin
+
+language_output_is( 'Scheme', <<'CODE', q{}, 'string, no sideeffects' );
+"Hello World!"
+CODE
+
+language_output_is( 'Scheme', <<'CODE', q{}, 'string, no sideeffects' );
++12345678
+CODE
+
+language_output_is( 'Scheme', <<'CODE', q{}, 'string, no sideeffects' );
+12345678
+CODE
+
+language_output_is( 'Scheme', <<'CODE', q{}, 'string, no sideeffects' );
+-12345678
+CODE
+
+language_output_is( 'Scheme', <<'CODE', q{}, 'string, no sideeffects' );
+#t
+CODE
+
+language_output_is( 'Scheme', <<'CODE', q{}, 'string, no sideeffects' );
+#f
+CODE
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: scheme/trunk/t/syn/begin.t
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ scheme/trunk/t/syn/begin.t Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,97 @@
+#! perl
+# $Id$
+
+# Copyright (C) 2007, Parrot Foundation.
+
+use strict;
+use warnings;
+use FindBin;
+use lib "$FindBin::Bin/../../lib";
+
+use Parrot::Test tests => 7;
+
+# begin
+
+language_output_is( 'Scheme', <<'CODE', 1, 'begin 1 subexpression' );
+(begin
+ (write 1))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', 1, 'no begin 1 subexpression' );
+ (write 1)
+CODE
+
+language_output_is( 'Scheme', <<'CODE', 12, 'no begin 2 subexpression' );
+(begin
+ (write 1)
+ (write 2))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', 12, 'no begin 2 subexpression' );
+ (write 1)
+ (write 2)
+CODE
+
+language_output_is( 'Scheme', <<'CODE', '12333333333333333333333', 'begin 23 subexpression' );
+(begin
+ (write 1)
+ (write 2)
+ (write 3)
+ (write 3)
+ (write 3)
+ (write 3)
+ (write 3)
+ (write 3)
+ (write 3)
+ (write 3)
+ (write 3)
+ (write 3)
+ (write 3)
+ (write 3)
+ (write 3)
+ (write 3)
+ (write 3)
+ (write 3)
+ (write 3)
+ (write 3)
+ (write 3)
+ (write 3)
+ (write 3))
+CODE
+
+language_output_is( 'Scheme', <<'CODE', '12333333333333333333333', 'no begin 23 subexpression' );
+ (write 1)
+ (write 2)
+ (write 3)
+ (write 3)
+ (write 3)
+ (write 3)
+ (write 3)
+ (write 3)
+ (write 3)
+ (write 3)
+ (write 3)
+ (write 3)
+ (write 3)
+ (write 3)
+ (write 3)
+ (write 3)
+ (write 3)
+ (write 3)
+ (write 3)
+ (write 3)
+ (write 3)
+ (write 3)
+ (write 3)
+CODE
+
+language_output_is( 'Scheme', <<'CODE', '6', 'nested begins' );
+(begin ( begin ( begin ( begin ( begin ( write (* 2 3 ) ))))))
+CODE
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: urm/trunk/INSTALL
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ urm/trunk/INSTALL Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,13 @@
+# $Id$
+
+For installing URM there is fot very much to do:
+Try
+ make test
+to see if your perl is capable of running urmc.
+Then try to build the examples:
+ make examples
+You'll end up with a bunch of pasm files in the
+examples dir.
+
+Have fun,
+ Marcus (marcus at cpan.org)
Added: urm/trunk/LICENSE
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ urm/trunk/LICENSE Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,340 @@
+ GNU GENERAL PUBLIC LICENSE
+ Version 2, June 1991
+
+ Copyright (C) 1989, 1991 Free Software Foundation, Inc.
+ 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+ Preamble
+
+ The licenses for most software are designed to take away your
+freedom to share and change it. By contrast, the GNU General Public
+License is intended to guarantee your freedom to share and change free
+software--to make sure the software is free for all its users. This
+General Public License applies to most of the Free Software
+Foundation's software and to any other program whose authors commit to
+using it. (Some other Free Software Foundation software is covered by
+the GNU Library General Public License instead.) You can apply it to
+your programs, too.
+
+ When we speak of free software, we are referring to freedom, not
+price. Our General Public Licenses are designed to make sure that you
+have the freedom to distribute copies of free software (and charge for
+this service if you wish), that you receive source code or can get it
+if you want it, that you can change the software or use pieces of it
+in new free programs; and that you know you can do these things.
+
+ To protect your rights, we need to make restrictions that forbid
+anyone to deny you these rights or to ask you to surrender the rights.
+These restrictions translate to certain responsibilities for you if you
+distribute copies of the software, or if you modify it.
+
+ For example, if you distribute copies of such a program, whether
+gratis or for a fee, you must give the recipients all the rights that
+you have. You must make sure that they, too, receive or can get the
+source code. And you must show them these terms so they know their
+rights.
+
+ We protect your rights with two steps: (1) copyright the software, and
+(2) offer you this license which gives you legal permission to copy,
+distribute and/or modify the software.
+
+ Also, for each author's protection and ours, we want to make certain
+that everyone understands that there is no warranty for this free
+software. If the software is modified by someone else and passed on, we
+want its recipients to know that what they have is not the original, so
+that any problems introduced by others will not reflect on the original
+authors' reputations.
+
+ Finally, any free program is threatened constantly by software
+patents. We wish to avoid the danger that redistributors of a free
+program will individually obtain patent licenses, in effect making the
+program proprietary. To prevent this, we have made it clear that any
+patent must be licensed for everyone's free use or not licensed at all.
+
+ The precise terms and conditions for copying, distribution and
+modification follow.
+
+ GNU GENERAL PUBLIC LICENSE
+ TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
+
+ 0. This License applies to any program or other work which contains
+a notice placed by the copyright holder saying it may be distributed
+under the terms of this General Public License. The "Program", below,
+refers to any such program or work, and a "work based on the Program"
+means either the Program or any derivative work under copyright law:
+that is to say, a work containing the Program or a portion of it,
+either verbatim or with modifications and/or translated into another
+language. (Hereinafter, translation is included without limitation in
+the term "modification".) Each licensee is addressed as "you".
+
+Activities other than copying, distribution and modification are not
+covered by this License; they are outside its scope. The act of
+running the Program is not restricted, and the output from the Program
+is covered only if its contents constitute a work based on the
+Program (independent of having been made by running the Program).
+Whether that is true depends on what the Program does.
+
+ 1. You may copy and distribute verbatim copies of the Program's
+source code as you receive it, in any medium, provided that you
+conspicuously and appropriately publish on each copy an appropriate
+copyright notice and disclaimer of warranty; keep intact all the
+notices that refer to this License and to the absence of any warranty;
+and give any other recipients of the Program a copy of this License
+along with the Program.
+
+You may charge a fee for the physical act of transferring a copy, and
+you may at your option offer warranty protection in exchange for a fee.
+
+ 2. You may modify your copy or copies of the Program or any portion
+of it, thus forming a work based on the Program, and copy and
+distribute such modifications or work under the terms of Section 1
+above, provided that you also meet all of these conditions:
+
+ a) You must cause the modified files to carry prominent notices
+ stating that you changed the files and the date of any change.
+
+ b) You must cause any work that you distribute or publish, that in
+ whole or in part contains or is derived from the Program or any
+ part thereof, to be licensed as a whole at no charge to all third
+ parties under the terms of this License.
+
+ c) If the modified program normally reads commands interactively
+ when run, you must cause it, when started running for such
+ interactive use in the most ordinary way, to print or display an
+ announcement including an appropriate copyright notice and a
+ notice that there is no warranty (or else, saying that you provide
+ a warranty) and that users may redistribute the program under
+ these conditions, and telling the user how to view a copy of this
+ License. (Exception: if the Program itself is interactive but
+ does not normally print such an announcement, your work based on
+ the Program is not required to print an announcement.)
+
+These requirements apply to the modified work as a whole. If
+identifiable sections of that work are not derived from the Program,
+and can be reasonably considered independent and separate works in
+themselves, then this License, and its terms, do not apply to those
+sections when you distribute them as separate works. But when you
+distribute the same sections as part of a whole which is a work based
+on the Program, the distribution of the whole must be on the terms of
+this License, whose permissions for other licensees extend to the
+entire whole, and thus to each and every part regardless of who wrote it.
+
+Thus, it is not the intent of this section to claim rights or contest
+your rights to work written entirely by you; rather, the intent is to
+exercise the right to control the distribution of derivative or
+collective works based on the Program.
+
+In addition, mere aggregation of another work not based on the Program
+with the Program (or with a work based on the Program) on a volume of
+a storage or distribution medium does not bring the other work under
+the scope of this License.
+
+ 3. You may copy and distribute the Program (or a work based on it,
+under Section 2) in object code or executable form under the terms of
+Sections 1 and 2 above provided that you also do one of the following:
+
+ a) Accompany it with the complete corresponding machine-readable
+ source code, which must be distributed under the terms of Sections
+ 1 and 2 above on a medium customarily used for software interchange; or,
+
+ b) Accompany it with a written offer, valid for at least three
+ years, to give any third party, for a charge no more than your
+ cost of physically performing source distribution, a complete
+ machine-readable copy of the corresponding source code, to be
+ distributed under the terms of Sections 1 and 2 above on a medium
+ customarily used for software interchange; or,
+
+ c) Accompany it with the information you received as to the offer
+ to distribute corresponding source code. (This alternative is
+ allowed only for noncommercial distribution and only if you
+ received the program in object code or executable form with such
+ an offer, in accord with Subsection b above.)
+
+The source code for a work means the preferred form of the work for
+making modifications to it. For an executable work, complete source
+code means all the source code for all modules it contains, plus any
+associated interface definition files, plus the scripts used to
+control compilation and installation of the executable. However, as a
+special exception, the source code distributed need not include
+anything that is normally distributed (in either source or binary
+form) with the major components (compiler, kernel, and so on) of the
+operating system on which the executable runs, unless that component
+itself accompanies the executable.
+
+If distribution of executable or object code is made by offering
+access to copy from a designated place, then offering equivalent
+access to copy the source code from the same place counts as
+distribution of the source code, even though third parties are not
+compelled to copy the source along with the object code.
+
+ 4. You may not copy, modify, sublicense, or distribute the Program
+except as expressly provided under this License. Any attempt
+otherwise to copy, modify, sublicense or distribute the Program is
+void, and will automatically terminate your rights under this License.
+However, parties who have received copies, or rights, from you under
+this License will not have their licenses terminated so long as such
+parties remain in full compliance.
+
+ 5. You are not required to accept this License, since you have not
+signed it. However, nothing else grants you permission to modify or
+distribute the Program or its derivative works. These actions are
+prohibited by law if you do not accept this License. Therefore, by
+modifying or distributing the Program (or any work based on the
+Program), you indicate your acceptance of this License to do so, and
+all its terms and conditions for copying, distributing or modifying
+the Program or works based on it.
+
+ 6. Each time you redistribute the Program (or any work based on the
+Program), the recipient automatically receives a license from the
+original licensor to copy, distribute or modify the Program subject to
+these terms and conditions. You may not impose any further
+restrictions on the recipients' exercise of the rights granted herein.
+You are not responsible for enforcing compliance by third parties to
+this License.
+
+ 7. If, as a consequence of a court judgment or allegation of patent
+infringement or for any other reason (not limited to patent issues),
+conditions are imposed on you (whether by court order, agreement or
+otherwise) that contradict the conditions of this License, they do not
+excuse you from the conditions of this License. If you cannot
+distribute so as to satisfy simultaneously your obligations under this
+License and any other pertinent obligations, then as a consequence you
+may not distribute the Program at all. For example, if a patent
+license would not permit royalty-free redistribution of the Program by
+all those who receive copies directly or indirectly through you, then
+the only way you could satisfy both it and this License would be to
+refrain entirely from distribution of the Program.
+
+If any portion of this section is held invalid or unenforceable under
+any particular circumstance, the balance of the section is intended to
+apply and the section as a whole is intended to apply in other
+circumstances.
+
+It is not the purpose of this section to induce you to infringe any
+patents or other property right claims or to contest validity of any
+such claims; this section has the sole purpose of protecting the
+integrity of the free software distribution system, which is
+implemented by public license practices. Many people have made
+generous contributions to the wide range of software distributed
+through that system in reliance on consistent application of that
+system; it is up to the author/donor to decide if he or she is willing
+to distribute software through any other system and a licensee cannot
+impose that choice.
+
+This section is intended to make thoroughly clear what is believed to
+be a consequence of the rest of this License.
+
+ 8. If the distribution and/or use of the Program is restricted in
+certain countries either by patents or by copyrighted interfaces, the
+original copyright holder who places the Program under this License
+may add an explicit geographical distribution limitation excluding
+those countries, so that distribution is permitted only in or among
+countries not thus excluded. In such case, this License incorporates
+the limitation as if written in the body of this License.
+
+ 9. The Free Software Foundation may publish revised and/or new versions
+of the General Public License from time to time. Such new versions will
+be similar in spirit to the present version, but may differ in detail to
+address new problems or concerns.
+
+Each version is given a distinguishing version number. If the Program
+specifies a version number of this License which applies to it and "any
+later version", you have the option of following the terms and conditions
+either of that version or of any later version published by the Free
+Software Foundation. If the Program does not specify a version number of
+this License, you may choose any version ever published by the Free Software
+Foundation.
+
+ 10. If you wish to incorporate parts of the Program into other free
+programs whose distribution conditions are different, write to the author
+to ask for permission. For software which is copyrighted by the Free
+Software Foundation, write to the Free Software Foundation; we sometimes
+make exceptions for this. Our decision will be guided by the two goals
+of preserving the free status of all derivatives of our free software and
+of promoting the sharing and reuse of software generally.
+
+ NO WARRANTY
+
+ 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
+FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
+OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
+PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
+OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS
+TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE
+PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
+REPAIR OR CORRECTION.
+
+ 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
+REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
+INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
+OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
+TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
+YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
+PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGES.
+
+ END OF TERMS AND CONDITIONS
+
+ How to Apply These Terms to Your New Programs
+
+ If you develop a new program, and you want it to be of the greatest
+possible use to the public, the best way to achieve this is to make it
+free software which everyone can redistribute and change under these terms.
+
+ To do so, attach the following notices to the program. It is safest
+to attach them to the start of each source file to most effectively
+convey the exclusion of warranty; and each file should have at least
+the "copyright" line and a pointer to where the full notice is found.
+
+ <one line to give the program's name and a brief idea of what it does.>
+ Copyright (C) <year> <name of author>
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+
+Also add information on how to contact you by electronic and paper mail.
+
+If the program is interactive, make it output a short notice like this
+when it starts in an interactive mode:
+
+ Gnomovision version 69, Copyright (C) year name of author
+ Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
+ This is free software, and you are welcome to redistribute it
+ under certain conditions; type `show c' for details.
+
+The hypothetical commands `show w' and `show c' should show the appropriate
+parts of the General Public License. Of course, the commands you use may
+be called something other than `show w' and `show c'; they could even be
+mouse-clicks or menu items--whatever suits your program.
+
+You should also get your employer (if you work as a programmer) or your
+school, if any, to sign a "copyright disclaimer" for the program, if
+necessary. Here is a sample; alter the names:
+
+ Yoyodyne, Inc., hereby disclaims all copyright interest in the program
+ `Gnomovision' (which makes passes at compilers) written by James Hacker.
+
+ <signature of Ty Coon>, 1 April 1989
+ Ty Coon, President of Vice
+
+This General Public License does not permit incorporating your program into
+proprietary programs. If your program is a subroutine library, you may
+consider it more useful to permit linking proprietary applications with the
+library. If this is what you want to do, use the GNU Library General
+Public License instead of this License.
Added: urm/trunk/MAINTAINER
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ urm/trunk/MAINTAINER Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,4 @@
+# $Id$
+
+N: Marcus Thiesen
+E: marcus at cpan.org
Added: urm/trunk/README
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ urm/trunk/README Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,151 @@
+# $Id$
+
+urmc - an URM compiler for Parrot
+
+2003 (c) by Marcus Thiesen <marcus at cpan.org>
+
+What is URM?
+============
+
+URM is a "language" at least used in German universities to teach the
+basic principles of programming. URM stands for Universal Register
+Machine - it basically means that you have a couple of operations and
+an unlimited amount of registers to use for your programs.
+See Syntax for a description
+
+Why a compiler?
+===============
+
+You might know that it is quite boring to program with pen and paper,
+at least if you're not debugging some screwed up C code but just some
+examples for your upcoming exam. So, I didn't want to learn and I
+wrote a compiler - in Perl. It wasn't really a compiler, just some
+regexes and eval commands. It had one problem - it was slow.
+
+So I dropped it and didn't think about it for a year now. Enter
+Acme. He gave quite a good talk on YAPC::EU 2003 about "Little
+languages in Parrot" and I dreamt of rewriting my URM compiler to run
+on Parrot. So here it is! :-)
+
+Usage
+=====
+
+The urm compiler (urmc) has some command line arguments and operation modes.
+One is to simply call it with
+ ./urmc somefile.urm
+and it will compile it to a temporary pasm (Parrot Assembly) file and
+try to execute this file with your Parrot installation.
+
+The other one mode is if you call it with
+ ./urmc -c somefile.urm
+it will create a pasm file called somefile.pasm which you can execute
+by hand with your parrot installation.
+The URM standard is rather strict (see Syntax) and therefore does not
+allow some operation which are easy to implement (e.g. writing r1 <-
+r2 + 1). I allowed these options but throw a warning every time you
+violate the standard. If you don't like these warnings you can say
+ ./urmc -s somefile.urm
+which will not give any warnings.
+
+
+Overall Syntax
+==============
+
+URM is rather simple - if you're an assembler programmer :-)
+
+At the beginning of each file you got to have two lines, defining the
+input and output registers of your program:
+ in (r1,r2)
+ out (r3)
+You can have as many input registers as you like (delimited by ",")
+but only one output register.
+
+Code lines are always preceded by their logical line number (not the
+actual line number in the file) which are addressed in the goto
+control flow statements.
+
+Register Naming
+===============
+Registers hold ints, i.e. one plain decimal number
+
+Registers are always named with a beginning r followed by a
+digit to identify it:
+ r1
+ r537
+ r249343
+
+Branching
+==========
+The URM knows two operations to modify the program flow.
+The unconditioned branching is a simple goto followed by a logical
+line number:
+ goto 5
+ goto 72
+
+To get a conditioned branch you can only test if a register is 0:
+ if r3 = 0 goto 37
+ if r5 = 0 goto 1
+
+These are the only control flow commands.
+
+Operations
+==========
+The URM knows three operations:
+1. Initialize a register with zero:
+ r3 <- 0
+This is believed to be optional, therefore it is only for good style
+in my examples.
+(Really, we were told that the registers are believed to be in a state
+of 0, but we had to initialize them)
+
+2. Add 1 to a register
+To add a number to a register you can execute
+ r4 <- r4 + 1
+Note: The register number before and after the <- must match, you can
+not directly add one register to another.
+
+Note: You can only add 1 to a register.
+
+3. Subtract 1 from a register
+Guess what:
+ r4 <- r4 - 1
+Note: The same rules as for adding, only operate on one register and
+only subtract 1.
+
+Program End
+===========
+To end a program, you have to jump to a nonexistent line behind the
+end of the code. If your code has e.g. 14 logical lines a
+ goto 15
+will end the program and output the value of the output register.
+
+See the files in the examples/ directory for some examples.
+
+Last Notes
+==========
+
+The compiler is written in Perl and uses only basic features of this
+language, so it shouldn't have such a huge version requirement.
+
+Prerequisites
+=============
+Getopt::Long is needed for urmc
+Parrot to actually execute the code.
+
+License
+=======
+This stuff is all GPL, see LICENSE
+
+Debugging
+=========
+I included my original URM compiler as urm-old.pl. As it is very slow
+I don't recommend using it, but it outputs the whole program flow to
+STDOUT. Maybe you can use it as a debugging help.
+
+Have fun
+ Marcus
+
+P.S.:
+It took me about 20 minutes in that exam to figure out how to get a
+sum from 1 to n-1 over n right in URM. Try it yourself.
+
Added: urm/trunk/config/makefiles/root.in
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ urm/trunk/config/makefiles/root.in Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,68 @@
+# Copyright (C) 2003-2009, Parrot Foundation.
+# $Id$
+
+# Makefile for languages/urm
+
+# Setup of some commands
+RM_F = @rm_f@
+PERL = @perl@
+PARROT = ../../parrot at exe@
+BUILD_DIR = @build_dir@
+RECONFIGURE = $(PERL) @build_dir@/tools/dev/reconfigure.pl
+#CONDITIONED_LINE(darwin):
+#CONDITIONED_LINE(darwin):# MACOSX_DEPLOYMENT_TARGET must be defined for OS X compilation/linking
+#CONDITIONED_LINE(darwin):export MACOSX_DEPLOYMENT_TARGET := @osx_version@
+
+default: build
+
+help :
+ @echo ""
+ @echo "Following targets are available for the user:"
+ @echo ""
+ @echo " build: Just check whether 'urmc' compiles"
+ @echo " This is the default."
+ @echo ""
+ @echo " test: run the test suite,"
+ @echo ""
+ @echo " clean: clean up temporary files"
+ @echo ""
+ @echo " realclean: clean up generated files"
+ @echo ""
+ @echo " help: print this help message"
+
+# regenerate the Makefile
+Makefile: config/makefiles/root.in
+ cd $(BUILD_DIR) && $(RECONFIGURE) --step=gen::languages --languages=urm
+
+test: build
+ cd .. && $(PERL) -I../lib urm/t/harness
+
+examples: build
+ $(PERL) urmc -c examples/biggerzero.urm
+ $(PERL) urmc -c examples/sub.urm
+ $(PERL) urmc -c examples/sim.urm
+ $(PERL) urmc -c examples/mult.urm
+ $(PERL) urmc -c examples/div.urm
+ $(PERL) urmc -c examples/distance.urm
+
+build:
+ $(PERL) -c urmc
+
+clean:
+ $(RM_F) \
+ core "*.pbc" "*~" "foo.p*" \
+ "*~" "*.pasm" \
+ "*~" \
+ "\#*" \
+ "examples/*.pasm" "examples/*.pbc" \
+ "examples/*~" \
+ "examples/\#*" \
+ "t/*.pasm" "t/*.urm" "t/*.out"
+
+realclean: clean
+ $(RM_F) Makefile
+
+# Local variables:
+# mode: makefile
+# End:
+# vim: ft=make:
Added: urm/trunk/examples/biggerzero.urm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ urm/trunk/examples/biggerzero.urm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,16 @@
+# 2003 (c) by Marcus Thiesen
+# <marcus at cpan.org>
+# This program is under GPL
+# See the LICENSE file
+### This program outputs 1
+### if both numbers are greater
+### than zero
+
+in(r1,r2)
+out(r3)
+
+1: r3 <- 0
+2: if r1 = 0 goto 8
+3: if r2 = 0 goto 8
+4: r3 <- r3 + 1
+
Added: urm/trunk/examples/distance.urm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ urm/trunk/examples/distance.urm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,26 @@
+# 2003 (c) by Marcus Thiesen
+# <marcus at cpan.org>
+# This program is under GPL
+# See the LICENSE file
+### This URM program
+### computes the distance
+### between two numbers
+
+in(r1,r2)
+
+1: if r1 = 0 goto 6
+2: if r2 = 0 goto 6
+3: r1 <- r1 - 1
+4: r2 <- r2 - 1
+5: goto 1
+6: if r1 = 0 goto 11
+7: if r1 = 0 goto 15
+8: r1 <- r1 - 1
+9: r3 <- r3 + 1
+10: goto 7
+11: if r2 = 0 goto 15
+12: r2 <- r2 - 1
+13: r3 <- r3 + 1
+14: goto 11
+
+out(r3)
Added: urm/trunk/examples/div.urm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ urm/trunk/examples/div.urm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,25 @@
+# 2003 (c) by Marcus Thiesen
+# <marcus at cpan.org>
+# This program is under GPL
+# See the LICENSE file
+### Division in URM
+### divides r1 by rw and
+### outputs r3
+
+in(r1,r2);
+out(r3);
+
+1: r3 <- 0
+2: r4 <- 0
+3: if r2 = 0 goto 7
+4: r2 <- r2 - 1
+5: r4 <- r4 + 1
+6: goto 3
+7: if r4 = 0 goto 13
+8: if r1 = 0 goto 15
+9: r1 <- r1 - 1
+10: r4 <- r4 - 1
+11: r2 <- r2 + 1
+12: goto 7
+13: r3 <- r3 + 1
+14: goto 3
Added: urm/trunk/examples/mult.urm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ urm/trunk/examples/mult.urm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,23 @@
+# 2003 (c) by Marcus Thiesen
+# <marcus at cpan.org>
+# This program is under GPL
+# See the LICENSE file
+### Multiplikation in URM
+
+in(r1,r2)
+out(r3)
+
+1: r3 <- 0
+2: r4 <- 0
+3: if r2 = 0 goto 15
+4: if r1 = 0 goto 8
+5: r1 <- r1 - 1
+6: r4 <- r4 + 1
+7: goto 4
+8: if r4 = 0 goto 13
+9: r4 <- r4 - 1
+10: r3 <- r3 + 1
+11: r1 <- r1 + 1
+12: goto 8
+13: r2 <- r2 - 1
+14: goto 3
Added: urm/trunk/examples/sim.urm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ urm/trunk/examples/sim.urm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,20 @@
+# 2003 (c) by Marcus Thiesen
+# <marcus at cpan.org>
+# This program is under GPL
+# See the LICENSE file
+### Tests if r1 and r2 are identical
+
+in(r1,r2)
+out(r3)
+
+1: r3 <- 0
+2: r3 <- r3 + 1
+3: if r1 = 0 goto 7
+4: if r2 = 0 goto 8
+5: r1 <- r1 - 1
+6: r2 <- r2 - 1
+7: goto 2
+8: if r2 = 0 goto 11
+9: r3 <- 0
+10: if r1 = 0 goto 11
+11: r3 <- 0
Added: urm/trunk/examples/sub.urm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ urm/trunk/examples/sub.urm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,15 @@
+# 2003 (c) by Marcus Thiesen
+# <marcus at cpan.org>
+# This program is under GPL
+# See the LICENSE file
+### Substracts r2 from r1
+
+in(r1,r2)
+out(r1)
+
+
+1: if r1 = 0 goto 6
+2: if r2 = 0 goto 6
+3: r1 <- r1 - 1
+4: r2 <- r2 - 1
+5: goto 1
Added: urm/trunk/lib/URM/Test.pm
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ urm/trunk/lib/URM/Test.pm Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,109 @@
+# $Id$
+
+# Copyright (C) 2005-2008, Parrot Foundation.
+
+package URM::Test;
+
+use strict;
+use warnings;
+use vars qw(@EXPORT @ISA);
+
+use Parrot::Config;
+
+require Exporter;
+require Parrot::Test;
+
+ at EXPORT = ( qw(output_is output_like output_isnt), @Test::More::EXPORT );
+ at ISA = qw(Exporter Test::More);
+
+sub import {
+ my ( $class, $plan, @args ) = @_;
+
+ Test::More->import( $plan, @args );
+
+ # __PACKAGE__->_export_to_level( 2, __PACKAGE__ );
+ my $callpkg = caller(2);
+ __PACKAGE__->export($callpkg);
+}
+
+my $count;
+
+foreach my $meth (qw(is isnt like)) {
+ no strict 'refs';
+
+ *{"URM::Test::output_$meth"} = sub {
+ my ( $lang_code, $output, $desc, @other ) = @_;
+
+ ++$count;
+ my ( $lang_f, $pasm_f, $by_f, $out_f ) = map { # JMG
+ my $t = $0;
+ $t =~ s/\.t$/_$count\.$_/;
+ $t
+ } (qw(urm pasm pbc out)); # JMG
+
+ # STDERR is written into same output file
+ open LANG, ">", "$lang_f" or die "Unable to open '$lang_f'"; # JMG
+ binmode LANG; # JMG
+ print LANG $lang_code; # JMG
+ close LANG; # JMG
+
+ Parrot::Test::run_command(
+ "$PConfig{perl} languages/urm/urmc -s languages/$lang_f",
+ CD => '..', # $self->{relpath},
+ STDOUT => $pasm_f,
+ STDERR => $pasm_f,
+ );
+ Parrot::Test::run_command(
+ "./parrot languages/$pasm_f @other",
+ CD => '..', # $self->{relpath},
+ STDOUT => $out_f,
+ STDERR => $out_f,
+ );
+ my $prog_output = Parrot::Test::slurp_file("$out_f");
+
+ @_ = ( $prog_output, $output, $desc );
+
+ #goto &{"Test::More::$meth"};
+ my $ok = &{"Test::More::$meth"}(@_);
+
+ # if( $ok ) { foreach my $meth ( $lang_f, $pasm_f, $by_f, $out_f ) { unlink $meth } } # JMG
+ }
+}
+
+1;
+
+my $urmc = "$PConfig{perl} $FindBin::Bin$PConfig{slash}..$PConfig{slash}urmc";
+my $compile = "-c -s";
+my $run = "-s";
+
+sub compile_test {
+ my $file = shift;
+
+ my $ret = system("$urmc $compile $FindBin::Bin$PConfig{slash}$file");
+ if ($ret) {
+ print STDERR "TEST FAILED: $file ($ret)\n";
+ return;
+ }
+ print "OK: $file\n";
+}
+
+sub run_test {
+ my ( $file, $expect ) = @_;
+ my $ret = `$urmc $run $FindBin::Bin$PConfig{slash}$file`;
+ if ( !$ret ) {
+ print STDERR "TEST FAILED: $file didn't return a value, Parrot crashed?\n";
+ return;
+ }
+ if ( $ret != $expect ) {
+ print STDERR "TEST FAILED: $file (got $ret expected $expect)\n";
+ return;
+ }
+ print "OK: $file\n";
+}
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: urm/trunk/t/harness
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ urm/trunk/t/harness Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,59 @@
+# $Id$
+
+=head1 NAME
+
+languages/urm/t/harness - A harness for urm
+
+=head1 SYNOPSIS
+
+ cd languages && perl -I../lib urm/t/harness ---files
+
+ cd languages && perl -I../lib urm/t/harness
+
+ cd languages && perl -I../lib urm/t/harness urm/t/testmmu.t urm/t/testmmu2.t
+
+=head1 DESCRIPTION
+
+If I'm called with a single argument of "--files",
+ I just return a list of files to process.
+This list is one per line, and is relative to the languages dir.
+
+If I'm called with no args, I run the complete suite.
+
+Otherwise I run the tests that were passed on the command line.
+
+=cut
+
+use strict;
+use FindBin;
+
+use lib '../../lib';
+use Parrot::Config;
+use Test::Harness();
+
+my $language = 'urm';
+
+if ( grep { m/^--files$/ } @ARGV ) {
+ # Only the Makefile in 'parrot/languages' uses --files
+ my $dir = File::Spec->catfile( $language, 't' );
+ my @files = glob( File::Spec->catfile( $dir, '*.t' ) );
+ print join( "\n", @files );
+ print "\n" if scalar(@files);
+} else {
+ my @files;
+ if ( scalar(@ARGV) ) {
+ # Someone specified tests for me to run.
+ @files = grep { -f $_ } @ARGV
+ }
+ else
+ {
+ ( undef, undef, my $current_dir ) = File::Spec->splitpath( Cwd::getcwd() );
+ if ( $current_dir eq 'languages' ) {
+ @files = glob( File::Spec->catfile( $language, 't', '*.t' ) );
+ }
+ elsif ( $current_dir eq $language ) {
+ @files = glob( File::Spec->catfile( 't', '*.t' ) );
+ }
+ }
+ Test::Harness::runtests( @files ) if scalar( @files );
+}
Added: urm/trunk/t/in_out.t
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ urm/trunk/t/in_out.t Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,26 @@
+# $Id$
+
+use FindBin;
+use lib "$FindBin::Bin/../lib";
+
+use URM::Test tests => 3;
+
+output_is(<< 'CODE', << 'OUT', 'echo single arg', 42);
+in(r17); out(r17);
+CODE
+42
+OUT
+
+output_is(<< 'CODE', << 'OUT', 'echo 0', 0);
+in(r17); out(r17);
+CODE
+0
+OUT
+
+# URM seems to have only a single output register
+output_is(<< 'CODE', << 'OUT', 'echo 6 args ', 00, 11, 22, 33, 44, 55);
+in(r17,r18,r19,r20,r21,r22);
+out(r22);
+CODE
+55
+OUT
Added: urm/trunk/t/mmu.t
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ urm/trunk/t/mmu.t Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,281 @@
+# $Id$
+
+use FindBin;
+use lib "$FindBin::Bin/../lib";
+
+use URM::Test tests => 3;
+
+## Ok, writing my own mmu
+
+output_is(<< 'CODE', << 'OUT', 'from testmmu.urm');
+
+out(r100);
+
+5: r5 <- 5
+6: r6 <- 6
+7: r7 <- 7
+8: r8 <- 8
+9: r9 <- 9
+10: r10 <- 10
+11: r11 <- 11
+12: r12 <- 12
+13: r13 <- 13
+14: r14 <- 14
+15: r15 <- 15
+16: r16 <- 16
+17: r17 <- 17
+18: r18 <- 18
+19: r19 <- 19
+20: r20 <- 20
+21: r21 <- 21
+22: r22 <- 22
+23: r23 <- 23
+24: r24 <- 24
+25: r25 <- 25
+26: r26 <- 26
+27: r27 <- 27
+28: r28 <- 28
+29: r29 <- 29
+30: r30 <- 30
+31: r31 <- 31
+32: r32 <- 32
+33: r33 <- 33
+34: r34 <- 34
+35: r35 <- 35
+36: r36 <- 36
+37: r37 <- 37
+38: r38 <- 38
+39: r39 <- 39
+40: r40 <- 40
+41: r41 <- 41
+42: r42 <- 42
+43: r43 <- 43
+44: r44 <- 44
+45: r45 <- 45
+46: r46 <- 46
+47: r47 <- 47
+48: r48 <- 48
+49: r49 <- 49
+50: r50 <- 50
+51: r51 <- 51
+52: r52 <- 52
+53: r53 <- 53
+54: r54 <- 54
+55: r55 <- 55
+56: r56 <- 56
+57: r57 <- 57
+58: r58 <- 58
+59: r59 <- 59
+60: r60 <- 60
+61: r61 <- 61
+62: r62 <- 62
+63: r63 <- 63
+64: r64 <- 64
+65: r65 <- 65
+66: r66 <- 66
+67: r67 <- 67
+68: r68 <- 68
+69: r69 <- 69
+70: r70 <- 70
+71: r71 <- 71
+72: r72 <- 72
+73: r73 <- 73
+74: r74 <- 74
+75: r75 <- 75
+76: r76 <- 76
+77: r77 <- 77
+78: r78 <- 78
+79: r79 <- 79
+80: r80 <- 80
+81: r81 <- 81
+82: r82 <- 82
+83: r83 <- 83
+84: r84 <- 84
+85: r85 <- 85
+86: r86 <- 86
+87: r87 <- 87
+88: r88 <- 88
+89: r89 <- 89
+90: r90 <- 90
+91: r91 <- 91
+92: r92 <- 92
+93: r93 <- 93
+94: r94 <- 94
+95: r95 <- 95
+96: r96 <- 96
+97: r97 <- 97
+98: r98 <- 98
+99: r99 <- 99
+100: r100 <- 100
+101: r101 <- 101
+102: r102 <- 102
+103: r103 <- 103
+104: r104 <- 104
+105: r105 <- 105
+106: r106 <- 106
+107: r107 <- 107
+108: r108 <- 108
+109: r109 <- 109
+110: r110 <- 110
+111: r111 <- 111
+112: r112 <- 112
+113: r113 <- 113
+114: r114 <- 114
+115: r115 <- 115
+116: r116 <- 116
+117: r117 <- 117
+118: r118 <- 118
+119: r119 <- 119
+120: r120 <- 120
+121: r121 <- 121
+122: r122 <- 122
+123: r123 <- 123
+124: r124 <- 124
+125: r125 <- 125
+126: r126 <- 126
+127: r127 <- 127
+128: r128 <- 128
+129: r129 <- 129
+130: r130 <- 130
+131: r131 <- 131
+132: r132 <- 132
+133: r133 <- 133
+134: r134 <- 134
+135: r135 <- 135
+136: r136 <- 136
+137: r137 <- 137
+138: r138 <- 138
+139: r139 <- 139
+140: r140 <- 140
+141: r141 <- 141
+142: r142 <- 142
+143: r143 <- 143
+144: r144 <- 144
+145: r145 <- 145
+146: r146 <- 146
+147: r147 <- 147
+148: r148 <- 148
+149: r149 <- 149
+150: r150 <- 150
+151: r151 <- 151
+152: r152 <- 152
+153: r153 <- 153
+154: r154 <- 154
+155: r155 <- 155
+156: r156 <- 156
+157: r157 <- 157
+158: r158 <- 158
+159: r159 <- 159
+160: r160 <- 160
+161: r161 <- 161
+162: r162 <- 162
+163: r163 <- 163
+164: r164 <- 164
+165: r165 <- 165
+166: r166 <- 166
+167: r167 <- 167
+168: r168 <- 168
+169: r169 <- 169
+170: r170 <- 170
+171: r171 <- 171
+172: r172 <- 172
+173: r173 <- 173
+174: r174 <- 174
+175: r175 <- 175
+176: r176 <- 176
+177: r177 <- 177
+178: r178 <- 178
+179: r179 <- 179
+180: r180 <- 180
+181: r181 <- 181
+182: r182 <- 182
+183: r183 <- 183
+184: r184 <- 184
+185: r185 <- 185
+186: r186 <- 186
+187: r187 <- 187
+188: r188 <- 188
+189: r189 <- 189
+190: r190 <- 190
+191: r191 <- 191
+192: r192 <- 192
+193: r193 <- 193
+194: r194 <- 194
+195: r195 <- 195
+196: r196 <- 196
+197: r197 <- 197
+198: r198 <- 198
+199: r199 <- 199
+200: r200 <- 200
+CODE
+100
+OUT
+
+
+
+output_is(<< 'CODE', << 'OUT', 'from testmmu.urm');
+## Ok, testing my own mmu
+## The thing leo got me with
+
+out(r32);
+
+1: r40 <- r100 + r200
+2: r32 <- 5 # should be I0
+3: r64 <- 3 # this too
+4: r128 <- 29 # and this too
+5: r32 <- r64 - 1
+CODE
+2
+OUT
+
+
+output_is(<< 'CODE', << 'OUT', 'from testmmu.urm');
+
+out(r5);
+
+5: r5 <- 5
+6: r6 <- 6
+7: r7 <- 7
+8: r8 <- 8
+9: r9 <- 9
+10: r10 <- 10
+11: r11 <- 11
+12: r12 <- 12
+13: r13 <- 13
+14: r14 <- 14
+15: r15 <- 15
+16: r16 <- 16
+17: r17 <- 17
+18: r18 <- 18
+19: r19 <- 19
+20: r20 <- 20
+21: r21 <- 21
+22: r22 <- 22
+23: r23 <- 23
+24: r24 <- 24
+25: r25 <- 25
+26: r26 <- 26
+27: r27 <- 27
+28: r28 <- 28
+29: r29 <- 29
+30: r30 <- 30
+31: r31 <- 31
+32: r32 <- 32
+33: r33 <- 33
+34: r34 <- 34
+35: r35 <- 35
+36: r36 <- 36
+37: r37 <- 37
+38: r38 <- 38
+39: r39 <- 39
+40: r40 <- 40
+41: r41 <- 41
+42: r42 <- 42
+43: r43 <- 43
+
+44: r5 <- r10 + r32
+55: r6 <- r20 + r30
+56: r5 <- r5 + r6
+CODE
+92
+OUT
Added: urm/trunk/t/syn.t
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ urm/trunk/t/syn.t Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,44 @@
+# $Id$
+
+use FindBin;
+use lib "$FindBin::Bin/../lib";
+
+use URM::Test tests => 1;
+
+# Test parsing of URM code
+
+output_is(<< 'CODE', << 'OUT', 'from testpars.urm', 42, 43);
+# 2003 (c) by Marcus Thiesen
+# <marcus at cpan.org>
+# This program is under GPL
+# See the LICENSE file
+# Testing the URM Parser
+
+#This should work
+in(r3,r2); out(r3);
+
+#Well formated
+1: r1 <- r1 + 1
+
+#Not that nice
+2:r1<-r1-1
+
+#Even more crap
+3: r3 <- r3 - 1
+
+#This should work too
+4: r3 <- r3 + 1 #More comments
+
+# Test the register code
+5: r5 <- 0
+6: r6 <- 0
+7: r7 <- 0
+8: r8 <- 0
+9: r9 <- 0
+10: r10 <- 0
+11: r11 <- 0
+12: r12 <- 0
+13: r13 <- 0
+CODE
+42
+OUT
Added: urm/trunk/urm-old.pl
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ urm/trunk/urm-old.pl Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,87 @@
+#! perl
+# urm.pl
+# 2003 (c) by Marcus Thiesen
+# Maybe you can use it for debugging
+# Copyright (C) 2003-2006, Parrot Foundation.
+# $Id$
+
+use strict;
+use warnings;
+use Data::Dumper;
+
+my @program;
+my %register;
+my $outreg;
+open PROGRAM, '<', $ARGV[0] or die "Couldn't get file";
+foreach my $line (<PROGRAM>) {
+ chomp $line;
+ next if ( $line =~ /^ *\#/ );
+ if ( $line =~ /in *\(([r\d,]+)\)/ ) {
+ print "Werte für $1: ";
+ my $input = readline(STDIN);
+ my @register = split( ",", $1 );
+ chomp $input;
+ my @input = split( ",", $input );
+ foreach my $reg (@register) {
+ $register{$reg} = shift @input;
+ }
+ }
+ if ( $line =~ /(r\d+)/ ) { $register{$1} = 0 unless defined $register{$1} }
+ if ( $line =~ /out\((r\d+)/ ) { $outreg = $1 }
+ if ( $line =~ /^\d+:(.+)/ ) {
+ my $code = $1;
+
+ # Some beautification!
+ $code =~ s/ +/ /g;
+ $code =~ s/\#.*//g;
+ next unless $code;
+ push @program, $code;
+ }
+}
+close PROGRAM;
+
+#print Dumper @program;
+
+my $pos = 1;
+while (1) {
+ my $line = $program[ $pos - 1 ];
+ if ( $pos > @program ) { last; }
+ print "($pos";
+ foreach my $reg ( sort keys %register ) {
+ print ", " . $register{$reg};
+ }
+ print ") \t$line\n";
+ if ( $line =~ /if *(r\d) *= *(\d) *goto *(\d+)/ ) {
+ $register{$1} = 0 unless defined $register{$1};
+ if ( $register{$1} == $2 ) { $pos = $3; }
+ else { $pos++ }
+ }
+ elsif ( $line =~ /(r\d) *<- *(\d+)/ ) {
+ $register{$1} = $2;
+ $pos++;
+ }
+ elsif ( $line =~ /(r\d) *<- *(r\d+) *([+-]) *1/ ) {
+ if ( $1 ne $2 ) { print "Syntax error: Registers don't match!\n"; exit 1; }
+ $register{$1} = eval("$register{$2} $3 1;");
+ if ( $register{$1} < 0 ) { $register{$1} = 0 }
+ $pos++;
+ }
+ elsif ( $line =~ / *goto *(\d+)/ ) {
+ $pos = $1;
+ }
+ else {
+ print "Syntax error\n";
+ exit;
+ }
+}
+
+print "Output: $register{$outreg}\n";
+
+#print Dumper %register;
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Added: urm/trunk/urmc
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ urm/trunk/urmc Sun Mar 15 11:23:30 2009 (r54)
@@ -0,0 +1,300 @@
+#! perl -w
+# urmc - 2003-2005 (c) by Marcus Thiesen
+# $Id$
+
+=head1 NAME
+
+urmc - This is just another little language for Parrot
+
+=head1 LICENSE
+
+This code is under the GPL
+
+=head1 AUTHOR
+
+Markus Thiessen - <marcus at cpan.org>
+
+=cut
+
+use strict;
+use FindBin;
+use lib "$FindBin::Bin/../../lib";
+
+use Data::Dumper;
+use Getopt::Long;
+use Parrot::Config;
+
+# $opti is localized later
+use vars qw( $opti );
+$opti = 1; # more a debug flag
+
+# globals
+my ( $filename, $silent );
+my $parrot = "$FindBin::Bin$PConfig{slash}..$PConfig{slash}..$PConfig{slash}parrot$PConfig{exe}";
+
+sub filename {
+ my $arg = shift;
+ if (-e $arg) {
+ $filename = $arg;
+ }
+}
+
+GetOptions( "silent" => \$silent,
+ "<>" => \&filename
+ );
+
+my $version = '0.4';
+my @pasm =
+ ( qq{## Compiled by urmc $version},
+ q{## 2003 (c) by Marcus Thiesen},
+ q{## <marcus at cpan.org>},
+ q{},
+ q{_MAIN:},
+ qq{\tget_params "(0)", P5 # Get command line},
+ qq{\tshift S1, P5 # we don't need the scriptname},
+ );
+
+my $lp = qr/\s*(\d+)\s*\:/; #line prefix (1:)
+my (%lines, %jtarget); # tcount lines and jump targets
+my $out_reg; # save the output registers name
+
+my @source;
+if ($filename) {
+ open SOURCE, $filename or die "Can't get sourcefile $filename :$!";
+ @source = <SOURCE>;
+ close SOURCE; ### if gnu would hear that... :-)
+} else {
+ die "$0 <file>"
+}
+
+sub warning{
+ return if $silent;
+ my ($warning, $linenr) = @_;
+ print STDERR "WARNING: $warning is not standard URM at line $linenr\n";
+}
+
+### memory management:
+
+my $stackcount = 0;
+my %look_tbl;
+my %reg_tbl;
+my %lra_tbl;
+
+for my $i (0..31) { $reg_tbl{$i} = 0; }
+
+# for debugging purposes
+sub dump_tables{
+ print "\$stackcount:\t $stackcount\n";
+
+ print "reg_tbl:\n";
+ map { print "$_\t => $reg_tbl{$_}\n"} sort { $a <=> $b } keys %reg_tbl;
+
+ print "look_tbl:\n";
+ map { print "$_\t => $look_tbl{$_}\n"} sort { $a <=> $b } keys %look_tbl;
+
+ print "lra_tbl:\n";
+}
+
+sub mmu {
+ my $name = shift;
+
+ ## lookup the register
+ if ((defined $look_tbl{$name}) &&
+ ($look_tbl{$name} =~ /^I(\d+)/)) {
+ return $1;
+ }
+
+ ## if not on stack: get a free one
+ foreach my $reg (sort {$a <=> $b} keys %reg_tbl) {
+ unless ($reg_tbl{$reg}) {
+ $reg_tbl{$reg} = $name;
+ my $time = time();
+ $lra_tbl{$time} = $reg;
+ $look_tbl{$name} = "I$reg";
+ return $reg;
+ }
+ }
+
+ ### no free registers left or on stack
+ # on stack
+ if (defined $look_tbl{$name}) {
+ # get last recently allocated:
+ my @times = sort { $a <=> $b } keys %lra_tbl;
+ my $time = shift @times;
+
+ my $old = $lra_tbl{"$time"};
+ die "\$old undefined\n" unless defined $old;
+ delete $lra_tbl{$time};
+ # save register nr $old on stack
+ push @pasm, "\tsave I$old";
+ $look_tbl{$reg_tbl{$old}} = $stackcount;
+ $reg_tbl{$old} = 0;
+ $stackcount++;
+
+
+ # get requested register from stack
+ $stackcount--;
+ my $nr_on_stack = ($stackcount - $look_tbl{$name}) - 1;
+ my $rotate_more = $stackcount - 1 - $nr_on_stack - 1;
+
+ for my $i (0..$nr_on_stack) {
+ push @pasm, "\trotate_up $stackcount";
+ }
+ push @pasm, "\trestore I$old";
+ for my $i (0..$rotate_more) {
+ push @pasm, "\trotate_up $stackcount";
+ }
+
+
+# push @pasm, "\tlookback I$old, $nr_on_stack";
+
+ $look_tbl{$name} = "I$old";
+ $lra_tbl{time()} = $old;
+ $reg_tbl{$old} = "$name";
+
+ return $old;
+ }
+
+ # no free register left
+ # free one and call yourself
+ # get last recently allocated:
+ my @times = sort { $a <=> $b } keys %lra_tbl;
+ my $time = shift @times;
+ my $old = $lra_tbl{"$time"};
+ delete $lra_tbl{$time};
+ # save register nr $old on stack
+ push @pasm, "\tsave I$old";
+ $look_tbl{$reg_tbl{$old}} = $stackcount;
+ $reg_tbl{$old} = 0;
+ $stackcount++;
+ return mmu($name);
+}
+
+### The parser
+foreach my $line (@source) {
+ next unless defined $line;
+ next if $line =~ /^\#/; # comments
+ next if $line =~ /^\s+$/; # spacy lines
+ $line =~ s/\#.+//; # stip in line comments;
+ chomp $line;
+ # parse in(r1,r2); out(r3); or out(r3); or in(r34);
+ if ( ( undef, my $in, undef, my $out ) =
+ $line =~ m/^(\s*in\(([0-9r\ ,]*?)\);)? # optional input registers
+ (\s*out\(r(\d+)\);)? # optional output register
+ \s*$ # insignificant lines are already skipped
+ /x ) {
+ $in ||= '';
+ $out_reg = $out if defined $out;
+ foreach ( split( /\s*,\s*/, $in ) ) {
+ my ( $in_reg ) = m/r(\d+)/;
+ my $rn = "I" . (mmu $in_reg);
+ push @pasm, "\t#get input for $_";
+ push @pasm, "\tshift S0, P5";
+ push @pasm, "\tset $rn, S0";
+ }
+ next;
+ }
+ #parse 0: r3 <- 0
+ elsif ($line =~ /$lp\s*r(\d+)\s*<-\s*(\d+)\s*$/o) {
+ $lines{$1} = 1;
+ if ($3 != 0) {
+ local $opti = 0;
+ warning("Assigning not 0 to a register", $1);
+ }
+ ## parrot does the work for us....
+ if ($opti <= 1) {
+ push @pasm, "L$1:";
+ push @pasm, "\tset I" . (mmu($2)) . ", $3\t\#$line";
+ next;
+ }
+ }
+ #parse 3: if r2 = 0 goto 7
+ elsif ($line =~ /$lp\s*if\sr(\d+)\s*=\s*0\s*goto\s*(\d+)/o) {
+ $lines{$1} = 1;
+ push @pasm, "L$1:";
+ push @pasm, "\teq I" . (mmu $2) . ", 0, L$3\t\#$line";
+ $jtarget{$3} = 1;
+ next;
+ }
+ elsif ($line =~ /^inline_pasm:/) {
+ $line =~ s/^inline_pasm://;
+ push @pasm, $line;
+ next;
+ }
+ #parse 4: r2 <- r2 +|- 1
+ elsif ($line =~
+ /$lp\s*r(\d+)\s*<-\s*r(\d+)\s*(\+|-)\s*(?:(r(\d+))|(\d+))/o ) {
+ $lines{$1} = 1;
+ if ($2 != $3) {
+ warning("Assigning one register to another", $1);
+ }
+ my $rn3;
+ if (defined $6) {
+ warning("Assigning sum of two registers", $1);
+ $rn3 = "I" . (mmu $6);
+ }
+ elsif ((defined $6) && ($6 != 1)) {
+ warning("Adding more than one", $1);
+ }
+
+ push @pasm, "L$1:";
+ my $rn1 = "I" . (mmu $2);
+ my $rn2 = "I" . (mmu $3);
+ $rn3 = 1 unless defined $rn3;
+ if ($4 eq "+") {
+ push @pasm, "\tadd $rn1, $rn2, $rn3\t\#$line";
+ } else {
+ push @pasm, "\tsub $rn1, $rn2, $rn3\t\#$line";
+ }
+ next;
+ }
+ #parse 5: goto 5
+ elsif ($line =~ /$lp\s*goto\s*(\d+)/) {
+ $lines{$1} = 1;
+ push @pasm, "L$1:";
+ push @pasm, "\tbranch L$2\t\#$line";
+ $jtarget{$2} = 1;
+ next;
+ }
+ else {
+ die "SYNTAX ERROR:\n$line\nCan't parse line\n";
+ }
+
+}
+
+my @newpasm;
+
+## clean up the labels
+if ($opti > 0) {
+ for my $line (@pasm) {
+ if ($line =~ /^L(\d+)/) {
+ push @newpasm, $line if exists $jtarget{$1};
+ next;
+ }
+ push @newpasm, $line;
+ }
+ @pasm = @newpasm;
+}
+
+if (scalar %jtarget) {
+ foreach my $key (keys %jtarget) {
+ next if exists $lines{$key};
+ if (defined $out_reg) {
+ $out_reg = mmu($out_reg);
+ push @pasm, "L$key:";
+ push @pasm, "\tprint I$out_reg";
+ push @pasm, "\tprint \"\\n\"";
+ }
+ push @pasm, "\tend";
+ }
+} else {
+ if (defined $out_reg) {
+ $out_reg = mmu($out_reg);
+ push @pasm, "\tprint I$out_reg";
+ push @pasm, "\tprint \"\\n\"";
+ }
+ push @pasm, "end";
+}
+
+# Consider this as a treewalker of an degenerate tree
+print join("\n", @pasm), "\n";
More information about the parrot-commits
mailing list