[svn:parrot] r35311 - in trunk: . languages/perl6 languages/perl6/config/makefiles languages/perl6/src/builtins languages/perl6/src/classes languages/perl6/src/parser languages/perl6/src/pmc languages/perl6/t languages/perl6/t/00-parrot languages/perl6/t/

From:

pmichaud

Date:

January 9, 2009 07:51

Subject:

Message ID:

20090109155045.6FE92CB9F9@x12.develooper.com

Author: pmichaud Date: Fri Jan 9 07:50:41 2009 New Revision: 35311 Added: trunk/languages/perl6/src/classes/Regex.pir (contents, props changed) - copied, changed from r35307, /branches/rvar2/languages/perl6/src/classes/Regex.pir Modified: trunk/MANIFEST trunk/languages/perl6/config/makefiles/root.in trunk/languages/perl6/perl6.pir trunk/languages/perl6/src/builtins/assign.pir trunk/languages/perl6/src/builtins/globals.pir trunk/languages/perl6/src/builtins/guts.pir trunk/languages/perl6/src/builtins/op.pir trunk/languages/perl6/src/classes/Array.pir trunk/languages/perl6/src/classes/Hash.pir trunk/languages/perl6/src/classes/Object.pir trunk/languages/perl6/src/classes/Pair.pir trunk/languages/perl6/src/classes/Protoobject.pir trunk/languages/perl6/src/classes/Signature.pir trunk/languages/perl6/src/parser/actions.pm trunk/languages/perl6/src/parser/grammar.pg trunk/languages/perl6/src/pmc/objectref_pmc.template trunk/languages/perl6/src/pmc/perl6multisub.pmc trunk/languages/perl6/t/00-parrot/05-var.t trunk/languages/perl6/t/00-parrot/08-regex.t trunk/languages/perl6/t/pmc/objectref.t trunk/languages/perl6/t/pmc/perl6multisub-arity.t trunk/languages/perl6/t/pmc/perl6multisub-tiebreak.t trunk/languages/perl6/t/pmc/perl6multisub-type.t trunk/languages/perl6/t/spectest.data Log: [rakudo]: Merge rvar2 branch to trunk. This is a major refactor of variable and parameter handling in Rakudo. jonathan++, particle++, and others for assistance with the branch. Modified: trunk/MANIFEST ============================================================================== --- trunk/MANIFEST (original) +++ trunk/MANIFEST Fri Jan 9 07:50:41 2009 @@ -1,7 +1,7 @@ # ex: set ro: # $Id$ # -# generated by tools/dev/mk_manifest_and_skip.pl Wed Jan 7 19:48:30 2009 UT +# generated by tools/dev/mk_manifest_and_skip.pl Fri Jan 9 15:18:09 2009 UT # # See tools/dev/install_files.pl for documentation on the # format of this file. @@ -2154,6 +2154,7 @@ languages/perl6/src/classes/Positional.pir [perl6] languages/perl6/src/classes/Protoobject.pir [perl6] languages/perl6/src/classes/Range.pir [perl6] +languages/perl6/src/classes/Regex.pir [perl6] languages/perl6/src/classes/Role.pir [perl6] languages/perl6/src/classes/Routine.pir [perl6] languages/perl6/src/classes/Scalar.pir [perl6] @@ -3568,6 +3569,10 @@ t/pmc/orderedhash.t [] t/pmc/os.t [] t/pmc/packfile.t [] +t/pmc/packfileconstanttable.t [] +t/pmc/packfiledirectory.t [] +t/pmc/packfilerawsegment.t [] +t/pmc/packfilesegment.t [] t/pmc/pair.t [] t/pmc/parrotclass.t [] t/pmc/parrotinterpreter.t [] Modified: trunk/languages/perl6/config/makefiles/root.in ============================================================================== --- trunk/languages/perl6/config/makefiles/root.in (original) +++ trunk/languages/perl6/config/makefiles/root.in Fri Jan 9 07:50:41 2009 @@ -69,6 +69,7 @@ src/classes/Block.pir \ src/classes/Routine.pir \ src/classes/Sub.pir \ + src/classes/Regex.pir \ src/classes/Method.pir \ src/classes/Junction.pir \ src/classes/Failure.pir \ Modified: trunk/languages/perl6/perl6.pir ============================================================================== --- trunk/languages/perl6/perl6.pir (original) +++ trunk/languages/perl6/perl6.pir Fri Jan 9 07:50:41 2009 @@ -88,7 +88,7 @@ setattribute perl6, '$version', $P0 ## create a list for holding the stack of nested blocks - $P0 = new 'List' + $P0 = new ['List'] set_hll_global ['Perl6';'Grammar';'Actions'], '@?BLOCK', $P0 ## create a list for holding the stack of nested packages @@ -96,23 +96,19 @@ $P0 = new 'List' set_hll_global ['Perl6';'Grammar';'Actions'], '@?PACKAGE', $P0 - ## create a list for holding the stack of nested modules - ## (that may be roles, classes or grammars). - $P0 = new 'List' - set_hll_global ['Perl6';'Grammar';'Actions'], '@?MODULE', $P0 - - ## create a list for holding the stack of nested classes - ## (that may be classes or grammars). + ## create a list for holding the stack of nested package + ## declarators $P0 = new 'List' - set_hll_global ['Perl6';'Grammar';'Actions'], '@?CLASS', $P0 + set_hll_global ['Perl6';'Grammar';'Actions'], '@?PKGDECL', $P0 - ## create a list for holding the stack of nested roles - $P0 = new 'List' - set_hll_global ['Perl6';'Grammar';'Actions'], '@?ROLE', $P0 - - ## create a list for holding the stack of nested grammars - $P0 = new 'List' - set_hll_global ['Perl6';'Grammar';'Actions'], '@?GRAMMAR', $P0 + ## create a (shared) metaclass node + $P0 = get_hll_global ['PAST'], 'Var' + $P0 = $P0.'new'( 'name'=>'metaclass', 'scope'=>'register' ) + set_hll_global ['Perl6';'Grammar';'Actions'], '$?METACLASS', $P0 + + ## create the $?CLASSMAP hash + $P0 = new ['Hash'] + set_hll_global ['Perl6';'Grammar';'Actions'], '%?CLASSMAP', $P0 ## create a list of END blocks to be run $P0 = new 'List' Modified: trunk/languages/perl6/src/builtins/assign.pir ============================================================================== --- trunk/languages/perl6/src/builtins/assign.pir (original) +++ trunk/languages/perl6/src/builtins/assign.pir Fri Jan 9 07:50:41 2009 @@ -16,7 +16,7 @@ .param pmc cont .param pmc source - source = 'Scalar'(source) + source = '!CALLMETHOD'('Scalar', source) .local pmc ro, type getprop ro, 'readonly', cont if null ro goto ro_ok @@ -27,13 +27,21 @@ unless $I0 goto do_assign getprop type, 'type', cont if null type goto do_assign + # XXX FIXME We should instead translate this to a proto. + $I0 = isa type, 'NameSpace' + if $I0 goto do_assign $I0 = type.'ACCEPTS'(source) if $I0 goto do_assign 'die'("Type mismatch in assignment.") do_assign: - eq_addr cont, source, skip_copy + eq_addr cont, source, assign_done copy cont, source - skip_copy: + # We need to copy over any $!signature property on sub objects + $I0 = isa source, 'Sub' + unless $I0 goto assign_done + $P0 = getprop '$!signature', source + setprop cont, '$!signature', $P0 + assign_done: .return (cont) .end @@ -73,23 +81,41 @@ .param pmc source ## get the list of containers and sources + $P0 = new ['List'] + splice $P0, list, 0, 0 + list = $P0 source = source.'list'() source.'!flatten'() - ## first, temporarily mark each container with a property - ## so we can clone it in source if needed - .local pmc it, true - it = iter list + ## now, go through our list of containers, flattening + ## any intermediate lists we find, and marking each + ## container with a property so we can clone it in source + ## if needed + .local pmc true + .local int i true = box 1 + i = 0 mark_loop: - unless it goto mark_done - $P0 = shift it - setprop $P0, 'target', true + $I0 = elements list + unless i < $I0 goto mark_done + .local pmc cont + cont = list[i] + $I0 = isa cont, ['ObjectRef'] + if $I0 goto mark_next + $I0 = isa cont, ['Perl6Array'] + if $I0 goto mark_next + $I0 = does cont, 'array' + unless $I0 goto mark_next + splice list, cont, $I0, 1 + goto mark_loop + mark_next: + setprop cont, 'target', true + inc i goto mark_loop mark_done: ## now build our 'real' source list, cloning any targets we encounter - .local pmc slist + .local pmc slist, it slist = new 'List' it = iter source source_loop: Modified: trunk/languages/perl6/src/builtins/globals.pir ============================================================================== --- trunk/languages/perl6/src/builtins/globals.pir (original) +++ trunk/languages/perl6/src/builtins/globals.pir Fri Jan 9 07:50:41 2009 @@ -75,6 +75,10 @@ config = interp[.IGLOBALS_CONFIG_HASH] vm['config'] = config set_hll_global "%VM", vm + + ## the default value for new ObjectRefs + $P0 = 'undef'() + set_hll_global '$!OBJECTREF', $P0 .end Modified: trunk/languages/perl6/src/builtins/guts.pir ============================================================================== --- trunk/languages/perl6/src/builtins/guts.pir (original) +++ trunk/languages/perl6/src/builtins/guts.pir Fri Jan 9 07:50:41 2009 @@ -58,6 +58,36 @@ .end +=item !CALLMETHOD('method', obj) + +Invoke a method on a possibly foreign object. If the object +supports the requested method, we use it, otherwise we assume +the object is foreign and try using the corresponding method +from C<Any>. + +=cut + +.namespace [] +.sub '!CALLMETHOD' + .param string method + .param pmc obj + $I0 = isa obj, 'ObjectRef' + if $I0 goto any_method + $I0 = can obj, method + unless $I0 goto any_method + .tailcall obj.method() + any_method: + .local pmc anyobj + anyobj = get_global '$!ANY' + unless null anyobj goto any_method_1 + anyobj = new 'Any' + set_global '$!ANY', anyobj + any_method_1: + $P0 = find_method anyobj, method + .tailcall obj.$P0() +.end + + =item !VAR Helper function for implementing the VAR and .VAR macros. @@ -162,8 +192,8 @@ unless $I0 == $I1 goto not_junc .local pmc j1, j2 .local int max, i - j1 = t1.'values'() - j2 = t1.'values'() + j1 = t1.'!eigenstates'() + j2 = t1.'!eigenstates'() max = elements j1 i = 0 junc_loop: @@ -291,9 +321,13 @@ # also add it back to the class. .local pmc class class = get_class namespace - if null class goto no_class + if null class goto class_done class.'remove_method'(name) - no_class: + $I0 = isa class, 'Class' + if $I0 goto class_done + ## class isn't really a Class, it's (likely) a Role + class.'add_method'(name, p6multi) + class_done: # Make new namespace entry. namespace[name] = p6multi @@ -336,6 +370,397 @@ .end +=item !capture + +Combine slurpy positional and slurpy named args into a list. +Note that original order may be lost -- that's the nature +of captures. + +=cut + +.sub '!capture' + .param pmc args :slurpy + .param pmc options :slurpy :named + unless options goto done + .local pmc it + it = iter options + iter_loop: + unless it goto done + $S0 = shift it + $P0 = options[$S0] + $P0 = 'infix:=>'($S0, $P0) + push args, $P0 + goto iter_loop + done: + .tailcall args.'list'() +.end + + +=item !meta_create(type, name, also) + +Create a metaclass object for C<type> with the given C<name>. +This simply creates a handle on which we can hang methods, attributes, +traits, etc. -- the class itself isn't created until the class +is composed (see C<!meta_compose> below). + +=cut + +.sub '!meta_create' + .param string type + .param string name + .param int also + + .local pmc nsarray + $P0 = compreg 'Perl6' + nsarray = $P0.'parse_name'(name) + + if type == 'package' goto package + if type == 'module' goto package + if type == 'class' goto class + if type == 'grammar' goto class + if type == 'role' goto role + 'die'("Unsupported package declarator ", type) + + package: + $P0 = get_hll_namespace nsarray + .return ($P0) + + class: + .local pmc metaclass, ns + ns = get_hll_namespace nsarray + if also goto is_also + metaclass = newclass ns + $P0 = box type + setprop metaclass, 'pkgtype', $P0 + .return (metaclass) + is_also: + metaclass = get_class ns + .return (metaclass) + + role: + .local pmc info, metarole + info = new 'Hash' + $P0 = nsarray[-1] + info['name'] = $P0 + info['namespace'] = nsarray + metarole = new 'Role', info + nsarray = clone nsarray + $S0 = pop nsarray + set_hll_global nsarray, $S0, metarole + .return (metarole) +.end + + +=item !meta_compose(Class metaclass) + +Compose the class. This includes resolving any inconsistencies +and creating the protoobjects. + +=cut + +.sub '!meta_compose' :multi(['Class']) + .param pmc metaclass + .local pmc p6meta + p6meta = get_hll_global ['Perl6Object'], '$!P6META' + + # Parrot handles composing methods into roles, but we need to handle the + # attribute composition ourselves. + .local pmc roles, roles_it + roles = inspect metaclass, 'roles' + roles_it = iter roles + roles_it_loop: + unless roles_it goto roles_it_loop_end + $P0 = shift roles_it + '!compose_role_attributes'(metaclass, $P0) + goto roles_it_loop + roles_it_loop_end: + + # Create proto-object with default parent being Any or Grammar. + $S0 = 'Any' + $P0 = getprop 'pkgtype', metaclass + if null $P0 goto no_pkgtype + if $P0 != 'grammar' goto register + $S0 = 'Grammar' + register: + .tailcall p6meta.'register'(metaclass, 'parent'=>$S0) + no_pkgtype: +.end + + +=item !meta_compose() + +Default meta composer -- does nothing. + + +=cut + +.sub '!meta_compose' :multi() + .param pmc metaclass + # Currently, nothing to do. +.end + + +=item !meta_trait(metaclass, type, name) + +Add a trait with the given C<type> and C<name> to C<metaclass>. + +=cut + +.sub '!meta_trait' + .param pmc metaclass + .param string type + .param string name + + if type == 'trait_auxiliary:is' goto is + if type == 'trait_auxiliary:does' goto does + 'die'("Unknown trait auxiliary ", type) + + is: + ## get the (parrot)class object associated with name + $P0 = compreg 'Perl6' + $P0 = $P0.'parse_name'(name) + $P0 = get_hll_namespace $P0 + $P0 = get_class $P0 + + ## add it as parent to metaclass + metaclass.'add_parent'($P0) + .return () + + does: + ## get the role to be composed + $P0 = compreg 'Perl6' + $P0 = $P0.'parse_name'(name) + $S0 = pop $P0 + $P0 = get_hll_global $P0, $S0 + + ## add it to the class. + metaclass.'add_role'($P0) +.end + + +=item !meta_attribute(metaclass, name, itype [, 'type'=>type] ) + +Add attribute C<name> to C<metaclass> with the given C<itype> +and C<type>. + +=cut + +.sub '!meta_attribute' + .param pmc metaclass + .param string name + .param string itype :optional + .param int has_itype :opt_flag + .param pmc attr :slurpy :named + + # twigil handling + .local string twigil + twigil = substr name, 1, 1 + if twigil == '.' goto twigil_public + if twigil == '!' goto twigil_done + substr name, 1, 0, '!' + goto twigil_done + twigil_public: + substr name, 1, 1, '!' + twigil_done: + + $P0 = metaclass.'attributes'() + $I0 = exists $P0[name] + if $I0 goto attr_exists + metaclass.'add_attribute'(name) + $P0 = metaclass.'attributes'() + attr_exists: + + .local pmc attrhash, it + attrhash = $P0[name] + + # Set any itype for the attribute. + unless has_itype goto itype_done + attrhash['itype'] = itype + itype_done: + + # and set any other attributes that came in via the slurpy hash + it = iter attr + attr_loop: + unless it goto attr_done + $S0 = shift it + $P0 = attr[$S0] + attrhash[$S0] = $P0 + goto attr_loop + attr_done: + + .const 'Sub' handles = '!handles' + $P0 = attr['traitlist'] + if null $P0 goto traitlist_done + it = iter $P0 + traitlist_loop: + unless it goto traitlist_done + .local pmc trait + trait = shift it + $S0 = trait[0] + if $S0 != 'trait_verb:handles' goto traitlist_loop + .local pmc handles_it + $P0 = trait[1] + $P0 = 'list'($P0) + handles_it = iter $P0 + handles_loop: + unless handles_it goto handles_done + $P0 = clone handles + $P1 = box name + setprop $P0, 'attrname', $P1 + $P1 = shift handles_it + setprop $P0, 'methodname', $P1 + $S1 = $P1 + metaclass.'add_method'($S1, $P0) + goto handles_loop + handles_done: + goto traitlist_loop + traitlist_done: +.end + + +.sub '!handles' :method + .param pmc args :slurpy + .param pmc options :slurpy :named + .local pmc method, attribute + $P0 = getinterp + method = $P0['sub'] + $P1 = getprop 'attrname', method + $S1 = $P1 + attribute = getattribute self, $S1 + $P1 = getprop 'methodname', method + $S1 = $P1 + .tailcall attribute.$S1(args :flat, options :flat :named) +.end + + +=item !sub_trait(sub, type, trait, arg?) + +=cut + +.sub '!sub_trait' + .param pmc block + .param string type + .param string trait + .param pmc arg :optional + .param int has_arg :opt_flag + + if has_arg goto have_arg + null arg + have_arg: + + $S0 = concat '!sub_trait_', trait + $P0 = find_name $S0 + if null $P0 goto done + $P0(trait, block, arg) + done: +.end + + +=item !sub_trait_default(trait, block, arg) + +Sets the default trait, which marks a multi candidate as the default choice +in an ambiguous multiple dispatch. + +=cut + +.sub '!sub_trait_default' + .param string trait + .param pmc block + .param pmc arg + $P0 = new 'Integer' + $P0 = 1 + setprop block, 'default', $P0 +.end + + +=item !sub_trait_export(trait, block, arg) + +=cut + +.sub '!sub_trait_export' + .param string trait + .param pmc block + .param pmc arg + + .local string blockname + blockname = block + .local pmc blockns, exportns + blockns = block.'get_namespace'() + exportns = blockns.'make_namespace'('EXPORT') + if null arg goto arg_done + .local pmc it + arg = arg.'list'() + it = iter arg + arg_loop: + unless it goto arg_done + .local pmc tag, ns + tag = shift it + $I0 = isa tag, ['Perl6Pair'] + unless $I0 goto arg_loop + $S0 = tag.'key'() + ns = exportns.'make_namespace'($S0) + ns[blockname] = block + goto arg_loop + arg_done: + ns = exportns.'make_namespace'('ALL') + ns[blockname] = block +.end + + +=item !compose_role_attributes(class, role) + +Helper method to compose the attributes of a role into a class. + +=cut + +.sub '!compose_role_attributes' + .param pmc class + .param pmc role + + .local pmc role_attrs, class_attrs, ra_iter + .local string cur_attr + role_attrs = inspect role, "attributes" + class_attrs = inspect class, "attributes" + ra_iter = iter role_attrs + ra_iter_loop: + unless ra_iter goto ra_iter_loop_end + cur_attr = shift ra_iter + + # Check that this attribute doesn't conflict with one already in the class. + $I0 = exists class_attrs[cur_attr] + unless $I0 goto no_conflict + + # We have a name conflict. Let's compare the types. If they match, then we + # can merge the attributes. + .local pmc class_attr_type, role_attr_type + $P0 = class_attrs[cur_attr] + if null $P0 goto conflict + class_attr_type = $P0['type'] + if null class_attr_type goto conflict + $P0 = role_attrs[cur_attr] + if null $P0 goto conflict + role_attr_type = $P0['type'] + if null role_attr_type goto conflict + $I0 = '!SAMETYPE_EXACT'(class_attr_type, role_attr_type) + if $I0 goto merge + + conflict: + $S0 = "Conflict of attribute '" + $S0 = concat cur_attr + $S0 = concat "' in composition of role '" + $S1 = role + $S0 = concat $S1 + $S0 = concat "'" + 'die'($S0) + + no_conflict: + addattribute class, cur_attr + merge: + goto ra_iter_loop + ra_iter_loop_end: +.end + + =item !keyword_class(name) Internal helper method to create a class. Modified: trunk/languages/perl6/src/builtins/op.pir ============================================================================== --- trunk/languages/perl6/src/builtins/op.pir (original) +++ trunk/languages/perl6/src/builtins/op.pir Fri Jan 9 07:50:41 2009 @@ -404,6 +404,7 @@ if $I0 goto one_role $I0 = isa role, 'List' if $I0 goto many_roles + error: 'die'("'does' expects a role or a list of roles") one_role: @@ -416,6 +417,8 @@ roles_loop: unless role_it goto roles_loop_end cur_role = shift role_it + $I0 = isa cur_role, 'Role' + unless $I0 goto error '!keyword_does'(derived, cur_role) goto roles_loop roles_loop_end: Modified: trunk/languages/perl6/src/classes/Array.pir ============================================================================== --- trunk/languages/perl6/src/classes/Array.pir (original) +++ trunk/languages/perl6/src/classes/Array.pir Fri Jan 9 07:50:41 2009 @@ -251,7 +251,7 @@ array_loop: unless it goto array_done $P0 = shift it - $P0 = 'Scalar'($P0) + $P0 = '!CALLMETHOD'('Scalar',$P0) $P0 = clone $P0 push array, $P0 goto array_loop Modified: trunk/languages/perl6/src/classes/Hash.pir ============================================================================== --- trunk/languages/perl6/src/classes/Hash.pir (original) +++ trunk/languages/perl6/src/classes/Hash.pir Fri Jan 9 07:50:41 2009 @@ -130,7 +130,7 @@ key = elem.'key'() value = elem.'value'() iter_kv: - value = 'Scalar'(value) + value = '!CALLMETHOD'('Scalar', value) hash[key] = value goto iter_loop iter_hash: @@ -140,7 +140,7 @@ unless hashiter goto hashiter_done $S0 = shift hashiter value = elem[$S0] - value = 'Scalar'(value) + value = '!CALLMETHOD'('Scalar', value) value = clone value hash[$S0] = value goto hashiter_loop Modified: trunk/languages/perl6/src/classes/Object.pir ============================================================================== --- trunk/languages/perl6/src/classes/Object.pir (original) +++ trunk/languages/perl6/src/classes/Object.pir Fri Jan 9 07:50:41 2009 @@ -52,17 +52,23 @@ result = clone self # Set any new attributes. - .local pmc it - it = iter new_attrs - it_loop: - unless it goto it_loop_end - $S0 = shift it - $P0 = new_attrs[$S0] - $S0 = concat '!', $S0 - $P1 = result.$S0() - 'infix:='($P1, $P0) - goto it_loop - it_loop_end: + .local pmc p6meta, parrotclass, attributes, it + p6meta = get_hll_global ['Perl6Object'], '$!P6META' + parrotclass = p6meta.'get_parrotclass'(result) + attributes = inspect parrotclass, 'attributes' + it = iter attributes + attrinit_loop: + unless it goto attrinit_done + .local string attrname, shortname + attrname = shift it + shortname = substr attrname, 2 + $I0 = exists new_attrs[shortname] + unless $I0 goto attrinit_loop + $P0 = getattribute result, attrname + $P1 = new_attrs[shortname] + 'infix:='($P0, $P1) + goto attrinit_loop + attrinit_done: .return (result) .end @@ -228,7 +234,7 @@ =cut .namespace ['Perl6Object'] -.sub '' :method('Scalar') :anon +.sub 'Scalar' :method $I0 = isa self, 'ObjectRef' unless $I0 goto not_ref .return (self) @@ -237,21 +243,6 @@ .return ($P0) .end -.namespace [] -.sub 'Scalar' - .param pmc source - $I0 = isa source, 'ObjectRef' - if $I0 goto done - $I0 = can source, 'Scalar' - if $I0 goto can_scalar - $I0 = does source, 'scalar' - source = new 'ObjectRef', source - done: - .return (source) - can_scalar: - .tailcall source.'Scalar'() -.end - =item Str() Return a string representation of the invocant. Default is @@ -272,183 +263,146 @@ =back -=head2 Special methods +=head2 Object constructor methods =over 4 -=item new() - -Create a new object having the same class as the invocant. - =cut .namespace ['Perl6Object'] -.sub 'new' :method - .param pmc init_parents :slurpy - .param pmc init_this :named :slurpy +.sub 'bless' :method + .param pmc posargs :slurpy + .param pmc attrinit :slurpy :named + + .local pmc candidate + candidate = self.'CREATE'() + .tailcall self.'BUILDALL'(candidate, attrinit, posargs) +.end + + +.sub 'BUILD' :method + .param pmc candidate + .param pmc attrinit :slurpy :named + + .local pmc p6meta, parrotclass, attributes, it + p6meta = get_hll_global ['Perl6Object'], '$!P6META' + parrotclass = p6meta.'get_parrotclass'(self) + attributes = inspect parrotclass, 'attributes' + it = iter attributes + attrinit_loop: + unless it goto attrinit_done + .local string attrname + .local pmc attrhash, itypeclass + attrname = shift it + attrhash = attributes[attrname] + itypeclass = attrhash['itype'] + unless null itypeclass goto attrinit_itype + $S0 = substr attrname, 0, 1 + if $S0 == '@' goto attrinit_array + if $S0 == '%' goto attrinit_hash + itypeclass = get_class ['ObjectRef'] + goto attrinit_itype + attrinit_array: + itypeclass = get_class ['Perl6Array'] + goto attrinit_itype + attrinit_hash: + itypeclass = get_class ['Perl6Hash'] + attrinit_itype: + .local pmc attr + attr = new itypeclass + setattribute candidate, parrotclass, attrname, attr + $P0 = attrhash['type'] + setprop attr, 'type', $P0 + .local string keyname + $I0 = index attrname, '!' + if $I0 < 0 goto attrinit_loop + inc $I0 + keyname = substr attrname, $I0 + $P0 = attrinit[keyname] + unless null $P0 goto attrinit_assign + $P0 = attrhash['init_value'] + if null $P0 goto attrinit_loop + attrinit_assign: + 'infix:='(attr, $P0) + goto attrinit_loop + attrinit_done: + .return (candidate) +.end + - # Instantiate. +.sub 'BUILDALL' :method + .param pmc candidate + .param pmc attrinit + .param pmc posargs + + .include 'iterator.pasm' + .local pmc p6meta, parents, it + p6meta = get_hll_global ['Perl6Object'], '$!P6META' + $P0 = p6meta.'get_parrotclass'(self) + parents = inspect $P0, 'all_parents' + it = iter parents + set it, .ITERATE_FROM_END + parents_loop: + # Loop through all of the parent classes, in reverse mro. + # For each parent class, call its BUILD method with the + # appropriate arguments. + unless it goto parents_done + $P0 = pop it + $I0 = isa $P0, 'PMCProxy' + if $I0 goto parents_loop + .local pmc parentproto + $P0 = getprop 'metaclass', $P0 + parentproto = $P0.'WHAT'() + $I0 = can parentproto, 'BUILD' + unless $I0 goto parents_loop + # Look through posargs for a corresponding protoobject + # with a WHENCE property. If found, that WHENCE property + # is used as the arguments to the parent class BUILD. + .local pmc pos_it, argproto + pos_it = iter posargs + posargs_loop: + unless pos_it goto posargs_done + argproto = shift pos_it + $P1 = $P0.'WHAT'() + ne_addr parentproto, $P1, posargs_loop + $P0 = argproto.'WHENCE'() + if null $P0 goto posargs_done + parentproto.'BUILD'(candidate, $P0 :flat :named) + goto parents_loop + posargs_done: + parentproto.'BUILD'(candidate, attrinit :flat :named) + goto parents_loop + parents_done: + .return (candidate) +.end + + +=item CREATE() + +Create a candidate object of the type given by the invocant. + +=cut + +.sub 'CREATE' :method .local pmc p6meta p6meta = get_hll_global ['Perl6Object'], '$!P6META' $P0 = p6meta.'get_parrotclass'(self) $P1 = new $P0 + .return ($P1) +.end - # If this proto object has a WHENCE auto-vivification, we should use - # put any values it contains but that init_this does not into init_this. - .local pmc whence - whence = self.'WHENCE'() - unless whence goto no_whence - .local pmc this_whence_iter - this_whence_iter = iter whence - this_whence_iter_loop: - unless this_whence_iter goto no_whence - $S0 = shift this_whence_iter - $I0 = exists init_this[$S0] - if $I0 goto this_whence_iter_loop - $P2 = whence[$S0] - init_this[$S0] = $P2 - goto this_whence_iter_loop - no_whence: - - # Now we will initialize each attribute in the class itself and it's - # parents with an Undef or the specified initialization value. Note that - # the all_parents list includes ourself. - .local pmc all_parents, class_iter - all_parents = inspect $P0, "all_parents" - class_iter = iter all_parents - class_iter_loop: - unless class_iter goto class_iter_loop_end - .local pmc cur_class - cur_class = shift class_iter - - # If it's PMCProxy, then skip over it, since it's attribute is the delegate - # instance of a parent PMC class, which we should not change to Undef. - .local int is_pmc_proxy - is_pmc_proxy = isa cur_class, "PMCProxy" - if is_pmc_proxy goto class_iter_loop_end - - # If this the current class? - .local pmc init_attribs - eq_addr cur_class, $P0, current_class - - # If it's not the current class, need to see if we have any attributes. - # Go through the provided init_parents to see if we have anything that - # matches. - .local pmc ip_iter, cur_ip - ip_iter = iter init_parents - ip_iter_loop: - unless ip_iter goto ip_iter_loop_end - cur_ip = shift ip_iter - - # We will check if their HOW matches. - $P2 = p6meta.'get_parrotclass'(cur_ip) - eq_addr cur_class, $P2, found_parent_init - - goto found_init_attribs - ip_iter_loop_end: - - # If we get here, found nothing. - init_attribs = new 'Hash' - goto parent_init_search_done - - # We found some parent init data, potentially. - found_parent_init: - init_attribs = cur_ip.'WHENCE'() - $I0 = 'defined'(init_attribs) - if $I0 goto parent_init_search_done - init_attribs = new 'Hash' - parent_init_search_done: - goto found_init_attribs - - # If it's the current class, we will take the init_this hash. - current_class: - init_attribs = init_this - found_init_attribs: - - # Now go through attributes of the current class and iternate over them. - .local pmc attribs, it - attribs = inspect cur_class, "attributes" - it = iter attribs - iter_loop: - unless it goto iter_end - $S0 = shift it - - # See if we have an init value; use Undef if not. - .local int got_init_value - $S1 = substr $S0, 2 - got_init_value = exists init_attribs[$S1] - if got_init_value goto have_init_value - $P2 = new 'Undef' - goto init_done - have_init_value: - $P2 = init_attribs[$S1] - delete init_attribs[$S1] - init_done: - - # Is it a scalar? If so, want a scalar container with the type set on it. - .local string sigil - sigil = substr $S0, 0, 1 - if sigil != '$' goto no_scalar - .local pmc attr_info, type - attr_info = attribs[$S0] - if null attr_info goto set_attrib - type = attr_info['type'] - if null type goto set_attrib - if got_init_value goto no_proto_init - $I0 = isa type, 'P6protoobject' - unless $I0 goto no_proto_init - set $P2, type - no_proto_init: - $P2 = new 'Perl6Scalar', $P2 - setprop $P2, 'type', type - goto set_attrib - no_scalar: - - # Is it an array? If so, initialize to Perl6Array. - if sigil != '@' goto no_array - $P3 = new 'Perl6Array' - $I0 = defined $P2 - if $I0 goto have_array_value - set $P2, $P3 - goto set_attrib - have_array_value: - 'infix:='($P3, $P2) - set $P2, $P3 - goto set_attrib - no_array: - - # Is it a Hash? If so, initialize to Perl6Hash. - if sigil != '%' goto no_hash - $P3 = new 'Perl6Hash' - $I0 = defined $P2 - if $I0 goto have_hash_value - set $P2, $P3 - goto set_attrib - have_hash_value: - 'infix:='($P3, $P2) - set $P2, $P3 - goto set_attrib - no_hash: - - set_attrib: - push_eh set_attrib_eh - setattribute $P1, cur_class, $S0, $P2 - set_attrib_eh: - pop_eh - goto iter_loop - iter_end: - - # Do we have anything left in the hash? If so, unknown. - $I0 = elements init_attribs - if $I0 == 0 goto init_attribs_ok - 'die'("You passed an initialization parameter that does not have a matching attribute.") - init_attribs_ok: - - # Next class. - goto class_iter_loop - class_iter_loop_end: - .return ($P1) +=item new() + +Create a new object having the same class as the invocant. + +=cut + +.sub 'new' :method + .param pmc posargs :slurpy + .param pmc attrinit :slurpy :named + + .tailcall self.'bless'(posargs :flat, attrinit :flat :named) .end =item 'PARROT' Modified: trunk/languages/perl6/src/classes/Pair.pir ============================================================================== --- trunk/languages/perl6/src/classes/Pair.pir (original) +++ trunk/languages/perl6/src/classes/Pair.pir Fri Jan 9 07:50:41 2009 @@ -153,8 +153,12 @@ .param pmc value key = key.'item'() value = value.'item'() - $P0 = get_hll_global 'Pair' - .tailcall $P0.'new'('key'=>key, 'value'=>value) + $P0 = new ['Perl6Pair'] + $P1 = new ['ObjectRef'] + 'infix:='($P1, key) + setattribute $P0, '$!key', $P1 + setattribute $P0, '$!value', value + .return ($P0) .end Modified: trunk/languages/perl6/src/classes/Protoobject.pir ============================================================================== --- trunk/languages/perl6/src/classes/Protoobject.pir (original) +++ trunk/languages/perl6/src/classes/Protoobject.pir Fri Jan 9 07:50:41 2009 @@ -73,6 +73,19 @@ =back +=head2 Coercions + +=over + +=item Scalar() + +=cut + +.namespace ['P6protoobject'] +.sub 'Scalar' :method + .return (self) +.end + =head2 Private methods =over Copied: trunk/languages/perl6/src/classes/Regex.pir (from r35307, /branches/rvar2/languages/perl6/src/classes/Regex.pir) ============================================================================== --- /branches/rvar2/languages/perl6/src/classes/Regex.pir (original) +++ trunk/languages/perl6/src/classes/Regex.pir Fri Jan 9 07:50:41 2009 @@ -1,31 +1,31 @@ -## $Id: $ - -=head1 TITLE - -Regex - Perl 6 Regex class - -=head1 DESCRIPTION - -This file sets up the Perl 6 C<Regex> class, the class for regexes. - -=cut - -.namespace ['Regex'] - -.sub 'onload' :anon :load :init - .local pmc p6meta - p6meta = get_hll_global ['Perl6Object'], '$!P6META' - p6meta.'new_class'('Regex', 'parent'=>'Routine') -.end - -=over 4 - -=back - -=cut - -# Local Variables: -# mode: pir -# fill-column: 100 -# End: -# vim: expandtab shiftwidth=4 ft=pir: +## $Id$ + +=head1 TITLE + +Regex - Perl 6 Regex class + +=head1 DESCRIPTION + +This file sets up the Perl 6 C<Regex> class, the class for regexes. + +=cut + +.namespace ['Regex'] + +.sub 'onload' :anon :load :init + .local pmc p6meta + p6meta = get_hll_global ['Perl6Object'], '$!P6META' + p6meta.'new_class'('Regex', 'parent'=>'Routine') +.end + +=over 4 + +=back + +=cut + +# Local Variables: +# mode: pir +# fill-column: 100 +# End: +# vim: expandtab shiftwidth=4 ft=pir: Modified: trunk/languages/perl6/src/classes/Signature.pir ============================================================================== --- trunk/languages/perl6/src/classes/Signature.pir (original) +++ trunk/languages/perl6/src/classes/Signature.pir Fri Jan 9 07:50:41 2009 @@ -43,24 +43,24 @@ =over 4 -=item !create +=item !add_param( $varname, *%attr ) -Used to create a new signature object with the given paramter descriptors. The -constraints entry that we actually get passed in here contains both class, role -and subset types; we separate them out in here. At some point in the future, we -should be smart enough to do this at compile time. +Add the attributes given by C<%attr> as the entry for C<$var> in +the Signature. =cut -.sub '!create' :method - .param pmc parameters :slurpy - - # Iterate over parameters. - .local pmc param_iter, cur_param - param_iter = iter parameters - param_loop: - unless param_iter goto param_loop_end - cur_param = shift param_iter +.sub '!add_param' :method + .param string varname + .param pmc attr :slurpy :named + + attr['name'] = varname + + # If no multi_invocant value, set it to 1 (meaning it is one). + $I0 = exists attr['multi_invocant'] + if $I0 goto have_mi + attr['multi_invocant'] = 1 + have_mi: # Get constraints list, which may have class and role types as well as # subset types. If we have no unique role or class type, they all become @@ -69,9 +69,10 @@ .local pmc cur_list, cur_list_iter, constraints, type, test_item constraints = 'list'() type = null - cur_list = cur_param["constraints"] + cur_list = attr["type"] + if null cur_list goto cur_list_loop_end + cur_list = cur_list.'!eigenstates'() cur_list_iter = iter cur_list - cur_list_loop: unless cur_list_iter goto cur_list_loop_end test_item = shift cur_list_iter @@ -99,7 +100,7 @@ unless null type goto have_type type = get_hll_global 'Any' have_type: - cur_param["type"] = type + attr["nom_type"] = type $I0 = elements constraints if $I0 == 0 goto no_constraints constraints = 'all'(constraints) @@ -107,16 +108,43 @@ no_constraints: constraints = null set_constraints: - cur_param["constraints"] = constraints + attr["cons_type"] = constraints + + # Add to parameters list. + .local pmc params + params = self.'params'() + push params, attr +.end - goto param_loop - param_loop_end: - $P0 = self.'new'() - setattribute $P0, '@!params', parameters - .return ($P0) +=item !add_implicit_self + +Ensures that if there is no explicit invocant, we add one. + +=cut + +.sub '!add_implicit_self' :method + .local pmc params + params = self.'params'() + $I0 = elements params + if $I0 == 0 goto add_implicit_self + $P0 = params[0] + $I0 = $P0['invocant'] + if $I0 != 1 goto add_implicit_self + .return () + + add_implicit_self: + $P0 = new 'Hash' + $P0['name'] = 'self' + $P0['invocant'] = 1 + $P0['multi_invocant'] = 1 + # XXX Need to get type of class/role/grammar method is in. + $P1 = get_hll_global 'Object' + $P0['nom_type'] = $P1 + unshift params, $P0 .end + =item params Get the array of parameter describing hashes. @@ -125,6 +153,10 @@ .sub 'params' :method $P0 = getattribute self, "@!params" + unless null $P0 goto done + $P0 = 'list'() + setattribute self, "@!params", $P0 + done: .return ($P0) .end @@ -171,7 +203,7 @@ separator_done: # First any nominal type. - $P0 = cur_param["type"] + $P0 = cur_param["nom_type"] if null $P0 goto any_type $P0 = $P0.'perl'() concat s, $P0 @@ -200,7 +232,7 @@ optional_done: # Now any constraints. - $P0 = cur_param["constraints"] + $P0 = cur_param["cons_type"] if null $P0 goto constraints_done unless $P0 goto constraints_done concat s, " where " @@ -223,10 +255,86 @@ .return (s) .end +=item !BIND_SIGNATURE + +Analyze the signature of the caller, (re)binding the caller's +lexicals as needed and performing type checks. + +=cut + +.namespace [] +.sub '!SIGNATURE_BIND' + .local pmc callersub, callerlex, callersig + $P0 = getinterp + callersub = $P0['sub';1] + callerlex = $P0['lexpad';1] + getprop callersig, '$!signature', callersub + if null callersig goto end + .local pmc it + $P0 = callersig.'params'() + if null $P0 goto end + it = iter $P0 + param_loop: + unless it goto param_done + .local pmc param + param = shift it + .local string name, sigil + name = param['name'] + if name == 'self' goto param_loop + sigil = substr name, 0, 1 + .local pmc type, orig, var + type = param['type'] + orig = callerlex[name] + if sigil == '@' goto param_array + if sigil == '%' goto param_hash + var = '!CALLMETHOD'('Scalar', orig) + ## typecheck the argument + if null type goto param_val_done + .lex '$/', $P99 + $P0 = type.'ACCEPTS'(var) + unless $P0 goto err_param_type + goto param_val_done + param_array: + var = '!CALLMETHOD'('Array', orig) + goto param_val_done + param_hash: + var = '!CALLMETHOD'('Hash', orig) + param_val_done: + ## handle readonly/copy traits + $S0 = param['readtype'] + if $S0 == 'rw' goto param_readtype_done + if $S0 == 'copy' goto param_readtype_copy + ne_addr orig, var, param_readtype_var + var = new 'ObjectRef', var + param_readtype_var: + $P0 = get_hll_global ['Bool'], 'True' + setprop var, 'readonly', $P0 + goto param_readtype_done + param_readtype_copy: + var = clone var + param_readtype_done: + ## set any type properties + setprop var, 'type', type + ## place the updated variable back into lex + callerlex[name] = var + goto param_loop + param_done: + end: + .return () + err_param_type: + $S0 = callersub + if $S0 goto have_callersub_name + $S0 = '<anon>' + have_callersub_name: + 'die'('Parameter type check failed in call to ', $S0) +.end + + =back =cut + # Local Variables: # mode: pir # fill-column: 100 Modified: trunk/languages/perl6/src/parser/actions.pm ============================================================================== --- trunk/languages/perl6/src/parser/actions.pm (original) +++ trunk/languages/perl6/src/parser/actions.pm Fri Jan 9 07:50:41 2009 @@ -3,6 +3,17 @@ class Perl6::Grammar::Actions ; +# The %?CLASSMAP hash is used to identify those classes where we +# "lie" about the class name in order to work around RT #43419 / TT #71. +# When those are fixed and we can use the "true" Perl 6 classnames, +# this can be removed. (See also the C<package_def> method below.) +our %?CLASSMAP; +%?CLASSMAP<Object> := 'Perl6Object'; +%?CLASSMAP<Array> := 'Perl6Array'; +%?CLASSMAP<Hash> := 'Perl6Hash'; +%?CLASSMAP<Pair> := 'Perl6Pair'; +%?CLASSMAP<Complex> := 'Perl6Complex'; + method TOP($/) { my $past := $( $<statement_block> ); $past.blocktype('declaration'); @@ -57,26 +68,22 @@ method statement_block($/, $key) { - our $?BLOCK; our @?BLOCK; - our $?BLOCK_SIGNATURED; - ## when entering a block, use any $?BLOCK_SIGNATURED if it exists, + our $?BLOCK_OPEN; + ## when entering a block, use any $?BLOCK_OPEN if it exists, ## otherwise create an empty block with an empty first child to ## hold any parameters we might encounter inside the block. if $key eq 'open' { - if $?BLOCK_SIGNATURED { - $?BLOCK := $?BLOCK_SIGNATURED; - $?BLOCK_SIGNATURED := 0; - $?BLOCK.symbol('___HAVE_A_SIGNATURE', :scope('lexical')); + if $?BLOCK_OPEN { + @?BLOCK.unshift( $?BLOCK_OPEN ); + $?BLOCK_OPEN := 0; } else { - $?BLOCK := PAST::Block.new( PAST::Stmts.new(), :node($/)); + @?BLOCK.unshift( PAST::Block.new( PAST::Stmts.new(), :node($/))); } - @?BLOCK.unshift($?BLOCK); } if $key eq 'close' { my $past := @?BLOCK.shift(); - $?BLOCK := @?BLOCK[0]; $past.push($($<statementlist>)); make $past; } @@ -103,7 +110,7 @@ $past := $( $<statement_control> ); } elsif $key eq 'null' { - $past := PAST::Stmts.new(); # empty stmts seem eliminated by TGE + $past := PAST::Stmts.new(); } else { my $sml; @@ -233,7 +240,8 @@ } sub when_handler_helper($block) { - our $?BLOCK; + our @?BLOCK; + my $?BLOCK := @?BLOCK[0]; # XXX TODO: This isn't quite the right way to check this... unless $?BLOCK.handlers() { my @handlers; @@ -307,6 +315,12 @@ method pblock($/) { my $block := $( $<block> ); + ## Add a call to !SIGNATURE_BIND to fixup params and do typechecks. + if $block<signature> { + $block[0].push( + PAST::Op.new( :pasttype('call'), :name('!SIGNATURE_BIND') ) + ); + } make $block; } @@ -327,8 +341,8 @@ if $name ne 'v6' && $name ne 'lib' { ## Create a loadinit node so the use module is loaded ## when this module is loaded... - our $?BLOCK; - $?BLOCK.loadinit().push( + our @?BLOCK; + @?BLOCK[0].loadinit().push( PAST::Op.new( PAST::Val.new( :value($name) ), :name('use'), @@ -381,7 +395,8 @@ ), $past ); - our $?BLOCK; + our @?BLOCK; + my $?BLOCK := @?BLOCK[0]; my $eh := PAST::Control.new( $past ); my @handlers; if $?BLOCK.handlers() { @@ -408,7 +423,8 @@ ), $past ); - our $?BLOCK; + our @?BLOCK; + my $?BLOCK := @?BLOCK[0]; my $eh := PAST::Control.new( $past, :handle_types('CONTROL') @@ -512,139 +528,36 @@ } -method multi_declarator($/, $key) { - my $past := $( $/{$key} ); - - # If we just got a routine_def, make it a sub. - if $key eq 'routine_def' { - create_sub($/, $past); - } - - # If we have an only, proto or multi, we must have a name. - if $<sym> ne "" && $past.name() eq "" { - $/.panic("'" ~ $<sym> ~ "' can only be used on named routines"); - } - - # If it was multi or a proto, then emit a :multi. - if $<sym> eq 'multi' || $<sym> eq 'proto' { - # For now, if this is a multi we need to add code to transform the sub's - # multi container to a Perl6MultiSub. - $past.loadinit().push( - PAST::Op.new( - :pasttype('call'), - :name('!TOPERL6MULTISUB'), - PAST::Var.new( - :name('block'), - :scope('register') +method multi_declarator($/) { + my $sym := ~$<sym>; + my $past := $<declarator> ?? $( $<declarator> ) !! $( $<routine_def> ); + + if $past.isa(PAST::Block) { + # If we have a multi declarator, must have a named routine too. + if $sym ne "" && $past.name() eq "" { + $/.panic("'" ~ $<sym> ~ "' can only be used on named routines"); + } + + # If we're declaring a multi or a proto, flag the sub as :multi, + # and transform the sub's container to a Perl6MultiSub. + if $sym eq 'multi' || $sym eq 'proto' { + my $pirflags := ~$past.pirflags(); + $past.pirflags( $pirflags ~ ' :multi()' ); + $past.loadinit().push( + PAST::Op.new( :name('!TOPERL6MULTISUB'), :pasttype('call'), + PAST::Var.new( :name('block'), :scope('register') ) ) - ) - ); - - # Flag the sub as multi, but it will get the signature from the - # signature object, so don't worry about that here. - my $pirflags := $past.pirflags(); - unless $pirflags { $pirflags := '' } - $past.pirflags($pirflags ~ ' :multi()'); - } - - # Protos also need the proto property setting on them. - if $<sym> eq 'proto' { - $past.loadinit().push( - PAST::Op.new( - :inline(' setprop %0, "proto", %1'), - PAST::Var.new( - :name('block'), - :scope('register') - ), - 1 - ) - ); - } - - make $past; -} - - -method routine_declarator($/, $key) { - my $past; - if $key eq 'sub' { - $past := $($<routine_def>); - create_sub($/, $past); - } - elsif $key eq 'method' { - $past := $($<method_def>); - - # If it's got a name, only valid inside a class, role or grammar. - if $past.name() { - our @?CLASS; - our @?GRAMMAR; - our @?ROLE; - unless +@?CLASS || +@?GRAMMAR || +@?ROLE { - $/.panic("Named methods cannot appear outside of a class, grammar or role."); - } - } - - # Add declaration of leixcal self. - $past[0].unshift(PAST::Op.new( - :pasttype('bind'), - PAST::Var.new( - :name('self'), - :scope('lexical'), - :isdecl(1) - ), - PAST::Var.new( :name('self'), :scope('register') ) - )); - - # Set up the block details. - $past.blocktype('method'); - set_block_proto($past, 'Method'); - my $signature; - if $<method_def><multisig> { - $signature := $( $<method_def><multisig>[0]<signature> ); - set_block_sig($past, $signature); - } - else { - $signature := empty_signature(); - set_block_sig($past, $signature); + ); } - $past := add_method_to_class($past); - # If the signature doesn't include an explicity invocant, add one to - # the signature. - my $found_invocant := 0; - if $signature[1].isa(PAST::Stmts) && $signature[1][1].isa(PAST::Stmts) { - for @($signature[1][1]) { - if $_[0].value() eq 'invocant' { - $found_invocant := 1; - } - } - } - if !$found_invocant { - # Add anonymous parameter taking invocant. - my $descriptor := sig_descriptor_create(); - sig_descriptor_set($descriptor, 'name', PAST::Val.new( :value('$') )); - sig_descriptor_set($descriptor, 'invocant', 1); - sig_descriptor_set($descriptor, 'multi_invocant', 1); - sig_descriptor_set($descriptor, 'constraints', - PAST::Op.new( - :pasttype('call'), - :name('list') - )); - my $obj := $signature.shift(); - $signature.unshift($descriptor); - $signature.unshift($obj); + # Protos also need the proto property setting on them. + if $<sym> eq 'proto' { + $past.loadinit().push( + PAST::Op.new(:inline(' setprop block, "proto", %0'), 1) + ); } } - elsif $key eq 'submethod' { - $/.panic('submethod declarations not yet implemented'); - } - $past.node($/); - if (+@($past[1])) { - declare_implicit_routine_vars($past); - } - else { - $past[1].push( PAST::Op.new( :name('list') ) ); - } + make $past; } @@ -905,8 +818,8 @@ # Assemble all that we build into a statement list and then place it # into the init code. - our $?BLOCK; - my $loadinit := $?BLOCK.loadinit(); + our @?BLOCK; + my $loadinit := @?BLOCK[0].loadinit(); $loadinit.push($role_past); $loadinit.push($class_past); @@ -925,473 +838,274 @@ } +method routine_declarator($/, $key) { + my $past; + if $key eq 'sub' { + $past := $($<routine_def>); + } + elsif $key eq 'method' { + $past := $($<method_def>); + } + elsif $key eq 'submethod' { + $/.panic('submethod declarations not yet implemented'); + } + $past.node($/); + if (+@($past[1])) { + declare_implicit_routine_vars($past); + } + else { + $past[1].push( PAST::Op.new( :name('list') ) ); + } + ## Add a call to !SIGNATURE_BIND to fixup params and do typechecks. + $past[0].push( + PAST::Op.new( :pasttype('call'), :name('!SIGNATURE_BIND') ) + ); + make $past; +} + + method routine_def($/) { - my $past := $( $<block> ); + my $block := $( $<block> ); + $block.blocktype('declaration'); + if $<deflongname> { + my $name := ~$<deflongname>[0]; + $block.name( $name ); + our @?BLOCK; + @?BLOCK[0].symbol( $name, :scope('package') ); + } + $block.control('return_pir'); + block_signature($block); - if $<identifier> { - $past.name( ~$<identifier>[0] ); - our $?BLOCK; - $?BLOCK.symbol(~$<identifier>[0], :scope('package')); - } - $past.control('return_pir'); - - ## process traits - ## NOTE: much trait processing happens elsewhere at the moment - ## so don't deal with errors until refactoring is complete if $<trait> { - for $<trait> { - my $trait := $_; - if $trait<trait_auxiliary> { - my $aux := $trait<trait_auxiliary>; - my $sym := $aux<sym>; - - if $sym eq 'is' { - my $name := $aux<name>; - - ## is export(...) - if $name eq 'export' { - if ! $<identifier> { - $/.panic("use of 'is export(...)' trait" - ~ " on anonymous Routines is not allowed"); - } - - my $loadinit := $past.loadinit(); - our $?NS; - - ## create the export namespace(s) - my $export_ns_base := ~$?NS ~ '::EXPORT::'; - my @export_ns; - - ## every exported routine is bound to ::EXPORT::ALL - @export_ns.push( $export_ns_base ~ 'ALL' ); - - ## get the names of the tagsets, if any, from the ast - my $tagsets := $( $aux<postcircumfix>[0] ); - if $tagsets { - my $tagsets_past := $tagsets; - if $tagsets_past.isa(PAST::Op) - && $tagsets_past.pasttype() eq 'call' { - for @( $tagsets_past ) { - unless $_.isa(PAST::Val) - && $_.named() { - $/.panic('unknown argument "' ~ $_ - ~ '" in "is export()" trait' ); - } - - my $tag := $_<named><value>; - if $tag ne 'ALL' { - @export_ns.push( - $export_ns_base ~ $tag - ); - } - } - } - } - - ## bind the routine to the export namespace(s) - for @export_ns { - $loadinit.push( - PAST::Op.new( - :pasttype('bind'), - PAST::Var.new( - :name( $past.name() ), - :namespace( - Perl6::Compiler.parse_name( $_ ) - ), - :scope('package'), - :isdecl(1) - ), - PAST::Var.new( - :name('block'), :scope('register') - ) - ) - ); - } - } - else { - # Trait not handled in the compiler; emit call to apply it. - my @ns := Perl6::Compiler.parse_name( $name ); - $past.loadinit().push( - PAST::Op.new( - :pasttype('call'), - :name('trait_auxiliary:is'), - PAST::Var.new( - :name(@ns.pop()), - :namespace(@ns), - :scope('package') - ), - PAST::Var.new( - :name('block'), :scope('register') - ) - ) - ); - } - } - } + my $loadinit := $block.loadinit(); + my $blockreg := PAST::Var.new( :name('block'), :scope('register') ); + for @($<trait>) { + # Trait nodes come in as PAST::Op( :name('list') ). + # We just modify them to call !sub_trait and add + # 'block' as the first argument. + my $trait := $( $_ ); + $trait.name('!sub_trait'); + $trait.unshift($blockreg); + $loadinit.push($trait); } } - - make $past; + make $block; } + method method_def($/) { - my $past := $( $<block> ); - my $identifier := $<identifier>; - if $identifier { - $past.name( ~$identifier[0] ); + my $block := $( $<block> ); + $block.blocktype('method'); + + if $<longname> { + $block.name( ~$<longname> ); } - $past.control('return_pir'); - # Emit code to apply any traits. + # Add lexical 'self'. + $block[0].unshift( + PAST::Var.new( :name('self'), :scope('lexical'), :isdecl(1), + :viviself( PAST::Var.new( :name('self'), :scope('register' ) ) ) + ) + ); + + $block.control('return_pir'); + block_signature($block); + # Ensure there's an invocant in the signature. + $block.loadinit().push(PAST::Op.new( + :pasttype('callmethod'), + :name('!add_implicit_self'), + PAST::Var.new( :name('signature'), :scope('register') ) + )); + if $<trait> { - for $<trait> { - my $trait := $_; - if $trait<trait_auxiliary> { - my $aux := $trait<trait_auxiliary>; - my $sym := $aux<sym>; - - if $sym eq 'is' { - my $name := $aux<name>; - - # Emit call to trait_auxiliary:is apply trait. - my @ns := Perl6::Compiler.parse_name( $name ); - $past.loadinit().push( - PAST::Op.new( - :pasttype('call'), - :name('trait_auxiliary:is'), - PAST::Var.new( - :name(@ns.pop()), - :namespace(@ns), - :scope('package') - ), - PAST::Var.new( - :name('block'), :scope('register') - ) - ) - ); - } - } + my $loadinit := $block.loadinit(); + my $blockreg := PAST::Var.new( :name('block'), :scope('register') ); + for @($<trait>) { + # Trait nodes come in as PAST::Op( :name('list') ). + # We just modify them to call !sub_trait and add + # 'block' as the first argument. + my $trait := $( $_ ); + $trait.name('!sub_trait'); + $trait.unshift($blockreg); + $loadinit.push($trait); } } + make $block; +} + + +method trait($/) { + my $past; + if $<trait_auxiliary> { + $past := $( $<trait_auxiliary> ); + } + elsif $<trait_verb> { + $past := $( $<trait_verb> ); + } make $past; } -method signature($/) { - # In here, we build a signature object and optionally some other things - # if $?SIG_BLOCK_NOT_NEEDED is not set to a true value. - # * $?BLOCK_SIGNATURED ends up containing the PAST tree for a block that - # takes and binds the parameters. This is used for generating subs, - # methods and so forth. - - # Initialize PAST for the signatured block, if we're going to have it. - our $?SIG_BLOCK_NOT_NEEDED; - my $params; - my $type_check; - my $block_past; - unless $?SIG_BLOCK_NOT_NEEDED { - $params := PAST::Stmts.new( :node($/) ); - $block_past := PAST::Block.new( $params, :blocktype('declaration') ); - $type_check := PAST::Stmts.new( :node($/) ); +method trait_auxiliary($/) { + my $sym := ~$<sym>; + my $trait := PAST::Op.new( :name('infix:,'), 'trait_auxiliary:' ~ $sym); + if $sym eq 'is' { + $trait.push( ~$<name> ); + if $<postcircumfix> { + my $arg := $( $<postcircumfix>[0] ); + $arg.name('!capture'); + $trait.push($arg); + } + } + elsif $sym eq 'does' { + $trait.push( ~$<name> ); } + make $trait; +} - # Initialize PAST for constructing the signature object. - my $sig_past := PAST::Op.new( - :pasttype('callmethod'), - :name('!create'), - PAST::Var.new( - :name('Signature'), - :scope('package'), - :namespace(list()) - ) - ); - # Go through the parameters. - my $is_multi_invocant := 1; - for $/[0] { - my $parameter := $($_<parameter>); - my $separator := $_[0]; - my $is_invocant := 0; - - # If it has & sigil, strip it off, but record it was a sub. - my $is_callable := 0; - if substr($parameter.name(), 0, 1) eq '&' { - $parameter.name(substr($parameter.name(), 1)); - $is_callable := 1; - } - - # Add parameter declaration to the block, if we're producing one. - unless $?SIG_BLOCK_NOT_NEEDED { - # Register symbol and put parameter PAST into the node. - $block_past.symbol($parameter.name(), :scope('lexical')); - $params.push($parameter); - - # If it is invocant, modify it to be just a lexical and bind self to it. - if substr($separator, 0, 1) eq ':' { - $is_invocant := 1; - - # Make sure it's first parameter. - if +@($params) != 1 { - $/.panic("There can only be one invocant and it must be the first parameter"); - } +method trait_verb($/) { + my $sym := ~$<sym>; + my $value; + if $sym eq 'handles' { $value := $( $<EXPR> ); } + else { $value := $( $<typename> ); } + make PAST::Op.new( :name('infix:,'), 'trait_verb:' ~ $sym, $value ); +} - # Modify. - $parameter.scope('lexical'); - $parameter.isdecl(1); - - # Bind self to it. - $params.push(PAST::Op.new( - :pasttype('bind'), - PAST::Var.new( - :name($parameter.name()), - :scope('lexical') - ), - PAST::Var.new( :name('self'), :scope('register') ) - )); - } - } - # Now start making a descriptor for the signature. - my $descriptor := sig_descriptor_create(); - $sig_past.push($descriptor); - sig_descriptor_set($descriptor, 'name', - PAST::Val.new( :value(~$parameter.name()) )); - if $parameter.named() { - sig_descriptor_set($descriptor, 'named', - PAST::Val.new( :value(~$parameter.named()) )); - } - if $parameter.viviself() { - sig_descriptor_set($descriptor, 'optional', 1); - } - if $parameter.slurpy() { - sig_descriptor_set($descriptor, 'slurpy', 1); - } - if $is_invocant { - sig_descriptor_set($descriptor, 'invocant', 1); - } - if $is_multi_invocant { - sig_descriptor_set($descriptor, 'multi_invocant', 1); - } - - # See if we have any traits. For now, we just handle ro, rw and copy. - my $cont_trait := 'readonly'; - my $cont_traits := 0; - for $_<parameter><trait> { - if $_<trait_auxiliary> { - # Get name of the trait and see if it's one of the special - # traits we handle in the compiler. - my $name := ~$_<trait_auxiliary><name>; - if $name eq 'readonly' { - $cont_traits := $cont_traits + 1; - } - elsif $name eq 'rw' { - $cont_trait := 'rw'; - $cont_traits := $cont_traits + 1; - } - elsif $name eq 'copy' { - $cont_trait := 'copy'; - $cont_traits := $cont_traits + 1; - } - else { - $/.panic("Cannot apply trait " ~ $name ~ " to parameters yet."); - } - } - else { - $/.panic("Cannot apply traits to parameters yet."); +method signature($/, $key) { + our @?BLOCK; + if $key eq 'open' { + my $sigpast := PAST::Op.new( :pasttype('stmts'), :node($/) ); + my $block := PAST::Block.new( $sigpast, :blocktype('declaration') ); + $block<explicit_signature> := 1; + @?BLOCK.unshift($block); + } + else { + my $block := @?BLOCK.shift(); + my $sigpast := $block[0]; + my $loadinit := $block.loadinit(); + my $sigobj := PAST::Var.new( :name('signature'), :scope('register') ); + + block_signature($block); + + ## loop through parameters of signature + my $arity := $<parameter> ?? +@($<parameter>) !! 0; + $block.arity($arity); + my $i := 0; + my $multi_inv_suppress := 0; + while $i < $arity { + my $var := $( $<parameter>[$i] ); + my $name := $var.name(); + + if $var<type_binding> { + $sigpast.push( $var<type_binding> ); + } + + ## add parameter to the signature object + my $sigparam := PAST::Op.new( :pasttype('callmethod'), + :name('!add_param'), $sigobj, $name ); + + ## add any typechecks + my $type := $var<type>; + if +@($type) > 0 { + $type.named('type'); + $sigparam.push($type); + } + + ## add traits (we're not using this yet.) + my $trait := $var<trait>; + if $trait { + $trait.named('trait'); + $sigparam.push($trait); + } + + my $readtype := trait_readtype( $var<traitlist> ) || 'readonly'; + if $readtype eq 'CONFLICT' { + $<parameter>[$i].panic( + "Can use only one of readonly, rw, and copy on " + ~ $name ~ " parameter" + ); } - } - - # If we had is copy is rw or some other impossible combination, die. - if $cont_traits > 1 { - $/.panic("Can only use one of readonly, rw and copy on a parameter."); - } - - # Add any type check that is needed. The scheme for this: $type_check - # is a statement block. We create a block for each parameter, which - # will be empty if there are no constraints for that parameter. This - # is so we can later generate a multi-sig from it. - my $cur_param_types := PAST::Stmts.new(); - if $_<parameter><type_constraint> { - for $_<parameter><type_constraint> { - # Just a type name? - if $_<typename><name><identifier> { - # Get type; we may have to fix up the scope if it's - # been captured within the signature. - my $type := $( $_<typename> ); - my $local_sym := $block_past.symbol($type.name()); - if $local_sym { - $type.scope($local_sym<scope>); - } + $sigparam.push(PAST::Val.new(:value($readtype),:named('readtype'))); - # Emit check. - my $type_obj := PAST::Op.new( - :pasttype('call'), - :name('!TYPECHECKPARAM'), - $type, - PAST::Var.new( - :name($parameter.name()), - :scope('lexical') - ) - ); - $cur_param_types.push($type_obj); - } - # is it a ::Foo type binding? - elsif $_<typename> { - my $tvname := ~$_<typename><name><morename>[0]<identifier>; - $params.push(PAST::Op.new( - :pasttype('bind'), - PAST::Var.new( :name($tvname), :scope('lexical'), :isdecl(1)), - PAST::Op.new( - :pasttype('callmethod'), - :name('WHAT'), - PAST::Var.new( - :name($parameter.name()), - :scope('lexical') - ) - ) - )); - $block_past.symbol($tvname, :scope('lexical')); + ## if it's an invocant, flag it as such and make the var be a + ## lexical that has self register bound to it + if $<param_sep>[$i][0] eq ':' { + if $i == 0 { + $sigparam.push(PAST::Val.new( :value(1), :named('invocant'))); + $var.scope('lexical'); + $var.isdecl(1); + $var.viviself( + PAST::Var.new( :name('self'), :scope('register') ) + ) } else { - my $type_obj := make_anon_subset($( $_<EXPR> ), $parameter); - $cur_param_types.push($type_obj); + $/.panic("Can only use : separator to denote invocant after first parameter."); } } - } - # Add any post-constraints too. - for $_<parameter><post_constraint> { - my $type_obj := make_anon_subset($( $_<EXPR> ), $parameter); - $cur_param_types.push($type_obj); - } + ## handle end of multi-invocant sequence + if ($multi_inv_suppress) { + $sigparam.push(PAST::Val.new(:value(0),:named('multi_invocant'))); + } + if $<param_sep>[$i][0] eq ';;' { $multi_inv_suppress := 1; } - # Also any constraint from the sigil. - if $is_callable { - $cur_param_types.push(PAST::Op.new( - :pasttype('call'), - :name('!TYPECHECKPARAM'), - PAST::Var.new( :name('Callable'), :scope('package') ), - PAST::Var.new( - :name($parameter.name()), - :scope('lexical') - ) - )); - } + ## add var node to block + $sigpast.push( $var ); - # For blocks, we just collect the check into the list of all checks. - unless $?SIG_BLOCK_NOT_NEEDED { - $type_check.push($cur_param_types); + $loadinit.push($sigparam); + $i++; } - # For signatures, we build a list from the constraints and store it. - my $sig_type_cons := PAST::Stmts.new( - PAST::Op.new( - :inline(' $P2 = new "List"') - ), - PAST::Stmts.new(), - PAST::Op.new( - :inline(' %r = $P2') - ) - ); - for @($cur_param_types) { - # Just want the type, not the call to the checker. - $sig_type_cons[1].push(PAST::Op.new( - :inline(' push $P2, %0'), - $_[0] - )); - } - sig_descriptor_set($descriptor, 'constraints', $sig_type_cons); + ## restore block stack and return signature ast + our $?BLOCK_OPEN; + $?BLOCK_OPEN := $block; + make $sigpast; + } +} - # If we're making a block, emit code for trait types. - unless $?SIG_BLOCK_NOT_NEEDED { - if $cont_trait eq 'rw' { - # We just leave it as it is. - } - elsif $cont_trait eq 'readonly' { - # Create a new container with ro set and bind the parameter to it. - $params.push(PAST::Op.new( - :pasttype('bind'), - PAST::Var.new( - :name($parameter.name()), - :scope('lexical') - ), - PAST::Op.new( - :inline( - ' %r = new "Perl6Scalar", %0', - ' $P0 = get_hll_global ["Bool"], "True"', - ' setprop %r, "readonly", $P0' - ), - PAST::Var.new( - :name($parameter.name()), - :scope('lexical') - ) - ) - )); - } - elsif $cont_trait eq 'copy' { - # Create a new container and copy the value into it.. - $params.push(PAST::Op.new( - :pasttype('bind'), - PAST::Var.new( - :name($parameter.name()), - :scope('lexical') - ), - PAST::Op.new( - :inline( - ' %r = new "Perl6Scalar"', - ' "!COPYPARAM"(%r, %0)' - ), - PAST::Var.new( - :name($parameter.name()), - :scope('lexical') - ) - ) - )); - } - } - # If the separator is a ;; then parameters beyond this are not multi - # invocants. - if substr($separator, 0, 2) eq ';;' { - $is_multi_invocant := 0; - } +method type_constraint($/) { + my $past; + if $<fulltypename> { + $past := $( $<fulltypename> ); } - - # Finish setting up the signatured block, if we're making one. - unless $?SIG_BLOCK_NOT_NEEDED { - $block_past.arity( +$/[0] ); - our $?BLOCK_SIGNATURED := $block_past; - $params.push($type_check); + else { + $past := make_anon_subtype($( $<EXPR> )); } + make $past; +} + - # Hand back the PAST to construct a signature object. - make $sig_past; +method post_constraint($/) { + my $past := make_anon_subtype($( $<EXPR> )); + make $past; } method parameter($/) { - my $past := $( $<param_var> ); + my $var := $( $<param_var> ); my $sigil := $<param_var><sigil>; my $quant := $<quant>; + ## handle slurpy and optional flags if $quant eq '*' { - $past.slurpy( $sigil eq '@' || $sigil eq '%' ); - $past.named( $sigil eq '%' ); + $var.slurpy( $sigil eq '@' || $sigil eq '%' ); + $var.named( $sigil eq '%' ); } - else { - if $<named> eq ':' { # named - $past.named(~$<param_var><identifier>); - if $quant ne '!' { # required (optional is default) - $past.viviself('Failure'); - } - } - else { # positional - if $quant eq '?' { # optional (required is default) - $past.viviself('Failure'); - } + elsif $<named> eq ':' { # named + $var.named(~$<param_var><identifier>); + if $quant ne '!' { # required (optional is default) + $var.viviself('Nil'); } } + elsif $quant eq '?' { # positional optional + $var.viviself('Nil'); + } + + ## handle any default value if $<default_value> { if $quant eq '!' { $/.panic("Can't put a default on a required parameter"); @@ -1399,27 +1113,87 @@ if $quant eq '*' { $/.panic("Can't put a default on a slurpy parameter"); } - $past.viviself( $( $<default_value>[0]<EXPR> ) ); + $var.viviself( $( $<default_value>[0]<EXPR> ) ); } - make $past; + + ## keep track of any type constraints + my $typelist := PAST::Op.new( :name('all'), :pasttype('call') ); + $var<type> := $typelist; + if $<type_constraint> { + for @($<type_constraint>) { + my $type_past := $( $_ ); + if $type_past.isa(PAST::Var) && $type_past.scope() eq 'lexical' { + our @?BLOCK; + # Lexical type constraint. + if $type_past.isdecl() { + # If it's a declaration, we need to initialize it. + $type_past.viviself( + PAST::Op.new( :pasttype('callmethod'), :name('WHAT'), + PAST::Var.new( :name($var.name()) ) + ) + ); + $var<type_binding> := $type_past; + @?BLOCK[0].symbol( $type_past.name(), :scope('lexical') ); + } + else { + # we need to thunk it + my $thunk := PAST::Op.new( + :name('ACCEPTS'), :pasttype('callmethod'), + $type_past, + PAST::Var.new( :name('$_'), :scope('parameter') ) + ); + $thunk := PAST::Block.new($thunk, :blocktype('declaration')); + @?BLOCK[0].push($thunk); + $type_past := PAST::Val.new( :value($thunk) ); + $typelist.push( $type_past ); + } + } + else { + $typelist.push( $type_past ); + } + } + } + if $<post_constraint> { + for @($<post_constraint>) { + $typelist.push($( $_ )); + } + } + + if $<trait> { + my $traitlist := PAST::Op.new( :name('infix:,'), :pasttype('call') ); + $var<traitlist> := $traitlist; + for @($<trait>) { $traitlist.push( $( $_ ) ); } + } + + make $var; } method param_var($/) { - my $twigil := $<twigil>; - if $twigil && $twigil[0] ne '.' && $twigil[0] ne '!' { + my $sigil := ~$<sigil>; + my $twigil := ~$<twigil>[0]; + if $sigil eq '&' { $sigil := ''; } + my $name := $sigil ~ $twigil ~ ~$<identifier>; + if $twigil eq '.' { + $name := $sigil ~ '!' ~ $<identifier>; + } + elsif $twigil && $twigil ne '!' { $/.panic('Invalid twigil used in signature parameter.'); } - make PAST::Var.new( - :name(~$/), + my $var := PAST::Var.new( + :name($name), :scope('parameter'), :node($/) ); -} - + $var<twigil> := $twigil; + $var<itype> := container_itype( $<sigil> ); + # Declare symbol as lexical in current (signature) block. + # This is needed in case any post_constraints try to reference + # this new param_var. + our @?BLOCK; + @?BLOCK[0].symbol( $name, :scope('lexical') ); -method special_variable($/) { - make PAST::Var.new( :node($/), :name(~$/), :scope('lexical') ); + make $var; } @@ -1613,998 +1387,433 @@ } -sub apply_package_traits($package, $traits) { - for $traits { - my $aux := $_<trait_auxiliary>; - # Apply any "is" traits through MMD. - if $aux<sym> eq 'is' { - # Check it's not a compiler-handled one. - if $aux<name> ne 'also' { - # Emit the call. - my @identifier := Perl6::Compiler.parse_name(~$aux<name>); - my $name := @identifier.pop(); - my $superclass := PAST::Var.new( - :name($name), - :scope('package'), - :viviself('Undef') - ); - if +@identifier != 0 { - $superclass.namespace(@identifier); - } - $package.push( - PAST::Op.new( - :pasttype('call'), - :name('trait_auxiliary:is'), - $superclass, - PAST::Var.new( - :name('def'), - :scope('register') - ) - ) - ); - } - } - elsif $aux<sym> eq 'does' { - # Role. - my @identifier := Perl6::Compiler.parse_name(~$aux<name>); - my $name := @identifier.pop(); - my $role_name := PAST::Var.new( - :name($name), - :namespace(@identifier), - :scope('package'), - ); - $package.push( - PAST::Op.new( - :pasttype('call'), - :name('!keyword_does'), - PAST::Var.new( - :name('def'), - :scope('register') - ), - $role_name - ) - ); - } - else { - $traits.panic("Currently only is and does traits are supported on packages."); - } +method package_declarator($/, $key) { + our @?PKGDECL; + my $sym := ~$<sym>; + my $past; + if $key eq 'open' { + our $?BLOCK_OPEN; + $?BLOCK_OPEN := PAST::Block.new( PAST::Stmts.new(), :node($/) ); + $?BLOCK_OPEN<pkgdecl> := $sym; + @?PKGDECL.unshift( $sym ); + } + else { + make $( $<package_def> ); + @?PKGDECL.shift(); } } -method package_declarator($/, $key) { - our $?CLASS; - our @?CLASS; - our $?GRAMMAR; - our @?GRAMMAR; - our $?MODULE; - our @?MODULE; - our $?PACKAGE; - our @?PACKAGE; - our $?ROLE; - our @?ROLE; - - my $sym := $<sym>; - - if $key eq 'open' { - # Start of a new package. We create an empty PAST::Stmts node for the - # package definition to be stored in and put it onto the current stack - # of packages and the stack of its package type. - my $decl_past := PAST::Stmts.new(); - - if $sym eq 'package' { - @?PACKAGE.unshift($decl_past); - } - ## module isa package - elsif $sym eq 'module' { - @?MODULE.unshift($decl_past); - @?PACKAGE.unshift($decl_past); - } - ## role isa module isa package - elsif $sym eq 'role' { - @?ROLE.unshift($decl_past); - @?MODULE.unshift($decl_past); - @?PACKAGE.unshift($decl_past); - } - ## class isa module isa package - elsif $sym eq 'class' { - @?CLASS.unshift($decl_past); - @?MODULE.unshift($decl_past); - @?PACKAGE.unshift($decl_past); - } - ## grammar isa class isa module isa package - elsif $sym eq 'grammar' { - @?GRAMMAR.unshift($decl_past); - @?CLASS.unshift($decl_past); - @?MODULE.unshift($decl_past); - @?PACKAGE.unshift($decl_past); - } - } - else { - # End of declaration. Our PAST will be that made by the package_def or - # role_def. - my $past := $( $/{$key} ); - - # Set $?PACKAGE at the start of it. - $past.unshift(set_package_magical()); - - # Restore outer values in @?<magical> arrays - if $sym eq 'package' { - @?PACKAGE.shift(); - } - ## module isa package - elsif $sym eq 'module' { - @?MODULE.shift(); - @?PACKAGE.shift(); - } - ## role isa module isa package - elsif $sym eq 'role' { - @?ROLE.shift(); - @?MODULE.shift(); - @?PACKAGE.shift(); - } - ## class isa module isa package - elsif $sym eq 'class' { - @?CLASS.shift(); - @?MODULE.shift(); - @?PACKAGE.shift(); - } - ## grammar isa class isa module isa package - elsif $sym eq 'grammar' { - @?GRAMMAR.shift(); - @?CLASS.shift(); - @?MODULE.shift(); - @?PACKAGE.shift(); - } - make $past; - } - - # make sure @?<magical>[0] is always the same as $?<magical> - $?CLASS := @?CLASS[0]; - $?GRAMMAR := @?GRAMMAR[0]; - $?MODULE := @?MODULE[0]; - $?PACKAGE := @?PACKAGE[0]; - $?ROLE := @?ROLE[0]; -} - - method package_def($/, $key) { - our $?CLASS; - our $?GRAMMAR; - our $?MODULE; - our $?NS; - our $?PACKAGE; - my $name := $<name>; - - if $key eq 'open' { - # Start of package definition. Handle class and grammar specially. - if $?PACKAGE =:= $?GRAMMAR { - # Anonymous grammars not supported. - unless $name { - $/.panic('Anonymous grammars not supported'); - } + our @?PKGDECL; + my $?PKGDECL := @?PKGDECL[0]; - # Start of grammar definition. Create grammar class object. - $?GRAMMAR.push( - PAST::Op.new( - :pasttype('bind'), - PAST::Var.new( - :name('def'), - :scope('register'), - :isdecl(1) - ), - PAST::Op.new( - :pasttype('call'), - :name('!keyword_grammar'), - PAST::Val.new( :value(~$name[0]) ) - ) - ) - ); - } - elsif $?PACKAGE =:= $?CLASS { - my $class_def; + if $key eq 'panic' { + $/.panic("Unable to parse " ~ $?PKGDECL ~ " definition"); + } - if !have_trait('also', 'is', $<trait>) { - # Start of class definition; make PAST to create class object if - # we're creating a new class. - $class_def := PAST::Op.new( - :pasttype('bind'), - PAST::Var.new( - :name('def'), - :scope('register'), - :isdecl(1) - ), - PAST::Op.new( - :pasttype('call'), - :name('!keyword_class') - ) - ); + my $block := $( $/{$key} ); + $block.blocktype('declaration'); + $block.lexical(0); - # Add a name, if we have one. - if $name { - $class_def[1].push( PAST::Val.new( :value(~$name[0]) ) ); - } - } - else { - # We're adding to an existing class. Look up class by name and put - # it in $def. - unless $<name> { - $/.panic("Can only use is also trait on a named class."); - } - my @namespace := Perl6::Compiler.parse_name($<name>[0]); - my $short_name := @namespace.pop(); - $class_def := PAST::Op.new( - :node($/), - :pasttype('bind'), - PAST::Var.new( - :name('def'), - :scope('register'), - :isdecl(1) - ), - PAST::Op.new( - :pasttype('callmethod'), - :name('get_parrotclass'), - PAST::Var.new( - :scope('package'), - :name('$!P6META'), - :namespace('Perl6Object') - ), - PAST::Var.new( - :name($short_name), - :namespace(@namespace), - :scope('package') - ) - ) - ); - } + my $modulename := $<module_name> + ?? ~$<module_name>[0] !! + $block.unique('!ANON'); - $?CLASS.push($class_def); - } - else { - # Anonymous modules not supported. - unless $name { - $/.panic('Anonymous modules not supported'); - } - } + # See note at top of file for %?CLASSMAP. + if %?CLASSMAP{$modulename} { $modulename := %?CLASSMAP{$modulename}; } - # Also store the current namespace, if we're not anonymous. - if $name { - $?NS := ~$name[0]; - } + if ($modulename) { + $block.namespace( Perl6::Compiler.parse_name($modulename) ); } - else { - # XXX For now, to work around the :load :init not being allowed to be - # an outer bug, we will enclose the actual package block inside an - # immediate block of its own. - my $inner_block := $( $<package_block> ); - $inner_block.blocktype('immediate'); - my $past := PAST::Block.new( - $inner_block - ); - - # Declare the namespace and that the result block holds things that we - # do "on load". - if $name { - $past.namespace(Perl6::Compiler.parse_name($<name>[0])); - } - $past.blocktype('declaration'); - $past.pirflags(':init :load'); - - if $?PACKAGE =:= $?GRAMMAR { - # Apply traits. - apply_package_traits($?GRAMMAR, $<trait>); - # Make proto-object for grammar. - $?GRAMMAR.push( - PAST::Op.new( - :pasttype('call'), - :name('!PROTOINIT'), - PAST::Op.new( - :pasttype('callmethod'), - :name('register'), - PAST::Var.new( - :scope('package'), - :name('$!P6META'), - :namespace('Perl6Object') - ), - PAST::Var.new( - :scope('register'), - :name('def') - ), - PAST::Val.new( - :value('Grammar'), - :named( PAST::Val.new( :value('parent') ) ) - ) - ) - ) - ); + if $key eq 'block' { + # A normal block acts like a BEGIN and is executed ASAP. + $block.pirflags(':load :init'); + } + elsif $key eq 'statement_block' && !$<module_name> { + $/.panic("Compilation unit cannot be anonymous"); + } - # Attatch grammar declaration to the init code. - our $?BLOCK; - $?BLOCK.loadinit().push( $?GRAMMAR ); - - # Clear namespace. - $?NS := ''; - } - elsif $?PACKAGE =:= $?CLASS { - # Apply traits. - apply_package_traits($?CLASS, $<trait>); - - # Check if we have the is also trait - don't re-create - # proto-object if so. - if !have_trait('also', 'is', $<trait>) { - # It's a new class definition. Make proto-object. - $?CLASS.push( - PAST::Op.new( - :pasttype('call'), - :name('!PROTOINIT'), - PAST::Op.new( - :pasttype('callmethod'), - :name('register'), - PAST::Var.new( - :scope('package'), - :name('$!P6META'), - :namespace('Perl6Object') - ), - PAST::Var.new( - :scope('register'), - :name('def') - ), - PAST::Val.new( - :value('Any'), - :named( PAST::Val.new( :value('parent') ) ) - ) - ) - ) - ); + # Create a node at the beginning of the block's initializer + # for package initializations + my $init := PAST::Stmts.new(); + $block[0].unshift( $init ); - # If this is an anonymous class, the block doesn't want to be a - # :init :load, and it's going to contain the class definition, so - # we need to declare the lexical $def. - unless $name { - $past.pirflags(''); - $past.blocktype('immediate'); - $past[0].push(PAST::Var.new( - :name('def'), - :scope('register'), - :isdecl(1) - )); - } - } + # Normally we would create the metaclass object first, + # but if there's an "is also" trait we want to do a class + # lookup instead. So we do the trait processing first + # (scanning for 'is also' as we go), and then decide how + # to obtain the metaclass. - # Attatch any class initialization code to the init code; - # note that we skip blocks, which are method accessors that - # we want to put under this block so they get the correct - # namespace. If it's an anonymous class, everything goes into - # this block. - for @( $?CLASS ) { - if $_.isa(PAST::Block) || !$name { - $past[0].push( $_ ); - } - else { - our $?BLOCK; - $?BLOCK.loadinit().push( $_ ); - } + # Add any traits coming from the package declarator. + # Traits in the body have already been added to the block. + our $?METACLASS; + if $<trait> { + for @($<trait>) { + # Trait nodes come in as PAST::Op( :name('list') ). + # We just modify them to call !meta_trait and add + # the metaclass as the first argument. + my $trait := $( $_ ); + if $trait[1] eq 'also' { $block<isalso> := 1; } + else { + $trait.name('!meta_trait'); + $trait.unshift($?METACLASS); + $init.push($trait); } } - - make $past; } -} - - -method role_def($/, $key) { - our $?ROLE; - our $?NS; - my $name := ~$<name>; - if $key eq 'open' { - # Start of role definition. Push on code to create a role object. - $?ROLE.push( - PAST::Op.new( - :pasttype('bind'), - PAST::Var.new( - :name('def'), - :scope('register'), - :isdecl(1) - ), - PAST::Op.new( - :pasttype('call'), - :name('!keyword_role'), - PAST::Val.new( :value($name) ) - ) + # At the beginning, create the "class/module/grammar/role/etc" + # metaclass handle on which we do the other operations. + $init.unshift( + PAST::Op.new( :pasttype('bind'), + PAST::Var.new(:name('metaclass'), :scope('register'), :isdecl(1) ), + PAST::Op.new(:name('!meta_create'), + $?PKGDECL, $modulename, +$block<isalso> ) - ); + ) + ); - # Also store the current namespace. - $?NS := $name; + # ...and at the end of the block's initializer (after any other + # items added by the block), we finalize the composition. This + # returns a proto, which we need to keep around and also return at + # the end of initialization for anonymous classes. + if $<module_name> eq "" && ($?PKGDECL eq 'class' || $?PKGDECL eq 'role' + || $?PKGDECL eq 'grammar') { + $block[0].push(PAST::Op.new( + :pasttype('bind'), + PAST::Var.new(:name('proto_store'), :scope('register'), :isdecl(1)), + PAST::Op.new( :name('!meta_compose'), $?METACLASS) + )); + $block.push(PAST::Var.new(:name('proto_store'), :scope('register'))); + $block.blocktype('immediate'); + $block.pirflags(''); } else { - # Declare the namespace and that the result block holds things that we - # do "on load". - my $past := $( $<package_block> ); - $past.namespace( PAST::Compiler.parse_name($name) ); - $past.blocktype('declaration'); - $past.pirflags(':init :load'); - - # Apply traits. - apply_package_traits($?ROLE, $<trait>); - - # Attatch role declaration to the init code, skipping blocks since - # those are accessors. - for @( $?ROLE ) { - if $_.isa(PAST::Block) { - $past.push( $_ ); - } - else { - our $?BLOCK; - $?BLOCK.loadinit().push( $_ ); - } - } - - # Clear namespace. - $?NS := ''; - - make $past; + $block[0].push( PAST::Op.new( :name('!meta_compose'), $?METACLASS) ); } -} - -method package_block($/, $key) { - my $past := $( $/{$key} ); - make $past; + make $block; } -method variable_declarator($/) { - my $past := $( $<variable> ); +method scope_declarator($/) { + our @?BLOCK; + my $block := @?BLOCK[0]; + my $sym := ~$<sym>; + my $past := $( $<scoped> ); + my $scope := 'lexical'; + if $sym eq 'our' { $scope := 'package'; } + elsif $sym eq 'has' { $scope := 'attribute'; } + + # Private methods get a leading !. + if $scope eq 'lexical' && $past.isa(PAST::Block) + && $past.blocktype() eq 'method' { + $past.name( '!' ~ $past.name()); + } + + # If we have a single variable, we temporarily pack it into + # a PAST::Op node (like a signature of one variable) and + # let the PAST::Op code below handle it. It then gets + # unpacked at the end. + if $past.isa(PAST::Var) { + $past := PAST::Op.new( $past ); + } + + if $past.isa(PAST::Op) { + my $i := 0; + for @($past) { + if $_.isa(PAST::Var) && !$_<redecl> { + my $var := $_; + + # This is a variable declaration, so we set the scope in + # the block's symbol table as well as the variable itself. + $block.symbol( $var.name(), :scope($scope) ); + $var.scope($scope); + $var.isdecl(1); + if $scope eq 'package' { $var.lvalue(1); } + my $init_value := $var.viviself(); + my $type; + if +@($var<type>) { $type := $var<type>[0]; } # FIXME + + # If the var has a '.' twigil, we need to create an + # accessor method for it in the block (class/grammar/role) + if $var<twigil> eq '.' { + my $method := PAST::Block.new( :blocktype('method') ); + $method.name( substr($var.name(), 2) ); + my $value := PAST::Var.new( :name($var.name()) ); + my $readtype := trait_readtype( $var<traitlist> ) || 'readonly'; + if $readtype eq 'CONFLICT' { + $<scoped>.panic( + "Can use only one of readonly, rw, and copy on " + ~ $var.name() ~ " parameter" + ); + } + elsif $readtype ne 'rw' { + $value := PAST::Op.new( :pirop('new PsP'), + 'ObjectRef', $value); + $value := PAST::Op.new( :pirop('setprop'), + $value, 'readonly', 1); + } + $method.push( $value ); + $block[0].push($method); + } - # If it's an attribute declaration, we handle traits elsewhere. - my $twigil := $<variable><twigil>[0]; - if $<trait> && $twigil ne '.' && $twigil ne '!' { - for $<trait> { - my $trait := $_; - if $trait<trait_auxiliary> { - my $aux := $trait<trait_auxiliary>; - my $sym := $aux<sym>; - if $sym eq 'is' { - if $aux<postcircumfix> { - $/.panic("'" ~ ~$trait ~ "' not implemented"); + if $scope eq 'attribute' { + # If no twigil, we need a twigiled entry of + # the attribute in the block's symbol table. + if $var<twigil> eq '' { + my $sigil := substr($var.name(), 0, 1); + my $name := substr($var.name(), 1); + $block.symbol( $sigil ~ '!' ~ $name, :scope($scope)); + } + my $pkgdecl := $block<pkgdecl>; + unless $pkgdecl eq 'class' || $pkgdecl eq 'role' + || $pkgdecl eq 'grammar' { + $/.panic("Attempt to define attribute " ~ $var.name() ~ + " outside of class, role, or grammar"); } - else { - $past.viviself(~$aux<name>); + # Attribute declaration. Add code to the beginning + # of the block (really class/grammar/role) to + # create the attribute. + our $?METACLASS; + my $has := PAST::Op.new( :name('!meta_attribute'), + $?METACLASS, $var.name(), $var<itype> ); + if $type { $type.named('type'); $has.push($type); } + if $init_value { + $init_value.named('init_value'); + $has.push($init_value); } + if $var<traitlist> { + $var<traitlist>.named('traitlist'); + $has.push($var<traitlist>); + } + $block[0].push( $has ); } else { - $/.panic("'" ~ $sym ~ "' not implemented"); - } - } - elsif $trait<trait_verb> { - my $verb := $trait<trait_verb>; - my $sym := $verb<sym>; - if $sym ne 'handles' { - $/.panic("'" ~ $sym ~ "' not implemented"); + # $scope eq 'package' | 'lexical' + my $viviself := PAST::Op.new( :pirop('new PsP'), $var<itype> ); + if $init_value { $viviself.push( $init_value ); } + $var.viviself( $viviself ); + if $type { + $var := PAST::Op.new( :pirop('setprop'), + $var, 'type', $type ); + } } + $past[$i] := $var; } + $i++; } + if $scope eq 'attribute' { + $past.pasttype('null'); + $past<scopedecl> := $scope; + } + elsif +@($past) == 1 { $past := $past[0]; } + else { $past.name('infix:,'); $past.pasttype('call'); } } - make $past; } method scoped($/) { my $past; - - # Variable declaration? - if $<declarator><variable_declarator> { - $past := $( $<declarator><variable_declarator> ); - - # Unless it's an attribute, emit code to set type and initialize it to - # the correct proto. - if $<fulltypename> && $past.isa(PAST::Var) { - my $type_pir := " %r = new %0, %1\n setprop %r, 'type', %2\n"; - my $type := build_type($<fulltypename>); - $past.viviself( - PAST::Op.new( - :inline($type_pir), - PAST::Val.new( :value(~$past.viviself()) ), - PAST::Op.new( - :pasttype('if'), - PAST::Op.new( - :pirop('isa'), - $type, - PAST::Val.new( :value("P6protoobject") ) - ), - $type, - PAST::Var.new( - :name('Failure'), - :scope('package') - ) - ), - $type - ) - ); - } + if $<declarator> { + $past := $( $<declarator> ); } - - # Variable declaration, but with a signature? - elsif $<declarator><signature> { - if $<fulltypename> { - $/.panic("Distributing a type across a signature at declaration unimplemented."); - } - $past := $( $<declarator><signature> ); - } - - # Routine declaration? - else { - $past := $( $<routine_declarator> ); - - # Don't support setting return type yet. - if $<fulltypename> { - $/.panic("Setting return type of a routine not yet implemented."); + elsif $<multi_declarator> { + $past := $( $<multi_declarator> ); + if $past.isa(PAST::Var) { + my $type := $past<type>; + for @($<fulltypename>) { + $type.push( $( $_ ) ); + } + $past.viviself( $( $<fulltypename>[0] ).clone() ); } } make $past; } -sub declare_attribute($/, $sym, $variable_sigil, $variable_twigil, $variable_name) { - # Get the class or role we're in. - our $?CLASS; - our $?ROLE; - our $?PACKAGE; - our $?BLOCK; - my $class_def; - if $?ROLE =:= $?PACKAGE { - $class_def := $?ROLE; - } - else { - $class_def := $?CLASS; - } - unless defined( $class_def ) { - $/.panic( - "attempt to define attribute '" ~ $name ~ "' outside of class" - ); - } - - # Is this a role-private or just a normal attribute? - my $name; - if $sym eq 'my' { - # These are only allowed inside a role. - unless $class_def =:= $?ROLE { - $/.panic('Role private attributes can only be declared in a role'); - } - - # We need to name-manage this somehow. We'll do $!rolename!attrname - # for now; long term, want some UUID. For the block entry, we enter it - # as $!attrname, add the real name and set the scope as rpattribute, - # then translate it to the right thing when we see it. - our $?NS; - $name := ~$variable_sigil ~ '!' ~ $?NS ~ '!' ~ ~$variable_name; - my $visible_name := ~$variable_sigil ~ '!' ~ ~$variable_name; - my $real_name := '!' ~ $?NS ~ '!' ~ ~$variable_name; - $?BLOCK.symbol($visible_name, :scope('rpattribute'), :real_name($real_name)); - } - else { - # Register name as attribute scope. - $name := ~$variable_sigil ~ '!' ~ ~$variable_name; - $?BLOCK.symbol($name, :scope('attribute')); - } - - # Add attribute to class (always name it with ! twigil). - if $/<scoped><fulltypename> { - $class_def.push( - PAST::Op.new( - :pasttype('call'), - :name('!keyword_has'), - PAST::Var.new( - :name('def'), - :scope('register') - ), - PAST::Val.new( :value($name) ), - build_type($/<scoped><fulltypename>) - ) - ); - } - else { - $class_def.push( - PAST::Op.new( - :pasttype('call'), - :name('!keyword_has'), - PAST::Var.new( - :name('def'), - :scope('register') - ), - PAST::Val.new( :value($name) ) - ) - ); - } - - # Is there any "handles" trait verb or an "is rw" or "is ro"? - my $rw := 0; - if $<scoped><declarator><variable_declarator><trait> { - for $<scoped><declarator><variable_declarator><trait> { - if $_<trait_verb><sym> eq 'handles' { - # Get the methods for the handles and add them to - # the class - my $meths := process_handles( - $/, - $( $_<trait_verb><EXPR> ), - $name - ); - for @($meths) { - $class_def.push($_); - } - } - elsif $_<trait_auxiliary><sym> eq 'is' { - # Just handle rw for now. - if ~$_<trait_auxiliary><name> eq 'rw' { - $rw := 1; - } - else { - $/.panic("Only 'is rw' trait is implemented for attributes"); - } - } - else { - $/.panic("Only is and handles trait verbs are implemented for attributes"); - } - } - } - - # Generate private accessor. - my $accessor := make_accessor($/, '!' ~ ~$variable_name, $name, 1, 'attribute'); - $class_def.push(add_method_to_class($accessor)); - - # Twigil handling. - if $variable_twigil eq '.' { - # We have a . twigil, so we need to generate a public accessor. - my $accessor := make_accessor($/, ~$variable_name, $name, $rw, 'attribute'); - $class_def.push(add_method_to_class($accessor)); - } - elsif $variable_twigil eq '!' { - # Don't need to do anything. +method declarator($/) { + my $past; + if $<variable_declarator> { + $past := $( $<variable_declarator> ); } - elsif $variable_twigil eq '' { - # We have no twigil, make $name as an alias to $!name. - $?BLOCK.symbol( - ~$variable_sigil ~ ~$variable_name, :scope('attribute') - ); + elsif $<signature> { + $past := $( $<signature> ); + our $?BLOCK_OPEN; + $?BLOCK_OPEN := 0; } - else { - # It's a twigil that you canny use in an attribute declaration. - $/.panic( - "invalid twigil " - ~ $variable_twigil ~ " in attribute declaration" - ); + elsif $<routine_declarator> { + $past := $( $<routine_declarator> ); } + make $past; } -method scope_declarator($/) { - our $?BLOCK; - my $declarator := $<sym>; - my $past := $( $<scoped> ); - - # What sort of thing are we scoping? - if $<scoped><declarator><variable_declarator> { - our $?PACKAGE; - our $?ROLE; - our $?CLASS; - - # Variable. If it's declared with "has" it is always an attribute. If - # it is declared with "my" inside a role and has the ! twigil, it is - # a role private attribute. - my $variable := $<scoped><declarator><variable_declarator><variable>; - my $twigil := $variable<twigil>[0]; - my $role_priv := $?ROLE =:= $?PACKAGE && $declarator eq 'my' && $twigil eq '!'; - if $declarator eq 'has' || $role_priv { - # Attribute declarations need special handling. - my $sigil := ~$<scoped><declarator><variable_declarator><variable><sigil>; - my $twigil := ~$<scoped><declarator><variable_declarator><variable><twigil>[0]; - my $name := ~$<scoped><declarator><variable_declarator><variable><name>; - declare_attribute($/, $declarator, $sigil, $twigil, $name); - - # Always leave a PAST::Var attribute node behind (can't just use what was - # produced as . twigil may have transformed it to a method call). - $past := PAST::Var.new( - :node($<scoped><declarator><variable_declarator><variable>), - :name($name), - :scope('attribute'), - :isdecl(1) - ); - } - # If we're in a class and have something declared with a sigil, then - # we need to generate an accessor method and emit that along with the - # lexical declaration itself. - elsif ($twigil eq '.' || $twigil eq '!') && $?CLASS =:= $?PACKAGE { - # This node is just the variable declaration; also register it in - # the symbol table. - my $orig_past := $past; - $past := PAST::Var.new( - :name(~$variable<sigil> ~ '!' ~ ~$variable<name>), - :scope('lexical'), - :isdecl(1), - :viviself(container_type(~$variable<sigil>)) - ); - $?BLOCK.symbol($past.name(), :scope('lexical')); - - # Now generate accessor, if it's public. - if $twigil eq '.' { - $?CLASS.push(make_accessor($/, $orig_past.name(), $past.name(), 1, 'lexical')); - } - } - - # Otherwise, just a normal variable declaration. - else { - # Has this already been declared? - my $name := $past.name(); - unless $?BLOCK.symbol($name) { - # First declaration - my $scope := 'lexical'; - $past.isdecl(1); - if $declarator eq 'our' { - $scope := 'package'; - } - elsif $declarator ne 'my' { - $/.panic( - "scope declarator '" - ~ $declarator ~ "' not implemented" - ); - } - - # Add block entry and set scope. - $past.scope($scope); - $?BLOCK.symbol($name, :scope($scope)); - } - } - } +method variable_declarator($/) { + our @?BLOCK; + my $var := $( $<variable> ); - # Signature. - elsif $<scoped><declarator><signature> { - # We'll emit code to declare each of the parameters, then we'll have - # the declaration evaluate to the signature object, thus allowing an - # assignment to it. - my @declare := sig_extract_declarables($/, $past); - $past := PAST::Op.new(:name('list'), :node($/) ); - for @declare { - # Work out sigil and twigil. - my $sigil := substr($_, 0, 1); - my $twigil := substr($_, 1, 1); - my $desigilname; - if $twigil eq '.' || $twigil eq '!' { - $desigilname := substr($_, 2); - } - else { - $twigil := ''; - $desigilname := substr($_, 1); - } + ## The $<variable> subrule might've saved a PAST::Var node for + ## us (e.g., $.x), if so, use it instead. - # Decide by declarator. - if $declarator eq 'my' || $declarator eq 'our' { - # Add declaration code. - my $scope; - if $declarator eq 'my' { - $scope := 'lexical' - } - else { - $scope := 'package'; - } - $past.push(PAST::Var.new( - :name($_), - :isdecl(1), - :scope($scope), - :viviself(container_type($sigil)) - )); - - # Add block entry. - $?BLOCK.symbol($_, :scope($scope)); - } elsif $declarator eq 'has' { - declare_attribute($/, $declarator, $sigil, $twigil, $desigilname); - } - else { - $/.panic("Scope declarator " ~ $declarator ~ " unimplemented with signatures."); - } - } + if $var<vardecl> { $var := $var<vardecl>; } + my $name := $var.name(); + my $symbol := @?BLOCK[0].symbol( $name ); + if $symbol<scope> eq 'lexical' { + warn("Redeclaration of variable " ~ $name); + $var<redecl> := 1; + $var.isdecl(0); } - - # Routine? - elsif $<scoped><routine_declarator> { - # What declarator? - if $declarator eq 'our' { - # Default, nothing to do. - } - elsif $declarator eq 'my' { - if $<scoped><routine_declarator><sym> eq 'method' { - # Add ! to start of name. - $past.name('!' ~ $past.name()); - } - else { - $/.panic("Lexically scoped subs not yet implemented."); - } - } - else { - $/.panic("Cannot apply declarator '" ~ $declarator ~ "' to a routine."); - } - } - - # Something else we've not implemetned yet? else { - $/.panic("Don't know how to apply a scope declarator here."); + $var.isdecl(1); + $var<type> := PAST::Op.new( :name('and'), :pasttype('call') ); + $var<itype> := container_itype($<variable><sigil>); + + if $<trait> { + my $traitlist := PAST::Op.new( :name('infix:,'), :pasttype('call') ); + $var<traitlist> := $traitlist; + for @($<trait>) { $traitlist.push( $( $_ ) ); } + } } - make $past; + make $var; } - - -method variable($/, $key) { - my $past; - if $key eq 'special_variable' { - $past := $( $<special_variable> ); - } - elsif $key eq '$0' { - $past := PAST::Var.new( - :scope('keyed_int'), - :node($/), - :viviself('Failure'), - PAST::Var.new( - :scope('lexical'), - :name('$/') - ), - PAST::Val.new( - :value(~$<matchidx>), - :returns('Int') - ) - ); - } - elsif $key eq '$<>' { - $past := $( $<postcircumfix> ); - $past.unshift(PAST::Var.new( - :scope('lexical'), - :name('$/'), - :viviself('Failure') - )); - } - elsif $key eq '$var' { - our $?BLOCK; - # Handle naming. - my @identifier := Perl6::Compiler.parse_name($<name>); - my $name := @identifier.pop(); - - my $twigil := ~$<twigil>[0]; - my $sigil := ~$<sigil>; - my $fullname := $sigil ~ $twigil ~ ~$name; - - if $fullname eq '@_' || $fullname eq '%_' { - unless $?BLOCK.symbol($fullname) { - $?BLOCK.symbol( $fullname, :scope('lexical') ); - my $var; - if $sigil eq '@' { - $var := PAST::Var.new( :name($fullname), :scope('parameter'), :slurpy(1) ); - } - else { - $var := PAST::Var.new( :name($fullname), :scope('parameter'), :slurpy(1), :named(1) ); - } - $?BLOCK[0].unshift($var); - } + +method variable($/, $key) { + my $var; + our @?BLOCK; + my $?BLOCK := @?BLOCK[0]; + if $key eq 'desigilname' { + my $sigil := ~$<sigil>; + if $sigil eq '&' { $sigil := ''; } + my $twigil := ~$<twigil>[0]; + my @ns := Perl6::Compiler.parse_name( $<desigilname> ); + my $name := ~@ns.pop(); + my $varname := $sigil ~ $twigil ~ $name; + + # If no twigil, but varname is 'attribute' in outer scope, + # it's really a private attribute and implies a '!' twigil + if !$twigil { + my $sym := outer_symbol($varname); + if $sym && $sym<scope> eq 'attribute' { + $twigil := '!'; + $varname := $sigil ~ $twigil ~ $name; + }; } + # If twigil is ^ or :, it's a placeholder var. Create the + # parameter for the block if one doesn't already exist. if $twigil eq '^' || $twigil eq ':' { - if $?BLOCK.symbol('___HAVE_A_SIGNATURE') { - $/.panic('A signature must not be defined on a sub that uses placeholder vars.'); + if $?BLOCK<explicit_signature> { + $/.panic("Cannot use placeholder var in block with signature."); } - unless $?BLOCK.symbol($fullname) { - $?BLOCK.symbol( $fullname, :scope('lexical') ); + $varname := $sigil ~ $name; + unless $?BLOCK.symbol($varname) { + $?BLOCK.symbol( $varname, :scope('lexical') ); $?BLOCK.arity( +$?BLOCK.arity() + 1 ); - my $var := PAST::Var.new(:name($fullname), :scope('parameter')); - if $twigil eq ':' { $var.named( ~$name ); } - my $block := $?BLOCK[0]; - my $i := +@($block); - while $i > 0 && $block[$i-1]<name> gt $fullname { - $block[$i] := $block[$i-1]; + my $param := PAST::Var.new(:name($varname), :scope('parameter')); + if $twigil eq ':' { $param.named( $name ); } + my $blockinit := $?BLOCK[0]; + my $i := +@($blockinit); + while $i > 0 && $blockinit[$i-1].name() gt $varname { + $blockinit[$i] := $blockinit[$i-1]; $i--; } - $block[$i] := $var; + $blockinit[$i] := $param; + + ## add to block's signature + block_signature($?BLOCK); + $?BLOCK.loadinit().push( + PAST::Op.new( :pasttype('callmethod'), :name('!add_param'), + PAST::Var.new( :name('signature'), :scope('register') ), + $varname + ) + ); } + ## use twigil-less form afterwards + $twigil := ''; } - # If it's $.x, it's a method call, not a variable. - if $twigil eq '.' { - $past := PAST::Op.new( - :node($/), - :pasttype('callmethod'), - :name($name), - PAST::Var.new( - :name('self'), - :scope('lexical'), - :node($/) - ) - ); - } - else { - # Variable. [!:^] twigil should be kept in the name. - if $twigil eq '!' || $twigil eq ':' || $twigil eq '^' || $twigil eq '?' { - $name := $twigil ~ ~$name; - } + $var := PAST::Var.new( :name($varname), :node($/) ); + if $twigil { $var<twigil> := $twigil; } - # All but subs should keep their sigils. - my $sigil := ''; - if $<sigil> ne '&' { - $sigil := ~$<sigil>; - } + # If namespace qualified or has a '*' twigil, it's a package var. + if @ns || $twigil eq '*' { + $twigil := ''; + $varname := $sigil ~ $name; + $var.name($varname); + $var.namespace(@ns); + $var.scope('package'); + $var.viviself( container_itype($sigil) ); + } - # If we have no twigil, but we see the name noted as an attribute in - # an enclosing scope, add the ! twigil anyway; it's an alias. - if $twigil eq '' { - our @?BLOCK; - for @?BLOCK { - if defined( $_ ) { - my $sym_table := $_.symbol($sigil ~ $name); - if defined( $sym_table ) - && $sym_table<scope> eq 'attribute' { - $name := '!' ~ $name; - $twigil := '!'; - } - } - } + ## @_ and %_ add a slurpy param to the block + if $varname eq '@_' || $varname eq '%_' { + unless $?BLOCK.symbol($varname) { + $?BLOCK.symbol( $varname, :scope('lexical') ); + my $param := PAST::Var.new( :name($varname), + :scope('parameter'), + :slurpy(1) ); + if $sigil eq '%' { $param.named(1); } + $?BLOCK[0].unshift($param); } + } - # If it's a role-private attribute, fix up the name. - if $twigil eq '!' { - our @?BLOCK; - for @?BLOCK { - if defined( $_ ) { - my $sym_table := $_.symbol($sigil ~ $name); - if defined( $sym_table ) - && $sym_table<scope> eq 'rpattribute' { - $name := $sym_table<real_name>; - } - } - } - } + # Until PCT has 'name' scope, we handle lexical/package lookup here. + if $<sigil> eq '&' { + my $sym := outer_symbol($varname); + $var.scope( ($sym && $sym<scope>) || 'package'); + } - $past := PAST::Var.new( - :name( $sigil ~ $name ), - :node($/) - ); - if @identifier || $twigil eq '*' { - $past.namespace(@identifier); - $past.scope('package'); - } - - # If it has a ! twigil, give it attribute scope and add self. - if $twigil eq '!' { - $past.scope('attribute'); - $past.unshift(PAST::Var.new( - :name('self'), - :scope('lexical') - )); - } - - # If we have something with an & sigil see if it has any entries - # in the enclosing blocks; otherwise, default to package. - if $<sigil> eq '&' { - $past.scope('package'); - our @?BLOCK; - for @?BLOCK { - if defined($_) { - my $sym_table := $_.symbol($name); - if defined($sym_table) && defined($sym_table<scope>) { - $past.scope( $sym_table<scope> ); - } - } - } - } + # The ! twigil always implies attribute scope. + if $twigil eq '!' { + $var.scope('attribute'); + } - # If we have the ? sigil, lexical scope. - if $twigil eq '?' { - $past.scope('lexical'); - } + # ! and . twigils may need 'self' for attribute lookup ... + if $twigil eq '!' || $twigil eq '.' { + $var.unshift( PAST::Var.new( :name('self'), :scope('lexical') ) ); + } - $past.viviself(container_type($sigil)); + # ...but return . twigil as a method call, saving the + # PAST::Var node in $var<vardecl> where it can be easily + # retrieved by <variable_declarator> if we're called from there. + if $twigil eq '.' { + my $vardecl := $var; + $vardecl.name( $sigil ~ '!' ~ $name ); + $var := PAST::Op.new( :node($/), :pasttype('callmethod'), + :name($name), + PAST::Var.new( :name('self'), :scope('lexical') ) + ); + $var<vardecl> := $vardecl; } } - make $past; + elsif $key eq 'special_variable' { + $var := $( $<special_variable> ); + } + elsif $key eq '$0' { + $var := PAST::Var.new( + :scope('keyed_int'), + :node($/), + :viviself('Failure'), + PAST::Var.new( :scope('lexical'), :name('$/') ), + +$<matchidx> ); + } + elsif $key eq '$<>' { + $var := $( $<postcircumfix> ); + $var.unshift( PAST::Var.new( :scope('lexical'), :name('$/'), + :viviself('Failure'), :node($/) ) + ); + } + make $var; +} + + +method special_variable($/) { + make PAST::Var.new( :node($/), :name(~$/), :scope('lexical') ); } @@ -2689,6 +1898,39 @@ } +method typename($/) { + # Extract shortname part of identifier, if there is one. + my $ns := Perl6::Compiler.parse_name($<name>); + my $shortname := $ns.pop(); + + my $past := PAST::Var.new( :name($shortname), :namespace($ns), :node($/) ); + + my $scope := ''; + our @?BLOCK; + if +$ns == 0 && @?BLOCK { + for @?BLOCK { + if defined($_) && !$scope { + my $sym := $_.symbol($shortname); + if defined($sym) && $sym<scope> { $scope := $sym<scope>; } + } + } + } + + $past.scope($scope || 'package'); + make $past; +} + + +method fulltypename($/) { + my $past := $( $<typename> ); + if substr( $<typename>.text(), 0, 2) eq '::' { + $past.isdecl(1); + $past.scope('lexical'); + } + make $past; +} + + method number($/, $key) { make $( $/{$key} ); } @@ -2834,36 +2076,6 @@ } -method typename($/) { - # Extract shortname part of identifier, if there is one. - my $ns := Perl6::Compiler.parse_name($<name>); - my $shortname := $ns.pop(); - - # determine type's scope - my $scope := ''; - our @?BLOCK; - if +$ns == 0 && @?BLOCK { - for @?BLOCK { - if defined($_) && !$scope { - my $sym := $_.symbol($shortname); - if defined($sym) && $sym<scope> { $scope := $sym<scope>; } - } - } - } - - # Create default PAST node for package lookup of type. - my $past := PAST::Var.new( - :name($shortname), - :namespace($ns), - :node($/), - :scope($scope ?? $scope !! 'package'), - :viviself('Failure') - ); - - make $past; -} - - method term($/, $key) { my $past; if $key eq 'noarg' { @@ -2936,26 +2148,14 @@ my $rhs := $( $/[1] ); my $past; - # Is it an assignment to an attribute? - if $lhs.isa(PAST::Var) && $lhs.scope() eq 'attribute' && $lhs.isdecl() { - # Add this to the WHENCE clause. - # XXX Need to make it a closure, but will need :subid to get - # scoping right. - our $?CLASS; - $?CLASS.push( - PAST::Op.new( - :pasttype('call'), - :name('!ADD_TO_WHENCE'), - PAST::Var.new( - :name('def'), - :scope('register') - ), - $lhs.name(), - $rhs - ) + if $lhs<scopedecl> eq 'attribute' { + $rhs.named('init_value'); + our $?METACLASS; + $past := PAST::Op.new( :name('!meta_attribute'), + $?METACLASS, $lhs[0].name(), $rhs ); - - # Nothing to emit at this point. + our @?BLOCK; + @?BLOCK[0][0].push($past); $past := PAST::Stmts.new(); } else { @@ -3051,32 +2251,27 @@ } -method regex_declarator($/, $key) { - make $( $/{$key} ); -} - - -method regex_declarator_regex($/) { - my $past := $( $<quote_expression> ); - $past.name( ~$<identifier>[0] ); - make $past; -} - - -method regex_declarator_token($/) { - my $past := $( $<quote_expression> ); - $past.compiler_args( :ratchet(1) ); - $past.name( ~$<identifier>[0] ); +method regex_declarator($/) { + my $sym := ~$<sym>; + my $past := $( $<regex_def> ); + if $sym eq 'token' + { $past.compiler_args( :grammar(''), :ratchet(1) ); } + elsif $sym eq 'rule' + { $past.compiler_args( :grammar(''), :s(1), :ratchet(1) ); } + else + { $past.compiler_args( :grammar('') ); } make $past; } - -method regex_declarator_rule($/) { - my $past := $( $<quote_expression> ); - $past.compiler_args( :s(1), :ratchet(1) ); - $past.name( ~$<identifier>[0] ); +method regex_def($/) { + my $past := $( $<regex_block> ); + $past.name( ~$<deflongname>[0] ); make $past; } + +method regex_block($/) { + make $( $<quote_expression> ); +} method type_declarator($/) { @@ -3158,8 +2353,8 @@ # Put this code in loadinit, so the type is created early enough, # then this node results in an empty statement node. - our $?BLOCK; - $?BLOCK.loadinit().push($past); + our @?BLOCK; + @?BLOCK[0].loadinit().push($past); make PAST::Stmts.new(); } @@ -3244,6 +2439,18 @@ } +# search through outer blocks for a symbol table entry +sub outer_symbol($name) { + our @?BLOCK; + my $symbol; + for @?BLOCK { + $symbol := $_.symbol($name); + if $symbol { return $symbol; } + } + return $symbol; +} + + # Used by all calling code to process arguments into the correct form. sub build_call($args) { if !$args.isa(PAST::Op) || $args.name() ne 'infix:,' { @@ -3316,285 +2523,28 @@ } -sub container_type($sigil) { - if $sigil eq '@' { return 'Perl6Array' } - elsif $sigil eq '%' { return 'Perl6Hash' } - else { return 'Perl6Scalar' } +sub container_itype($sigil) { + if $sigil eq '@' { return 'Perl6Array' } + elsif $sigil eq '%' { return 'Perl6Hash' } + else { return 'ObjectRef' } } -# Processes a handles expression to produce the appropriate method(s). -sub process_handles($/, $expr, $attr_name) { - my $past := PAST::Stmts.new(); - - # What type of expression do we have? - if $expr.isa(PAST::Val) && $expr.returns() eq 'Str' { - # Just a single string mapping. - my $name := ~$expr.value(); - my $method := make_handles_method($/, $name, $name, $attr_name); - $past.push(add_method_to_class($method)); - } - elsif $expr.isa(PAST::Op) && $expr.returns() eq 'Pair' { - # Single pair. - my $method := make_handles_method_from_pair($/, $expr, $attr_name); - $past.push(add_method_to_class($method)); - } - elsif $expr.isa(PAST::Op) && $expr.pasttype() eq 'call' && - $expr.name() eq 'list' { - # List of something, but what is it? - for @($expr) { - if $_.isa(PAST::Val) && $_.returns() eq 'Str' { - # String value. - my $name := ~$_.value(); - my $method := make_handles_method($/, $name, $name, $attr_name); - $past.push(add_method_to_class($method)); - } - elsif $_.isa(PAST::Op) && $_.returns() eq 'Pair' { - # Pair. - my $method := make_handles_method_from_pair($/, $_, $attr_name); - $past.push(add_method_to_class($method)); - } - else { - $/.panic( - 'Only a list of constants or pairs can be used in handles' - ); +sub trait_readtype($traitpast) { + my $readtype; + if $traitpast { + for @($traitpast) { + my $tname := $_[1]; + if $tname eq 'readonly' || $tname eq 'rw' || $tname eq 'copy' { + $readtype := $readtype ?? 'CONFLICT' !! $tname; } } } - elsif $expr.isa(PAST::Stmts) && $expr[0].name() eq 'infix:,' { - # Also a list, but constructed differently. - for @($expr[0]) { - if $_.isa(PAST::Val) && $_.returns() eq 'Str' { - # String value. - my $name := ~$_.value(); - my $method := make_handles_method($/, $name, $name, $attr_name); - $past.push(add_method_to_class($method)); - } - elsif $_.isa(PAST::Op) && $_.returns() eq 'Pair' { - # Pair. - my $method := make_handles_method_from_pair($/, $_, $attr_name); - $past.push(add_method_to_class($method)); - } - else { - $/.panic( - 'Only a list of constants or pairs can be used in handles' - ); - } - } - } - else { - $/.panic('Illegal or unimplemented use of handles'); - } - - $past + $readtype; } # Produces a handles method. -sub make_handles_method($/, $from_name, $to_name, $attr_name) { - PAST::Block.new( - :name($from_name), - :pirflags(':method'), - :blocktype('declaration'), - :node($/), - PAST::Var.new( - :name('@a'), - :scope('parameter'), - :slurpy(1) - ), - PAST::Var.new( - :name('%h'), - :scope('parameter'), - :named(1), - :slurpy(1) - ), - PAST::Op.new( - :name($to_name), - :pasttype('callmethod'), - PAST::Var.new( - :name($attr_name), - :scope('attribute') - ), - PAST::Var.new( - :name('@a'), - :scope('lexical'), - :flat(1) - ), - PAST::Var.new( - :name('%h'), - :scope('lexical'), - :flat(1), - :named(1) - ) - ) - ) -} - - -# Makes a handles method from a pair. -sub make_handles_method_from_pair($/, $pair, $attr_name) { - my $meth; - - # Single pair mapping. Check we have string name and value. - my $key := $pair[0]; - my $value := $pair[1]; - if $key.isa((PAST::Val) && $value.isa(PAST::Val)) { - my $from_name := ~$key.value(); - my $to_name := ~$value.value(); - $meth := make_handles_method($/, $from_name, $to_name, $attr_name); - } - else { - $/.panic('Only constants may be used in a handles pair argument.'); - } - - $meth -} - - -# This takes an array of match objects of type constraints and builds a type -# representation out of them. -sub build_type($cons_pt) { - # Build the type constraints list for the variable. - my $num_types := 0; - my $type_cons := PAST::Op.new(); - for $cons_pt { - $type_cons.push( $( $_<typename> ) ); - $num_types := $num_types + 1; - } - - # If there were none, it's Object. - if $num_types == 0 { - $type_cons.push(PAST::Var.new( - :name('Object'), - :scope('package') - )); - $num_types := 1; - } - - # Now need to apply the type constraints. How many are there? - if $num_types == 1 { - # Just the first one. - $type_cons := $type_cons[0]; - } - else { - # Many; make an and junction of types. - $type_cons.pasttype('call'); - $type_cons.name('all'); - } - - $type_cons -} - - -# Takes a block and turns it into a sub. -sub create_sub($/, $past) { - $past.blocktype('declaration'); - set_block_proto($past, 'Sub'); - my $multisig := $<routine_def><multisig>; - if $multisig { - set_block_sig($past, $( $multisig[0]<signature> )); - } - else { - set_block_sig($past, empty_signature()); - } -} - - -# Set the proto object type of a block. -sub set_block_proto($block, $type) { - my $loadinit := $block.loadinit(); - $loadinit.push( - PAST::Op.new( - :inline('setprop %0, "$!proto", %1'), - PAST::Var.new( :name('block'), :scope('register') ), - PAST::Var.new( :name($type), :scope('package') ) - ) - ); -} - - -# Associate a signature object with a block. -sub set_block_sig($block, $sig_obj) { - my $loadinit := $block.loadinit(); - $loadinit.push( - PAST::Op.new( - :inline('setprop %0, "$!signature", %1'), - PAST::Var.new( :name('block'), :scope('register') ), - $sig_obj - ) - ); -} - - -# Create an empty signautre object for subs with no signatures. -sub empty_signature() { - PAST::Op.new( - :pasttype('callmethod'), - :name('!create'), - PAST::Var.new( - :name('Signature'), - :scope('package'), - :namespace(list()) - ) - ) -} - - -# Creates a signature descriptor (for now, just a hash). -sub sig_descriptor_create() { - PAST::Stmts.new( - PAST::Op.new( :inline(' $P1 = new "Hash"') ), - PAST::Stmts.new(), - PAST::Op.new( :inline(' %r = $P1') ) - ) -} - -# Sets a given value in the signature descriptor. -sub sig_descriptor_set($descriptor, $name, $value) { - $descriptor[1].push(PAST::Op.new( - :inline(' $P1[%0] = %1'), - PAST::Val.new( :value(~$name) ), - $value - )); -} - -# Returns a list of variables from a signature that we are to declare. Panics -# if the signature is too complex to unpack. -sub sig_extract_declarables($/, $sig_setup) { - # Just make sure it's what we expect. - if !$sig_setup.isa(PAST::Op) || $sig_setup.pasttype() ne 'callmethod' || - $sig_setup[0].name() ne 'Signature' { - $/.panic("sig_extract_declarables was not passed signature declaration PAST!"); - } - - # Now go through what signature and extract what to declare. - my @result := list(); - my $first := 1; - for @($sig_setup) { - if $first { - # Skip over invocant. - $first := 0; - } - else { - # If it has a name, we're fine; if not, it's something odd - give - # it a miss for now. - my $found_name := undef; - for @($_[1]) { - if $_[0].value() eq 'name' { - $found_name := ~$_[1].value(); - } - } - if defined($found_name) { - @result.push($found_name); - } - else { - $/.panic("Signature too complex for LHS of assignment."); - } - } - } - @result -} - # Generates a setter/getter method for an attribute in a class or role. sub make_accessor($/, $method_name, $attr_name, $rw, $scope) { my $getset; @@ -3622,48 +2572,10 @@ } -# Adds the given method to the current class. This just returns the method that -# is passed to it if the current class is named and the original declaration; in -# the case that it is anonymous or we're adding to it we need instead to emit an -# add_method call and remove the methods name so it doesn't pollute the namespace. -sub add_method_to_class($method) { - our $?CLASS; - our $?PACKAGE; - if !($?CLASS =:= $?PACKAGE) || $?CLASS[0][1].name() eq '!keyword_class' && +@($?CLASS[0][1]) == 1 { - $method - } - else { - # Create new PAST::Block - can't work out how to unset the name of an - # existing one. - my $new_method := PAST::Block.new( - :blocktype($method.blocktype()), - :pirflags($method.pirflags()) - ); - for @($method) { - $new_method.push($_); - } - - # Put call to add method into the class definition. - $?CLASS.push(PAST::Op.new( - :pasttype('callmethod'), - :name('add_method'), - PAST::Var.new( - :name('def'), - :scope('register') - ), - PAST::Val.new( :value($method.name()) ), - $new_method - )); - - $new_method - } -} - # Creates an anonymous subset type. -sub make_anon_subset($past, $parameter) { +sub make_anon_subtype($past) { # We need a block containing the constraint condition. if !$past.isa(PAST::Block) { - # Make block with the expression as its contents. $past := PAST::Block.new( PAST::Stmts.new(), PAST::Stmts.new( $past ) @@ -3686,48 +2598,16 @@ unless $param { if $dollar_underscore { $dollar_underscore.scope('parameter'); - $param := $dollar_underscore; } else { - $param := PAST::Var.new( + $past[0].push(PAST::Var.new( :name('$_'), :scope('parameter') - ); - $past[0].push($param); + )); } } - # Now we'll just pass this block to the type checker, - # since smart-matching a block invokes it. - return PAST::Op.new( - :pasttype('call'), - :name('!TYPECHECKPARAM'), - PAST::Op.new( - :pirop('newclosure'), - $past - ), - PAST::Var.new( - :name($parameter.name()), - :scope('lexical') - ) - ); -} - - -# Takes a parse tree of traits and checks if we have the trait of the given -# name applied with the given verb. If it finds the trait, returns the -# syntax tree for that trait; otherwise, returns undef. -sub have_trait($name, $verb, $traits) { - unless $traits { return 0; } - for @($traits) { - if $_ && $_<trait_auxiliary> { - my $trait := $_<trait_auxiliary>; - if $trait<sym> eq $verb && $trait<name> eq $name { - return $trait; - } - } - } - return 0; + return $past; } @@ -3742,6 +2622,19 @@ } +sub block_signature($block) { + unless $block<signature> { + $block.loadinit().push( + PAST::Op.new( :inline(' .local pmc signature', + ' signature = new ["Signature"]', + ' setprop block, "$!signature", signature') + ) + ); + $block<signature> := 1; + } +} + + # Local Variables: # mode: cperl # cperl-indent-level: 4 Modified: trunk/languages/perl6/src/parser/grammar.pg ============================================================================== --- trunk/languages/perl6/src/parser/grammar.pg (original) +++ trunk/languages/perl6/src/parser/grammar.pg Fri Jan 9 07:50:41 2009 @@ -355,46 +355,63 @@ #### Subroutine and method definitions #### rule multi_declarator { - $<sym>=[multi|proto|only] - [ <routine_declarator> {*} #= routine_declarator - | <routine_def> {*} #= routine_def + [ + | $<sym>=[multi|proto|only] [ <declarator> || <routine_def> ] + | <declarator> ] + {*} } token routine_declarator { - | $<sym>='sub' <routine_def> {*} #= sub - | $<sym>='method' <method_def> {*} #= method + | $<sym>='sub' <routine_def> {*} #= sub + | $<sym>='method' <method_def> {*} #= method | $<sym>='submethod' <method_def> {*} #= submethod } +rule multisig { + ':'?'(' ~ ')' <signature> + {*} +} + rule routine_def { - <identifier>? <multisig>? - <trait>* + [ <deflongname=identifier> ]? [ <multisig> | <trait> ]* <block> {*} } rule method_def { - <identifier>? <multisig>? - <trait>* + [ + | <longname=name> [ <multisig> | <trait> ]* + | <multisig> <trait>* + | :: + ] <block> {*} } rule trait { + [ | <trait_auxiliary> | <trait_verb> + ] + {*} } rule trait_auxiliary { + [ | $<sym>=[is] <name><postcircumfix>? | $<sym>=[does] <name>['['<EXPR>']']? | $<sym>=[will] <identifier> <block> + ] + {*} } rule trait_verb { + [ | $<sym>=[of|returns] <typename> | $<sym>=[handles] <EXPR> + ] + {*} } token capterm { @@ -407,29 +424,27 @@ {*} } -rule multisig { - '(' <signature> ')' +token sigterm { + ':(' ~ ')' <signature> {*} } -token signature { - ( <parameter> <.ws> ( ',' <.ws> | ':' <.ws> | ';;' <.ws> | <?before ')' | '{'> ) )* <.ws> - {*} -} +rule param_sep { (','|':'|';;'|';') } -token sigterm { - ':(' - {{ - $P0 = new 'Integer' - $P0 = 1 - set_global [ 'Perl6' ; 'Grammar' ; 'Actions' ], '$?SIG_BLOCK_NOT_NEEDED', $P0 - }} - ~ ')' <signature> - {{ - $P0 = new 'Integer' - $P0 = 0 - set_global [ 'Perl6' ; 'Grammar' ; 'Actions' ], '$?SIG_BLOCK_NOT_NEEDED', $P0 - }} - {*} +token signature { + {*} #= open + <.ws> + [ + | <parameter> + | <?before '-->' | ')' | ']' | '{' | ':'<!before ':' > > + ] ** 1 ## PGE bug + [ <param_sep> + [ + | <parameter> + | <?before '-->' | ')' | ']' | '{' | ':'<!before ':' > > + ] + ]* + <.ws> + {*} #= close } rule type_declarator { @@ -445,13 +460,19 @@ # commented out. rule type_constraint { [ - | <typename> - | where <EXPR: 'm='> # XXX <EXPR(%chaining)> + | <fulltypename> + | where <EXPR: 'm='> # XXX <EXPR(item %chaining)> ] + {*} } rule post_constraint { - where <EXPR: 'm='> # XXX <EXPR(%chaining)> + where <EXPR: 'm='> {*} # XXX <EXPR(item %chaining)> +} + +token param_var { + <sigil> <twigil>? <identifier> + {*} } token parameter { @@ -472,17 +493,6 @@ '=' <EXPR: 'i='> } -token param_var { - <sigil> <twigil>? <identifier> - {*} -} - - -#### Special variables #### - -token special_variable { - $<sym>=[ '$/' | '$!' | '$¢' ] <!before \w> {*} -} #### Terms #### @@ -545,15 +555,15 @@ # XXX Note that 'self' here should be a term. token noun { | <fatarrow> {*} #= fatarrow + | <variable> {*} #= variable | <package_declarator> {*} #= package_declarator | <scope_declarator> {*} #= scope_declarator - | <multi_declarator> {*} #= multi_declarator | <routine_declarator> {*} #= routine_declarator + | <?before multi|proto|only> <multi_declarator> {*} #= multi_declarator | <regex_declarator> {*} #= regex_declarator | <type_declarator> {*} #= type_declarator | <enum_declarator> {*} #= enum_declarator | <circumfix> {*} #= circumfix - | <variable> {*} #= variable | <statement_prefix> {*} #= statement_prefix | <dotty> {*} #= dotty | <value> {*} #= value @@ -597,44 +607,21 @@ } rule package_declarator { - [ - | $<sym>=[class|grammar|module|package] {*} #= open - <package_def> {*} #= package_def - | $<sym>=[role] {*} #= open - <role_def> {*} #= role_def - ] + $<sym>=[class|grammar|module|package|role] {*} #= open + <package_def> {*} #= package_def } rule package_def { - <name>? <trait>* {*} #= open - <package_block> {*} #= close -} - - -rule role_def { - <name>['['<signature>']']? <trait>* {*} #= open - <package_block> {*} #= close -} - - -rule package_block { [ - || ';' <statement_block> {*} #= statement_block - || <block> {*} #= block - ] -} - - -token variable_declarator { - <variable> + <module_name=name> + ]? <trait>* -# XXX let EXPR handle this automatically until we can pass arguments -# <.ws> -# [ # XXX <EXPR(%item_assignment)> -# | $<op>=['='|'.='] <.ws> <EXPR> -# ]? - {*} + [ + | ';' <statement_block> {*} #= statement_block + | <block> {*} #= block + | {*} #= panic + ] } @@ -646,61 +633,72 @@ ] } - -token declarator { - [ - | <variable_declarator> - | '(' - {{ - $P0 = new 'Integer' - $P0 = 1 - set_global [ 'Perl6' ; 'Grammar' ; 'Actions' ], '$?SIG_BLOCK_NOT_NEEDED', $P0 - }} - ~ ')' <signature> - {{ - $P0 = new 'Integer' - $P0 = 0 - set_global [ 'Perl6' ; 'Grammar' ; 'Actions' ], '$?SIG_BLOCK_NOT_NEEDED', $P0 - }} - ] +rule scope_declarator { + $<sym>=[my|our|state|constant|has] + <scoped> {*} } - rule scoped { - <fulltypename>* [ | <declarator> | <routine_declarator> + | <fulltypename>+ <multi_declarator> ] {*} } - -rule scope_declarator { - $<sym>=[my|our|state|constant|has] - <scoped> +token declarator { + [ + | <variable_declarator> + | '(' ~ ')' <signature> <trait>* + | <routine_declarator> + | <regex_declarator> + | <type_declarator> + ] {*} } -token circumfix { - | '(' <statementlist> ')' {*} #= ( ) - | '[' <statementlist> ']' {*} #= [ ] - | <?before '{' | <lambda> > <pblock> {*} #= { } - | <sigil> '(' <semilist> ')' {*} #= $( ) +token variable_declarator { + <variable> + <.ws> + <trait>* + <post_constraint>* + {*} } token variable { - | <special_variable> {*} #= special_variable - | <sigil> <twigil>? <name> {*} #= $var - | <sigil> $<matchidx>=[\d+] {*} #= $0 - | <sigil> <?before '<' > <postcircumfix> {*} #= $<> + <?sigil> + [ + | <sigil> <twigil>? <desigilname> {*} #= desigilname + | <special_variable> {*} #= special_variable + | <sigil> $<matchidx>=[\d+] {*} #= $0 + | <sigil> <?before '<'> <postcircumfix> {*} #= $<> + ] } token sigil { '$' | '@' | '%' | '&' | '@@' } token twigil { <[.!^:*+?=]> } +token desigilname { + [ + | <?before '$' > <variable> + | <longname=name> + ] +} + +token special_variable { + $<sym>=[ '$/' | '$!' | '$¢' ] <!before \w> {*} +} + +token circumfix { + | '(' <statementlist> ')' {*} #= ( ) + | '[' <statementlist> ']' {*} #= [ ] + | <?before '{' | <lambda> > <pblock> {*} #= { } + | <sigil> '(' <semilist> ')' {*} #= $( ) +} + token name { | <identifier> <morename>* | <morename>+ @@ -719,6 +717,18 @@ | <number> {*} #= number } +token typename { + <?before <.upper> | '::' > <name> + {*} +} + +rule fulltypename { + <typename> +# [ of <fulltypename> ]? + {*} +} + + ## Quoting is tricky -- the <quote_concat> subrule is in ## F<src/parser/quote_expression.pir> . token quote { @@ -804,46 +814,23 @@ {*} } -rule fulltypename { - <typename> -# [ of <fulltypename> ]? - {*} -} - -token typename { - <?before <.upper> | '::' > <name> - {*} -} -# These regex rules are some way off STD.pm at the moment, but we'll work them -# closer to it over time. rule regex_declarator { - | <regex_declarator_regex> {*} #= regex_declarator_regex - | <regex_declarator_token> {*} #= regex_declarator_token - | <regex_declarator_rule> {*} #= regex_declarator_rule -} - -rule regex_declarator_regex { - $<sym>='regex' - <identifier>? - <before '{'> <quote_expression: :regex><.BLOCK_STATEMENT_END>? + $<sym>=[regex|token|rule] <regex_def> {*} } -rule regex_declarator_token { - $<sym>='token' - <identifier>? - <before '{'> <quote_expression: :regex :ratchet><.BLOCK_STATEMENT_END>? - {*} +rule regex_def { + <deflongname=name>? <regex_block> {*} } -rule regex_declarator_rule { - $<sym>='rule' - <identifier>? - <before '{'> <quote_expression: :regex :ratchet :sigspace><.BLOCK_STATEMENT_END>? +token regex_block { + <?before '{'> <quote_expression: :regex> + <.BLOCK_STATEMENT_END>? {*} } + ## S05 shows semilist as being a list of statements, in order ## to support multidimensional argument lists. For now we ## just handle a single-dimensional argument list. @@ -875,14 +862,6 @@ ] } -token desigilname { - [ - | <?before '$' > <variable> - | <name> - ] - {*} -} - #### expressions and operators #### ## The EXPR rule is our entry point into the operator Modified: trunk/languages/perl6/src/pmc/objectref_pmc.template ============================================================================== --- trunk/languages/perl6/src/pmc/objectref_pmc.template (original) +++ trunk/languages/perl6/src/pmc/objectref_pmc.template Fri Jan 9 07:50:41 2009 @@ -23,8 +23,10 @@ ATTR PMC *cached_type; VTABLE void init() { - /* Initialize with a null PMC for properties. */ - STATICSELF.init_pmc(PMCNULL); + PMC * const hll_ns = Parrot_get_ctx_HLL_namespace(INTERP); + STRING * const s_obj = string_from_literal(INTERP, "!$OBJECTREF"); + PMC * const objectpmc = Parrot_find_global_n(INTERP, hll_ns, s_obj); + STATICSELF.init_pmc(objectpmc); } VTABLE void init_pmc(PMC *value) { Modified: trunk/languages/perl6/src/pmc/perl6multisub.pmc ============================================================================== --- trunk/languages/perl6/src/pmc/perl6multisub.pmc (original) +++ trunk/languages/perl6/src/pmc/perl6multisub.pmc Fri Jan 9 07:50:41 2009 @@ -329,9 +329,9 @@ for (j = 0; j < sig_elems; j++) { PMC *param = VTABLE_get_pmc_keyed_int(interp, params, j); PMC *type = VTABLE_get_pmc_keyed_str(interp, param, - CONST_STRING(interp, "type")); + CONST_STRING(interp, "nom_type")); PMC *constraints = VTABLE_get_pmc_keyed_str(interp, param, - CONST_STRING(interp, "constraints")); + CONST_STRING(interp, "cons_type")); PMC *multi_inv = VTABLE_get_pmc_keyed_str(interp, param, CONST_STRING(interp, "multi_invocant")); info->types[j] = type; Modified: trunk/languages/perl6/t/00-parrot/05-var.t ============================================================================== --- trunk/languages/perl6/t/00-parrot/05-var.t (original) +++ trunk/languages/perl6/t/00-parrot/05-var.t Fri Jan 9 07:50:41 2009 @@ -34,5 +34,5 @@ ## nested 'our' declarations -our $x = 'not ok 12'; { our $x = 'ok 12'; }; say $x; +$x = 'not ok 12'; { our $x = 'ok 12'; }; say $x; Modified: trunk/languages/perl6/t/00-parrot/08-regex.t ============================================================================== --- trunk/languages/perl6/t/00-parrot/08-regex.t (original) +++ trunk/languages/perl6/t/00-parrot/08-regex.t Fri Jan 9 07:50:41 2009 @@ -19,7 +19,7 @@ '5' ~~ $r and say 'ok 6'; '25' ~~ $r or say 'ok 7'; -my $r = / 5 /; +$r = / 5 /; $l ~~ $r and say 'ok 8'; 5 ~~ $r and say 'ok 9'; '5' ~~ $r and say 'ok 10'; Modified: trunk/languages/perl6/t/pmc/objectref.t ============================================================================== --- trunk/languages/perl6/t/pmc/objectref.t (original) +++ trunk/languages/perl6/t/pmc/objectref.t Fri Jan 9 07:50:41 2009 @@ -25,7 +25,7 @@ plan(4) init() - assign_val() + init_pmc() meth_call() multi_call() .end @@ -39,13 +39,12 @@ .end -.sub assign_val +.sub init_pmc # Assigning a value. - $P1 = new 'ObjectRef' $P2 = get_hll_global 'Int' $P2 = $P2.'new'() $P2 = 42 - assign $P1, $P2 + $P1 = new 'ObjectRef', $P2 # Get integer value; see what we have stored. $I0 = $P1 @@ -55,9 +54,8 @@ .sub meth_call # Check we can call methods. - $P1 = new 'ObjectRef' $P2 = 'list'(1,2,3) - assign $P1, $P2 + $P1 = new 'ObjectRef', $P2 $I0 = $P1.'elems'() is($I0, 3, 'method calls on value work') .end @@ -66,15 +64,13 @@ .sub multi_call # Try and do a multi-dispatch call with two items. .local pmc x, y - x = new 'ObjectRef' - y = new 'ObjectRef' $P2 = get_hll_global 'Int' $P3 = $P2.'new'() $P3 = 35 - x = $P3 + x = new 'ObjectRef', $P3 $P4 = $P2.'new'() $P4 = 7 - y = $P4 + y = new 'ObjectRef', $P4 $P5 = 'infix:+'(x, y) $I0 = $P5 is($I0, 42, 'multi call worked') Modified: trunk/languages/perl6/t/pmc/perl6multisub-arity.t ============================================================================== --- trunk/languages/perl6/t/pmc/perl6multisub-arity.t (original) +++ trunk/languages/perl6/t/pmc/perl6multisub-arity.t Fri Jan 9 07:50:41 2009 @@ -161,7 +161,7 @@ param_loop: if $I0 == num_params goto param_loop_end $P2 = new 'Perl6Hash' - $P2["type"] = any + $P2["nom_type"] = any $P2["multi_invocant"] = true push $P1, $P2 inc $I0 Modified: trunk/languages/perl6/t/pmc/perl6multisub-tiebreak.t ============================================================================== --- trunk/languages/perl6/t/pmc/perl6multisub-tiebreak.t (original) +++ trunk/languages/perl6/t/pmc/perl6multisub-tiebreak.t Fri Jan 9 07:50:41 2009 @@ -79,8 +79,8 @@ unless it goto param_loop_end con = shift it $P2 = new 'Perl6Hash' - $P2["type"] = any - $P2["constraints"] = con + $P2["nom_type"] = any + $P2["cons_type"] = con $P2["multi_invocant"] = true push $P1, $P2 goto param_loop Modified: trunk/languages/perl6/t/pmc/perl6multisub-type.t ============================================================================== --- trunk/languages/perl6/t/pmc/perl6multisub-type.t (original) +++ trunk/languages/perl6/t/pmc/perl6multisub-type.t Fri Jan 9 07:50:41 2009 @@ -187,7 +187,7 @@ $S0 = $P3 type = get_hll_global $S0 $P2 = new 'Perl6Hash' - $P2["type"] = type + $P2["nom_type"] = type $P2["multi_invocant"] = true push $P1, $P2 goto param_loop Modified: trunk/languages/perl6/t/spectest.data ============================================================================== --- trunk/languages/perl6/t/spectest.data (original) +++ trunk/languages/perl6/t/spectest.data Fri Jan 9 07:50:41 2009 @@ -7,6 +7,7 @@ # S03-operators/overflow.t - passes only if bignum lib is available # S03-operators/binding-arrays.t - regressed to allow slices # S03-operators/binding-hashes.t - regressed to allow slices +# integration/man-or-boy.t - regressed for rvar branch integration/99problems-01-to-10.t integration/99problems-11-to-20.t @@ -17,7 +18,6 @@ integration/99problems-61-to-70.t integration/lexical-array-in-inner-block.t integration/lexicals-and-attributes.t -integration/man-or-boy.t integration/method-calls-and-instantiation.t integration/real-strings.t integration/say-crash.t

nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About