[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