[svn:parrot] [svn:languages] r12 - in pheme: . branches tags trunk trunk/config trunk/config/makefiles trunk/lib trunk/t trunk/t/phemer

allison at svn.parrot.org allison at svn.parrot.org
Tue Mar 10 19:44:42 UTC 2009


Author: allison
Date: Tue Mar 10 19:44:41 2009
New Revision: 12
URL: https://trac.parrot.org/languages/changeset/12

Log:
[pheme] Migrating Pheme to the languages repository from
https://svn.parrot.org/trunk/languages/pheme.

Added:
   pheme/
   pheme/branches/
   pheme/tags/
   pheme/trunk/
   pheme/trunk/Configure.pl
   pheme/trunk/MAINTAINER
   pheme/trunk/MANIFEST
   pheme/trunk/README
   pheme/trunk/TODO
   pheme/trunk/config/
   pheme/trunk/config/makefiles/
   pheme/trunk/config/makefiles/root.in
   pheme/trunk/lib/
   pheme/trunk/lib/PhemeGrammar.pir
   pheme/trunk/lib/PhemeObjects.pir
   pheme/trunk/lib/PhemeSymbols.pir
   pheme/trunk/lib/PhemeTest.pir
   pheme/trunk/lib/pge2past.tg
   pheme/trunk/lib/pheme.g
   pheme/trunk/pheme.pir
   pheme/trunk/t/
   pheme/trunk/t/atom.t
   pheme/trunk/t/car.t
   pheme/trunk/t/cdr.t
   pheme/trunk/t/cond.t
   pheme/trunk/t/cons.t
   pheme/trunk/t/divide.t
   pheme/trunk/t/harness
   pheme/trunk/t/lambda.t
   pheme/trunk/t/minus.t
   pheme/trunk/t/multiply.t
   pheme/trunk/t/null.t
   pheme/trunk/t/phemer/
   pheme/trunk/t/phemer/chapter_1.t
   pheme/trunk/t/plus.t
   pheme/trunk/t/quote.t
   pheme/trunk/t/write.t

Added: pheme/trunk/Configure.pl
==============================================================================
--- /dev/null	00:00:00 1970	(empty, because file is newly added)
+++ pheme/trunk/Configure.pl	Tue Mar 10 19:44:41 2009	(r12)
@@ -0,0 +1,9 @@
+#! perl
+# $Id: Configure.pl 36833 2009-02-17 20:09:26Z allison $
+# Copyright (C) 2009, Parrot Foundation.
+
+use strict;
+use warnings;
+
+chdir '../..';
+`$^X -Ilib tools/dev/reconfigure.pl --step=gen::languages --languages=pheme`;

Added: pheme/trunk/MAINTAINER
==============================================================================
--- /dev/null	00:00:00 1970	(empty, because file is newly added)
+++ pheme/trunk/MAINTAINER	Tue Mar 10 19:44:41 2009	(r12)
@@ -0,0 +1,5 @@
+# $Id: MAINTAINER 18122 2007-04-10 16:58:56Z bernhard $
+
+N: chromatic
+E: chromatic at wgz.org
+W: http://wgz.org/chromatic/

Added: pheme/trunk/MANIFEST
==============================================================================
--- /dev/null	00:00:00 1970	(empty, because file is newly added)
+++ pheme/trunk/MANIFEST	Tue Mar 10 19:44:41 2009	(r12)
@@ -0,0 +1,19 @@
+lib/pge2past.tg
+lib/PhemeCompiler.pir
+lib/PhemeGrammar.pir
+lib/PhemeSymbols.pir
+lib/PhemeTest.pir
+lib/pheme.g
+lib/PhemeSymbols.pir
+lib/PhemeTest.pir
+MANIFEST
+pheme.pir
+t/harness
+t/car.t
+t/cdr.t
+t/cons.t
+t/lambda.t
+t/quote.t
+t/write.t
+README
+TODO

Added: pheme/trunk/README
==============================================================================
--- /dev/null	00:00:00 1970	(empty, because file is newly added)
+++ pheme/trunk/README	Tue Mar 10 19:44:41 2009	(r12)
@@ -0,0 +1,40 @@
+This is Pheme, version 0.1.0
+----------------------------
+
+Copyright (C) 2006 - 2007, Parrot Foundation.
+
+Pheme is a Parrot-based implementation of Scheme, in the sense that it has the
+same syntax (what syntax it has) and shares the name of some built-ins.  Please
+note the version number.
+
+PREREQUISITES
+-------------
+
+Pheme depends on Parrot 0.4.13 or higher, PGE, and TGE.
+
+INSTRUCTIONS
+------------
+
+Get Parrot.  Compile Parrot.  Make sure its tests pass, particularly those of
+PGE and TGE.
+
+Compile Pheme:
+
+  $ make
+  $ make test
+
+Note that the tests are actual Pheme programs, written entirely in Pheme
+(except for the test library, which is a PIR program).
+
+Run the Pheme compiler via Parrot.  The first argument to the compiler should
+be a Pheme program to run.
+
+  $ parrot pheme.pbc some_program.pheme
+
+Read the TODO file for an idea of some ways to improve this language.
+
+Please send all patches, bug reports, and suggestions to the Parrot mailing
+list.
+
+15 July 2007
+chromatic

Added: pheme/trunk/TODO
==============================================================================
--- /dev/null	00:00:00 1970	(empty, because file is newly added)
+++ pheme/trunk/TODO	Tue Mar 10 19:44:41 2009	(r12)
@@ -0,0 +1,79 @@
+http://schemers.org/Documents/Standards/R5RS/HTML/
+
+Atom:
+	- create atom object
+	- add subtypes for string, number, etc.?
+
+Cons:
+	- fix cons count for empty cons?
+
+Builtins:
+	- consider if eq? and eqlist? should really be multis
+		- add varieties for mismatched parameters if not
+	- refactor is_deeply() and is() in Pheme::Test
+		- add diagnostics too, if possible
+	- add nil?
+	- fix car on empty cons
+
+Special forms:
+	- cond
+	- lambda (be careful of define interaction though!)
+	- else
+	- and
+	- or
+
+Compiler:
+	- extract and merge POST improvements with Punie
+		- publish them under compilers/
+		- share those nodes somehow
+	- port to new TGE, when the branch lands
+	- fix load_bytecode section in generated code
+	- refactor compiler backend object
+		- share with Perl 6 and Punie
+		- move somewhere in Parrot lib path
+		- allow dumping of trees and (runnable) PIR
+	- use precompiled tree grammars
+	- merge all PBC files into pheme.pbc
+
+Fix namespace:
+	- lowercase
+	- directly under Parrot root
+	- use nested namespaces properly
+
+Grammar:
+	- tighten identifiers
+		- allow ! $ % & * + - . / : < = > ? @ ^ _ ~ 
+		- start with any non-number-beginning character
+		- . + - not allowed at the start of an identifier
+		- + - themselves can be an identifier
+		- ... can be an identifier
+	- fix whitespace
+		- space, newline (also tab, carriage return)
+	- parse numbers
+		- . + - allowed at the start of a number
+	- add more rules
+		- \ is an escape character
+
+Predicates:
+	- boolean?
+		- everything but #f is true (conditionals, not true here)
+	- symbol?
+	- char?
+	- vector?
+	- procedure?
+	- pair?
+	- number?
+	- string?
+	- port?
+	- predicates are disjoint
+	- empty list satisfies none
+
+
+The following tickets were stored in parrot's RT system.
+
+They have now been marked as rejected in that system, but are listed
+here for posterity, so they can easily be migrated into pheme's new
+ticketing system, whatever that may be.
+
+#60208: [BUG] pheme -- t/null test fails in r32229
+  http://rt.perl.org/rt3/Ticket/Display.html?id=60208

Added: pheme/trunk/config/makefiles/root.in
==============================================================================
--- /dev/null	00:00:00 1970	(empty, because file is newly added)
+++ pheme/trunk/config/makefiles/root.in	Tue Mar 10 19:44:41 2009	(r12)
@@ -0,0 +1,74 @@
+# Copyright (C) 2006-2009, Parrot Foundation.
+# $Id: root.in 36833 2009-02-17 20:09:26Z allison $
+
+# configuration settings
+BUILD_DIR     = @build_dir@
+
+# Setup some commands
+PERL          = @perl@
+RM_F          = @rm_f@
+PARROT        = ../../parrot at exe@
+TGE_DIR       = ../../compilers/tge
+PGE_LIBRARY   = $(BUILD_DIR)/runtime/parrot/library/PGE
+PERL6GRAMMAR  = $(PGE_LIBRARY)/Perl6Grammar.pbc
+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@
+
+# the default target
+all: pheme.pbc
+
+lib/pheme_grammar_gen.pir: lib/pheme.g
+	$(PARROT) $(PERL6GRAMMAR) \
+	 --output=lib/pheme_grammar_gen.pir lib/pheme.g
+
+lib/ASTGrammar.pir: lib/pge2past.tg
+	$(PARROT) $(TGE_DIR)/tgc.pir --output=lib/ASTGrammar.pir lib/pge2past.tg
+
+pheme.pbc: pheme.pir lib/PhemeSymbols.pir lib/PhemeObjects.pir lib/ASTGrammar.pir lib/pheme_grammar_gen.pir
+	$(PARROT) -o pheme.pbc pheme.pir
+
+# regenerate the Makefile
+Makefile: config/makefiles/root.in
+	cd $(BUILD_DIR) && $(RECONFIGURE) --step=gen::languages --languages=pheme
+
+# This is a listing of all targets that users can call
+help:
+	@echo ""
+	@echo "Following targets are available for the user:"
+	@echo ""
+	@echo "  all:               pheme.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) -Ilib t/harness
+
+testclean:
+
+clean: testclean
+	$(RM_F) pheme.pbc
+	$(RM_F) lib/pheme_grammar_gen.pir
+	$(RM_F) lib/ASTGrammar.pir
+
+realclean: clean
+	$(RM_F) Makefile
+
+distclean: realclean
+
+# Local variables:
+#   mode: makefile
+# End:
+# vim: ft=make:

Added: pheme/trunk/lib/PhemeGrammar.pir
==============================================================================
--- /dev/null	00:00:00 1970	(empty, because file is newly added)
+++ pheme/trunk/lib/PhemeGrammar.pir	Tue Mar 10 19:44:41 2009	(r12)
@@ -0,0 +1,19 @@
+.namespace [ 'PhemeGrammar' ]
+
+.sub '_load' :load
+    load_bytecode 'PGE.pbc'
+
+    .local pmc pge_rule_class
+    .local pmc pheme_grammar_class
+
+    pge_rule_class      = get_class ['PGE';'Grammar']
+    pheme_grammar_class = subclass pge_rule_class, 'PhemeGrammar'
+.end
+
+.include "languages/pheme/lib/pheme_grammar_gen.pir"
+
+# Local Variables:
+#   mode: pir
+#   fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:

Added: pheme/trunk/lib/PhemeObjects.pir
==============================================================================
--- /dev/null	00:00:00 1970	(empty, because file is newly added)
+++ pheme/trunk/lib/PhemeObjects.pir	Tue Mar 10 19:44:41 2009	(r12)
@@ -0,0 +1,118 @@
+.namespace [ 'Pheme'; 'Cons' ]
+
+.sub '_initialize' :anon :load :init
+    .local pmc cons_class
+    cons_class = get_class [ 'Pheme'; 'Cons' ]
+    $I0 = defined cons_class
+    unless $I0 goto register
+    .return()
+
+  register:
+    newclass cons_class, [ 'Pheme'; 'Cons' ]
+
+    addattribute cons_class, 'head'
+    addattribute cons_class, 'tail'
+.end
+
+.sub 'get_bool' :vtable
+    .return( 1 )
+.end
+
+.sub 'get_string' :vtable :method
+    .local pmc    head
+    .local string output
+    head    = self.'head'()
+
+    .local int head_defined
+    head_defined = defined head
+    unless head_defined goto return_it
+    output  = head
+
+    .local pmc tail
+    tail = self.'tail'()
+
+    .local string tail_output
+    tail_output = tail
+    unless tail_output goto return_it
+
+    output .= ':'
+    output .= tail_output
+
+  return_it:
+    .return( output )
+.end
+
+.sub 'head' :method
+    .param pmc new_head  :optional
+    .param int have_head :opt_flag
+
+    unless have_head goto return_head
+    setattribute self, 'head', new_head
+    .return( new_head )
+
+  return_head:
+    .local pmc head
+    head = getattribute self, 'head'
+    .return( head )
+.end
+
+.sub 'get_integer' :vtable :method
+    .local pmc elem
+    elem  = self.'head'()
+
+    .local int elem_defined
+    elem_defined = defined elem
+
+    if elem_defined goto count_tail
+    .return( 0 )
+
+  count_tail:
+    .local int count
+    count = 0
+    elem  = self
+
+  loop_start:
+    inc count
+    elem         = elem.'tail'()
+    elem_defined = defined elem
+    if elem_defined goto loop_start
+
+  loop_end:
+    .return( count )
+.end
+
+.sub 'tail' :method
+    .param pmc new_tail  :optional
+    .param int have_tail :opt_flag
+
+    unless have_tail goto return_tail
+    setattribute self, 'tail', new_tail
+    .return( new_tail )
+
+  return_tail:
+    .local pmc tail
+    tail = getattribute self, 'tail'
+    .return( tail )
+.end
+
+.namespace [ 'Pheme'; 'Atom' ]
+
+.sub '_initialize' :anon :load :init
+    .local pmc atom_class
+    newclass atom_class, [ 'Pheme'; 'Atom' ]
+
+    addattribute atom_class, 'value'
+.end
+
+.namespace [ 'Pheme'; 'Atom'; 'Symbol' ]
+
+.sub '_initialize' :anon :load :init
+    .local pmc symbol_class
+    subclass symbol_class, [ 'Pheme'; 'Atom' ], [ 'Pheme'; 'Atom'; 'Symbol' ]
+.end
+
+# Local Variables:
+#   mode: pir
+#   fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:

Added: pheme/trunk/lib/PhemeSymbols.pir
==============================================================================
--- /dev/null	00:00:00 1970	(empty, because file is newly added)
+++ pheme/trunk/lib/PhemeSymbols.pir	Tue Mar 10 19:44:41 2009	(r12)
@@ -0,0 +1,403 @@
+.namespace [ 'PhemeCompiler' ]
+
+.sub '__onload' :anon :load :init
+    .local pmc symbols
+    symbols = new 'Hash'
+
+    symbols["'define'"]            = 1
+    symbols["'car'"]               = 1
+    symbols["'cdr'"]               = 1
+    symbols["'cons'"]              = 1
+    symbols["'cond'"]              = 1
+    symbols["'include_file'"]      = 1
+    symbols["'write'"]             = 1
+    symbols["'+'"]                 = 1
+    symbols["'-'"]                 = 1
+    symbols["'*'"]                 = 1
+    symbols["'/'"]                 = 1
+
+    set_hll_global ['PhemeCompiler'], 'symbols', symbols
+    .return()
+.end
+
+.namespace [ 'Pheme' ]
+
+.sub '__resolve_at_runtime' :multi( [ 'Pheme'; 'Cons' ] )
+    .param pmc args :slurpy
+
+    .tailcall __list_to_cons( args :flat )
+.end
+
+.sub '__resolve_at_runtime' :multi( string )
+    .param string symbol_name
+    .param pmc    args :slurpy
+
+    .local pmc function
+    push_eh return_list
+    function = get_global symbol_name
+    unless function goto return_list
+    pop_eh
+
+    .tailcall function( args :flat )
+
+  return_list:
+    .tailcall __list_to_cons( symbol_name, args :flat )
+.end
+
+.sub '__list_to_cons'
+    .param pmc args :slurpy
+
+    .local pmc result
+    result = new [ 'Pheme'; 'Cons' ]
+
+    .local int args_count
+    .local pmc arg
+
+  loop_start:
+    args_count = args
+    unless args_count goto loop_end
+    arg        = pop args
+    result     = cons( arg, result )
+    goto loop_start
+
+  loop_end:
+    .return( result )
+.end
+
+.sub '__evaluate' :multi( [ 'Pheme'; 'Cons' ] )
+    .param pmc cons
+
+    .local pmc cons_list
+    cons_list = new 'ResizablePMCArray'
+
+    # walk through cons
+    # push onto stack backwards
+    # evaluate that way
+    .local pmc head
+    .local int item_defined
+  get_loop:
+    head = cons.'head'()
+    item_defined = defined head
+    unless item_defined goto end_get_loop
+    push cons_list, head
+
+    cons = cons.'tail'()
+    goto get_loop
+  end_get_loop:
+
+    .local pmc first
+    first = cons_list[0]
+
+    .local string first_type
+    first_type = typeof first
+
+    if first_type == 'String' goto call_func
+
+    .tailcall __list_to_cons( cons_list :flat )
+
+  call_func:
+    first  = shift cons_list
+
+    .local string func_name
+    func_name = first
+
+    .tailcall __resolve_at_runtime( func_name, cons_list :flat )
+.end
+
+.sub '__evaluate' :multi( pmc )
+    .param pmc atom
+    .return( atom )
+.end
+
+.sub 'car'
+    .param pmc cons
+
+    .local pmc head
+    head = cons.'head'()
+
+    .local int defined_head
+    defined_head = defined head
+
+    unless defined_head goto return_nil
+    .return( head )
+
+  return_nil:
+    .return( 'nil' )
+.end
+
+.sub 'cdr'
+    .param pmc cons
+
+    .local pmc tail
+    .tailcall cons.'tail'()
+.end
+
+.sub 'include_file'
+    .param pmc file_path
+
+    .local string filename
+    filename = file_path
+
+    load_bytecode filename
+    .return()
+.end
+
+.sub 'cons'
+    .param pmc l
+    .param pmc r
+
+    .local pmc result
+    result = new [ 'Pheme'; 'Cons' ]
+
+    result.'head'( l )
+    result.'tail'( r )
+
+    .return( result )
+.end
+
+.sub 'cond'
+    .param pmc exps :slurpy
+
+    .local pmc iter
+    iter = new 'Iterator', exps
+    iter = 0
+
+    .local pmc cond
+    .local pmc action
+
+  iter_loop:
+    unless iter goto iter_end
+    cond   = shift iter
+    action = shift iter
+
+    .local pmc result
+    result = __evaluate( cond )
+    unless result goto iter_loop
+
+    .tailcall __evaluate( action )
+
+  iter_end:
+    .return()
+.end
+
+.sub 'write' :multi()
+    .param pmc messages :slurpy
+
+    .local string message
+    .local pmc iter
+    iter = new 'Iterator', messages
+    iter = 0
+
+  iter_loop:
+    unless iter goto iter_end
+    message = shift iter
+    print message
+    goto iter_loop
+
+  iter_end:
+    .return()
+.end
+
+.sub 'eqlist?'
+    .param pmc l_cons
+    .param pmc r_cons
+
+    .local int l_count
+    .local int r_count
+    l_count = l_cons
+    r_count = r_cons
+
+    unless l_count == 0 goto not_empty
+    unless r_count == 0 goto not_empty
+    .return( 1 )
+
+  not_empty:
+    if l_count == r_count goto compare_head
+    .return( 0 )
+
+  compare_head:
+    .local pmc l_head
+    .local pmc r_head
+
+    l_head = l_cons.'head'()
+    r_head = r_cons.'head'()
+
+    .local int head_equal
+    head_equal = 'eq?'( l_head, r_head )
+
+    if head_equal goto compare_tail
+    .return( 0 )
+
+  compare_tail:
+    .local pmc l_tail
+    .local pmc r_tail
+
+    l_tail = l_cons.'tail'()
+    r_tail = r_cons.'tail'()
+
+    .tailcall 'eqlist?'( l_head, r_head )
+.end
+
+.sub 'eq?' :multi( pmc, pmc )
+    .param pmc l_atom
+    .param pmc r_atom
+
+    eq l_atom, r_atom, return_true
+    .return( 0 )
+
+  return_true:
+    .return( 1 )
+.end
+
+.sub 'eq?' :multi( [ 'Pheme'; 'Cons' ], [ 'Pheme'; 'Cons' ] )
+    .param pmc l_cons
+    .param pmc r_cons
+
+    .tailcall 'eqlist?'( l_cons, r_cons )
+.end
+
+# XXX - return #t
+.sub 'atom?' :multi( [ 'Pheme'; 'Atom' ] )
+    .param pmc atom
+
+    .return( 1 )
+.end
+
+# XXX - return #f
+.sub 'atom?' :multi( [ 'Pheme'; 'Cons' ] )
+    .param pmc cons
+
+    .return( 0 )
+.end
+
+# XXX - a cheat for now
+.sub 'atom?' :multi( String )
+    .param pmc val
+    .return( 1 )
+.end
+
+# XXX - a cheat for now
+.sub 'atom?' :multi( string )
+    .param pmc val
+    .return( 1 )
+.end
+
+.sub 'null?' :multi( [ 'Pheme'; 'Cons' ] )
+    .param pmc cons
+    .local int count
+    count = cons
+
+    eq count, 0, indeed_empty
+    .return( 0 )
+
+  indeed_empty:
+    .return( 1 )
+.end
+
+.sub '+' :multi( _ )
+    .param num first
+    .param pmc   rest   :slurpy
+
+    .local num result
+    result   = first
+
+    .local pmc iter
+    iter = new 'Iterator', rest
+
+    .local pmc   next
+    .local num next_val
+
+  loop:
+    unless iter goto end_loop
+    next     = shift iter
+    next_val = next
+    result  += next_val
+    goto loop
+
+  end_loop:
+    .return( result )
+.end
+
+.sub '*' :multi( _ )
+    .param num first
+    .param pmc   rest   :slurpy
+
+    .local num result
+    result   = first
+
+    .local pmc iter
+    iter = new 'Iterator', rest
+
+    .local pmc   next
+    .local num next_val
+
+  loop:
+    unless iter goto end_loop
+    next     = shift iter
+    next_val = next
+    result  *= next_val
+    goto loop
+
+  end_loop:
+    .return( result )
+.end
+
+.sub '-' :multi( _ )
+    .param num first
+    .param pmc   rest :slurpy
+
+    .local num result
+    result   = first
+
+    .local pmc iter
+    iter = new 'Iterator', rest
+
+    .local pmc   next
+    .local num next_val
+
+  loop:
+    unless iter goto end_loop
+    next     = shift iter
+    next_val = next
+    result  -= next_val
+    goto loop
+
+  end_loop:
+    .return( result )
+.end
+
+.sub '/'
+    .param num l
+    .param num r
+
+    .local num result
+    result = l / r
+
+    .return( result )
+.end
+
+.sub 'null?' :multi( _ )
+    .param pmc dummy
+    .return( 0 )
+.end
+
+.sub 'write' :multi( string )
+    .param string message_string
+
+    print message_string
+    .return()
+.end
+
+.sub '__make_empty_cons'
+    .local pmc result
+
+    .local pmc result
+    result = new [ 'Pheme'; 'Cons' ]
+    .return( result )
+.end
+
+# Local Variables:
+#   mode: pir
+#   fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:

Added: pheme/trunk/lib/PhemeTest.pir
==============================================================================
--- /dev/null	00:00:00 1970	(empty, because file is newly added)
+++ pheme/trunk/lib/PhemeTest.pir	Tue Mar 10 19:44:41 2009	(r12)
@@ -0,0 +1,68 @@
+.namespace [ 'Test'; 'More' ]
+
+.sub is :multi( [ 'Pheme'; 'Cons' ], [ 'Pheme'; 'Cons' ] )
+    .param pmc    l_cons
+    .param pmc    r_cons
+    .param string description :optional
+
+    .local pmc eqlist
+    eqlist = get_hll_global ['Pheme'], 'eqlist?'
+
+    .local int equal
+    equal = eqlist( l_cons, r_cons )
+
+    .local pmc test
+    test = get_hll_global [ 'Test'; 'More' ], '_test'
+
+    test.'ok'( equal, description )
+    .return( equal )
+.end
+
+.sub is_deeply :multi( [ 'Pheme'; 'Cons' ], [ 'Pheme'; 'Cons' ] )
+    .param pmc    l_cons
+    .param pmc    r_cons
+    .param string description :optional
+
+    .local pmc eqlist
+    eqlist = get_hll_global ['Pheme'], 'eqlist?'
+
+    .local int equal
+    equal = eqlist( l_cons, r_cons )
+
+    .local pmc test
+    test = get_hll_global [ 'Test'; 'More' ], '_test'
+
+    test.'ok'( equal, description )
+    .return( equal )
+.end
+
+.namespace [ 'Pheme' ]
+
+.sub _load :load
+    load_bytecode 'library/Test/More.pir'
+    _export( 'is', 'ok', 'nok', 'diag', 'is_deeply', 'plan' )
+.end
+
+.sub _export
+    .param pmc exports :slurpy
+
+    .local pmc iter
+    iter = new 'Iterator', exports
+
+    .local string name
+    .local pmc    sub
+  iter_loop:
+    unless iter goto iter_end
+    name = shift iter
+    sub  = get_hll_global [ 'Test'; 'More' ], name
+    set_global name, sub
+    goto iter_loop
+  iter_end:
+
+.end
+
+# Local Variables:
+#   mode: pir
+#   fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:

Added: pheme/trunk/lib/pge2past.tg
==============================================================================
--- /dev/null	00:00:00 1970	(empty, because file is newly added)
+++ pheme/trunk/lib/pge2past.tg	Tue Mar 10 19:44:41 2009	(r12)
@@ -0,0 +1,519 @@
+grammar Pheme::AST::Grammar is TGE::Grammar;
+
+transform past (ROOT) :language('PIR') {
+    .local pmc result
+    result = new ['PAST';'Block']
+    result.'namespace'( 'Pheme' )
+    result.'hll'('pheme')
+
+    .local pmc lists
+    lists = node['pheme_list']
+
+    .local pmc iter
+    iter = new 'Iterator', lists
+
+    .local pmc elem
+
+  iter_loop:
+    unless iter goto iter_end
+    elem = shift iter
+    elem = tree.'get'( 'past', elem, 'pheme_list' )
+
+    result.'push'( elem )
+    goto iter_loop
+
+  iter_end:
+    .return( result )
+}
+
+transform past (pheme_list) :language('PIR') {
+    .local pmc iter
+    $P0 = node.'hash'()
+    iter = new 'Iterator', $P0
+
+    .local string key_name
+    key_name = shift iter
+
+    .local pmc elem
+    elem = node[key_name]
+
+    .local pmc op
+    op = new ['PAST';'Op']
+    op.'name'( '__list_to_cons' )
+    op.'pasttype'( 'call' )
+
+  check_for_atom:
+    .local int has_atom
+    has_atom = exists elem['atom']
+    unless has_atom goto check_for_special
+
+    .local pmc atom
+    atom = elem['atom']
+    atom = tree.'get'( 'past', atom, 'atom' )
+    op.'push'( atom )
+
+  check_for_special:
+    .local int has_special
+    has_special = exists elem['special']
+    unless has_special goto make_cons
+
+    .local pmc special
+    special = elem['special']
+
+    .local string special_name
+    special_name = special
+
+    special = new ['PAST';'Op']
+    special.'name'( special_name )
+    op.'push'( special )
+
+  make_cons:
+    .local pmc list
+    list = elem['list_item']
+
+    .local pmc iter
+    iter = new 'Iterator', list
+
+    .local pmc item
+  iter_loop:
+    unless iter goto iter_end
+    item = shift iter
+    item = tree.'get'( 'past', item, 'list_item' )
+    op.'push'( item )
+    goto iter_loop
+
+  iter_end:
+    .local pmc result
+    result = new ['PAST';'Op']
+    result.'name'( '__evaluate' )
+    result.'pasttype'( 'call' )
+    result.'push'( op )
+
+    .tailcall tree.'get'( key_name, result )
+}
+
+transform past (list_item) :language('PIR') {
+    .local pmc iter
+    $P0 = node.'hash'()
+    iter = new 'Iterator', $P0
+
+    .local string key_name
+    key_name = shift iter
+
+    .local pmc    elem
+    elem     = node[key_name]
+
+    .tailcall tree.'get'( 'past', elem, key_name )
+}
+
+transform special_form (PAST;Op) :language('PIR') {
+    .local pmc make_cons
+    make_cons = node[0]
+
+    .local pmc cons_iter
+    cons_iter = make_cons.'iterator'()
+
+    .local pmc form_op
+    form_op = shift cons_iter
+
+    .local string form_name
+    form_name = form_op.'name'()
+
+    .tailcall tree.'get'( form_name, make_cons )
+}
+
+# this *may* be an application; this is an optimization
+transform application (PAST;Op) :language('PIR') {
+    .local pmc make_cons
+    make_cons = node[0]
+
+    .local pmc cons_iter
+    cons_iter = make_cons.'iterator'()
+
+    .local pmc maybe_op
+    maybe_op = shift cons_iter
+
+    .local string func_name
+    func_name = maybe_op.'name'()
+
+    .local int name_length
+    name_length = length func_name
+
+    # strip off the quotes from the atom name
+    name_length -= 2
+    func_name    = substr func_name, 1, name_length
+
+    .local pmc func_func
+    func_func = get_hll_global ['Pheme'], func_name
+
+    .local int have_func
+    have_func = defined func_func
+
+    if have_func goto rewrite_to_call
+    .return( node )
+
+  rewrite_to_call:
+    .local pmc result
+    result = new ['PAST';'Op']
+    result.'pasttype'( 'call' )
+    result.'name'( func_name )
+
+    .local pmc item
+  iter_loop:
+    unless cons_iter goto iter_end
+    item = shift cons_iter
+    result.'push'( item )
+    goto iter_loop
+
+  iter_end:
+    .return( result )
+}
+
+transform cons (PAST;Op) :language('PIR') {
+    .local pmc make_cons
+    make_cons = node[0]
+    .return( make_cons )
+}
+
+transform make_cons (list) :language('PIR') {
+    .local pmc iter
+    $P0 = node.'hash'()
+    iter = new 'Iterator', $P0
+
+    .local pmc cons
+    cons = new ['PAST';'Op']
+    cons.'name'( '__list_to_cons' )
+    cons.'pasttype'( 'call' )
+
+    .local pmc child
+
+  iter_loop:
+    unless iter, iter_end
+    child = shift iter
+    child = tree.'get'( 'past', child, 'list_item' )
+    cons.'push'( child )
+    goto iter_loop
+
+  iter_end:
+    .local pmc eval
+    eval = new ['PAST';'Op']
+    eval.'name'( '__evaluate' )
+    eval.'pasttype'( 'call' )
+    eval.'push'( cons )
+
+    .return( eval )
+}
+
+transform special_form (define) :language('PIR') {
+    .local pmc iter
+    iter   = node.'iterator'()
+
+    .local pmc op, name, lambda
+    op     = shift iter
+    name   = shift iter
+    lambda = shift iter
+
+    .local pmc name_str
+    name_str = name.'name'()
+
+    .local pmc result
+    result = new ['PAST';'Block']
+
+    result.'name'( name_str )
+    result.'push'( lambda )
+
+    .return( result )
+}
+
+transform quote (PAST;Op) :language( 'PIR' ) {
+    .local pmc children
+    children = node.'list'()
+
+    # first kid is quote op; remove
+    .local pmc quote_op
+    quote_op = shift children
+
+    .local pmc quoted_item
+    quoted_item = children[0]
+
+    .local string name
+    name = quoted_item.'name'()
+    ne name, '__evaluate', quote_item
+
+    # splice out eval
+    quoted_item = quoted_item[0]
+
+  quote_item:
+    quoted_item = tree.'get'( 'force_to_val', quoted_item )
+    children[0] = quoted_item
+
+    .local int num_kids
+    num_kids = children
+
+    if num_kids > 1 goto return_node
+    .return( quoted_item )
+
+  return_node:
+    .return( node )
+}
+
+transform force_to_val (PAST;Op) :language('PIR') {
+    .local pmc result
+    result = new ['PAST';'Val']
+
+    .local string name
+    name = node.'name'()
+    ne name, '__make_empty_cons', really_rewrite
+    .return( node )
+
+  really_rewrite:
+    node.'name'( '__list_to_cons' )
+    name  = "'" . name
+    name .= "'"
+    result.'value'( name )
+    result.'returns'( 'Undef' )
+
+    .local pmc children
+    children = node.'list'()
+    unshift children, result
+
+    .return( node )
+}
+
+transform force_to_val (PAST;Val) :language('PIR') {
+    .return( node )
+}
+
+transform force_to_val (PAST;Var) :language('PIR') {
+    .return( node )
+}
+
+transform cond (PAST;Op) :language( 'PIR' ) {
+    .local pmc result
+    result = new ['PAST';'Op']
+    result.'pasttype'( 'if' )
+
+    .local pmc iter
+    iter = node.'iterator'()
+
+    # throw away first child; it's 'cond'
+    .local pmc child
+    child = shift iter
+
+    .local pmc parent_if
+    parent_if = result
+
+  append_children:
+    .local pmc if_op
+    if_op = shift iter
+    parent_if.'push'( if_op )
+    unless iter goto return_result
+
+    .local pmc then_node
+    then_node = shift iter
+    parent_if.'push'( then_node )
+    unless iter goto return_result
+
+    .local int num_children
+    num_children = iter
+    unless num_children == 1 goto nest_if
+
+    .local pmc else_node
+    else_node = shift iter
+    parent_if.'push'( else_node )
+    goto return_result
+
+  nest_if:
+    .local pmc new_if
+    new_if = new ['PAST';'Op']
+    new_if.'pasttype'( 'if' )
+    parent_if.'push'( new_if )
+    parent_if = new_if
+    goto append_children
+
+  return_result:
+    .return( result )
+}
+
+transform lambda (PAST;Op) :language('PIR') {
+    .local pmc result
+    result = new ['PAST';'Block']
+    result.'blocktype'( 'declaration' )
+
+    .local pmc child_iter
+    child_iter = node.'iterator'()
+
+    # discard first child; it's the lambda op
+    .local pmc child
+    child = shift child_iter
+
+    .local pmc args
+    args = shift child_iter
+
+    .local pmc args_iter
+    args_iter = args.'iterator'()
+
+    .local pmc    rewrite_args
+    rewrite_args = new 'Hash'
+
+    .local string arg_name
+    .local pmc    arg
+  args_iter_loop:
+    unless args_iter goto args_iter_end
+    child    = shift args_iter
+    arg      = new ['PAST';'Var']
+    arg_name = child.'name'()
+    arg.'name'( arg_name )
+    arg.'scope'( 'parameter' )
+    result.'push'( arg )
+    rewrite_args[arg_name] = 1
+    goto args_iter_loop
+  args_iter_end:
+    .local pmc arg_names_stack
+    arg_names_stack = get_global 'arg_names_stack'
+
+    .local int have_stack
+    have_stack = defined arg_names_stack
+    if have_stack goto add_names_to_stack
+
+    arg_names_stack = new 'ResizablePMCArray'
+    set_global 'arg_names_stack', arg_names_stack
+
+  add_names_to_stack:
+    push arg_names_stack, rewrite_args
+
+  child_iter_loop:
+    unless child_iter goto child_iter_end
+    child    = shift child_iter
+    child    = tree.'get'( 'rewrite_var_name', child )
+    result.'push'( child )
+    goto child_iter_loop
+
+    # XXX - must rewrite all PAST;Val in children to PAST;Var as appropriate
+  child_iter_end:
+    rewrite_args = pop arg_names_stack
+    .return( result )
+}
+
+transform rewrite_var_name (PAST;Op) :language('PIR') {
+    .local pmc children
+    children = node.'list'()
+
+    .local int elements
+    elements = children
+
+    .local int i
+    i = 0
+
+    .local pmc child
+  start_loop:
+    if i == elements goto end_loop
+    child       = children[i]
+    child       = tree.'get'( 'rewrite_var_name', child )
+    children[i] = child
+    inc i
+    goto start_loop
+
+  end_loop:
+    .return( node )
+}
+
+transform rewrite_var_name (PAST;Val) :language('PIR') {
+    .local pmc arg_names_stack
+    arg_names_stack = get_global 'arg_names_stack'
+
+    .local pmc arg_names
+    arg_names = arg_names_stack[-1]
+
+    .local string arg_name
+    arg_name = node.'name'()
+
+    .local int name_exists
+    name_exists = exists arg_names[arg_name]
+
+    if name_exists goto rewrite_to_var
+    .return( node )
+
+  rewrite_to_var:
+    .local pmc var
+    var = new ['PAST';'Var']
+    var.'scope'( 'lexical' )
+    var.'name'( arg_name )
+    .return( var )
+}
+
+transform rewrite_var_name (PAST;Var) :language('PIR') {
+    .return( node )
+}
+
+transform define (PAST;Op) :language('PIR') {
+    .local pmc iter
+    iter = node.'iterator'()
+
+    # throw away first child; it's the define op
+    .local pmc define_op
+    define_op = shift iter
+
+    .local pmc name
+    name = shift iter
+
+    .local string name_str
+    name_str = name.'name'()
+
+    .local pmc lambda
+    lambda = shift iter
+    lambda.'name'( name_str )
+
+    .return( lambda )
+}
+
+# XXX: almost certainly wrong
+transform past (empty_list) :language('PIR') {
+    .local pmc result
+
+    result = new ['PAST';'Op']
+    result.'name'( '__make_empty_cons' )
+
+    .return( result )
+}
+
+transform past (atom) :language('PIR') {
+    .local pmc result
+    result   = new ['PAST';'Val']
+
+    .local string value
+    value    = node
+
+    # if this is a quoted atom, strip off the quote; it's meaningless here
+    .local int is_quoted
+    is_quoted = exists node['quote']
+    unless is_quoted goto add_quotes
+
+    value = substr value, 1
+
+  add_quotes:
+    .local string quoted_value
+    quoted_value  = "'"
+    quoted_value .= value
+    quoted_value .= "'"
+
+    result.'value'( quoted_value )
+    result.'name'( quoted_value )
+    result.'returns'( 'Undef' )
+
+    .return( result )
+}
+
+transform past (quoted_string) :language('PIR') {
+    .local pmc result
+    result = new ['PAST';'Val']
+
+    .local string value
+    value  = node
+
+    result.'name'( value )
+    result.'value'( value )
+    result.'returns'( 'Undef' )
+
+    .return( result )
+}

Added: pheme/trunk/lib/pheme.g
==============================================================================
--- /dev/null	00:00:00 1970	(empty, because file is newly added)
+++ pheme/trunk/lib/pheme.g	Tue Mar 10 19:44:41 2009	(r12)
@@ -0,0 +1,28 @@
+grammar Pheme::Grammar;
+
+rule TOP { <pheme_list>+ }
+
+rule pheme_list { '(' [ <special_form> | <application> | <cons> ] ')' }
+
+rule special_form { <special> <list_item>+ }
+
+rule application { <atom> <list_item>+ }
+
+rule cons { <list_item>+ }
+
+# quoted_string has to come first
+rule list_item { <quoted_string> | <empty_list> | <atom> | <pheme_list> }
+
+token empty_list { <quote>? '()' }
+
+token atom { [ <symbol_tag> | <quote> ]? <-[\ \n\r\(\)]>+ }
+
+token quoted_string { <PGE::Text::bracketed: '"'> }
+
+token quote { \' }
+
+token symbol_tag { '#' }
+
+token ws { [ [ ';' \N+ ]? \s+ ]* }
+
+token special { ('if' | 'cond' | 'define' | 'lambda' | 'quote') }

Added: pheme/trunk/pheme.pir
==============================================================================
--- /dev/null	00:00:00 1970	(empty, because file is newly added)
+++ pheme/trunk/pheme.pir	Tue Mar 10 19:44:41 2009	(r12)
@@ -0,0 +1,104 @@
+# $Id: pheme.pir 35006 2009-01-05 20:46:44Z tene $
+
+=head1 TITLE
+
+pheme.pir - A Pheme compiler.
+
+=head2 Description
+
+This is the base file for the Pheme compiler.
+
+This file includes the parsing and grammar rules from
+the lib/ directory, loads the relevant PGE libraries,
+and registers the compiler under the name 'Pheme'.
+
+=head2 Functions
+
+=over 4
+
+=item __onload()
+
+Loads the PGE libraries needed for running the parser,
+and registers the Pheme compiler using a C<HLLCompiler>
+object.
+
+=cut
+
+.HLL 'pheme'
+
+.sub '' :anon :load :init
+    load_bytecode 'PCT.pbc'
+    load_bytecode 'TGE.pbc'
+
+    .local pmc parrotns, hllns, exports
+    parrotns = get_root_namespace ['parrot']
+    hllns = get_hll_namespace
+    exports = split ' ', 'PAST PCT PGE TGE'
+    parrotns.'export_to'(hllns, exports)
+.end
+
+.include 'languages/pheme/lib/PhemeObjects.pir'
+.include 'languages/pheme/lib/PhemeSymbols.pir'
+.include 'languages/pheme/lib/pheme_grammar_gen.pir'
+.include 'languages/pheme/lib/ASTGrammar.pir'
+
+.namespace [ 'Pheme';'Compiler' ]
+
+.sub '__onload' :load :init
+    load_bytecode 'PCT.pbc'
+    load_bytecode 'PGE/Text.pbc'
+
+    .local pmc p6meta
+    p6meta = get_root_global ['parrot'], 'P6metaclass'
+
+    $P0 = p6meta.'new_class'('Match','parent'=>'parrot;PGE::Match')
+    $P0 = p6meta.'new_class'('Grammar','parent'=>'Match')
+    $P0 = p6meta.'new_class'('Pheme::PGE::Grammar','parent'=>'Grammar')
+
+    $P0 = get_hll_global ['PCT'], 'HLLCompiler'
+    $P1 = $P0.'new'()
+
+    $P1.'language'('pheme')
+    $P0 = get_hll_namespace ['Pheme';'Grammar']
+    $P1.'parsegrammar'($P0)
+    $P0 = get_hll_namespace ['Pheme';'AST';'Grammar']
+    $P1.'astgrammar'(  $P0)
+.end
+
+=item main(args :slurpy)  :main
+
+Start compilation by passing any command line C<args> to the Pheme compiler.
+
+=cut
+
+.sub 'main' :anon :main
+    .param pmc args
+
+    $P0 = compreg 'pheme'
+
+    .include 'except_severity.pasm'
+    .local pmc eh
+    eh = new 'ExceptionHandler'
+    eh.'handle_types'(.EXCEPT_EXIT)
+    set_addr eh, exit_handler
+    push_eh eh
+      $P1 = $P0.'command_line'(args)
+    pop_eh
+    goto done
+
+  exit_handler:
+    .get_results($P0)
+
+  done:
+    end
+.end
+
+=back
+
+=cut
+
+# Local Variables:
+#   mode: pir
+#   fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:

Added: pheme/trunk/t/atom.t
==============================================================================
--- /dev/null	00:00:00 1970	(empty, because file is newly added)
+++ pheme/trunk/t/atom.t	Tue Mar 10 19:44:41 2009	(r12)
@@ -0,0 +1,11 @@
+(include_file lib/PhemeTest.pir)
+
+(plan 4)
+
+(ok (atom? foo) "atom? should be true given one atom")
+
+(nok (atom? (foo)) "... but not a list")
+
+(ok (atom? (car (baz))) "car of one element list should make atom? true")
+
+(nok (atom? (cdr (quux qix))) "cdr of list should make atom? false")

Added: pheme/trunk/t/car.t
==============================================================================
--- /dev/null	00:00:00 1970	(empty, because file is newly added)
+++ pheme/trunk/t/car.t	Tue Mar 10 19:44:41 2009	(r12)
@@ -0,0 +1,7 @@
+(include_file lib/PhemeTest.pir)
+
+(plan 2)
+
+(is (car (biz baz)) biz "head of two element list is first element")
+
+(is (car (baz)) baz "head of one element list is still first element")

Added: pheme/trunk/t/cdr.t
==============================================================================
--- /dev/null	00:00:00 1970	(empty, because file is newly added)
+++ pheme/trunk/t/cdr.t	Tue Mar 10 19:44:41 2009	(r12)
@@ -0,0 +1,13 @@
+(include_file lib/PhemeTest.pir)
+
+(plan 2)
+
+(is
+	(cdr (biz baz buzz))
+	(baz buzz)
+	"tail of three elem list should be two elem list")
+
+(is
+	(cdr (biz baz))
+	(baz)
+	"tail of two elem list should be one elem list")

Added: pheme/trunk/t/cond.t
==============================================================================
--- /dev/null	00:00:00 1970	(empty, because file is newly added)
+++ pheme/trunk/t/cond.t	Tue Mar 10 19:44:41 2009	(r12)
@@ -0,0 +1,7 @@
+(include_file lib/PhemeTest.pir)
+
+(plan 2)
+
+(ok (cond (6) 6) "cond should return first value if first s-exp is true")
+
+(is (cond (atom? '()) foo (1) bar) bar "... or second if second s-exp is true")

Added: pheme/trunk/t/cons.t
==============================================================================
--- /dev/null	00:00:00 1970	(empty, because file is newly added)
+++ pheme/trunk/t/cons.t	Tue Mar 10 19:44:41 2009	(r12)
@@ -0,0 +1,35 @@
+(include_file lib/PhemeTest.pir)
+
+(plan 6)
+
+(is
+	(cons banana (and honey sandwich))
+	(banana and honey sandwich)
+	"cons of atom to list should add atom to list head")
+
+(is
+	(car (cons banana (and honey sandwich)))
+	banana
+	"cons of atom to list should add atom to list head")
+
+(is
+	(car (cons (banana) (and honey sandwich)))
+	(banana)
+	"cons of list to list should add list to list head")
+
+(is
+	(cons
+		((help) me)
+		(learn (this) (consing stuff)))
+	(((help) me) learn (this) ((consing stuff)))
+	"cons of list to list should add list to list head")
+
+(is
+	(cons (alpha beta (gamma)) '())
+	((alpha beta (gamma)))
+	"cons onto empty list should wrap sexpr in another cons")
+
+(is
+	(cons a (car ((b) c d)))
+	(a b)
+	"cons onto list should prepend element to list")

Added: pheme/trunk/t/divide.t
==============================================================================
--- /dev/null	00:00:00 1970	(empty, because file is newly added)
+++ pheme/trunk/t/divide.t	Tue Mar 10 19:44:41 2009	(r12)
@@ -0,0 +1,11 @@
+(include_file lib/PhemeTest.pir)
+
+(plan 2)
+
+(is (/ 999 3) 333 "slash operator should divide two integers")
+
+(is (/ 105 10) 10.5 "... and two floats")
+
+;(is_exception (/ 1 2 3 4 5) "some exception" "... but shouldn't allow a list of more than two atoms")
+
+;(is_exception (/ 5) "some exception" "... nor of fewer than two atoms")

Added: pheme/trunk/t/harness
==============================================================================
--- /dev/null	00:00:00 1970	(empty, because file is newly added)
+++ pheme/trunk/t/harness	Tue Mar 10 19:44:41 2009	(r12)
@@ -0,0 +1,8 @@
+#! perl
+
+use strict;
+use warnings;
+
+use lib 'lib', '../../lib';
+
+use Parrot::Test::Harness language => 'pheme', compiler => 'pheme.pbc';

Added: pheme/trunk/t/lambda.t
==============================================================================
--- /dev/null	00:00:00 1970	(empty, because file is newly added)
+++ pheme/trunk/t/lambda.t	Tue Mar 10 19:44:41 2009	(r12)
@@ -0,0 +1,22 @@
+(include_file lib/PhemeTest.pir)
+
+(plan 3)
+
+(define carcar
+	(lambda (l)
+		(car (cdr l))))
+
+(is
+	(cdr (biz baz buzz))
+	(baz buzz)
+	"cdr gives final two elements")
+
+(is
+	(car (cdr (biz baz buzz)))
+	baz
+	"car gives first element")
+
+(is
+	(carcar (biz baz buzz))
+	baz
+	"head of two element list is first element")

Added: pheme/trunk/t/minus.t
==============================================================================
--- /dev/null	00:00:00 1970	(empty, because file is newly added)
+++ pheme/trunk/t/minus.t	Tue Mar 10 19:44:41 2009	(r12)
@@ -0,0 +1,12 @@
+(include_file lib/PhemeTest.pir)
+
+(plan 4)
+
+(is (- 77 7) 70 "minus operator should subtract first number from second")
+
+(is (- 77.8 0.73) 77.07 "... for floats too")
+
+(is (- 5000 495 5) 4500 "... for lists with more than 2 elements too")
+
+(is (- 33.06 54.32 1 2 3.5) -27.76
+    "... and for longer lists of floats with a negative result")

Added: pheme/trunk/t/multiply.t
==============================================================================
--- /dev/null	00:00:00 1970	(empty, because file is newly added)
+++ pheme/trunk/t/multiply.t	Tue Mar 10 19:44:41 2009	(r12)
@@ -0,0 +1,11 @@
+(include_file lib/PhemeTest.pir)
+
+(plan 3)
+
+(is (* 999 3) 2997 "asterisk operator should multiply two integers")
+
+(is (* 105 10.5) 1102.5 "... and two floats")
+
+(is (* 1 2 3 4 5) 120 "... and a list of of more than two atoms")
+
+;(is_exception (* 5) "some exception message" "... but not fewer than two atoms")

Added: pheme/trunk/t/null.t
==============================================================================
--- /dev/null	00:00:00 1970	(empty, because file is newly added)
+++ pheme/trunk/t/null.t	Tue Mar 10 19:44:41 2009	(r12)
@@ -0,0 +1,15 @@
+(include_file lib/PhemeTest.pir)
+
+(plan 6)
+
+(ok (null? '()) "null? should be true given an empty list")
+
+(ok (null? (quote ())) "... marked with quote")
+
+(ok (null? '()) "... or a single quote")
+
+(nok (null? (a list)) "null? should be false given a list with atoms")
+
+(nok (null? ((a list))) "... or a nested list")
+
+(nok (null? ( '() )) "... or even a list containing an empty list")

Added: pheme/trunk/t/phemer/chapter_1.t
==============================================================================
--- /dev/null	00:00:00 1970	(empty, because file is newly added)
+++ pheme/trunk/t/phemer/chapter_1.t	Tue Mar 10 19:44:41 2009	(r12)
@@ -0,0 +1,26 @@
+(include_file lib/PhemeTest.pir)
+
+(plan 6)
+
+(is (car (a b c)) a "car of (a b c) should be a")
+
+(is
+	(car
+		((a b c) x y z))
+	(a b c)
+	"car of ((a b c) x y z) should be (a b c)")
+
+(is (car ()) "nil" "car of empty list should be nil")
+
+(is_deeply
+	(car
+		(((hotdogs)) (and) (pickle) relish))
+	((hotdogs))
+	"car of list of double-nested lists should be double-nested list")
+
+(is_deeply
+ 	(cdr ((a b c) x y z))
+ 	(x y z)
+ 	"cdr of list of lists should be second part" )
+
+(is_deeply (cdr (hamburger)) () "cdr of one-element list should be empty list")

Added: pheme/trunk/t/plus.t
==============================================================================
--- /dev/null	00:00:00 1970	(empty, because file is newly added)
+++ pheme/trunk/t/plus.t	Tue Mar 10 19:44:41 2009	(r12)
@@ -0,0 +1,9 @@
+(include_file lib/PhemeTest.pir)
+
+(plan 3)
+
+(is (+ 1 1) 2 "plus operator should add two numbers")
+
+(is (+ 1 2 3 4 5) 15 "plus operator should add a list of numbers")
+
+(is (+ 1.1 2.2 3.3 4.4 5.5) 16.5 "... a list of floats too")

Added: pheme/trunk/t/quote.t
==============================================================================
--- /dev/null	00:00:00 1970	(empty, because file is newly added)
+++ pheme/trunk/t/quote.t	Tue Mar 10 19:44:41 2009	(r12)
@@ -0,0 +1,11 @@
+(include_file lib/PhemeTest.pir)
+
+(plan 4)
+
+(is 'cons "cons" "quoting a symbol name should prevent execution")
+
+(is 'cons "cons" "quoting a symbol name should prevent execution")
+
+(is_deeply (quote ()) '() "quote on the empty list should give the empty list")
+
+(is_deeply (quote (car cdr)) (cons 'car ('cdr)) "quote should handle a list")

Added: pheme/trunk/t/write.t
==============================================================================
--- /dev/null	00:00:00 1970	(empty, because file is newly added)
+++ pheme/trunk/t/write.t	Tue Mar 10 19:44:41 2009	(r12)
@@ -0,0 +1,19 @@
+(write "1..4\n")
+
+(write "ok 1 - all in one line\n")
+
+(write "ok " 2 " - a list of quoted and unquoted atoms" "\n")
+
+(write "ok" " " "3" " - a list of mixed, quoted atoms\n")
+
+(write ok)
+
+(write " ")
+
+(write "4")
+
+(write " - " )
+
+(write "separate write statements")
+
+(write "\n")


More information about the parrot-commits mailing list