[svn:parrot] r35134 - in branches/rvar2: compilers/pct/src/PAST compilers/pct/src/PCT compilers/pct/src/POST languages/perl6 languages/perl6/src/builtins languages/perl6/src/classes languages/perl6/src/parser languages/perl6/src/pmc languages/perl6/t/00-p

From:

pmichaud

Date:

January 7, 2009 09:13

Subject:

Message ID:

20090107171329.00663CB9F9@x12.develooper.com

Author: pmichaud Date: Wed Jan 7 09:13:27 2009 New Revision: 35134 Modified: branches/rvar2/compilers/pct/src/PAST/Compiler.pir branches/rvar2/compilers/pct/src/PAST/Node.pir branches/rvar2/compilers/pct/src/PCT/Node.pir branches/rvar2/compilers/pct/src/POST/Node.pir branches/rvar2/languages/perl6/perl6.pir branches/rvar2/languages/perl6/src/builtins/assign.pir branches/rvar2/languages/perl6/src/builtins/globals.pir branches/rvar2/languages/perl6/src/builtins/guts.pir branches/rvar2/languages/perl6/src/classes/Array.pir branches/rvar2/languages/perl6/src/classes/Hash.pir branches/rvar2/languages/perl6/src/classes/Object.pir branches/rvar2/languages/perl6/src/classes/Protoobject.pir branches/rvar2/languages/perl6/src/classes/Signature.pir branches/rvar2/languages/perl6/src/parser/actions.pm branches/rvar2/languages/perl6/src/parser/grammar.pg branches/rvar2/languages/perl6/src/pmc/objectref_pmc.template branches/rvar2/languages/perl6/t/00-parrot/05-var.t branches/rvar2/languages/perl6/t/00-parrot/08-regex.t branches/rvar2/languages/perl6/t/pmc/objectref.t branches/rvar2/src/pmc/class.pmc Log: Second step of new branch from rvar+trunk. Modified: branches/rvar2/compilers/pct/src/PAST/Compiler.pir ============================================================================== --- branches/rvar2/compilers/pct/src/PAST/Compiler.pir (original) +++ branches/rvar2/compilers/pct/src/PAST/Compiler.pir Wed Jan 7 09:13:27 2009 @@ -80,7 +80,7 @@ piropsig['pow'] = 'NN+' piropsig['print'] = 'v*' piropsig['set'] = 'PP' - piropsig['setprop'] = 'vP~P' + piropsig['setprop'] = '0P~P' set_global '%piropsig', piropsig ## %valflags specifies when PAST::Val nodes are allowed to @@ -584,7 +584,7 @@ =cut -.sub 'as_post' :method :multi(_, ['PAST';'Node']) +.sub 'as_post' :method :multi(_, ['PAST';'Node']) :subid('Node.as_post') .param pmc node .param pmc options :slurpy :named @@ -743,10 +743,11 @@ unshift blockpast, node .local string name, pirflags, blocktype - .local pmc ns, hll + .local pmc subid, ns, hll name = node.'name'() pirflags = node.'pirflags'() blocktype = node.'blocktype'() + subid = node.'subid'() ns = node.'namespace'() hll = node.'hll'() @@ -760,7 +761,7 @@ ## create a POST::Sub node for this block .local pmc bpost $P0 = get_hll_global ['POST'], 'Sub' - bpost = $P0.'new'('node'=>node, 'name'=>name, 'blocktype'=>blocktype, 'namespace'=>ns, 'hll'=>hll) + bpost = $P0.'new'('node'=>node, 'name'=>name, 'blocktype'=>blocktype, 'namespace'=>ns, 'hll'=>hll, 'subid'=>subid) unless pirflags goto pirflags_done bpost.'pirflags'(pirflags) pirflags_done: @@ -1045,6 +1046,11 @@ $S0 = substr signature, 0, 1 if $S0 == 'v' goto pirop_void + $I0 = index '0123456789', $S0 + if $I0 < 0 goto pirop_reg + $S0 = arglist[$I0] + ops.'result'($S0) + goto pirop_void pirop_reg: .local string result result = self.'uniquereg'($S0) @@ -1505,6 +1511,37 @@ .end +=item stmts(PAST::Op node) + +Treat the node like a PAST::Stmts node -- i.e., invoke all the +children and return the value of the last one. + +=cut + +.sub 'stmts' :method :multi(_, ['PAST';'Op']) + .param pmc node + .param pmc options :slurpy :named + + .const 'Sub' $P0 = 'Node.as_post' + .tailcall self.$P0(node, options :flat :named) +.end + + +=item null(PAST::Op node) + +A "no-op" node -- none of the children are processed, and +no statements are generated. + +=cut + +.sub 'null' :method :multi(_, ['PAST';'Op']) + .param pmc node + .param pmc options :slurpy :named + $P0 = get_hll_global ['POST'], 'Ops' + .tailcall $P0.'new'('node'=>node) +.end + + =item return(PAST::Op node) Generate a return exception, using the first child (if any) as @@ -1916,7 +1953,17 @@ scope = concat " '", scope scope = concat scope, "'" scope_error_1: - .tailcall self.'panic'("Scope", scope, " not found for PAST::Var '", name, "'") + # Find the nearest named block + .local pmc it + $P0 = get_global '@?BLOCK' + it = iter $P0 + scope_error_block_loop: + unless it goto scope_error_2 + $P0 = shift it + $S0 = $P0.'name'() + unless $S0 goto scope_error_block_loop + scope_error_2: + .tailcall self.'panic'("Scope", scope, " not found for PAST::Var '", name, "' in ", $S0) .end @@ -2156,9 +2203,6 @@ name = node.'name'() name = self.'escape'(name) - .local int isdecl - isdecl = node.'isdecl'() - .local pmc call_on, ops call_on = node[0] if null call_on goto use_self @@ -2173,21 +2217,14 @@ if bindpost goto attribute_bind attribute_post: - if isdecl goto attribute_decl .local pmc fetchop, storeop $P0 = get_hll_global ['POST'], 'Op' fetchop = $P0.'new'(ops, call_on, name, 'pirop'=>'getattribute') storeop = $P0.'new'(call_on, name, ops, 'pirop'=>'setattribute') .tailcall self.'vivify'(node, ops, fetchop, storeop) - attribute_decl: - .tailcall $P0.'new'('node'=>node) - attribute_bind: $P0 = get_hll_global ['POST'], 'Op' - if isdecl goto attribute_bind_decl - .tailcall $P0.'new'(call_on, name, bindpost, 'pirop'=>'setattribute', 'result'=>bindpost) - attribute_bind_decl: .tailcall $P0.'new'(call_on, name, bindpost, 'pirop'=>'setattribute', 'result'=>bindpost) .end @@ -2198,6 +2235,10 @@ .local string name name = node.'name'() + if name goto have_name + name = self.'uniquereg'('P') + node.'name'(name) + have_name: .local pmc ops $P0 = get_hll_global ['POST'], 'Ops' Modified: branches/rvar2/compilers/pct/src/PAST/Node.pir ============================================================================== --- branches/rvar2/compilers/pct/src/PAST/Node.pir (original) +++ branches/rvar2/compilers/pct/src/PAST/Node.pir Wed Jan 7 09:13:27 2009 @@ -551,7 +551,7 @@ .end -=item symbol(name, [attr1 => val1, attr2 => val2, ...]) +=item symbol(name [, attr1 => val1, attr2 => val2, ...]) If called with named arguments, sets the symbol hash corresponding to C<name> in the current block. The HLL is free to select @@ -573,14 +573,24 @@ symtable = new 'Hash' self['symtable'] = symtable have_symtable: - if attr goto set_symbol - get_symbol: - $P0 = symtable[name] - if null $P0 goto end - .return ($P0) - set_symbol: + .local pmc symbol + symbol = symtable[name] + if null symbol goto symbol_empty + unless attr goto attr_done + .local pmc it + it = iter attr + attr_loop: + unless it goto attr_done + $S0 = shift it + $P0 = attr[$S0] + symbol[$S0] = $P0 + goto attr_loop + attr_done: + .return (symbol) + symbol_empty: + unless attr goto symbol_done symtable[name] = attr - end: + symbol_done: .return (attr) .end @@ -660,6 +670,27 @@ .tailcall self.'attr'('compiler_args', value, have_value) .end +=item subid([subid]) + +If C<subid> is provided, then sets the subid for this block. +Returns the current subid for the block, generating a unique +subid for the block if one does not already exist. + +=cut + +.sub 'subid' :method + .param pmc value :optional + .param int has_value :opt_flag + if has_value goto getset_value + $I0 = exists self['subid'] + if $I0 goto getset_value + value = self.'unique'() + has_value = 1 + getset_value: + .tailcall self.'attr'('subid', value, has_value) +.end + + =item pirflags([pirflags]) Get/set any pirflags for this block. Modified: branches/rvar2/compilers/pct/src/PCT/Node.pir ============================================================================== --- branches/rvar2/compilers/pct/src/PCT/Node.pir (original) +++ branches/rvar2/compilers/pct/src/PCT/Node.pir Wed Jan 7 09:13:27 2009 @@ -97,6 +97,18 @@ .end +=item clone() + +Clone the node. + +=cut + +.sub 'clone' :method + $P0 = clone self + .return ($P0) +.end + + =item unshift(child) Add C<child> to the beginning of the invocant's list of children. Modified: branches/rvar2/compilers/pct/src/POST/Node.pir ============================================================================== --- branches/rvar2/compilers/pct/src/POST/Node.pir (original) +++ branches/rvar2/compilers/pct/src/POST/Node.pir Wed Jan 7 09:13:27 2009 @@ -207,7 +207,7 @@ if has_value goto getset_value $I0 = exists self['subid'] if $I0 goto getset_value - value = self.'unique'() + value = self.'unique'('post') has_value = 1 getset_value: .tailcall self.'attr'('subid', value, has_value) Modified: branches/rvar2/languages/perl6/perl6.pir ============================================================================== --- branches/rvar2/languages/perl6/perl6.pir (original) +++ branches/rvar2/languages/perl6/perl6.pir Wed Jan 7 09:13:27 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,15 @@ $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 a list of END blocks to be run $P0 = new 'List' Modified: branches/rvar2/languages/perl6/src/builtins/assign.pir ============================================================================== --- branches/rvar2/languages/perl6/src/builtins/assign.pir (original) +++ branches/rvar2/languages/perl6/src/builtins/assign.pir Wed Jan 7 09:13:27 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 @@ -73,23 +73,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: branches/rvar2/languages/perl6/src/builtins/globals.pir ============================================================================== --- branches/rvar2/languages/perl6/src/builtins/globals.pir (original) +++ branches/rvar2/languages/perl6/src/builtins/globals.pir Wed Jan 7 09:13:27 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: branches/rvar2/languages/perl6/src/builtins/guts.pir ============================================================================== --- branches/rvar2/languages/perl6/src/builtins/guts.pir (original) +++ branches/rvar2/languages/perl6/src/builtins/guts.pir Wed Jan 7 09:13:27 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. @@ -336,6 +366,212 @@ .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 == 'class' goto class + if type == 'grammar' goto class + if type == 'role' goto role + 'die'("Unsupported package declarator ", type) + + class: + .local pmc metaclass, ns + ns = get_hll_namespace nsarray + if also goto is_also + metaclass = newclass ns + .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 + .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' + + p6meta.'register'(metaclass, 'parent'=>'Any') +.end + + +=item !meta_compose(Role role) + +Compose the role. + +=cut + +.sub '!meta_compose' :multi(['Role']) + .param pmc role + # 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 + $P0 = get_class $P0 + + ## 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 !keyword_class(name) Internal helper method to create a class. Modified: branches/rvar2/languages/perl6/src/classes/Array.pir ============================================================================== --- branches/rvar2/languages/perl6/src/classes/Array.pir (original) +++ branches/rvar2/languages/perl6/src/classes/Array.pir Wed Jan 7 09:13:27 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: branches/rvar2/languages/perl6/src/classes/Hash.pir ============================================================================== --- branches/rvar2/languages/perl6/src/classes/Hash.pir (original) +++ branches/rvar2/languages/perl6/src/classes/Hash.pir Wed Jan 7 09:13:27 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: branches/rvar2/languages/perl6/src/classes/Object.pir ============================================================================== --- branches/rvar2/languages/perl6/src/classes/Object.pir (original) +++ branches/rvar2/languages/perl6/src/classes/Object.pir Wed Jan 7 09:13:27 2009 @@ -228,7 +228,7 @@ =cut .namespace ['Perl6Object'] -.sub '' :method('Scalar') :anon +.sub 'Scalar' :method $I0 = isa self, 'ObjectRef' unless $I0 goto not_ref .return (self) @@ -237,21 +237,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 +257,127 @@ =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) +.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 + + +.sub 'BUILDALL' :method + .param pmc candidate + .param pmc attrinit + + .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: + 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 + 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. - # Instantiate. +=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: branches/rvar2/languages/perl6/src/classes/Protoobject.pir ============================================================================== --- branches/rvar2/languages/perl6/src/classes/Protoobject.pir (original) +++ branches/rvar2/languages/perl6/src/classes/Protoobject.pir Wed Jan 7 09:13:27 2009 @@ -73,6 +73,19 @@ =back +=head2 Coercions + +=over + +=item Scalar() + +=cut + +.namespace ['P6protoobject'] +.sub 'Scalar' :method + .return (self) +.end + =head2 Private methods =over Modified: branches/rvar2/languages/perl6/src/classes/Signature.pir ============================================================================== --- branches/rvar2/languages/perl6/src/classes/Signature.pir (original) +++ branches/rvar2/languages/perl6/src/classes/Signature.pir Wed Jan 7 09:13:27 2009 @@ -43,78 +43,36 @@ =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 - - # 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 - # constraints; otherwise, we find the unique type. Finally, we turn the - # list of constraints into a junction. - .local pmc cur_list, cur_list_iter, constraints, type, test_item - constraints = 'list'() - type = null - cur_list = cur_param["constraints"] - cur_list_iter = iter cur_list - - cur_list_loop: - unless cur_list_iter goto cur_list_loop_end - test_item = shift cur_list_iter - $I0 = isa test_item, "Role" - if $I0 goto is_type - $P0 = getprop "subtype_realtype", test_item - if null $P0 goto not_refinement - unless null type goto all_constraints - type = $P0 - push constraints, test_item - goto cur_list_loop - not_refinement: - $I0 = isa test_item, "P6protoobject" - if $I0 goto is_type - push constraints, test_item - goto cur_list_loop - is_type: - unless null type goto all_constraints - type = test_item - goto cur_list_loop - all_constraints: - type = null - constraints = cur_list - cur_list_loop_end: - unless null type goto have_type - type = get_hll_global 'Any' +.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: + + # For now, if no type, set it to Any. + $P0 = attr['type'] + unless null $P0 goto have_type + $P0 = get_hll_global 'Any' + attr['type'] = $P0 have_type: - cur_param["type"] = type - $I0 = elements constraints - if $I0 == 0 goto no_constraints - constraints = 'all'(constraints) - goto set_constraints - no_constraints: - constraints = null - set_constraints: - cur_param["constraints"] = constraints - goto param_loop - param_loop_end: - - $P0 = self.'new'() - setattribute $P0, '@!params', parameters - .return ($P0) + # Add to parameters list. + .local pmc params + params = self.'params'() + push params, attr .end =item params @@ -125,6 +83,10 @@ .sub 'params' :method $P0 = getattribute self, "@!params" + unless null $P0 goto done + $P0 = 'list'() + setattribute self, "@!params", $P0 + done: .return ($P0) .end @@ -223,10 +185,82 @@ .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'] + 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 + ne_addr orig, var, param_readtype_var + var = new 'ObjectRef', var + param_readtype_var: + if $S0 == 'copy' goto param_readtype_done + $P0 = get_hll_global ['Bool'], 'True' + setprop var, 'readonly', $P0 + 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: branches/rvar2/languages/perl6/src/parser/actions.pm ============================================================================== --- branches/rvar2/languages/perl6/src/parser/actions.pm (original) +++ branches/rvar2/languages/perl6/src/parser/actions.pm Wed Jan 7 09:13:27 2009 @@ -57,26 +57,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 +99,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 +229,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; @@ -327,8 +324,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 +378,8 @@ ), $past ); - our $?BLOCK; + our @?BLOCK; + my $?BLOCK := @?BLOCK[0]; my $eh := PAST::Control.new( $past ); my @handlers; if $?BLOCK.handlers() { @@ -408,7 +406,8 @@ ), $past ); - our $?BLOCK; + our @?BLOCK; + my $?BLOCK := @?BLOCK[0]; my $eh := PAST::Control.new( $past, :handle_types('CONTROL') @@ -512,139 +511,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 +801,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 +821,212 @@ } -method routine_def($/) { - my $past := $( $<block> ); - - if $<identifier> { - $past.name( ~$<identifier>[0] ); - our $?BLOCK; - $?BLOCK.symbol(~$<identifier>[0], :scope('package')); +method routine_declarator($/, $key) { + my $past; + if $key eq 'sub' { + $past := $($<routine_def>); } - $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') - ) - ) - ); - } - } - } - } + 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 method_def($/) { + +method routine_def($/) { my $past := $( $<block> ); - my $identifier := $<identifier>; - if $identifier { - $past.name( ~$identifier[0] ); + $past.blocktype('declaration'); + if $<deflongname> { + my $name := ~$<deflongname>[0]; + $past.name( $name ); + our @?BLOCK; + @?BLOCK[0].symbol( $name, :scope('package') ); } $past.control('return_pir'); - - # Emit code to apply any traits. - 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') - ) - ) - ); - } - } - } - } - + create_signature_if_none($past); 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($/) ); - } - - # 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()) - ) - ); +method method_def($/) { + my $past := $( $<block> ); + $past.blocktype('method'); - # 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"); - } + if $<longname> { + $past.name( ~$<longname> ); + } - # 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') ) - )); - } - } + # Add lexical 'self'. + $past[0].unshift( + PAST::Var.new( :name('self'), :scope('lexical'), :isdecl(1), + :viviself( 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."); - } - } + $past.control('return_pir'); + create_signature_if_none($past); + make $past; +} - # 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>); - } - # 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')); - } - else { - my $type_obj := make_anon_subset($( $_<EXPR> ), $parameter); - $cur_param_types.push($type_obj); - } - } - } +method trait($/) { + my $past; + if $<trait_auxiliary> { + $past := $( $<trait_auxiliary> ); + } + elsif $<trait_verb> { + $past := $( $<trait_verb> ); + } + make $past; +} - # Add any post-constraints too. - for $_<parameter><post_constraint> { - my $type_obj := make_anon_subset($( $_<EXPR> ), $parameter); - $cur_param_types.push($type_obj); - } +method trait_auxiliary($/) { + my $sym := ~$<sym>; + my $trait; + if $sym eq 'is' || $sym eq 'does' { + $trait := ~$<name>; + } + make PAST::Op.new( :name('infix:,'), 'trait_auxiliary:' ~ $sym, $trait ); +} - # 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') - ) - )); - } - # For blocks, we just collect the check into the list of all checks. - unless $?SIG_BLOCK_NOT_NEEDED { - $type_check.push($cur_param_types); - } +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 ); +} - # 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); - # 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') - ) - ) - )); +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<signature> := 1; + $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( :scope('register') ); + + ## create a Signature object and attach to the block + $loadinit.push( + PAST::Op.new( :inline(' %0 = new "Signature"', + ' setprop block, "$!signature", %0'), + $sigobj) + ); + + ## 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(); + + ## add var node to block + $sigpast.push( $var ); + + 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 { + ## don't need the 'and' junction for only one type + if +@($type) == 1 { $type := $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" + ); } - 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') - ) - ) - )); + $sigparam.push(PAST::Val.new(:value($readtype),:named('readtype'))); + + if ($multi_inv_suppress) { + $sigparam.push(PAST::Val.new(:value(0),:named('multi_invocant'))); } - } + if $<param_sep>[$i][0] eq ';;' { $multi_inv_suppress := 1; } - # If the separator is a ;; then parameters beyond this are not multi - # invocants. - if substr($separator, 0, 2) eq ';;' { - $is_multi_invocant := 0; + $loadinit.push($sigparam); + $i++; } - } - # 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); + ## restore block stack and return signature ast + our $?BLOCK_OPEN; + $?BLOCK_OPEN := $block; + make $sigpast; } +} - # Hand back the PAST to construct a signature object. - make $sig_past; + +method type_constraint($/) { + my $past; + if $<fulltypename> { + $past := $( $<fulltypename> ); + } + 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 +1034,63 @@ 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('and'), :pasttype('call') ); + $var<type> := $typelist; + if $<type_constraint> { + for @($<type_constraint>) { + my $type_past := $( $_ ); + if substr( $_.text() , 0, 2 ) eq '::' { + # it's a type binding + $type_past.scope('lexical'); + $type_past.isdecl(1); + $type_past.viviself( + PAST::Op.new( :pasttype('callmethod'), :name('WHAT'), + PAST::Var.new( :name($var.name()) ) + ) + ); + $var<type_binding> := $type_past; + our @?BLOCK; + @?BLOCK[0].symbol( $type_past.name(), :scope('lexical') ); + } + else { + $typelist.push( $type_past ); + } + } + } + + 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 $name := ~$/; + my $twigil := ~$<twigil>[0]; + if $twigil && $twigil ne '.' && $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<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; } @@ -1673,938 +1344,375 @@ 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>; - + our @?PKGDECL; + my $sym := ~$<sym>; + my $past; 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); - } + our $?BLOCK_OPEN; + $?BLOCK_OPEN := PAST::Block.new( PAST::Stmts.new(), :node($/) ); + $?BLOCK_OPEN<pkgdecl> := $sym; + @?PKGDECL.unshift( $sym ); } 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 $( $<package_def> ); + @?PKGDECL.shift(); } - - # 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'); - } - - # 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; + our @?PKGDECL; + my $?PKGDECL := @?PKGDECL[0]; - 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') - ) - ); - - # 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') - ) - ) - ); - } - - $?CLASS.push($class_def); - } - else { - # Anonymous modules not supported. - unless $name { - $/.panic('Anonymous modules not supported'); - } - } - - # Also store the current namespace, if we're not anonymous. - if $name { - $?NS := ~$name[0]; - } + if $key eq 'panic' { + $/.panic("Unable to parse " ~ $?PKGDECL ~ " definition"); } - 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') ) ) - ) - ) - ) - ); - - # 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') ) ) - ) - ) - ) - ); - - # 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) - )); - } - } - # 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( $_ ); - } - } - } + my $block := $( $/{$key} ); + $block.blocktype('declaration'); + $block.lexical(0); - make $past; + my $modulename := $<module_name> + ?? ~$<module_name>[0] !! + $block.unique('!ANON'); + if ($modulename) { + $block.namespace( PAST::Compiler.parse_name( $modulename ) ); } -} - -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) ) - ) - ) - ); - - # Also store the current namespace. - $?NS := $name; + if $key eq 'block' { + # A normal block acts like a BEGIN and is executed ASAP. + $block.pirflags(':load :init'); } - 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; + elsif $key eq 'statement_block' && !$<module_name> { + $/.panic("Compilation unit cannot be anonymous"); } -} + # Create a node at the beginning of the block's initializer + # for package initializations + my $init := PAST::Stmts.new(); + $block[0].unshift( $init ); -method package_block($/, $key) { - my $past := $( $/{$key} ); - make $past; -} - + # 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. -method variable_declarator($/) { - my $past := $( $<variable> ); - - # 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"); - } - else { - $past.viviself(~$aux<name>); - } - } - 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"); - } - } - } - } - - 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 - ) - ); - } - } - - # 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."); - } - } - 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"); - } - } + # 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 { - $/.panic("Only is and handles trait verbs are implemented for attributes"); + $trait.name('!meta_trait'); + $trait.unshift($?METACLASS); + $init.push($trait); } } } - # 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. - } - elsif $variable_twigil eq '' { - # We have no twigil, make $name as an alias to $!name. - $?BLOCK.symbol( - ~$variable_sigil ~ ~$variable_name, :scope('attribute') - ); - } - else { - # It's a twigil that you canny use in an attribute declaration. - $/.panic( - "invalid twigil " - ~ $variable_twigil ~ " in attribute declaration" - ); - } -} - -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" - ); - } + # 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> + ) + ) + ); - # Add block entry and set scope. - $past.scope($scope); - $?BLOCK.symbol($name, :scope($scope)); - } - } - } + # ...and at the end of the block's initializer (after any other + # items added by the block), we finalize the composition + $block[0].push( PAST::Op.new( :name('!meta_compose'), $?METACLASS) ); - # 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); - } + make $block; +} + + +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) { + 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); + } - # Decide by declarator. - if $declarator eq 'my' || $declarator eq 'our' { - # Add declaration code. - my $scope; - if $declarator eq 'my' { - $scope := 'lexical' + if $scope eq 'attribute' { + 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"); + } + # 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 { - $scope := 'package'; + # $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.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."); + $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; +} - # 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."); + +method scoped($/) { + my $past; + if $<declarator> { + $past := $( $<declarator> ); + } + elsif $<multi_declarator> { + $past := $( $<multi_declarator> ); + if $past.isa(PAST::Var) { + my $type := $past<type>; + for @($<fulltypename>) { + $type.push( $( $_ ) ); } - } - else { - $/.panic("Cannot apply declarator '" ~ $declarator ~ "' to a routine."); + $past.viviself( $( $<fulltypename>[0] ).clone() ); } } - - # Something else we've not implemetned yet? - else { - $/.panic("Don't know how to apply a scope declarator here."); - } - make $past; } -method variable($/, $key) { +method declarator($/) { my $past; - if $key eq 'special_variable' { - $past := $( $<special_variable> ); + if $<variable_declarator> { + $past := $( $<variable_declarator> ); } - 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 $<signature> { + $past := $( $<signature> ); + our $?BLOCK_OPEN; + $?BLOCK_OPEN := 0; } - elsif $key eq '$<>' { - $past := $( $<postcircumfix> ); - $past.unshift(PAST::Var.new( - :scope('lexical'), - :name('$/'), - :viviself('Failure') - )); + elsif $<routine_declarator> { + $past := $( $<routine_declarator> ); } - 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); - } + make $past; +} + + +method variable_declarator($/) { + our @?BLOCK; + my $var := $( $<variable> ); + + ## The $<variable> subrule might've saved a PAST::Var node for + ## us (e.g., $.x), if so, use it instead. + + if $var<vardecl> { $var := $var<vardecl>; } + my $name := $var.name(); + my $symbol := @?BLOCK[0].symbol( $name ); + if $symbol<scope> eq 'lexical' { + $/.panic("Redeclaration of variable " ~ $name); + } + + $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 $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') ); + $twigil := ''; + $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 $param := PAST::Var.new(:name($varname), :scope('parameter')); + if $twigil eq ':' { $param.named( $name ); } my $block := $?BLOCK[0]; my $i := +@($block); - while $i > 0 && $block[$i-1]<name> gt $fullname { + while $i > 0 && $block[$i-1].name() gt $varname { $block[$i] := $block[$i-1]; $i--; } - $block[$i] := $var; + $block[$i] := $param; + + # XXX Need to generate Signature accounting for the placeholders. + $?BLOCK<signature> := 1; } } - # 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($/) - ) - ); + $var := PAST::Var.new( :name($varname), :node($/) ); + if $twigil { $var<twigil> := $twigil; } + + # If namespace qualified or has a '*' twigil, it's a package var. + if @ns || $twigil eq '*' { + $var.namespace(@ns); + $var.scope('package'); + $var.viviself( container_itype($sigil) ); } - else { - # Variable. [!:^] twigil should be kept in the name. - if $twigil eq '!' || $twigil eq ':' || $twigil eq '^' || $twigil eq '?' { - $name := $twigil ~ ~$name; - } - # All but subs should keep their sigils. - my $sigil := ''; - if $<sigil> ne '&' { - $sigil := ~$<sigil>; + ## @_ 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 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 := '!'; - } - } - } - } + # Until PCT has 'name' scope, we handle lexical/package lookup here. + if $<sigil> eq '&' { + $var.scope('package'); + my $sym := outer_symbol($varname); + if $sym && $sym<scope> { $var.scope( $sym<scope> ); } + } - # 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>; - } - } - } - } + # ! and . twigils may need 'self' for attribute lookup ... + if $twigil eq '!' || $twigil eq '.' { + $var.unshift( PAST::Var.new( :name('self'), :scope('lexical') ) ); + } - $past := PAST::Var.new( - :name( $sigil ~ $name ), - :node($/) + # ...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') ) ); - 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> ); - } - } - } - } - - # If we have the ? sigil, lexical scope. - if $twigil eq '?' { - $past.scope('lexical'); - } - - $past.viviself(container_type($sigil)); + $var<vardecl> := $vardecl; } } - make $past; + elsif $key eq 'special_variable' { + $var := $( $<special_variable> ); + } + make $var; +} + + +method special_variable($/) { + make PAST::Var.new( :node($/), :name(~$/), :scope('lexical') ); } @@ -2689,6 +1797,40 @@ } +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 || 'package'), + ); + + make $past; +} + + +method fulltypename($/) { + make $( $<typename> ); +} + + method number($/, $key) { make $( $/{$key} ); } @@ -2834,36 +1976,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 +2048,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 { @@ -3158,8 +2258,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 +2344,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,77 +2428,24 @@ } -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' - ); - } - } - } - 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' - ); +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; } } } - else { - $/.panic('Illegal or unimplemented use of handles'); - } - - $past + $readtype; } @@ -3451,150 +2510,6 @@ } -# 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; @@ -3742,6 +2657,19 @@ } +# Adds an empty signature to a routine if it is missing one. +sub create_signature_if_none($block) { + unless $block<signature> { + my $sigobj := PAST::Var.new( :scope('register') ); + $block.loadinit().push( + PAST::Op.new( :inline(' %0 = new "Signature"', + ' setprop block, "$!signature", %0'), + $sigobj) + ); + } +} + + # Local Variables: # mode: cperl # cperl-indent-level: 4 Modified: branches/rvar2/languages/perl6/src/parser/grammar.pg ============================================================================== --- branches/rvar2/languages/perl6/src/parser/grammar.pg (original) +++ branches/rvar2/languages/perl6/src/parser/grammar.pg Wed Jan 7 09:13:27 2009 @@ -355,46 +355,61 @@ #### 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> ]* + ] <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 +422,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 +458,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 +491,6 @@ '=' <EXPR: 'i='> } -token param_var { - <sigil> <twigil>? <identifier> - {*} -} - - -#### Special variables #### - -token special_variable { - $<sym>=[ '$/' | '$!' | '$¢' ] <!before \w> {*} -} #### Terms #### @@ -545,15 +553,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 +605,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 +631,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 +715,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,17 +812,6 @@ {*} } -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 { @@ -875,14 +872,6 @@ ] } -token desigilname { - [ - | <?before '$' > <variable> - | <name> - ] - {*} -} - #### expressions and operators #### ## The EXPR rule is our entry point into the operator Modified: branches/rvar2/languages/perl6/src/pmc/objectref_pmc.template ============================================================================== --- branches/rvar2/languages/perl6/src/pmc/objectref_pmc.template (original) +++ branches/rvar2/languages/perl6/src/pmc/objectref_pmc.template Wed Jan 7 09:13:27 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: branches/rvar2/languages/perl6/t/00-parrot/05-var.t ============================================================================== --- branches/rvar2/languages/perl6/t/00-parrot/05-var.t (original) +++ branches/rvar2/languages/perl6/t/00-parrot/05-var.t Wed Jan 7 09:13:27 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: branches/rvar2/languages/perl6/t/00-parrot/08-regex.t ============================================================================== --- branches/rvar2/languages/perl6/t/00-parrot/08-regex.t (original) +++ branches/rvar2/languages/perl6/t/00-parrot/08-regex.t Wed Jan 7 09:13:27 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: branches/rvar2/languages/perl6/t/pmc/objectref.t ============================================================================== --- branches/rvar2/languages/perl6/t/pmc/objectref.t (original) +++ branches/rvar2/languages/perl6/t/pmc/objectref.t Wed Jan 7 09:13:27 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: branches/rvar2/src/pmc/class.pmc ============================================================================== --- branches/rvar2/src/pmc/class.pmc (original) +++ branches/rvar2/src/pmc/class.pmc Wed Jan 7 09:13:27 2009 @@ -923,8 +923,21 @@ Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, "Unknown introspection value '%S'", what); - /* Clone and return. */ - return PMC_IS_NULL(found) ? PMCNULL : VTABLE_clone(interp, found); + /* return found value */ + if (PMC_IS_NULL(found)) { return PMCNULL; } + if (found->vtable->base_type == enum_class_Hash) { + /* for Hash return values, create and return a shallow + * clone because the VTABLE_clone does a deep clone */ + PMC * const hash = pmc_new(interp, enum_class_Hash); + PMC * const iter = VTABLE_get_iter(interp, found); + while (VTABLE_get_bool(interp, iter)) { + STRING * key = VTABLE_shift_string(interp, iter); + PMC * value = VTABLE_get_pmc_keyed_str(interp, found, key); + VTABLE_set_pmc_keyed_str(interp, hash, key, value); + } + return hash; + } + return VTABLE_clone(interp, found); } /*

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