null.pmc000644000765000765 506112356767111 14522 0ustar00bruce000000000000parrot-6.6.0/src/pmc/* Copyright (C) 2001-2014, Parrot Foundation. =head1 NAME src/pmc/null.pmc - Null PMC =head1 DESCRIPTION This singleton simply creates a way of catching C register accesses without really slowing down the bytecode execution. =cut */ /* HEADERIZER HFILE: none */ /* HEADERIZER BEGIN: static */ /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */ PARROT_DOES_NOT_RETURN static void null_pmc_access(PARROT_INTERP, int index) __attribute__nonnull__(1); #define ASSERT_ARGS_null_pmc_access __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp)) /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */ /* HEADERIZER END: static */ pmclass Null singleton { /* =head2 Vtable functions =over 4 =item C Overrides the default to do nothing. =cut */ VTABLE void init() :no_wb { UNUSED(INTERP) UNUSED(SELF) } VTABLE void *get_pointer() :no_wb { UNUSED(INTERP) UNUSED(SELF) return PMCNULL; } VTABLE void set_pointer(void *p) :no_wb { UNUSED(INTERP) UNUSED(SELF) PMCNULL = (PMC *)p; } VTABLE INTVAL does(STRING *what) :no_wb { UNUSED(INTERP) UNUSED(SELF) UNUSED(what) /* XXX maybe a hack to get TGE running again */ return 0; } /* =item C Returns true if value is also a null PMC, false otherwise. =cut */ VTABLE INTVAL is_same(PMC *value) :no_wb { UNUSED(INTERP) UNUSED(SELF) return PMC_IS_NULL(value); } /* =item C Gives a more informative message than the automaticaly generated version. =cut */ VTABLE PMC *find_method(STRING *method_name) :no_wb { UNUSED(SELF) Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_NULL_REG_ACCESS, "Null PMC access in find_method('%Ss')", method_name); } } /* =back =head2 Auxiliary functions =over 4 =item C Throws the Null PMC access exception. =cut */ PARROT_DOES_NOT_RETURN static void null_pmc_access(PARROT_INTERP, int index) { ASSERT_ARGS(null_pmc_access) Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_NULL_REG_ACCESS, "Null PMC access in %s()", Parrot_get_vtable_name(interp, index)); } /* =back =cut */ /* * Local variables: * c-file-style: "parrot" * End: * vim: expandtab shiftwidth=4 cinoptions='\:2=2' : */ NoneGrammar.tg000644000765000765 150611466337263 17264 0ustar00bruce000000000000parrot-6.6.0/t/compilers/tge# This file is currently not used. # It was saved from the deleted directory 't/compilers/past-pm' grammar NoneGrammar is TGE::Grammar; transform past (ROOT) :language('PIR') { .local pmc past past = new 'PAST::Block' .local pmc op, childpast op = node['op'] childpast = tree.'get'('past', op, 'op') past.'push'(childpast) .return (past) } transform past (op) :language('PIR') { .local pmc past past = new 'PAST::Op' past.'init'('name'=>'test', 'pirop'=>'say') .local pmc val, childpast val = node['val'] childpast = tree.'get'('past', val, 'val') past.'push'(childpast) .return (past) } transform past (val) :language('PIR') { .local pmc past $S0 = node past = new 'PAST::Val' past.'init'('vtype'=>'.String', 'name'=>$S0, 'ctype'=>'s~') .return (past) } auto.pm000644000765000765 232312101554066 16471 0ustar00bruce000000000000parrot-6.6.0/config/auto/cpu/i386# Copyright (C) 2001-2013, Parrot Foundation. =head1 NAME config/auto/cpu/i386/auto.pm =head1 DESCRIPTION Test for cmpxchg ASM functionality. Creates these Config entries i386_has_gcc_cmpxchg_c => 1 =cut package auto::cpu::i386::auto; use strict; use warnings; sub runstep { my ( $self, $conf ) = @_; my @files = qw( test_gcc_cmpxchg_c.in ); for my $f (@files) { $conf->debug(" $f "); my ($suffix) = $f =~ /test_(\w+)/; my $path_f = "config/auto/cpu/i386/$f"; $conf->cc_gen($path_f); eval { $conf->cc_build("-DPARROT_CONFIG_TEST") }; if ($@) { $conf->debug(" $@ "); } else { if ( $conf->cc_run() =~ /ok/ ) { _handle_cc_run_ok($conf, $suffix, $path_f); $conf->add_to_generated( $path_f, "[]" ); } } $conf->cc_clean(); } return; } sub _handle_cc_run_ok { my ($conf, $suffix, $path_f) = @_; $conf->data->set( "i386_has_$suffix" => '1', "HAS_i386_$suffix" => '1', ); $conf->debug(" (\U$suffix) "); } 1; # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: chameneos.pir000644000765000765 2105312135343346 17441 0ustar00bruce000000000000parrot-6.6.0/examples/threads#!./parrot # Copyright (C) 2012-2013, Parrot Foundation. =head1 NAME examples/threads/chameneos.pir - Example peer-to-peer multi-core cooperation algorithm =head1 SYNOPSIS % time ./parrot examples/threads/chameneos.pir =head1 DESCRIPTION This is a Parrot example implementation of a P2P (peer-to-peer) cooperation algorithm used in the threads test in the alioth shootout benchmark game L It uses Task PMCs to implement an algorithm that can utilize multiple cores with non-blocking GC. It is also a good example how to use semaphores with parrot threads. =head1 REFERENCES [0] "Chameneos, a Concurrency Game for Java, Ada and Others" L =cut .sub 'main' :main .local pmc colors, start_colors, at_most_two, at_most_two_waiters, mutex, sem_priv, first_call, a_color, b_color, chameneos, chameneo, code, data, number, color, dummy, count .local int i dummy = new ['Continuation'] # workaround, see TODO in Proxy instantiate count = new 'Integer' count = 0 set_global 'count', count colors = new ['ResizableStringArray'] colors = 3 colors[0] = 'Blue' colors[1] = 'Red' colors[2] = 'Yellow' start_colors = new ['ResizableIntegerArray'] start_colors = 4 start_colors[0] = 2 start_colors[1] = 0 start_colors[2] = 1 start_colors[3] = 0 # init cooperation at_most_two_waiters = new ['ResizablePMCArray'] at_most_two = new ['Integer'] at_most_two = 2 mutex = new ['Integer'] mutex = 1 sem_priv = new ['Integer'] sem_priv = 0 first_call = new ['Integer'] first_call = 1 a_color = new ['Integer'] a_color = -1 b_color = new ['Integer'] b_color = -1 code = get_global 'chameneos_code' chameneos = new ['ResizablePMCArray'] chameneos = 4 i = 0 init_chameneos: chameneo = new ['Task'] chameneos[i] = chameneo data = new ['FixedPMCArray'] data = 2 number = new ['Integer'] number = i data[0] = number color = new ['Integer'] color = start_colors[i] data[1] = color setattribute chameneo, 'code', code setattribute chameneo, 'data', data push chameneo, b_color push chameneo, a_color push chameneo, first_call push chameneo, at_most_two push chameneo, at_most_two_waiters push chameneo, mutex push chameneo, sem_priv push chameneo, colors schedule chameneo inc i if i < 4 goto init_chameneos say "going to sleep" sleep 10 say "woke up just in time for exit" say count exit 0 .end .sub chameneos_code .param pmc data .local pmc interp, task, number, color, colors, at_most_two, at_most_two_waiters, mutex, sem_priv, cooperation, first_call, a_color, b_color, other_color .local int old_color, other_color_int, color_int .local string color_name interp = getinterp task = interp.'current_task'() colors = pop task sem_priv = pop task mutex = pop task at_most_two_waiters = pop task at_most_two = pop task first_call = pop task a_color = pop task b_color = pop task number = data[0] color = data[1] color_int = color color = new ['Integer'] color = color_int cooperation = get_global 'cooperation' start: color_name = colors[color] #print 'This is ' #print number #print " and I'm " #say color_name other_color = cooperation(number, color, sem_priv, mutex, at_most_two, at_most_two_waiters, first_call, a_color, b_color) other_color_int = other_color color_int = color if color_int == other_color_int goto start color_int = 3 - color_int color_int = color_int - other_color_int color = color_int goto start .end .sub cooperation .param pmc id .param pmc color .param pmc sem_priv .param pmc mutex .param pmc at_most_two .param pmc at_most_two_waiters .param pmc first_call .param pmc a_color .param pmc b_color .local pmc interp, sem_wait, sem_unlock, call_core, call_task .local int other_color interp = getinterp sem_wait = get_global 'sem_wait' sem_unlock = get_global 'sem_unlock' call_task = new ['Task'] setattribute call_task, 'data', color push call_task, b_color push call_task, a_color sem_wait(mutex) if a_color > -1 goto second call_core = get_global 'first_call_core' setattribute call_task, 'code', call_core interp.'schedule_proxied'(call_task, a_color) wait call_task sem_unlock(mutex) sem_wait(sem_priv) other_color = b_color sem_unlock(mutex) goto done second: other_color = a_color call_core = get_global 'second_call_core' setattribute call_task, 'code', call_core interp.'schedule_proxied'(call_task, b_color) wait call_task sem_unlock(sem_priv) done: .return(other_color) .end .sub first_call_core .param pmc data .local pmc interp, task, a_color, b_color .local int a_color_int interp = getinterp task = interp.'current_task'() a_color = pop task b_color = pop task a_color_int = data a_color = a_color_int b_color = -1 .end .sub second_call_core .param pmc data .local pmc interp, task, b_color, a_color, count .local int b_color_int interp = getinterp task = interp.'current_task'() a_color = pop task b_color = pop task b_color_int = data b_color = b_color_int a_color = -1 count = get_global 'count' inc count #say count .end .sub sem_unlock .param pmc sem .local pmc interp, sem_unlock_task, sem_unlock_core interp = getinterp sem_unlock_core = get_global 'sem_unlock_core' sem_unlock_task = new ['Task'] setattribute sem_unlock_task, 'code', sem_unlock_core setattribute sem_unlock_task, 'data', sem interp.'schedule_proxied'(sem_unlock_task, sem) .end .sub sem_wait .param pmc sem .local pmc interp, waiter, sem_wait_task, sem_wait_core interp = getinterp sem_wait_core = get_global 'sem_wait_core' sem_wait_task = new ['Task'] setattribute sem_wait_task, 'code', sem_wait_core setattribute sem_wait_task, 'data', sem interp.'schedule_proxied'(sem_wait_task, sem) wait sem_wait_task returncc .end .sub sem_wait_core .param pmc data .local pmc sem sem = data test: disable_preemption if sem > 0 goto lock enable_preemption pass goto test lock: dec sem enable_preemption .end .sub sem_unlock_core .param pmc data .local pmc sem sem = data inc sem .end .sub sem_ackquire .param pmc sem .param pmc sem_waiters .local pmc interp, waiter, sem_wait_task, sem_ackquire_core interp = getinterp sem_ackquire_core = get_global 'sem_ackquire_core' sem_wait_task = new ['Task'] setattribute sem_wait_task, 'code', sem_ackquire_core setattribute sem_wait_task, 'data', sem push sem_wait_task, sem_waiters interp.'schedule_proxied'(sem_wait_task, sem) wait sem_wait_task returncc .end .sub sem_ackquire_core .param pmc data .local pmc sem, sem_waiters, interp, task, cont interp = getinterp task = interp.'current_task'() sem_waiters = pop task disable_preemption sem = data if sem > 0 goto lock cont = new ['Continuation'] set_label cont, lock setattribute task, 'code', cont push sem_waiters, task enable_preemption terminate lock: dec sem enable_preemption .end .sub sem_release .param pmc sem .param pmc sem_waiters .local pmc interp, sem_release_task, sem_release_core interp = getinterp sem_release_core = get_global 'sem_release_core' sem_release_task = new ['Task'] setattribute sem_release_task, 'code', sem_release_core setattribute sem_release_task, 'data', sem push sem_release_task, sem_waiters interp.'schedule_proxied'(sem_release_task, sem) .end .sub sem_release_core .param pmc data .local pmc sem, sem_waiters, interp, task, waiter .local int waiters_count interp = getinterp task = interp.'current_task'() sem_waiters = pop task disable_preemption sem = data inc sem waiters_count = sem_waiters if waiters_count <= 0 goto done waiter = pop sem_waiters schedule_local waiter done: enable_preemption .end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: fasta.pir_output000644000765000765 2400511466337261 20454 0ustar00bruce000000000000parrot-6.6.0/examples/shootout>ONE Homo sapiens alu GGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGA TCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACT AAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAG GCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCG CCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGT GGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCA GGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAA TTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAG AATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCA GCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGT AATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACC AGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTG GTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACC CGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAG AGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTT TGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACA TGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCT GTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGG TTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGT CTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGG CGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCG TCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTA CTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCG AGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCG GGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACC TGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAA TACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGA GGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACT GCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTC ACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGT TCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGC CGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCG CTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTG GGCGACAGAGCGAGACTCCG >TWO IUB ambiguity codes cttBtatcatatgctaKggNcataaaSatgtaaaDcDRtBggDtctttataattcBgtcg tactDtDagcctatttSVHtHttKtgtHMaSattgWaHKHttttagacatWatgtRgaaa NtactMcSMtYtcMgRtacttctWBacgaaatatagScDtttgaagacacatagtVgYgt cattHWtMMWcStgttaggKtSgaYaaccWStcgBttgcgaMttBYatcWtgacaYcaga gtaBDtRacttttcWatMttDBcatWtatcttactaBgaYtcttgttttttttYaaScYa HgtgttNtSatcMtcVaaaStccRcctDaataataStcYtRDSaMtDttgttSagtRRca tttHatSttMtWgtcgtatSSagactYaaattcaMtWatttaSgYttaRgKaRtccactt tattRggaMcDaWaWagttttgacatgttctacaaaRaatataataaMttcgDacgaSSt acaStYRctVaNMtMgtaggcKatcttttattaaaaagVWaHKYagtttttatttaacct tacgtVtcVaattVMBcttaMtttaStgacttagattWWacVtgWYagWVRctDattBYt gtttaagaagattattgacVatMaacattVctgtBSgaVtgWWggaKHaatKWcBScSWa accRVacacaaactaccScattRatatKVtactatatttHttaagtttSKtRtacaaagt RDttcaaaaWgcacatWaDgtDKacgaacaattacaRNWaatHtttStgttattaaMtgt tgDcgtMgcatBtgcttcgcgaDWgagctgcgaggggVtaaScNatttacttaatgacag cccccacatYScaMgtaggtYaNgttctgaMaacNaMRaacaaacaKctacatagYWctg ttWaaataaaataRattagHacacaagcgKatacBttRttaagtatttccgatctHSaat actcNttMaagtattMtgRtgaMgcataatHcMtaBSaRattagttgatHtMttaaKagg YtaaBataSaVatactWtataVWgKgttaaaacagtgcgRatatacatVtHRtVYataSa KtWaStVcNKHKttactatccctcatgWHatWaRcttactaggatctataDtDHBttata aaaHgtacVtagaYttYaKcctattcttcttaataNDaaggaaaDYgcggctaaWSctBa aNtgctggMBaKctaMVKagBaactaWaDaMaccYVtNtaHtVWtKgRtcaaNtYaNacg gtttNattgVtttctgtBaWgtaattcaagtcaVWtactNggattctttaYtaaagccgc tcttagHVggaYtgtNcDaVagctctctKgacgtatagYcctRYHDtgBattDaaDgccK tcHaaStttMcctagtattgcRgWBaVatHaaaataYtgtttagMDMRtaataaggatMt ttctWgtNtgtgaaaaMaatatRtttMtDgHHtgtcattttcWattRSHcVagaagtacg ggtaKVattKYagactNaatgtttgKMMgYNtcccgSKttctaStatatNVataYHgtNa BKRgNacaactgatttcctttaNcgatttctctataScaHtataRagtcRVttacDSDtt aRtSatacHgtSKacYagttMHtWataggatgactNtatSaNctataVtttRNKtgRacc tttYtatgttactttttcctttaaacatacaHactMacacggtWataMtBVacRaSaatc cgtaBVttccagccBcttaRKtgtgcctttttRtgtcagcRttKtaaacKtaaatctcac aattgcaNtSBaaccgggttattaaBcKatDagttactcttcattVtttHaaggctKKga tacatcBggScagtVcacattttgaHaDSgHatRMaHWggtatatRgccDttcgtatcga aacaHtaagttaRatgaVacttagattVKtaaYttaaatcaNatccRttRRaMScNaaaD gttVHWgtcHaaHgacVaWtgttScactaagSgttatcttagggDtaccagWattWtRtg ttHWHacgattBtgVcaYatcggttgagKcWtKKcaVtgaYgWctgYggVctgtHgaNcV taBtWaaYatcDRaaRtSctgaHaYRttagatMatgcatttNattaDttaattgttctaa ccctcccctagaWBtttHtBccttagaVaatMcBHagaVcWcagBVttcBtaYMccagat gaaaaHctctaacgttagNWRtcggattNatcRaNHttcagtKttttgWatWttcSaNgg gaWtactKKMaacatKatacNattgctWtatctaVgagctatgtRaHtYcWcttagccaa tYttWttaWSSttaHcaaaaagVacVgtaVaRMgattaVcDactttcHHggHRtgNcctt tYatcatKgctcctctatVcaaaaKaaaagtatatctgMtWtaaaacaStttMtcgactt taSatcgDataaactaaacaagtaaVctaggaSccaatMVtaaSKNVattttgHccatca cBVctgcaVatVttRtactgtVcaattHgtaaattaaattttYtatattaaRSgYtgBag aHSBDgtagcacRHtYcBgtcacttacactaYcgctWtattgSHtSatcataaatataHt cgtYaaMNgBaatttaRgaMaatatttBtttaaaHHKaatctgatWatYaacttMctctt ttVctagctDaaagtaVaKaKRtaacBgtatccaaccactHHaagaagaaggaNaaatBW attccgStaMSaMatBttgcatgRSacgttVVtaaDMtcSgVatWcaSatcttttVatag ttactttacgatcaccNtaDVgSRcgVcgtgaacgaNtaNatatagtHtMgtHcMtagaa attBgtataRaaaacaYKgtRccYtatgaagtaataKgtaaMttgaaRVatgcagaKStc tHNaaatctBBtcttaYaBWHgtVtgacagcaRcataWctcaBcYacYgatDgtDHccta >THREE Homo sapiens frequency aacacttcaccaggtatcgtgaaggctcaagattacccagagaacctttgcaatataaga atatgtatgcagcattaccctaagtaattatattctttttctgactcaaagtgacaagcc ctagtgtatattaaatcggtatatttgggaaattcctcaaactatcctaatcaggtagcc atgaaagtgatcaaaaaagttcgtacttataccatacatgaattctggccaagtaaaaaa tagattgcgcaaaattcgtaccttaagtctctcgccaagatattaggatcctattactca tatcgtgtttttctttattgccgccatccccggagtatctcacccatccttctcttaaag gcctaatattacctatgcaaataaacatatattgttgaaaattgagaacctgatcgtgat tcttatgtgtaccatatgtatagtaatcacgcgactatatagtgctttagtatcgcccgt gggtgagtgaatattctgggctagcgtgagatagtttcttgtcctaatatttttcagatc gaatagcttctatttttgtgtttattgacatatgtcgaaactccttactcagtgaaagtc atgaccagatccacgaacaatcttcggaatcagtctcgttttacggcggaatcttgagtc taacttatatcccgtcgcttactttctaacaccccttatgtatttttaaaattacgttta ttcgaacgtacttggcggaagcgttattttttgaagtaagttacattgggcagactcttg acattttcgatacgactttctttcatccatcacaggactcgttcgtattgatatcagaag ctcgtgatgattagttgtcttctttaccaatactttgaggcctattctgcgaaatttttg ttgccctgcgaacttcacataccaaggaacacctcgcaacatgccttcatatccatcgtt cattgtaattcttacacaatgaatcctaagtaattacatccctgcgtaaaagatggtagg ggcactgaggatatattaccaagcatttagttatgagtaatcagcaatgtttcttgtatt aagttctctaaaatagttacatcgtaatgttatctcgggttccgcgaataaacgagatag attcattatatatggccctaagcaaaaacctcctcgtattctgttggtaattagaatcac acaatacgggttgagatattaattatttgtagtacgaagagatataaaaagatgaacaat tactcaagtcaagatgtatacgggatttataataaaaatcgggtagagatctgctttgca attcagacgtgccactaaatcgtaatatgtcgcgttacatcagaaagggtaactattatt aattaataaagggcttaatcactacatattagatcttatccgatagtcttatctattcgt tgtatttttaagcggttctaattcagtcattatatcagtgctccgagttctttattattg ttttaaggatgacaaaatgcctcttgttataacgctgggagaagcagactaagagtcgga gcagttggtagaatgaggctgcaaaagacggtctcgacgaatggacagactttactaaac caatgaaagacagaagtagagcaaagtctgaagtggtatcagcttaattatgacaaccct taatacttccctttcgccgaatactggcgtggaaaggttttaaaagtcgaagtagttaga ggcatctctcgctcataaataggtagactactcgcaatccaatgtgactatgtaatactg ggaacatcagtccgcgatgcagcgtgtttatcaaccgtccccactcgcctggggagacat gagaccacccccgtggggattattagtccgcagtaatcgactcttgacaatccttttcga ttatgtcatagcaatttacgacagttcagcgaagtgactactcggcgaaatggtattact aaagcattcgaacccacatgaatgtgattcttggcaatttctaatccactaaagcttttc cgttgaatctggttgtagatatttatataagttcactaattaagatcacggtagtatatt gatagtgatgtctttgcaagaggttggccgaggaatttacggattctctattgatacaat ttgtctggcttataactcttaaggctgaaccaggcgtttttagacgacttgatcagctgt tagaatggtttggactccctctttcatgtcagtaacatttcagccgttattgttacgata tgcttgaacaatattgatctaccacacacccatagtatattttataggtcatgctgttac ctacgagcatggtattccacttcccattcaatgagtattcaacatcactagcctcagaga tgatgacccacctctaataacgtcacgttgcggccatgtgaaacctgaacttgagtagac gatatcaagcgctttaaattgcatataacatttgagggtaaagctaagcggatgctttat ataatcaatactcaataataagatttgattgcattttagagttatgacacgacatagttc actaacgagttactattcccagatctagactgaagtactgatcgagacgatccttacgtc gatgatcgttagttatcgacttaggtcgggtctctagcggtattggtacttaaccggaca ctatactaataacccatgatcaaagcataacagaatacagacgataatttcgccaacata tatgtacagaccccaagcatgagaagctcattgaaagctatcattgaagtcccgctcaca atgtgtcttttccagacggtttaactggttcccgggagtcctggagtttcgacttacata aatggaaacaatgtattttgctaatttatctatagcgtcatttggaccaatacagaatat tatgttgcctagtaatccactataacccgcaagtgctgatagaaaatttttagacgattt ataaatgccccaagtatccctcccgtgaatcctccgttatactaattagtattcgttcat acgtataccgcgcatatatgaacatttggcgataaggcgcgtgaattgttacgtgacaga gatagcagtttcttgtgatatggttaacagacgtacatgaagggaaactttatatctata gtgatgcttccgtagaaataccgccactggtctgccaatgatgaagtatgtagctttagg tttgtactatgaggctttcgtttgtttgcagagtataacagttgcgagtgaaaaaccgac gaatttatactaatacgctttcactattggctacaaaatagggaagagtttcaatcatga gagggagtatatggatgctttgtagctaaaggtagaacgtatgtatatgctgccgttcat tcttgaaagatacataagcgataagttacgacaattataagcaacatccctaccttcgta acgatttcactgttactgcgcttgaaatacactatggggctattggcggagagaagcaga tcgcgccgagcatatacgagacctataatgttgatgatagagaaggcgtctgaattgata catcgaagtacactttctttcgtagtatctctcgtcctctttctatctccggacacaaga attaagttatatatatagagtcttaccaatcatgttgaatcctgattctcagagttcttt ggcgggccttgtgatgactgagaaacaatgcaatattgctccaaatttcctaagcaaatt ctcggttatgttatgttatcagcaaagcgttacgttatgttatttaaatctggaatgacg gagcgaagttcttatgtcggtgtgggaataattcttttgaagacagcactccttaaataa tatcgctccgtgtttgtatttatcgaatgggtctgtaaccttgcacaagcaaatcggtgg tgtatatatcggataacaattaatacgatgttcatagtgacagtatactgatcgagtcct ctaaagtcaattacctcacttaacaatctcattgatgttgtgtcattcccggtatcgccc gtagtatgtgctctgattgaccgagtgtgaaccaaggaacatctactaatgcctttgtta ggtaagatctctctgaattccttcgtgccaacttaaaacattatcaaaatttcttctact tggattaactacttttacgagcatggcaaattcccctgtggaagacggttcattattatc ggaaaccttatagaaattgcgtgttgactgaaattagatttttattgtaagagttgcatc tttgcgattcctctggtctagcttccaatgaacagtcctcccttctattcgacatcgggt ccttcgtacatgtctttgcgatgtaataattaggttcggagtgtggccttaatgggtgca actaggaatacaacgcaaatttgctgacatgatagcaaatcggtatgccggcaccaaaac gtgctccttgcttagcttgtgaatgagactcagtagttaaataaatccatatctgcaatc gattccacaggtattgtccactatctttgaactactctaagagatacaagcttagctgag accgaggtgtatatgactacgctgatatctgtaaggtaccaatgcaggcaaagtatgcga gaagctaataccggctgtttccagctttataagattaaaatttggctgtcctggcggcct cagaattgttctatcgtaatcagttggttcattaattagctaagtacgaggtacaactta tctgtcccagaacagctccacaagtttttttacagccgaaacccctgtgtgaatcttaat atccaagcgcgttatctgattagagtttacaactcagtattttatcagtacgttttgttt ccaacattacccggtatgacaaaatgacgccacgtgtcgaataatggtctgaccaatgta ggaagtgaaaagataaatat Sprite.pir000644000765000765 3007611533177636 20572 0ustar00bruce000000000000parrot-6.6.0/runtime/parrot/library/SDL =head1 NAME SDL::Sprite - Parrot class representing sprites in Parrot SDL =head1 SYNOPSIS # load this library load_bytecode 'SDL/Sprite.pir' # ... load a new SDL::Image into image # create a new SDL::Sprite object .local pmc sprite sprite = new ['SDL'; 'Sprite'] # set the sprite's arguments sprite.'init'( 'surface' => image, 'source_x' => 0, 'source_y' => 0, 'dest_x' => 270, 'dest_y' => 212, 'bgcolor' => black ) # if the image has multiple tiles that represent animation frames, set the # width and height of each tile # 'width' => 100, 'height' => 56 # ... draw the sprite to surfaces as you will =head1 DESCRIPTION A SDL::Sprite object represents an image and its position. By changing the coordinates of the sprite, you'll change its position when it draws itself to a surface. This is a class in progress; it has to represent several different drawing styles. =head1 METHODS A SDL::Sprite object has the following methods: =over 4 =cut .namespace [ 'SDL'; 'Sprite' ] .sub _initialize :load .local pmc sprite_class newclass sprite_class, ['SDL'; 'Sprite'] addattribute sprite_class, 'surface' addattribute sprite_class, 'source_rect' addattribute sprite_class, 'prev_rect' addattribute sprite_class, 'rect' addattribute sprite_class, 'bgcolor' addattribute sprite_class, 'drawn_rect' addattribute sprite_class, 'undrawn_rect' addattribute sprite_class, 'x_velocity' addattribute sprite_class, 'y_velocity' .end =item init( 'arg' => pairs ) Given argument key-value pairs, sets the attributes of this object. The useful keys are as follows: =over 4 =item surface The SDL::Image from which to draw the sprite frames. =item source_x The x coordinate within the C from which to start drawing. =item source_y The y coordinate within the C from which to start drawing. =item dest_x The x coordinate within the destination surface to which to draw. =item dest_y The y coordinate within the destination surface to which to draw. =item bgcolor A SDL::Color object representing the background color of the main surface. This will come in handy when drawing over the previous position of this sprite, unless you redraw the entire surface on every frame. =item width The width of the image, in pixels, to draw. If you have multiple frames of an animation within the image provided, set the width here to the width of a single frame. If you don't set this value, this will use the current width of the image. =item height The height of the image, in pixels, to draw. If you have multiple frames of an animation within the image provided, set the height here to the height of a single frame. If you don't set this value, this will use the current height of the image. =back B I'm not completely thrilled with these arguments, so they may change slightly. =cut .sub 'init' :method .param pmc surface :named( 'surface' ) .param pmc source_x :named( 'source_x' ) .param pmc source_y :named( 'source_y' ) .param pmc dest_x :named( 'dest_x' ) .param pmc dest_y :named( 'dest_y' ) .param pmc bgcolor :named( 'bgcolor' ) .param pmc width :named( 'width' ) :optional .param int has_width :opt_flag .param pmc height :named( 'height' ) :optional .param int has_height :opt_flag setattribute self, 'surface', surface # set all of the rect attributes if has_width goto set_height width = surface.'width'() set_height: if has_height goto done height = surface.'height'() done: # first the source rectangle .local pmc source_rect source_rect = new ['SDL'; 'Rect'] source_rect.'init'( 'x' => source_x, 'y' => source_y, 'height' => height, 'width' => width ) setattribute self, 'source_rect', source_rect # now the dest rectangle .local pmc rect rect = new ['SDL'; 'Rect'] rect.'init'( 'x' => dest_x, 'y' => dest_y ) setattribute self, 'rect', rect rect = self.'rect'() # and now the previous rect .local pmc prev_rect prev_rect = new ['SDL'; 'Rect'] prev_rect.'init'( 'x' => source_x, 'y' => source_y, 'height' => height, 'width' => width ) setattribute self, 'prev_rect', prev_rect # the background color .local pmc bgcolor_pmc bgcolor_pmc = bgcolor setattribute self, 'bgcolor', bgcolor_pmc # the drawn rect .local pmc drawn_rect drawn_rect = new ['SDL'; 'Rect'] drawn_rect.'init'( 'x' => source_x, 'y' => source_y, 'height' => height, 'width' => width ) setattribute self, 'drawn_rect', drawn_rect # the undrawn rect .local pmc undrawn_rect undrawn_rect = new ['SDL'; 'Rect'] undrawn_rect.'init'( 'x' => source_x, 'y' => source_y, 'height' => height, 'width' => width ) setattribute self, 'undrawn_rect', undrawn_rect # and finally the x and y velocities .local pmc x_velocity x_velocity = new 'Integer' x_velocity = 0 setattribute self, 'x_velocity', x_velocity .local pmc y_velocity y_velocity = new 'Integer' y_velocity = 0 setattribute self, 'y_velocity', y_velocity .return() .end =item draw_undraw( surface ) Draws the image this object represents to the given SDL::Surface. This will return two SDL::Rect objects, one representing the previous position of this sprite and one representing the current position. Use this when dealing with a single-buffered main window. You'll need to call C on the C to make things actually show up, if it's the main surface. Note that this will fill in the previous position with the background color set in the constructor. =cut .sub draw_undraw :method .param pmc dest_surface .local pmc surface .local pmc source_rect .local pmc rect .local pmc prev_rect .local pmc bgcolor .local pmc drawn_rect .local pmc undrawn_rect surface = self.'surface'() source_rect = self.'source_rect'() rect = self.'rect'() prev_rect = self.'prev_rect'() bgcolor = self.'bgcolor'() drawn_rect = self.'drawn_rect'() undrawn_rect = self.'undrawn_rect'() dest_surface.'fill_rect'( prev_rect, bgcolor ) dest_surface.'blit'( surface, source_rect, rect ) .local int x .local int y x = prev_rect.'x'() y = prev_rect.'y'() undrawn_rect.'x'( x ) undrawn_rect.'y'( y ) x = rect.'x'() y = rect.'y'() drawn_rect.'x'( x ) drawn_rect.'y'( y ) prev_rect.'x'( x ) prev_rect.'y'( y ) .return( drawn_rect, undrawn_rect ) .end =item draw( surface ) Draws the image represented by this object to the given surface. This will also fill the previous position of the image with the background color. (Arguably, this is not always right, but I know about it and will figure something out, unless you have a better idea and let me know first.) Use this when dealing with a double-buffered main window. In that case, you will have to call C on the C yourself to make your changes appear. =cut .sub draw :method .param pmc dest_surface .local pmc surface .local pmc source_rect .local pmc rect .local pmc prev_rect .local pmc bgcolor surface = self.'surface'() source_rect = self.'source_rect'() rect = self.'rect'() prev_rect = self.'prev_rect'() bgcolor = self.'bgcolor'() dest_surface.'fill_rect'( prev_rect, bgcolor ) dest_surface.'blit'( surface, source_rect, rect ) .local int x .local int y x = rect.'x'() y = rect.'y'() prev_rect.'x'( x ) prev_rect.'y'( y ) .end =item surface() Returns the underlying surface of the image represented by this class. You should never need to call this directly, unless you're working with the raw SDL functions. =cut .sub surface :method .local pmc surface getattribute surface, self, 'surface' .return( surface ) .end =item source_rect() Returns the SDL::Rect object representing the source from which to draw within the underlying image. You should never need to call this directly. =cut .sub source_rect :method .local pmc source_rect getattribute source_rect, self, 'source_rect' .return( source_rect ) .end =item prev_rect() Returns the SDL::Rect representing the previous position of this sprite within a destination surface. You should never need to call this directly. =cut .sub prev_rect :method .local pmc prev_rect getattribute prev_rect, self, 'prev_rect' .return( prev_rect ) .end =item rect() Returns the SDL::Rect representing this sprite's current position within the destination surface. You should never need to call this directly. =cut .sub rect :method .local pmc rect getattribute rect, self, 'rect' .return( rect ) .end =item bgcolor() Returns the SDL::Color object representing the background color to draw to the destination when undrawing the previous position of this sprite. You should never need to call this directly. =cut .sub bgcolor :method .local pmc bgcolor getattribute bgcolor, self, 'bgcolor' .return( bgcolor ) .end =item drawn_rect() Returns the SDL::Rect representing the current position of the sprite within the destination surface as of the current drawing operation. You should I need to call this directly. I mean it. This may go away suddenly in a brilliant flash of insight. =cut .sub drawn_rect :method .local pmc drawn_rect getattribute drawn_rect, self, 'drawn_rect' .return( drawn_rect ) .end =item undrawn_rect() Returns the SDL::Rect representing the previous position of the sprite within the destination surface as of the current drawing operation. You should I need to call this directly. I mean it. This may go away suddenly in a brilliant flash of insight. =cut .sub undrawn_rect :method .local pmc undrawn_rect getattribute undrawn_rect, self, 'undrawn_rect' .return( undrawn_rect ) .end =item x( [ new_x_coordinate ] ) Gets and sets the x coordinate of this sprite within the destination surface, in pixels. This is always an integer. =cut .sub x :method .param int new_x :optional .param int have_x :opt_flag .local pmc rect rect = self.'rect'() if have_x == 0 goto getter rect.'x'( new_x ) getter: .local int result result = rect.'x'() .return( result ) .end =item y( [ new_y_coordinate ] ) Gets and sets the y coordinate of this sprite within the destination surface, in pixels. This is always an integer. =cut .sub y :method .param int new_y :optional .param int have_y :opt_flag .local pmc rect rect = self.'rect'() if have_y == 0 goto getter rect.'y'( new_y ) getter: .local int result result = rect.'y'() .return( result ) .end =item x_velocity( [ new_x_velocity ] ) Gets and sets the x velocity of this sprite. This is always an integer. Maybe this method shouldn't be here; it may move. =cut .sub x_velocity :method .param int new_x_vel :optional .param int have_x :opt_flag .local pmc x_vel getattribute x_vel, self, 'x_velocity' .local pmc rect if have_x == 0 goto getter x_vel = new_x_vel .return( new_x_vel ) getter: .local int result result = x_vel .return( result ) .end =item y_velocity( [ new_y_velocity ] ) Gets and sets the y velocity of this sprite. This is always an integer. Maybe this method shouldn't be here; it may move. =cut .sub y_velocity :method .param int new_y_vel :optional .param int have_y :opt_flag .local pmc y_vel getattribute y_vel, self, 'y_velocity' if have_y == 0 goto getter y_vel = new_y_vel .return( new_y_vel ) getter: .local int result result = y_vel .return( result ) .end =back =head1 AUTHOR Written and maintained by chromatic, Echromatic at wgz dot orgE, with suggestions from Jens Rieks. Please send patches, feedback, and suggestions to the Perl 6 Internals mailing list. =head1 COPYRIGHT Copyright (C) 2004-2008, Parrot Foundation. =cut # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: pbc.h000644000765000765 703112233541455 15320 0ustar00bruce000000000000parrot-6.6.0/compilers/imcc/* * Copyright (C) 2002-2009, Parrot Foundation. */ #ifndef PARROT_IMCC_PBC_H_GUARD #define PARROT_IMCC_PBC_H_GUARD /* HEADERIZER BEGIN: compilers/imcc/pbc.c */ /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */ void e_pbc_close(ARGMOD(imc_info_t * imcc), void *param) __attribute__nonnull__(1) FUNC_MODIFIES(* imcc); int e_pbc_emit( ARGMOD(imc_info_t * imcc), void *param, ARGIN(const IMC_Unit *unit), ARGIN(const Instruction *ins)) __attribute__nonnull__(1) __attribute__nonnull__(3) __attribute__nonnull__(4) FUNC_MODIFIES(* imcc); void e_pbc_end_sub( ARGMOD(imc_info_t * imcc), void *param, ARGIN(IMC_Unit *unit)) __attribute__nonnull__(1) __attribute__nonnull__(3) FUNC_MODIFIES(* imcc); void e_pbc_new_sub( ARGMOD(imc_info_t * imcc), void *param, ARGIN(IMC_Unit *unit)) __attribute__nonnull__(1) __attribute__nonnull__(3) FUNC_MODIFIES(* imcc); int e_pbc_open(ARGMOD(imc_info_t * imcc)) __attribute__nonnull__(1) FUNC_MODIFIES(* imcc); PARROT_WARN_UNUSED_RESULT INTVAL IMCC_int_from_reg(ARGMOD(imc_info_t * imcc), ARGIN(const SymReg *r)) __attribute__nonnull__(1) __attribute__nonnull__(2) FUNC_MODIFIES(* imcc); void imcc_pbc_add_libdep(ARGMOD(imc_info_t * imcc), ARGIN(STRING *libname)) __attribute__nonnull__(1) __attribute__nonnull__(2) FUNC_MODIFIES(* imcc); PARROT_WARN_UNUSED_RESULT PARROT_CANNOT_RETURN_NULL STRING * IMCC_string_from__STRINGC( ARGMOD(imc_info_t * imcc), ARGIN(char *buf)) __attribute__nonnull__(1) __attribute__nonnull__(2) FUNC_MODIFIES(* imcc); PARROT_WARN_UNUSED_RESULT PARROT_CANNOT_RETURN_NULL STRING * IMCC_string_from_reg( ARGMOD(imc_info_t * imcc), ARGIN(const SymReg *r)) __attribute__nonnull__(1) __attribute__nonnull__(2) FUNC_MODIFIES(* imcc); #define ASSERT_ARGS_e_pbc_close __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(imcc)) #define ASSERT_ARGS_e_pbc_emit __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(imcc) \ , PARROT_ASSERT_ARG(unit) \ , PARROT_ASSERT_ARG(ins)) #define ASSERT_ARGS_e_pbc_end_sub __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(imcc) \ , PARROT_ASSERT_ARG(unit)) #define ASSERT_ARGS_e_pbc_new_sub __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(imcc) \ , PARROT_ASSERT_ARG(unit)) #define ASSERT_ARGS_e_pbc_open __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(imcc)) #define ASSERT_ARGS_IMCC_int_from_reg __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(imcc) \ , PARROT_ASSERT_ARG(r)) #define ASSERT_ARGS_imcc_pbc_add_libdep __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(imcc) \ , PARROT_ASSERT_ARG(libname)) #define ASSERT_ARGS_IMCC_string_from__STRINGC __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(imcc) \ , PARROT_ASSERT_ARG(buf)) #define ASSERT_ARGS_IMCC_string_from_reg __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(imcc) \ , PARROT_ASSERT_ARG(r)) /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */ /* HEADERIZER END: compilers/imcc/pbc.c */ #endif /* PARROT_IMCC_PBC_H_GUARD */ /* * Local variables: * c-file-style: "parrot" * End: * vim: expandtab shiftwidth=4 cinoptions='\:2=2' : */ methods.t000644000765000765 467112101554067 14207 0ustar00bruce000000000000parrot-6.6.0/t/oo#!./parrot # Copyright (C) 2007-2012, Parrot Foundation. =head1 NAME t/oo/methods.t - Test OO methods =head1 SYNOPSIS % prove t/oo/methods.t =head1 DESCRIPTION Tests features related to the creation, addition, and execution of OO methods. =cut .const string library_file = "method_library.pir" .sub main :main .include 'test_more.pir' create_library() plan(6) loading_methods_from_file() loading_methods_from_eval() overridden_find_method() overridden_core_pmc() try_delete_library() .end .sub create_library .local pmc file file = new ['FileHandle'] file.'open'(library_file, 'w') $S0 = <<'END' .namespace['Foo'] .sub 'bar_method' :method .return (1) .end END print file, $S0 file.'close'() .end .sub try_delete_library .local pmc os os = new 'OS' os.'rm'(library_file) .return () .end .sub loading_methods_from_file $P0 = newclass 'Foo' $P1 = new 'Foo' $I0 = $P1.'foo_method'() ok ($I0, 'calling foo_method') load_bytecode library_file $P1 = new 'Foo' $I0 = $P1.'bar_method'() ok ($I0, 'calling bar_method') $P0 = null .end .namespace ['Foo'] .sub 'foo_method' :method .return (1) .end .namespace [] .sub loading_methods_from_eval $P0 = newclass 'Bar' $P1 = new 'Bar' $I0 = $P1.'foo_method'() ok ($I0, 'calling foo_method') $S2 = <<'END' .namespace ['Bar'] .sub 'bar_method' :method .return (1) .end END $P2 = compreg 'PIR' $P2($S2) $P1 = new 'Bar' $I0 = $P1.'bar_method'() ok ($I0, 'calling bar_method') .end .namespace ['Bar'] .sub 'foo_method' :method .return (1) .end .namespace [] .sub overridden_find_method $P0 = newclass 'Obj' $P2 = new 'Obj' $I0 = $P2.'some_method'(42) is ($I0, 42, 'calling overriden method') .end .namespace ['Obj'] .sub 'meth' :method .param pmc a .return (a) .end .sub 'find_method' :vtable :method .param string meth_name .const 'Sub' meth = 'meth' .return (meth) .end .namespace [] .sub 'overridden_core_pmc' .local string msg msg = "able to invoke overridden method on core PMC (TT #1596)" $P0 = new 'ResizablePMCArray' $I0 = $P0.'foo'() is($I0, 1, msg) .return() .end .namespace ['ResizablePMCArray'] .sub 'foo' :method .return(1) .end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: Defines.in000644000765000765 123512101554067 16167 0ustar00bruce000000000000parrot-6.6.0/src/dynoplibs# Copyright (C) 2010-2012, Parrot Foundation. DYNOPLIBS_TARGETS = \ $(DYNEXT_DIR)/obscure_ops$(LOAD_EXT) \ $(DYNEXT_DIR)/math_ops$(LOAD_EXT) \ $(DYNEXT_DIR)/trans_ops$(LOAD_EXT) \ $(DYNEXT_DIR)/bit_ops$(LOAD_EXT) \ $(DYNEXT_DIR)/debug_ops$(LOAD_EXT) \ $(DYNEXT_DIR)/sys_ops$(LOAD_EXT) \ $(DYNEXT_DIR)/io_ops$(LOAD_EXT) DYNOPLIBS_CLEANUPS = \ $(DYNOPLIBS_TARGETS) \ src/dynoplibs/*.c \ src/dynoplibs/*.h \ #IF(win32): src/dynoplibs/*.lib \ #IF(win32): src/dynoplibs/*.pdb \ #IF(win32): src/dynoplibs/*.ilk \ #IF(win32): src/dynoplibs/*.def \ #IF(win32): src/dynoplibs/*.manifest \ #IF(o): src/dynoplibs/*$(O) regression.t000644000765000765 213711533177643 17063 0ustar00bruce000000000000parrot-6.6.0/t/compilers/pge#! perl # Copyright (C) 2001-2009, Parrot Foundation. use strict; use warnings; use lib qw( t . lib ../lib ../../lib ); use Test::More; use Parrot::Test tests => 2; =head1 NAME t/compilers/pge/regression.t =head1 SYNOPSIS % prove t/compilers/pge/regression.t =head1 DESCRIPTION PGE regression tests =cut pir_output_is( <<'CODE', <<'OUTPUT', 'load_bytecode with .pir' ); .sub main :main load_bytecode 'PGE.pbc' load_bytecode 'dumper.pir' load_bytecode 'PGE/Dumper.pir' $P0 = compreg 'PGE::P5Regex' $P1 = $P0('aabb*') $P2 = $P1('fooaabbbar') _dumper($P2) .end CODE "VAR1" => PMC 'PGE;Match' => "aabbb" @ 3 OUTPUT pir_output_is( <<'CODE', <<'OUTPUT', 'load_bytecode with .pbc' ); .sub main :main load_bytecode 'PGE.pbc' load_bytecode 'dumper.pbc' load_bytecode 'PGE/Dumper.pbc' $P0 = compreg 'PGE::P5Regex' $P1 = $P0('aabb*') $P2 = $P1('fooaabbbar') _dumper($P2) .end CODE "VAR1" => PMC 'PGE;Match' => "aabbb" @ 3 OUTPUT # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: resizablepmcarray.pmc000644000765000765 4701112356767111 17310 0ustar00bruce000000000000parrot-6.6.0/src/pmc/* Copyright (C) 2001-2014, Parrot Foundation. =head1 NAME src/pmc/resizablepmcarray.pmc - ResizablePMCArray PMC =head1 DESCRIPTION This class, ResizablePMCArray, implements an resizable array which stores PMCs. It puts things into Integer, Float, or String PMCs as appropriate. =head2 Internal Functions =over 4 =cut */ #define PMC_size(x) ((Parrot_ResizablePMCArray_attributes *)PMC_data(x))->size #define PMC_array(x) ((Parrot_ResizablePMCArray_attributes *)PMC_data(x))->pmc_array #define PMC_threshold(x) ((Parrot_ResizablePMCArray_attributes *)PMC_data(x))->resize_threshold /* HEADERIZER HFILE: none */ /* HEADERIZER BEGIN: static */ /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */ PARROT_INLINE static void do_shift(ARGIN(PMC *arr)) __attribute__nonnull__(1); PARROT_INLINE static void do_unshift(PARROT_INTERP, ARGIN(PMC *arr), ARGIN(PMC *val)) __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__nonnull__(3); PARROT_DOES_NOT_RETURN static void throw_pop_empty(PARROT_INTERP) __attribute__nonnull__(1); PARROT_DOES_NOT_RETURN static void throw_shift_empty(PARROT_INTERP) __attribute__nonnull__(1); #define ASSERT_ARGS_do_shift __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(arr)) #define ASSERT_ARGS_do_unshift __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(arr) \ , PARROT_ASSERT_ARG(val)) #define ASSERT_ARGS_throw_pop_empty __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp)) #define ASSERT_ARGS_throw_shift_empty __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp)) /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */ /* HEADERIZER END: static */ /* =item C Removes and returns an item from the start of the array. Moves the whole rest of the array around. =cut */ PARROT_INLINE static void do_shift(ARGIN(PMC *arr)) { ASSERT_ARGS(do_shift) INTVAL size = PMC_size(arr); PMC ** const item = PMC_array(arr); PMC_size(arr) = --size; memmove(item, item + 1, size * sizeof (PMC *)); item[size] = PMCNULL; } /* =item C Adds an item at the start of the array. Moves the whole rest of the array around. =cut */ PARROT_INLINE static void do_unshift(PARROT_INTERP, ARGIN(PMC *arr), ARGIN(PMC *val)) { ASSERT_ARGS(do_unshift) const INTVAL size = PMC_size(arr); PMC **item; VTABLE_set_integer_native(interp, arr, size + 1); item = PMC_array(arr); memmove(item + 1, item, size * sizeof (PMC *)); item[0] = val; } /* =back =head1 Vtable Functions =over =cut */ pmclass ResizablePMCArray extends FixedPMCArray auto_attrs provides array { ATTR INTVAL resize_threshold; /* max size before array needs resizing */ /* =item C Initializes the array. =cut */ VTABLE void init_int(INTVAL size) :manual_wb { if (size < 0) Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_OUT_OF_BOUNDS, _("ResizeblePMCArray: Cannot set array size to a negative number (%d)"), size); SUPER(size); if (size > 0) { PMC_threshold(SELF) = size; PARROT_GC_WRITE_BARRIER(INTERP, SELF); } } /* =item C Resizes the array to C elements. =cut */ VTABLE void set_integer_native(INTVAL size) :manual_wb { if (size < 0) Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_OUT_OF_BOUNDS, "ResizablePMCArray: Can't resize!"); if (!PMC_array(SELF)) { /* empty - used fixed routine */ if (size < 8) { SUPER(8); PMC_size(SELF) = size; PMC_threshold(SELF) = 8; } else { SUPER(size); PMC_threshold(SELF) = size; } } else if (size == PMC_size(SELF)) { return; } else if (size <= PMC_threshold(SELF)) { PMC_size(SELF) = size; PARROT_GC_WRITE_BARRIER(INTERP, SELF); /* we could shrink here if necessary */ return; } else { INTVAL i, cur; i = cur = PMC_threshold(SELF); if (cur < 8192) cur = (size < 2 * cur) ? (2 * cur) : size; else { const INTVAL needed = size - cur; cur += needed + 4096; cur &= ~0xfff; } if (cur < 8) cur = 8; PMC_array(SELF) = mem_gc_realloc_n_typed_zeroed(INTERP, PMC_array(SELF), cur, i, PMC *); for (; i < cur; ++i) { (PMC_array(SELF))[i] = PMCNULL; } PMC_threshold(SELF) = cur; PMC_size(SELF) = size; } PARROT_GC_WRITE_BARRIER(INTERP, SELF); } /* =item C =item C =item C =item C Removes and returns an item from the start of the array. =cut TODO: This always moves the array memory, which is not very performant TODO: Check whether there is already an element that can be shifted */ VTABLE FLOATVAL shift_float() { const INTVAL size = PMC_size(SELF); FLOATVAL value; if (0 == size) throw_shift_empty(INTERP); value = VTABLE_get_number(INTERP, PMC_array(SELF)[0]); do_shift(SELF); return value; } VTABLE INTVAL shift_integer() { const INTVAL size = PMC_size(SELF); INTVAL value; if (0 == size) throw_shift_empty(INTERP); value = VTABLE_get_integer(INTERP, PMC_array(SELF)[0]); do_shift(SELF); return value; } VTABLE PMC *shift_pmc() { const INTVAL size = PMC_size(SELF); PMC *data; if (0 == size) throw_shift_empty(INTERP); data = PMC_array(SELF)[0]; do_shift(SELF); return data; } VTABLE STRING *shift_string() { const INTVAL size = PMC_size(SELF); STRING *value; if (0 == size) throw_shift_empty(INTERP); value = VTABLE_get_string(INTERP, PMC_array(SELF)[0]); do_shift(SELF); return value; } /* =item C Returns the PMC value of the element at index C. =cut */ VTABLE PMC *get_pmc_keyed_int(INTVAL key) :no_wb { PMC **data; if (key < 0) key += PMC_size(SELF); if (key < 0) Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_OUT_OF_BOUNDS, "ResizablePMCArray: index out of bounds!"); if (key >= PMC_size(SELF)) return PMCNULL; data = PMC_array(SELF); if (PMC_IS_NULL(data[key])) return PMCNULL; return data[key]; } /* =item C Sets the PMC value of the element at index C to C<*src>. =item C Sets the PMC value of the element keyed by C to C<*src>. =cut */ VTABLE void set_pmc_keyed_int(INTVAL key, PMC *src) { PMC **data; if (key < 0) key += PMC_size(SELF); if (key < 0) Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_OUT_OF_BOUNDS, "ResizablePMCArray: index out of bounds!"); if (key >= PMC_size(SELF)) SELF.set_integer_native(key+1); data = PMC_array(SELF); data[key] = src; } VTABLE void set_pmc_keyed(PMC *key, PMC *src) :manual_wb { SUPER(key, src); } VTABLE void set_pmc(PMC *value) :manual_wb { INTVAL size; INTVAL i; if (SELF == value) return; if (!VTABLE_does(INTERP, value, CONST_STRING(INTERP, "array"))) Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_OUT_OF_BOUNDS, _("Can't set self from this type")); if (PMC_array(SELF)) mem_gc_free(INTERP, PMC_array(SELF)); size = PMC_size(SELF) = VTABLE_elements(INTERP, value); PMC_array(SELF) = mem_gc_allocate_n_typed(INTERP, size, PMC *); for (i = 0; i < size; ++i) (PMC_array(SELF))[i] = VTABLE_get_pmc_keyed_int(INTERP, value, i); PObj_custom_mark_destroy_SETALL(SELF); PARROT_GC_WRITE_BARRIER(INTERP, SELF); } /* =item C =item C Delete the element at index C. =cut */ VTABLE void delete_keyed(PMC *key) :manual_wb { const INTVAL idx = VTABLE_get_integer(INTERP, key); SELF.delete_keyed_int(idx); } VTABLE void delete_keyed_int(INTVAL key) { PMC ** const data = PMC_array(SELF); const INTVAL n = PMC_size(SELF); INTVAL i; for (i = key; i < n - 1; ++i) data[i] = data[i + 1]; --PMC_size(SELF); } /* =item C =item C Returns TRUE is the element at C exists; otherwise returns false. =cut */ VTABLE INTVAL exists_keyed_int(INTVAL key) :no_wb { PMC **data; PARROT_GC_WRITE_BARRIER(INTERP, SELF); if (key < 0) key += PMC_size(SELF); if (key < 0 || key >= PMC_size(SELF)) return 0; data = PMC_array(SELF); return !PMC_IS_NULL(data[key]); } VTABLE INTVAL exists_keyed(PMC *key) :no_wb { const INTVAL ix = VTABLE_get_integer(INTERP, key); return SELF.exists_keyed_int(ix); } /* =item C Returns TRUE is the element at C is defined; otherwise returns false. =cut */ VTABLE INTVAL defined_keyed_int(INTVAL key) :no_wb { PMC *val; if (key < 0) key += PMC_size(SELF); if (key < 0 || key >= PMC_size(SELF)) return 0; val = SELF.get_pmc_keyed_int(key); if (PMC_IS_NULL(val)) { return 0; } return VTABLE_defined(INTERP, val); } /* =item C =item C =item C =item C Extends the array by adding an element of value C<*value> to the end of the array. =cut */ VTABLE void push_float(FLOATVAL value) :manual_wb { const INTVAL size = PMC_size(SELF); PMC * const val = Parrot_pmc_new(INTERP, enum_class_Float); VTABLE_set_number_native(INTERP, val, value); SELF.set_pmc_keyed_int(size, val); } VTABLE void push_integer(INTVAL value) :manual_wb { const INTVAL size = PMC_size(SELF); PMC * const val = Parrot_pmc_new_init_int(INTERP, enum_class_Integer, value); SELF.set_pmc_keyed_int(size, val); } VTABLE void push_pmc(PMC *value) { const INTVAL size = PMC_size(SELF); const INTVAL thresh = PMC_threshold(SELF); if (PMC_array(SELF) && size < thresh) PMC_size(SELF) = size + 1; else { SELF.set_integer_native(size + 1); } ((PMC **)PMC_array(SELF))[size] = value; } VTABLE void push_string(STRING *value) :manual_wb { const INTVAL size = PMC_size(SELF); PMC * const val = Parrot_pmc_new(INTERP, enum_class_String); VTABLE_assign_string_native(INTERP, val, value); SELF.set_pmc_keyed_int(size, val); } /* Removes and returns the last element in the array. =item C =item C =item C =item C =cut */ VTABLE FLOATVAL pop_float() :manual_wb { INTVAL size = PMC_size(SELF); PMC *data; if (0 == size) throw_pop_empty(INTERP); data = PMC_array(SELF)[--size]; PMC_size(SELF) = size; PARROT_GC_WRITE_BARRIER(INTERP, SELF); return VTABLE_get_number(INTERP, data); } VTABLE INTVAL pop_integer() :manual_wb { INTVAL size = PMC_size(SELF); PMC *data; if (0 == size) throw_pop_empty(INTERP); data = PMC_array(SELF)[--size]; PMC_size(SELF) = size; PARROT_GC_WRITE_BARRIER(INTERP, SELF); return VTABLE_get_integer(INTERP, data); } VTABLE PMC *pop_pmc() :manual_wb { INTVAL size = PMC_size(SELF); PMC *data; if (0 == size) throw_pop_empty(INTERP); data = PMC_array(SELF)[--size]; PMC_size(SELF) = size; PARROT_GC_WRITE_BARRIER(INTERP, SELF); return data; } VTABLE STRING *pop_string() :manual_wb { INTVAL size = PMC_size(SELF); PMC *data; if (0 == size) throw_pop_empty(INTERP); data = PMC_array(SELF)[--size]; PMC_size(SELF) = size; PARROT_GC_WRITE_BARRIER(INTERP, SELF); return VTABLE_get_string(INTERP, data); } /* =item C =item C =item C =item C Extends the array by adding an element of value C<*value> to the begin of the array. =cut */ VTABLE void unshift_float(FLOATVAL value) { PMC * const val = Parrot_pmc_new(INTERP, enum_class_Float); VTABLE_set_number_native(INTERP, val, value); do_unshift(INTERP, SELF, val); } VTABLE void unshift_integer(INTVAL value) { PMC * const val = Parrot_pmc_new_init_int(INTERP, enum_class_Integer, value); do_unshift(INTERP, SELF, val); } VTABLE void unshift_pmc(PMC *value) { do_unshift(INTERP, SELF, value); } VTABLE void unshift_string(STRING *value) { PMC * const val = Parrot_pmc_new(INTERP, enum_class_String); VTABLE_set_string_native(INTERP, val, value); do_unshift(INTERP, SELF, val); } /* =item C Creates and returns a copy of the array. =cut */ VTABLE PMC *clone() :no_wb { PMC * const copy = SUPER(); /* copy trimmed extra space */ PMC_threshold(copy) = PMC_size(SELF); return copy; } /* =item C Returns the Parrot string representation C. =cut */ VTABLE STRING *get_repr() :no_wb { INTVAL j; const INTVAL n = VTABLE_elements(INTERP, SELF); STRING *res = CONST_STRING(INTERP, "[ "); STRING *ret; for (j = 0; j < n; ++j) { PMC * const val = SELF.get_pmc_keyed_int(j); res = Parrot_str_concat(INTERP, res, VTABLE_get_repr(INTERP, val)); if (j < n - 1) res = Parrot_str_concat(INTERP, res, CONST_STRING(INTERP, ", ")); } ret = Parrot_str_concat(INTERP, res, CONST_STRING(INTERP, " ]")); return ret; } /* =item C Replaces C elements starting at C with the elements in C. Note that the C PMC can be of any of the various array types. =cut */ VTABLE void splice(PMC *from, INTVAL offset, INTVAL count) { const INTVAL elems0 = VTABLE_elements(INTERP, SELF); const INTVAL elems1 = VTABLE_elements(INTERP, from); PMC **item = 0; INTVAL tail; INTVAL i; /* start from end? */ if (offset < 0) offset += elems0; if (offset < 0) Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_OUT_OF_BOUNDS, "illegal splice offset\n"); /* number of elements to the right of the splice (the "tail") */ tail = elems0 - offset - count; if (tail < 0) tail = 0; item = PMC_array(SELF); if (tail > 0 && count > elems1) { /* we're shrinking the array, so first move the tail left */ memmove(item + offset + elems1, item + offset + count, tail * sizeof (PMC *)); } /* now resize the array */ SELF.set_integer_native(offset + elems1 + tail); item = PMC_array(SELF); if (tail > 0 && count < elems1) { /* the array grew, so move the tail to the right */ memmove(item + offset + elems1, item + offset + count, tail * sizeof (PMC *)); } /* now copy C's elements into SELF */ if (elems1 > 0) { PMC *iter = VTABLE_get_iter(INTERP, from); for (i = 0; i < elems1; i++) item[offset + i] = VTABLE_shift_pmc(INTERP, iter); } } /* =back =head2 Methods =over 4 =item METHOD append(PMC *other) Append the other array to this array. =cut */ METHOD append(PMC *other) { const INTVAL n = VTABLE_elements(INTERP, SELF); const INTVAL m = VTABLE_elements(INTERP, other); if (!m) return; /* pre-size it */ VTABLE_set_integer_native(INTERP, SELF, n + m); if (other->vtable->base_type == SELF->vtable->base_type || other->vtable->base_type == enum_class_FixedPMCArray) { PMC ** const other_data = PMC_array(other); PMC ** const this_data = PMC_array(SELF); /* libc is faster at copying data than a manual loop here */ memmove(this_data + n, other_data, m * sizeof (PMC *)); } else { PMC ** const this_data = PMC_array(SELF); INTVAL i; for (i = 0; i < m; ++i) this_data[n + i] = VTABLE_get_pmc_keyed_int(INTERP, other, i); } RETURN(void); } /* =item METHOD PMC* shift() =item METHOD PMC* pop() Method forms to remove and return a PMC from the beginning or end of the array. =cut */ METHOD shift() :manual_wb { PMC * const value = VTABLE_shift_pmc(INTERP, SELF); RETURN(PMC *value); } METHOD pop() :manual_wb { PMC * const value = VTABLE_pop_pmc(INTERP, SELF); RETURN(PMC *value); } /* =item METHOD unshift(PMC* value) =item METHOD push(PMC* value) Method forms to add a PMC to the beginning or end of the array. =cut */ METHOD unshift(PMC* value) :manual_wb { VTABLE_unshift_pmc(INTERP, SELF, value); } METHOD push(PMC* value) :manual_wb { VTABLE_push_pmc(INTERP, SELF, value); } } /* =back =head2 Auxiliar functions =over 4 =item C Common part for shift operations. =item C Common part for unshift operations. =item C =item C Throws with the appropriate message. =cut */ PARROT_DOES_NOT_RETURN static void throw_shift_empty(PARROT_INTERP) { ASSERT_ARGS(throw_shift_empty) Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_OUT_OF_BOUNDS, "ResizablePMCArray: Can't shift from an empty array!"); } PARROT_DOES_NOT_RETURN static void throw_pop_empty(PARROT_INTERP) { ASSERT_ARGS(throw_pop_empty) Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_OUT_OF_BOUNDS, "ResizablePMCArray: Can't pop from an empty array!"); } /* =back =head1 See also F. =cut */ /* * Local variables: * c-file-style: "parrot" * End: * vim: expandtab shiftwidth=4 cinoptions='\:2=2' : */ fixedstringarray.t000644000765000765 1764212346145241 16316 0ustar00bruce000000000000parrot-6.6.0/t/pmc#!./parrot # Copyright (C) 2001-2010, Parrot Foundation. =head1 NAME t/pmc/fixedstringarray.t - FixedStringArray PMC =head1 SYNOPSIS % prove t/pmc/fixedstringarray.t =head1 DESCRIPTION Tests C PMC. Checks size, sets various elements, including out-of-bounds test. Checks INT and PMC keys. =cut .sub 'main' :main .include 'test_more.pir' plan(50) test_set_size() test_reset_size() test_set_first() test_set_second() test_out_of_bounds() test_set_via_pmc() test_get_via_pmc() test_interface_done() test_clone() test_clone_unitialized() test_truth() test_get_iter() test_freez_thaw() test_get_string() test_equality() test_number() test_new_style_init() test_invalid_init_tt1509() test_gc() .end .sub 'test_set_size' $P0 = new ['FixedStringArray'] $I0 = $P0 is($I0, 0, "Fresh array has 0 elements") $P0 = 42 $I0 = $P0 is($I0, 42, "Size was set correctly") .end .sub 'test_reset_size' $P0 = new ['FixedStringArray'] $I0 = 1 $P0 = 1 push_eh handled $P0 = 2 $I0 = 0 handled: pop_eh ok($I0, "Can't resize") .end .sub 'test_set_first' $P0 = new ['FixedStringArray'] $P0 = 1 $P0[0] = -7 $I0 = $P0[0] is($I0, -7, "First element set to integer properly") $P0[0] = 3.7 $N0 = $P0[0] is($N0, 3.7, "First element set to number properly") $P0[0] = "muwhahaha" $S0 = $P0[0] is($S0, "muwhahaha", "First element set to string properly") .end .sub 'test_set_second' $P0 = new ['FixedStringArray'] $P0 = 2 $P0[1] = -7 $I0 = $P0[1] is($I0, -7, "Second element set to integer properly") $P0[1] = 3.7 $I0 = $P0[1] is($I0, 3, "Second element set to number properly") $P0[1] = "purple" $S0 = $P0[1] is($S0, "purple", "Second element set to string properly") .end .sub 'test_out_of_bounds' $P0 = new ['FixedStringArray'] $P0 = 1 $I0 = 1 push_eh handle_set $P0[2] = 7 $I0 = 0 handle_set: ok($I0, "Can't set out-of-bounds element") pop_eh $I0 = 1 push_eh handle_set_negative $P0[-42] = 7 $I0 = 0 handle_set_negative: ok($I0, "Can't set element on negative index") pop_eh $I0 = 1 push_eh handle_get $I1 = $P0[2] $I0 = 0 handle_get: ok($I0, "Can't get out-of-bounds element") pop_eh $I0 = 1 push_eh handle_get_negative $I1 = $P0[-1] $I0 = 0 handle_get_negative: ok($I0, "Can't get element with negative index") pop_eh .end # Set via PMC keys, access via INTs .sub 'test_set_via_pmc' $P0 = new ['FixedStringArray'] $P0 = 3 $P1 = new ['Key'] $P1 = 0 $P0[$P1] = 25 $S0 = $P0[0] is($S0, "25", "Set INTVAL via PMC Key works") $P1 = 1 $P0[$P1] = 2.5 $S0 = $P0[1] is($S0, "2.5", "Set FLOATVAL via PMC Key works") $P1 = 2 $P0[$P1] = "bleep" $S0 = $P0[2] is($S0, "bleep", "Set STRING via PMC Key works") .end # Set via INTs, access via PMC Keys .sub 'test_get_via_pmc' $P0 = new ['FixedStringArray'] $P0 = 1024 $P0[25] = 125 $P0[128] = 10.2 $P0[513] = "blah" $P1 = new ['Integer'] $P1 = 123456 $P0[1023] = $P1 $P2 = new ['Key'] $P2 = 25 $I0 = $P0[$P2] is($I0, 125, "Get INTVAL via Key works") $P2 = 128 $N0 = $P0[$P2] is($N0, 10.2, "Get FLOATVAL via Key works") $P2 = 513 $S0 = $P0[$P2] is($S0, "blah", "Get STRING via Key works") $P2 = 1023 $I0 = $P0[$P2] is($I0, 123456, "Get INTVAL for stored PMC via Key works") .end .sub 'test_interface_done' .local pmc pmc1 pmc1 = new ['FixedStringArray'] .local int bool1 does bool1, pmc1, "scalar" nok(bool1, "Does not scalar") does bool1, pmc1, "array" ok(bool1, "Does array") does bool1, pmc1, "no_interface" nok(bool1, "Does not no_interface") .end .sub 'test_clone' new $P0, ['FixedStringArray'] set $P0, 3 set $P0[0], "abcde" set $P0[1], "fghi" set $P0[2], "jkl" clone $P1, $P0 set $P0[0], "" set $P0[1], "" set $P0[2], "" set $S0, $P1[0] is($S0, "abcde", "First element cloned") set $S0, $P1[1] is($S0, "fghi", "Second element cloned") set $S0, $P1[2] is($S0, "jkl", "Third element cloned") .end .sub 'test_clone_unitialized' $P0 = new ['FixedStringArray'] $P1 = clone $P0 $I0 = 0 push_eh clone_1 $P0 = 10 $P1 = 20 $I0 = 1 clone_1: pop_eh ok($I0, "Resize of uninitialized clone successful") $I1 = 1 push_eh clone_2 $P2 = clone $P0 $P2 = 30 $I0 = 0 clone_2: ok($I0, "Resize of initialization not successful") pop_eh .end .sub 'test_truth' $P0 = new ['FixedStringArray'] nok($P0, "Empty array is false") $P0 = 10 ok($P0, "Non-empty array is true") .end .sub 'test_get_iter' $P0 = new ['FixedStringArray'] $P0 = 3 $P0[0] = "foo" $P0[1] = "bar" $P0[2] = "baz" $S0 = "" $P1 = iter $P0 loop: unless $P1 goto loop_end $S2 = shift $P1 $S0 = concat $S0, $S2 goto loop loop_end: is($S0, "foobarbaz", "Iteration works") .end .sub 'test_freez_thaw' .local pmc fsa, it .local string s new fsa, ['FixedStringArray'] fsa = 5 fsa[0] = 42 fsa[1] = 43 fsa[2] = 44 fsa[3] = 99 fsa[4] = 101 s = freeze fsa fsa = thaw s it = iter fsa $S0 = "" loop: unless it goto loop_end s = shift it $S0 = concat $S0, s goto loop loop_end: is($S0, "42434499101", "get_iter works") .end .sub 'test_get_string' $P0 = new ['FixedStringArray'] $P0 = 2 $P0[0] = "foo" is($P0, '[ "foo", "" ]', "Array stringified properly") .end .sub 'test_equality' .local pmc a1, a2, other .local int i .local string s a1 = new ['FixedStringArray'] a2 = new ['FixedStringArray'] other = new ['Integer'] is(a1, a2, "Empty arrays are equal") i = iseq a1, other is(i, 0, "Not equal to other type") a1 = 3 isnt(a1, a2, "Different size arrays aren't equal") a2 = 3 a1[0] = "foo" a2[0] = "foo" is(a1, a2, "Equal with first element set") a1[1] = "bar" a2[1] = "BAR" isnt(a1, a2, "Not equal when second element differ") a2[1] = "bar" is(a1, a2, "Equal when second element same") null s a2[1] = s isnt(a1, a2, "Not equal when second element is null") .end .sub 'test_number' .local pmc fsa fsa = new ['FixedStringArray'] fsa = 3 $I0 = fsa is($I0, 3, "get_integer returns correct size") $N0 = fsa is($N0, 3.0, "get_number returns correct size") .end .sub 'test_new_style_init' $P0 = new 'FixedStringArray', 10 $I0 = $P0 is($I0, 10, "New style init creates the correct # of elements") $P0 = new ['FixedStringArray'], 10 $I0 = $P0 is($I0, 10, "New style init creates the correct # of elements for a key constant") .end .sub test_invalid_init_tt1509 throws_substring(<<'CODE', 'FixedStringArray: Cannot set array size to a negative number (-10)', 'New style init does not dump core for negative array lengths') .sub main :main $P0 = new ['FixedStringArray'], -10 .end CODE throws_substring(<<'CODE', 'FixedStringArray: Cannot set array size to a negative number (-10)', 'New style init (key constant) does not dump core for negative array lengths') .sub main :main $P0 = new 'FixedStringArray', -10 .end CODE .end .sub 'test_gc' $P0 = new ['FixedStringArray'] $P0 = 8192 $I0 = 0 loop: $P0[$I0] = $I0 inc $I0 sweep 1 if $I0 < 8192 goto loop $S0 = $P0[1000] is($S0, "1000", "1000th element survived") $S0 = $P0[2000] is($S0, "2000", "2000th element survived") $S0 = $P0[4000] is($S0, "4000", "4000th element survived") $S0 = $P0[8000] is($S0, "8000", "8000th element survived") .end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: arriter.rb000644000765000765 64111466337261 17410 0ustar00bruce000000000000parrot-6.6.0/examples/benchmarks#! ruby k = Array.new nk = Array.new ha = Hash.new 10.times { |i| s = (65 + i).chr k.push s } (0..3).each { |e| 10.times { |i| k.each{ |s| _nk = s + (65 + i).chr nk.push _nk } } k = nk nk = Array.new } puts k.length j = 0 k.each{ |s| j+=1 ha[s] = 1 } puts j puts ha.keys.length print ha["AAAAA"] print ha["ABCDE"] print ha["BBBBB"] print ha["CCCCC"] print ha["HHHHH"] print ha["IIIII"] puts list.h000644000765000765 1311512233541455 15571 0ustar00bruce000000000000parrot-6.6.0/include/parrot/* Copyright (C) 2010, Parrot Foundation. =head1 NAME src/gc/list.h - Linked lists of allocated objects. =head1 DESCRIPTION Implementation of double linked lists used by various GC implementations. */ #ifndef PARROT_GC_LIST_H_GUARD #define PARROT_GC_LIST_H_GUARD /* Allocatable objects has headers to use in linked lists */ typedef struct List_Item_Header { struct List_Item_Header *prev; struct List_Item_Header *next; #ifndef NDEBUG struct Linked_List *owner; #endif } List_Item_Header; /* Double-linked list. */ /* N.B. List doesn't _own_ items */ typedef struct Linked_List { struct List_Item_Header *first; struct List_Item_Header *last; /* Cache object count in list. We use it very often */ size_t count; } Linked_List; /* Such headers allocated in front of real objects. */ /* There is helper macros to convert to/from real objects */ #define Obj2LLH(p) ((List_Item_Header *)((char*)(p) - sizeof (List_Item_Header))) #define LLH2Obj_typed(p, type) ((type*)((char*)(p) + sizeof (List_Item_Header))) #define LLH2Obj(p) LLH2Obj_typed(p, void) #ifdef NDEBUG # define SET_LIST_OWNER(l, i) #else # define SET_LIST_OWNER(l, i) (i)->owner = (l); #endif #define LIST_APPEND(l, i) \ do { \ List_Item_Header *_item = (i); \ Linked_List *_list = (l); \ \ if (_list->last) { \ _item->prev = _list->last; \ _list->last->next = _item; \ } \ else if (!_list->first) { \ _item->prev = NULL; \ _list->first = _item; \ } \ \ _list->last = _item; \ _item->next = NULL; \ \ SET_LIST_OWNER(_list, _item) \ _list->count++; \ } while (0); #define LIST_REMOVE(l, i) \ do { \ List_Item_Header *_item = (i); \ Linked_List *_list = (l); \ List_Item_Header *next = _item->next; \ List_Item_Header *prev = _item->prev; \ \ PARROT_ASSERT(_list == _item->owner); \ \ /* First _item */ \ if (_list->first == _item) \ _list->first = next; \ \ if (_list->last == _item) \ _list->last = prev; \ \ if (prev) \ prev->next = next; \ if (next) \ next->prev = prev; \ \ _list->count--; \ } while (0) /* HEADERIZER BEGIN: src/list.c */ /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */ PARROT_EXPORT void Parrot_list_append(PARROT_INTERP, ARGMOD(Linked_List *list), ARGMOD(List_Item_Header *item)) __attribute__nonnull__(2) __attribute__nonnull__(3) FUNC_MODIFIES(*list) FUNC_MODIFIES(*item); PARROT_EXPORT PARROT_CONST_FUNCTION INTVAL Parrot_list_check(PARROT_INTERP, ARGIN(const Linked_List *list)) __attribute__nonnull__(2); PARROT_EXPORT PARROT_PURE_FUNCTION INTVAL Parrot_list_contains(PARROT_INTERP, ARGIN(const Linked_List *list), ARGIN(const List_Item_Header *item)) __attribute__nonnull__(2) __attribute__nonnull__(3); PARROT_EXPORT void Parrot_list_destroy(PARROT_INTERP, ARGMOD(Linked_List* list)) __attribute__nonnull__(2) FUNC_MODIFIES(* list); PARROT_EXPORT PARROT_CANNOT_RETURN_NULL struct Linked_List* Parrot_list_new(PARROT_INTERP); PARROT_EXPORT PARROT_CAN_RETURN_NULL List_Item_Header* Parrot_list_pop(PARROT_INTERP, ARGIN(Linked_List *list)) __attribute__nonnull__(2); PARROT_EXPORT PARROT_CAN_RETURN_NULL List_Item_Header* Parrot_list_remove(PARROT_INTERP, ARGMOD(Linked_List *list), ARGMOD(List_Item_Header *item)) __attribute__nonnull__(2) __attribute__nonnull__(3) FUNC_MODIFIES(*list) FUNC_MODIFIES(*item); #define ASSERT_ARGS_Parrot_list_append __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(list) \ , PARROT_ASSERT_ARG(item)) #define ASSERT_ARGS_Parrot_list_check __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(list)) #define ASSERT_ARGS_Parrot_list_contains __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(list) \ , PARROT_ASSERT_ARG(item)) #define ASSERT_ARGS_Parrot_list_destroy __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(list)) #define ASSERT_ARGS_Parrot_list_new __attribute__unused__ int _ASSERT_ARGS_CHECK = (0) #define ASSERT_ARGS_Parrot_list_pop __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(list)) #define ASSERT_ARGS_Parrot_list_remove __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(list) \ , PARROT_ASSERT_ARG(item)) /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */ /* HEADERIZER END: src/list.c */ #endif /* PARROT_GC_LIST_H_GUARD */ /* * Local variables: * c-file-style: "parrot" * End: * vim: expandtab shiftwidth=4 cinoptions='\:2=2' : */ primes2.rb000644000765000765 43311533177634 17321 0ustar00bruce000000000000parrot-6.6.0/examples/benchmarks#! ruby i6 = 0 i7 = 0 max = 500 def is_prime(n) if n < 1 return false end (n-1).downto(2) { |i| if n % i == 0 return false end } true end max.times { |i| if is_prime i i6 += 1 i7 = i end } puts "# of primes calculated to #{max}: #{i6}" puts "last is: #{i7}" tutorial_episode_1.pod000644000765000765 2436012101554066 23630 0ustar00bruce000000000000parrot-6.6.0/examples/languages/squaak/doc# Copyright (C) 2008-2012, Parrot Foundation. =pod =head1 DESCRIPTION This is the first episode in a tutorial series on building a compiler with the Parrot Compiler Tools. =head1 Episode 1: Introduction =head2 Introduction If you're interested in virtual machines, you've probably heard of the Parrot virtual machine. Parrot is a generic virtual machine designed for dynamic languages. This is in contrast with the Java virtual machine (JVM) and Microsoft's Bommon Banguage Buntime (CLR), both of which were designed to run static languages. Both the JVM and Microsoft (through the Dynamic Language Runtime -- DLR) are adding support for dynamic languages, but their primary focus is still static languages. =head2 High Level Languages The main purpose of a virtual machine is to run programs. These programs are typically written in some Bigh Bevel Banguage (HLL). Some well-known dynamic languages (sometimes referred to as scripting languages) are Lua, Perl, PHP, Python, Ruby, and Tcl. Parrot is designed to be able to run all these languages. Each language that Parrot hosts, needs a compiler to parse the syntax of the language and generate Parrot instructions. If you've never implemented a programming language (and maybe even if you have implemented a language), you might consider writing a compiler a bit of a black art. I know I did when I became interested. And you know what, it is. Compilers are complex programs, and implementing a language can be very difficult. The Facts: 1) Parrot is suitable for running virtually any dynamic language known, but before doing so, compilers must be written, and 2) writing compilers from scratch is rather difficult. =head2 The Parrot Compiler Toolkit Enter the B

arrot Bompiler Boolkit (PCT). In order to make Parrot an interesting target for language developers, the process of constructing a compiler should be supported by the right tools. Just as any construction task becomes much easier if you have the right tools (you wouldn't build a house using only your bare hands, would you?), the same is true for constructing a compiler. The PCT was designed to do just that: provide powerful tools to make writing a compiler for Parrot childishly easy. This tutorial introduces the PCT by showing how a simple case study language is implemented for Parrot. The sample language is not as complex as a real-world language, but is interesting enough to whet your appetite and show the power of the PCT. This tutorial also presents some exercises which you can explore in order to learn more details of the PCT not covered in this tutorial. =head2 Squaak: A Simple Language The case study language is named Squaak. We will be implementing on Parrot a full-fledged compiler that can compile a Squaak program from source into Parrot Intermediate Representation (PIR) or run a Squaak program immediately. The compiler can also be used as an interactive interpreter, REPL, for Squaak. Squaak demonstrates some common language constructs, but is lacking some other, seemingly simple, features. For instance, our language will have no return, break or continue statements (or equivalents in your favorite syntax). Squaak has the following features: =over 4 =item * global and local variables =item * basic types: integer, floating-point and strings =item * aggregate types: arrays and hash tables =item * operators: +, -, /, *, %, <, <=, >, >=, ==, !=, .., and, or, not =item * subroutines and parameters =item * assignments and various control statements, such as "if" and "while" =back As you can see, a number of common (more advanced) features are missing. Most notable are: =over 4 =item * classes and objects =item * control flow statements such as break and return =item * advanced control statements such as switch =item * closures (nested subroutines and accessing local variables in an outer scope) =back =head2 The Tools The Parrot Compiler Toolkit consists of the following tools: =over 4 =item Bot Buite B

erl (6) (NQP-rx). NQP is a lightweight language inspired by Perl 6 which can be used to write the methods that must be executed during the parsing phase, just as you can write actions in a Yacc/Bison input file. It also provides the regular expression engine we'll use to write our grammar. In addition to the capabilities of Perl 5's regexes, the Perl 6 regexes that NQP implements can be used to define language grammars. (Check the references for the specification.) =item B

arrot Bbstract Byntax Bree (PAST). The PAST nodes are a set of classes defining generic abstract syntax tree nodes that represent common language constructs. =item HLL::Compiler class. This class is the compiler driver for any PCT-based compiler. =back =head2 Getting Started For this tutorial, it is assumed you have successfully compiled parrot (and maybe even run the test suite). If, after reading this tutorial, you feel like contributing to one of the already implemented languages, you can check out the mailing list or join IRC (see the references section for details). Parrot comes with a Perl 5 script that generates the necessary files for a language implementation. In order to generate these files for our sample language, go the Parrot's root directory and type: $ perl tools/dev/mk_language_shell.pl Squaak ~/src/squaak (Note: if you're on Windows, you should use backslashes.) This will generate the files in the directory F<~/src/squaak>. The name of the language will be Squaak. After this, go to the directory F<~/src/squaak> and type: $ parrot setup.pir test This will compile the grammar and the actions and run the test suite. For running F you can either use an installed parrot executable from your distribution or the one you have just compiled. If you want more information on what files are being generated, please check out the references at the end of this episode or read the documentation included in the file F. Note that we didn't write a single line of code, and already we have the basic infrastructure in place to get us started. Of course, the generated compiler doesn't even look like the language we will be implementing, but that's ok for now. Later we'll adapt the grammar to accept our language. Now you might want to actually run a simple script with this compiler. Launch your favorite editor, and put in this statement: say "Squaak!"; Save it the as file F and type: $ ./installable_squaak test.sq "installable_squaak" is a "fake-cutable" an executable that bundles the Parrot interpreter and the compiled bytecode for a program to allow treating a Parrot program as a normal executable program. This will run Parrot, specifying squaak.pbc as the file to be run by Parrot, which takes a single argument: the file test.sq. If all went well, you should see the following output: $ ./installable_squaak test.sq Squaak! Instead of running a script file, you can also run the Squaak compiler as an interactive interpreter. Run the Squaak compiler without specifying a script file, and type the same statement as you wrote in the file: $ ./installable_squaak say "Squaak!"; which will print: Squaak! =head2 What's next? This first episode of this tutorial is mainly an overview of what will be coming. Hopefully you now have a global idea of what the Parrot Compiler Tools are, and how they can be used to build a compiler targeting Parrot. If you want to check out some serious usage of the PCT, check out Rakudo (Perl 6 on Parrot) at http://rakudo.org/ or Pynie (Python on Parrot) at http://code.google.com/p/pynie/ . The next episodes will focus on the step-by-step implementation of our language, including the following topics: =over 4 =item structure of PCT-based compilers =item using NQP-rx rules to define the language grammar =item implementing operator precedence using an operator precedence table =item using NQP to write embedded parse actions =item implementing language library routines =back In the mean time, experiment for yourself. You are welcome to join us on IRC (see the References section for details). Any feedback on this tutorial is appreciated. =head2 Exercises The exercises are provided at the end of each episode of this tutorial. In order to keep the length of this tutorial somewhat acceptable, not everything can be discussed in full detail. With episode 3 the answers and/or solutions to these exercises are at the end of each episode. The answer of the exercise from episode 1 is at the end of episode 2. =head3 Advanced interactive mode. Launch your favorite editor and look at the file Compiler.pm in the directory F<~/src/squaak/src/Squaak/>. This file contains the main function (entry point) of the compiler. The class HLLCcompiler defines methods to set a command-line banner and prompt for your compiler when it is running in interactive mode. For instance, when you run Python in interactive mode, you'll see: Python 2.5.1 (r251:54863, Apr 18 2007, 08:51:08) [MSC v.1310 32 bit (Intel)] on win32 Type "help", "copyright", "credits" or "license" for more information. or something similar (depending on your Python installation and version). This text is called the command line banner. And while running in interactive mode, each line will start with: >>> which is called a prompt. For Squaak, we'd like to see the following when running in interactive mode (of course you can change this according to your personal taste): $ ./installable_squaak Squaak for Parrot VM. > Add code to the file ~/src/squaak/src/Squaak/Compiler.pm to achieve this. Hint 1: Look in the INIT block. Hint 2: Note that only double-quoted strings in NQP can interpret escape-characters such as '\n'. Hint 3: The functions to do this are documented in F. =head2 References =over 4 =item * Parrot mailing list: parrot-dev@lists.parrot.org =item * IRC: join #parrot on irc.parrot.org =item * Getting started with PCT: docs/pct/gettingstarted.pod =item * Parrot Abstract Syntax Tree (PAST): docs/pct/past_building_blocks.pod =item * Operator Precedence Parsing with PCT: docs/pct/pct_optable_guide.pod =item * Perl 6/NQP rules syntax: Synopsis 5 at http://perlcabal.org/syn/S05.html or http://svn.pugscode.org/pugs/docs/Perl6/Spec/S05-regex.pod =item * List of HLL projects: https://github.com/parrot/parrot/wiki/Languages =back =cut structview.t000644000765000765 1077511567202625 15154 0ustar00bruce000000000000parrot-6.6.0/t/pmc#!./parrot # Copyright (C) 2011, Parrot Foundation. .include 'datatypes.pasm' .sub 'main' :main .include 'test_more.pir' plan(16) test_bit_struct() test_unaligned_struct() test_union() test_fp() test_explicit_sized_types() test_struct_pad() .end .sub test_bit_struct $P0 = new ['FixedIntegerArray'], 10 $P0[0] = .DATATYPE_STRUCT $P0[1] = 8 $I0 = 2 loop: $P0[$I0] = .DATATYPE_BIT inc $I0 unless $I0 > 9 goto loop .local pmc sv sv = new ['StructView'], $P0 $I0 = sv.'size'() is($I0, 1, '8 bits in one byte') $I0 = sv.'align'() is($I0, 1, 'single byte is byte-aligned') $I0 = sv.'aligned_size'() is($I0, 1, 'byte-aligned single byte is single byte when aligned') .local pmc buf buf = sv.'alloc'() ok(buf, 'allocate an instance') $I0 = 1 loop2: sv[buf; $I0] = 1 $I0 += 2 unless $I0 > 8 goto loop2 $P0 = new ['FixedIntegerArray'], 3 $P0[0] = .DATATYPE_STRUCT $P0[1] = 1 $P0[2] = .DATATYPE_UCHAR .local pmc sv2 sv2 = new ['StructView'], $P0 $I0 = sv2[buf; 0] is($I0, 0xAA, 'bitpattern gives correct byte') .end .sub 'test_unaligned_struct' $P0 = new ['FixedIntegerArray'], 13 $P0[0] = .DATATYPE_SIZED # custom layout struct $P0[1] = 3 $P0[2] = 2 # size $P0[3] = 1 # alignment $P0[4] = .DATATYPE_UINT4 $P0[5] = 0 # byte-offset $P0[6] = 0 # bit-offset $P0[7] = .DATATYPE_UCHAR $P0[8] = 0 $P0[9] = 4 $P0[10] = .DATATYPE_UINT4 $P0[11] = 1 $P0[12] = 4 .local pmc sv, buf sv = new ['StructView'], $P0 buf = sv.'alloc'() sv[buf; 0] = 0xB sv[buf; 1] = 0xDA sv[buf; 2] = 0xC $P0 = new ['FixedIntegerArray'], 4 $P0[0] = .DATATYPE_STRUCT $P0[1] = 2 $P0[2] = .DATATYPE_UCHAR $P0[3] = .DATATYPE_UCHAR .local pmc sv2 sv2 = new ['StructView'], $P0 $I0 = sv2[buf; 0] is($I0, 0xAB, 'unaligned struct first byte') $I0 = sv2[buf; 1] is($I0, 0xCD, 'unaligned struct second byte') .end .sub 'test_union' $P0 = new ['FixedIntegerArray'], 4 $P0[0] = .DATATYPE_UNION $P0[1] = 2 $P0[2] = .DATATYPE_USHORT $P0[3] = .DATATYPE_UCHAR .local pmc sv, buf sv = new ['StructView'], $P0 buf = sv.'alloc'() sv[buf; 0] = 0xFEDC $I0 = sv[buf; 1] $I1 = $I0 == 0xFE $I2 = $I0 == 0xDC $I0 = $I1 || $I2 ok($I0, 'union { short s; char c; }') .end .sub 'test_fp' $P0 = new ['FixedIntegerArray'], 5 $P0[0] = .DATATYPE_STRUCT $P0[1] = 3 $P0[2] = .DATATYPE_FLOAT $P0[3] = .DATATYPE_DOUBLE $P0[4] = .DATATYPE_FLOATVAL .local pmc sv, buf sv = new ['StructView'], $P0 buf = sv.'alloc'() $N0 = 2.41241 sv[buf; 0] = $N0 sv[buf; 1] = $N0 sv[buf; 2] = $N0 $N1 = sv[buf; 0] $I0 = fp_like($N0, $N1, 0.0001) ok($I0, 'float roundtrip') $N1 = sv[buf; 1] $I0 = fp_like($N0, $N1, 0.000001) ok($I0, 'double roundtrip') $N1 = sv[buf; 2] $I0 = fp_like($N0, $N1, 0.000001) ok($I0, 'floatval roundtrip') .end .sub 'fp_like' .param num n1 .param num n2 .param num eps $N0 = n1 - n2 $N0 = abs $N0 $I0 = eps > $N0 .return ($I0) .end .sub 'test_explicit_sized_types' $P0 = new ['FixedPMCArray'], 3 $P0[0] = .DATATYPE_STRUCT $P0[1] = 1 $P0[2] = .DATATYPE_INT8 .local pmc sv sv = new ['StructView'], $P0 $I0 = sv.'size'() is($I0, 1, 'sizeof (struct { int8 c; })') $P0[2] = .DATATYPE_UINT16 sv = new ['StructView'], $P0 $I0 = sv.'size'() is($I0, 2, 'sizeof (struct { uint16 s; })') $P0[2] = .DATATYPE_UINT32 sv = new ['StructView'], $P0 $I0 = sv.'size'() is($I0, 4, 'sizeof (struct { int32 i; })') .end .sub 'test_struct_pad' $P0 = new ['FixedIntegerArray'], 5 $P0[0] = .DATATYPE_STRUCT $P0[1] = 3 $P0[2] = .DATATYPE_INT8 $P0[3] = .DATATYPE_INT32 $P0[4] = .DATATYPE_INT8 .local pmc sv, sv2 sv = new ['StructView'], $P0 $P0[1] = 1 $P0[2] = .DATATYPE_INT8 sv2 = new ['StructView'], $P0 $I0 = sv2.'size'() $P0[1] = 1 $P0[2] = .DATATYPE_INT32 sv2 = new ['StructView'], $P0 $I1 = sv2.'size'() $I0 *= 2 $I0 += $I1 $I1 = sv.'size'() $I2 = $I1 > $I0 ok($I2, 'sizeof poorly aligned struct greater than the sum of the sizes') $I0 = sv.'aligned_size'() $I2 = $I0 > $I1 ok($I2, 'aligned size of poorly aligned struct greater than size') .end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: pascserp.bef000644000765000765 26611533177634 20005 0ustar00bruce000000000000parrot-6.6.0/examples/pir/befunge58*00p010p>58*00g-|>0g#<1-10gg00g10v v98p00:+1g00< v67<> >1 v+g-1g< >*7+-! #v_v>^^< |%2pg0 1g00:< v p00*58< ^,<^48<>10g!|@ >52*,10g1+ :1 0p83 *- ! | v <list.in000644000765000765 774111567202625 20761 0ustar00bruce000000000000parrot-6.6.0/t/tools/dev/headerizer/testlib/* Copyright (C) 2010, Parrot Foundation. =head1 NAME src/list.c - Implementation of double linked lists. =head1 DESCRIPTION This code implements double linked list of GCable objects. =cut */ #include "parrot/parrot.h" #include "parrot/list.h" /* HEADERIZER HFILE: include/parrot/list.h */ /* HEADERIZER BEGIN: static */ /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */ /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */ /* HEADERIZER END: static */ /* =over 4 =item C Allocate a doubly link list =cut */ PARROT_EXPORT PARROT_CANNOT_RETURN_NULL struct Linked_List* Parrot_list_new(SHIM_INTERP) { ASSERT_ARGS(Parrot_list_new) Linked_List *res = (Linked_List*)mem_sys_allocate_zeroed(sizeof (Linked_List)); return res; } /* =item C Destroy the specified list (free up memory associated with the list) =cut */ PARROT_EXPORT void Parrot_list_destroy(SHIM_INTERP, ARGMOD(Linked_List* list)) { ASSERT_ARGS(Parrot_list_destroy) mem_sys_free(list); } /* =item C Append an item to the list =cut */ PARROT_EXPORT void Parrot_list_append(SHIM_INTERP, ARGMOD(Linked_List *list), ARGMOD(List_Item_Header *item)) { ASSERT_ARGS(Parrot_list_append) item->prev = item->next = NULL; if (list->last) { item->prev = list->last; list->last->next = item; } list->last = item; if (!list->first) list->first = item; list->count++; #ifndef NDEBUG item->owner = list; #endif } /* =item C Remove an item from the list, returning the (pointer to) item =cut */ PARROT_EXPORT PARROT_CAN_RETURN_NULL List_Item_Header* Parrot_list_remove(SHIM_INTERP, ARGMOD(Linked_List *list), ARGMOD(List_Item_Header *item)) { ASSERT_ARGS(Parrot_list_remove) List_Item_Header *next = item->next; List_Item_Header *prev = item->prev; PARROT_ASSERT(list == item->owner); /* First item */ if (list->first == item) list->first = next; if (list->last == item) list->last = prev; if (prev) prev->next = next; if (next) next->prev = prev; list->count--; return item; } /* =item C Pop an item off the list - i.e. get the first item in the list and remove it. =cut */ PARROT_EXPORT PARROT_CAN_RETURN_NULL List_Item_Header* Parrot_list_pop(PARROT_INTERP, ARGIN(Linked_List *list)) { ASSERT_ARGS(Parrot_list_pop) List_Item_Header *ret = list->first; if (ret) LIST_REMOVE(list, ret); return ret; } /* =item C Check the validity of the list =cut */ PARROT_EXPORT INTVAL Parrot_list_check(SHIM_INTERP, ARGIN(Linked_List *list)) { ASSERT_ARGS(Parrot_list_check) List_Item_Header *tmp = list->first; size_t counter = 0; while (tmp) { List_Item_Header *next = tmp->next; PARROT_ASSERT(tmp->owner == list); tmp = next; ++counter; PARROT_ASSERT(counter <= list->count); } return 1; } /* =item C Returns True if the is in the list =cut */ PARROT_EXPORT INTVAL Parrot_list_contains(SHIM_INTERP, ARGIN(Linked_List *list), ARGIN(List_Item_Header *item)) { ASSERT_ARGS(Parrot_list_contains) List_Item_Header *tmp = list->first; #ifndef NDEBUG if (item->owner != list) return 0; #endif while (tmp) { if (tmp == item) return 1; tmp = tmp->next; } return 0; } /* =back =cut */ /* * Local variables: * c-file-style: "parrot" * End: * vim: expandtab shiftwidth=4: */ 32-protoregex.t000644000765000765 133012101554067 17357 0ustar00bruce000000000000parrot-6.6.0/ext/nqp-rx/t/nqp#!./parrot-nqp # test protoregexes in grammars plan(6); grammar ABC { token TOP { .* } proto token symbols { <...> } token symbols:sym { } token symbols:sym { } token symbols:sym { $=['!'] } token symbols:sym<===> { } } my $/ := ABC.parse('abcdef'); ok( ?$/ , 'successfully matched grammar' ); ok( $/ eq 'abcdef', 'successful string match' ); ok( $ eq 'abc', 'successful protoregex match'); ok( $ eq 'abc', 'correct proto candidate match' ); $/ := ABC.parse('adef'); ok( ?$/ , 'successfully matched grammar' ); $/ := ABC.parse('xxx'); ok( !$/ , 'successfully failed protoregex match' ); post.pir000644000765000765 262011656271050 15417 0ustar00bruce000000000000parrot-6.6.0/examples/io#!parrot # Copyright (C) 2010, Parrot Foundation. .include 'iglobals.pasm' .sub 'send_archive_to_smolder' :main .local pmc config $P0 = getinterp config = $P0[.IGLOBALS_CONFIG_HASH] .local pmc contents contents = new 'ResizablePMCArray' # by couple push contents, 'architecture' $S0 = config['cpuarch'] push contents, $S0 push contents, 'platform' $S0 = config['osname'] push contents, $S0 push contents, 'revision' $S0 = config['revision'] push contents, $S0 push contents, 'username' push contents, 'parrot-autobot' push contents, 'password' push contents, 'qa_rocks' push contents, 'comments' push contents, "EXPERIMENTAL LWP.pir" push contents, 'report_file' $P0 = new 'FixedStringArray' set $P0, 1 $P0[0] = 't/archive/parrot_test_run.tar.gz' push contents, $P0 load_bytecode 'LWP/UserAgent.pir' .const string url = 'http://smolder.parrot.org/app/projects/process_add_report/1' .local pmc ua, response ua = new ['LWP';'UserAgent'] ua.'env_proxy'() ua.'show_progress'(1) response = ua.'post'(url, contents :flat, 'form-data' :named('Content-Type'), 'close' :named('Connection')) $I0 = response.'code'() unless $I0 == 302 goto L1 $S0 = response.'content'() say $S0 L1: .end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: packfile.t000644000765000765 2437511715102036 14502 0ustar00bruce000000000000parrot-6.6.0/t/pmc#!./parrot # Copyright (C) 2006-2010, Parrot Foundation. =head1 NAME t/pmc/packfile.t - test the Packfile PMC =head1 SYNOPSIS % make test_prep % prove t/pmc/packfile.t =head1 DESCRIPTION Tests the Packfile PMC. =cut .include 't/pmc/testlib/packfile_common.pir' .include 'except_types.pasm' .sub main :main .include 'test_more.pir' plan(45) 'test_new'() 'test_set_string_native'() 'test_get_string'() 'test_set_string'() 'test_get_integer_keyed_str'() 'test_set_integer_keyed_str'() 'test_get_directory'() 'test_load'() 'test_pack_fresh_packfile'() 'test_pack'() skip(2, "test_synonyms crash on many platforms. See GH #514") # 'test_synonyms'() .end # Packfile constructor .sub 'test_new' .local pmc pf pf = new ['Packfile'] $I0 = defined pf ok($I0, 'new') # Make sure the mark vtable function is exercised sweep 1 .tailcall _check_header(pf) .end .sub 'test_set_string_native' .local pmc pf, eh .local int result eh = new ['ExceptionHandler'] eh.'handle_types'(.EXCEPTION_MALFORMED_PACKFILE) set_label eh, catch push_eh eh pf = new ['Packfile'] pf = 'This is not data with a valid packfile format' result = 0 goto end catch: result = 1 end: pop_eh is(result, 1, 'set_string_native with invalid data throws') .end .sub 'test_get_string' .local pmc pf, eh pf = new ['Packfile'] $S0 = pf["uuid"] ok(1, 'get_string(uuid)') # Requesting unknown key should throw exception eh = new ['ExceptionHandler'] eh.'handle_types'(.EXCEPTION_KEY_NOT_FOUND) set_label eh, unknown_key push_eh eh $S0 = pf["foo"] pop_eh ok(0, "get_string_keyed_int return unknown key") .return () unknown_key: pop_eh ok(1, "get_string_keyed_int handle unknown key properly") .return () .end .sub 'test_set_string' .local pmc pf pf = new ['Packfile'] pf["uuid"] = "fe9ab64082e0f6bbbd7b1e8264127908" ok(1, 'set_string(uuid)') # Special check for 0 $S0 = "\0" $I0 = length $S0 is($I0, 1, "Length is 1") pf["uuid"] = $S0 $S1 = pf["uuid"] $I1 = length $S1 is($I1, 1, "Fetched length is 1") # Requesting unknown key should throw exception push_eh unknown_key pf["foo"] = "fe9ab64082e0f6bbbd7b1e8264127908" pop_eh ok(0, "set_string_keyed_int set unknown key") .return () unknown_key: pop_eh ok(1, "set_string_keyed_int handle unknown key properly") .return () .end # Compose the message for the given key .sub 'keyed_str_msg' .param string key .local string msg msg = 'get_integer_keyed_str(' msg = concat msg, key msg = concat msg, ')' .return(msg) .end .sub 'set_keyed_str_msg' .param string key .local string msg msg = 'set_integer_keyed_str(' msg = concat msg, key msg = concat msg, ')' .return(msg) .end # Check the given key in the Packfile pf .sub 'do_get_integer_keyed_str' .param pmc pf .param string key .local string msg .local int result msg = 'keyed_str_msg'(key) result = 0 push_eh fail $I0 = pf[key] result = 1 goto end fail: .get_results($P0) pop_eh end: ok(result, msg) .end # Create a list of the keys for the integer attributes .sub 'integer_keys' .local pmc keys keys = new ['ResizableStringArray'] push keys, 'wordsize' push keys, 'byteorder' push keys, 'fptype' push keys, 'version_major' push keys, 'version_minor' push keys, 'version_patch' push keys, 'bytecode_major' push keys, 'bytecode_minor' push keys, 'uuid_type' .return(keys) .end # Some keys are still not handled in set_integer_keyed_str # Use this list for its test .sub 'integer_keys_s' .local pmc keys keys = new ['ResizableStringArray'] push keys, 'version_major' push keys, 'version_minor' push keys, 'version_patch' push keys, 'uuid_type' .return(keys) .end .sub 'test_get_integer_keyed_str' .local pmc pf, keys .local int nkeys, i keys = 'integer_keys'() nkeys = elements keys push_eh load_error pf = _pbc() pop_eh i = 0 nextkey: $S0 = keys[i] do_get_integer_keyed_str(pf, $S0) inc i if i < nkeys goto nextkey # Requesting unknown key should throw exception push_eh unknown_key $I3 = pf["foo"] ok(0, "get_integer_keyed_str return unknown key") .return () unknown_key: pop_eh ok(1, "get_integer_keyed_str handle unknown key properly") .return () # On load error report a failure for each test load_error: .get_results($P0) pop_eh i = 0 nexterr: $S0 = keys[i] $S0 = keyed_str_msg($S0) report_load_error($P0, $S0) inc i if i < nkeys goto nexterr report_load_error($P0, "get_integer_keyed_str unknown key") .return() .end .sub 'test_set_integer_keyed_str' .local pmc pf, keys, saved .local int nkeys, i, value, check .local string skey, msg keys = 'integer_keys_s'() nkeys = elements keys pf = new ['Packfile'] saved = new ['FixedIntegerArray'], nkeys # For each key get its value, set it modified and save the new value # The modified value may be invalid, but we are not going to pack it, # so it shouldn't fail here. i = 0 set_next: skey = keys[i] value = pf[skey] inc value pf[skey] = value saved[i] = value inc i if i < nkeys goto set_next # Read new values and compare with the saved ones i = 0 get_next: skey = keys[i] value = pf[skey] check = saved[i] msg = 'set_keyed_str_msg'(skey) is(value, check, msg) inc i if i < nkeys goto get_next i = 0 push_eh unknown_key pf["foo"] = value goto done unknown_key: i = 1 done: pop_eh is(i, 1, "set_integer_keyed_str handle unknown key properly") .return() .end # Packfile.get_directory .sub 'test_get_directory' .local pmc pf pf = new ['Packfile'] $P0 = pf.'get_directory'() isa_ok($P0, 'PackfileDirectory') .end # PackfileSegment.pack (via subclass PackfileDirectory) .sub 'test_get_directory' .local pmc pf, pfdir push_eh load_error pf = _pbc() pop_eh pfdir = pf.'get_directory'() $S0 = pfdir.'pack'() $I0 = length $S0 $I1 = cmp $I0, 0 ok($I1, 'get_directory') .return() load_error: .get_results($P0) pop_eh report_load_error($P0, 'get_directory') .return() .end # Packfile.set_string_native # Check that packfile was loaded properly and set various attributes .sub 'test_load' .local pmc pf push_eh load_error pf = _pbc() pop_eh .tailcall _check_header(pf) load_error: .get_results($P0) pop_eh report_load_error($P0, "Wordsize set") report_load_error($P0, "version_major set") report_load_error($P0, "bytecode_major set") .return() .end # Helper sub to check fields in Packfile header .sub '_check_header' .param pmc pf # wordsize always greater than 0 $I0 = pf["wordsize"] ok($I0, "Wordsize set") # We are living in post-1.0 era. $I0 = pf["version_major"] ok($I0, "version_major set") $I0 = pf["bytecode_major"] ok($I0, "bytecode_major set") .end # Create very simple Packfile and pack it .sub 'test_pack_fresh_packfile' .local pmc pf, pfdir pf = new 'Packfile' pfdir = pf.'get_directory'() $P1 = new 'PackfileRawSegment' pfdir["BYTECODE_t/pmc/packfile.t"] = $P1 $P2 = new 'PackfileConstantTable' # float constants $P2[0] = 42.0 # string constants $P2[0] = "42" # PMC constants $P3 = new 'Integer' $P3 = 42 $P2[0] = $P3 $P4 = new 'Key' $P4 = 42 $P2[1] = $P4 pfdir["CONSTANTS_t/pmc/packfile.t"] = $P2 # Set uuid_type pf['uuid_type'] = 1 $S0 = pf # Pack it ok(1, "PackFile packed") # $P1 = new ['FileHandle'] # $P1.'open'("/tmp/1.pbc", "w") # $P1.'print'($S0) # $P1.'close'() pf = new 'Packfile' pf = $S0 ok(1, "PackFile unpacked after pack") $I0 = pf['uuid_type'] is($I0, 1, "uuid_type preserved") # Check unpacked ConstTable $P0 = _find_segment_by_type(pf, "PackfileConstantTable") $I0 = defined $P0 ok($I0, "ConstantTable unpacked") $I0 = $P0.'num_count'() is($I0, 1, " and contains 1 number constants") $I0 = $P0.'str_count'() is($I0, 1, " and contains 1 string constant") $I0 = $P0.'pmc_count'() is($I0, 2, " and contains 2 pmc constants") $N0 = $P0[0] is($N0, 42.0, " first number") $S0 = $P0[0] is($S0, "42", " first string") $P1 = $P0[0] isa_ok($P1, "Integer") $I0 = $P1 is($I0, 42, " with proper value") $P1 = $P0[1] isa_ok($P1, "Key") .end # Packfile.pack. # Check that unpack-pack produce correct result. .sub 'test_pack' .local string filename, orig push_eh load_error $S0 = '_filename'() $P0 = new ['FileHandle'] $P0.'open'($S0, 'rb') orig = $P0.'readall'() .local pmc packfile packfile = new 'Packfile' packfile = orig pop_eh # Loaded packfile can be from different platform/config, # packing and unpacking again to avoid that differences. .local string first, second # Pack first = packfile .local pmc packfilesecond packfilesecond = new 'Packfile' packfilesecond = first second = packfilesecond is(first, second, 'pack produced same result twice: TT #1614') .return() load_error: .get_results($P0) pop_eh report_load_error($P0, 'pack produced same result twice') .return() .end # Test pack/set_string unpack/get_string equivalency .sub 'test_synonyms' .local pmc pf push_eh load_error pf = '_pbc'() pop_eh $S0 = pf $S1 = pf.'pack'() $I0 = cmp $S0, $S1 is($I0, 0, "pack and get_string are synonyms") # Unpack data in two ways $P0 = new ['Packfile'] $P0 = $S0 $P1 = new ['Packfile'] $P1.'unpack'($S0) $S0 = $P0 $S1 = $P1 $I0 = cmp $S0, $S1 is($I0, 0, "unpack and set_string are synonyms") .return() load_error: .get_results($P0) pop_eh report_load_error($P0, "pack and get_string are synonyms") report_load_error($P0, "unpack and set_string are synonyms") .return() .end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: hll.c000644000765000765 3212212233541455 13224 0ustar00bruce000000000000parrot-6.6.0/src/* Copyright (C) 2005-2011, Parrot Foundation. =head1 NAME src/hll.c - High Level Language support =head1 DESCRIPTION The Parrot core sometimes has to create new PMCs which should map to the current HLL's defaults. The current language and a typemap provides this feature. =head1 DATA interp->HLL_info @HLL_info = [ [ hll_name, hll_lib, { core_type => HLL_type, ... }, namespace, hll_id ], ... ] =head2 Functions =over 4 =cut */ #include "parrot/parrot.h" #include "parrot/dynext.h" #include "pmc/pmc_callcontext.h" #include "pmc/pmc_fixedintegerarray.h" #include "hll.str" /* HEADERIZER HFILE: include/parrot/hll.h */ /* HEADERIZER BEGIN: static */ /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */ PARROT_CANNOT_RETURN_NULL PARROT_WARN_UNUSED_RESULT static PMC* new_hll_entry(PARROT_INTERP, ARGIN(STRING *entry_name)) __attribute__nonnull__(1) __attribute__nonnull__(2); #define ASSERT_ARGS_new_hll_entry __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(entry_name)) /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */ /* HEADERIZER END: static */ /* for shared HLL data, do COW stuff */ #define START_READ_HLL_INFO(interp, hll_info) #define END_READ_HLL_INFO(interp, hll_info) /* =item C Create a new HLL information table entry. Takes an interpreter name and (optional) entry name. Returns a pointer to the new entry. Used by Parrot_hll_register_HLL. =cut */ PARROT_CANNOT_RETURN_NULL PARROT_WARN_UNUSED_RESULT static PMC* new_hll_entry(PARROT_INTERP, ARGIN(STRING *entry_name)) { ASSERT_ARGS(new_hll_entry) PMC * const hll_info = interp->HLL_info; const INTVAL id = VTABLE_elements(interp, hll_info); PMC *entry_id; PMC * const entry = Parrot_pmc_new_init_int(interp, enum_class_FixedPMCArray, e_HLL_MAX); if (entry_name && !STRING_IS_EMPTY(entry_name)) { VTABLE_set_pmc_keyed_str(interp, hll_info, entry_name, entry); } else VTABLE_push_pmc(interp, hll_info, entry); entry_id = Parrot_pmc_new_init_int(interp, enum_class_Integer, id); VTABLE_set_pmc_keyed_int(interp, entry, e_HLL_id, entry_id); VTABLE_push_pmc(interp, interp->HLL_entries, entry); return entry; } /* =item C Initialises the HLL_info and HLL_namespace fields of the interpreter structure. Registers the default HLL namespace "parrot". =cut */ void Parrot_hll_init_HLL(PARROT_INTERP) { ASSERT_ARGS(Parrot_hll_init_HLL) interp->HLL_info = Parrot_pmc_new(interp, enum_class_OrderedHash); interp->HLL_namespace = Parrot_pmc_new(interp, enum_class_ResizablePMCArray); interp->HLL_entries = Parrot_pmc_new(interp, enum_class_ResizablePMCArray); Parrot_hll_register_HLL(interp, CONST_STRING(interp, "parrot")); } /* =item C Register the HLL with the given STRING name C in the interpreter. If the HLL has already been registered, the ID of the HLL is returned. Otherwise the HLL is registered, a corresponding HLL namespace is created, and the HLL ID is returned. If there is an error, C<-1> is returned. =cut */ PARROT_EXPORT PARROT_IGNORABLE_RESULT INTVAL Parrot_hll_register_HLL(PARROT_INTERP, ARGIN(STRING *hll_name)) { ASSERT_ARGS(Parrot_hll_register_HLL) PMC *entry, *name, *ns_hash, *hll_info; INTVAL idx; /* TODO LOCK or disallow in threads */ idx = Parrot_hll_get_HLL_id(interp, hll_name); if (idx >= 0) return idx; hll_info = interp->HLL_info; idx = VTABLE_elements(interp, hll_info); entry = new_hll_entry(interp, hll_name); /* register HLL name */ name = Parrot_pmc_new(interp, enum_class_String); VTABLE_set_string_native(interp, name, hll_name); VTABLE_set_pmc_keyed_int(interp, entry, e_HLL_name, name); /* create HLL namespace */ hll_name = Parrot_str_downcase(interp, VTABLE_get_string(interp, name)); /* HLL type mappings aren't yet created, we can't create * a namespace in HLL's flavor yet - maybe promote the * ns_hash to another type, if mappings provide one * XXX - FIXME */ ns_hash = Parrot_ns_make_namespace_keyed_str(interp, interp->root_namespace, hll_name); /* cache HLL's toplevel namespace */ VTABLE_set_pmc_keyed_int(interp, interp->HLL_namespace, idx, ns_hash); /* create HLL typemap hash */ VTABLE_set_pmc_keyed_int(interp, entry, e_HLL_typemap, PMCNULL); return idx; } /* =item C Returns the ID number of the HLL with the given name. The default HLL namespace C has an ID number of 0. On error, or if an HLL with the given name does not exist, returns -1. =cut */ PARROT_EXPORT PARROT_WARN_UNUSED_RESULT INTVAL Parrot_hll_get_HLL_id(PARROT_INTERP, ARGIN(STRING *hll_name)) { ASSERT_ARGS(Parrot_hll_get_HLL_id) PMC * entry; PMC * const hll_info = interp->HLL_info; INTVAL i = -1; if (STRING_IS_NULL(hll_name)) return i; START_READ_HLL_INFO(interp, hll_info); entry = VTABLE_get_pmc_keyed_str(interp, hll_info, hll_name); if (!PMC_IS_NULL(entry)) { PMC * const entry_id = VTABLE_get_pmc_keyed_int(interp, entry, e_HLL_id); i = VTABLE_get_integer(interp, entry_id); } END_READ_HLL_INFO(interp, hll_info); return i; } /* =item C Returns the STRING name of the HLL with the given C number. If the id is out of range or does not exist, the NULL value is returned instead. Note that some HLLs are anonymous and so might also return NULL. =cut */ PARROT_EXPORT PARROT_WARN_UNUSED_RESULT PARROT_CANNOT_RETURN_NULL STRING * Parrot_hll_get_HLL_name(PARROT_INTERP, INTVAL id) { ASSERT_ARGS(Parrot_hll_get_HLL_name) PMC * const hll_info = interp->HLL_info; const INTVAL nelements = VTABLE_elements(interp, hll_info); PMC *entry, *name_pmc; if (id < 0 || id >= nelements) return STRINGNULL; START_READ_HLL_INFO(interp, hll_info); entry = VTABLE_get_pmc_keyed_int(interp, hll_info, id); name_pmc = VTABLE_get_pmc_keyed_int(interp, entry, e_HLL_name); END_READ_HLL_INFO(interp, hll_info); /* loadlib-created 'HLL's are nameless */ if (PMC_IS_NULL(name_pmc)) return STRINGNULL; else return VTABLE_get_string(interp, name_pmc); } /* =item C Register a type mapping of C<< core_type => hll_type >> for the given HLL. =cut */ PARROT_EXPORT void Parrot_hll_register_HLL_type(PARROT_INTERP, INTVAL hll_id, INTVAL core_type, INTVAL hll_type) { ASSERT_ARGS(Parrot_hll_register_HLL_type) if (hll_id == Parrot_hll_get_HLL_id(interp, CONST_STRING(interp, "parrot"))) Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, "Cannot map without an HLL"); else { PMC * const hll_info = interp->HLL_info; const INTVAL n = VTABLE_elements(interp, hll_info); if (hll_id >= n) Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_GLOBAL_NOT_FOUND, "no such HLL ID (%vd)", hll_id); else { PMC *type_array; PMC * const entry = VTABLE_get_pmc_keyed_int(interp, hll_info, hll_id); PARROT_ASSERT(!PMC_IS_NULL(entry)); type_array = VTABLE_get_pmc_keyed_int(interp, entry, e_HLL_typemap); if (PMC_IS_NULL(type_array)) { int i; type_array = Parrot_pmc_new(interp, enum_class_FixedIntegerArray); VTABLE_set_integer_native(interp, type_array, PARROT_MAX_CLASSES); for (i = 0; i < PARROT_MAX_CLASSES; ++i) VTABLE_set_integer_keyed_int(interp, type_array, i, i); VTABLE_set_pmc_keyed_int(interp, entry, e_HLL_typemap, type_array); } VTABLE_set_integer_keyed_int(interp, type_array, core_type, hll_type); } } } /* =item C Get an equivalent HLL type number for the language C. If the given HLL doesn't remap the given type, or if C is the special value C, returns C unchanged. =cut */ PARROT_EXPORT INTVAL Parrot_hll_get_HLL_type(PARROT_INTERP, INTVAL hll_id, INTVAL core_type) { ASSERT_ARGS(Parrot_hll_get_HLL_type) if (hll_id == PARROT_HLL_NONE || hll_id == 0) return core_type; if (hll_id < 0) Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_GLOBAL_NOT_FOUND, "no such HLL ID (%vd)", hll_id); else { PMC * const hll_info = interp->HLL_info; PMC *entry, *type_array; Parrot_FixedIntegerArray_attributes *type_array_attrs; START_READ_HLL_INFO(interp, hll_info); entry = VTABLE_get_pmc_keyed_int(interp, hll_info, hll_id); END_READ_HLL_INFO(interp, hll_info); if (PMC_IS_NULL(entry)) Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_GLOBAL_NOT_FOUND, "no such HLL ID (%vd)", hll_id); type_array = VTABLE_get_pmc_keyed_int(interp, entry, e_HLL_typemap); if (PMC_IS_NULL(type_array)) return core_type; if (core_type >= PARROT_MAX_CLASSES || core_type < 0) { Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_OUT_OF_BOUNDS, "FixedIntegerArray: index out of bounds!"); } type_array_attrs = PARROT_FIXEDINTEGERARRAY(type_array); return type_array_attrs->int_array[core_type]; } } /* =item C Return an equivalent PMC type number according to the HLL settings in the current context. If no type is registered, returns C. =cut */ PARROT_EXPORT INTVAL Parrot_hll_get_ctx_HLL_type(PARROT_INTERP, INTVAL core_type) { ASSERT_ARGS(Parrot_hll_get_ctx_HLL_type) const INTVAL hll_id = Parrot_pcc_get_HLL(interp, CURRENT_CONTEXT(interp)); if (!hll_id || hll_id == PARROT_HLL_NONE) return core_type; return Parrot_hll_get_HLL_type(interp, hll_id, core_type); } /* =item C Return root namespace of the current HLL. =cut */ PARROT_EXPORT PARROT_WARN_UNUSED_RESULT PARROT_CAN_RETURN_NULL PMC* Parrot_hll_get_ctx_HLL_namespace(PARROT_INTERP) { ASSERT_ARGS(Parrot_hll_get_ctx_HLL_namespace) return Parrot_hll_get_HLL_namespace(interp, Parrot_pcc_get_HLL(interp, CURRENT_CONTEXT(interp))); } /* =item C Return root namespace of the HLL with the ID of I. If C is the special value C, return the global root namespace. =cut */ PARROT_EXPORT PARROT_WARN_UNUSED_RESULT PARROT_CANNOT_RETURN_NULL PMC* Parrot_hll_get_HLL_namespace(PARROT_INTERP, int hll_id) { ASSERT_ARGS(Parrot_hll_get_HLL_namespace) if (hll_id == PARROT_HLL_NONE) return interp->root_namespace; return VTABLE_get_pmc_keyed_int(interp, interp->HLL_namespace, hll_id); } /* =item C Create all HLL namespaces that don't already exist. This is necessary when creating a new interpreter which shares an old interpreter's HLL_info. =cut */ PARROT_EXPORT void Parrot_hll_regenerate_HLL_namespaces(PARROT_INTERP) { ASSERT_ARGS(Parrot_hll_regenerate_HLL_namespaces) const INTVAL n = VTABLE_elements(interp, interp->HLL_info); INTVAL hll_id; /* start at one since the 'parrot' namespace should already have been * created */ for (hll_id = 1; hll_id < n; ++hll_id) { PMC *ns_hash = VTABLE_get_pmc_keyed_int(interp, interp->HLL_namespace, hll_id); if (PMC_IS_NULL(ns_hash) || ns_hash->vtable->base_type == enum_class_Undef) { STRING * hll_name = Parrot_hll_get_HLL_name(interp, hll_id); if (!hll_name) continue; hll_name = Parrot_str_downcase(interp, hll_name); /* XXX as in Parrot_hll_register_HLL() this needs to be fixed to use * the correct type of namespace. It's relatively easy to do that * here because the typemap already exists, but it is not currently * done for consistency. */ ns_hash = Parrot_ns_make_namespace_keyed_str(interp, interp->root_namespace, hll_name); VTABLE_set_pmc_keyed_int(interp, interp->HLL_namespace, hll_id, ns_hash); } } } /* =back =head1 AUTHOR Leopold Toetsch =head1 SEE ALSO F =cut */ /* * Local variables: * c-file-style: "parrot" * End: * vim: expandtab shiftwidth=4 cinoptions='\:2=2' : */ pmc_docs.t000644000765000765 643312312075407 15672 0ustar00bruce000000000000parrot-6.6.0/t/codingstd#! perl # Copyright (C) 2006-2014, Parrot Foundation. use strict; use warnings; use lib qw( . lib ../lib ../../lib ); use Test::More; use Parrot::Config qw(%PConfig); use Parrot::Distribution; use Parrot::Headerizer; =head1 NAME t/codingstd/pmc_docs.t - checks for missing function documentation =head1 SYNOPSIS # test all files % prove t/codingstd/pmc_docs.t # test specific files % perl t/codingstd/pmc_docs.t src/foo.pmc src/bar.pmc =head1 DESCRIPTION Checks that all PMC source files have documentation for each function declared. =cut my $DIST = Parrot::Distribution->new; my $headerizer = Parrot::Headerizer->new; my @files = @ARGV ? @ARGV : map {s/^$PConfig{build_dir}\///; $_} map {s/\\/\//g; $_} map {$_->path} $DIST->pmc_source_files(); plan tests => scalar @files; my %todos; while () { next if /^#/; next if /^\s*$/; chomp; $todos{$_} = 1; } my %all_files = (); # Traverse each file, analyzing each function declaration therein, then # post results in %all_files. foreach my $path (@files) { my $buf = $DIST->slurp($path); my @function_decls = $headerizer->extract_function_declarations($buf); # We start out asserting that every file will have documentation for each # of its function declarations. We then seek to contradict this # assertion. my %this_file = ( overall => 1 ); for my $function_decl (@function_decls) { my $escaped_decl = $headerizer->generate_documentation_signature($function_decl); $this_file{$function_decl}{esc} = $escaped_decl; if ( $buf =~ m/^\Q$escaped_decl\E$(.*?)^=cut/sm ) { my $docs = $1; $docs =~ s/\s//g; if ($docs eq '') { # boilerplate only $this_file{$function_decl}{status} = 0; $this_file{overall} = 0; } else { # documentation found $this_file{$function_decl}{status} = 1; } } else { # no documentation found $this_file{$function_decl}{status} = undef; $this_file{overall} = 0; } } $all_files{$path} = \%this_file; } foreach my $path (sort keys %all_files) { ok( $all_files{$path}{overall}, $path ) or diag( diagnosis( \%all_files, $path ) ); } sub diagnosis { my ($all_files_ref, $path) = @_; my $missing = ''; my $boilerplate = ''; my %this_file = %{ $all_files_ref->{$path} }; delete $this_file{overall}; foreach my $decl ( sort keys %this_file ) { if ( ! defined $this_file{$decl}{status} ) { $missing .= "$decl\n"; $missing .= "Need:\n"; $missing .= "$this_file{$decl}{esc}\n\n"; } elsif ( ! $this_file{$decl}{status} ) { $boilerplate .= "$this_file{$decl}{esc}\n\n"; } else { # docs! } } my $diagnosis = "$path\n"; $diagnosis .= "Undocumented functions:\n\n$missing" if $missing; $diagnosis .= "Boilerplate only:\n$boilerplate" if $boilerplate; return "$diagnosis"; } __DATA__ src/pmc/bigint.pmc src/pmc/callcontext.pmc src/pmc/class.pmc src/pmc/complex.pmc src/pmc/namespace.pmc src/pmc/object.pmc # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: 042-list_of_steps.t000644000765000765 351411533177644 17275 0ustar00bruce000000000000parrot-6.6.0/t/configure#! perl # Copyright (C) 2007, Parrot Foundation. # 042-list_of_steps.t use strict; use warnings; use Test::More tests => 6; use Carp; use lib qw( lib t/configure/testlib ); use Parrot::Configure; use Parrot::Configure::Options qw( process_options ); use Parrot::Configure::Step::List qw( get_steps_list ); my ($args, $step_list_ref) = process_options( { argv => [ ], mode => q{configure}, } ); ok(defined $args, "process_options returned successfully"); my $conf = Parrot::Configure->new; ok(defined $conf, "Parrot::Configure->new() returned okay"); my $first_step = q{init::zeta}; my @official_steps = get_steps_list(); eval { $conf->get_list_of_steps(); }; like ($@, qr/^list_of_steps not available until steps have been added/, "Got expected failure message when get_list_of_steps called too early" ); $conf->add_steps( $first_step, @official_steps ); my @list_of_steps = $conf->get_list_of_steps(); is_deeply( [ ( $first_step, @official_steps ) ], [ @list_of_steps ], "get_steps_list() and get_list_of_steps() returned same step names"); my $steps_ref = $conf->get_list_of_steps(); is_deeply( [ ( $first_step, @official_steps ) ], $steps_ref, "get_steps_list() and get_list_of_steps() returned same step names"); pass("Completed all tests in $0"); ################### DOCUMENTATION ################### =head1 NAME 042-list_of_steps.t - test C =head1 SYNOPSIS % prove t/configure/042-list_of_steps.t =head1 DESCRIPTION The files in this directory test functionality used by F. The tests in this file C. =head1 AUTHOR James E Keenan =head1 SEE ALSO Parrot::Configure, F. =cut # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: Matcher.nqp000644000765000765 500111533177636 22005 0ustar00bruce000000000000parrot-6.6.0/runtime/parrot/library/ProfTest # Copyright (C) 2010, Parrot Foundation. class ProfTest::Matcher is Hash; method new(*@wants) { self := (); for @wants -> $want { self.push($want); self.say("pushed a thing:"~$want.get_str); } self.push( ProfTest::Want::Goal.new() ); self; } method matches($profile) { my @backtracks := (); my $line_idx := 0; my $want_idx := 0; my $start_line := 0; my $max_line := +$profile.profile_array; my %curr_line; my $curr_want; while ($line_idx < $max_line) { %curr_line := $profile.profile_array[$line_idx]; $curr_want := self[$want_idx]; self.say("current want: "~$curr_want.get_str); my $line_desc; if self { $line_desc := "current line: " ~ %curr_line ~'('; for %curr_line -> $k { unless $k eq 'type' { $line_desc := "$line_desc :$k(" ~ %curr_line{$k} ~") "; } } $line_desc := $line_desc ~ ")"; } self.say($line_desc); if $curr_want.goal { self.say("SUCCESS\n"); return 1; } elsif ($curr_want.accepts(%curr_line)) { self.say("ACCEPTED"); $line_idx++; # +0 is a workaround for crappy lvalue semantics @backtracks.push( [$line_idx+0, $want_idx+0] ); self.say("saving line $line_idx, want $want_idx"); self.say("now have "~ ~@backtracks ~ " elements in the stack"); $want_idx++; } else { self.say("REJECTED"); if !@backtracks && $start_line == $max_line { self.say("FAILURE\n"); return 0; } elsif !@backtracks { $start_line++; $line_idx := $start_line+0; self.say("FAILURE: restarting at $line_idx\n"); } else { my @a := @backtracks.pop; $line_idx := @a[0]; $want_idx := @a[1]; self.say("backtracking to line $line_idx, want $want_idx"); self.say("now have "~ ~@backtracks ~ " elements in the stack"); } } self.say(''); } } method say($str) { if self { pir::say($str); } } method debugging($i) { self := $i+0; } # Local Variables: # mode: perl6 # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=perl crow.pir000644000765000765 433612134032542 15736 0ustar00bruce000000000000parrot-6.6.0/tools/release#! ./parrot # Copyright (C) 2007-2008, Parrot Foundation. =head1 TITLE crow.pir -- Make noise about the new Parrot release =head1 DESCRIPTION This utility is used to help Release Managers format announcement messages. It uses a *very* simple and fast templating system, described in the related module, L. =head1 SYNOPSIS # see % parrot tools/release/crow.pir --help =cut .sub 'main' :main .param pmc args load_bytecode 'Crow.pbc' .local pmc exports, curr_namespace, test_namespace curr_namespace = get_namespace test_namespace = get_namespace ['Crow'] exports = split ' ', 'get_news get_args get_message_digests process' test_namespace.'export_to'(curr_namespace, exports) .local pmc opts opts = get_args(args) unless null opts goto got_opts opts = new 'Hash' got_opts: .local pmc templates templates = 'get_json'('tools/release/templates.json') .local string template, type type = opts['type'] if type != '' goto got_type type = 'text' got_type: template = 'get_template'(templates, type) .local pmc data data = 'get_json'('tools/release/release.json') .local string version version = data['release.version'] $S0 = concat type, '.news' $I0 = templates[$S0] if $I0 goto get_news data['NEWS'] = '' goto process get_news: $S0 = 'get_news'(version) data['NEWS'] = $S0 process: $S0 = 'get_message_digests'(version) data['message_digests'] = $S0 .local string result result = process(template, data) say result .end .sub 'get_json' .param string filename load_bytecode 'Config/JSON.pbc' .local pmc exports, curr_namespace, test_namespace curr_namespace = get_namespace test_namespace = get_namespace [ 'Config';'JSON' ] exports = split ' ', 'ReadConfig' test_namespace.'export_to'(curr_namespace, exports) .local pmc result result = ReadConfig(filename) .return (result) .end .sub 'get_template' .param pmc templates .param string type $S0 = concat type, '.text' $S1 = templates[$S0] .return ($S1) .end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: pge_globs.t000644000765000765 625211567202625 16642 0ustar00bruce000000000000parrot-6.6.0/t/compilers/pge#! perl # Copyright (C) 2001-2005, Parrot Foundation. use strict; use warnings; use lib qw( t . lib ../lib ../../lib ); use Test::More; use Parrot::Test tests => 28; use Parrot::Test::PGE; =head1 NAME t/library/pge_globs.t =head1 SYNOPSIS % prove -Ilib t/library/pge_globs.t =head1 DESCRIPTION Parrot Grammar Engine tests of globs =cut ## literal match pgeglob_is( '', '', 'literal: empty string, empty pattern' ); pgeglob_isnt( '0', '', 'literal: empty pattern' ); pgeglob_isnt( '', '0', 'literal: empty string' ); pgeglob_is( 'abc', 'abc', 'literal' ); pgeglob_isnt( 'abc', 'abd', 'literal' ); ## wildcards pgeglob_is( 'bznza', 'b?n*a', "glob wildcards" ); pgeglob_is( 'bana', 'b?n*a', "glob wildcards" ); pgeglob_isnt( 'bnana', 'b?n*a', "glob wildcards" ); pgeglob_is( 'bnan', '?n?*', "glob wildcards" ); pgeglob_is( 'ana', '?n?*', "glob wildcards" ); pgeglob_isnt( 'an', '?n?*', "glob wildcards" ); ## enumerated chars pgeglob_is( 'orange', '[go]range', 'glob enumerated characters' ); pgeglob_is( 'grange', '[go]range', 'glob enumerated characters' ); pgeglob_isnt( 'ggrange', '[go]range', 'glob enumerated characters' ); pgeglob_isnt( 'borange', '[go]range', 'glob enumerated characters' ); pgeglob_isnt( 'arange', '[go]range', 'glob enumerated characters' ); pgeglob_is( 'a', '[^0-9]', 'glob enumerated characters' ); pgeglob_isnt( '4', '[^0-9]', 'glob enumerated characters' ); pgeglob_isnt( '0', '[^0-9]', 'glob enumerated characters' ); pgeglob_isnt( '9', '[^0-9]', 'glob enumerated characters' ); pgeglob_isnt( '4a', '[^0-9]', 'glob enumerated characters' ); pgeglob_isnt( 'aa', '[^0-9]', 'glob enumerated characters' ); pgeglob_is( '_', '[A-z]', '_ is between A and z' ); ## empty string pgeglob_is( '', '*', 'glob empty string' ); pgeglob_isnt( '', '?', 'glob empty string' ); pgeglob_isnt( '', '[0]', 'glob empty string' ); pgeglob_isnt( '', '[^0]', 'glob empty string' ); ## alternate pir_output_is( <<'CODE', <<'OUT', "Glob, alternate" ); .sub _main :main load_bytecode "PGE.pbc" load_bytecode "PGE/Glob.pbc" .local pmc rule, globc globc = compreg "PGE::Glob" rule = globc.'compile'("{app,bet,cod}a") $P1 = rule("appa") if $P1 goto ok1 print "not " ok1: print "ok1\n" $P1 = rule("coda") if $P1 goto ok2 print "not " ok2: print "ok2\n" $P1 = rule("beta") if $P1 goto ok3 print "not " ok3: print "ok3\n" $P1 = rule("bet") unless $P1 goto ok4 print "not " ok4: print "ok4\n" $P1 = rule("alfa") unless $P1 goto ok5 print "not " ok5: print "ok5\n" rule = globc.'compile'("*{1,two,three}") $P1 = rule("1") if $P1 goto ok6 print "not " ok6: print "ok6\n" $P1 = rule("ptwo") if $P1 goto ok7 print "not " ok7: print "ok7\n" $P1 = rule("al") unless $P1 goto ok8 print "not " ok8: print "ok8\n" $P1 = rule("three") if $P1 goto ok9 print "not " ok9: print "ok9\n" $P1 = rule("twop") unless $P1 goto ok10 print "not " ok10: print "ok10\n" $P1 = rule("1atwo") if $P1 goto ok11 print "not " ok11: print "ok11\n" .end CODE ok1 ok2 ok3 ok4 ok5 ok6 ok7 ok8 ok9 ok10 ok11 OUT # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: PullParserTextToken.pm000644000765000765 612411644422074 20513 0ustar00bruce000000000000parrot-6.6.0/lib/Pod/Simple require 5; package Pod::Simple::PullParserTextToken; use Pod::Simple::PullParserToken (); use strict; use vars qw(@ISA $VERSION); @ISA = ('Pod::Simple::PullParserToken'); $VERSION = '3.19'; sub new { # Class->new(text); my $class = shift; return bless ['text', @_], ref($class) || $class; } # Purely accessors: sub text { (@_ == 2) ? ($_[0][1] = $_[1]) : $_[0][1] } sub text_r { \ $_[0][1] } 1; __END__ =head1 NAME Pod::Simple::PullParserTextToken -- text-tokens from Pod::Simple::PullParser =head1 SYNOPSIS (See L) =head1 DESCRIPTION When you do $parser->get_token on a L, you might get an object of this class. This is a subclass of L and inherits all its methods, and adds these methods: =over =item $token->text This returns the text that this token holds. For example, parsing CZ<> will return a C start-token, a text-token, and a C end-token. And if you want to get the "foo" out of the text-token, call C<< $token->text >> =item $token->text(I) This changes the string that this token holds. You probably won't need to do this. =item $token->text_r() This returns a scalar reference to the string that this token holds. This can be useful if you don't want to memory-copy the potentially large text value (well, as large as a paragraph or a verbatim block) as calling $token->text would do. Or, if you want to alter the value, you can even do things like this: for ( ${ $token->text_r } ) { # Aliases it with $_ !! s/ The / the /g; # just for example if( 'A' eq chr(65) ) { # (if in an ASCII world) tr/\xA0/ /; tr/\xAD//d; } ...or however you want to alter the value... } =back You're unlikely to ever need to construct an object of this class for yourself, but if you want to, call C<< Pod::Simple::PullParserTextToken->new( I ) >> =head1 SEE ALSO L, L, L =head1 SUPPORT Questions or discussion about POD and Pod::Simple should be sent to the pod-people@perl.org mail list. Send an empty email to pod-people-subscribe@perl.org to subscribe. This module is managed in an open GitHub repository, L. Feel free to fork and contribute, or to clone L and send patches! Patches against Pod::Simple are welcome. Please send bug reports to . =head1 COPYRIGHT AND DISCLAIMERS Copyright (c) 2002 Sean M. Burke. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. This program is distributed in the hope that it will be useful, but without any warranty; without even the implied warranty of merchantability or fitness for a particular purpose. =head1 AUTHOR Pod::Simple was created by Sean M. Burke . But don't bother him, he's retired. Pod::Simple is maintained by: =over =item * Allison Randal C =item * Hans Dieter Pearcey C =item * David E. Wheeler C =back =cut test_c.in000644000765000765 130411567202622 16626 0ustar00bruce000000000000parrot-6.6.0/config/auto/isreg/* Copyright (C) 2003-2009, Parrot Foundation. test for S_ISREG macro */ #include #include int main(int argc, char **argv) { struct stat file_stat; struct stat dir_stat; if (0 != stat("config/auto/isreg/test_c.in", &file_stat)) { puts("file stat failed"); return 0; } if (0 != stat("config/auto/isreg", &dir_stat)) { puts("dir stat failed"); return 0; } if (S_ISREG(file_stat.st_mode) && ! S_ISREG(dir_stat.st_mode)) { puts("ok"); } else { puts("borken"); } return 0; } /* * Local variables: * c-file-style: "parrot" * End: * vim: expandtab shiftwidth=4 cinoptions='\:2=2' : */ QtHelloWorld.pasm000644000765000765 334312101554066 17322 0ustar00bruce000000000000parrot-6.6.0/examples/nci# Copyright (C) 2001-2012, Parrot Foundation. =head1 NAME examples/nci/QtHelloWorld.pasm - Qt Example =head1 SYNOPSIS % ./parrot examples/nci/QtHelloWorld.pasm =head1 DESCRIPTION Sample "Hello World" with Qt, via Parrot Native Call Interface (NCI). See F. Qt - A cross-platform application and UI framework (L). You'll need to build F or F and install it in F for this to work, see F for more information. Note that this will either need JIT for building the NCI-functions on the fly. If this is not available try adding missing signatures to F, running F, and rebuilding Parrot. =cut # load the shared lib loadlib P1, "libPQt" print "Loaded\n" # get and invoke the QApplication_new function dlfunc P0, P1, "QApplication_new", "pv" invokecc P0 set P2, P5 # remember pApp # get and invoke QLabel_new dlfunc P0, P1, "QLabel_new", "pS" # if you need more labels, save P0 = QLabel_new() function set_args "0", "Hello, world!" get_results "0", P5 invokecc P0 set P6, P5 # save pLabel # size the QLabel dlfunc P0, P1, "QLabel_resize", "vpii" set_args "0,0,0", P6, 120, 30 invokecc P0 dlfunc P0, P1, "QLabel_show", "vp" invokecc P0 # and go dlfunc P0, P1,"QApplication_exec", "vp" set_args "0", P2 invokecc P0 end =head1 SEE ALSO F, F, F. =cut # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: 048-return_result_undef.t000644000765000765 513711533177644 20527 0ustar00bruce000000000000parrot-6.6.0/t/configure#! perl # Copyright (C) 2007, Parrot Foundation. # 048-return_result_undef.t use strict; use warnings; use Test::More tests => 13; use Carp; use lib qw( lib t/configure/testlib ); use Parrot::Configure; use Parrot::Configure::Options qw( process_options ); use IO::CaptureOutput qw | capture |; $| = 1; is( $|, 1, "output autoflush is set" ); my ($args, $step_list_ref) = process_options( { argv => [], mode => q{configure}, } ); ok( defined $args, "process_options returned successfully" ); my %args = %$args; my $conf = Parrot::Configure->new; ok( defined $conf, "Parrot::Configure->new() returned okay" ); my $step = q{init::iota}; my $description = 'Determining if your computer does iota'; $conf->add_steps($step); my @confsteps = @{ $conf->steps }; isnt( scalar @confsteps, 0, "Parrot::Configure object 'steps' key holds non-empty array reference" ); is( scalar @confsteps, 1, "Parrot::Configure object 'steps' key holds ref to 1-element array" ); my $nontaskcount = 0; foreach my $k (@confsteps) { $nontaskcount++ unless $k->isa("Parrot::Configure::Task"); } is( $nontaskcount, 0, "Each step is a Parrot::Configure::Task object" ); is( $confsteps[0]->step, $step, "'step' element of Parrot::Configure::Task struct identified" ); ok( !ref( $confsteps[0]->object ), "'object' element of Parrot::Configure::Task struct is not yet a ref" ); $conf->options->set(%args); is( $conf->options->{c}->{debugging}, 1, "command-line option '--debugging' has been stored in object" ); { my $rv; my ($stdout, $stderr); capture ( sub {$rv = $conf->runsteps}, \$stdout, \$stderr ); ok($rv, "runsteps successfully ran $step"); like($stdout, qr/$description/s, "Got correct description for $step"); like($stderr, qr/step $step failed:/, "Got error message expected upon running $step"); } pass("Completed all tests in $0"); ################### DOCUMENTATION ################### =head1 NAME 048-return_result_undef.t - see what happens when configuration step returns undefined value and has an undefined result method =head1 SYNOPSIS % prove t/configure/048-return_result_undef.t =head1 DESCRIPTION The files in this directory test functionality used by F. The tests in this file examine what happens when your configuration step module returns something other than the object but has some other defined result method. =head1 AUTHOR James E Keenan =head1 SEE ALSO Parrot::Configure, F. =cut # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: foo2.pmc000644000765000765 67211567202624 15107 0ustar00bruce000000000000parrot-6.6.0/src/dynpmc/* * Copyright (C) 2009, Parrot Foundation. */ /* * Sample Foo2 class used to verify dynamic loading and * proper inheritance - for testing only */ pmclass Foo2 dynpmc group foo_group provides scalar extends Foo auto_attrs { VTABLE INTVAL get_integer() { INTVAL i = SUPER(); return i + 1; } } /* * Local variables: * c-file-style: "parrot" * End: * vim: expandtab shiftwidth=4 cinoptions='\:2=2' : */ partialsums-2.pir000644000765000765 335311533177635 20426 0ustar00bruce000000000000parrot-6.6.0/examples/shootout#!./parrot # Copyright (C) 2006-2009, Parrot Foundation. # # ./parrot -R jit partialsums-2.pir N (N = 2500000 for shootout) # # By Joshua Isom # changed default value to N=25000 (shootout test default) Karl Forner .loadlib 'trans_ops' .sub main :main .param pmc argv .local int k, n .local num sum1, sum2, sum3, sum4, sum5, sum6, sum7, sum8, sum9, a .local pmc parray .local string result parray = new 'FixedFloatArray' parray = 9 $I0 = argv n = 25000 unless $I0 == 2 goto argok $S0 = argv[1] n = $S0 argok: sum1 = 0.0 sum2 = 0.0 sum3 = 0.0 sum4 = 0.0 sum5 = 0.0 sum6 = 0.0 sum7 = 0.0 sum8 = 0.0 sum9 = 0.0 a = -1.0 .local num div23, k2, k3 div23 = 2.0 / 3.0 # sum1 starts at zero - k := 0 case unrolled $N1 = pow div23, 0 sum1 += $N1 k = 1 beginfor: # This is what overoptimized looks like.... $N1 = pow div23, k sum1 += $N1 $N1 = sqrt k $N1 = 1.0 / $N1 sum2 += $N1 $N1 = k + 1.0 $N1 *= k $N1 = 1.0 / $N1 sum3 += $N1 k2 = k * k $N1 = 1.0 / k2 sum7 += $N1 k3 = k2 * k $N1 = sin k $N1 *= $N1 $N1 *= k3 $N1 = 1.0 / $N1 sum4 += $N1 $N1 = cos k $N1 *= $N1 $N1 *= k3 $N1 = 1.0 / $N1 sum5 += $N1 $N1 = 1.0 / k sum6 += $N1 neg a $N1 = a * $N1 sum8 += $N1 $N1 = 2.0 * k dec $N1 $N1 = a / $N1 sum9 += $N1 inc k if k <= n goto beginfor parray[0] = sum1 parray[1] = sum2 parray[2] = sum3 parray[3] = sum4 parray[4] = sum5 parray[5] = sum6 parray[6] = sum7 parray[7] = sum8 parray[8] = sum9 result = sprintf <<"END", parray %.9f\t(2/3)^k %.9f\tk^-0.5 %.9f\t1/k(k+1) %.9f\tFlint Hills %.9f\tCookson Hills %.9f\tHarmonic %.9f\tRiemann Zeta %.9f\tAlternating Harmonic %.9f\tGregory END print result .end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: make.pm000644000765000765 633012101554066 15331 0ustar00bruce000000000000parrot-6.6.0/config/inter# Copyright (C) 2001-2007, Parrot Foundation. =head1 NAME config/inter/make.pm - make utility =head1 DESCRIPTION Determines whether C is installed and if it's actually GNU C. =cut package inter::make; use strict; use warnings; use base qw(Parrot::Configure::Step); use Parrot::Configure::Utils qw( :inter capture_output check_progs ); sub _init { my $self = shift; my %data; $data{description} = q{Is make installed}; $data{result} = q{}; return \%data; } sub runstep { my ( $self, $conf ) = @_; my $util = 'make'; my $prompt = "Do you have a make utility like 'gmake' or 'make'?"; my $verbose = $conf->options->get('verbose'); # undef means we don't have GNU make... default to not having it $conf->data->set( gmake_version => undef ); my $candidates; if ( $^O eq 'cygwin') { # On Cygwin prefer make over nmake. $candidates = ['gmake', 'make']; } elsif ($conf->option_or_data('cc') =~ /cl(\.exe)?$/i) { # Windows, Visual C++, prefer nmake # This test should use something more stable than the compiler # executable name. 'msvcversion' might be good, but is determined # after this check. $candidates = [ 'nmake', 'mingw32-make', 'gmake', 'make' ]; } else { # Default $candidates = ['gmake', 'mingw32-make', 'nmake', 'make']; } my $prog; # check the candidates for a 'make' program in this order: # environment ; option ; probe ; ask ; default # first pick wins. $prog ||= $ENV{ uc($util) }; $prog ||= $conf->options->get($util); $prog ||= check_progs( $candidates, $verbose ); if ( !$prog ) { $prog = ( $conf->options->get('ask') ) ? prompt( $prompt, $prog ? $prog : $conf->data->get($util) ) : $conf->data->get($util); } # never override the user. If a non-existent program is specified then # the user is responsible for the consequences. if ( defined $prog ) { $conf->data->set( $util => $prog ); $self->set_result('yes'); } else { $prog = check_progs( $candidates, $verbose ); unless ($prog) { # fall back to default $self->set_result('no'); return 1; } } my ( $stdout, $stderr, $ret ) = capture_output( $prog, '--version' ); # don't override the user even if the program they provided appears to be # broken if ( $ret == -1 and !$conf->options->get('ask') ) { # fall back to default $self->set_result('no'); return 1; } # if '--version' returns a string assume that this is gmake. if ( $stdout =~ /GNU \s+ Make \s+ (\d+) \. (\d+)/x ) { $conf->data->set( gmake_version => "$1.$2" ); } $conf->data->set( $util => $prog ); $self->set_result('yes'); # setup make_C _set_make_c($conf, $prog); return 1; } sub _set_make_c { my ($conf, $prog) = @_; if ( $conf->data->get('gmake_version') ) { $conf->data->set( make_c => "+$prog -C" ); } else { # The default value is fine. } } 1; # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: multisub.t000644000765000765 354611533177645 14565 0ustar00bruce000000000000parrot-6.6.0/t/pmc#!./parrot # Copyright (C) 2001-2008, Parrot Foundation. =head1 NAME t/pmc/multisub.t - Multi Sub PMCs =head1 SYNOPSIS % prove t/pmc/multisub.t =head1 DESCRIPTION Tests the creation and invocation of Perl6 multi subs. =cut .sub main :main .include 'test_more.pir' plan( 8 ) $P0 = new ['MultiSub'] $I0 = defined $P0 ok($I0, "create PMC") $I0 = elements $P0 is($I0, 0, "multisubs start empty") $S0 = foo() is($S0, "testing no arg", "no argument variant") $S0 = foo("hello") is($S0, "testing hello", "single string variant") $S0 = foo(5) is($S0, "testing 5", "single int variant") $S0 = foo(42, "goodbye") is($S0, "testing 42, goodbye", "int and string variant") ## Test handling of :flat parameters. $P0 = new ['ResizablePMCArray'] push $P0, 42 push $P0, "goodbye" $S0 = foo($P0 :flat) is($S0, "testing 42, goodbye", "Int and String :flat") ## Now try double :flat $P1 = new ['ResizablePMCArray'] push $P1, 42 $P2 = new ['ResizablePMCArray'] push $P2, "goodbye" $S0 = foo($P1 :flat, $P2 :flat) is($S0, "testing 42, goodbye", "Int and String double :flat") .end .sub foo :multi() .return ('testing no arg') .end .sub foo :multi(string) .param string bar $S0 = "testing " . bar .return ($S0) .end .sub foo :multi(int) .param int bar $S1 = bar $S0 = "testing " . $S1 .return ($S0) .end .sub foo :multi(int, string) .param int bar .param string baz $S1 = bar $S0 = "testing " . $S1 $S0 .= ", " $S0 .= baz .return ($S0) .end .sub foo :multi(Integer, String) .param pmc bar .param pmc baz $S1 = bar $S2 = baz $S0 = "testing " . $S1 $S0 .= ", " $S0 .= $S2 .return ($S0) .end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: test_atim_c.in000644000765000765 103111567202622 17477 0ustar00bruce000000000000parrot-6.6.0/config/auto/stat/* Copyright (C) 2010, Parrot Foundation. check if struct stat has st_atim, st_mtim and st_ctim */ #include #include #include int main() { struct stat st; st.st_atim.tv_sec = 22; st.st_atim.tv_nsec = 500; st.st_mtim.tv_sec = 22; st.st_mtim.tv_nsec = 500; st.st_ctim.tv_sec = 22; st.st_ctim.tv_nsec = 500; printf("OK\n"); return EXIT_SUCCESS; } /* * Local variables: * c-file-style: "parrot" * End: * vim: expandtab shiftwidth=4 cinoptions='\:2=2' : */ ch08_dynops.pod000644000765000765 2374311533177634 17355 0ustar00bruce000000000000parrot-6.6.0/docs/book/draft=pod =head1 Dynamic Opcodes Z The smallest executable component is not the compilation unit or even the subroutine, but is actually the I. Opcodes in Parrot, like opcodes in other machines (both virtual and physical), are individual instructions that implement low-level operations in the machine. In the world of microprocessors, the word "opcode" typically refers to the numeric identifier for each instructions. The human-readable word used in the associated assembly language is called the "mnemonic". An assembler, among other tasks, is responsible for converting mnemonics into opcodes for execution. In Parrot, instead of referring to an instruction by different names depending on what form it's in, we just call them all "opcodes". =head2 Opcodes Opcodes are the smallest logical execution element in Parrot. An individual opcode corresponds, in an abstract kind of way, with a single machine code instruction for a particular hardware processor architecture. Parrot is a pretty high-level virtual machine, and even though its opcodes represent the smallest bits of executable code in Parrot, they are hardly small or low-level by themselves. In fact, some Parrot opcodes implement some complex operations and algorithms. Other opcodes are more traditional, performing basic arithmetic and data manipulating operations. Parrot comes with about 1,200 opcodes total in a basic install. It also has a facility for dynamically loading additional opcode libraries, called C, as needed. =head3 Opcode naming To the PIR and PASM programmers, opcodes appear to be polymorphic. That is, some opcodes appear to have multiple allowable argument formats. This is just an illusion, however. Parrot opcodes are not polymorphic, although certain features enable them to appear that way to the PIR programmer. Different argument list formats are detected during parsing and mapped to separate, unique opcode names. During the Parrot build process, opcode definitions called "ops files" are translated into C code prior to compilation. This translation process renames all ops to use unique names depending on their argument lists. An op "foo" that takes two PMCs and returns an integer would be renamed to C. Another op named "foo" that takes one floating point number and returns a string would be renamed to C. So, when we call the opcode "foo" from our PIR program, the PIR compiler will look at the list of arguments and call the appropriate opcode to handle it. =head2 Writing Opcodes Writing Opcodes, like writing PMCs, is done in a C-like language which is later compiled into C code by the X opcode compiler. The opcode script represents a thin overlay on top of ordinary C code: All valid C code is valid opcode script. There are a few neat additions that make writing opcodes easier. The C keyword, for instance, contains a reference to the current interpreter structure. C is always available when writing opcodes, even though it isn't defined anywhere. Opcodes are all defined with the C keyword. Opcodes are written in files with the C<.ops> extension. The core operation files are stored in the C directory. =head3 Opcode Parameters Each opcode can take any fixed number of input and output arguments. These arguments can be any of the four primary data types--INTVALs, PMCs, NUMBERS and STRINGs--but can also be one of several other types of values including LABELs, KEYs and INTKEYs. Each parameter can be an input, an output or both, using the C, C, and C keywords respectively. Here is an example: op Foo (out INT, in NUM) This opcode could be called like this: $I0 = Foo $N0 # in PIR syntax Foo I0, N0 # in PASM syntax When Parrot parses through the file and sees the C operation, it converts it to the real name C. The real name of an opcode is its name followed by an underscore-separated ordered list of the parameters to that opcode. This is how Parrot appears to use polymorphism: It translates the overloaded opcode common names into longer unique names depending on the parameter list of that opcode. Here is a list of some of the variants of the C opcode: add_i_i # $I0 += $I1 add_n_n # $N0 += $N1 add_p_p # $P0 += $P1 add_i_i_i # $I0 = $I1 + $I2 add_p_p_i # $P0 = $P1 + $I0 add_p_p_n # $P0 = $P1 + $N0 This isn't a complete list, but you should get the picture. Each different combination of parameters translates to a different unique operation, and each operation is remarkably simple to implement. In some cases, Parrot can even use its multi-method dispatch system to call opcodes which are heavily overloaded, or for which there is no exact fit but the parameters could be coerced into different types to complete the operation. For instance, attempting to add a STRING to a PMC might coerce the string into a numerical PMC type first, and then dispatch to the C opcode. This is just an example, and the exact mechanisms may change as more opcodes are added or old ones are deleted. Parameters can be one of the following types: =over 4 =item * INT A normal integer type, such as one of the I registers =item * NUM A floating point number, like is used in the N registers =item * STR A string, such as in a S register =item * PMC A PMC value, like a P register =item * KEY A key value. Something like C<[5 ; "Foo" ; 6 ; "Bar"]>. These are the same as indexes that we use in PMC aggregates. =item * INTKEY A basic key value that uses only integer values C<[1 ; 2 ; 3 ]>. =item * LABEL A label value, which represents a named statement in PIR or PASM code. =back In addition to these types, you need to specify the direction that data is moving through that parameter: =over 4 =item * in The parameter is an input, and should be initialized before calling the op. =item * out The parameter is an output =item * inout The parameter is an input and an output. It should be initialized before calling the op, and its value will change after the op executes. =item * invar The parameter is a reference type like a String or PMC, and its internals might change in the call. =back =head3 Opcode Control Flow Some opcodes have the ability to alter control flow of the program they are in. There are a number of control behaviors that can be implemented, such as an unconditional jump in the C opcode, or a subroutine call in the C code, or the conditional behavior implemented by C. At the end of each opcode you can call a C operation to jump to the next opcode to execute. If no C is performed, control flow will continue like normal to the next operation in the program. In this way, opcodes can easily manipulate control flow. Opcode script provides a number of keywords to alter control flow: =over 4 =item * NEXT() The keyword C contains the address of the next opcode in memory. At the end of a normal op you don't need to call C because moving to the next opcode in the program is the default behavior of Parrot N. The C keyword is frequently used in places like the C opcode to create a continuation to the next opcode to return to after the subroutine returns. =item * ADDRESS() Jumps execution to the given address. ADDRESS(x); Here, C should be an C value of the opcode to jump to. =item * OFFSET() Jumps to the address given as an offset from the current address. OFFSET(x) Here, C is an offset in C units that represents how far forward (positive) or how far backwards (negative) to jump to. =back =head2 The Opcode Compiler As we've seen in our discussions above, ops have a number of transformations to go through before they can be become C code and compiled into Parrot. The various special variables like C<$1>, C and C

need to be converted to normal variable values. Also, each runcore requires the ops be compiled into various formats: The slow and fast cores need the ops to be compiled into individual subroutines. The switch core needs all the ops to be compiled into a single function using a large C statement. The computed goto cores require the ops be compiled into a large function with a large array of label addresses. Parrot's opcode compiler is a tool that's tasked with taking raw opcode files with a C<.ops> extension and converting them into several different formats, all of which need to be syntactically correct C code for compilation. =head2 Dynops Parrot has about 1200 built-in opcodes. These represent operations which are sufficiently simple and fundamental, but at the same time are very common. However, these do not represent all the possible operations that some programmers are going to want to use. Of course, not all of those 1200 ops are unique, many of them are overloaded variants of one another. As an example there are about 36 variants of the C opcode, to account for all the different types of values you may want to set to all the various kinds of registers. The number of unique operations therefore is much smaller then 1200. This is where I come in. Dynops are dynamically-loadable libraries of ops that can be written and compiled separately from Parrot and loaded in at runtime. dynops, along with dynpmcs and runtime libraries are some of the primary ways that Parrot can be extended. Parrot ships with a small number of example dynops libraries in the file L. These are small libraries of mostly nonsensical but demonstrative opcodes that can be used as an example to follow. Dynops can be written in a C<.ops> file like the normal built-in ops are. The ops file should use C<#include "parrot/extend.h"> in addition to any other libraries the ops need. They can be compiled into C using the opcode compiler, then compiled into a shared library using a normal C compiler. Once compiled, the dynops can be loaded into Parrot using the .loadlib directive. =cut # Local variables: # c-file-style: "parrot" # End: # vim: expandtab shiftwidth=4: parrot_embed_pl.in000644000765000765 407411533177633 21150 0ustar00bruce000000000000parrot-6.6.0/config/gen/makefiles# Copyright (C) 2007, Parrot Foundation. # use strict; use warnings; use Cwd; use Config; use File::Copy; use ExtUtils::MakeMaker; copy( 'lib/Parrot/Embed.xs', 'Embed.xs' ); # cross-platform commands and paths my %config; $config{CC} = '@cc@'; $config{PARROTDIR} = '../..'; $config{PARROT} = '..@slash@..@slash@parrot@exe@'; $config{C_LIBS} = '@libs@'; $config{INCLUDE} = "$config{PARROTDIR}/include"; #UNLESS(win32):$config{ALL_PARROT_LIBS} = "@libparrot_linkflags@ $config{C_LIBS} @linkflags@"; $config{ABS_PARROTDIR} = Cwd::realpath( File::Spec->rel2abs( $config{PARROTDIR} ) ); $config{LDDLFLAGS} = $Config{lddlflags}; if ($config{CC} eq 'cl') { $config{LDDLFLAGS} .= qq| -libpath:"$config{ABS_PARROTDIR} "| . File::Spec->catfile( $config{ABS_PARROTDIR}, 'libparrot.lib' ); } WriteMakefile( 'NAME' => 'Parrot::Embed', 'VERSION_FROM' => 'lib/Parrot/Embed.pm', 'PREREQ_PM' => { 'ExtUtils::CBuilder' => 0 }, #IF(win32): 'LIBS' => [ $config{C_LIBS} ], #ELSE: 'LIBS' => [ $config{ALL_PARROT_LIBS} ], #IF(win32): 'OBJECT' => q|@libparrot_linkflags@ Embed@o@|, 'INC' => "-I$config{INCLUDE}", 'PM' => { map { $_ => "blib/$_" } }, 'clean' => { FILES => '*.xs t/greet.pbc' }, 'LDDLFLAGS' => $config{LDDLFLAGS}, ); package MY; sub postamble { "t/greet.pbc:\n\t$config{PARROT} -o t/greet.pbc t/greet.pir\n"; } sub test { my $inherited = shift->SUPER::test(@_); return $inherited unless $config{cc} eq 'cl'; my $dynlib_path = "\tset PATH=%PATH%:$config{ABS_PARROTDIR}"; $inherited =~ s{^(test.*ic ::.*)$}{$1\n$dynlib_path}mg; return $inherited; } sub dynamic_lib { my $inherited = shift->SUPER::dynamic_lib(@_); my $sub_target = quotemeta( ': $(OBJECT)' ); $inherited =~ s{($sub_target)}{$1 t/greet.pbc}; $inherited; } # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: uri_escape.t000644000765000765 232611533177644 15717 0ustar00bruce000000000000parrot-6.6.0/t/library#!./parrot # Copyright (C) 2010, Parrot Foundation. =head1 NAME t/library/uri_escape.t =head1 DESCRIPTION Test the URI Escape library =head1 SYNOPSIS % prove t/library/uri_escape.t =cut .sub 'main' :main .include 'test_more.pir' load_bytecode 'URI/Escape.pbc' plan(6) $P0 = new ['Exporter'] $P1 = get_namespace ['URI'; 'Escape'] $P2 = get_namespace $P0.'import'($P1 :named('source'), $P2 :named('destination'), 'percent_encode percent_encode_component' :named('globals')) $S0 = percent_encode('Hello') is($S0, 'Hello', 'plain ascii without special chars') $S0 = percent_encode_component('Hello') is($S0, 'Hello', 'plain ascii without special chars - component') $S0 = percent_encode('Hello?world') is($S0, 'Hello?world', 'plain ascii') $S1 = percent_encode_component('Hello?world') is($S1, 'Hello%3Fworld', 'plain ascii - component') $S0 = percent_encode(iso-8859-1:"A\x{D1}O#a") is($S0, 'A%C3%91O#a', 'iso-8859-1 string') $S0 = percent_encode_component(iso-8859-1:"A\x{D1}O#a") is($S0, 'A%C3%91O%23a', 'iso-8859-1 string - component') .end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: primes2.c000644000765000765 270111567202623 17152 0ustar00bruce000000000000parrot-6.6.0/examples/benchmarks/* Copyright (C) 2001-2003, Parrot Foundation. =head1 NAME examples/benchmarks/primes2.c - Calculate prime numbers < 10000 =head1 SYNOPSIS % make examples/benchmarks/primes2 % time examples/benchmarks/primes2 =head1 DESCRIPTION Calculates all the prime numbers up to 10000 and prints out the number of primes and the last one found. =head2 Functions =over 4 =cut */ /* =item C Main function to run the example. =cut */ int main(int argc, char *argv[]) { int i=0, max=500; int i6 = 0; int i7; while (1) { if (isprime1(i)) { i7 = i; i6++; } i++; if (i==max) { break; } } printf("N primes calculated to %d is %d\nlast is: %d\n", max, i6, i7); return 0; } /* =item C Determines if the input number is a prime. =cut */ int isprime1(int input) { int n; if (input < 1) { return 0; } n = input - 1; while (n > 1) { if (input%n == 0) return 0; n--; } return 1; } /* =back =head1 SEE ALSO F, F, F, F, F, F. =cut */ /* * Local variables: * c-file-style: "parrot" * End: * vim: expandtab shiftwidth=4 cinoptions='\:2=2' : */ capture.pmc000644000765000765 5010412346145241 15222 0ustar00bruce000000000000parrot-6.6.0/src/pmc/* Copyright (C) 2001-2014, Parrot Foundation. =head1 NAME src/pmc/capture.pmc - Capture PMC =head1 DESCRIPTION These are the vtable functions for the Capture PMC. =head2 Functions =over 4 =cut */ /* HEADERIZER HFILE: none */ /* HEADERIZER BEGIN: static */ /* HEADERIZER END: static */ #define CAPTURE_array_CREATE(i, obj, arr) \ do { \ GETATTR_Capture_array((i), (obj), (arr)); \ if (!(arr)) { \ PObj_custom_mark_SET(obj); \ (arr) = Parrot_pmc_new((i), enum_class_ResizablePMCArray); \ SETATTR_Capture_array((i), (obj), (arr)); \ PARROT_GC_WRITE_BARRIER((i), (obj)); \ } \ } while (0) #define CAPTURE_hash_CREATE(i, obj, hsh) \ do { \ GETATTR_Capture_hash((i), (obj), (hsh)); \ if (!(hsh)) { \ PObj_custom_mark_SET(obj); \ (hsh) = Parrot_pmc_new((i), enum_class_Hash); \ SETATTR_Capture_hash((i), (obj), (hsh)); \ PARROT_GC_WRITE_BARRIER((i), (obj)); \ } \ } while (0) pmclass Capture auto_attrs { ATTR PMC *array; ATTR PMC *hash; /* =item C Creates an identical copy of the Capture. =cut */ VTABLE PMC *clone() :no_wb { PMC *array, *hash; PMC * const dest = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); GET_ATTR_array(INTERP, SELF, array); GET_ATTR_hash(INTERP, SELF, hash); if (!PMC_IS_NULL(array)) { PObj_custom_mark_SET(dest); array = VTABLE_clone(INTERP, array); SET_ATTR_array(INTERP, dest, array); } if (!PMC_IS_NULL(hash)) { PObj_custom_mark_SET(dest); hash = VTABLE_clone(INTERP, hash); SET_ATTR_hash(INTERP, dest, hash); } /* clone of parts can trigger GC. Explicitely WB dest */ PARROT_GC_WRITE_BARRIER(INTERP, dest); return dest; } /* =item C =item C =item C =item C Sets a value in the array component of the Capture. =cut */ VTABLE void set_number_keyed_int(INTVAL key, FLOATVAL value) :manual_wb { PMC *array; CAPTURE_array_CREATE(INTERP, SELF, array); VTABLE_set_number_keyed_int(INTERP, array, key, value); } VTABLE void set_integer_keyed_int(INTVAL key, INTVAL value) :manual_wb { PMC *array; CAPTURE_array_CREATE(INTERP, SELF, array); VTABLE_set_integer_keyed_int(INTERP, array, key, value); } VTABLE void set_pmc_keyed_int(INTVAL key, PMC *value) :manual_wb { PMC *array; CAPTURE_array_CREATE(INTERP, SELF, array); VTABLE_set_pmc_keyed_int(INTERP, array, key, value); } VTABLE void set_string_keyed_int(INTVAL key, STRING *value) :manual_wb { PMC *array; CAPTURE_array_CREATE(INTERP, SELF, array); VTABLE_set_string_keyed_int(INTERP, array, key, value); } /* =item C =item C =item C =item C Retrieves a value in the array component of the Capture. =cut */ VTABLE FLOATVAL get_number_keyed_int(INTVAL key) :no_wb { PMC *array; GET_ATTR_array(INTERP, SELF, array); if (!array) return 0.0; return VTABLE_get_number_keyed_int(INTERP, array, key); } VTABLE INTVAL get_integer_keyed_int(INTVAL key) :no_wb { PMC *array; GET_ATTR_array(INTERP, SELF, array); if (!array) return 0; return VTABLE_get_integer_keyed_int(INTERP, array, key); } VTABLE PMC *get_pmc_keyed_int(INTVAL key) :no_wb { PMC *array; GET_ATTR_array(INTERP, SELF, array); if (!array) return PMCNULL; return VTABLE_get_pmc_keyed_int(INTERP, array, key); } VTABLE STRING *get_string_keyed_int(INTVAL key) :no_wb { PMC *array; GET_ATTR_array(INTERP, SELF, array); if (!array) return CONST_STRING(INTERP, ""); return VTABLE_get_string_keyed_int(INTERP, array, key); } /* =item C =item C =item C =item C Push a value onto the array component of the Capture. =item C =item C =item C =item C Unshift a value onto the array component of the Capture. =cut */ VTABLE void push_float(FLOATVAL value) :manual_wb { PMC *array; CAPTURE_array_CREATE(INTERP, SELF, array); VTABLE_push_float(INTERP, array, value); } VTABLE void push_integer(INTVAL value) :manual_wb { PMC *array; CAPTURE_array_CREATE(INTERP, SELF, array); VTABLE_push_integer(INTERP, array, value); } VTABLE void push_pmc(PMC *value) :manual_wb { PMC *array; CAPTURE_array_CREATE(INTERP, SELF, array); VTABLE_push_pmc(INTERP, array, value); } VTABLE void push_string(STRING *value) :manual_wb { PMC *array; CAPTURE_array_CREATE(INTERP, SELF, array); VTABLE_push_string(INTERP, array, value); } VTABLE void unshift_float(FLOATVAL value) :manual_wb { PMC *array; CAPTURE_array_CREATE(INTERP, SELF, array); VTABLE_unshift_float(INTERP, array, value); } VTABLE void unshift_integer(INTVAL value) :manual_wb { PMC *array; CAPTURE_array_CREATE(INTERP, SELF, array); VTABLE_unshift_integer(INTERP, array, value); } VTABLE void unshift_pmc(PMC *value) :manual_wb { PMC *array; CAPTURE_array_CREATE(INTERP, SELF, array); VTABLE_unshift_pmc(INTERP, array, value); } VTABLE void unshift_string(STRING *value) :manual_wb { PMC *array; CAPTURE_array_CREATE(INTERP, SELF, array); VTABLE_unshift_string(INTERP, array, value); } /* =item C =item C =item C =item C Pop a value from the array component of the Capture. =item C =item C =item C =item C Shift a value from the array component of the Capture. =cut */ VTABLE FLOATVAL pop_float() :manual_wb { PMC *array; FLOATVAL ret; CAPTURE_array_CREATE(INTERP, SELF, array); ret = VTABLE_pop_float(INTERP, array); RETURN(FLOATVAL ret); } VTABLE INTVAL pop_integer() :manual_wb { PMC *array; INTVAL ret; CAPTURE_array_CREATE(INTERP, SELF, array); ret = VTABLE_pop_integer(INTERP, array); RETURN(INTVAL ret); } VTABLE PMC *pop_pmc() :manual_wb { PMC *array, *ret; CAPTURE_array_CREATE(INTERP, SELF, array); ret = VTABLE_pop_pmc(INTERP, array); RETURN(PMC *ret); } VTABLE STRING *pop_string() :manual_wb { PMC *array; STRING *ret; CAPTURE_array_CREATE(INTERP, SELF, array); ret = VTABLE_pop_string(INTERP, array); RETURN(STRING *ret); } VTABLE FLOATVAL shift_float() :manual_wb { PMC *array; FLOATVAL ret; CAPTURE_array_CREATE(INTERP, SELF, array); ret = VTABLE_shift_float(INTERP, array); RETURN(FLOATVAL ret); } VTABLE INTVAL shift_integer() :manual_wb { PMC *array; INTVAL ret; CAPTURE_array_CREATE(INTERP, SELF, array); ret = VTABLE_shift_integer(INTERP, array); RETURN(INTTVAL ret); } VTABLE PMC *shift_pmc() :manual_wb { PMC *array, *ret; CAPTURE_array_CREATE(INTERP, SELF, array); ret = VTABLE_shift_pmc(INTERP, array); RETURN(PMC *ret); } VTABLE STRING *shift_string() :manual_wb { PMC *array; STRING *ret; CAPTURE_array_CREATE(INTERP, SELF, array); ret = VTABLE_shift_string(INTERP, array); RETURN(STRING *ret); } /* =item C Return the number of elements in the array component of the Capture. =item C Return true if element C of the array component is defined. =item C Return true if element C of the array component exists. =item C Delete the element corresponding to C in the array component. =cut */ VTABLE INTVAL elements() :no_wb { PMC *array; GET_ATTR_array(INTERP, SELF, array); if (!array) return 0; return VTABLE_elements(INTERP, array); } VTABLE INTVAL defined_keyed_int(INTVAL key) :no_wb { PMC *array; GET_ATTR_array(INTERP, SELF, array); if (!array) return 0; return VTABLE_defined_keyed_int(INTERP, array, key); } VTABLE INTVAL exists_keyed_int(INTVAL key) :no_wb { PMC *array; GET_ATTR_array(INTERP, SELF, array); if (!array) return 0; return VTABLE_exists_keyed_int(INTERP, array, key); } VTABLE void delete_keyed_int(INTVAL key) :manual_wb { PMC *array; GET_ATTR_array(INTERP, SELF, array); if (array) { VTABLE_delete_keyed_int(INTERP, array, key); PARROT_GC_WRITE_BARRIER(INTERP, SELF); } } /* =item C =item C =item C =item C Sets a value in the hash component of the Capture. =cut */ VTABLE void set_number_keyed(PMC *key, FLOATVAL value) :manual_wb { PMC *hash; CAPTURE_hash_CREATE(INTERP, SELF, hash); VTABLE_set_number_keyed(INTERP, hash, key, value); } VTABLE void set_integer_keyed(PMC *key, INTVAL value) :manual_wb { PMC *hash; CAPTURE_hash_CREATE(INTERP, SELF, hash); VTABLE_set_integer_keyed(INTERP, hash, key, value); } VTABLE void set_pmc_keyed(PMC *key, PMC *value) :manual_wb { PMC *hash; CAPTURE_hash_CREATE(INTERP, SELF, hash); VTABLE_set_pmc_keyed(INTERP, hash, key, value); } VTABLE void set_string_keyed(PMC *key, STRING *value) :manual_wb { PMC *hash; CAPTURE_hash_CREATE(INTERP, SELF, hash); VTABLE_set_string_keyed(INTERP, hash, key, value); } /* =item C =item C =item C =item C Retrieves a value from the hash component of the Capture. =cut */ VTABLE FLOATVAL get_number_keyed(PMC *key) :no_wb { PMC *hash; GET_ATTR_hash(INTERP, SELF, hash); if (!hash) return 0.0; return VTABLE_get_number_keyed(INTERP, hash, key); } VTABLE INTVAL get_integer_keyed(PMC *key) :no_wb { PMC *hash; GET_ATTR_hash(INTERP, SELF, hash); if (!hash) return 0; return VTABLE_get_integer_keyed(INTERP, hash, key); } VTABLE PMC *get_pmc_keyed(PMC *key) :no_wb { PMC *hash; GET_ATTR_hash(INTERP, SELF, hash); if (!hash) return PMCNULL; return VTABLE_get_pmc_keyed(INTERP, hash, key); } VTABLE STRING *get_string_keyed(PMC *key) :no_wb { PMC *hash; GET_ATTR_hash(INTERP, SELF, hash); if (!hash) return CONST_STRING(INTERP, ""); return VTABLE_get_string_keyed(INTERP, hash, key); } /* =item C =item C =item C =item C Sets a value in the hash component of the Capture. =cut */ VTABLE void set_number_keyed_str(STRING *key, FLOATVAL value) :manual_wb { PMC *hash; CAPTURE_hash_CREATE(INTERP, SELF, hash); VTABLE_set_number_keyed_str(INTERP, hash, key, value); } VTABLE void set_integer_keyed_str(STRING *key, INTVAL value) :manual_wb { PMC *hash; CAPTURE_hash_CREATE(INTERP, SELF, hash); VTABLE_set_integer_keyed_str(INTERP, hash, key, value); } VTABLE void set_pmc_keyed_str(STRING *key, PMC *value) :manual_wb { PMC *hash; CAPTURE_hash_CREATE(INTERP, SELF, hash); VTABLE_set_pmc_keyed_str(INTERP, hash, key, value); } VTABLE void set_string_keyed_str(STRING *key, STRING *value) :manual_wb { PMC *hash; CAPTURE_hash_CREATE(INTERP, SELF, hash); VTABLE_set_string_keyed_str(INTERP, hash, key, value); } /* =item C =item C =item C =item C Retrieves a value in the hash component of the Capture. =cut */ VTABLE FLOATVAL get_number_keyed_str(STRING *key) :no_wb { PMC *hash; GET_ATTR_hash(INTERP, SELF, hash); if (!hash) return 0.0; return VTABLE_get_number_keyed_str(INTERP, hash, key); } VTABLE INTVAL get_integer_keyed_str(STRING *key) :no_wb { PMC *hash; GET_ATTR_hash(INTERP, SELF, hash); if (!hash) return 0; return VTABLE_get_integer_keyed_str(INTERP, hash, key); } VTABLE PMC *get_pmc_keyed_str(STRING *key) :no_wb { PMC *hash; GET_ATTR_hash(INTERP, SELF, hash); if (!hash) return PMCNULL; return VTABLE_get_pmc_keyed_str(INTERP, hash, key); } VTABLE STRING *get_string_keyed_str(STRING *key) :no_wb { PMC *hash; GET_ATTR_hash(INTERP, SELF, hash); if (!hash) return CONST_STRING(INTERP, ""); return VTABLE_get_string_keyed_str(INTERP, hash, key); } /* =item C Return true if element C of the hash component is defined. =item C Return true if element C of the hash component exists. =item C Delete the element corresponding to C in the hash component. =cut */ VTABLE INTVAL defined_keyed(PMC *key) :no_wb { PMC *hash; GET_ATTR_hash(INTERP, SELF, hash); if (!hash) return 0; return VTABLE_defined_keyed(INTERP, hash, key); } VTABLE INTVAL exists_keyed(PMC *key) :no_wb { PMC *hash; GET_ATTR_hash(INTERP, SELF, hash); if (!hash) return 0; return VTABLE_exists_keyed(INTERP, hash, key); } VTABLE void delete_keyed(PMC *key) :manual_wb { PMC *hash; GET_ATTR_hash(INTERP, SELF, hash); if (hash) { VTABLE_delete_keyed(INTERP, hash, key); PARROT_GC_WRITE_BARRIER(INTERP, SELF); } } /* =item C Return true if element C of the hash component is defined. =item C Return true if element C of the hash component exists. =item C Delete the element corresponding to C in the hash component. =cut */ VTABLE INTVAL defined_keyed_str(STRING *key) :no_wb { PMC *hash; GET_ATTR_hash(INTERP, SELF, hash); if (!hash) return 0; return VTABLE_defined_keyed_str(INTERP, hash, key); } VTABLE INTVAL exists_keyed_str(STRING *key) :no_wb { PMC *hash; GET_ATTR_hash(INTERP, SELF, hash); if (!hash) return 0; return VTABLE_exists_keyed_str(INTERP, hash, key); } VTABLE void delete_keyed_str(STRING *key) :manual_wb { PMC *hash; GET_ATTR_hash(INTERP, SELF, hash); if (hash) { VTABLE_delete_keyed_str(INTERP, hash, key); PARROT_GC_WRITE_BARRIER(INTERP, SELF); } } /* =item C Set this capture to hold the value of another. If set to PMCNULL, erase the contents of the array and hash components. =cut */ VTABLE void set_pmc(PMC *capture) { if (PMC_IS_NULL(capture)) { SET_ATTR_array(INTERP, SELF, NULL); SET_ATTR_hash(INTERP, SELF, NULL); } else if (VTABLE_isa(INTERP, capture, CONST_STRING(INTERP, "Capture"))) { PMC *array, *hash; GET_ATTR_array(INTERP, capture, array); GET_ATTR_hash(INTERP, capture, hash); SET_ATTR_array(INTERP, SELF, array); SET_ATTR_hash(INTERP, SELF, hash); if (!PMC_IS_NULL(array) || !PMC_IS_NULL(hash)) PObj_custom_mark_SET(SELF); } else Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_INVALID_OPERATION, "Can only set a capture to another capture."); } /* =item C Return a string representation of the hash, showing class and memory address. =cut */ VTABLE STRING *get_string() :no_wb { const STRING * const classname = VTABLE_name(INTERP, SELF); return Parrot_sprintf_c(INTERP, "%S[0x%x]", classname, SELF); } /* =item C Mark the array. =cut */ VTABLE void mark() :no_wb { PMC *array, *hash; GET_ATTR_array(INTERP, SELF, array); GET_ATTR_hash(INTERP, SELF, hash); Parrot_gc_mark_PMC_alive(INTERP, array); Parrot_gc_mark_PMC_alive(INTERP, hash); } /* =item C =item C Freeze/thaw Capture =cut */ VTABLE void freeze(PMC *info) :no_wb { PMC *array, *hash; GET_ATTR_array(INTERP, SELF, array); GET_ATTR_hash(INTERP, SELF, hash); VTABLE_push_pmc(INTERP, info, array); VTABLE_push_pmc(INTERP, info, hash); } VTABLE void thaw(PMC *info) { PMC *tmp = VTABLE_shift_pmc(INTERP, info); if (!PMC_IS_NULL(tmp)) { SET_ATTR_array(INTERP, SELF, tmp); PObj_custom_mark_SET(SELF); } tmp = VTABLE_shift_pmc(INTERP, info); if (!PMC_IS_NULL(tmp)) { SET_ATTR_hash(INTERP, SELF, tmp); PObj_custom_mark_SET(SELF); } } /* =back =head2 Methods =over 4 =cut */ METHOD list() :manual_wb { PMC *array; PMC *capt; /* XXX: This workaround is for when we get here as part of a subclass of Capture */ if (PObj_is_object_TEST(SELF)) { PMC *classobj; PMC *ns = INTERP->root_namespace; ns = Parrot_ns_get_namespace_keyed_str(INTERP, ns, CONST_STRING(INTERP, "parrot")); ns = Parrot_ns_get_namespace_keyed_str(INTERP, ns, CONST_STRING(INTERP, "Capture")); classobj = Parrot_oo_get_class(INTERP, ns); capt = VTABLE_get_attr_keyed(INTERP, SELF, classobj, CONST_STRING(INTERP, "proxy")); } else capt = SELF; CAPTURE_array_CREATE(INTERP, capt, array); RETURN(PMC *array); } METHOD hash() :manual_wb { PMC *hash; PMC *capt; /* XXX: This workaround is for when we get here as part of a subclass of Capture */ if (PObj_is_object_TEST(SELF)) { STRING * const classname = CONST_STRING(INTERP, "Capture"); PMC * const classobj = Parrot_oo_get_class_str(INTERP, classname); capt = VTABLE_get_attr_keyed(INTERP, SELF, classobj, CONST_STRING(INTERP, "proxy")); } else capt = SELF; CAPTURE_hash_CREATE(INTERP, capt, hash); RETURN(PMC *hash); } } /* =back =cut */ /* * Local variables: * c-file-style: "parrot" * End: * vim: expandtab shiftwidth=4 cinoptions='\:2=2' : */ boolean.t000644000765000765 1123011606346603 14336 0ustar00bruce000000000000parrot-6.6.0/t/pmc#!./parrot # Copyright (C) 2001-2007, Parrot Foundation. =head1 NAME t/pmc/boolean.t - Boolean Ops =head1 SYNOPSIS % prove t/pmc/boolean.t =head1 DESCRIPTION Tests C PMC. Checks comparison and logic operations for various type combinations. =cut .include 'fp_equality.pasm' .sub main :main .include 'test_more.pir' plan(35) init_null_tests() init_int_tests() instantiate_tests() num_tests() string_tests() pmc_to_pmc_tests() boolean_as_conditional() logic_operations() negation_tests() iseq_tests() interface_check() .end .sub init_null_tests null $P0 $P1 = new ['Boolean'], $P0 set $I0, $P1 is($I0, 0, "init with null pmc gives false") .end .sub init_int_tests $P0 = new ['Boolean'] set $I0, $P0 is($I0, 0, "Boolean defaults to false") set $I0, 1 set $P0, $I0 set $I1, $P0 is($I1, 1, "Boolean converts 1 to true") set $P0, -4 set $I0, $P0 is($I0, 1, "Boolean converts negative int to true") .end .sub instantiate_tests $P0 = new ['Boolean'] $P0 = 1 $P2 = get_class ['Boolean'] $P1 = new $P2, $P0 $I0 = $P1 is($I0, 1, "Boolean instantiated to true") $P0 = 0 $P1 = new ['Boolean'], $P0 $I0 = $P1 is($I0, 0, "Boolean instantiated to false") .end .sub num_tests $P0 = new ['Boolean'] set $N0, 0 set $P0, $N0 set $I0, $P0 is($I0, 0, "Boolean converts num 0 to false") set $N0, 0.001 set $P0, $N0 set $I0, $P0 is($I0, 1, "Boolean converts non-0 num to true") $P0 = 1 $N1 = $P0 .fp_eq_ok($N1, 1, 'Boolean converts true value to a numeric') $P0 = 0 $N1 = $P0 .fp_eq_ok($N1, 0, 'Boolean converts false value to a numeric') .end .sub string_tests $P0 = new ['Boolean'] set $S0, "0" set $P0, $S0 set $I0, $P0 is($I0, 0, "Boolean converts string '0' to false") set $S0, "foo" set $P0, $S0 set $I0, $P0 is($I0, 1, "Boolean converts string 'foo' to true") set $S0, "" set $P0, $S0 set $I0, $P0 is($I0, 0, "Boolean converts empty string to false") .end .sub pmc_to_pmc_tests $P0 = new ['Boolean'] $P1 = new ['Boolean'] set $P0, 1 clone $P1, $P0 set $I0, $P1 is($I0, 1, "cloned Boolean has correct value") set $P0, 0 set $I0, $P1 is($I0, 1, "cloned Boolean is not a reference") set $P1, 0 set $I0, $P1 is($I0, 0, "cloned Boolean can change value") .end .sub boolean_as_conditional $P0 = new ['Boolean'] set $P0, 1 if $P0, OK_1 ok(0, "Boolean is broken as a conditional") goto end OK_1: ok(1, "Boolean works as a conditional") end: .end .sub logic_operations $P0 = new ['Boolean'] $P1 = new ['Boolean'] $P2 = new ['Boolean'] set $P0, 1 set $P1, 0 or $P2, $P0, $P1 is($P2, 1, "1|0 == 1 for Booleans") #$P0 = 0, $P1 = 1, $P2 = 1 or $P2, $P1, $P1 is($P2, 0, "0|0 == 0 for Booleans") #$P0 = 0, $P1 = 1, $P2 = 0 and $P2, $P0, $P1 is($P2, 0, "0&1 == 0 for Booleans") set $P0, 0 set $P1, 0 and $P2, $P0, $P1 is($P2, 0, "0&0 == 0 for Booleans") #$P0 = 0, $P1 = 0, $P2 = 0 not $P1, $P1 is($P1, 1, "!0 == 1 for Booleans") #$P0 = 0, $P1 = 1, $P2 = 0 not $P0, $P0 and $P2, $P0, $P1 is($P2, 1, "1&1 == 1 for Booleans") #$P0 = 1, $P1 = 1, $P2 = 1 xor $P2, $P0, $P1 is($P2, 0, "1xor1 == 0 for Booleans") #$P0 = 1, $P1 = 1, $P2 = 0 not $P0, $P0 xor $P2, $P0, $P1 is($P2, 1, "0xor1 == 1 for Booleans") #$P0 = 0, $P1 = 1, $P2 = 1 not $P1, $P1 xor $P2, $P0, $P1 is($P2, 0, "0xor0 == 0 for Booleans") .end .sub negation_tests $P0 = new ['Boolean'] $P1 = new ['Boolean'] set $P0, 1 neg $P1, $P0 is($P1, 1, "negated Boolean true is still true") set $P0, 0 neg $P1, $P0 is($P1, 0, "negated Boolean false is still false") set $P0, 1 neg $P0 is($P0, 1, "in-place negated Boolean true is still true") set $P0, 0 neg $P0 is($P0, 0, "in-place negated Boolean false is still false") .end .sub iseq_tests $P1 = new ['Boolean'] $P2 = new ['Boolean'] $P3 = new ['Boolean'] set $P3, 1 $I0 = iseq $P1, $P2 is($I0, 1, "equal") $I0 = iseq $P1, $P3 is($I0, 0, "not equal") .end .sub interface_check .local pmc p .local int b p = new ['Boolean'] does b, p, "scalar" is(b, 1, "Boolean does scalar") does b, p, "boolean" is(b, 1, "Boolean does boolean (big surprise there)") does b, p, "no_interface" is(b, 0, "Boolean doesn't do no_interface") .end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: Tester.pir000644000765000765 2622611567202624 22450 0ustar00bruce000000000000parrot-6.6.0/runtime/parrot/library/Test/Builder =head1 NAME Test::Builder::Tester - Parrot extension for testing test modules =head1 SYNOPSIS # load this library load_bytecode 'Test/Builder/Tester.pbc' # grab the subroutines you want to use .local pmc plan .local pmc test_out .local pmc test_diag .local pmc test_test plan = get_hll_global [ 'Test'; 'Builder'; 'Tester' ], 'plan' test_out = get_hll_global [ 'Test'; 'Builder'; 'Tester' ], 'test_out' test_diag = get_hll_global [ 'Test'; 'Builder'; 'Tester' ], 'test_diag' test_test = get_hll_global [ 'Test'; 'Builder'; 'Tester' ], 'test_test' # create a new Test::Builder object .local pmc tb_args .local pmc test tb_args = new 'Hash' test = new [ 'Test'; 'Builder' ], tb_args # set your test plan plan( 4 ) # test a passing test test_out( 'ok 1 - hi' ) test.'ok'( 1, 'hi' ) test_test( 'passing test') # test a test with some diagnostics test_out( 'ok 3 - A message' ) test_diag( "some\nlines" ) test.ok( 1, 'A message' ) test.diag( 'some' ) test.diag( 'lines' ) test_test( 'passing test with diagnostics' ) # clean up test.'finish'() =head1 DESCRIPTION Test::Builder::Tester is a pure-Parrot library for testing testing modules built on L. It allows you to describe the TAP output that they will produce, showing any differences in description, directive, and diagnostics. This is a procedural library. =head1 FUNCTIONS This module defines the following public functions: =over 4 =cut .namespace [ 'Test'; 'Builder'; 'Tester'; 'Output' ] .sub _initialize :load .local pmc tbto_class newclass tbto_class, [ 'Test'; 'Builder'; 'Tester'; 'Output' ] addattribute tbto_class, 'output' addattribute tbto_class, 'diagnostics' .end .sub init :vtable :method .local pmc output .local pmc diagnostics output = new 'ResizablePMCArray' diagnostics = new 'ResizablePMCArray' setattribute self, "output", output setattribute self, "diagnostics", diagnostics .end .sub get_output :method .local pmc output getattribute output, self, "output" .return( output ) .end .sub get_diagnostics :method .local pmc diagnostics getattribute diagnostics, self, "diagnostics" .return( diagnostics ) .end .sub write :method .param string message .local pmc message_string message_string = new 'String' set message_string, message .local pmc output output = self.'get_output'() push output, message_string .end .sub diag :method .param string message .local pmc message_string message_string = new 'String' set message_string, message .local pmc diagnostics diagnostics = self.'get_diagnostics'() push diagnostics, message_string .end .sub output :method .local pmc output output = self.'get_output'() unless_null output, JOIN_LINES .return( '' ) JOIN_LINES: .local string output_string output_string = join "\n", output set output, 0 .return( output_string ) .end .sub diagnostics :method .local pmc diagnostics diagnostics = self.'get_diagnostics'() unless_null diagnostics, JOIN_LINES .return( '' ) JOIN_LINES: .local string diag_string diag_string = join "\n", diagnostics diagnostics = 0 .return( diag_string ) .end .namespace [ 'Test'; 'Builder'; 'Tester' ] .sub _initialize :load load_bytecode 'Test/Builder.pbc' .local pmc test .local pmc output .local pmc test_output .local pmc expect_out .local pmc expect_diag .local pmc default_test .local pmc args # set the default output for the Test::Builder singleton test_output = new [ 'Test'; 'Builder'; 'Tester'; 'Output' ] args = new 'Hash' set args['output'], test_output default_test = new [ 'Test'; 'Builder' ], args default_test.'plan'( 'no_plan' ) test_output.'output'() # create the Test::Builder object that this uses .local pmc tb_create tb_create = get_hll_global [ 'Test'; 'Builder' ], 'create' args = new 'Hash' output = new [ 'Test'; 'Builder'; 'Output' ], args .local pmc results, testplan results = new 'ResizablePMCArray' testplan = new 'String' testplan = '' set args['output'], output test = tb_create( args ) expect_out = new 'ResizablePMCArray' expect_diag = new 'ResizablePMCArray' set_hll_global [ 'Test'; 'Builder'; 'Tester' ], '_test', test set_hll_global [ 'Test'; 'Builder'; 'Tester' ], '_default_test', default_test set_hll_global [ 'Test'; 'Builder'; 'Tester' ], '_test_output', test_output set_hll_global [ 'Test'; 'Builder'; 'Tester' ], '_expect_out', expect_out set_hll_global [ 'Test'; 'Builder'; 'Tester' ], '_expect_diag', expect_diag .end =item C Sets the number of tests you plan to run, where C is an int. =cut .sub plan .param int tests .local pmc test test = get_hll_global [ 'Test'; 'Builder'; 'Tester' ], '_test' test.'plan'( tests ) .end .sub line_num .end =item C Sets the expectation for a test to pass. C is the optional description of the test. =cut .sub test_pass .param string description :optional .param int have_desc :opt_flag set_output( 'ok', description ) .end =item C Sets the expectation for a test to fail. C is the optional description of the test. =cut .sub test_fail .param string description :optional set_output( 'not ok', description ) .end .sub set_output .param string test_type .param string description .local pmc test .local pmc results .local int result_count .local pmc next_result test = get_hll_global [ 'Test'; 'Builder'; 'Tester' ], '_default_test' results = test.'results'() result_count = results inc result_count next_result = new 'String' set next_result, result_count .local pmc line_string line_string = new 'String' line_string = concat line_string, test_type line_string = concat line_string, ' ' line_string = concat line_string, next_result .local int string_defined string_defined = length description unless string_defined goto SET_EXPECT_OUTPUT line_string = concat line_string, ' - ' line_string = concat line_string, description SET_EXPECT_OUTPUT: .local pmc expect_out expect_out = get_hll_global [ 'Test'; 'Builder'; 'Tester' ], '_expect_out' push expect_out, line_string .end =item C Sets the expected output for this test to a string. This should be a line of TAP output containing a combination of test number, status, description, and directive. =cut .sub test_out .param string line .local pmc line_string line_string = new 'String' set line_string, line .local pmc expect_out expect_out = get_hll_global [ 'Test'; 'Builder'; 'Tester' ], '_expect_out' push expect_out, line_string .end =item C Sets the expected diagnostic output for this test to a string. This should be a line of TAP output containing a test directive. =cut .sub test_err .param string line .local pmc line_string line_string = new 'String' set line_string, line .local pmc expect_diag expect_diag = get_hll_global [ 'Test'; 'Builder'; 'Tester' ], '_expect_diag' push expect_diag, line_string .end =item C Sets the expected diagnostic output for this test to a string. This should be a line of TAP output containing a test directive. This and C are effectively the same. =cut .sub test_diag .param string line .local pmc line_string line_string = new 'String' set line_string, line .local pmc expect_diag expect_diag = get_hll_global [ 'Test'; 'Builder'; 'Tester' ], '_expect_diag' push expect_diag, line_string .end =item C Compares all of the expected test output and diagnostic output with the actual test output. This reports success or failure, using the giving string for the test description, and prints a diagnostic message with the divergent test output or diagnostic output. =cut .sub test_test .param string description .local int string_defined string_defined = length description if string_defined goto FETCH_GLOBALS description = '' FETCH_GLOBALS: .local pmc test .local pmc expect_out .local pmc expect_diag .local pmc test_output test = get_hll_global [ 'Test'; 'Builder'; 'Tester' ], '_test' expect_out = get_hll_global [ 'Test'; 'Builder'; 'Tester' ], '_expect_out' expect_diag = get_hll_global [ 'Test'; 'Builder'; 'Tester' ], '_expect_diag' test_output = get_hll_global [ 'Test'; 'Builder'; 'Tester' ], '_test_output' .local string received_out_string .local string received_diag_string .local string expected_out_string .local string expected_diag_string received_out_string = test_output.'output'() received_diag_string = test_output.'diagnostics'() MAKE_EXPECTED_OUTPUT_STRING: .local int num_lines num_lines = expect_out ne num_lines, 0, JOIN_EO_STRING goto MAKE_EXPECTED_DIAG_STRING JOIN_EO_STRING: expected_out_string = join "\n", expect_out expect_out = 0 MAKE_EXPECTED_DIAG_STRING: num_lines = expect_diag ne num_lines, 0, JOIN_DIAG_STRING goto COMPARE_OUT_STRINGS JOIN_DIAG_STRING: expected_diag_string = join "\n", expect_diag expect_diag = 0 .local int diag_matches .local int output_matches diag_matches = 1 output_matches = 1 COMPARE_OUT_STRINGS: eq received_out_string, expected_out_string, COMPARE_DIAG_STRINGS output_matches = 0 goto FAIL_TEST COMPARE_DIAG_STRINGS: eq received_diag_string, expected_diag_string, PASS_TEST diag_matches = 0 goto FAIL_TEST PASS_TEST: test.'ok'( 1, description ) .return( 1 ) FAIL_TEST: test.'ok'( 0, description ) eq output_matches, 1, REPORT_DIAG_MISMATCH REPORT_OUTPUT_MISMATCH: .local string diagnostic diagnostic = "output mismatch\nhave: " diagnostic = concat diagnostic, received_out_string diagnostic = concat diagnostic, "\nwant: " diagnostic = concat diagnostic, expected_out_string diagnostic = concat diagnostic, "\n" test.'diag'( diagnostic ) eq diag_matches, 1, RETURN REPORT_DIAG_MISMATCH: diagnostic = "diagnostic mismatch\nhave: '" diagnostic = concat diagnostic, received_diag_string diagnostic = concat diagnostic, "'\nwant: '" diagnostic = concat diagnostic, expected_diag_string diagnostic = concat diagnostic, "'\n" test.'diag'( diagnostic ) RETURN: .return( 0 ) .end =back =head1 AUTHOR Written and maintained by chromatic, C<< chromatic at wgz dot org >>, based on the Perl 6 port he wrote, based on the original Perl 5 version written by Mark Fowler. Please send patches, feedback, and suggestions to the Perl 6 internals mailing list. =head1 COPYRIGHT Copyright (C) 2005-2008, Parrot Foundation. =cut # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: pg.t000644000765000765 1620611656271051 14221 0ustar00bruce000000000000parrot-6.6.0/t/library#!./parrot # Copyright (C) 2006-2010, Parrot Foundation. =head1 NAME t/library/pg.t -- Postgres Tests =head1 SYNOPSIS ./parrot t/library/pg.t =head1 DESCRIPTION Test Parrot's libpg interface. The test is using the user's default table, which should be created by your sysadmin. =cut .const int N_TESTS = 43 ## XXX ## .include 'postgres.pasm' .include 'iglobals.pasm' .const int CONNECTION_OK = 0 .const int PGRES_COMMAND_OK = 1 .const int PGRES_TUPLES_OK = 2 .sub main :main load_bytecode 'Test/Builder.pir' .local pmc test test = new [ 'Test'; 'Builder' ] $P0 = getinterp $P1 = $P0[.IGLOBALS_CONFIG_HASH] $I1 = $P1['HAS_EXTRA_NCI_THUNKS'] if $I1 == 1 goto have_enough_nci test.'skip_all'('Extra NCI thunks not available') exit 0 have_enough_nci: test.'plan'(N_TESTS) push_eh no_pg # TODO: fix when exception handling works again loadlib $P0, 'libpq' if $P0 goto have_lib loadlib $P0, 'pq' unless $P0 goto no_pg have_lib: load_bytecode 'postgres.pir' pop_eh test.'ok'(1, 'load_bytecode') load_bytecode 'Pg.pir' test.'ok'(1, 'load_bytecode Pg') .local pmc cl, con, res cl = new 'Pg' test.'ok'(1, 'Pg class exists') con = cl.'connectdb'('') # assume table = user is present $I0 = isa con, ['Pg'; 'Conn'] test.'ok'($I0, 'con isa Pg;Conn') $I0 = istrue con if $I0 goto have_connected test.'skip'( 39, 'no Pg connection; skipping remaining tests' ) .return() have_connected: test.'ok'($I0, 'con is true after connect') $I0 = con.'status'() $I1 = iseq $I0, CONNECTION_OK test.'ok'($I1, 'con.status() == CONNECTION_OK ') # PGconn $P0 = con.'PGconn'() $P1 = get_root_global ['parrot';'Pg'], 'PQstatus' $I0 = $P1($P0) $I1 = iseq $I0, CONNECTION_OK test.'ok'($I1, 'status(PGconn) == CONNECTION_OK ') # exec res = con.'exec'('BEGIN') test.'ok'(1, 'exec BEGIN called') $I0 = isa res, ['Pg'; 'Result'] test.'ok'($I0, 'res isa Pg;Result') $I0 = res.'resultStatus'() $I1 = iseq $I0, PGRES_COMMAND_OK test.'ok'($I1, 'res.resultStatus() == PGRES_COMMAND_OK ') res.'clear'() # install a notice receiver to silent the CREATE .const 'Sub' cb = 'notice' $P0 = con.'setNoticeReceiver'(cb, test) # create a temp table res = con.'exec'(<<'EOT') CREATE TEMP TABLE parrot_tbl ( id serial, foo text, bar text ) EOT $I0 = res.'resultStatus'() $I1 = iseq $I0, PGRES_COMMAND_OK test.'ok'($I1, 'table created PGRES_COMMAND_OK ') # add a row res = con.'exec'(<<'EOT') INSERT INTO parrot_tbl (foo, bar) VALUES('a', 'b') EOT $I0 = res.'resultStatus'() $I1 = iseq $I0, PGRES_COMMAND_OK test.'ok'($I1, 'insert row PGRES_COMMAND_OK ') # get all res = con.'exec'(<<'EOT') SELECT * FROM parrot_tbl EOT $I0 = res.'resultStatus'() $I1 = iseq $I0, PGRES_TUPLES_OK test.'ok'($I1, 'select * PGRES_TUPLES_OK ') # check tuples $I0 = res.'ntuples'() $I1 = iseq $I0, 1 test.'ok'($I1, 'res.ntuples == 1') $I0 = res.'nfields'() $I1 = iseq $I0, 3 test.'ok'($I1, 'res.nfields == 3') # check field name $S0 = res.'fname'(1) $I1 = iseq $S0, "foo" test.'ok'($I1, 'res.fname(1) == "foo"') $S0 = res.'fname'(2) $I1 = iseq $S0, "bar" test.'ok'($I1, 'res.fname(1) == "bar"') $I0 = res.'fnumber'('id') $I1 = iseq $I0, 0 test.'ok'($I1, 'res.fnumber("id") == 0') $I0 = res.'fnumber'('bar') $I1 = iseq $I0, 2 test.'ok'($I1, 'res.fnumber("bar") == 2') $I0 = res.'fnumber'('no_such_col_name') $I1 = iseq $I0, -1 test.'ok'($I1, 'res.fnumber("no_such_col_name") == -1') # check vals $S0 = res.'getvalue'(0, 1) $I1 = iseq $S0, 'a' test.'ok'($I1, 'getvalue(0, 1) == "a"') $S0 = res.'getvalue'(0, 2) $I1 = iseq $S0, 'b' test.'ok'($I1, 'getvalue(0, 2) == "b"') # TODO # execParams res = con.'execParams'(<<'EOT', 'c', 'd') INSERT INTO parrot_tbl (foo, bar) VALUES($1, $2) EOT $I0 = res.'resultStatus'() $I1 = iseq $I0, PGRES_COMMAND_OK test.'ok'($I1, 'insert w execParams PGRES_COMMAND_OK ') res = con.'exec'(<<'EOT') SELECT * FROM parrot_tbl EOT $I0 = res.'ntuples'() $I1 = iseq $I0, 2 test.'ok'($I1, 'res.ntuples == 2') # check vals $S0 = res.'getvalue'(1, 1) $I1 = iseq $S0, 'c' test.'ok'($I1, 'getvalue(1, 1) == "c"') $S0 = res.'getvalue'(1, 2) $I1 = iseq $S0, 'd' test.'ok'($I1, 'getvalue(1, 2) == "d"') # prepare res = con.'prepare'('ins2', <<'EOT', 2) INSERT INTO parrot_tbl (foo, bar) VALUES($1, $2) EOT $I0 = res.'resultStatus'() $I1 = iseq $I0, PGRES_COMMAND_OK test.'ok'($I1, 'prepare PGRES_COMMAND_OK ') res = con.'execPrepared'('ins2', 'e', 'f') $I0 = res.'resultStatus'() $I1 = iseq $I0, PGRES_COMMAND_OK test.'ok'($I1, 'execPrepared PGRES_COMMAND_OK ') res = con.'exec'(<<'EOT') SELECT * FROM parrot_tbl EOT $I0 = res.'ntuples'() $I1 = iseq $I0, 3 test.'ok'($I1, 'res.ntuples == 3') res = con.'execPrepared'('ins2', 'g', 'h') $I0 = res.'resultStatus'() $I1 = iseq $I0, PGRES_COMMAND_OK test.'ok'($I1, 'execPrepared PGRES_COMMAND_OK ') res = con.'exec'(<<'EOT') SELECT * FROM parrot_tbl EOT $I0 = res.'ntuples'() $I1 = iseq $I0, 4 test.'ok'($I1, 'res.ntuples == 4') res = con.'exec'(<<'EOT') INSERT INTO parrot_tbl (foo) VALUES('i') EOT $I0 = res.'resultStatus'() $I1 = iseq $I0, PGRES_COMMAND_OK test.'ok'($I1, 'insert row PGRES_COMMAND_OK ') res = con.'exec'(<<'EOT') SELECT * FROM parrot_tbl EOT $I0 = res.'ntuples'() $I1 = iseq $I0, 5 test.'ok'($I1, 'res.ntuples == 5') $S0 = res.'getvalue'(4, 1) $I1 = iseq $S0, 'i' test.'ok'($I1, 'getvalue(4, 1) == "i"') $S0 = res.'getvalue'(4, 2) $I1 = iseq $S0, '' test.'ok'($I1, 'getvalue(4, 2) == ""') $I0 = res.'getisnull'(4, 1) $I1 = iseq $I0, 0 test.'ok'($I1, 'getisnull(4, 1) == 0') $I0 = res.'getisnull'(4, 2) $I1 = iseq $I0, 1 test.'ok'($I1, 'getisnull(4, 2) == 1') # done res = con.'exec'('ABORT') $I0 = res.'resultStatus'() $I1 = iseq $I0, PGRES_COMMAND_OK test.'ok'($I1, 'ABORT succeeded') null res # this calls __finalize, but there isn't a good way to test this # because any references to the object would prevent destruction #' sweep 1 con.'finish'() test.'ok'(1, 'con.finish()') $I0 = isfalse con test.'ok'($I0, 'con is false after finish') test.'finish'() end no_pg: .local pmc ex .local string msg .get_results(ex) msg = ex test.'skip'(N_TESTS) test.'finish'() .end # notice receiver callback function .sub 'notice' .param pmc test .param pmc res test.'ok'(1, 'notice receiver called') # res ought to be a PGresult struct $S0 = typeof res $I0 = $S0 == 'UnManagedStruct' test.'ok'($I0, 'notice callback got a struct') .local pmc st st = get_root_global ['parrot';'Pg'], 'PQresultStatus' $I0 = st(res) $I1 = iseq $I0, PGRES_COMMAND_OK test.'todo'($I1, 'notice result is still ok') .end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: parrotio.t000644000765000765 1326212101554067 14561 0ustar00bruce000000000000parrot-6.6.0/t/pmc#!perl # Copyright (C) 2006-2008, Parrot Foundation. use strict; use warnings; use lib qw( . lib ../lib ../../lib ); use Test::More; use Parrot::Test tests => 5; =head1 NAME t/pmc/parrotio.t - test the FileHandle PMC =head1 SYNOPSIS % prove t/pmc/parrotio.t =head1 DESCRIPTION Tests the FileHandle PMC. =cut # L pir_output_is( <<'CODE', <<'OUT', 'new' ); .sub 'test' :main new $P0, ['FileHandle'] say "ok 1 - $P0 = new ['FileHandle']" .end CODE ok 1 - $P0 = new ['FileHandle'] OUT # L pir_output_is( <<'CODE', <<'OUT', 'open and close - synchronous', todo => 'not yet implemented' ); .sub 'test' :main $P0 = new ['FileHandle'] $P0.open('README.pod') say 'ok 1 - $P0.open($S1)' $P0.close() say 'ok 2 - $P0.close()' $P0.open('README.pod', 'rw') say 'ok 3 - $P0.open($S1, $S2) # rw mode' $P0.close() $P0.open() say 'ok 4 - $P0.open()' push_eh eh_bad_file_1 $P0.open('bad_file') pop_eh test_5: push_eh eh_bad_file_2 $P0.open('bad_file', 'r') pop_eh test_6: $P0.open('new_file', 'w') say 'ok 6 - $P0.open($S1, $S2) # new file, write mode succeeds' goto end bad_file_1: say 'ok 5 - $P0.open($S1) # with bad file' goto test_5 end: .end CODE ok 1 - $P0.open($S1) ok 2 - $P0.close() ok 3 - $P0.open($S1, $S2) # rw mode ok 4 - $P0.open() ok 5 - $P0.open($S1) # with bad file ok 6 - $P0.open($S1, $S2) # new file, write mode succeeds OUT # should be in the PIR code unlink 'new_file'; SKIP: { skip 'no async calls yet' => 1; pir_output_is( <<'CODE', <<'OUT', 'open and close - asynchronous' ); .sub 'test' :main $P1 = # GH #535 create a callback here $P0 = new ['FileHandle'] $P0.open('README.pod') say 'ok 1 - $P0.open($S1)' $P0.close() say 'ok 2 - $P0.close($P1)' $P0.open('README.pod', 'rw') say 'ok 3 - $P0.open($S1, $S2)' $P0.close() $P0.open() say 'ok 4 - $P0.open()' cleanup: $P0.close() .end CODE ok 1 - $P0.open($S1) ok 2 - $P0.close() ok 3 - $P0.open($S1, $S2) ok 4 - $P0.open() OUT } # L pir_output_is( <<'CODE', <<'OUT', 'print, read, and readline - synchronous', todo => 'not yet implemented' ); .sub 'test' :main load_bytecode 'String/Utils.pbc' .local pmc chomp chomp = get_global ['String';'Utils'], 'chomp' $P0 = new ['FileHandle'] $P0.open('README.pod') $S0 = $P0.read(15) # bytes if $S0 == '# Copyright (C)' goto ok_1 print 'not ' ok_1: say 'ok 1 - $S0 = $P1.read($I2)' $S0 = $P0.read(12) # throw away bytes $S0 = $P0.read(17) # bytes if $S0 == 'Parrot Foundation' goto ok_2 print 'not ' ok_2: say 'ok 2 - $S0 = $P1.read($I2) # again on same stream' $P0.print(123) $P0.print(456.789) $P0.print("squawk\n") $P1 = new ['Integer'] $P1 = 42 $P0.print($P1) say 'ok 3 - $P0.print(${I,N,S,P}1)' $S0 = $P0.readline() $S0 = chomp( $S0 ) if $S0 == '123456.789000squawk' goto ok_4 print 'not ' ok_4: say 'ok 4 - $S0 = $P1.readline($I2)' $S0 = $P0.readline() $S0 = chomp( $S0 ) if $S0 == '42' goto ok_5 print 'not ' ok_5: say 'ok 5 - $S0 = $P1.readline($I2) # again on same stream' .end CODE ok 1 - $S0 = $P1.read($I2) ok 2 - $S0 = $P1.read($I2) # again on same stream ok 3 - $P0.print(${I,N,S,P}1) ok 4 - $S0 = $P1.readline($I2) ok 5 - $S0 = $P1.readline($I2) # again on same stream OUT # GH #535 test reading long chunks, eof, and across newlines # GH #535 pir_output_is( <<'CODE', <<'OUT', 'print, read, and readline - asynchronous', todo => 'not yet implemented' ); # L pir_output_is( <<'CODE', <<'OUT', 'buffer_type', todo => 'not yet implemented' ); .sub 'test' :main .include 'io_buffer_types.pasm' $P0 = new ['FileHandle'] $P0.buffer_type('unbuffered') $I0 = $P0.buffer_type() if $I0 == PIO_NONBUF goto ok_1 print 'not ' ok_1: say 'ok 1 - $I0 = $P1.buffer_type() # PIO_NONBUF' $P0.buffer_type(PIO_NONBUF) $S0 = $P0.buffer_type() if $S0 == 'unbuffered' goto ok_2 print 'not ' ok_2: say 'ok 2 - $S0 = $P1.buffer_type() # PIO_NONBUF' $P0.buffer_type('line-buffered') $I0 = $P0.buffer_type() if $I0 == PIO_LINEBUF goto ok_3 print 'not ' ok_3: say 'ok 3 - $I0 = $P1.buffer_type() # PIO_LINEBUF' $P0.buffer_type(PIO_LINEBUF) $S0 = $P0.buffer_type() if $S0 == 'line-buffered' goto ok_4 print 'not ' ok_4: say 'ok 4 - $S0 = $P1.buffer_type() # PIO_LINEBUF' $P0.buffer_type('full-buffered') $I0 = $P0.buffer_type() if $I0 == PIO_FULLBUF goto ok_5 print 'not ' ok_5: say 'ok 5 - $I0 = $P1.buffer_type() # PIO_FULLBUF' $P0.buffer_type(PIO_FULLBUF) $S0 = $P0.buffer_type() if $S0 == 'full-buffered' goto ok_6 print 'not ' ok_6: say 'ok 6 - $S0 = $P1.buffer_type() # PIO_FULLBUF' .end CODE ok 1 - $I0 = $P1.buffer_type() # PIO_NONBUF ok 2 - $S0 = $P1.buffer_type() # PIO_NONBUF ok 3 - $I0 = $P1.buffer_type() # PIO_LINEBUF ok 4 - $S0 = $P1.buffer_type() # PIO_LINEBUF ok 5 - $I0 = $P1.buffer_type() # PIO_FULLBUF ok 6 - $S0 = $P1.buffer_type() # PIO_FULLBUF OUT # GH #535 test effects of buffer_type, not just set/get # GH #458 # L # NOTES: try setting positive, zero, negative int # perform print and read ops # change buffer size while it contains data # try with all 'buffer_type' modes # GH #465 # L # NOTES: this is going to be platform dependent # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: 04_pod_comments.pir000644000765000765 61712101554066 20641 0ustar00bruce000000000000parrot-6.6.0/examples/tutorial# Copyright (C) 2007-2012, Parrot Foundation. =pod =head1 DESCRIPTION A tutorial lesson about how PIR files can contain Pod documentation. =head1 POD DOCUMENTATION As you may have noticed, PIR files can contain Pod documentation. =cut .sub main :main say "Ignored Pod comments." .end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: parrot_config.pod000644000765000765 142712101554066 17556 0ustar00bruce000000000000parrot-6.6.0/docs/binaries# Copyright (C) 2011, Parrot Foundation. =head1 Name parrot_config - Parrot Configuration =head1 DESCRIPTION parrot_config can be used find out compile-time configuration information about the Parrot executable. =head1 SYNOPSIS To print every available key: parrot_config --dump With specific key it will print only it's corresponding value. To get the current version of Parrot: parrot_config VERSION To get a descriptive version string that will uniquely identify commits which are not releases: parrot_config git_describe =head1 Help For more help or any other question you go to L or L.Or you can send email to 'parrot-dev@parrot.org'. You can also join Parrot IRC channel: #parrot on irc.parrot.org . =cut subs.t000644000765000765 231611533177644 14725 0ustar00bruce000000000000parrot-6.6.0/t/examples#! perl # Copyright (C) 2005-2007, Parrot Foundation. use strict; use warnings; use lib qw( . lib ../lib ../../lib ); use Test::More; use Parrot::Test tests => 5; use Parrot::Config; =head1 NAME t/examples/subs.t - Test examples in F =head1 SYNOPSIS % prove t/examples/subs.t =head1 DESCRIPTION Test the examples in F. =head1 SEE ALSO F F F =cut # Set up expected output for examples my %expected = ( 'coroutine.pasm' => << 'END_EXPECTED', Calling 1st co-routine Entry Resumed Done Calling 2nd co-routine Entry Resumed Done END_EXPECTED 'pasm_sub1.pasm' => << 'END_EXPECTED', Hello from subroutine Hello from main END_EXPECTED 'single_retval.pir' => << 'END_EXPECTED', 7 8 nine 10 return: 10 7 8 nine 10 return: 10 END_EXPECTED 'multi_retvals.pir' => << 'END_EXPECTED', return: 10 11 12 END_EXPECTED 'no_retval.pir' => << 'END_EXPECTED', 7 8 nine END_EXPECTED ); while ( my ( $example, $expected ) = each %expected ) { example_output_is( "examples/subs/$example", $expected ); } # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: setup.pir000755000765000765 330211715102032 17356 0ustar00bruce000000000000parrot-6.6.0/examples/pir/befunge#! ../../../parrot # Copyright (C) 2009-2011, Parrot Foundation. =head1 NAME setup.pir - Python distutils style =head1 DESCRIPTION No Configure step, no Makefile generated. See F. =head1 USAGE $ parrot setup.pir $ parrot setup.pir test $ sudo parrot setup.pir install =cut .sub 'main' :main .param pmc args $S0 = shift args load_bytecode 'distutils.pbc' $P0 = new 'Hash' $P0['name'] = 'befunge' $P0['abstract'] = 'This is a Befunge interpreter written in PIR' $P0['description'] = 'This is a Befunge interpreter written in PIR' $P0['license_type'] = 'Artistic License 2.0' $P0['license_uri'] = 'http://www.perlfoundation.org/artistic_license_2_0' $P0['copyright_holder'] = 'Parrot Foundation' $P0['checkout_uri'] = 'https://github.com/parrot/parrot/tree/master/examples/pir/befunge' $P0['browser_uri'] = 'https://github.com/parrot/parrot/tree/master/examples/pir/befunge' $P0['project_uri'] = 'https://github.com/parrot/parrot/tree/master/examples/pir/befunge' # build $P1 = new 'Hash' $P2 = split "\n", <<'SOURCES' befunge.pir debug.pir flow.pir io.pir load.pir maths.pir stack.pir SOURCES $P1['befunge.pbc'] = $P2 $P0['pbc_pir'] = $P1 $P3 = new 'Hash' $P3['parrot-befunge'] = 'befunge.pbc' $P0['exe_pbc'] = $P3 $P0['installable_pbc'] = $P3 # test $P0['test_exec'] = 'perl' # dist $P4 = glob('*.bef') $P0['manifest_includes'] = $P4 $P5 = split ' ', 'Changes MAINTAINER README' $P0['doc_files'] = $P5 .tailcall setup(args :flat, $P0 :flat :named) .end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: experimental.ops000644000765000765 3131612312075407 16323 0ustar00bruce000000000000parrot-6.6.0/src/ops/* ** experimental.ops */ BEGIN_OPS_PREAMBLE #include "parrot/scheduler_private.h" #include "pmc/pmc_task.h" END_OPS_PREAMBLE =head1 NAME experimental.ops - Experimental Opcodes =cut =head1 DESCRIPTION This file contains experimental opcodes. These opcodes should be considered implicitly deprecated - that is, they may be removed in any release. If you rely on any of these opcodes, please open an issue at L When making changes to any ops file, run C to regenerate all generated ops files. =cut ############################################################################### =head2 More Experimental Ops =over 4 =item B() Break into debugger. Implementation notes: - x86/gcc ... works with gdb - ppc/gcc ... works with gdb, to proceed: gdb> p $pc = $pc + 4 - TODO For other architectures, this is a C. =cut op trap() :deprecated { UNUSED(interp); #if defined(__GNUC__) && defined(i386) && !defined(sun) __asm__("int3"); /* opcode 0xcc */ #endif #if defined(__GNUC__) && defined(PPC) __asm__("trap"); /* opcode tr 31, 0, 0 */ #endif } =item B(invar PMC, inconst LABEL) Sets the opcode_t* label value for the given PMC. This is basically only useful for PMCs such as Sub, Continuation, ExceptionHandler and derivatives =item B(out INT, invar PMC) Gets the opcode_t* label value from the given PMC. This is basically only useful for PMCs such as Sub, Continuation, ExceptionHandler and derivatives =cut inline op set_label(invar PMC, inconst LABEL) { VTABLE_set_pointer(interp, $1, (CUR_OPCODE + $2)); } inline op get_label(out INT, invar PMC) { void * const ptr = VTABLE_get_pointer(interp, $2); $1 = PTR2INTVAL(ptr); } =item B(out INT, in PMC) Gets a unique(*) ID for a PMC. This may or may not be based on the pointer of the PMC, but almost certainly is not the raw pointer value. (*) Uniqueness of these IDs is only guarranteed within code to which this PMC is currently visible (ie: not across processes, or share-nothing threads, and not beyond the lifetime of the PMC). =cut inline op get_id(out INT, in PMC) { $1 = Parrot_hash_pointer((void *)$2, interp->hash_seed); } =item B(out PMC, in PMC, in PMC, in PMC) Fetches a value from $2, keyed by $3 into $1. If the resulting PMC is PMCNULL, uses the type in $4 to create and return a new PMC. =item B(out PMC, in PMC, in INT, in PMC) =item B(out PMC, in PMC, in STR, in PMC) =cut inline op fetch(out PMC, in PMC, in PMC, in PMC) { $1 = VTABLE_get_pmc_keyed(interp, $2, $3); if (PMC_IS_NULL($1)) { $1 = Parrot_pmc_new_from_type(interp, $4); } } inline op fetch(out PMC, in PMC, in INT, in PMC) { $1 = VTABLE_get_pmc_keyed_int(interp, $2, $3); if (PMC_IS_NULL($1)) { $1 = Parrot_pmc_new_from_type(interp, $4); } } inline op fetch(out PMC, in PMC, in STR, in PMC) { $1 = VTABLE_get_pmc_keyed_str(interp, $2, $3); if (PMC_IS_NULL($1)) { $1 = Parrot_pmc_new_from_type(interp, $4); } } =item B(out PMC, in PMC, in PMC, in PMC) Fetches a value from $2, keyed by $3 into $1. If the resulting PMC is PMCNULL, uses the type in $4 to create and return a new PMC. =item B(out PMC, in PMC, in INT, in PMC) =item B(out PMC, in PMC, in STR, in PMC) =cut inline op vivify(out PMC, in PMC, in PMC, in PMC) { $1 = VTABLE_get_pmc_keyed(interp, $2, $3); if (PMC_IS_NULL($1)) { $1 = Parrot_pmc_new_from_type(interp, $4); VTABLE_set_pmc_keyed(interp, $2, $3, $1); } } inline op vivify(out PMC, in PMC, in INT, in PMC) { $1 = VTABLE_get_pmc_keyed_int(interp, $2, $3); if (PMC_IS_NULL($1)) { $1 = Parrot_pmc_new_from_type(interp, $4); VTABLE_set_pmc_keyed_int(interp, $2, $3, $1); } } inline op vivify(out PMC, in PMC, in STR, in PMC) { $1 = VTABLE_get_pmc_keyed_str(interp, $2, $3); if (PMC_IS_NULL($1)) { $1 = Parrot_pmc_new_from_type(interp, $4); VTABLE_set_pmc_keyed_str(interp, $2, $3, $1); } } =item B(out PMC, in STR, in INT) =item B(out PMC, in PMC, in INT) =cut op new(out PMC, in STR, in INT) { STRING * const name = $2; PMC * const _class = Parrot_pcc_get_HLL(interp, CURRENT_CONTEXT(interp)) ? Parrot_oo_get_class_str(interp, name) : PMCNULL; if (!PMC_IS_NULL(_class)) { PMC * const initial = Parrot_pmc_new(interp, Parrot_hll_get_ctx_HLL_type(interp, enum_class_Integer)); VTABLE_set_integer_native(interp, initial, $3); $1 = VTABLE_instantiate(interp, _class, initial); } else { const INTVAL type = Parrot_pmc_get_type_str(interp, name); if (type <= 0) { opcode_t *dest = Parrot_ex_throw_from_op_args(interp, expr NEXT(), EXCEPTION_NO_CLASS, "Class '%Ss' not found", name); goto ADDRESS(dest); } $1 = Parrot_pmc_new_init_int(interp, type, $3); } } op new(out PMC, in PMC, in INT) { PMC * const name_key = $2; /* get_class() returns a PMCProxy for core types, so check for core PMCs */ const INTVAL type = Parrot_pmc_get_type(interp, name_key); /* if it's clearly a PIR-level PMC */ if (type > enum_class_core_max) { PMC * const _class = Parrot_oo_get_class(interp, name_key); if (!PMC_IS_NULL(_class)) { PMC * const initial = Parrot_pmc_new(interp, Parrot_hll_get_ctx_HLL_type(interp, enum_class_Integer)); VTABLE_set_integer_native(interp, initial, $3); $1 = VTABLE_instantiate(interp, _class, initial); } } /* if it's a core PMC */ else if (type > enum_class_default) $1 = Parrot_pmc_new_init_int(interp, type, $3); /* it's a typo */ else { opcode_t * const dest = Parrot_ex_throw_from_op_args(interp, expr NEXT(), EXCEPTION_NO_CLASS, "Class '%Ss' not found", VTABLE_get_repr(interp, name_key)); goto ADDRESS(dest); } } =item B(out PMC, in PMC, in INT) =cut op root_new(out PMC, in PMC, in INT) { PMC * const name_key = $2; /* get_class() returns a PMCProxy for core types, so check for core PMCs */ const INTVAL type = Parrot_pmc_get_type(interp, name_key); /* if it's clearly a PIR-level PMC */ if (type > enum_class_core_max) { PMC * const root_ns = interp->root_namespace; PMC * const ns = Parrot_ns_get_namespace_keyed(interp, root_ns, name_key); PMC * const _class = Parrot_oo_get_class(interp, ns); if (!PMC_IS_NULL(_class)) { PMC * const initial = Parrot_pmc_new(interp, Parrot_hll_get_ctx_HLL_type(interp, enum_class_Integer)); VTABLE_set_integer_native(interp, initial, $3); $1 = VTABLE_instantiate(interp, _class, initial); } } /* if it's a core PMC */ else if (type > enum_class_default) $1 = Parrot_pmc_new_init_int(interp, type, $3); /* it's a typo */ else { opcode_t * const dest = Parrot_ex_throw_from_op_args(interp, expr NEXT(), EXCEPTION_NO_CLASS, "Class '%Ss' not found", VTABLE_get_repr(interp, name_key)); goto ADDRESS(dest); } } =item B(out PMC) =cut op get_context(out PMC) { $1 = CURRENT_CONTEXT(interp); } =item B(out PMC) =cut op new_call_context(out PMC) { $1 = Parrot_pcc_new_call_object(interp); } =item B(invar PMC, invar PMC) =cut inline op invokecc(invar PMC, invar PMC) :flow { PMC * const p = $1; opcode_t *dest = expr NEXT(); PMC * const signature = $2; Parrot_pcc_set_pc(interp, CURRENT_CONTEXT(interp), dest); Parrot_pcc_reuse_continuation(interp, CURRENT_CONTEXT(interp), dest); dest = VTABLE_invoke(interp, p, dest); goto ADDRESS(dest); } =item B(invar PMC, invar PMC, in INT) =cut op flatten_array_into(invar PMC, invar PMC, in INT) { PMC * const dest = $1; PMC * const src = $2; const INTVAL overwrite = $3; INTVAL i; INTVAL start_idx = overwrite ? 0 : VTABLE_elements(interp, dest); INTVAL src_elems = VTABLE_elements(interp, src); for (i = 0; i < src_elems; i++) { PMC * const val = VTABLE_get_pmc_keyed_int(interp, dest, i); VTABLE_set_pmc_keyed_int(interp, dest, i + start_idx, val); } } =item B(invar PMC, invar PMC, in INT) =cut op flatten_hash_into(invar PMC, invar PMC, in INT) { PMC * const dest = $1; PMC * const src = $2; const INTVAL overwrite = $3; Parrot_hash_flatten_hash_into(interp, dest, src, overwrite); } =item B(out PMC, invar PMC, in INT) =cut op slurp_array_from(out PMC, invar PMC, in INT) { PMC * const dest = Parrot_pmc_new(interp, enum_class_ResizablePMCArray); PMC * const src = $2; const INTVAL src_elems = VTABLE_elements(interp, src); INTVAL i; for (i = $3; i < src_elems; i++) { PMC * const value = VTABLE_get_pmc_keyed_int(interp, src, i); VTABLE_push_pmc(interp, src, value); } $1 = dest; } =item B(out PMC) Receive a message sent to the current task. If there is no waiting message, block and wait. =cut op receive(out PMC) { opcode_t *const dest = expr NEXT(); PMC *cur_task = Parrot_cx_current_task(interp); Parrot_Task_attributes *tdata = PARROT_TASK(cur_task); int msg_count; if (tdata->partner) { Parrot_Task_attributes * const pdata = PARROT_TASK(tdata->partner); LOCK(pdata->mailbox_lock); Parrot_block_GC_mark(interp); /* block GC while we're accessing foreign PMCs */ if (PMC_IS_NULL(pdata->mailbox)) msg_count = 0; else msg_count = VTABLE_elements(interp, pdata->mailbox); if (msg_count > 0) { $1 = VTABLE_shift_pmc(pdata->interp, pdata->mailbox); Parrot_unblock_GC_mark(interp); UNLOCK(pdata->mailbox_lock); goto ADDRESS(dest); } else { Parrot_unblock_GC_mark(interp); TASK_recv_block_SET(cur_task); (void) Parrot_cx_stop_task(interp, cur_opcode); UNLOCK(pdata->mailbox_lock); goto ADDRESS(0); } } else { if (PMC_IS_NULL(tdata->mailbox)) msg_count = 0; else msg_count = VTABLE_elements(interp, tdata->mailbox); if (msg_count > 0) { $1 = VTABLE_shift_pmc(interp, tdata->mailbox); goto ADDRESS(dest); } else { TASK_recv_block_SET(cur_task); (void) Parrot_cx_stop_task(interp, cur_opcode); goto ADDRESS(0); } } } =item B(in PMC) Block and wait for a task to complete. =cut op wait(in PMC) { opcode_t *const next = expr NEXT(); PMC *task = $1; PMC *cur_task; Parrot_Task_attributes *tdata; if (!VTABLE_isa(interp, task, Parrot_str_new_constant(interp, "Task"))) Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, "Argument to wait op must be a Task.\n"); tdata = PARROT_TASK(task); LOCK(tdata->waiters_lock); if (tdata->killed) { UNLOCK(tdata->waiters_lock); goto ADDRESS(next); } cur_task = Parrot_cx_stop_task(interp, next); if (PMC_IS_NULL(tdata->waiters)) { tdata->waiters = Parrot_pmc_new(interp, enum_class_ResizablePMCArray); PARROT_GC_WRITE_BARRIER(interp, task); } VTABLE_push_pmc(interp, tdata->waiters, cur_task); UNLOCK(tdata->waiters_lock); goto ADDRESS(0); } =item B() Pass the rest of the current quantum and schedule the next task in the task queue. =cut op pass() { opcode_t *const next = expr NEXT(); opcode_t *const addr = Parrot_cx_preempt_task(interp, interp->scheduler, next); goto ADDRESS(addr); } =item B() Disables preemption so the current task can run uninterrupted through a critical section. =cut op disable_preemption() { Parrot_cx_disable_preemption(interp); } =item B() Enables preemption. To be called after the current task has finished executing a critical section. =cut op enable_preemption() { Parrot_cx_enable_preemption(interp); } =item B() Terminate the current task immediately. =cut op terminate() { UNUSED(interp); UNUSED(cur_opcode); goto ADDRESS(0); } =back =head1 COPYRIGHT Copyright (C) 2001-2012, Parrot Foundation. =head1 LICENSE This program is free software. It is subject to the same license as the Parrot interp itself. =cut /* * Local variables: * c-file-style: "parrot" * End: * vim: expandtab shiftwidth=4 cinoptions='\:2=2' : */ stress_strings1.pir000644000765000765 173012101554066 21313 0ustar00bruce000000000000parrot-6.6.0/examples/benchmarks# Copyright (C) 2010-2012, Parrot Foundation. =head1 NAME examples/benchmarks/stress_strings1.pir - comparison with stress_stringsu.pir =head1 SYNOPSIS % time ./parrot examples/benchmarks/stress_strings1.pir % time ./parrot examples/benchmarks/stress_stringsu.pir =head1 DESCRIPTION Create non-encoded strings, running through the imcc optimizer. Some of the strings are long-lived, most of them are short lived. =cut .sub 'main' :main .local pmc rsa # array of long lived strings. .local pmc args .local int i rsa = new ['ResizableStringArray'] args = new ['ResizablePMCArray'] i = 0 push args, i loop: $S0 = "c" args[0] = i sprintf $S1, "%d", args $S2 = concat $S0, $S1 $I0 = i % 10 # every 10th string is longlived if $I0 goto inc_i push rsa, $S2 inc_i: inc i if i < 10000000 goto loop .end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: imageiostrings.pmc000644000765000765 706312356767111 16600 0ustar00bruce000000000000parrot-6.6.0/src/pmc/* Copyright (C) 2010-2014, Parrot Foundation. =head1 NAME src/pmc/imageiostrings.pmc - ImageIOStrings PMC =head1 DESCRIPTION Get a list of strings in an object graph. Used in packfile creation. =cut */ /* HEADERIZER HFILE: none */ /* HEADERIZER BEGIN: static */ /* HEADERIZER END: static */ pmclass ImageIOStrings auto_attrs { ATTR PMC *seen; /* seen hash */ ATTR PMC *todo; /* todo list */ ATTR PMC *list; /* list of strings seen */ /* =head1 VTABLES =over 4 =cut */ /* =item C Initializes the PMC. =cut */ VTABLE void init() { PARROT_IMAGEIOSTRINGS(SELF)->todo = Parrot_pmc_new(INTERP, enum_class_ResizablePMCArray); PARROT_IMAGEIOSTRINGS(SELF)->seen = Parrot_pmc_new(INTERP, enum_class_Hash); VTABLE_set_pointer(INTERP, PARROT_IMAGEIOSTRINGS(SELF)->seen, Parrot_hash_new_intval_hash(INTERP)); PARROT_IMAGEIOSTRINGS(SELF)->list = Parrot_pmc_new(INTERP, enum_class_ResizableStringArray); PObj_custom_mark_SET(SELF); } /* =item C Marks the PMC as alive. =cut */ VTABLE void mark() :no_wb { Parrot_gc_mark_PMC_alive(INTERP, PARROT_IMAGEIOSTRINGS(SELF)->todo); Parrot_gc_mark_PMC_alive(INTERP, PARROT_IMAGEIOSTRINGS(SELF)->seen); Parrot_gc_mark_PMC_alive(INTERP, PARROT_IMAGEIOSTRINGS(SELF)->list); } /* =item C Gets the result PMC after a thaw. =cut */ VTABLE PMC *get_pmc() :no_wb { UNUSED(INTERP) return PARROT_IMAGEIOSTRINGS(SELF)->list; } /* =item C Returns the flags describing the visit action =cut */ VTABLE INTVAL get_integer() :no_wb { UNUSED(INTERP) UNUSED(SELF) return VISIT_FREEZE_NORMAL; } /* =item C Do nothing. =cut */ VTABLE void push_integer(INTVAL v) :no_wb { UNUSED(INTERP) UNUSED(SELF) UNUSED(v) } /* =item C Do nothing. =cut */ VTABLE void push_float(FLOATVAL v) :no_wb { UNUSED(INTERP) UNUSED(SELF) UNUSED(v) } /* =item C Adds the string to the list of strings. =cut */ VTABLE void push_string(STRING *v) :manual_wb { VTABLE_push_string(INTERP, PARROT_IMAGEIOSTRINGS(SELF)->list, v); } /* =item C Checks new pmcs for strings. =cut */ VTABLE void push_pmc(PMC *v) :manual_wb { if (!PMC_IS_NULL(v)) { Hash * const hash = (Hash *)VTABLE_get_pointer(INTERP, PARROT_IMAGEIOSTRINGS(SELF)->seen); HashBucket * const b = Parrot_hash_get_bucket(INTERP, hash, v); if (!b) { /* not yet seen */ Parrot_hash_put(INTERP, hash, v, v); VTABLE_push_pmc(INTERP, PARROT_IMAGEIOSTRINGS(SELF)->todo, v); } else PARROT_GC_WRITE_BARRIER(INTERP, SELF); } } VTABLE void set_pmc(PMC *p) :manual_wb { PMC * const todo = PARROT_IMAGEIOSTRINGS(SELF)->todo; STATICSELF.push_pmc(p); while (VTABLE_elements(INTERP, todo)) { PMC * const current = VTABLE_shift_pmc(INTERP, todo); VTABLE_freeze(INTERP, current, SELF); VTABLE_visit(INTERP, current, SELF); SELF.push_pmc(PMC_metadata(current)); } } /* =back =cut */ } /* * Local variables: * c-file-style: "parrot" * End: * vim: expandtab shiftwidth=4 cinoptions='\:2=2' : */ getopt_demo.pir000644000765000765 1016511533177634 20027 0ustar00bruce000000000000parrot-6.6.0/examples/library# Copyright (C) 2004-2008, Parrot Foundation. =head1 NAME examples/library/getopt_demo.pir - demonstrating use of the module Getopt/Obj.pir =head1 SYNOPSIS % ./parrot examples/library/getopt_demo.pir --help % ./parrot examples/library/getopt_demo.pir --version % ./parrot examples/library/getopt_demo.pir --string=asdf --bool --integer=42 some thing =head1 DESCRIPTION This demo program shows how to handle command line arguments with the PIR library F. =cut =head1 SUBROUTINES =head2 main This is executed when you call F. =cut .sub main :main .param pmc argv load_bytecode "Getopt/Obj.pbc" # shift name of the program, so that argv contains only options and extra params .local string program_name program_name = shift argv # Specification of command line arguments. .local pmc getopts getopts = new ["Getopt";"Obj"] # getopts."notOptStop"(1) # --version, boolean push getopts, "version|v" # --help, boolean push getopts, "help|h" # --bool, boolean push getopts, "bool|b" # --string, string push getopts, "string|s=s" # --integer, integer push getopts, "integer|i=i" .local pmc opt opt = getopts."get_options"(argv) # Now we do what the passed options tell .local int is_defined # Was '--version' passed ? is_defined = defined opt["version"] unless is_defined goto NO_VERSION_FLAG print "getopt_demo.pir 0.04\n" end NO_VERSION_FLAG: # Was '--help' passed ? is_defined = defined opt["help"] unless is_defined goto NO_HELP_FLAG usage( program_name ) end NO_HELP_FLAG: # Say Hi print "Hi, I am 'getopt_demo.pir'.\n" print "\n" # handle the bool option is_defined = defined opt["bool"] unless is_defined goto NO_BOOL_OPTION print "You have passed the option '--bool'.\n" goto END_BOOL_OPTION NO_BOOL_OPTION: print "You haven't passed the option '--bool'. This is fine with me.\n" END_BOOL_OPTION: # handle the string option is_defined = defined opt["string"] unless is_defined goto NO_STRING_OPTION .local string string_option string_option = opt["string"] print "You have passed the option '--string'. The value is '" print string_option print "'.\n" goto END_STRING_OPTION NO_STRING_OPTION: print "You haven't passed the option '--string'. This is fine with me.\n" END_STRING_OPTION: # handle the integer option is_defined = defined opt["integer"] unless is_defined goto NO_INTEGER_OPTION .local string integer_option integer_option = opt["integer"] print "You have passed the option '--integer'. The value is '" print integer_option print "'.\n" goto END_INTEGER_OPTION NO_INTEGER_OPTION: print "You haven't passed the option '--integer'. This is fine with me.\n" END_INTEGER_OPTION: .local string other_arg .local int cnt_other_args cnt_other_args = 0 .local int num_other_args num_other_args = argv goto CHECK_OTHER_ARG_LOOP REDO_OTHER_ARG_LOOP: other_arg = argv[cnt_other_args] print "You have passed the additional argument: '" print other_arg print "'.\n" inc cnt_other_args CHECK_OTHER_ARG_LOOP: if cnt_other_args < num_other_args goto REDO_OTHER_ARG_LOOP print "All args have been parsed.\n" .end =head2 usage Print the usage message. TODO: Pass a flag for EXIT_FAILURE and EXIT_SUCCESS =cut .sub usage .param string program_name print "Usage: ./parrot " print program_name print " [OPTION]... [STRING]...\n" print "\n" print "Operation modes:\n" print " -h --help display this help and exit\n" print " -v --version output version information and exit\n" print "\n" print "For demo of option parsing:\n" print " -s --string=STRING a string option\n" print " -i --integer=INTEGER an integer option\n" print " -b --bool a boolean option\n" .end =head1 AUTHOR Bernhard Schmalhofer - C =head1 SEE ALSO F =cut # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: 03-past-macros.t000644000765000765 67511567202625 17526 0ustar00bruce000000000000parrot-6.6.0/t/compilers/opsc#! ./parrot-nqp # Copyright (C) 2011, Parrot Foundation. # "Comprehensive" test for creating PAST for C macros. # Parse single op and check various aspects of created PAST. pir::load_bytecode('opsc.pbc'); pir::load_bytecode('dumper.pbc'); Q:PIR{ .include "test_more.pir" }; # TESTS GOES HERE. done_testing(); # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=perl6: pmcs.pod000644000765000765 2770012101554066 15662 0ustar00bruce000000000000parrot-6.6.0/docs/user/pir# Copyright (C) 2001-2012, Parrot Foundation. =pod =head1 NAME docs/user/pir/pmcs.pod - Programming Parrot PMCs. =head1 DESCRIPTION This document covers programming with Parrot's PMCs from the user's perspective. =head1 PROGRAMMING PARROT -- PMCs =head2 Preliminaries To run the example code in this article, you'll need to obtain a copy of Parrot and build it for your system. For information on obtaining Parrot, see L. Instructions for compiling Parrot are available in the Parrot distribution itself. All code examples in this article were tested with Parrot 0.8.1 =head2 A quick review of Parrot As mentioned by Alberto Manuel Simões in TPR 2.3, Parrot is a register-based virtual machine with 4 register types: Integer, String, Number and PMC. PIR registers are referenced by a C<$> character, a capital letter signifying the register type followed by the register number (C<$S15> is String register number 15). Parrot programs consist of lines of text where each line contains one opcode and its arguments. Each subroutine will have as many registers available of each basic type (int, num, string, and pmc) as necessary; a simple subroutine will only need a few whereas complex subroutines with many calculations will need a larger number of registers. This is a fundamental difference from hardware CPUs (and the original design of Parrot), in which there are a fixed number of registers. PIR also provides for a more "natural" syntax for opcodes than the standard assembly language C format. Rather than writing C to assign a zero to the $I1 register, you may instead write C<$I1 = 0>. PIR also provides easy syntax for creating named variables and constants, subroutines, passing parameters to subroutines, accessing parameters by name, etc. Now, on to business ... =head2 What's a PMC? Integers, strings, and floating point numbers are common data types in most programming languages, but what's a PMC? PMC stands for "I

olyIorphic Iontainer". PMCs are how Parrot handles more complicated structures and behaviors, such as arrays, hashes, and objects. anything that can't be expressed using just integers, floating point numbers and strings can be expressed with a PMC. Parrot comes with many types of PMC that encapsulate common, useful behavior. Many of the PMC type names give clues as to how they are used. Here's a table that gives a short description of several interesting and useful PMC types: PMC type Description of PMC -------- ------------------ Env access environment variables Iterator iterate over aggregates such as arrays or hashes Array A generic, resizable array Hash A generic, resizable hash String Similar to a string register but in PMC form Integer Similar to an int register but in PMC form Float Similar to a num register but in PMC form Exception The standard exception mechanism Timer A timer of course :) =head2 Your wish is my command line Before I take a closer look at some of these PMC types, let's look at a common thing that people want to know how to do -- read command line arguments. The subroutine designated as the main program (by the C<:main> pragma) has an implicit parameter passed to it that is the command line arguments. Since previous examples never had such a parameter to the main program, Parrot simply ignored whatever was passed on the command line. Now I want Parrot to capture the command line so that I can manipulate it. So, let's write a program that reads the command line arguments and outputs them one per line: =head3 Example 2: reading command line arguments, take 1 =begin PIR .sub _ :main .param pmc args loop: unless args goto end_loop # line 4 $S0 = shift args print $S0 print "\n" goto loop end_loop: .end =end PIR The C<.param> directive tells parrot that I want this subroutine to accept a single parameter and that parameter is some sort of PMC that I've named C. Since this is the main subroutine of my program (as designated by the C<:main> modifier to the subroutine), Parrot arranges for the C PMC to be an aggregate of some sort that contains the command line arguments. We then repeatedly use the C opcode to remove an element from the front of C and place it into a string register which I then output. When the C PMC is empty, it will evaluate as a boolean false and the conditional on line 4 will cause the program to end. One problem with my program is that it's destructive to the C PMC. What if I wanted to use the C PMC later in the program? One way to do that is to use an integer to keep an index into the aggregate and then just print out each indexed value. =head3 Example 3: reading command line arguments, take 2 =begin PIR .sub _ :main .param pmc args .local int argc argc = args # line 4 $I0 = 0 loop: unless $I0 < argc goto end_loop print $I0 print "\t" $S0 = args[$I0] # line 10 print $S0 print "\n" inc $I0 goto loop end_loop: .end =end PIR Line 4 shows something interesting about aggregates. Similar to perl, when you assign an aggregate to an integer thing (whether it be a register or local variable, but as was explained before, a local variable is in fact just a symbol indicating that is mapped to a register), Parrot puts the number of elements in the aggregate into the integer thing. (e.g., if you had a PMC that held 5 things in C<$P0>, the statement C<$I0 = $P0> assigns 5 to the register C<$I0>) Since I know how many things are in the aggregate, I can make a loop that increments a value until it reaches that number. Line 10 shows that to index an aggregate, you use square brackets just like you would in Perl and many other programming languages. Also note that I'm assigning to a string register and then printing that register. Why didn't I just do C instead? Because this isn't a high level language. PIR provides a nicer syntax but it's still really low level. Each line of PIR still essentially corresponds to one opcode (there are cases in which this is not the case, but those will be discussed later). So, while there's an opcode to index into an aggregate and an opcode to print a string, there is no opcode to do I of those things. BTW, what type of aggregate is the C PMC anyway? Another way to use the C opcode is to pass it an actual PMC: =head3 Example 4: Typing the C PMC =begin PIR .sub _ :main .param pmc args $S0 = typeof args print $S0 print "\n" .end =end PIR When you run this program it should output "ResizableStringArray". If you assign the result of the C opcode to a string thing, you get the name of the PMC type. =head2 "You are standing in a field of PMCs" Now, let's get back to that table above. The C PMC can be thought of as a hash where the keys are environment variable names and the values are the corresponding environment variable values. But where does the actual PMC come from? For the command line, the PMC showed up as an implicit parameter to the main subroutine. Does C do something similar? Nope. If you want to access environment variables I need to create a PMC of type C. This is accomplished by the C opcode like so: C<$P0 = new 'Env'> After that statement, C<$P0> will contain a hash consisting of all of the environment variables at that time. But, both the keys and values the C hash are strings, so how do I iterate over them as I did for the command line? We can't do the same as I did with the command line and use an integer index into the PMC because the keys are strings, not integers. So, how do I do it? The answer is another PMC type--C An C PMC is used, as its name implies, to iterate over aggregates. It doesn't care if they are arrays or hashes or something else entirely, it just gives you a way to walk from one end of the aggregate to the other. Here's a program that outputs the name and value of all environment variables: =head3 Example 5: output environment =begin PIR .sub _ :main .local pmc env, it .local string key, value env = new 'Env' # line 3 it = iter env # line 4 iterloop: unless it goto iterend key = shift it # line 8 value = env[key] print key print ":" print value print "\n" goto iterloop iterend: .end =end PIR Lines 3 and 4 create my new PMCs. Line 3 creates a new C PMC which at the moment of its existence contains a hash of all of the environment variables currently in the environment. Line 4 creates a new C PMC and initializes it with the PMC that I wish to iterate over (my newly created C PMC in this case). From that point on, I treat the C much the same way I first treated the PMC of command line arguments. Test if it's "empty" (the iterator has been exhausted) and shift elements from the C in order to walk from one end of the aggregate to the other. A key difference is however, I'm not modifying the original aggregate, just the C which can be thrown away or reset so that I can iterate the aggregate over and over again or even have two iterators iterating the same aggregate simultaneously. For more information on iterators, see L So, to output the environment variables, I use the C to walk the keys, and then index each key into the C PMC to get the value associated with that key and then output it. Simple. Say ... couldn't I have iterated over the command line this same way? Sure! =head3 Example 6: reading command line arguments, take 3 =begin PIR .sub _ :main .param pmc args .local pmc cmdline cmdline = iter args loop: unless cmdline goto end_loop $S0 = shift cmdline print $S0 print "\n" goto loop end_loop: .end =end PIR Notice how this code approaches the simplicity of the original that destructively iterated the C PMC. Using indexes can quickly become complicated by comparison. =head2 How do I create my own PMC type? That's really beyond the scope of this article, but if you're really interested in doing so, get a copy of the Parrot source and read the file C. This file outlines the steps you need to take to create a new PMC type. =head2 A few more PMC examples I'll conclude with a few examples without explanation. I encourage you to explore the Parrot source code and documentation to find out more about these (and other) PMCs. A good place to start is the docs directory in the Parrot distribution (parrot/docs) =head3 Example 7: Triggering an exception =begin PIR .sub _ :main $P0 = new 'Exception' $P0 = "The sky is falling!" throw $P0 .end =end PIR =head3 Example 8: Setting a timer =begin PIR .include 'timer.pasm' # for the timer constants .sub expired say 'Timer has expired!' exit 1 .end .sub main :main $P0 = new 'Timer' $P1 = get_global 'expired' $P0[.PARROT_TIMER_HANDLER] = $P1 # call sub in $P1 when timer goes off $P0[.PARROT_TIMER_SEC] = 2 # trigger in 10 seconds $P0[.PARROT_TIMER_REPEAT] = 1 # repeat indefinitely $P0[.PARROT_TIMER_RUNNING] = 1 # start timer immediately set_global 'timer', $P0 # keep the timer around $I0 = 0 loop: print $I0 say ': running...' inc $I0 sleep 1 # wait a second goto loop .end =end PIR =head2 Author Jonathan Scott Duff =head2 Thanks =over 4 * Alberto Simões =back =cut 03-past-declarator.t000644000765000765 446311567202625 20401 0ustar00bruce000000000000parrot-6.6.0/t/compilers/opsc#! ./parrot-nqp # Copyright (C) 2010, Parrot Foundation. # "Comprehensive" test for creating PAST for op. # Parse single op and check various aspects of created PAST. pir::load_bytecode('opsc.pbc'); pir::load_bytecode('dumper.pbc'); Q:PIR{ .include "test_more.pir" }; my $buf := q| inline op foo(inconst NUM) { PMC * const foo; foo(); foo(bar); foo(bar, baz); if (answer != 42) { answer = 42; } else { question = "what?"; } } |; my $compiler := pir::compreg__Ps('Ops'); my $past := $compiler.compile($buf, target => 'past'); ok(1, "PAST::Node created"); my $op := @($past)[0][0]; my $var := $op[0]; ok( $var ~~ PAST::Var, "PAST::Var created" ); ok( $var.isdecl, ".. as declaration" ); is( $var.name, "foo", ".. with proper name" ); is( $var.vivibase, "PMC ", ".. with proper type" ); is( $var, "* const ", ".. with proper pointer" ); my $call := $op[1]; ok( $call ~~ PAST::Op, "PAST::op for call created" ); is( $call.pasttype, "call", ".. with pasttype call" ); is( $call.name, "foo", ".. with name 'foo'" ); is( +@($call), 0, ".. with 0 args" ); $call := $op[2]; is( +@($call), 1, ".. with 1 arg" ); $call := $op[3]; is( +@($call), 2, ".. with 2 args" ); my $if := $op[4]; ok( $if ~~ PAST::Op, "PAST::op for if created" ); is( $if.pasttype, "if", ".. with pasttype call" ); is( +@($if), 3, ".. with 3 children" ); # test while pasttype $buf := q| inline op bar(out PMC, in INT) { while (1) { foo(); } }|; $past := $compiler.compile($buf, target => 'past'); $op := $past[0]; is( $op[0][0], 'while', "while loop generates right pasttype"); # test for pasttype $buf := q| inline op bar(out PMC, in INT) { for (i = 0; i < 111; quux($2)) { foo($1); } }|; $past := $compiler.compile($buf, target => 'past'); $op := $past[0]; is( $op[0][0], 'for', "for loop generates right pasttype"); $buf := q| inline op bar(out PMC, in INT) { if (foo) bar(); baz(); }|; $past := $compiler.compile($buf, target => 'past'); $op := $past[0]; # if, baz, WB, goto is( +@($op[0]), 4, "Properly handle single statement in 'if'"); done_testing(); # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=perl6: misc.c000644000765000765 147311567202624 16471 0ustar00bruce000000000000parrot-6.6.0/src/platform/netbsd/* * Copyright (C) 2009, Parrot Foundation. */ /* =head1 NAME src/platform/netbsd/misc.c =head1 DESCRIPTION Miscellaneous helper functions that are specific to NetBSD. =head2 Functions =over 4 =cut */ #include "parrot/parrot.h" /* HEADERIZER HFILE: none */ /* =item C Initialize Parrot for the NetBSD platform. So far turns off SIGFPE for Alpha, and ensures IEEE floating-point semantics from the math library. =cut */ #include #include void Parrot_platform_init_code(void) { _LIB_VERSION = _IEEE_; /* force IEEE math semantics and behaviour */ #if defined(__alpha__) signal(SIGFPE, SIG_IGN); #endif } /* =back =cut */ /* * Local variables: * c-file-style: "parrot" * End: * vim: expandtab shiftwidth=4 cinoptions='\:2=2' : */ 004-configure.t000644000765000765 1052511533177643 16416 0ustar00bruce000000000000parrot-6.6.0/t/configure#! perl # Copyright (C) 2007, Parrot Foundation. # 004-configure.t use strict; use warnings; use Test::More tests => 29; use Carp; use lib qw( lib ); use Parrot::Configure; use Parrot::Configure::Options qw( process_options ); use Parrot::Configure::Step::List qw| get_steps_list |; $| = 1; is( $|, 1, "output autoflush is set" ); my $CC = "/usr/bin/gcc-3.3"; my $localargv = [ qq{--cc=$CC}, ]; my ($args, $step_list_ref) = process_options( { mode => q{configure}, argv => $localargv, } ); ok( defined $args, "process_options returned successfully" ); my %args = %$args; my $conf = Parrot::Configure->new; ok( defined $conf, "Parrot::Configure->new() returned okay" ); isa_ok( $conf, "Parrot::Configure" ); my $newconf = Parrot::Configure->new; ok( defined $newconf, "Parrot::Configure->new() returned okay" ); isa_ok( $newconf, "Parrot::Configure" ); is( $conf, $newconf, "Parrot::Configure object is a singleton" ); # Since these tests peek into the Parrot::Configure object, they will break if # the structure of that object changes. We retain them for now to delineate # our progress in testing the object. foreach my $k (qw| steps options data |) { ok( defined $conf->$k, "Parrot::Configure object has $k key" ); } is( ref( $conf->steps ), q{ARRAY}, "Parrot::Configure object 'steps' key is array reference" ); is( scalar @{ $conf->steps }, 0, "Parrot::Configure object 'steps' key holds empty array reference" ); foreach my $k (qw| options data |) { isa_ok( $conf->$k, "Parrot::Configure::Data" ); } can_ok( "Parrot::Configure", qw| data | ); can_ok( "Parrot::Configure", qw| options | ); can_ok( "Parrot::Configure", qw| steps | ); can_ok( "Parrot::Configure", qw| add_step | ); can_ok( "Parrot::Configure", qw| add_steps | ); can_ok( "Parrot::Configure", qw| run_single_step | ); can_ok( "Parrot::Configure", qw| runsteps | ); can_ok( "Parrot::Configure", qw| _run_this_step | ); $conf->add_steps( get_steps_list() ); my @confsteps = @{ $conf->steps }; isnt( scalar @confsteps, 0, "Parrot::Configure object 'steps' key holds non-empty array reference" ); my $nontaskcount = 0; foreach my $k (@confsteps) { $nontaskcount++ unless $k->isa("Parrot::Configure::Task"); } is( $nontaskcount, 0, "Each step is a Parrot::Configure::Task object" ); $conf->options->set(%args); is( $conf->options->{c}->{cc}, $CC, "command-line option '--cc' has been stored in object" ); is( $conf->options->{c}->{debugging}, 1, "command-line option '--debugging' has been stored in object" ); my $res = eval "no strict; use Parrot::Config::Generated; \\%PConfig"; SKIP: { my $reason = <data()->get_PConfig(); }; like( $@, qr/You cannot use --step until you have completed the full configure process/, "Got expected error message for --step option and get_PConfig() without prior configuration" ); } $res = eval "no strict; use Parrot::Config::Generated; \\%PConfig_Temp"; SKIP: { my $reason = <data()->get_PConfig_Temp(); }; like( $@, qr/You cannot use --step until you have completed the full configure process/, "Got expected error message for --step option and get_PConfig_Temp() without prior configuration" ); } pass("Completed all tests in $0"); ################### DOCUMENTATION ################### =head1 NAME 004-configure.t - test Parrot::Configure =head1 SYNOPSIS % prove t/configure/004-configure.t =head1 DESCRIPTION The files in this directory test functionality used by F. The tests in this file test those Parrot::Configure methods regularly called by F up to, but not including, C. There is also a test for failure of the C<--step> option without prior completed configuration. =head1 AUTHOR James E Keenan =head1 SEE ALSO Parrot::Configure, F. =cut # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: Lines.pir000644000765000765 244212101554066 16552 0ustar00bruce000000000000parrot-6.6.0/examples/streams =head1 DESCRIPTION This example demonstrates what C does. =head1 FUNCTIONS =over 4 =item _main Creates a stream and pipes it through a Stream::Lines stream. =cut .sub _main :main .local pmc stream .local pmc lines load_bytecode 'Stream/Sub.pbc' load_bytecode 'Stream/Lines.pbc' # create a text stream stream = new ['Stream'; 'Sub'] # set the source .const 'Sub' temp = "_text" assign stream, temp # create a lines stream lines = new ['Stream'; 'Lines'] # set the source assign lines, stream # dump the stream lines."dump"() end .end =item _text This sub is used as a source for a stream piped through C. Writes some text containing newlines to the stream. C will return it one line per read. =cut .sub _text :method self."write"( "this\nis a\n" ) self."write"( "Stream::Lines\ntest" ) self."write"( "case\nhello world" ) .end =back =head1 AUTHOR Jens Rieks Eparrot at jensbeimsurfen dot deE is the author and maintainer. Please send patches and suggestions to the Perl 6 Internals mailing list. =head1 COPYRIGHT Copyright (C) 2004-2009, Parrot Foundation. =cut # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: tables.c000644000765000765 576712233541455 17012 0ustar00bruce000000000000parrot-6.6.0/src/string/encoding/* * Copyright (C) 2005-2011, Parrot Foundation. * * DO NOT EDIT THIS FILE DIRECTLY! * please update the tools/dev/gen_charset_tables.pl script instead. * * Created by gen_charset_tables.pl 19534 2007-07-02 02:12:08Z petdance * Overview: * This file contains various charset tables. * Data Structure and Algorithms: * History: * Notes: * References: */ /* HEADERIZER HFILE: none */ #include "tables.h" const INTVAL Parrot_iso_8859_1_typetable[256] = { 0x0200, 0x0200, 0x0200, 0x0200, 0x0200, 0x0200, 0x0200, 0x0200, /* 0-7 */ 0x0200, 0x0320, 0x1220, 0x0220, 0x1220, 0x1220, 0x0200, 0x0200, /* 8-15 */ 0x0200, 0x0200, 0x0200, 0x0200, 0x0200, 0x0200, 0x0200, 0x0200, /* 16-23 */ 0x0200, 0x0200, 0x0200, 0x0200, 0x0200, 0x0200, 0x0200, 0x0200, /* 24-31 */ 0x0160, 0x04c0, 0x04c0, 0x04c0, 0x04c0, 0x04c0, 0x04c0, 0x04c0, /* 32-39 */ 0x04c0, 0x04c0, 0x04c0, 0x04c0, 0x04c0, 0x04c0, 0x04c0, 0x04c0, /* 40-47 */ 0x28d8, 0x28d8, 0x28d8, 0x28d8, 0x28d8, 0x28d8, 0x28d8, 0x28d8, /* 48-55 */ 0x28d8, 0x28d8, 0x04c0, 0x04c0, 0x04c0, 0x04c0, 0x04c0, 0x04c0, /* 56-63 */ 0x04c0, 0x28d5, 0x28d5, 0x28d5, 0x28d5, 0x28d5, 0x28d5, 0x28c5, /* 64-71 */ 0x28c5, 0x28c5, 0x28c5, 0x28c5, 0x28c5, 0x28c5, 0x28c5, 0x28c5, /* 72-79 */ 0x28c5, 0x28c5, 0x28c5, 0x28c5, 0x28c5, 0x28c5, 0x28c5, 0x28c5, /* 80-87 */ 0x28c5, 0x28c5, 0x28c5, 0x04c0, 0x04c0, 0x04c0, 0x04c0, 0x24c0, /* 88-95 */ 0x04c0, 0x28d6, 0x28d6, 0x28d6, 0x28d6, 0x28d6, 0x28d6, 0x28c6, /* 96-103 */ 0x28c6, 0x28c6, 0x28c6, 0x28c6, 0x28c6, 0x28c6, 0x28c6, 0x28c6, /* 104-111 */ 0x28c6, 0x28c6, 0x28c6, 0x28c6, 0x28c6, 0x28c6, 0x28c6, 0x28c6, /* 112-119 */ 0x28c6, 0x28c6, 0x28c6, 0x04c0, 0x04c0, 0x04c0, 0x04c0, 0x0200, /* 120-127 */ 0x0200, 0x0200, 0x0200, 0x0200, 0x0200, 0x1220, 0x0200, 0x0200, /* 128-135 */ 0x0200, 0x0200, 0x0200, 0x0200, 0x0200, 0x0200, 0x0200, 0x0200, /* 136-143 */ 0x0200, 0x0200, 0x0200, 0x0200, 0x0200, 0x0200, 0x0200, 0x0200, /* 144-151 */ 0x0200, 0x0200, 0x0200, 0x0200, 0x0200, 0x0200, 0x0200, 0x0200, /* 152-159 */ 0x04e0, 0x04c0, 0x04c0, 0x04c0, 0x04c0, 0x04c0, 0x04c0, 0x04c0, /* 160-167 */ 0x04c0, 0x04c0, 0x28c4, 0x04c0, 0x04c0, 0x04c0, 0x04c0, 0x04c0, /* 168-175 */ 0x04c0, 0x04c0, 0x04c0, 0x04c0, 0x04c0, 0x28c6, 0x04c0, 0x04c0, /* 176-183 */ 0x04c0, 0x04c0, 0x28c4, 0x04c0, 0x04c0, 0x04c0, 0x04c0, 0x04c0, /* 184-191 */ 0x28c5, 0x28c5, 0x28c5, 0x28c5, 0x28c5, 0x28c5, 0x28c5, 0x28c5, /* 192-199 */ 0x28c5, 0x28c5, 0x28c5, 0x28c5, 0x28c5, 0x28c5, 0x28c5, 0x28c5, /* 200-207 */ 0x28c5, 0x28c5, 0x28c5, 0x28c5, 0x28c5, 0x28c5, 0x28c5, 0x04c0, /* 208-215 */ 0x28c5, 0x28c5, 0x28c5, 0x28c5, 0x28c5, 0x28c5, 0x28c5, 0x28c6, /* 216-223 */ 0x28c6, 0x28c6, 0x28c6, 0x28c6, 0x28c6, 0x28c6, 0x28c6, 0x28c6, /* 224-231 */ 0x28c6, 0x28c6, 0x28c6, 0x28c6, 0x28c6, 0x28c6, 0x28c6, 0x28c6, /* 232-239 */ 0x28c6, 0x28c6, 0x28c6, 0x28c6, 0x28c6, 0x28c6, 0x28c6, 0x04c0, /* 240-247 */ 0x28c6, 0x28c6, 0x28c6, 0x28c6, 0x28c6, 0x28c6, 0x28c6, 0x28c6, /* 248-255 */ }; /* * Local variables: * c-file-style: "parrot" * End: * vim: expandtab shiftwidth=4 cinoptions='\:2=2' : */ 024-version.t000644000765000765 375511533177643 16113 0ustar00bruce000000000000parrot-6.6.0/t/configure#! perl # Copyright (C) 2007, Parrot Foundation. # 024-version.t use strict; use warnings; use Test::More tests => 10; use Carp; use Cwd; use File::Copy; use File::Temp qw| tempdir |; use lib qw( lib t/configure/testlib ); use Parrot::BuildUtil; use Make_VERSION_File qw| make_VERSION_file |; my $cwd = cwd(); { my $tdir = tempdir( CLEANUP => 1 ); ok( chdir $tdir, "Changed to temporary directory for testing" ); ok( ( mkdir "lib" ), "Able to make directory lib" ); ok( ( mkdir "lib/Parrot" ), "Able to make directory lib/Parrot" ); # Case 6: Installed copy of Parrot my $installed_dir = q{lib/Parrot/something}; ok( ( mkdir $installed_dir ), "Able to make directory $installed_dir" ); ok( chdir $installed_dir, "Changed deeper into temporary directory for testing" ); make_VERSION_file(q{0.4.11}); ok( chdir $tdir, "Changed back to temporary directory" ); my ( $pv, @pv ); $pv = Parrot::BuildUtil::parrot_version($installed_dir); is( $pv, q{0.4.11}, "Correct version number returned in scalar context" ); @pv = Parrot::BuildUtil::parrot_version($installed_dir); is_deeply( \@pv, [ 0, 4, 11 ], "Correct version number returned in list context" ); unlink qq{$installed_dir/VERSION} or croak "Unable to delete file from tempdir after testing"; ok( chdir $cwd, "Able to change back to directory after testing" ); } pass("Completed all tests in $0"); ################### DOCUMENTATION ################### =head1 NAME 024-version.t - test C =head1 SYNOPSIS % prove t/configure/024-version.t =head1 DESCRIPTION The files in this directory test functionality used by F. The tests in this file test Parrot::BuildUtil (F). =head1 AUTHOR James E Keenan =head1 SEE ALSO Parrot::BuildUtil, F. =cut # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: boolean.pir000644000765000765 216411533177634 17571 0ustar00bruce000000000000parrot-6.6.0/examples/benchmarks# Copyright (C) 2010, Parrot Foundation. =head1 NAME examples/benchmarks/boolean.pir: Manipulate the Boolean PMC =head1 SYNOPSIS parrot examples/benchmarks/boolean.pir =head1 DESCRIPTION This benchmark operates on the Boolean PMC, allocating new ones, setting them, and performing logical operations on them. =cut .const num iterations = 10e6 # Number of iterations. .sub main :main .local num start_time, end_time .local int counter .local pmc a, b, c, result print "Perform " print iterations say " iterations of various Boolean operations" a = new 'Boolean', 1 start_time = time counter = iterations LOOP: b = new 'Boolean' b = 1 c = new 'Boolean', b result = not a result = and result, b result = or result, c not result if result goto TRUE a = 0 goto NEXT TRUE: a = 1 NEXT: dec counter if counter > 0 goto LOOP end_time = time end_time = end_time - start_time end_time = end_time / iterations print "Elapsed time per iteration: " say end_time .end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: library.c000644000765000765 7213212233541455 14116 0ustar00bruce000000000000parrot-6.6.0/src/* Copyright (C) 2004-2012, Parrot Foundation. =head1 NAME src/library.c - Interface to Parrot's bytecode library =head1 DESCRIPTION This file contains C functions to access Parrot's bytecode library functions, for include files (via C<.include>), library files (via C), and dynext files (via C). =head2 Functions =over 4 =cut */ #include "parrot/parrot.h" #include "parrot/dynext.h" #include "library.str" /* HEADERIZER HFILE: include/parrot/library.h */ /* HEADERIZER BEGIN: static */ /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */ static void add_env_paths(PARROT_INTERP, ARGIN(PMC *libpath), ARGIN(const STRING *envstr)) __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__nonnull__(3); PARROT_WARN_UNUSED_RESULT PARROT_CANNOT_RETURN_NULL static STRING * cnv_to_win32_filesep(PARROT_INTERP, ARGIN(const STRING *path)) __attribute__nonnull__(1) __attribute__nonnull__(2); PARROT_WARN_UNUSED_RESULT PARROT_CANNOT_RETURN_NULL static PMC* get_search_paths(PARROT_INTERP, enum_lib_paths which) __attribute__nonnull__(1); PARROT_PURE_FUNCTION static int is_abs_path(PARROT_INTERP, ARGIN(const STRING *file)) __attribute__nonnull__(1) __attribute__nonnull__(2); PARROT_WARN_UNUSED_RESULT PARROT_CANNOT_RETURN_NULL static STRING* path_concat(PARROT_INTERP, ARGIN(STRING *l_path), ARGIN(const STRING *r_path)) __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__nonnull__(3); PARROT_WARN_UNUSED_RESULT PARROT_CANNOT_RETURN_NULL static STRING* path_guarantee_trailing_separator(PARROT_INTERP, ARGIN(STRING *path)) __attribute__nonnull__(1) __attribute__nonnull__(2); PARROT_WARN_UNUSED_RESULT PARROT_CAN_RETURN_NULL static STRING* try_bytecode_extensions(PARROT_INTERP, ARGIN(STRING* path)) __attribute__nonnull__(1) __attribute__nonnull__(2); PARROT_WARN_UNUSED_RESULT PARROT_CAN_RETURN_NULL static STRING* try_load_path(PARROT_INTERP, ARGIN(STRING* path)) __attribute__nonnull__(1) __attribute__nonnull__(2); #define ASSERT_ARGS_add_env_paths __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(libpath) \ , PARROT_ASSERT_ARG(envstr)) #define ASSERT_ARGS_cnv_to_win32_filesep __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(path)) #define ASSERT_ARGS_get_search_paths __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp)) #define ASSERT_ARGS_is_abs_path __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(file)) #define ASSERT_ARGS_path_concat __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(l_path) \ , PARROT_ASSERT_ARG(r_path)) #define ASSERT_ARGS_path_guarantee_trailing_separator \ __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(path)) #define ASSERT_ARGS_try_bytecode_extensions __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(path)) #define ASSERT_ARGS_try_load_path __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(path)) /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */ /* HEADERIZER END: static */ /* =item C Create an array of StringArrays with library searchpaths and shared extension used for loading various files at runtime. The created structures looks like this: lib_paths = [ [ "runtime/parrot/include", ... ], # paths for .include 'file' [ "runtime/parrot/library", ... ], # paths for load_bytecode [ "runtime/parrot/dynext", ... ], # paths for loadlib [ "languages", ... ], # paths for languages [ ".so", ... ] # list of shared extensions ] If the platform defines #define PARROT_PLATFORM_LIB_PATH_INIT_HOOK the_init_hook it will be called as a function with this prototype: void the_init_hook(PARROT_INTERP, PMC *lib_paths); Platform code may add, delete, or replace search path entries as needed. See also F for C. =cut */ void parrot_init_library_paths(PARROT_INTERP) { ASSERT_ARGS(parrot_init_library_paths) PMC *paths; STRING *entry; PMC * const iglobals = interp->iglobals; /* create the lib_paths array */ PMC * const lib_paths = Parrot_pmc_new_init_int(interp, enum_class_FixedPMCArray, PARROT_LIB_PATH_SIZE); VTABLE_set_pmc_keyed_int(interp, iglobals, IGLOBALS_LIB_PATHS, lib_paths); /* each is an array of strings */ /* define include paths */ paths = Parrot_pmc_new(interp, enum_class_ResizableStringArray); VTABLE_set_pmc_keyed_int(interp, lib_paths, PARROT_LIB_PATH_INCLUDE, paths); { /* EXPERIMENTAL: add include path from environment */ STRING *envvar = Parrot_getenv(interp, CONST_STRING(interp, "PARROT_INCLUDE")); Parrot_warn_experimental(interp, "PARROT_INCLUDE environment variable is experimental"); if (!STRING_IS_NULL(envvar) && !STRING_IS_EMPTY(envvar)) add_env_paths(interp, paths, envvar); } /* define library paths */ paths = Parrot_pmc_new(interp, enum_class_ResizableStringArray); VTABLE_set_pmc_keyed_int(interp, lib_paths, PARROT_LIB_PATH_LIBRARY, paths); { /* EXPERIMENTAL: add library path from environment */ STRING *envvar = Parrot_getenv(interp, CONST_STRING(interp, "PARROT_LIBRARY")); Parrot_warn_experimental(interp, "PARROT_LIBRARY environment variable is experimental"); if (!STRING_IS_NULL(envvar) && !STRING_IS_EMPTY(envvar)) add_env_paths(interp, paths, envvar); } /* define languages paths */ paths = Parrot_pmc_new(interp, enum_class_ResizableStringArray); VTABLE_set_pmc_keyed_int(interp, lib_paths, PARROT_LIB_PATH_LANG, paths); /* define dynext paths */ paths = Parrot_pmc_new(interp, enum_class_ResizableStringArray); VTABLE_set_pmc_keyed_int(interp, lib_paths, PARROT_LIB_PATH_DYNEXT, paths); entry = CONST_STRING(interp, "dynext/"); VTABLE_push_string(interp, paths, entry); { /* EXPERIMENTAL: add dynext path from environment */ STRING *dynext_dirs = Parrot_getenv(interp, CONST_STRING(interp, "PARROT_DYNEXT")); Parrot_warn_experimental(interp, "PARROT_DYNEXT environment variable is experimental"); if (!STRING_IS_NULL(dynext_dirs) && !STRING_IS_EMPTY(dynext_dirs)) { add_env_paths(interp, paths, dynext_dirs); } } /* shared exts */ paths = Parrot_pmc_new(interp, enum_class_ResizableStringArray); VTABLE_set_pmc_keyed_int(interp, lib_paths, PARROT_LIB_DYN_EXTS, paths); /* no CONST_STRING here - the c2str.pl preprocessor needs "real strs" */ entry = Parrot_str_new_constant(interp, PARROT_LOAD_EXT); VTABLE_push_string(interp, paths, entry); /* OS/X has .dylib and .bundle */ if (!STREQ(PARROT_LOAD_EXT, PARROT_SHARE_EXT)) { entry = Parrot_str_new_constant(interp, PARROT_SHARE_EXT); VTABLE_push_string(interp, paths, entry); } #ifdef PARROT_PLATFORM_LIB_PATH_INIT_HOOK PARROT_PLATFORM_LIB_PATH_INIT_HOOK(interp, lib_paths); #endif } /* =item C Updates library paths from the config hash stored in the interpreter. =cut */ PARROT_EXPORT void Parrot_lib_update_paths_from_config_hash(PARROT_INTERP) { ASSERT_ARGS(Parrot_lib_update_paths_from_config_hash) STRING * versionlib = NULL; STRING * entry = NULL; STRING * builddir = NULL; STRING * dynext_dirs = NULL; PMC * const lib_paths = VTABLE_get_pmc_keyed_int(interp, interp->iglobals, IGLOBALS_LIB_PATHS); PMC * const config_hash = VTABLE_get_pmc_keyed_int(interp, interp->iglobals, IGLOBALS_CONFIG_HASH); PMC * paths; if (VTABLE_elements(interp, config_hash)) { STRING * const libkey = CONST_STRING(interp, "libdir"); STRING * const verkey = CONST_STRING(interp, "versiondir"); STRING * const builddirkey = CONST_STRING(interp, "build_dir"); STRING * const installed = CONST_STRING(interp, "installed"); STRING * const dynextkey = CONST_STRING(interp, "dynext_dirs"); versionlib = VTABLE_get_string_keyed_str(interp, config_hash, libkey); entry = VTABLE_get_string_keyed_str(interp, config_hash, verkey); versionlib = Parrot_str_concat(interp, versionlib, entry); dynext_dirs = VTABLE_get_string_keyed_str(interp, config_hash, dynextkey); if (!VTABLE_get_integer_keyed_str(interp, config_hash, installed)) builddir = VTABLE_get_string_keyed_str(interp, config_hash, builddirkey); } paths = VTABLE_get_pmc_keyed_int(interp, lib_paths, PARROT_LIB_PATH_INCLUDE); if (!STRING_IS_NULL(builddir)) { entry = Parrot_str_concat(interp, builddir, CONST_STRING(interp, "/")); VTABLE_push_string(interp, paths, entry); entry = Parrot_str_concat(interp, builddir, CONST_STRING(interp, "/runtime/parrot/include/")); VTABLE_push_string(interp, paths, entry); } if (!STRING_IS_NULL(versionlib)) { entry = Parrot_str_concat(interp, versionlib, CONST_STRING(interp, "/include/")); VTABLE_push_string(interp, paths, entry); } entry = CONST_STRING(interp, "./"); VTABLE_push_string(interp, paths, entry); paths = VTABLE_get_pmc_keyed_int(interp, lib_paths, PARROT_LIB_PATH_LIBRARY); if (!STRING_IS_NULL(builddir)) { entry = Parrot_str_concat(interp, builddir, CONST_STRING(interp, "/runtime/parrot/library/")); VTABLE_push_string(interp, paths, entry); } if (!STRING_IS_NULL(versionlib)) { entry = Parrot_str_concat(interp, versionlib, CONST_STRING(interp, "/library/")); VTABLE_push_string(interp, paths, entry); } entry = CONST_STRING(interp, "./"); VTABLE_push_string(interp, paths, entry); paths = VTABLE_get_pmc_keyed_int(interp, lib_paths, PARROT_LIB_PATH_LANG); if (!STRING_IS_NULL(builddir)) { entry = Parrot_str_concat(interp, builddir, CONST_STRING(interp, "/runtime/parrot/languages/")); VTABLE_push_string(interp, paths, entry); } if (!STRING_IS_NULL(versionlib)) { entry = Parrot_str_concat(interp, versionlib, CONST_STRING(interp, "/languages/")); VTABLE_push_string(interp, paths, entry); } entry = CONST_STRING(interp, "./"); VTABLE_push_string(interp, paths, entry); paths = VTABLE_get_pmc_keyed_int(interp, lib_paths, PARROT_LIB_PATH_DYNEXT); if (!STRING_IS_NULL(builddir)) { entry = Parrot_str_concat(interp, builddir, CONST_STRING(interp, "/runtime/parrot/dynext/")); VTABLE_push_string(interp, paths, entry); } if (!STRING_IS_NULL(versionlib)) { entry = Parrot_str_concat(interp, versionlib, CONST_STRING(interp, "/dynext/")); VTABLE_push_string(interp, paths, entry); } #ifdef WIN32 entry = CONST_STRING(interp, "./"); VTABLE_push_string(interp, paths, entry); #endif if (!STRING_IS_NULL(dynext_dirs) && !STRING_IS_EMPTY(dynext_dirs)) { add_env_paths(interp, paths, dynext_dirs); } } /* =item C Return lib_paths as array of StringArrays with library searchpaths and shared extension used for loading various files at runtime. The structure looks like this: lib_paths = [ [ "runtime/parrot/include", ... ], # paths for .include 'file' [ "runtime/parrot/library", ... ], # paths for load_bytecode [ "runtime/parrot/dynext", ... ], # paths for loadlib [ "languages", ... ], # paths for languages [ ".so", ... ] # list of shared extensions ] =cut */ PARROT_WARN_UNUSED_RESULT PARROT_CANNOT_RETURN_NULL static PMC* get_search_paths(PARROT_INTERP, enum_lib_paths which) { ASSERT_ARGS(get_search_paths) PMC * const iglobals = interp->iglobals; PMC * const lib_paths = VTABLE_get_pmc_keyed_int(interp, iglobals, IGLOBALS_LIB_PATHS); return VTABLE_get_pmc_keyed_int(interp, lib_paths, which); } static const int path_separator = '/'; #ifdef WIN32 static const int win32_path_separator = '\\'; #endif /* =item C Determines whether a file name given by a fixed-8 or utf8 C is an absolute file name. Returns C<1> if the filename is absolute, returns C<0> otherwise. =cut */ PARROT_PURE_FUNCTION static int is_abs_path(PARROT_INTERP, ARGIN(const STRING *file)) { ASSERT_ARGS(is_abs_path) UINTVAL len = STRING_length(file); INTVAL c; if (len <= 1) return 0; c = STRING_ord(interp, file, 0); /* XXX ../foo, ./bar */ #ifdef WIN32 if (c == path_separator || c == win32_path_separator) return 1; if (len >= 3 && isalpha((unsigned char)c) && STRING_ord(interp, file, 1) == ':') { const INTVAL c2 = STRING_ord(interp, file, 2); if (c2 == path_separator || c2 == win32_path_separator) return 1; } #else if (c == path_separator) return 1; #endif return 0; } #ifdef WIN32 /* =item C Converts a path with forward slashes to one with backward slashes. =cut */ PARROT_WARN_UNUSED_RESULT PARROT_CANNOT_RETURN_NULL static STRING * cnv_to_win32_filesep(PARROT_INTERP, ARGIN(const STRING *path)) { ASSERT_ARGS(cnv_to_win32_filesep) const UINTVAL len = STRING_length(path); STRING *res = Parrot_str_new_noinit(interp, path->bufused); String_iter src, dst; res->encoding = path->encoding; STRING_ITER_INIT(interp, &src); STRING_ITER_INIT(interp, &dst); while (src.charpos < len) { INTVAL c = STRING_iter_get_and_advance(interp, path, &src); if (c == path_separator) c = win32_path_separator; STRING_iter_set_and_advance(interp, res, &dst, c); } res->bufused = dst.bytepos; res->strlen = dst.charpos; return res; } #endif /* =item C unary path argument. the path string will have a trailing path-separator appended if it is not there already. =cut */ PARROT_WARN_UNUSED_RESULT PARROT_CANNOT_RETURN_NULL static STRING* path_guarantee_trailing_separator(PARROT_INTERP, ARGIN(STRING *path)) { ASSERT_ARGS(path_guarantee_trailing_separator) /* make sure the path has a trailing slash before appending the file */ if (STRING_ord(interp, path, -1) != (UINTVAL)path_separator) path = Parrot_str_concat(interp, path, Parrot_str_chr(interp, path_separator)); return path; } /* =item C binary path arguments. A new string is created that is the concatenation of the two path components with a path-separator. =cut */ PARROT_WARN_UNUSED_RESULT PARROT_CANNOT_RETURN_NULL static STRING* path_concat(PARROT_INTERP, ARGIN(STRING *l_path), ARGIN(const STRING *r_path)) { ASSERT_ARGS(path_concat) STRING* join; join = path_guarantee_trailing_separator(interp, l_path); join = Parrot_str_concat(interp, join, r_path); return join; } /* =item C Split the env string into its components and add the entries to the libpath. =cut */ static void add_env_paths(PARROT_INTERP, ARGIN(PMC *libpath), ARGIN(const STRING *envstr)) { ASSERT_ARGS(add_env_paths) if (!STRING_IS_NULL(envstr) && !STRING_IS_EMPTY(envstr)) { #ifdef WIN32 STRING * const env_search_path_sep = CONST_STRING(interp, ";"); #else STRING * const env_search_path_sep = CONST_STRING(interp, ":"); #endif INTVAL start = 0; INTVAL index; if ((index = STRING_index(interp, envstr, env_search_path_sep, start)) >= 0) { STRING * entry; do { entry = STRING_substr(interp, envstr, start, index - start); if (!STRING_IS_EMPTY(entry)) { /* skip empty, as in ":/path" */ VTABLE_push_string(interp, libpath, path_guarantee_trailing_separator(interp, entry)); } start = index + 1; } while ((index = STRING_index(interp, envstr, env_search_path_sep, start)) >= 0); entry = STRING_substr(interp, envstr, start, STRING_length(envstr) - start); if (!STRING_IS_EMPTY(entry)) VTABLE_push_string(interp, libpath, path_guarantee_trailing_separator(interp, entry)); } else { STRING * env = Parrot_str_clone(interp, envstr); VTABLE_push_string(interp, libpath, path_guarantee_trailing_separator(interp, env)); } } } /* =item C Attempts to load a file with name C. If the file is successfully located, the finalized name of the file is returned as a STRING. Otherwise, returns NULL. =cut */ PARROT_WARN_UNUSED_RESULT PARROT_CAN_RETURN_NULL static STRING* try_load_path(PARROT_INTERP, ARGIN(STRING* path)) { ASSERT_ARGS(try_load_path) #ifdef WIN32 path = cnv_to_win32_filesep(interp, path); #endif if (Parrot_file_stat_intval(interp, path, STAT_EXISTS)) { return path; } return NULL; } /* =item C Guess extensions, so that the user can drop the extensions leaving it up to the build process/install whether or not a .pbc, .pasm or a .pir file is used. =cut */ PARROT_WARN_UNUSED_RESULT PARROT_CAN_RETURN_NULL static STRING* try_bytecode_extensions(PARROT_INTERP, ARGIN(STRING* path)) { ASSERT_ARGS(try_bytecode_extensions) STRING *test_path, *result; STRING * const bytecode_extension = CONST_STRING(interp, ".pbc"); STRING * const pir_extension = CONST_STRING(interp, ".pir"); STRING * const pasm_extension = CONST_STRING(interp, ".pasm"); test_path = path; /* First try the path as given. */ result = try_load_path(interp, test_path); if (result) return result; /* If the original requested file doesn't exist, try it with a different extension. A requested PIR or PASM file will check for a corresponding bytecode file. A requested bytecode file will check first for a corresponding PIR file, then for a PASM file. */ if (!STRING_IS_NULL(test_path)) { if (STRING_length(test_path) > 4) { STRING * const orig_ext = STRING_substr(interp, test_path, -4, 4); /* First try substituting .pbc for the .pir extension */ if (STRING_equal(interp, orig_ext, pir_extension)) { STRING * const without_ext = Parrot_str_chopn(interp, test_path, 4); test_path = Parrot_str_concat(interp, without_ext, bytecode_extension); result = try_load_path(interp, test_path); if (result) return result; } /* Next try substituting .pir, then .pasm for the .pbc extension */ else if (STRING_equal(interp, orig_ext, bytecode_extension)) { STRING * const without_ext = Parrot_str_chopn(interp, test_path, 4); test_path = Parrot_str_concat(interp, without_ext, pir_extension); result = try_load_path(interp, test_path); if (result) return result; test_path = Parrot_str_concat(interp, without_ext, pasm_extension); result = try_load_path(interp, test_path); if (result) return result; } } /* Finally, try substituting .pbc for the .pasm extension. */ if (STRING_length(test_path) > 5) { STRING * const orig_ext = STRING_substr(interp, test_path, -5, 5); if (STRING_equal(interp, orig_ext, pasm_extension)) { STRING * const without_ext = Parrot_str_chopn(interp, test_path, 5); test_path = Parrot_str_concat(interp, without_ext, bytecode_extension); result = try_load_path(interp, test_path); if (result) return result; } } } return NULL; } /* =item C Add a path to the library searchpath of the given type (passing in a STRING). =cut */ PARROT_EXPORT void Parrot_lib_add_path(PARROT_INTERP, ARGIN(STRING *path_str), enum_lib_paths which) { ASSERT_ARGS(Parrot_lib_add_path) PMC * const iglobals = interp->iglobals; PMC * const lib_paths = VTABLE_get_pmc_keyed_int(interp, iglobals, IGLOBALS_LIB_PATHS); PMC * const paths = VTABLE_get_pmc_keyed_int(interp, lib_paths, which); VTABLE_unshift_string(interp, paths, path_str); } /* =item C Add a path to the library searchpath of the given type (passing in a C string). =cut */ PARROT_EXPORT void Parrot_lib_add_path_from_cstring(PARROT_INTERP, ARGIN(const char *path), enum_lib_paths which) { ASSERT_ARGS(Parrot_lib_add_path_from_cstring) STRING * const path_str = Parrot_str_new(interp, path, 0); Parrot_lib_add_path(interp, path_str, which); } /* =item C Locate the full path for C and the given file type(s). The C is one or more of the types defined in F. =cut */ PARROT_EXPORT PARROT_WARN_UNUSED_RESULT PARROT_CAN_RETURN_NULL STRING* Parrot_locate_runtime_file_str(PARROT_INTERP, ARGIN(STRING *file), enum_runtime_ft type) { ASSERT_ARGS(Parrot_locate_runtime_file_str) STRING *prefix; STRING *full_name; PMC *paths; INTVAL i, n; /* if this is an absolute path return it as is */ if (is_abs_path(interp, file)) return file; if (type & PARROT_RUNTIME_FT_LANG) paths = get_search_paths(interp, PARROT_LIB_PATH_LANG); else if (type & PARROT_RUNTIME_FT_DYNEXT) paths = get_search_paths(interp, PARROT_LIB_PATH_DYNEXT); else if (type & (PARROT_RUNTIME_FT_PBC | PARROT_RUNTIME_FT_SOURCE)) paths = get_search_paths(interp, PARROT_LIB_PATH_LIBRARY); else paths = get_search_paths(interp, PARROT_LIB_PATH_INCLUDE); prefix = Parrot_get_runtime_path(interp); n = VTABLE_elements(interp, paths); for (i = 0; i < n; ++i) { STRING * const path = VTABLE_get_string_keyed_int(interp, paths, i); STRING *found_name; full_name = path_concat(interp, path, file); found_name = (type & PARROT_RUNTIME_FT_DYNEXT) ? try_load_path(interp, full_name) : try_bytecode_extensions(interp, full_name); if (found_name) return found_name; if (STRING_length(prefix) && !is_abs_path(interp, path)) { full_name = path_concat(interp, prefix, full_name); found_name = (type & PARROT_RUNTIME_FT_DYNEXT) ? try_load_path(interp, full_name) : try_bytecode_extensions(interp, full_name); if (found_name) return found_name; } } full_name = (type & PARROT_RUNTIME_FT_DYNEXT) ? try_load_path(interp, file) : try_bytecode_extensions(interp, file); return full_name; } /* =item C Locate the full path for C and the given file type(s). If successful, returns a C-string allocated with C or NULL otherwise. Remember to free the string with C. If successful, the returned STRING is 0-terminated so that Cstrstart> is usable as B c-string for C library functions like fopen(3). This is the preferred API function. The C is one or more of the types defined in F. =cut */ PARROT_EXPORT PARROT_WARN_UNUSED_RESULT PARROT_CAN_RETURN_NULL PARROT_MALLOC char* Parrot_locate_runtime_file(PARROT_INTERP, ARGIN(const char *file_name), enum_runtime_ft type) { ASSERT_ARGS(Parrot_locate_runtime_file) STRING * const file = Parrot_str_new(interp, file_name, 0); STRING * const result = Parrot_locate_runtime_file_str(interp, file, type); /* * XXX valgrind shows e.g. * invalid read of size 8 inside a string of length 69 * at position 64 * it seems that dlopen accesses words beyond the string end * * see also the log at #37814 */ return result ? Parrot_str_to_cstring(interp, result) : NULL; } /* =item C Return a string for the runtime prefix. =cut */ PARROT_EXPORT PARROT_CANNOT_RETURN_NULL STRING * Parrot_get_runtime_path(PARROT_INTERP) { ASSERT_ARGS(Parrot_get_runtime_path) STRING * const env = Parrot_getenv(interp, CONST_STRING(interp, "PARROT_RUNTIME")); STRING *result; if (!STRING_IS_NULL(env)) { result = env; } else { PMC * const config_hash = VTABLE_get_pmc_keyed_int(interp, interp->iglobals, (INTVAL) IGLOBALS_CONFIG_HASH); if (VTABLE_elements(interp, config_hash)) { STRING * const key = CONST_STRING(interp, "prefix"); result = VTABLE_get_string_keyed_str(interp, config_hash, key); } else result = CONST_STRING(interp, "."); } return result; } /* =item C Split the pathstring C into . Return the C of the pathstring. Set C to the part without extension and C to the extension or NULL. =cut */ PARROT_EXPORT PARROT_IGNORABLE_RESULT PARROT_CANNOT_RETURN_NULL STRING * parrot_split_path_ext(PARROT_INTERP, ARGIN(STRING *in), ARGOUT(STRING **wo_ext), ARGOUT(STRING **ext)) { ASSERT_ARGS(parrot_split_path_ext) /* This is a quick fix for TT #65 * TODO: redo it with the string reimplementation */ STRING * const slash1 = CONST_STRING(interp, "/"); STRING * const slash2 = CONST_STRING(interp, "\\"); STRING * const dot = CONST_STRING(interp, "."); const INTVAL len = STRING_length(in); STRING *stem; INTVAL pos_sl, pos_dot; pos_sl = STRING_rindex(interp, in, slash1, len); if (pos_sl == -1) pos_sl = STRING_rindex(interp, in, slash2, len); pos_dot = STRING_rindex(interp, in, dot, len); /* ignore dot in directory name */ if (pos_dot != -1 && pos_dot < pos_sl) pos_dot = -1; ++pos_dot; ++pos_sl; if (pos_sl && pos_dot) { stem = STRING_substr(interp, in, pos_sl, pos_dot - pos_sl - 1); *wo_ext = STRING_substr(interp, in, 0, pos_dot - 1); *ext = STRING_substr(interp, in, pos_dot, len - pos_dot); } else if (pos_dot) { stem = STRING_substr(interp, in, 0, pos_dot - 1); *wo_ext = stem; *ext = STRING_substr(interp, in, pos_dot, len - pos_dot); } else if (pos_sl) { stem = STRING_substr(interp, in, pos_sl, len - pos_sl); *wo_ext = in; *ext = STRINGNULL; } else { stem = in; *wo_ext = stem; *ext = STRINGNULL; } return stem; } /* =item C Returns a STRING that contains the specified search path, separated by colons (:). The C is one or more of the types defined in F. =cut */ PARROT_EXPORT PARROT_WARN_UNUSED_RESULT PARROT_CAN_RETURN_NULL STRING* Parrot_lib_search_paths_as_string(PARROT_INTERP, enum_runtime_ft type) { ASSERT_ARGS(Parrot_lib_search_paths_as_string) PMC *paths; /* TODO: Get the real separator, not this hacked-together stuff */ #ifdef WIN32 STRING * const env_search_path_sep = CONST_STRING(interp, ";"); #else STRING * const env_search_path_sep = CONST_STRING(interp, ":"); #endif if (type & PARROT_RUNTIME_FT_DYNEXT) paths = get_search_paths(interp, PARROT_LIB_PATH_DYNEXT); else if (type & (PARROT_RUNTIME_FT_PBC | PARROT_RUNTIME_FT_SOURCE)) paths = get_search_paths(interp, PARROT_LIB_PATH_LIBRARY); else paths = get_search_paths(interp, PARROT_LIB_PATH_INCLUDE); return Parrot_str_join(interp, env_search_path_sep, paths); } /* =back =head1 SEE ALSO F =cut */ /* * Local variables: * c-file-style: "parrot" * End: * vim: expandtab shiftwidth=4 cinoptions='\:2=2' : */ neg_0-01.t000644000765000765 645212140013540 15427 0ustar00bruce000000000000parrot-6.6.0/t/steps/auto#! perl # Copyright (C) 2009, Parrot Foundation. # auto_neg_0-01.t use strict; use warnings; use Test::More tests => 23; use Carp; use lib qw( lib t/configure/testlib ); use_ok('config::auto::neg_0'); use Parrot::Configure::Options qw( process_options ); use Parrot::Configure::Step::Test; use Parrot::Configure::Test qw( test_step_constructor_and_description ); use IO::CaptureOutput 'capture'; ########### regular ########### my ($args, $step_list_ref) = process_options( { argv => [ ], mode => 'configure', } ); my $conf = Parrot::Configure::Step::Test->new; $conf->include_config_results( $args ); my $pkg = 'auto::neg_0'; $conf->add_steps($pkg); my $serialized = $conf->pcfreeze(); $conf->options->set( %{$args} ); my $step = test_step_constructor_and_description($conf); my $ret = $step->runstep($conf); ok( $ret, 'runstep() returned true value' ); ok( defined $step->result(), 'A result has been defined'); $conf->replenish($serialized); ##### _evaluate_cc_run() ##### ($args, $step_list_ref) = process_options( { argv => [ ], mode => 'configure', } ); $conf->options->set( %{$args} ); $step = test_step_constructor_and_description($conf); my $d_neg_0; my $orig_has_neg_0 = 0; $d_neg_0 = '-0'; is( $step->_evaluate_cc_run($conf, $d_neg_0, $orig_has_neg_0), 1, '_evaluate_cc_run() completed satisfactorily' ); is( $step->result(), 'yes', 'Got expected result'); $d_neg_0 = '0'; is( $step->_evaluate_cc_run($conf, $d_neg_0, $orig_has_neg_0), 0, '_evaluate_cc_run() completed satisfactorily' ); is( $step->result(), 'no', 'Got expected result' ); $conf->replenish($serialized); ########## --verbose; _evaluate_cc_run() ########## ($args, $step_list_ref) = process_options( { argv => [ q{--verbose} ], mode => q{configure}, } ); $conf->add_steps($pkg); $conf->options->set( %{$args} ); $step = test_step_constructor_and_description($conf); my $has_neg_0; $d_neg_0 = '-0'; { my ($stdout, $stderr); capture( sub { $has_neg_0 = $step->_evaluate_cc_run( $conf, $d_neg_0, $orig_has_neg_0 ); }, \$stdout, ); is( $has_neg_0, 1, 'Got expected return value from _evaluate_cc_run()' ); is( $step->result(), 'yes', 'Got expected result: yes' ); like( $stdout, qr/\(yes\)/, 'Got expected verbose output' ); } $d_neg_0 = '0'; { my ($stdout, $stderr); capture( sub { $has_neg_0 = $step->_evaluate_cc_run( $conf, $d_neg_0, $orig_has_neg_0 ); }, \$stdout, ); is( $has_neg_0, 0, 'Got expected return value from _evaluate_cc_run()' ); is( $step->result(), 'no', 'Got expected result: no' ); like( $stdout, qr/\(no\)/, 'Got expected verbose output' ); } pass("Completed all tests in $0"); ################### DOCUMENTATION ################### =head1 NAME auto_neg_0-01.t - test auto::neg_0 =head1 SYNOPSIS % prove t/steps/auto_neg_0-01.t =head1 DESCRIPTION The files in this directory test functionality used by F. The tests in this file test auto::neg_0. =head1 AUTHOR Reini Urban =head1 SEE ALSO config::auto::neg_0, F. =cut # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: main.pasm000644000765000765 132311533177637 15371 0ustar00bruce000000000000parrot-6.6.0/src/dynpmc# Copyright (C) 2003-2009, Parrot Foundation. # experimental subproxy class test # the bytecode loading is deferred until the subproxy object is # invoked. Then the subproxy acts as a normal sub # running: # $ export LD_LIBRARY_PATH=.:blib/lib # $ make -C src/dynpmc # $ parrot src/dynpmc/main.pasm _main: loadlib P1, "subproxy" # set up which Sub should eventually be called new P3, 'Key' set P3, "src/dynpmc/ext.pir" # file - FIXME path handling new P4, 'Key' set P4, "_ext_main" # sub label push P3, P4 new P0, "SubProxy" assign P0, P3 invokecc P0 print "back\n" invokecc P0 print "back\n" end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: archive_zip.t000644000765000765 404211533177644 16100 0ustar00bruce000000000000parrot-6.6.0/t/library#!./parrot # Copyright (C) 2010, Parrot Foundation. =head1 NAME t/library/archive_zip.t =head1 DESCRIPTION Test the Archive/Zip library =head1 SYNOPSIS % prove t/library/archive_zip.t =cut .sub 'main' :main .include 'test_more.pir' .include 'iglobals.pasm' .local pmc config_hash, interp interp = getinterp config_hash = interp[.IGLOBALS_CONFIG_HASH] $S0 = config_hash['has_zlib'] unless $S0 goto no_zlib plan(14) load_bytecode 'Archive/Zip.pir' test_new() test_pack() .return() no_zlib: skip_all('No zlib library available') .return() .end .sub 'test_new' $P0 = new ['Archive';'Zip'] $I0 = isa $P0, ['Archive';'Zip'] ok($I0, "new ['Archive';'Zip']") $I0 = isa $P0, ['Archive';'Zip';'Base'] ok($I0, "is a ['Archive';'Zip';'Base']") $P0 = new ['Archive';'Zip';'Member'] $I0 = isa $P0, ['Archive';'Zip';'Member'] ok($I0, "new ['Archive';'Zip';'Member']") $I0 = isa $P0, ['Archive';'Zip';'Base'] ok($I0, "is a ['Archive';'Zip';'Base']") $P0 = new ['Archive';'Zip';'FileMember'] $I0 = isa $P0, ['Archive';'Zip';'FileMember'] ok($I0, "new ['Archive';'Zip';'FileMember']") $I0 = isa $P0, ['Archive';'Zip';'Member'] ok($I0, "is a ['Archive';'Zip';'Member']") $P0 = new ['Archive';'Zip';'NewFileMember'] $I0 = isa $P0, ['Archive';'Zip';'NewFileMember'] ok($I0, "new ['Archive';'Zip';'NewFileMember']") $I0 = isa $P0, ['Archive';'Zip';'FileMember'] ok($I0, "is a ['Archive';'Zip';'FileMember']") .end .sub 'test_pack' $P0 = new ['Archive';'Zip'] $S0 = $P0.'pack_C'(0x12) is( $S0, "\x12", "pack C (unsigned char)" ) $I0 = length $S0 is( $I0, 1 ) $S0 = $P0.'pack_v'(0x1234) is( $S0, "\x34\x12", "pack v (16bits litle endian)" ) $I0 = length $S0 is( $I0, 2 ) $S0 = $P0.'pack_V'(0x12345678) is( $S0, "\x78\x56\x34\x12", "pack V (32bits litle endian)" ) $I0 = length $S0 is( $I0, 4 ) .end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: alignof.pm000644000765000765 644112101554066 15665 0ustar00bruce000000000000parrot-6.6.0/config/auto# Copyright (C) 2012, Parrot Foundation. =head1 NAME config/auto/alignof.pm - clang++ offsetof values =head1 DESCRIPTION Determines the offsetof() values of our types, if the compiler cannot do compile-time ALIGNOF definitions via offsetof(). clang++ or strict C++ compilers need this step, to calculate these pre-compiled PARROT_ALIGNOF_* definitions. =cut package auto::alignof; use strict; use warnings; use base qw(Parrot::Configure::Step); use Parrot::Configure::Utils ':auto'; sub _init { my $self = shift; my %data; $data{description} = q{Determine offsetof values for our types}; $data{result} = q{}; return \%data; } sub runstep { my ( $self, $conf ) = @_; # This step only needed for clang++ if (test_if_needed($conf)) { # Can do compile-time ALIGNOF definitions via offsetof() $conf->data->set( 'HAS_COMPILER_OFFSETOF_ALIGNOF' => 1 ); $conf->debug("DEBUG: auto::alignof is only needed for clang++\n"); $self->set_result('skipped'); return 1; } # Need pre-compiled PARROT_ALIGNOF_* definitions $conf->data->set( 'HAS_COMPILER_OFFSETOF_ALIGNOF' => 0 ); my %types = ( intval => $conf->data->get('iv'), floatval => $conf->data->get('nv'), stringptr => 'STRING *', pmcptr => 'PMC *', char => 'char', short => 'short', int => 'int', long => 'long', uchar => 'unsigned char', ushort => 'unsigned short', uint => 'unsigned int', ulong => 'unsigned long', float => 'float', double => 'double', longdouble => 'long double', Parrot_Int1 => 'char', Parrot_Int2 => 'short', Parrot_Int4 => 'int', Parrot_Int8 => 'long long', charptr => 'char *', voidptr => 'void *', funcptr_t => 'funcptr_t', longlong => 'long long', ulonglong => 'unsigned long long', __float128 => '__float128', ); my $alignof = ''; for my $name (keys %types) { my $type = $types{$name}; my $value = test_alignof($conf, $name, $type); $alignof .= ' '.$name; if ($value) { $conf->data->set( 'PARROT_ALIGNOF_'.$name => $value ); } } $conf->data->set( 'alignof' => $alignof ); $self->set_result('done'); return 1; } #################### INTERNAL SUBROUTINES #################### sub test_if_needed { my ($conf) = @_; $conf->data->set( TEMP_type => 'int' ); my ($cc_inc, $ccflags) = $conf->data->get( 'cc_inc', 'ccflags' ); $conf->cc_gen('config/auto/alignof/test_c.in'); eval { $conf->cc_build("$cc_inc -DCHECK_COMPILER_OFFSETOF_ALIGNOF") }; my $ret = $@ ? 0 : eval $conf->cc_run(); $conf->cc_clean(); return $ret; } sub test_alignof { my ($conf, $name, $type) = @_; $conf->data->set( TEMP_type => $type ); my ($cc_inc, $ccflags) = $conf->data->get( 'cc_inc', 'ccflags' ); $conf->cc_gen('config/auto/alignof/test_c.in'); eval { $conf->cc_build("$cc_inc -x c++") }; my $ret = $@ ? 0 : eval $conf->cc_run(); $conf->cc_clean(); return $ret; } 1; # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: resizablepmcarray.t000644000765000765 6360011715102036 16435 0ustar00bruce000000000000parrot-6.6.0/t/pmc#!./parrot # Copyright (C) 2001-2011, Parrot Foundation. =head1 NAME t/pmc/resizablepmcarray.t - testing the ResizablePMCArray PMC =head1 SYNOPSIS % prove t/pmc/resizablepmcarray.t =head1 DESCRIPTION Tests C PMC. Checks size, sets various elements, including out-of-bounds test. Checks INT and PMC keys. =cut .include 'except_types.pasm' .sub main :main .include 'fp_equality.pasm' .include 'test_more.pir' plan(151) init_tests() resize_tests() negative_array_size() set_tests() exception_tests() set_keyed_get_keyed_tests() interface_check() inherited_sort_method() sort_subclass() push_pmc() push_int() push_string() shift_int() unshift_pmc() get_mro_tests() push_and_pop() unshift_and_shift() shift_empty() pop_empty() multikey_access() exists_and_defined() delete_keyed() get_rep() append_tests() splice_tests() splice_replace1() splice_replace2() iterate_subclass_of_rpa() method_forms_of_unshift_etc() sort_with_broken_cmp() equality_tests() sort_tailcall() push_to_subclasses_array() test_assign_from_another() test_assign_self() test_assign_non_array() method_reverse() .end .sub init_negative .local pmc p p = new ['ResizablePMCArray'], -1 .end .sub init_tests .const 'Sub' negative = 'init_negative' throws_type(negative, .EXCEPTION_OUT_OF_BOUNDS, 'new with negative size fails') .end .sub resize_tests .local pmc p .local int is_ok, i p = new ['ResizablePMCArray'] i = p is_ok = i == 0 ok(is_ok, "resize test (0)") p = 1 i = p is_ok = i == 1 ok(is_ok, "resize test (1)") p = 5 i = p is_ok = i == 5 ok(is_ok, "resize test (5)") p = 9 i = p is_ok = i == 9 ok(is_ok, "resize test (9)") p = 7 i = p is_ok = i == 7 ok(is_ok, "resize test (7)") .end .sub negative_array_size .local pmc p .local int is_ok, i p = new ['ResizablePMCArray'] push_eh eh p = -1 pop_eh ok(0, "exception not caught") goto end eh: ok(1, "exception caught") end: .end .sub set_tests .local pmc p .local int is_ok, i .local num n .local string s p = new ['ResizablePMCArray'] p = 1 p[0] = -7 i = p[0] is_ok = i == -7 ok(is_ok, "INTVAL assignment to first element") p[0] = 3.7 n = p[0] is_ok = n == 3.7 ok(is_ok, "FLOATVAL assignment to first element") p[0] = "muwhahaha" s = p[0] is_ok = s == "muwhahaha" ok(is_ok, "STRING assignment to first element") p[1] = -7 i = p[1] is_ok = i == -7 ok(is_ok, "INTVAL assignment to second element") p[1] = 3.7 n = p[1] is_ok = n == 3.7 ok(is_ok, "FLOATVAL assignment to second element") p[1] = "muwhahaha" s = p[1] is_ok = s == "muwhahaha" ok(is_ok, "STRING assignment to second element") p[10] = -7 i = p[10] is_ok = i == -7 ok(is_ok, "INTVAL assignment to last element") p[10] = 3.7 n = p[10] is_ok = n == 3.7 ok(is_ok, "FLOATVAL assignment to last element") p[10] = "muwhahaha" s = p[10] is_ok = s == "muwhahaha" ok(is_ok, "STRING assignment to last element") .end .sub exception_tests .local pmc rpa, i rpa = new ['ResizablePMCArray'] rpa = 1 i = new ['Integer'] i = 12345 push_eh eh1 rpa[10] = i pop_eh goto no_eh1 eh1: ok(0, "unwanted ex thrown for out-of-bounds index") goto test2 no_eh1: ok(1, "no ex thrown for out-of-bounds index") test2: rpa = 1 push_eh eh2 rpa[-10] = i pop_eh goto no_eh2 eh2: ok(1, "ex thrown for negative index") goto test3 no_eh2: ok(0, "no ex thrown for negative index") test3: rpa = 1 push_eh eh3 i = rpa[10] pop_eh goto no_eh3 eh3: ok(0, "unwanted ex thrown for out-of-bounds index") goto test4 no_eh3: ok(1, "no ex thrown for out-of-bounds index") test4: rpa = 1 push_eh eh4 i = rpa[-10] pop_eh goto no_eh4 eh4: ok(1, "ex thrown for negative index") goto end no_eh4: ok(0, "no ex thrown for negative index") end: .end .sub set_keyed_get_keyed_tests new $P0, ['ResizablePMCArray'] new $P1, ['Key'] set $P1, 0 set $P0[$P1], 25 set $P1, 1 set $P0[$P1], 2.5 set $P1, 2 set $P0[$P1], "bleep" new $P2, ['String'] set $P2, "Bloop" set $P1, 3 set $P0[$P1], $P2 set $I0, $P0[0] is($I0, 25, "set int via Key PMC, get int via int") set $N0, $P0[1] .fp_eq($N0, 2.5, OK1) ok(0, "set num via Key PMC, get num via int fails") goto NOK1 OK1: ok(1, "set num via Key PMC, get num via int fails") NOK1: set $S0, $P0[2] is($S0, "bleep", "set string via Key PMC, get string via int") new $P3, ['Undef'] set $P3, $P0[3] set $S0, $P3 is($S0, "Bloop", "set PMC via Key PMC, get PMC via PMC") new $P0, ['ResizablePMCArray'] set $P0, 1 set $P0[25], 125 set $P0[128], 10.2 set $P0[513], "cow" new $P1, ['Integer'] set $P1, 123456 set $P0[1023], $P1 new $P2, ['Key'] set $P2, 25 set $I0, $P0[$P2] is($I0, 125, "set int via int, get int via Key PMC") set $P2, 128 set $N0, $P0[$P2] .fp_eq($N0, 10.2, OK2) ok(0, "set num via int, get num via Key PMC") goto NOK2 OK2: ok(1, "set num via int, get num via Key PMC") NOK2: set $P2, 513 set $S0, $P0[$P2] is($S0, "cow", "set string via int, get string via Key PMC") set $P2, 1023 set $P3, $P0[$P2] set $I1, $P3 is($I1, 123456, "set int via int, get int via Key PMC") .end .sub interface_check .local pmc p p = new ['ResizablePMCArray'] .local int b does b, p, "scalar" is(b, 0 ,"ResizablePMCArray doesn't do scalar") does b, p, "array" is(b, 1, "ResizablePMCArray does array") does b, p, "no_interface" is(b, 0, "ResizablePMCArray doesn't do no_interface") .end .sub inherited_sort_method .local pmc ar ar = new ['ResizablePMCArray'] ar[0] = 10 ar[1] = 2 ar[2] = 5 ar[3] = 9 ar[4] = 1 .local pmc cmp_fun null cmp_fun ar."sort"(cmp_fun) .local string sorted sorted = '' .local pmc it iter it, ar lp: unless it goto done $P0 = shift it $S0 = $P0 sorted = concat sorted, $S0 sorted = concat sorted, " " goto lp done: is(sorted, "1 2 5 9 10 ", "inherited sort method works") .end .sub sort_subclass .local pmc subrpa, arr subrpa = subclass ['ResizablePMCArray'], 'ssRPA' arr = new subrpa arr[0] = 'p' arr[1] = 'a' arr[2] = 'z' # Use a comparator that gives a reverse alphabetical order # to make sure sort is using it, and not some default from # elsewhere. .local pmc comparator comparator = get_global 'compare_reverse' arr.'sort'(comparator) .local string s, aux s = typeof arr s = concat s, ':' aux = join '-', arr s = concat s, aux is(s, 'ssRPA:z-p-a', "sort works in a pir subclass, GH #303") .end .sub compare_reverse .param string a .param string b $I0 = cmp b, a .return($I0) .end .sub push_pmc .local pmc pmc_arr, pmc_9999, pmc_10000 pmc_arr = new ['ResizablePMCArray'] pmc_9999 = new ['Float'] pmc_9999 = 10000.10000 pmc_10000 = new ['Float'] pmc_10000 = 123.123 pmc_arr[9999] = pmc_9999 push pmc_arr, pmc_10000 .local int elements elements = pmc_arr is(elements, 10001, "element count is correct") .local pmc last last = pmc_arr[10000] is(last, 123.123, "last element has correct value") .end .sub push_int .local pmc pmc_arr, pmc_9999 .local int int_10000 pmc_arr = new ['ResizablePMCArray'] pmc_9999 = new ['Float'] pmc_9999 = 10000.10000 int_10000 = 123 pmc_arr[9999] = pmc_9999 push pmc_arr, int_10000 .local int elements elements = pmc_arr is(elements, 10001, "element count is correct") .local pmc last last = pmc_arr[10000] is(last, 123, "last element has correct value") .end .sub push_string .local pmc pmc_arr, pmc_9999 .local string string_10000 pmc_arr = new ['ResizablePMCArray'] pmc_9999 = new ['Float'] pmc_9999 = 10000.10000 string_10000 = '123asdf' pmc_arr[9999] = pmc_9999 push pmc_arr, string_10000 .local int elements elements = pmc_arr is(elements, 10001, "element count is correct") .local pmc last last = pmc_arr[10000] is(last, "123asdf", "last element has correct value") .end .sub shift_int .local pmc pmc_arr, elem pmc_arr = new ['ResizablePMCArray'] push pmc_arr, 4 push pmc_arr, 3 push pmc_arr, 2 push pmc_arr, 1 push pmc_arr, 0 .local int elements elements = pmc_arr is(elements, 5, "element count is correct") elem = shift pmc_arr is(elem, 4, "correct element unshifted") elements = pmc_arr is(elements, 4, "correct element count after unshifing") elem = shift pmc_arr is(elem, 3, "correct element unshifted") elements = pmc_arr is(elements, 3, "correct element count after unshifing") elem = shift pmc_arr is(elem, 2, "correct element unshifted") elements = pmc_arr is(elements, 2, "correct element count after unshifing") elem = shift pmc_arr is(elem, 1, "correct element unshifted") elements = pmc_arr is(elements, 1, "correct element count after unshifing") elem = shift pmc_arr is(elem, 0, "correct element unshifted") elements = pmc_arr is(elements, 0, "correct element count after unshifing") .end .sub unshift_pmc new $P0, ['ResizablePMCArray'] new $P1, ['Integer'] set $P1, 1 new $P2, ['Integer'] set $P2, 2 new $P3, ['Integer'] set $P3, 3 unshift $P0, $P1 unshift $P0, $P2 unshift $P0, $P3 elements $I0, $P0 is($I0, 3, "element count is correct") set $P3, $P0[0] is($P3, 3, "element 0 has correct value") set $P3, $P0[1] is($P3, 2, "element 1 has correct value") set $P3, $P0[2] is($P3, 1, "element 2 has correct value") .end .sub get_mro_tests new $P0, ['ResizablePMCArray'] $P1 = inspect $P0, 'mro' ok(1, "get_mro didn't explode") elements $I1, $P1 null $I0 $S1 = '' loop: set $P2, $P1[$I0] typeof $S0, $P2 $S1 = concat $S1, $S0 $S1 = concat $S1, "," inc $I0 lt $I0, $I1, loop is($S1, "ResizablePMCArray,FixedPMCArray,", "ResizablePMCArrays have the right MRO") .end .sub push_and_pop .local num f, f_elem .local int i, i_elem, elements .local pmc p, p_elem, pmc_arr .local string s, s_elem f = 123.123 i = 123 p = new ['Float'] p = 456.456 s = "abc" pmc_arr = new ['ResizablePMCArray'] elements = pmc_arr is(elements, 0, "element count of empty ResizablePMCArray is 0") push pmc_arr, s push pmc_arr, p push pmc_arr, i push pmc_arr, f elements = pmc_arr is(elements, 4, "element count after several push operations is correct") f_elem = pop pmc_arr is(f_elem, 123.123000, "shifted float is correct") i_elem = pop pmc_arr is(i_elem, 123, "shifted int is correct") p_elem = pop pmc_arr is(p_elem, 456.456, "shifted PMC is correct") s_elem = pop pmc_arr is(s_elem, "abc", "shifted string is correct") elements = pmc_arr is(elements, 0, "element count after several shift operations is correct") .end .sub unshift_and_shift .local num f, f_elem .local int i, i_elem, elements .local pmc p, p_elem, pmc_arr .local string s, s_elem f = 123.123 i = 123 p = new ['Float'] p = 456.456 s = "abc" pmc_arr = new ['ResizablePMCArray'] elements = pmc_arr is(elements, 0, "empty RPA has 0 elements") unshift pmc_arr, f unshift pmc_arr, i unshift pmc_arr, p unshift pmc_arr, s elements = pmc_arr is(elements, 4, "RPA has 4 elements after 4 unshifts") s_elem = shift pmc_arr is(s_elem, "abc", "shifted string has correct value") p_elem = shift pmc_arr is(p_elem, 456.456, "shifted pmc has correct value") i_elem = shift pmc_arr is(i_elem, 123, "shifted int has correct value") f_elem = shift pmc_arr is(f_elem, 123.123000, "shifted num has correct value") elements = pmc_arr is(elements, 0, "expectedly empty RPA has 0 elements") .end .sub shift_empty .local pmc pmc_arr pmc_arr = new ['ResizablePMCArray'] $I1 = 0 push_eh handle_i $I0 = shift pmc_arr inc $I1 handle_i: pop_eh is($I1, 0, 'shift int from empty RPA throws') push_eh handle_n $N0 = shift pmc_arr inc $I1 handle_n: pop_eh is($I1, 0, 'shift num from empty RPA throws') push_eh handle_s $S0 = shift pmc_arr inc $I1 handle_s: pop_eh is($I1, 0, 'shift string from empty RPA throws') push_eh handle_p $P0 = shift pmc_arr inc $I1 handle_p: pop_eh is($I1, 0, 'shift pmc from empty RPA throws') .end .sub pop_empty .local pmc pmc_arr pmc_arr = new ['ResizablePMCArray'] $I1 = 0 push_eh handle_i $I0 = pop pmc_arr inc $I1 handle_i: pop_eh is($I1, 0, 'pop int from empty RPA throws') push_eh handle_n $N0 = pop pmc_arr inc $I1 handle_n: pop_eh is($I1, 0, 'pop num from empty RPA throws') push_eh handle_s $S0 = pop pmc_arr inc $I1 handle_s: pop_eh is($I1, 0, 'pop string from empty RPA throws') push_eh handle_p $P0 = pop pmc_arr inc $I1 handle_p: pop_eh is($I1, 0, 'pop pmc from empty RPA throws') .end ## an Integer Matrix, as used by befunge as a playing field .sub multikey_access .local pmc matrix, row_in, row_out matrix = new ['ResizablePMCArray'] row_in = new ['ResizableIntegerArray'] push row_in, 42 push matrix, row_in .local int elem elem = matrix[0;0] is(elem, 42, "int in nested ResizableIntegerArray is 42") matrix[0;1] = 43 elem = matrix[0;1] is(elem, 43, "int in nested ResizableIntegerArray is 43") .end .sub exists_and_defined .local pmc array array = new ['ResizablePMCArray'] push array, 'a' push array, 'b' push array, 'c' $P0 = new ['Null'] push array, $P0 push array, 'e' $P0 = new ['Undef'] push array, $P0 push array, '7' push array, '-8.8' .local int flag, index, ex, def ## bounds checking: lower (0) ex = exists array[0] is(ex, 1, "element at idx 0 exists") def = defined array[0] is(def, 1, "element at idx 0 is defined") $P0 = new 'Integer', 0 ex = exists array[$P0] is(ex, 1, "element at PMC idx 0 exists") ## bounds checking: upper (7) ex = exists array[7] is(ex, 1, "element at idx 7 exists") def = defined array[7] is(def, 1, "element at idx 7 is defined") ## bounds checking: negative lower (-1) ex = exists array[-1] is(ex, 1, "element at idx -1 exists") def = defined array[-1] is(def, 1, "element at idx -1 is defined") ## bounds checking: negative upper (-8) ex = exists array[-8] is(ex, 1, "element at idx -8 exists") def = defined array[-8] is(def, 1, "element at idx -8 is defined") ## bounds checking: out-of-bounds (8) ex = exists array[8] is(ex, 0, "element at idx 8 does not exist") def = defined array[8] is(def, 0, "element at idx 8 is not defined") ## bounds checking: negative out-of-bounds (-9) ex = exists array[-9] is(ex, 0, "element at idx -9 does not exist") def = defined array[-9] is(def, 0, "element at idx -9 is not defined") ## null value (3) ex = exists array[3] is(ex, 0, "element at idx 3 does not exist") def = defined array[3] is(def, 0, "element at idx 3 is not defined") ## undefined value (5) ex = exists array[5] is(ex, 1, "element at idx 5 does not exist") def = defined array[5] is(def, 0, "element at idx 5 is not defined") .end .sub delete_keyed .local pmc array array = new ['ResizablePMCArray'] push array, 'a' push array, 'b' push array, 'c' $P0 = new 'Integer', 1 delete array[$P0] $S0 = array[1] is($S0, 'c', 'delete_keyed with PMC key') .end .sub get_rep .local pmc array array = new ['ResizablePMCArray'] push array, 'a' push array, 'b' $S0 = get_repr array is($S0, '[ a, b ]', 'get_repr') .end .sub append_tests $P1 = new ['ResizablePMCArray'] push $P1, 'a' push $P1, 'b' push $P1, 'c' $P2 = new ['FixedPMCArray'] $P2 = 2 $P0 = new ['Null'] $P2[0] = $P0 $P2[1] = 'e' $P0 = new ['Undef'] $P3 = new ['ResizablePMCArray'] push $P3, $P0 push $P3, '7' push $P3, '-8.8' $P4 = new ['ResizablePMCArray'] $P5 = new ['MultiSub'] # extends ResizablePMCArray $P99 = new ['Sub'] push $P5, $P99 $P4.'append'( $P4 ) ok( 1, 'parsing' ) $I1 = $P4 is( $I1, 0, 'still size 0' ) $P10 = $P1 $I1 = $P10 $P10.'append'( $P4 ) $I2 = $P10 is( $I1, $I2, 'append empty ResizablePMCArray' ) $S1 = $P10[2] is( $S1, 'c', 'indexing elements' ) $P10.'append'( $P2 ) is( $P10, 5, 'append FixedPMCArray' ) $S1 = $P10[2] is( $S1, 'c', 'indexing elements' ) $S1 = $P10[4] is( $S1, 'e', 'indexing elements' ) $P3.'append'( $P10 ) is( $P3, 8, 'append ResizablePMCArray' ) $S1 = $P3[2] is( $S1, '-8.8', 'indexing elements' ) $S1 = $P3[4] is( $S1, 'b', 'indexing elements' ) $P3.'append'( $P5 ) is( $P3, 9, 'append subclass' ) $S1 = $P3[2] is( $S1, '-8.8', 'indexing elements' ) $P99 = $P3[8] $I99 = isa $P99, 'Sub' ok( $I99, 'indexing elements' ) .end .sub get_array_string .param pmc p $S0 = '' $P3 = iter p loop: unless $P3 goto loop_end $P4 = shift $P3 $S1 = $P4 $S0 = concat $S0, $S1 goto loop loop_end: .return($S0) .end .sub splice_tests .local pmc ar1, ar2 ar1 = new ['ResizablePMCArray'] ar1[0] = 1 ar1[1] = 2 ar1[2] = 3 ar1[3] = 4 ar1[4] = 5 ar2 = new ['ResizablePMCArray'] ar2[0] = 'A' ar2[1] = 'B' ar2[2] = 'C' ar2[3] = 'D' ar2[4] = 'E' $P1 = clone ar1 $P2 = clone ar2 splice $P1, $P2, 0, 5 $S0 = get_array_string($P1) is($S0, "ABCDE", "splice with complete replace") $P1 = clone ar1 $P2 = clone ar2 splice $P1, $P2, 5, 0 $S0 = get_array_string($P1) is($S0, "12345ABCDE", "splice, append") $P1 = clone ar1 $P2 = clone ar2 splice $P1, $P2, 4, 0 $S0 = get_array_string($P1) is($S0, "1234ABCDE5", "splice, insert before last element") $P1 = clone ar1 $P2 = clone ar2 splice $P1, $P2, 3, 0 $S0 = get_array_string($P1) is($S0, "123ABCDE45", "splice, append-in-middle") $P1 = clone ar1 $P2 = clone ar2 splice $P1, $P2, 0, 2 $S0 = get_array_string($P1) is($S0, "ABCDE345", "splice, replace at beginning") $P1 = clone ar1 $P2 = clone ar2 splice $P1, $P2, 2, 2 $S0 = get_array_string($P1) is($S0, "12ABCDE5", "splice, replace in middle") $P1 = clone ar1 $P2 = clone ar2 splice $P1, $P2, 3, 2 $S0 = get_array_string($P1) is($S0, "123ABCDE", "splice, replace at end") $P1 = clone ar1 $P2 = new ['FixedStringArray'] $P2 = 5 $P2[0] = 'A' $P2[1] = 'B' $P2[2] = 'C' $P2[3] = 'D' $P2[4] = 'E' splice $P1, $P2, 3, 2 $S0 = get_array_string($P1) is($S0, "123ABCDE", "splice, replace with another type") $P1 = clone ar1 $P2 = new ['ResizablePMCArray'] splice $P1, $P2, 2, 2 $S0 = get_array_string($P1) is($S0, "125", "splice with empty replacement") $P1 = clone ar1 $P2 = new ['ResizablePMCArray'] $P2[0] = 'A' splice $P1, $P2, 2, 1 $S0 = get_array_string($P1) is($S0, "12A45", "splice with empty replacement") $P1 = clone ar1 $P2 = clone ar2 splice $P1, $P2, -3, 2 $S0 = get_array_string($P1) is($S0, "12ABCDE5", "splice with negative offset") $P1 = clone ar1 $P2 = clone ar2 $I0 = 1 push_eh too_low splice $P1, $P2, -10, 2 dec $I0 goto too_low_end too_low: .get_results($P9) finalize $P9 too_low_end: ok($I0, "splice with negative offset too low") .end .sub splice_replace1 $P1 = new ['ResizablePMCArray'] $P1 = 3 $P1[0] = '1' $P1[1] = '2' $P1[2] = '3' $P2 = new ['ResizablePMCArray'] $P2 = 1 $P2[0] = 'A' splice $P1, $P2, 1, 2 $S0 = join "", $P1 is($S0, "1A", "replacement via splice works") .end .sub splice_replace2 $P1 = new ['ResizablePMCArray'] $P1 = 3 $P1[0] = '1' $P1[1] = '2' $P1[2] = '3' $P2 = new ['ResizablePMCArray'] $P2 = 1 $P2[0] = 'A' splice $P1, $P2, 0, 2 $S0 = join "", $P1 is($S0, "A3", "replacement via splice works") .end .sub iterate_subclass_of_rpa .local pmc arr, it $P0 = subclass 'ResizablePMCArray', 'MyArray' arr = new ['MyArray'] push arr, 11 push arr, 13 push arr, 15 $I0 = elements arr is($I0, 3, "RPA subclass has correct element count") $S1 = '' it = iter arr loop: unless it goto end $P2 = shift it $S0 = $P2 $S1 = concat $S1, $S0 $S1 = concat $S1, "," goto loop end: is($S1, "11,13,15,", "iterator works on RPA subclass") .end .sub method_forms_of_unshift_etc $P0 = new ['ResizablePMCArray'] $P0.'unshift'(1) $P0.'push'('two') $I0 = $P0 is($I0, 2, "method forms of unshift and push add elements to an RPA") $P1 = $P0.'shift'() is($P1, 1, "method form of shift works") $P1 = $P0.'pop'() is($P1, "two", "method form of pop works") .end .sub sort_with_broken_cmp .local pmc array array = new ['ResizablePMCArray'] push array, 4 push array, 5 push array, 3 push array, 2 push array, 5 push array, 1 $S0 = join ' ', array is($S0, "4 5 3 2 5 1", "RPA has expected values") $P0 = get_global 'cmp_func' array.'sort'($P0) ok(1, "sort returns without crashing") .end .sub 'cmp_func' .param pmc a .param pmc b $I0 = 1 .return ($I0) .end .sub 'equality_tests' .local pmc array1, array2, array3, array4 array1 = new ['ResizablePMCArray'] array2 = new ['ResizablePMCArray'] array3 = new ['ResizablePMCArray'] array1[0] = "Hello Parrot!" array1[1] = 1664 array1[2] = 2.718 $P0 = box "Hello Parrot!" array2[0] = $P0 $P0 = box 1664 array2[1] = $P0 $P0 = box 2.718 array2[2] = $P0 array3[0] = "Goodbye Parrot!" array3[1] = 1664 array3[2] = 2.718 array4 = clone array1 is(array1, array2, 'Physically disjoint, but equal arrays') is(array1, array4, 'Clones are equal') isnt(array1, array3, 'Different arrays') .end .sub sort_tailcall .local pmc array array = new 'ResizablePMCArray' push array, 4 push array, 5 push array, 3 push array, 2 push array, 5 push array, 1 .local string unsorted unsorted = join ' ', array is(unsorted,"4 5 3 2 5 1", "unsorted array") ## sort using a non-tailcall function .const 'Sub' cmp_normal = 'cmp_normal_tailcall' $P1 = clone array $P1.'sort'(cmp_normal) .local string sorted1 sorted1 = join ' ', $P1 is (sorted1, "1 2 3 4 5 5", "sorted array, no tailcall") ## sort using a tailcall function .const 'Sub' cmp_tailcall = 'cmp_tailcall_tailcall' $P1 = clone array $P1.'sort'(cmp_tailcall) .local string sorted2 sorted2 = join ' ', $P1 is(sorted2, "1 2 3 4 5 5", "sorted array, with tailcall") .end .sub 'cmp_func_tailcall' .param pmc a .param pmc b $I0 = cmp a, b .return ($I0) .end .sub 'cmp_normal_tailcall' .param pmc a .param pmc b $P0 = 'cmp_func_tailcall'(a, b) .return ($P0) .end .sub 'cmp_tailcall_tailcall' .param pmc a .param pmc b .tailcall 'cmp_func_tailcall'(a, b) .end # Regression test for TT#835 .sub 'push_to_subclasses_array' .local pmc cl, array_one cl = subclass "ResizablePMCArray", "ExampleArray" array_one = new "ExampleArray" $I0 = 100000 loop: array_one.'push'($I0) dec $I0 if $I0 goto loop ok(1, "Push to subclassed array works") .end .sub test_assign_non_array throws_substring(<<'CODE', "Can't set self from this type",'assign from non-array') .sub main :main .local pmc arr, other .local int n arr = new ['ResizablePMCArray'] other = new ['Integer'] assign arr, other .end CODE .end .sub test_assign_self .local pmc arr arr = new ['ResizablePMCArray'] assign arr, arr ok(1, 'Can assign ResizablePMCArray to itself') .end .sub test_assign_from_another .local pmc arr1, arr2 .local int n arr1 = new ['ResizablePMCArray'] arr1 = 32 arr2 = new ['ResizablePMCArray'] arr2 = 15 assign arr1, arr2 n = arr1 is(n,15,'assigning to ResizablePMCArray from another ResizablePMCArray') .end .sub method_reverse .local pmc array array = new ['ResizablePMCArray'] array."reverse"() $I0 = elements array is($I0, 0, "method_reverse - reverse of empty array") push array, 3 array."reverse"() $S0 = array[0] is($S0, "3", "method_reverse - reverse of array with one element") push array, "1" array."reverse"() array."reverse"() array."reverse"() $S0 = array[0] is($S0, "1", "method_reverse - reverse of array with two elements") $S0 = array[1] is($S0, "3", "method_reverse - reverse of array with two elements second element") push array, 4 array."reverse"() push array, 5 array."reverse"() $S0 = join "", array is($S0, "5134", "method_reverse - four elements") array."reverse"() $S0 = join "", array is($S0, "4315", "method_reverse - four elements second reverse") push array, 6 array."reverse"() $S0 = join "", array is($S0, "65134", "method_reverse - five elements") array."reverse"() $S0 = join "", array is($S0, "43156", "method_reverse - five elements second reverse") .end # don't forget to change the test plan # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: has_header_h.in000644000765000765 77611567202622 20177 0ustar00bruce000000000000parrot-6.6.0/config/gen/config_h/* Copyright (C) 2009, Parrot Foundation. */ #ifndef PARROT_HAS_HEADER_H_GUARD #define PARROT_HAS_HEADER_H_GUARD /* * i_\w+ header includes */ @TEMP_header@ #define BUILD_OS_NAME "@osname@" /* * defines from commandline */ @TEMP_cli_define@ /* * HAS_\w+ config entries */ @TEMP_has_config@ /* * D_\w+ config entries */ @TEMP_d_config@ #endif /* PARROT_HAS_HEADER_H_GUARD */ /* * Local variables: * c-file-style: "parrot" * End: * vim: expandtab shiftwidth=4 cinoptions='\:2=2' : */ parrot_api.pod000644000765000765 274012101554066 16043 0ustar00bruce000000000000parrot-6.6.0/docs/dev# Copyright (C) 2007, Parrot Foundation. =head1 NAME docs/dev/parrot_api.pod - Notes on the PARROT_EXPORT macro =head1 DESCRIPTION This document addresses the correct use of the C macro. =head1 OVERVIEW Some compilers and platforms export all symbols either by default or through a switch. Others have no such mechanism and either need a list of symbols to export or need the symbols annotating in the source. The C macro exists for the purpose of annotating symbols that should be exported. One day, it may be used to express which functions are in the Parrot extension API and which are not. For now it should be used to mark anything that will be used by a shared library or by the main Parrot executable when Parrot is built as a shared library. =head1 USAGE Incorrect usage of C can break the build on some platforms, especially Win32. The rules for how to use it are as follows. =over 4 =item If you decorate a function with multiple modifiers, I C, C, C, C I appear first in the list. =item If you decorate a function with C in a .c file, you must also decorate the symbol with C in all .h files that mention it. =item If the symbol appears in more than one header file, all of them must have C or none of them should. Some with and some without won't work. =back =cut # vim: expandtab shiftwidth=2 tw=70: runcore_api.h000644000765000765 1422412307662657 17140 0ustar00bruce000000000000parrot-6.6.0/include/parrot/* runcore_api.h * Copyright (C) 2001-2009, Parrot Foundation. * Overview: * Functions and macros to dispatch opcodes. */ #ifndef PARROT_RUNCORE_API_H_GUARD #define PARROT_RUNCORE_API_H_GUARD struct runcore_t; typedef struct runcore_t Parrot_runcore_t; #include "parrot/parrot.h" #include "parrot/op.h" # define DO_OP(PC, INTERP) ((PC) = (((INTERP)->code->op_func_table)[*(PC)])((PC), (INTERP))) typedef opcode_t * (*runcore_runops_fn_type) (PARROT_INTERP, ARGIN(Parrot_runcore_t *), ARGIN(opcode_t *pc)); typedef void (*runcore_destroy_fn_type)(PARROT_INTERP, ARGIN(Parrot_runcore_t *)); typedef void * (*runcore_prepare_fn_type)(PARROT_INTERP, ARGIN(Parrot_runcore_t *)); typedef runcore_runops_fn_type Parrot_runcore_runops_fn_t; typedef runcore_destroy_fn_type Parrot_runcore_destroy_fn_t; typedef runcore_prepare_fn_type Parrot_runcore_prepare_fn_t; struct runcore_t { STRING *name; int id; oplib_init_f opinit; runcore_runops_fn_type runops; runcore_destroy_fn_type destroy; runcore_prepare_fn_type prepare_run; INTVAL flags; }; typedef enum Parrot_runcore_flags { RUNCORE_REENTRANT_FLAG = 1 << 0, RUNCORE_FUNC_TABLE_FLAG = 1 << 1 } Parrot_runcore_flags; #define Runcore_flag_SET(runcore, flag) \ ((runcore)->flags |= flag) #define Runcore_flag_TEST(runcore, flag) \ ((runcore)->flags & flag) #define PARROT_RUNCORE_FUNC_TABLE_TEST(runcore) \ Runcore_flag_TEST(runcore, RUNCORE_FUNC_TABLE_FLAG) #define PARROT_RUNCORE_FUNC_TABLE_SET(runcore) \ Runcore_flag_SET(runcore, RUNCORE_FUNC_TABLE_FLAG) /* HEADERIZER BEGIN: src/runcore/main.c */ /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */ PARROT_EXPORT void dynop_register(PARROT_INTERP, ARGIN(PMC *lib_pmc)) __attribute__nonnull__(1) __attribute__nonnull__(2); PARROT_EXPORT void Parrot_runcore_disable_event_checking(PARROT_INTERP) __attribute__nonnull__(1); PARROT_EXPORT void Parrot_runcore_enable_event_checking(PARROT_INTERP) __attribute__nonnull__(1); PARROT_EXPORT INTVAL Parrot_runcore_register(PARROT_INTERP, ARGIN(Parrot_runcore_t *coredata)) __attribute__nonnull__(1) __attribute__nonnull__(2); PARROT_EXPORT void Parrot_runcore_switch(PARROT_INTERP, ARGIN(STRING *name)) __attribute__nonnull__(1) __attribute__nonnull__(2); void parrot_hash_oplib(PARROT_INTERP, ARGIN(op_lib_t *lib)) __attribute__nonnull__(1) __attribute__nonnull__(2); void Parrot_runcore_destroy(PARROT_INTERP) __attribute__nonnull__(1); void Parrot_runcore_init(PARROT_INTERP) __attribute__nonnull__(1); void prepare_for_run(PARROT_INTERP) __attribute__nonnull__(1); void runops_int(PARROT_INTERP, size_t offset) __attribute__nonnull__(1); #define ASSERT_ARGS_dynop_register __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(lib_pmc)) #define ASSERT_ARGS_Parrot_runcore_disable_event_checking \ __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp)) #define ASSERT_ARGS_Parrot_runcore_enable_event_checking \ __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp)) #define ASSERT_ARGS_Parrot_runcore_register __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(coredata)) #define ASSERT_ARGS_Parrot_runcore_switch __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(name)) #define ASSERT_ARGS_parrot_hash_oplib __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(lib)) #define ASSERT_ARGS_Parrot_runcore_destroy __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp)) #define ASSERT_ARGS_Parrot_runcore_init __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp)) #define ASSERT_ARGS_prepare_for_run __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp)) #define ASSERT_ARGS_runops_int __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp)) /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */ /* HEADERIZER END: src/runcore/main.c */ /* HEADERIZER BEGIN: src/runcore/cores.c */ /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */ PARROT_WARN_UNUSED_RESULT PARROT_CANNOT_RETURN_NULL oplib_init_f get_core_op_lib_init(PARROT_INTERP, ARGIN(Parrot_runcore_t *runcore)) __attribute__nonnull__(2); void Parrot_runcore_debugger_init(PARROT_INTERP) __attribute__nonnull__(1); void Parrot_runcore_exec_init(PARROT_INTERP) __attribute__nonnull__(1); void Parrot_runcore_fast_init(PARROT_INTERP) __attribute__nonnull__(1); void Parrot_runcore_gc_debug_init(PARROT_INTERP) __attribute__nonnull__(1); void Parrot_runcore_slow_init(PARROT_INTERP) __attribute__nonnull__(1); #define ASSERT_ARGS_get_core_op_lib_init __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(runcore)) #define ASSERT_ARGS_Parrot_runcore_debugger_init __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp)) #define ASSERT_ARGS_Parrot_runcore_exec_init __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp)) #define ASSERT_ARGS_Parrot_runcore_fast_init __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp)) #define ASSERT_ARGS_Parrot_runcore_gc_debug_init __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp)) #define ASSERT_ARGS_Parrot_runcore_slow_init __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp)) /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */ /* HEADERIZER END: src/runcore/cores.c */ #endif /* PARROT_RUNCORE_API_H_GUARD */ /* * Local variables: * c-file-style: "parrot" * End: * vim: expandtab shiftwidth=4 cinoptions='\:2=2' : */ gziphandle.pmc000644000765000765 2042512171255036 16422 0ustar00bruce000000000000parrot-6.6.0/src/dynpmc/* Copyright (C) 2010-2012, Parrot Foundation. =head1 NAME src/dynpmc/gziphandle.pmc - GzipHandle PMC =head1 DESCRIPTION The GzipHandle PMC performs I/O operations on a source or destination file. This PMC wraps the zlib. =head2 Vtable Functions =over 4 =cut */ BEGIN_PMC_HEADER_PREAMBLE #include END_PMC_HEADER_PREAMBLE /* HEADERIZER HFILE: none */ /* HEADERIZER BEGIN: static */ /* HEADERIZER END: static */ pmclass GzipHandle extends Handle dynpmc auto_attrs { ATTR gzFile file; /* =item C Initializes a newly created GzipHandle object. =cut */ VTABLE void init() { PARROT_GZIPHANDLE(SELF)->file = NULL; Parrot_warn_experimental(interp, "GzipHandle is experimental"); } /* =item C Returns whether the GzipHandle has reached the end of the file. =cut */ VTABLE INTVAL get_bool() { gzFile file; GET_ATTR_file(INTERP, SELF, file); return !gzeof(file); } /* =back =head2 Stream-Oriented Methods =over 4 =item C Opens the file at the given filename (including path) with the given mode. The invocant is modified and becomes an open filehandle. =cut */ METHOD open(STRING *filename, STRING *mode :optional, INTVAL has_mode :opt_flag) { char * const path = Parrot_str_to_cstring(INTERP, filename); gzFile file; if (has_mode) { char * const mod = Parrot_str_to_cstring(INTERP, mode); file = gzopen(path, mod); Parrot_str_free_cstring(mod); } else file = gzopen(path, "rb"); Parrot_str_free_cstring(path); if (!file) Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_ILL_INHERIT, "gzopen fails"); SET_ATTR_file(INTERP, SELF, file); RETURN(PMC SELF); } /* =item C Close the gziphandle. =cut */ METHOD close() { INTVAL status; gzFile file; GET_ATTR_file(INTERP, SELF, file); status = gzclose(file); RETURN(INTVAL status); } /* =item C Returns true if the gziphandle is at end-of-file, returns false otherwise. =cut */ METHOD eof() { INTVAL status; gzFile file; GET_ATTR_file(INTERP, SELF, file); status = gzeof(file); RETURN(INTVAL status); } /* =item C Flushes the gziphandle. =cut */ METHOD flush() { INTVAL status; gzFile file; GET_ATTR_file(INTERP, SELF, file); status = gzflush(file, Z_SYNC_FLUSH); RETURN(INTVAL status); } /* =item C Print the passed in integer, number, string, or PMC to the gziphandle. (Integers, numbers, and strings are auto-boxed as PMCs.) =cut */ METHOD print(PMC *value) { gzFile file; STRING * const str = VTABLE_get_string(INTERP, value); char * const buf = Parrot_str_to_cstring(INTERP, str); const UINTVAL len = Parrot_str_byte_length(INTERP, str); GET_ATTR_file(INTERP, SELF, file); (void)gzwrite(file, buf, len); Parrot_str_free_cstring(buf); } /* =item C Print the string to the gziphandle. =cut */ METHOD puts(STRING *value) { INTVAL status; gzFile file; char * const buf = Parrot_str_to_cstring(INTERP, value); const UINTVAL len = Parrot_str_byte_length(INTERP, value); GET_ATTR_file(INTERP, SELF, file); status = gzwrite(file, buf, len); Parrot_str_free_cstring(buf); RETURN(INTVAL status); } /* =item C Read the given number of bytes from the gziphandle and return them in a string. =cut */ METHOD read(INTVAL length) { int result; gzFile file; STRING *str = STRINGNULL; char * const buf = mem_internal_allocate_n_zeroed_typed(length, char); GET_ATTR_file(INTERP, SELF, file); result = gzread(file, buf, length); if (result > 0) { str = Parrot_str_new_init(INTERP, buf, result, Parrot_binary_encoding_ptr, 0); } mem_sys_free(buf); RETURN(STRING *str); } /* =back =head2 Basic Methods =over 4 =item C Returns a string with the zlib version. =back =cut */ METHOD version() { STRING * const version = Parrot_str_new_constant(INTERP, zlibVersion()); RETURN(STRING *version); } METHOD compress(STRING *str) { int rc; char *buf; STRING *dst = STRINGNULL; UINTVAL srcLen, dstLen; char * const src = Parrot_str_to_cstring(INTERP, str); if (!src) Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_ILL_INHERIT, "failed to allocate"); srcLen = Parrot_str_byte_length(INTERP, str); dstLen = 12 + srcLen + srcLen / 1000; buf = mem_internal_allocate_n_zeroed_typed(dstLen, char); if (!buf) { Parrot_str_free_cstring(src); Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_ILL_INHERIT, "failed to allocate"); } rc = compress((Bytef *)buf, &dstLen, (const Bytef *)src, srcLen); Parrot_str_free_cstring(src); switch (rc) { case Z_OK: dst = Parrot_str_new_init(INTERP, buf, dstLen, Parrot_binary_encoding_ptr, 0); mem_sys_free(buf); break; case Z_MEM_ERROR: mem_sys_free(buf); Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_ILL_INHERIT, "not enough memory"); break; case Z_BUF_ERROR: mem_sys_free(buf); Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_ILL_INHERIT, "output buffer error"); break; default: /* these are the only three documented return values */ break; } RETURN(STRING *dst); } METHOD uncompress(STRING *str) { int rc; char *buf; STRING *dst = STRINGNULL; UINTVAL srcLen, dstLen; char * const src = Parrot_str_to_cstring(INTERP, str); if (!src) Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_ILL_INHERIT, "failed to allocate"); srcLen = Parrot_str_byte_length(INTERP, str); dstLen = 2 * srcLen; REDO: buf = mem_internal_allocate_n_zeroed_typed(dstLen, char); if (!buf) { Parrot_str_free_cstring(src); Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_ILL_INHERIT, "failed to allocate"); } rc = uncompress((Bytef *)buf, &dstLen, (const Bytef *)src, srcLen); switch (rc) { case Z_OK: Parrot_str_free_cstring(src); dst = Parrot_str_new_init(INTERP, buf, dstLen, Parrot_binary_encoding_ptr, 0); mem_sys_free(buf); break; case Z_MEM_ERROR: Parrot_str_free_cstring(src); mem_sys_free(buf); Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_ILL_INHERIT, "not enough memory"); break; case Z_BUF_ERROR: mem_sys_free(buf); dstLen *= 2; goto REDO; case Z_DATA_ERROR: Parrot_str_free_cstring(src); mem_sys_free(buf); Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_ILL_INHERIT, "input data corrupted"); break; default: /* these are the only four documented return values */ break; } RETURN(STRING *dst); } METHOD crc32(INTVAL crc, STRING *str) { UINTVAL srcLen; char * const src = Parrot_str_to_cstring(INTERP, str); if (!src) Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_ILL_INHERIT, "failed to allocate"); srcLen = Parrot_str_byte_length(INTERP, str); crc = crc32(crc, (const Bytef *)src, srcLen); RETURN(INTVAL crc); } } /* * Local variables: * c-file-style: "parrot" * End: * vim: expandtab shiftwidth=4 cinoptions='\:2=2' : */ interlangs.bas000644000765000765 616511533177634 16755 0ustar00bruce000000000000parrot-6.6.0/examples/pir1 REM Copyright (C) 2009, Parrot Foundation. 3 REM 110 REM +--------------------------------------------------------------------+ 120 REM + interlangs.bas + 130 REM + A test of parrot HLL languages interoperability + 140 REM + from pirric basic interpreter + 150 REM + First build perl6, ecmascript and pipp + 160 REM + Then do: + 170 REM + ../../parrot -L /yourparrotdir/languages/rakudo \ + 180 REM + -L /yourparrotdir/languages/ecmascript \ + 190 REM + -L /yourparrotdir/languages/pipp \ + 200 REM + pirric.pir interlang.bas + 210 REM +--------------------------------------------------------------------+ 220 REM 1000 REM Load languages 1010 GOSUB 2000 1020 REM Compile code 1030 GOSUB 3000 1200 REM Execute compiled code 1210 REM Forget the return value from ecmascript 1220 unused= jsblock() 1230 REM The perl6 block return the sub we need 1240 perl6sub= perl6block() 1300 REM Now start playing 1310 REM Get the javascript function created 1318 REM Get the function from the js HLL. 1319 REM *** This syntax is subject to change *** 1320 myfunc= js.myecmascriptfunc 1330 REM Call the perl6 sub passing the ecmascript function as second argument 1340 PRINT perl6sub("pirric", myfunc) 1400 REM Call the perl6 sub passing the pipp function as second argument 1410 mypippfunc= pipp.phpfunc 1420 PRINT perl6sub("pirric", mypippfunc) 1600 REM First the ecmascript function PRINT his message, 1610 REM then the parrot sub returns a string, 1620 REM that is printed by pirric. 1630 REM The output must be: 1640 REM 1650 REM Hello from ecmascript, perl6->pirric 1660 REM Hello from a perl6 sub, pirric 1670 REM 1680 REM Followed by the same with pipp 1900 REM That's all folks! 1910 EXIT 2000 REM 2010 REM Load languages 2020 REM 2100 ON ERROR GOTO 2900 2110 LOAD "perl6.pbc", b 2120 perl6compiler = COMPREG("Perl6") 2200 ON ERROR GOTO 2920 2210 LOAD "js.pbc", b 2220 ecmascriptcompiler= COMPREG("JS") 2300 ON ERROR GOTO 2940 2310 LOAD "pipp.pbc", b 2320 pippcompiler= COMPREG("Pipp") 2800 ON ERROR GOTO 0 2810 RETURN 2900 PRINT "Can't load perl6" 2910 EXIT 1 2920 PRINT "Can't load ecmascript" 2930 EXIT 1 2940 PRINT "Can't load pipp" 2950 EXIT 1 3000 REM 3010 REM Compile code 3020 REM 3100 REM Perl6 code that return an anonymous sub 3110 ON ERROR GOTO 3900 3120 perl6block=perl6compiler.compile("sub ($a, $b){$b('perl6->' ~ $a); 'Hello from a perl6 sub, ' ~ $a; };") 3200 REM ecmascript code that defines a function 3210 ON ERROR GOTO 3920 3220 jsblock=ecmascriptcompiler.compile("function myecmascriptfunc(n) { print ('Hello from ecmascript,', n); }") 3310 ON ERROR GOTO 3940 3320 pippblock= pippcompiler.compile("") 3800 ON ERROR GOTO 0 3810 RETURN 3900 PRINT "Error compiling perl6" 3910 EXIT 1 3920 PRINT "Error compiling ecmascript" 3930 EXIT 1 3940 PRINT "Error compiling pipp" 3950 EXIT 1 oo3.rb000644000765000765 22511466337261 16436 0ustar00bruce000000000000parrot-6.6.0/examples/benchmarks#! ruby class Foo attr_reader :i, :j def initialize() @i = 10 @j = 20 end end o = Foo.new (1..500000).each{ x = o.i; y = o.j } puts o.i bignum.t000644000765000765 4721712101554067 14212 0ustar00bruce000000000000parrot-6.6.0/t/pmc#! perl # Copyright (C) 2009, Parrot Foundation. use strict; use warnings; use lib qw( . lib ../lib ../../lib ); use Test::More; use Parrot::Test; use Parrot::Config; =head1 NAME t/pmc/bignum.t - BigNum PMC =head1 SYNOPSIS % prove t/pmc/bignum.t =head1 DESCRIPTION Tests the BigNum PMC. =cut if ( $PConfig{gmp} ) { plan tests => 45; } else { plan skip_all => "No BigNum PMC enabled"; } my $vers_check = <<'EOP'; .sub main :main .local pmc b, ar .local string v .local int ma, mi, pa b = new ['BigNum'] v = b.'version'() ar = split '.', v ma = ar[0] mi = ar[1] pa = ar[2] # GMP < 4.1.4 is bad if ma > 4 goto ok if ma < 4 goto warn if mi >= 2 goto ok if mi == 0 goto warn if pa >= 4 goto ok warn: print 'GMP version ' print v say " is buggy with huge digit multiply - please upgrade" ok: .end EOP if ( $PConfig{gmp} ) { # argh my $parrot = '.' . $PConfig{slash} . 'parrot' . $PConfig{exe}; my $test = 'temp_gmp_vers.pir'; open my $O, '>', "$test" or die "can't open $test: $!"; print $O $vers_check; close $O; my $warn = `$parrot $test`; diag $warn if $warn; unlink $test; } pasm_output_is( <<'CODE', <<'OUT', "create" ); .pcc_sub :main main: new P0, ['BigNum'] say "ok" end CODE ok OUT pasm_output_is( <<'CODE', <<'OUT', "set/get int" ); .pcc_sub :main main: new P0, ['BigNum'] set P0, 999999 set I1, P0 say I1 get_repr S0, P0 say S0 new P1, ['BigNum'] set P1, 22.2 setref P0, P1 set N0, P0 say N0 end CODE 999999 999999N 22.2 OUT pasm_output_is( <<'CODE', <<'OUT', "set/get keyed string" ); .pcc_sub :main main: new P0, ['BigNum'] set P0, 14 set S0, P0[16] say S0 set P0, 26 set S0, P0[8] say S0 set P0[16], "1F" set S0, P0 say S0 end CODE e 32 31 OUT pasm_output_is( <<'CODE', <<'OUT', "destroy on copy" ); .pcc_sub :main main: new P0, ['BigNum'] new P1, ['BigNum'] set P0, 4183 set P1, 33 copy P0, P1 say P0 end CODE 33 OUT pasm_output_is( <<'CODE', <<'OUT', "clone equality" ); .pcc_sub :main main: .include 'fp_equality.pasm' new P0, ['BigNum'] set P0, 56.743 clone P1, P0 set N0, P0 set N1, P1 .fp_eq_pasm(N0, N1, OK1) print "not " OK1:print "ok\n" end CODE ok OUT pasm_output_is( <<'CODE', <<'OUT', "inc/dec" ); .pcc_sub :main main: .include 'fp_equality.pasm' new P0, ['BigNum'] set P0, 5.5 inc P0 set N0, P0 .fp_eq_pasm(N0, 6.5, OK1) print "not " OK1:say "ok 1" set P0, 5.5 dec P0 set N0, P0 .fp_eq_pasm(N0, 4.5, OK2) print "not " OK2:say "ok 2" end CODE ok 1 ok 2 OUT pasm_output_is( <<"CODE", <<'OUT', "set int, get double" ); .pcc_sub :main main: .include 'fp_equality.pasm' new P0, ['BigNum'] set P0, 999999 set N1, P0 .fp_eq_pasm(N1, 999999.0, OK1) print "not " OK1: say "ok 1" set P0, -999999 set N1, P0 .fp_eq_pasm(N1, -999999.0, OK2) print "not " OK2: say "ok 2" set P0, 2147483646 set N1, P0 .fp_eq_pasm(N1, 2.147483646e9, OK3) print "not " OK3: say "ok 3" set P0, -2147483646 set N1, P0 .fp_eq_pasm(N1, -2.147483646e9, OK4) print "not " OK4: say "ok 4" end CODE ok 1 ok 2 ok 3 ok 4 OUT my @todo_str = ( todo => "bignum strings"); pasm_output_is( <<'CODE', <<'OUT', "set double, get str", @todo_str ); .pcc_sub :main main: new P0, ['BigNum'] set P0, 1.23e12 say P0 set P0, "1230000000000.0000000000000000122" say P0 end CODE 1230000000000 1230000000000.0000000000000000122 OUT pasm_output_is( <<'CODE', <<'OUT', "add", @todo_str); .pcc_sub :main main: new P0, ['BigNum'] set P0, 999999.5 new P1, ['BigNum'] set P1, 1000000.5 new P2, ['BigNum'] add P2, P0, P1 set S0, P2 say S0 set P0, "12345678987654321" set P1, "10000000000000000" add P2, P1, P0 set S0, P2 say S0 new P1, ['Integer'] set P0, 942 set P1, -2 add P0, P0, P1 set S0, P0 say S0 push_eh THROWN new P1, ['BigInt'] set P0, 100 set P1, 100 add P0, P0, P1 print "no " THROWN: pop_eh say "exception thrown" end CODE 2000000 22345678987654321 940 exception thrown OUT pasm_output_is( <<'CODE', <<'OUT', "i_add", @todo_str ); .pcc_sub :main main: new P0, ['BigNum'] new P1, ['Float'] set P0, 400 set P1, 3.75 add P0, P1 set S0, P0 say S0 new P1, ['BigNum'] set P0, 300 set P1, -200 add P0, P1 set S0, P0 say S0 new P1, ['Integer'] set P0, 300 set P1, -250 add P0, P1 set S0, P0 say S0 push_eh THROWN new P1, ['BigInt'] set P1, 3 add P0, P1 print "no " THROWN: say "exception thrown" set P0, 200 add P0, 5 set S0, P0 say S0 set P0, 200 add P0, 200.4 set S0, P0 say S0 end CODE 403.75 100 50 exception thrown 205 400.4 OUT pasm_output_is( <<'CODE', <<'OUT', "add_int", @todo_str ); .pcc_sub :main main: new P0, ['BigNum'] set P0, 999999 new P2, ['BigNum'] add P2, P0, 1000000 set S0, P2 say S0 set P0, "100000000000000000000.01" add P2, P0, 1000000 set S0, P2 say S0 end CODE 1999999 100000000000001000000.01 OUT pasm_output_is( <<'CODE', <<'OUTPUT', "sub bignum" ); .pcc_sub :main main: new P0, ['BigNum'] set P0, 12345678 new P1, ['BigNum'] set P1, 5678 new P2, ['BigNum'] sub P2, P0, P1 set I0, P2 eq I0, 12340000, OK1 print "not " OK1: say "ok 1" set P0, "123456789012345678" sub P2, P0, P1 new P3, ['BigNum'] set P3, "123456789012340000" eq P2, P3, OK2 print "not " OK2: say "ok 2" set P1, "223456789012345678" sub P2, P0, P1 set P3, "-100000000000000000" eq P2, P3, OK3 print "not " OK3: say "ok 3" end CODE ok 1 ok 2 ok 3 OUTPUT pasm_output_is( <<'CODE', <<'OUTPUT', "sub native int" ); .pcc_sub :main main: new P0, ['BigNum'] set P0, 12345678 new P2, ['BigNum'] sub P2, P0, 5678 set I0, P2 eq I0, 12340000, OK1 print "not " OK1: say "ok 1" set P0, "123456789012345678" sub P2, P0, 5678 new P3, ['BigNum'] set P3, "123456789012340000" eq P2, P3, OK2 print "not " OK2: say "ok 2" end CODE ok 1 ok 2 OUTPUT pasm_output_is( <<'CODE', <<'OUTPUT', "sub other int" ); .pcc_sub :main main: new P0, ['BigNum'] set P0, 12345678 new P1, ['Integer'] set P1, 5678 new P2, ['BigNum'] sub P2, P0, P1 set I0, P2 eq I0, 12340000, OK1 print "not " OK1: say "ok 1" set P0, "123456789012345678" sub P2, P0, P1 new P3, ['BigNum'] set P3, "123456789012340000" eq P2, P3, OK2 print "not " OK2: say "ok 2" set P0, 9876543 new P4, ['Integer'] set P4, 44 sub P2, P0, P4 set I0, P2 eq I0, 9876499, OK3 print "not " OK3: say "ok 3" set P0, "9876543219876543" sub P2, P0, P4 set P3, "9876543219876499" eq P3, P2, OK4 print "not " OK4: say "ok 4" push_eh THROWN new P1, ['BigInt'] set P0, 3 set P1, 3 sub P0, P0, P1 print "not " THROWN: say "ok 5" end CODE ok 1 ok 2 ok 3 ok 4 ok 5 OUTPUT pasm_output_is( <<'CODE', <<'OUTPUT', "i_subtract", todo => 'undiagnosed bug in i_subtract routine with immediate values' ); .pcc_sub :main main: .include 'fp_equality.pasm' new P0, ['BigNum'] new P1, ['BigNum'] set P0, 400 set P1, 99.5 sub P0, P1 set N0, P0 .fp_eq_pasm(N0, 300.5, OK1) print "not " OK1:say "ok 1" new P1, ['Integer'] set P0, 100 set P1, -50 sub P0, P1 set N0, P0 .fp_eq_pasm(N0, 150.0, OK2) print "not " OK2:say "ok 2" new P1, ['Float'] set P0, 50 set P1, 24.5 sub P0, P1 set N0, P0 .fp_eq_pasm(N0, 25.5, OK3) print "not " OK3:say "ok 3" push_eh THROWN new P1, ['BigInt'] set P1, 10 sub P0, P1 print "not " THROWN: pop_eh say "ok 4" set P0, 40 sub P0, 4 set N0, P0 .fp_eq_pasm(N0, 36.0, OK5) print "not " OK5:say "ok 5" set P0, 40 sub P0, 1.0 set N0, P0 .fp_eq_pasm(N0, 39.0, OK6) print "not " OK6:say "ok 6" end CODE ok 1 ok 2 ok 3 ok 4 ok 5 ok 6 OUTPUT pasm_output_is( <<'CODE', <<'OUT', "mul", @todo_str ); .pcc_sub :main main: new P0, ['BigNum'] set P0, 999.999 new P1, ['BigNum'] set P1, 10.000005 new P2, ['BigNum'] mul P2, P0, P1 set S0, P2 say S0 new P1, ['Integer'] set P0, 444 set P1, 2 mul P0, P0, P1 set S0, P0 say S0 push_eh THROWN new P1, ['BigInt'] set P1, 3 mul P0, P0, P1 print "no " THROWN: pop_eh say "exception thrown" set P0, 3 mul P0, P0, 2 set S0, P0 say S0 end CODE 9999.994999995 888 exception thrown 6 OUT pasm_output_is( <<'CODE', <<'OUT', "i_multiply", @todo_str ); .pcc_sub :main main: new P0, ['BigNum'] set P0, 50 new P1, ['BigNum'] set P1, 2 mul P0, P1 set S0, P0 say S0 new P1, ['Float'] set P0, 3 set P1, 5.5 mul P0, P1 set S0, P0 say S0 new P1, ['Integer'] set P0, 2 set P1, 4 mul P0, P1 set S0, P0 say S0 push_eh THROWN new P1, ['BigInt'] set P1, 3 mul P0, P1 print "no " THROWN: pop_eh say "exception thrown" new P0, ['BigNum'] set P0, 3 mul P0, 2 set S0, P0 say S0 set P0, 2 mul P0, 2.5 set N0, P0 say N0 end CODE 100 16.5 8 exception thrown 6 5 OUT pasm_output_is( <<'CODE', <<'OUT', "mul_float", @todo_str); .pcc_sub :main main: new P0, ['BigNum'] set P0, 999.999 mul P2, P0, 10.000005 say P2 end CODE 9999.994999995 OUT pasm_output_is( <<'CODE', <<'OUT', "div bignum" ); .pcc_sub :main main: new P0, ['BigNum'] set P0, "100000000000000000000" new P1, ['BigNum'] set P1, "100000000000000000000" new P2, ['BigNum'] div P2, P0, P1 set I0, P2 eq I0, 1, OK1 print "not " OK1: say "ok 1" new P3, ['BigNum'] set P3, "10000000000000" set P1, 10000000 div P2, P0, P1 eq P2, P3, OK2 print "not " OK2: say "ok 2" set P1, 10 set P3, "10000000000000000000" div P2, P0, P1 eq P2, P3, OK3 print "not " OK3: say "ok 3" set P1, -1 set P3, "-100000000000000000000" div P2, P0, P1 eq P2, P3, OK4 print "not " OK4: say "ok 4" end CODE ok 1 ok 2 ok 3 ok 4 OUT pasm_output_is( <<'CODE', <<'OUT', "div native int" ); .pcc_sub :main main: new P0, ['BigNum'] set P0, "100000000000000000000" new P1, ['BigNum'] div P1, P0, 10 new P2, ['BigNum'] set P2, "10000000000000000000" eq P1, P2, OK1 print "not " OK1: say "ok 1" set P0, "100000000000000" div P1, P0, 10000000 set P2, 10000000 eq P1, P2, OK2 print "not " OK2: say "ok 2" end CODE ok 1 ok 2 OUT pasm_output_is( <<'CODE', <<'OUT', "div other int" ); .pcc_sub :main main: new P0, ['BigNum'] set P0, "100000000000000000000" new P1, ['BigNum'] new P3, ['Integer'] set P3, 10 div P1, P0, P3 new P2, ['BigNum'] set P2, "10000000000000000000" eq P1, P2, OK1 print "not " OK1: say "ok 1" set P0, "100000000000000" new P4, ['Integer'] set P4, 10000000 div P1, P0, P4 set P2, 10000000 eq P1, P2, OK2 print "not " OK2: say "ok 2" end CODE ok 1 ok 2 OUT pasm_output_is( <<'CODE', <<'OUT', "div float" ); .pcc_sub :main main: new P0, ['BigNum'] set P0, "100000000000000000000" new P1, ['BigNum'] div P1, P0, 10.0 new P2, ['BigNum'] set P2, "10000000000000000000" eq P1, P2, OK1 print "not " OK1: say "ok 1" set P0, "100000000000000" div P1, P0, -10.0 set P2, "-10000000000000" eq P1, P2, OK2 print "not " OK2: say "ok 2" end CODE ok 1 ok 2 OUT pasm_output_is( <<'CODE', <<'OUT', "i_divide" ); .pcc_sub :main main: .include 'fp_equality.pasm' new P0, ['BigNum'] new P1, ['BigNum'] set P0, 10000000000 set P1, 5000000000 div P0, P1 set N0, P0 .fp_eq_pasm(N0, 2.0, OK1) print "not " OK1:say "ok 1" new P1, ['Integer'] set P0, 10 set P1, 4 div P0, P1 set N0, P0 .fp_eq_pasm(N0, 2.5, OK2) print "not " OK2:say "ok 2" new P1, ['Float'] set P0, 6 set P1, 1.5 div P0, P1 set N0, P0 .fp_eq_pasm(N0, 4.0, OK3) print "not " OK3:say "ok 3" push_eh THROWN new P1, ['BigInt'] set P1, 3 div P0, P1 print "no " THROWN: pop_eh say "exception thrown" set P0, 10 div P0, -5 set N0, P0 .fp_eq_pasm(N0, -2.0, OK4) print "not " OK4:say "ok 4" end CODE ok 1 ok 2 ok 3 exception thrown ok 4 OUT pasm_output_is( <<'CODE', <<'OUT', "floor_divide", todo => 'undiagnosed bug in floor division; no floor division is actually done.' ); .pcc_sub :main main: .include 'fp_equality.pasm' new P0, ['BigNum'] new P1, ['Integer'] set P0, 10 set P1, 4 fdiv P0, P0, P1 set N0, P0 .fp_eq_pasm(N0, 2.0, OK1) print "not " OK1:say "ok 1" push_eh THROWN new P1, ['Float'] set P1, 3.0 fdiv P0, P0, P1 print "no " THROWN: say "exception thrown" set P0, 10 fdiv P0, P0, -4 set N0, P0 say N0 .fp_eq_pasm(N0, -2.0, OK2) print "not " OK2:say "ok 2" new P1, ['BigNum'] set P0, 10 set P1, 4 fdiv P0, P1 set N0, P0 .fp_eq_pasm(N0, 2.0, OK3) print "not " OK3:say "ok 3" new P1, ['Integer'] set P0, 22 set P1, 4 fdiv P0, P1 set N0, P0 .fp_eq_pasm(N0, 5.0, OK4) print "not " OK4:say "ok 4" push_eh THROWN2 new P1, ['Float'] set P1, 3.0 fdiv P0, P1 print "no " THROWN2: say "exception thrown" set P0, 10 fdiv P0, 4 set N0, P0 .fp_eq_pasm(N0, 2.0, OK5) print "not " OK5:say "ok 5" end CODE ok 1 exception thrown ok 2 ok 3 ok 4 exception thrown ok 5 OUT pasm_output_is( <<'CODE', <<'OUT', "equality and comparison" ); .pcc_sub :main main: new P0, ['BigNum'] new P1, ['BigNum'] set P0, 3 set P1, 5 cmp I0, P0, P1 say I0 set P1, 2 cmp I0, P0, P1 say I0 set P1, 3 cmp I0, P0, P1 say I0 push_eh THROWN1 new P1, ['Float'] set P1, 3.3 iseq I0, P0, P1 print "no " THROWN1: pop_eh say "exception thrown" push_eh THROWN2 cmp I0, P0, P1 print "no " THROWN2: pop_eh say "exception thrown" end CODE -1 1 0 exception thrown exception thrown OUT pir_output_is( <<'CODE', <<'OUT', "pow method" ); .include 'fp_equality.pasm' .sub main :main $P0 = new ['BigNum'] $P1 = new ['Integer'] $P0 = 5 $P1 = 3 $P0 = $P0.'pow'($P1) $N0 = $P0 .fp_eq($N0, 125.0, OK1) print "not " OK1:say "ok 1" $P0 = 2 $P1 = -1 $P0 = $P0.'pow'($P1) $N0 = $P0 .fp_eq($N0, 0.5, OK2) print "not " OK2:say "ok 2" $P0 = 2456347674 $P1 = 0 $P0 = $P0.'pow'($P1) $N0 = $P0 .fp_eq($N0, 1, OK3) print "not " OK3:say "ok 3" .end CODE ok 1 ok 2 ok 3 OUT my @todo_sig = ( todo => "missing signature" ); for my $op ( "/", "%" ) { for my $type ( "BigNum", "BigInt", "Integer" ) { pir_output_is( <<"CODE", < 4 goto ok say "never" end ok: say "ok" .end CODE ok OUT pir_output_is( <<'CODE', <<'OUT', "BUG #34949 ge" ); .sub main :main .local pmc b b = new ['BigNum'] b = 1e10 if b >= 4 goto ok say "never" end ok: say "ok" .end CODE ok OUT pir_output_is( <<'CODE', <<'OUT', "BUG #34949 ne" ); .sub main :main .local pmc b b = new ['BigNum'] b = 1e10 if b != 4 goto ok say "never" end ok: say "ok" .end CODE ok OUT pir_output_is( <<'CODE', <<'OUT', "BUG #34949 eq" ); .sub main :main .local pmc b b = new ['BigNum'] b = 1e10 if b == 4 goto nok say "ok" end nok: say "nok" .end CODE ok OUT pir_output_is( <<'CODE', <<'OUT', "BUG #34949 le" ); .sub main :main .local pmc b b = new ['BigNum'] b = 1e10 if b <= 4 goto nok say "ok" end nok: say "nok" .end CODE ok OUT pir_output_is( <<'CODE', <<'OUT', "BUG #34949 lt" ); .sub main :main .local pmc b b = new ['BigNum'] b = 1e10 if b < 4 goto nok say "ok" end nok: say "nok" .end CODE ok OUT # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: optimize-01.t000644000765000765 1055411567202625 16330 0ustar00bruce000000000000parrot-6.6.0/t/steps/init#! perl # Copyright (C) 2007, Parrot Foundation. # init/optimize-01.t use strict; use warnings; use Test::More tests => 34; use Carp; use lib qw( lib t/configure/testlib ); use_ok('config::init::optimize'); use Parrot::Configure::Options qw( process_options ); use Parrot::Configure::Step::Test; use Parrot::Configure::Test qw( test_step_constructor_and_description ); use IO::CaptureOutput qw | capture |; ########## no optimization (default) ########## my ($args, $step_list_ref) = process_options( { argv => [], mode => q{configure}, } ); my $conf = Parrot::Configure::Step::Test->new; $conf->include_config_results( $args ); my $pkg = q{init::optimize}; $conf->add_steps($pkg); my $serialized = $conf->pcfreeze(); $conf->options->set( %{$args} ); my $step = test_step_constructor_and_description($conf); my $ret = $step->runstep($conf); ok( defined $ret, "runstep() returned defined value" ); $conf->replenish($serialized); ########## --optimize ########## ($args, $step_list_ref) = process_options( { argv => [q{--optimize}], mode => q{configure}, } ); $conf->options->set( %{$args} ); $step = test_step_constructor_and_description($conf); $ret = $step->runstep($conf); ok( defined $ret, "runstep() returned defined value" ); $conf->replenish($serialized); ########## --verbose ########## ($args, $step_list_ref) = process_options( { argv => [q{--verbose}], mode => q{configure}, } ); $conf->options->set( %{$args} ); $step = test_step_constructor_and_description($conf); { my $rv; my $stdout; capture ( sub {$rv = $step->runstep($conf) }, \$stdout); ok( defined $rv, "step_name runstep() returned defined value" ); ok( $stdout, "verbose output captured" ); } $conf->replenish($serialized); ########## --optimize ########## # 'bare' --optimize should mean: default to what Perl 5 uses (typically, -O2), # but perhaps with some manipulation due to GCC variations ($args, $step_list_ref) = process_options( { argv => [q{--optimize}], mode => q{configure}, } ); $conf->options->set( %{$args} ); $step = test_step_constructor_and_description($conf); $ret = $step->runstep($conf); ok( defined $ret, "runstep() returned defined value" ); my $perl5_setting = $conf->data->get('optimize_provisional'); like( $conf->data->get('optimize'), qr/$perl5_setting/, "Simple '--optimize' defaulted to Perl 5 optimization level" ); $conf->replenish($serialized); ########## --optimize=O2 ########## ($args, $step_list_ref) = process_options( { argv => [q{--optimize=-O3}], mode => q{configure}, } ); $conf->options->set( %{$args} ); $step = test_step_constructor_and_description($conf); $ret = $step->runstep($conf); ok( defined $ret, "runstep() returned defined value" ); is( $conf->data->get('optimize'), '-O3', "Got optimization level explicitly requested" ); $conf->replenish($serialized); ########## --optimize; gcc 3.3 ########## ($args, $step_list_ref) = process_options( { argv => [q{--optimize}], mode => q{configure}, } ); $conf->options->set( %{$args} ); $step = test_step_constructor_and_description($conf); $conf->data->set('gccversion' => '3.3'); $ret = $step->runstep($conf); ok( defined $ret, "runstep() returned defined value" ); $conf->replenish($serialized); ########## --optimize, --verbose; gcc 4.1 ########## ($args, $step_list_ref) = process_options( { argv => [q{--optimize}, q{--verbose}], mode => q{configure}, } ); $conf->options->set( %{$args} ); $step = test_step_constructor_and_description($conf); $conf->data->set('gccversion' => '4.1'); # need to capture the --verbose output, # because the fact that it does not end # in a newline confuses Test::Harness { my $rv; my $stdout; capture ( sub {$rv = $step->runstep($conf) }, \$stdout); ok( defined $rv, "runstep() returned defined value" ); ok( $stdout, "verbose output captured" ); } pass("Completed all tests in $0"); ################### DOCUMENTATION ################### =head1 NAME init/optimize-01.t - test init::optimize =head1 SYNOPSIS % prove t/steps/init/optimize-01.t =head1 DESCRIPTION The files in this directory test functionality used by F. The tests in this file test init::optimize. =head1 AUTHOR James E Keenan =head1 SEE ALSO config::init::optimize, F. =cut # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: misc.t000644000765000765 620111715102036 13633 0ustar00bruce000000000000parrot-6.6.0/t/src#! perl # Copyright (C) 2001-2011, Parrot Foundation. use strict; use warnings; use lib qw( . lib ../lib ../../lib ); use Test::More; use Parrot::Test; use Parrot::Config; use File::Spec::Functions; my $parrot_config = "parrot_config" . $PConfig{o}; plan skip_all => 'src/parrot_config.o does not exist' unless -e catfile("src", $parrot_config); plan tests => 4; =head1 NAME t/src/misc.t - Parrot miscellaneous utilities =head1 SYNOPSIS % prove t/src/misc.t =head1 DESCRIPTION Parrot miscellanea =cut sub linedirective { # Provide a #line directive for the C code in the heredoc # starting immediately after where this sub is called. my $linenum = shift() + 1; return "#line " . $linenum . ' "' . __FILE__ . '"' . "\n"; } c_output_is(linedirective(__LINE__) . <<'CODE', <<'OUTPUT', "Parrot_vsnprintf" ); #include #include #include "parrot/parrot.h" #include "parrot/misc.h" void fail(const char *msg); void fail(const char *msg) { fprintf(stderr, "failed: %s\n", msg); exit(EXIT_FAILURE); } int main(int argc, const char **argv) { Parrot_Interp interp; char buf[11]; interp = Parrot_interp_new(NULL); if (! interp) fail("Cannot create parrot interpreter"); Parrot_snprintf(interp, buf, 11, "test%d", 123456); puts(buf); Parrot_interp_destroy(interp); return 0; } CODE test123456 OUTPUT c_output_is(linedirective(__LINE__) . <<'CODE', <<'OUTPUT', "Parrot_vsnprintf with len 0" ); #include #include #include "parrot/parrot.h" #include "parrot/misc.h" void fail(const char *msg); void fail(const char *msg) { fprintf(stderr, "failed: %s\n", msg); exit(EXIT_FAILURE); } int main(int argc, const char **argv) { Parrot_Interp interp; char buf[] = "unchanged"; interp = Parrot_interp_new(NULL); if (! interp) fail("Cannot create parrot interpreter"); Parrot_snprintf(interp, buf, 0, ""); if (strcmp(buf, "unchanged") == 0) puts("Done"); else fail(buf); Parrot_interp_destroy(interp); return 0; } CODE Done OUTPUT c_output_is(linedirective(__LINE__) . <<'CODE', <<'OUTPUT', "Parrot_secret_snprintf", ( todo => "Parrot_secret_snprintf is more sprintf than snprintf")); #include #include #include "parrot/misc.h" void fail(const char *msg); void fail(const char *msg) { fprintf(stderr, "failed: %s\n", msg); exit(EXIT_FAILURE); } int main(int argc, const char **argv) { char buf[10]; /* int res = Parrot_secret_snprintf(buf, 10, "12345678901234567890"); if (res == 20) puts("Done"); else fail("snprintf len mismatch"); */ printf("THE FAILZ"); return 0; } CODE Done OUTPUT c_output_is(linedirective(__LINE__) . <<'CODE', <<'OUTPUT', "PARROT_GC_WRITE_BARRIER macro" ); #include #include #include "parrot/parrot.h" int main(int argc, const char **argv) { PMC pmc; pmc.flags = 0; /* It should compile */ PARROT_GC_WRITE_BARRIER(NULL, &pmc); printf("Done\n"); return 0; } CODE Done OUTPUT # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: ch05_control_structures.pod000644000765000765 2576611631440401 21502 0ustar00bruce000000000000parrot-6.6.0/docs/book/pir=pod =head1 Control Structures The semantics of control structures in high-level languages vary broadly. Rather than dictating one particular set of semantics for control structures, or attempting to provide multiple implementations of common control structures to fit the semantics of all major target languages, PIR provides a simple set of conditional and unconditional branch instructions.N =head2 Conditionals and Unconditionals X X An unconditional branch always jumps to a specified label. PIR has only one unconditional branch instruction, C. In this example, the first C statement never runs because the C always skips over it to the label C: =begin PIR_FRAGMENT goto skip_all_that say "never printed" skip_all_that: say "after branch" =end PIR_FRAGMENT X A conditional branch jumps to a specified label only when a particular condition is true. The condition may be as simple as checking the truth of a particular variable or as complex as a comparison operation. In this example, the CX skips to the label C only if the value stored in C<$I0> is true. If C<$I0> is false, it will print "might be printed" and then print "after branch": =begin PIR_FRAGMENT if $I0 goto maybe_skip say "might be printed" maybe_skip: say "after branch" =end PIR_FRAGMENT =head3 Boolean Truth X Parrot's C and C instructions evaluate a variable as a boolean to decide whether to jump. In PIR, an integer is false if it's 0 and true if it's any non-zero value. A number is false if it's 0.0 and true otherwise. A string is false if it's the empty string (C<"">) or a string containing only a zero (C<"0">), and true otherwise. Evaluating a PMC as a boolean calls the vtable function CX to check if it's true or false, so each PMC is free to determine what its boolean value should be. =head3 Comparisons X In addition to a simple check for the truth of a variable, PIR provides a collection of comparison operations for conditional branches. These jump when the comparison is true. This example compares C<$I0> to C<$I1> and jumps to the label C if C<$I0> is less than C<$I1>: =begin PIR_FRAGMENT if $I0 < $I1 goto success say "comparison false" success: say "comparison true" =end PIR_FRAGMENT The full set of comparison operators in PIR are C<==> (equal), C (not equal), C> (less than), C=> (less than or equal), C> (greater than), and C=> (greater than or equal). =head3 Complex Conditions PIR disallows nested expressions. You cannot embed a statement within another statement. If you have a more complex condition than a simple truth test or comparison, you must build up your condition with a series of instructions that produce a final, single truth value. This example performs two operations, addition and multiplication, then uses CX to check if the results of both operations were true. The C opcode stores a boolean value (0 or 1) in the integer variable C<$I2>; the code uses this value in an ordinary truth test: =begin PIR_FRAGMENT $I0 = 4 + 5 $I1 = 63 * 0 $I2 = and $I0, $I1 if $I2 goto true say "maybe printed" true: =end PIR_FRAGMENT =head2 If/Else Construct C High-level languages often use the keywords I and I for simple conditional control structures. These control structures perform an action when a condition is true and skip the action when the condition is false. PIR's C instruction can build up simple conditionals. This example checks the truth of the condition C<$I0>. If C<$I0> is true, it jumps to the C label, and runs the body of the conditional construct. If C<$I0> is false, it continues on to the next statement, a C instruction that skips over the body of the conditional to the label C: =begin PIR_FRAGMENT if $I0 goto do_it goto dont_do_it do_it: say "in the body of the if" dont_do_it: =end PIR_FRAGMENT The control flow of this example may seem backwards. In a high-level language, I often means I<"if the condition is true, run the next few lines of code">. In an assembly language, it's often more straightforward to write I<"if the condition is true, B the next few lines of code">. Because of the reversed logic, you may find it easier to build a simple conditional construct using the CX instruction instead of C. =begin PIR_FRAGMENT unless $I0 goto dont_do_it say "in the body of the if" dont_do_it: =end PIR_FRAGMENT This example produces the same output as the previous example, but the logic is simpler. When C<$I0> is true, C does nothing and the body of the conditional runs. When C<$I0> is false, C skips over the body of the conditional by jumping to C. C An I control structure is easier to build using the C instruction than C. To build an I, insert the body of the else right after the first C instruction. This example checks if C<$I0> is true. If so, it jumps to the label C and runs the body of the I construct. If C<$I0> is false, the C instruction does nothing, and the code continues to the body of the I construct. When the body of the else has finished, the C jumps to the end of the I control structure by skipping over the body of the I construct: if $I0 goto true say "in the body of the else" goto done true: say "in the body of the if" done: =head2 Switch Construct X A I control structure selects one action from a list of possible actions by comparing a single variable to a series of values until it finds one that matches. The simplest way to achieve this in PIR is with a series of C instructions: =begin PIR_FRAGMENT $S0 = 'a' option1: unless $S0 == 'a' goto option2 say "matched: a" goto end_of_switch option2: unless $S0 == 'b' goto default say "matched: b" goto end_of_switch default: say "I don't understand" end_of_switch: =end PIR_FRAGMENT This example uses C<$S0> as the I of the switch construct. It compares that case against the first value C. If they match, it prints the string "matched: a", then jumps to the end of the switch at the label C. If the first case doesn't match C, the C jumps to the label C to check the second option. The second option compares the case against the value C. If they match, it prints the string "matched: b", then jumps to the end of the switch. If the case doesn't match the second option, the C goes on to the default case, prints "I don't understand", and continues to the end of the switch. =head2 Do-While Loop A IX loop runs the body of the loop once, then checks a condition at the end to decide whether to repeat it. A single conditional branch can build this style of loop: =begin PIR_FRAGMENT $I0 = 0 # counter redo: # start of loop inc $I0 say $I0 if $I0 < 10 goto redo # end of loop =end PIR_FRAGMENT This example prints the numbers 1 to 10. The first time through, it executes all statements up to the C instruction. If the condition evaluates as true (C<$I0> is less than 10), it jumps to the C label and runs the loop body again. The loop ends when the condition evaluates as false. Here's a slightly more complex example that calculates the factorial C<5!>: =begin PIR_FRAGMENT .local int product, counter product = 1 counter = 5 redo: # start of loop product *= counter dec counter if counter > 0 goto redo # end of loop say product =end PIR_FRAGMENT Each time through the loop it multiplies C by the current value of the C, decrements the counter, and jumps to the start of the loop. The loop ends when C has counted down to 0. =head2 While Loop X A I loop tests the condition at the start of the loop instead of at the end. This style of loop needs a conditional branch combined with an unconditional branch. This example also calculates a factorial, but with a I loop: =begin PIR_FRAGMENT .local int product, counter product = 1 counter = 5 redo: # start of loop if counter <= 0 goto end_loop product *= counter dec counter goto redo end_loop: # end of loop say product =end PIR_FRAGMENT This code tests the counter C at the start of the loop to see if it's less than or equal to 0, then multiplies the current product by the counter and decrements the counter. At the end of the loop, it unconditionally jumps back to the start of the loop and tests the condition again. The loop ends when the counter C reaches 0 and the C jumps to the C label. If the counter is a negative number or zero before the loop starts the first time, the body of the loop will never execute. =head2 For Loop X A I loop is a counter-controlled loop with three declared components: a starting value, a condition to determine when to stop, and an operation to step the counter to the next iteration. A I loop in C looks something like: for (i = 1; i <= 10; i++) { ... } where C is the counter, C sets the start value, C<< i <= 10 >> checks the stop condition, and C steps to the next iteration. A I loop in PIR requires one conditional branch and two unconditional branches. =begin PIR_FRAGMENT loop_init: .local int counter counter = 1 loop_test: if counter <= 10 goto loop_body goto loop_end loop_body: say counter loop_continue: inc counter goto loop_test loop_end: =end PIR_FRAGMENT The first time through the loop, this example sets the initial value of the counter in C. It then goes on to test that the loop condition is met in C. If the condition is true (C is less than or equal to 10) it jumps to C and executes the body of the loop. If the condition is false, it will jump straight to C and the loop will end. The body of the loop prints the current counter then goes on to C, which increments the counter and jumps back up to C to continue on to the next iteration. Each iteration through the loop tests the condition and increments the counter, ending the loop when the condition is false. If the condition is false on the very first iteration, the body of the loop will never run. =cut # Local variables: # c-file-style: "parrot" # End: # vim: expandtab shiftwidth=4: 47-loop-control.t000644000765000765 61112135343346 17602 0ustar00bruce000000000000parrot-6.6.0/ext/nqp-rx/t/nqp#!./parrot-nqp plan(3); my $runs := 0; while $runs < 5 { $runs++; last if $runs == 3; } ok($runs == 3, "last works in while"); $runs := 0; my $i := 0; while $runs < 5 { $runs++; next if $runs % 2; $i++; } ok($i == 2, "next works in while"); $runs := 0; $i := 0; while $i < 5 { $runs++; redo if $runs % 2; $i++; } ok($runs == 10, "redo works in while"); gc_alloc_new.pasm000644000765000765 352111567202623 20724 0ustar00bruce000000000000parrot-6.6.0/examples/benchmarks# Copyright (C) 2001-2003, Parrot Foundation. =head1 NAME examples/benchmarks/gc_alloc_new.pasm - GC Benchmark =head1 SYNOPSIS % ./parrot examples/benchmarks/gc_alloc_new.pasm =head1 DESCRIPTION Makes a big string with C, then prints out some statistics indicating: =over 4 =item * the time taken =item * the total number of bytes allocated =item * the total of GC runs made =item * the total number of collection runs made =item * the total number of bytes copied =item * the number of active C Cs =item * the total number of C Cs =back =cut # a rather useless test to check if your system does swapping # if sizes are too big .pcc_sub :main main: set I0, 6 set I1, 0 set S1, "1234567890" time N5 loop: repeat S1, S1, 10 inc I1 lt I1, I0, loop getout: time N6 sub N7, N6, N5 print N7 print " seconds.\n" interpinfo I1, 1 print "A total of " print I1 print " bytes were allocated\n" interpinfo I1, 2 print "A total of " print I1 print " GC runs were made\n" interpinfo I1, 3 print "A total of " print I1 print " collection runs were made\n" interpinfo I1, 10 print "Copying a total of " print I1 print " bytes\n" interpinfo I1, 5 print "There are " print I1 print " active Buffer structs\n" interpinfo I1, 7 print "There are " print I1 print " total Buffer structs\n" end =head1 SEE ALSO F, F, F, F, F, F, F, F. =cut # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: mines.png000644000765000765 1106111466337261 20262 0ustar00bruce000000000000parrot-6.6.0/examples/sdl/minesweeperPNG  IHDRP@6IDATx}PT?ʾ,.pE@KRLbZNi2If2b$љNVڴLdMDhhR4֨ ˲ 9eW`&ׯsF8<<{~s'Y d2G?⥗^Z(_`6GP$TR\v ??Z4MBH$t:2/P(h4Zm|ZaxXF#b2T$) 7P U|: wg ύ(Je(P(/SL٦" Z6/OH@ဃ;,O{͍?N εwl3&Ȥ2I9yhC,KZ9N_I^ry))֒ *UZBta'V$R mfJ)(^"Ppkdfx< . ,mVss&C8L91~$Qo *ƭ[gF6m  |:C l$&a(3[v٤ܸ!chHϷ0Qmdwn42 Z26BXmmqT*um!MGLLXp8LM!`h'6 re2>.n.J~>U(eJ$AВY ~\>d2%˖@?BIב.~_39inV }>5-ׄrTNgF'&wюQFkq,,DLHSoI$b~QDFq$:qt;jad`a69(<$ 10ͼ}Sv.ʎ;Ыq{zǑɔX/##W^&DAcTϘ'@4%n)pjpB11tpz|1W,SZu ji1Ґ);}}MH$2s.\E.3լܵ)]İ]+Qggq\KoJZZd("7nxu?;49G>e»"I+ͦMQ~[06vTx<(:LogU՘13 C>c#fdr,\&P(JHb(W!3Sdz23Ej"1*)J+"IqTU*I|۰>@T dg?JRYAkb\oD&}u:ȵ<;;5k֐b@.\~M Ԉ@`>H_,));YjτqcL>(vN}KL& ԈrrrB aXi |2dddD9ݵ)--/ jLEE?<18 L'O/`ʀ F(E~:LL߸azlz#ᓗ_d[GVe%似\{nﭭ\pNw;uOݻwѣGfŊQ){hFh&a$'(._Q"CZ|755[SC+^$=W_}5g`NWSSێhnnFz!CKK X,\A!yz4kG#q(*+ #xHl6iiEדcmm ]*#w?͌wtq>4 DEo}[ֆgXسg]]]\|^{ OII < Qy#wǏVUKKeb<Hǎ䭭 (T*ֿwO?})-!}>Ȯ]HM\·#G͛1455qU),, ~sj#A]QF|=ICC(,$n5k@CD6A!HRk"SǑy&GtRUUEEEEBI|.)+VH`ŋd?L8`tdA@V F̙VA00}DDZ(D:81tq/nj[,8ar9<D{{;x<<{q93zyz-R)z{.a %mg'WW#r˅U"(}*_{ 8{{Q6l@Tnشi?|s~̹sP^^ƍINN(/PtHRS1|ov+IJM%Ez5^p16##YLn9żhjjjbrc5 >(>hBl6mB1>ܸ3"bV`tg^fZ0#~`/f6?}Q-O|7rq)zzz8_A?Yٳgo~Þ={"*9E^n>?Ox< Kee%vil\ٳ$6LN~p#GPW[w6ػ7|.'J$\.:a\0Z6,b4?ho'j)/*<(":勢n3>>E*Jff&IIIraB?arCvVCoh@;!gϞppZZZzdffRZZʖ-[(//j LNNv:5.rG@шuV+~!Νcll RIqq1?06l@~ $n7ʆ6 b:ɡCpBxt-zzza1]=fh'h3%p8\@ NSS\ fe+S "G 9s .\`۶m4ӧWUf4I"X,?77;vVx<:tXy@Avb7P4gL ڵk|?yN8#cǎqMXv-wߗ/))A`6#R (Z=^{254NNQ:< $jy|>yL hnnM={088H ýX~kk+'OyYG466#O_Q&țya֭SVVF~~ nfeԩS{^~_2::^IIfmpR.ikOJ;{x[~ _WXXdd2Ey!~__NX H .;;;R۷o8@bZh;UbЖ|xZB|;ʗV1U晉`ɿ:q^x1~Wǿas ?ڗ39s_Ή#aw;"\v#Baw;"\v# aw;{t:]L?l5{|U5vD0Q?nG.immv bXhXJRPER{%?Oůꫯ.ʏ\nKFzIENDB`mops_intval.pasm000644000765000765 261111567202623 20642 0ustar00bruce000000000000parrot-6.6.0/examples/benchmarks# Copyright (C) 2001-2003, Parrot Foundation. =head1 NAME examples/benchmarks/mops_intval.pasm - Calculate a benchmark =head1 SYNOPSIS % ./parrot examples/benchmarks/mops_intval.pasm =head1 DESCRIPTION Calculates a value for M ops/s (million operations per second) using integer arithmetic. =cut set I2, 0 set I3, 1 set I4, 100000000 print "Iterations: " print I4 print "\n" set I1, 2 mul I5, I4, I1 print "Estimated ops: " print I5 print "\n" time N1 REDO: sub I4, I4, I3 if I4, REDO DONE: time N5 sub N2, N5, N1 print "Elapsed time: " print N2 print "\n" if I4, BUG set N1, I5 div N1, N1, N2 set N2, 1000000.0 div N1, N1, N2 print "M op/s: " print N1 print "\n" end BUG: print "This can't happen\n" end =head1 SEE ALSO F, F, F, F, F, F, F, F, F, F. =cut # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: README.pod000644000765000765 237312101554067 14275 0ustar00bruce000000000000parrot-6.6.0/tools# Copyright (C) 2001-2012, Parrot Foundation. =pod =head1 NAME tools/README.pod - Readme file for the 'tools/' top-level directory. =head1 DESCRIPTION This directory contains multiple subdirectories which are outlined as follows: =over 4 =item F This subdirectory contains programs, templates, and configuration files invoked by the default 'make' target I 'make all', with or without command-line options, during the Parrot build process. =item F This subdirectory contains programs, templates, and configuration files found useful to Parrot developers, excluding those which are (1) invoked via the default 'make' target I 'make all' or (2) invoked by 'make install' or 'make install-dev'. =item F This subdirectory contains programs, templates, and configuration files found useful for working with or for the building of Parrot's documentation. =item F This subdirectory contains programs, templates, and configuration files found useful for the post-installation of Parrot, I smoke reports. =item F This subdirectory contains programs, templates, and configuration files invoked by 'make install' or 'make install-dev'. =back =head1 COPYRIGHT Copyright (C) 2012, Parrot Foundation. =cut Tools.pm000644000765000765 527511631440402 17441 0ustar00bruce000000000000parrot-6.6.0/lib/Parrot/Docs/Section# Copyright (C) 2006-2011, Parrot Foundation. =head1 NAME Parrot::Docs::Section::Tools - Tools documentation section =head1 SYNOPSIS use Parrot::Docs::Section::Tools; =head1 DESCRIPTION A documentation section describing Parrot tools. =head2 Class Methods =over =cut package Parrot::Docs::Section::Tools; use strict; use warnings; use base qw( Parrot::Docs::Section ); use Parrot::Docs::Item; =item C Returns a new section. =cut sub new { my $self = shift; return $self->SUPER::new( 'Tools', 'tools.html', '', $self->new_group( 'Configuration', '', $self->new_item( '', 'tools/dev/as2c.pl' ), $self->new_item( '', 'tools/build/vtable_h.pl' ), $self->new_item( '', 'tools/build/vtable_extend.pl' ), ), $self->new_group( 'Building', '', $self->new_item( '', 'docs/configuration.pod' ), $self->new_item( '', 'tools/build/c2str.pl' ), $self->new_item( '', 'tools/build/parrot_config_c.pl' ), $self->new_item( '', 'tools/build/pmc2c.pl' ), $self->new_item( '', 'tools/dev/install_files.pl' ), $self->new_item( '', 'tools/dev/mk_manifest_and_skip.pl' ), $self->new_item( '', 'tools/dev/symlink.pl' ), $self->new_item( '', 'tools/dev/mk_native_pbc' ), ), $self->new_group( 'Testing', '', $self->new_item( '', 'parrotbug' ), $self->new_item( '', 'tools/dev/manicheck.pl' ), $self->new_item( '', 'docs/tests.pod' ), ), $self->new_group( 'Documentation', '', $self->new_item( '', 'tools/dev/lib_deps.pl' ), $self->new_item( '', 'tools/dev/parrot_coverage.pl' ), $self->new_item( '', 'tools/docs/write_docs.pl' ), ), $self->new_group( 'Benchmarking', '', $self->new_item( '', 'tools/dev/bench_op.pir' ), $self->new_item( '', 'tools/dev/parrotbench.pl' ), ), $self->new_group( 'Utilities', '', $self->new_item( '', 'tools/dev/gen_class.pl' ), $self->new_item( '', 'tools/dev/ncidef2pir.pl' ), $self->new_item( '', 'tools/dev/pbc_header.pl' ), ), $self->new_group( 'Debugging', '', $self->new_item( 'Debugging Tools', 'docs/debug.pod'), $self->new_item( 'Parrot Debugger', 'docs/debugger.pod'), ), ); } =back =cut 1; # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: number_4_8_be.pbc000644000765000765 504012356767112 17152 0ustar00bruce000000000000parrot-6.6.0/t/native_pbcPBC   *BYTECODE_t/native_pbc/testdata/number.pasmD*CONSTANT_t/native_pbc/testdata/number.pasml-BYTECODE_t/native_pbc/testdata/number.pasm_DBX             core_ops dglB@PABAP@ABPAB0@0Ap@ABBp?A0B@pAB@@@C !t/native_pbc/testdata/number.pasm(null)parrotT XP  !"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRXP  !"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPinterp.t000644000765000765 640711567202625 14052 0ustar00bruce000000000000parrot-6.6.0/t/op#!perl # Copyright (C) 2001-2009, Parrot Foundation. use strict; use warnings; use lib qw( . lib ../lib ../../lib ); use Test::More; use Parrot::Test tests => 8; =head1 NAME t/op/interp.t - Running the Interpreter =head1 SYNOPSIS % prove t/op/interp.t =head1 DESCRIPTION Tests the old and new styles of running the Parrot interpreter and the C opcode. =cut # we probably shouldn't just run a label, but this catches a potential seggie pasm_output_is( <<'CODE', <<'OUTPUT', "runinterp - new style" ); .pcc_sub :main main: new P0, 'ParrotInterpreter' say 'calling' # set_addr/invoke ? runinterp P0, foo say 'ending' end say 'bad things!' foo: say 'In 2' end CODE calling In 2 ending OUTPUT pir_output_is( <<'CODE', <<'OUTPUT', 'runinterp - works with printing' ); .sub 'test' :main .local string actual .local pmc test_interp test_interp = new 'ParrotInterpreter' print "uno\n" runinterp test_interp, pasm print "dos\n" goto pasm_end pasm: noop end pasm_end: .end CODE uno dos OUTPUT # Need to disable GC while trace is on, as there's a non-zero chance that a # GC sweep would occur, causing a bonus "GC mark" line in the output, which makes # the test fail. pasm_output_like( <<'CODE', <<'OUTPUT', "restart trace" ); .pcc_sub :main main: print "ok 1\n" sweepoff set I0, 1 trace I0 dec I0 trace I0 sweepon print "ok 2\n" end CODE /^ok\s1\n (?:0+8.*)?\n (?:0+a.*)?\n ok\s2\n$/x OUTPUT pasm_output_is( <<'CODE', 'nada:', 'interp - warnings' ); .pcc_sub :main main: new P0, 'Undef' set I0, P0 print "nada:" warningson 1 new P1, 'Undef' set I0, P1 end CODE pasm_output_is( <<'CODE', <<'OUTPUT', "getinterp" ); .pcc_sub :main main: .include "interpinfo.pasm" getinterp P0 print "ok 1\n" set I0, P0[.INTERPINFO_ACTIVE_PMCS] interpinfo I1, .INTERPINFO_ACTIVE_PMCS eq I0, I1, ok2 print "not " ok2: print "ok 2\n" end CODE ok 1 ok 2 OUTPUT pasm_output_is( <<'CODE', <<'OUTPUT', "access argv" ); .pcc_sub :main main: get_params "0", P5 .include "iglobals.pasm" getinterp P1 set P2, P1[.IGLOBALS_ARGV_LIST] set I0, P5 set I1, P2 eq I0, I1, ok1 print "not " ok1: print "ok 1\n" set S0, P5[0] set S1, P2[0] eq S0, S1, ok2 print "not " ok2: print "ok 2\n" end CODE ok 1 ok 2 OUTPUT pasm_output_is( <<'CODE', <<'OUTPUT', "check_events" ); .pcc_sub :main main: print "before\n" check_events print "after\n" end CODE before after OUTPUT pir_output_is( <<'CODE', <<'OUTPUT', "interpinfo & getinterp: current runcore" ); .include 'interpinfo.pasm' .include 'interpcores.pasm' .sub 'test' :main $I0 = interpinfo .INTERPINFO_CURRENT_RUNCORE if $I0 == .PARROT_FUNCTION_CORE goto ok1 if $I0 == .PARROT_FAST_CORE goto ok1 if $I0 == .PARROT_EXEC_CORE goto ok1 if $I0 == .PARROT_GC_DEBUG_CORE goto ok1 print 'not ' ok1: say 'ok 1' $P0 = getinterp $I1 = $P0[.INTERPINFO_CURRENT_RUNCORE] if $I0 == $I1 goto ok2 print 'not ' ok2: say 'ok 2' .end CODE ok 1 ok 2 OUTPUT # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: Exception.pir000644000765000765 226011533177636 22061 0ustar00bruce000000000000parrot-6.6.0/runtime/parrot/library/Parrot=head1 TITLE Parrot::Exception - Auxiliary methods for Exceptions =head1 SYNOPSIS load_bytecode 'Parrot/Exception.pbc' # ... $S0 = 'XYZ' $P0 = get_class 'Exception' $P1 = $P0.'new'('Error in "', $S0, '" module') throw $P1 =head1 DESCRIPTION This module provides some additional support for using Parrot's built-in Exception class. The principal method is C, which simplifies the task of building and populating Exception objects. =head2 Methods =over 4 =item new([arg, ...]) Build an C object, initializing its message component to be the concatenation of any arguments supplied. Returns the newly created C. =cut .namespace [ 'Exception' ] .sub 'new' :method .param pmc args :slurpy .local pmc ex .local string message ex = new 'Exception' if null args goto end message = join '', args ex = message end: .return (ex) .end =back =head1 AUTHOR Patrick R. Michaud =head1 COPYRIGHT Copyright (C) 2007-2008, Parrot Foundation. =cut # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: Dumper.pir000644000765000765 371311567202622 17445 0ustar00bruce000000000000parrot-6.6.0/compilers/pct/src/PCT# Copyright (C) 2009, Parrot Foundation. =head1 NAME PCT::Dumper - various dumper formats for PCT =head1 DESCRIPTION This file implements a dumper that attempts to output PAST, Match, and Capture objects in a format that can be easily consumed by syntax highlighters (such as Padre). Yes, the code is probably much uglier and convoluted than it should be. No, I'm not proud of it, but it works for now. =cut .namespace ['PCT';'Dumper'] .sub 'padre' .param pmc obj .param string name .param pmc options :slurpy :named 'padre_item'(obj, name) .end .sub 'padre_item' :multi(_) .param pmc obj .param pmc name .end .sub 'padre_item' :multi(['PGE';'Match']) .param pmc obj .param pmc name .local string str str = obj.'Str'() $I0 = length str if $I0 < 48 goto have_str str = substr str, 0, 48 str = concat str, '...' have_str: str = escape str $S0 = obj['type'] unless $S0 goto have_name name = $S0 have_name: $P0 = new 'ResizablePMCArray' $I1 = obj.'from'() push $P0, $I1 $I2 = obj.'to'() $I2 -= $I1 push $P0, $I2 push $P0, name push $P0, str $S0 = sprintf ' %4d %4d %-20s "%s"', $P0 say $S0 .local pmc hash, hash_it hash = obj.'hash'() hash_it = iter hash hash_it_loop: unless hash_it goto hash_it_done .local string key key = shift hash_it $P0 = hash[key] 'padre_item'($P0, key) goto hash_it_loop hash_it_done: $P0 = obj.'list'() 'padre_item'($P0, name) .end .sub 'padre_item' :multi(['ResizablePMCArray']) .param pmc obj .param pmc name .local pmc list_it list_it = iter obj list_it_loop: unless list_it goto list_it_done $P0 = shift list_it 'padre_item'($P0, name) goto list_it_loop list_it_done: .end =head1 AUTHOR Patrick R. Michaud =cut # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: registernames.t000644000765000765 110411533177645 15570 0ustar00bruce000000000000parrot-6.6.0/t/pir#!./parrot # Copyright (C) 2009, Parrot Foundation. =head1 NAME t/pir/registernames.t - Tests for PIR register variable names =head1 SYNOPSIS % prove t/pir/registernames.t =head1 DESCRIPTION Tests for register variable names in PIR. =cut .sub 'main' :main .include 'test_more.pir' plan(1) test_I01_is_not_I1() .end .sub test_I01_is_not_I1 $I1 = 1 $I01 = 2 isnt($I1,$I01, 'Register variables "$I1" and "$I01" are not the same variable') .end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: blockdata.pir000644000765000765 1143012101554066 20057 0ustar00bruce000000000000parrot-6.6.0/examples/sdl/tetris =head1 DESCRIPTION blockdata.pir - a tetris block data class =head1 SYNOPSIS # create a new random block data = _BlockData::new( -1 ) # rotate the data clockwise _BlockData::rotate( data, 1 ) =cut .namespace ["Tetris::BlockData"] .sub __onload :load $P0 = get_class "Tetris::BlockData" unless null $P0 goto END newclass $P0, "Tetris::BlockData" addattribute $P0, "data" END: .end =head1 METHODS =over 4 =item blockdata."rotate"( dir ) Changes the C in a way to make the block look rotated. =over 4 =item parameter C

+1 = rotate clockwise -1 = rotate counterclockwise =back This method returns the old data representation. =cut .sub rotateData :method .param int val .local int size .local int x .local int y .local int i .local int j .local int v .local pmc olddata getattribute olddata, self, 'data' olddata = clone olddata size = self."size"() set y, size set i, size mul i, size dec i yLOOP: set x, 0 dec y if y < 0 goto END xLOOP: if val != +1 goto WAY2 set j, x mul j, size add j, y branch DONE WAY2: set j, size sub j, x dec j mul j, size set v, size sub v, y dec v add j, v DONE: v = olddata[i] self[j] = v dec i inc x if x >= size goto yLOOP branch xLOOP END: .return (olddata) .end =item rows = blockdata."vfree"() Checks how many free rows exist at the top edge of block represented by this block data. Returns the number of free rows. =cut .sub vfree :method .local int size .local int free .local int i .local int temp .local int size2 i = 0 size = self."size"() if size == 0 goto END set i, 0 set size2, size mul size2, size VFREE_LOOP: if i > size2 goto VFREE_END temp = self[i] if temp goto VFREE_END inc i branch VFREE_LOOP VFREE_END: div i, size END: .return (i) .end =item columns = blockdata."hfree"() Checks how many free columns exist at the left an right edges. Positive return values means that this many free colums were counted. If the returned value is negative, the absolute value is the number of free colums found at the right edge. Returns the number of free columns. =cut .sub hfree :method .local int size .local int free .local int i .local int offset .local int free .local int temp size = self."size"() free = 0 HFREE_LOOPfree: inc free set i, 0 set offset, free dec offset HFREE_LOOPcheck: temp = self[offset] if temp goto HFREE_ERROR inc i add offset, size if i < size goto HFREE_LOOPcheck if free < size goto HFREE_LOOPfree HFREE_ERROR: dec free if free goto HFREE_END free = 0 HFREE_LOOPfree2: dec free set i, size mul i, -1 if free < i goto HFREE_ERROR2 set i, 0 if offset < 0 goto HFREE_ERROR2 HFREE_LOOPcheck2: set temp, size add temp, free set offset, i mul offset, size add offset, temp temp = self[offset] if temp goto HFREE_ERROR2 inc i if i < size goto HFREE_LOOPcheck2 if free < size goto HFREE_LOOPfree2 HFREE_ERROR2: inc free HFREE_END: .return (free) .end =item size = blockdata."size"() Returns the size of the block represented by this block data. The square of the size is the number of items in the blockdata array. =cut .sub size :method getattribute $P0, self, 'data' $I0 = 0 if_null $P0, END $I0 = $P0 $N0 = $I0 sqrt $N0, $I0 $I0 = $N0 END: .return ($I0) .end .sub __set_pmc :method .param pmc data setattribute self, 'data', data .end .sub __get_integer_keyed :method .param pmc key .local int index index = key getattribute $P0, self, 'data' if_null $P0, ERR $I0 = $P0 if index >= $I0 goto ERR $I0 = $P0[index] .return ($I0) ERR: print "index out of bounds (" print index print ">=" print $I0 print ")!\n" $P0 = new 'Exception' $P0 = "out of bounds!" throw $P0 .end .sub __set_integer_keyed :method .param pmc key .param int val .local int index index = key getattribute $P0, self, 'data' if_null $P0, ERR $I0 = $P0 if index >= $I0 goto ERR $P0[index] = val .return ($I0) ERR: print "index out of bounds (" print index print ">=" print $I0 print ")!\n" $P0 = new 'Exception' $P0 = "out of bounds!" throw $P0 .end =back =head1 AUTHOR Jens Rieks Eparrot at jensbeimsurfen dot deE is the author and maintainer. Please send patches and suggestions to the Perl 6 Internals mailing list. =head1 COPYRIGHT Copyright (C) 2004-2008, Parrot Foundation. =cut # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: perltidy.conf000644000765000765 105211533177646 16122 0ustar00bruce000000000000parrot-6.6.0/tools/dev# A declarative version of PDD07 for perl. # Must apply... -l=100 # Source line width is limited to 100 characters. -i=4 # must be indented four columns (no tabs) -ola # Labels (including case labels) must be outdented two columns -ci=4 # Long lines, when split, must use at least one extra level of indentation on the continued line. -ce # Cuddled elses are forbidden: i.e. avoid } else { . # Nice to haves... # Freeze new lines; some really short lines look good the way they # are, this should stop perltidy from merging them together -fnl Config.pm000644000765000765 220711606346657 15265 0ustar00bruce000000000000parrot-6.6.0/lib/Parrot# Copyright (C) 2006-2007, Parrot Foundation. =head1 NAME Parrot::Config - Parrot Configuration Data =head1 DESCRIPTION This file is used for parrot's configuration data. If C hasn't been run yet, it dies with a message explaining that parrot needs to be configured first. It contains the C<%PConfig> hash which is exported with the values loaded from F. A list of valid keys can be found from running parrot_config --dump =head1 SYNOPSIS use Parrot::Config; my $has_ipv6 = $PConfig{HAS_IPV6}; =cut package Parrot::Config; use strict; use warnings; eval 'use Parrot::Config::Generated'; if ($@) { die "\nParrot::Config is unavailable until you configure parrot.\n" . "Please run `perl Configure.pl`.\n\n"; } use Exporter; use vars qw(@ISA @EXPORT %PConfig %PConfig_Temp); @ISA = qw(Exporter); @EXPORT = qw(%PConfig %PConfig_Temp); %PConfig = %Parrot::Config::Generated::PConfig; %PConfig_Temp = %Parrot::Config::Generated::PConfig_Temp; 1; # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: msvc.pm000644000765000765 612311533177633 15224 0ustar00bruce000000000000parrot-6.6.0/config/auto# Copyright (C) 2005-2007, Parrot Foundation. =head1 NAME config/auto/msvc.pm - Microsoft Visual C++ Compiler =head1 DESCRIPTION Determines whether the C compiler is actually Visual C++. =cut package auto::msvc; use strict; use warnings; use base qw(Parrot::Configure::Step); use Parrot::Configure::Utils ':auto'; sub _init { my $self = shift; my %data; $data{description} = q{Is your C compiler actually Visual C++}; $data{result} = q{}; return \%data; } sub runstep { my ( $self, $conf ) = ( shift, shift ); if ($conf->data->get('gccversion')) { $conf->debug(" (skipped) "); $self->set_result('skipped'); $conf->data->set( msvcversion => undef ); return 1; } my $msvcref = _probe_for_msvc($conf); $self->_evaluate_msvc($conf, $msvcref); return 1; } sub _probe_for_msvc { my $conf = shift; $conf->cc_gen("config/auto/msvc/test_c.in"); $conf->cc_build(); my %msvc = eval $conf->cc_run() or die "Can't run the test program: $!"; $conf->cc_clean(); return \%msvc; } sub _evaluate_msvc { my ($self, $conf, $msvcref) = @_; # Set msvcversion to undef. This will also trigger any hints-file # callbacks that depend on knowing whether or not we're using Visual C++. # This key should always exist unless the program couldn't be run, # which should have been caught by the 'die' above. # Therefore, test if it's defined to see if MSVC's installed. # return 'no' if it's not. unless ( defined $msvcref->{_MSC_VER} ) { $self->set_result('no'); $conf->data->set( msvcversion => undef ); return 1; } my $major = int( $msvcref->{_MSC_VER} / 100 ); my $minor = $msvcref->{_MSC_VER} % 100; my $status = $self->_handle_not_msvc($conf, $major, $minor); return 1 if $status; my $msvcversion = $self->_compose_msvcversion($major, $minor); $conf->data->set( msvcversion => $msvcversion ); # Add Visual C++ specifics here if ( $msvcversion >= 14.00 ) { # Version 14 (aka Visual C++ 2005) warns about unsafe, deprecated # functions with the following message. # # This function or variable may be unsafe. Consider using xxx_s instead. # To disable deprecation, use _CRT_SECURE_NO_DEPRECATE. See online help # for details. $conf->data->add( " ", "ccflags", "-D_CRT_SECURE_NO_DEPRECATE" ); } $conf->data->set( noinline => '__declspec(noinline)' ); return 1; } sub _handle_not_msvc { my $self = shift; my ($conf, $major, $minor) = @_; my $status; unless ( defined $major && defined $minor ) { $conf->debug(" (no) "); $self->set_result('no'); $conf->data->set( msvcversion => undef ); $status++; } return $status; } sub _compose_msvcversion { my $self = shift; my ($major, $minor) = @_; my $msvcversion = "$major.$minor"; $self->set_result("yes, $msvcversion"); return $msvcversion; } 1; # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: io_iterator.t000644000765000765 444611715102036 15221 0ustar00bruce000000000000parrot-6.6.0/t/pmc#!perl # Copyright (C) 2006-2007, Parrot Foundation. use strict; use warnings; use lib qw( . lib ../lib ../../lib ); use Test::More; use Parrot::Test tests => 3; =head1 NAME t/pmc/io_iterator.t - test the I/O Iterator PMC described in PDD22 =head1 SYNOPSIS % prove t/pmc/io_iterator.t =head1 DESCRIPTION Tests the I/O Iterator PMC described in PDD22. =cut # L pir_output_is( <<'CODE', <<'OUT', 'new', todo => 'not yet implemented' ); .sub 'test' :main $P99 = 1 # GH #633 replace with io object $P0 = iter $P99 say "ok 1 - $P0 = iter $P1" .end CODE ok 1 - $P0 = iter $P1 OUT # L pir_output_is( <<'CODE', <<'OUT', 'shift', todo => 'not yet implemented: GH #549' ); .sub 'test' :main $P99 = 1 # GH #633 replace with io object $P0 = iter $P99 $S0 = shift $P0 if $S0 == 'abc' goto ok_1 print 'not ' ok_1: say 'ok 1 - $S0 = shift $P1 # success' # GH #549 test more return values, including end of file .end CODE ok 1 - $I0 = shift $P1 # success OUT # L pir_output_is( <<'CODE', <<'OUT', 'get_bool (vtable)', todo => 'not yet implemented' ); .sub 'test' :main $P99 = 1 # GH #633 replace with io object $P0 = iter $P99 # empty i/o object unless $P0 goto ok_1 print 'not ' ok_1: say 'ok 1 - $P0 # empty i/o object returns false' # GH #633 setup i/o object with two lines if $P0 got ok_2 print 'not ' ok_2: say 'ok 2 - $P0 # i/o object with data returns true $S0 = shift $P0 $I0 = length $S0 unless $I0 goto nok_3 if $P0 goto ok_3 nok_3: print 'not ' ok_3: say 'ok 3 - $P0 # i/o object with more data returns true' $S0 = shift $P0 $I0 = length $S0 unless $I0 goto nok_4 unless $P0 goto ok_4 nok_4: print 'not ' ok_4: say 'ok 4 - $P0 # i/o object with no more data returns false' if $P0 goto ok_1 print 'not ' .end CODE ok 1 - $P0 # empty i/o object returns false ok 2 - $P0 # i/o object with data returns true ok 3 - $P0 # i/o object with more data returns true ok 4 - $P0 # i/o object with no more data returns false OUT # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: 002-messages.t000644000765000765 603611567202625 16220 0ustar00bruce000000000000parrot-6.6.0/t/configure#! perl # Copyright (C) 2007, Parrot Foundation. # 002-messages.t use strict; use warnings; use Carp; use Test::More tests => 13; use lib qw( lib ); use Parrot::Configure::Messages qw| print_introduction print_conclusion |; use IO::CaptureOutput qw| capture |; my $parrot_version = '0.4.10'; my $make_version = 'gnu make'; { my ( $rv, $stdout ); capture( sub { $rv = print_introduction($parrot_version); }, \$stdout, ); ok( $rv, "print_introduction() returned true" ); # Following test is definitive. like( $stdout, qr/$parrot_version/, "Message included Parrot version number supplied as argument" ); # Following tests are NOT definitive. They will break if content of # strings printed by function is changed. like( $stdout, qr/Parrot\sVersion/i, "Message included string 'Parrot version'" ); like( $stdout, qr/Configure/i, "Message included string 'Configure'" ); like( $stdout, qr/Copyright/i, "Message included copyright notice" ); } { my ( $rv, $stdout ); my $pseudo_conf = { log => [], }; my $args = {}; capture( sub { $rv = print_conclusion($pseudo_conf, $make_version, $args); }, \$stdout, ); ok( $rv, "print_conclusion() returned true" ); # Following test is definitive. like( $stdout, qr/$make_version/, "Message included make version supplied as argument" ); } { my ( $rv, $stdout, $stderr ); my $pseudo_conf = { log => [], }; my $args = { silent => 1 }; capture( sub { $rv = print_conclusion($pseudo_conf, $make_version, $args); }, \$stdout, \$stderr, ); ok( $rv, "print_conclusion() returned true" ); # Following test is definitive. ok( ! $stdout, "Configure.pl operated silently, as requested" ); } { my ( $rv, $stdout, $stderr ); my $pseudo_conf = { log => [ undef, { step => q{init::manifest} }, ], }; my $args = {}; capture( sub { $rv = print_conclusion($pseudo_conf, $make_version, $args); }, \$stdout, \$stderr, ); ok(! defined $rv, "print_conclusion() returned undefined value" ); ok( ! $stdout, "Because of the error, nothing printed to standard output"); like( $stderr, qr/During configuration the following steps failed:.*init::manifest/s, "Got expected message re configuration step failure" ); } pass("Completed all tests in $0"); ################### DOCUMENTATION ################### =head1 NAME 002-messages.t - test Parrot::Configure::Messages =head1 SYNOPSIS % prove t/configure/components/002-messages.t =head1 DESCRIPTION The files in this directory test functionality used by F. The tests in this file test subroutines exported by Parrot::Configure::Messages. =head1 AUTHOR James E Keenan =head1 SEE ALSO Parrot::Configure::Messages, F. =cut # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: pmc.c000644000765000765 4455212307662657 14324 0ustar00bruce000000000000parrot-6.6.0/src/embed/* Copyright (C) 2010-2014, Parrot Foundation. =head1 NAME src/embed/pmc.c - The Parrot PMC embedding interface =head1 DESCRIPTION This file implements PMC functions of the Parrot embedding interface. =head2 Functions =over 4 =cut */ #include "parrot/parrot.h" #include "parrot/api.h" #include "embed_private.h" /* HEADERIZER HFILE: include/parrot/api.h */ /* =item C Instantiate a new PMC of C using C values PMC and stores the brand new object in C. This function returns a true value if this call is successful and false value otherwise. =cut */ PARROT_API Parrot_Int Parrot_api_pmc_new_from_class(ARGIN(Parrot_PMC interp_pmc), ARGIN(Parrot_PMC class_pmc), ARGIN_NULLOK(Parrot_PMC init), ARGOUT(Parrot_PMC * pmc)) { ASSERT_ARGS(Parrot_api_pmc_new_from_class) EMBED_API_CALLIN(interp_pmc, interp) Parrot_PMC initializer = init ? init : PMCNULL; *pmc = VTABLE_instantiate(interp, class_pmc, initializer); EMBED_API_CALLOUT(interp_pmc, interp) } /* =item C Deserializes the PMC contained in C string and stores it in C. This function returns a true value if this call is successful and false value otherwise. =cut */ PARROT_API Parrot_Int Parrot_api_pmc_deserialize(ARGIN(Parrot_PMC interp_pmc), ARGIN(Parrot_String fpmc), ARGOUT(Parrot_PMC * pmc)) { ASSERT_ARGS(Parrot_api_pmc_deserialize) EMBED_API_CALLIN(interp_pmc, interp) Parrot_pf_verify_image_string(interp, fpmc); *pmc = Parrot_thaw(interp, fpmc); EMBED_API_CALLOUT(interp_pmc, interp); } /* =item C Deserializes the PMC contained in C buffer of C and stores it in C. This function returns a true value if this call is successful and false value otherwise. =cut */ PARROT_API Parrot_Int Parrot_api_pmc_deserialize_bytes(ARGIN(Parrot_PMC interp_pmc), ARGIN(const unsigned char *fpmc), Parrot_Int length, ARGOUT(Parrot_PMC *pmc)) { ASSERT_ARGS(Parrot_api_pmc_deserialize_bytes) EMBED_API_CALLIN(interp_pmc, interp) STRING * const fpmc_str = Parrot_str_new_init(interp, (const char *)fpmc, length, Parrot_binary_encoding_ptr, PObj_external_FLAG); *pmc = Parrot_thaw(interp, fpmc_str); EMBED_API_CALLOUT(interp_pmc, interp); } /* =item C Nullify C PMC. This function returns a true value if this call is successful and false value otherwise. =cut */ PARROT_API Parrot_Int Parrot_api_pmc_null(ARGIN(Parrot_PMC interp_pmc), ARGOUT(Parrot_PMC *pmctonull)) { ASSERT_ARGS(Parrot_api_pmc_null) EMBED_API_CALLIN(interp_pmc, interp) *pmctonull = PMCNULL; EMBED_API_CALLOUT(interp_pmc, interp); } /* =item C Stores an string in C that represents the string value of the PMC. This function returns a true value if this call is successful and false value otherwise. =cut */ PARROT_API Parrot_Int Parrot_api_pmc_get_string(ARGIN(Parrot_PMC interp_pmc), ARGIN(Parrot_PMC pmc), ARGOUT(Parrot_String * str)) { ASSERT_ARGS(Parrot_api_pmc_get_string) EMBED_API_CALLIN(interp_pmc, interp) *str = VTABLE_get_string(interp, pmc); EMBED_API_CALLOUT(interp_pmc, interp) } /* =item C Stores an integer in C that represents the integer value of the PMC. This function returns a true value if this call is successful and false value otherwise. =cut */ PARROT_API Parrot_Int Parrot_api_pmc_get_integer(ARGIN(Parrot_PMC interp_pmc), ARGIN(Parrot_PMC pmc), ARGOUT(Parrot_Int * value)) { ASSERT_ARGS(Parrot_api_pmc_get_integer) EMBED_API_CALLIN(interp_pmc, interp) *value = VTABLE_get_integer(interp, pmc); EMBED_API_CALLOUT(interp_pmc, interp) } /* =item C Stores a float in C that represents the float value of the PMC. This function returns a true value if this call is successful and false value otherwise. =cut */ PARROT_API Parrot_Int Parrot_api_pmc_get_float(ARGIN(Parrot_PMC interp_pmc), ARGIN(Parrot_PMC pmc), ARGOUT(Parrot_Float * value)) { ASSERT_ARGS(Parrot_api_pmc_get_float) EMBED_API_CALLIN(interp_pmc, interp) *value = VTABLE_get_number(interp, pmc); EMBED_API_CALLOUT(interp_pmc, interp) } /* =item C Lookup the value in the aggregate C with the PMC C. Return C<1> on success, C<0> on failure. =cut */ PARROT_API Parrot_Int Parrot_api_pmc_get_keyed(Parrot_PMC interp_pmc, Parrot_PMC pmc, Parrot_PMC key, ARGOUT(Parrot_PMC * value)) { ASSERT_ARGS(Parrot_api_pmc_get_keyed) EMBED_API_CALLIN(interp_pmc, interp) *value = VTABLE_get_pmc_keyed(interp, pmc, key); EMBED_API_CALLOUT(interp_pmc, interp) } /* =item C Stores the integer value of whatever is stored at the element of the C indexed by C. This function returns a true value if this call is successful and false value otherwise. =cut */ PARROT_API Parrot_Int Parrot_api_pmc_get_keyed_int(ARGIN(Parrot_PMC interp_pmc), ARGIN(Parrot_PMC pmc), Parrot_Int key, ARGOUT(Parrot_PMC *value)) { ASSERT_ARGS(Parrot_api_pmc_get_keyed_int) EMBED_API_CALLIN(interp_pmc, interp) *value = VTABLE_get_pmc_keyed_int(interp, pmc, key); EMBED_API_CALLOUT(interp_pmc, interp) } /* =item C Stores the string value of whatever is stored at the element of the C indexed by C. This function returns a true value if this call is successful and false value otherwise. =cut */ PARROT_API Parrot_Int Parrot_api_pmc_get_keyed_string(ARGIN(Parrot_PMC interp_pmc), ARGIN(Parrot_PMC pmc), ARGIN(Parrot_String key), ARGOUT(Parrot_PMC * value)) { ASSERT_ARGS(Parrot_api_pmc_get_keyed_string) EMBED_API_CALLIN(interp_pmc, interp) *value = VTABLE_get_pmc_keyed_str(interp, pmc, key); EMBED_API_CALLOUT(interp_pmc, interp) } /* =item C Sets the string C as C's value. This function returns a true value if this call is successful and false value otherwise. =cut */ PARROT_API Parrot_Int Parrot_api_pmc_set_string(ARGIN(Parrot_PMC interp_pmc), ARGIN(Parrot_PMC pmc), ARGIN(Parrot_String value)) { ASSERT_ARGS(Parrot_api_pmc_set_string) EMBED_API_CALLIN(interp_pmc, interp) VTABLE_set_string_native(interp, pmc, value); EMBED_API_CALLOUT(interp_pmc, interp) } /* =item C Sets the integer C as C's value. This function returns a true value if this call is successful and false value otherwise. =cut */ PARROT_API Parrot_Int Parrot_api_pmc_set_integer(ARGIN(Parrot_PMC interp_pmc), ARGIN(Parrot_PMC pmc), Parrot_Int value) { ASSERT_ARGS(Parrot_api_pmc_set_integer) EMBED_API_CALLIN(interp_pmc, interp) VTABLE_set_integer_native(interp, pmc, value); EMBED_API_CALLOUT(interp_pmc, interp) } /* =item C Sets the float C as the C's value. This function returns a true value if this call is successful and false value otherwise. =cut */ PARROT_API Parrot_Int Parrot_api_pmc_set_float(ARGIN(Parrot_PMC interp_pmc), ARGIN(Parrot_PMC pmc), Parrot_Float value) { ASSERT_ARGS(Parrot_api_pmc_set_float) EMBED_API_CALLIN(interp_pmc, interp) VTABLE_set_number_native(interp, pmc, value); EMBED_API_CALLOUT(interp_pmc, interp) } /* =item C Sets the value in aggregate C using the PMC C. Returns 1 on success, 0 on failure. =cut */ PARROT_API Parrot_Int Parrot_api_pmc_set_keyed(Parrot_PMC interp_pmc, Parrot_PMC pmc, Parrot_PMC key, Parrot_PMC value) { ASSERT_ARGS(Parrot_api_pmc_set_keyed) EMBED_API_CALLIN(interp_pmc, interp) VTABLE_set_pmc_keyed(interp, pmc, key, value); EMBED_API_CALLOUT(interp_pmc, interp) } /* =item C Stets the integer C at the element of the C indexed by C. This function returns a true value if this call is successful and false value otherwise. =cut */ PARROT_API Parrot_Int Parrot_api_pmc_set_keyed_int(ARGIN(Parrot_PMC interp_pmc), ARGIN(Parrot_PMC pmc), Parrot_Int key, ARGIN(Parrot_PMC value)) { ASSERT_ARGS(Parrot_api_pmc_set_keyed_int) EMBED_API_CALLIN(interp_pmc, interp) VTABLE_set_pmc_keyed_int(interp, pmc, key, value); EMBED_API_CALLOUT(interp_pmc, interp) } /* =item C Stets the string C at the element of the C indexed by C. This function returns a true value if this call is successful and false value otherwise. =cut */ PARROT_API Parrot_Int Parrot_api_pmc_set_keyed_string(ARGIN(Parrot_PMC interp_pmc), ARGIN(Parrot_PMC pmc), ARGIN(Parrot_String key), ARGIN(Parrot_PMC value)) { ASSERT_ARGS(Parrot_api_pmc_set_keyed_string) EMBED_API_CALLIN(interp_pmc, interp) VTABLE_set_pmc_keyed_str(interp, pmc, key, value); EMBED_API_CALLOUT(interp_pmc, interp) } /* =item C Wraps the string C into a PMC and stores the results in C. This function returns a true value if this call is successful and false value otherwise. =cut */ PARROT_API Parrot_Int Parrot_api_pmc_box_string(ARGIN(Parrot_PMC interp_pmc), ARGIN(Parrot_String str), ARGOUT(Parrot_PMC * str_pmc)) { ASSERT_ARGS(Parrot_api_pmc_box_string) EMBED_API_CALLIN(interp_pmc, interp) *str_pmc = Parrot_pmc_box_string(interp, str); EMBED_API_CALLOUT(interp_pmc, interp) } /* =item C Wraps the integer C into a PMC and stores the results in C. This function returns a true value if this call is successful and false value otherwise. =cut */ PARROT_API Parrot_Int Parrot_api_pmc_box_integer(Parrot_PMC interp_pmc, Parrot_Int value, ARGOUT(Parrot_PMC * int_pmc)) { ASSERT_ARGS(Parrot_api_pmc_box_integer) EMBED_API_CALLIN(interp_pmc, interp) *int_pmc = Parrot_pmc_box_integer(interp, value); EMBED_API_CALLOUT(interp_pmc, interp) } /* =item C Wraps the float C into a PMC and stores the results in C. This function returns a true value if this call is successful and false value otherwise. =cut */ PARROT_API Parrot_Int Parrot_api_pmc_box_float(Parrot_PMC interp_pmc, Parrot_Float value, ARGOUT(Parrot_PMC * float_pmc)) { ASSERT_ARGS(Parrot_api_pmc_box_float) EMBED_API_CALLIN(interp_pmc, interp) *float_pmc = Parrot_pmc_box_number(interp, value); EMBED_API_CALLOUT(interp_pmc, interp) } /* =item C Push a PMC C onto aggregate PMC C. =cut */ PARROT_API Parrot_Int Parrot_api_pmc_push(Parrot_PMC interp_pmc, Parrot_PMC pmc, Parrot_PMC item) { ASSERT_ARGS(Parrot_api_pmc_push) EMBED_API_CALLIN(interp_pmc, interp) VTABLE_push_pmc(interp, pmc, item); EMBED_API_CALLOUT(interp_pmc, interp) } /* =item C Adds a C to scheduler's list of handlers. This function returns a true value if this call is successful and false value otherwise. =cut */ /*PARROT_API Parrot_Int Parrot_api_add_exception_handler(ARGIN(Parrot_PMC interp_pmc), ARGIN(Parrot_PMC handler)) { ASSERT_ARGS(Parrot_api_add_exception_handler) EMBED_API_CALLIN(interp_pmc, interp) Parrot_cx_add_handler(interp, handler); EMBED_API_CALLOUT(interp_pmc, interp) }*/ /* =item C Invokes the C with C PMC in which parameters are stored. This function returns a true value if this call is successful and false value otherwise. =cut */ PARROT_API Parrot_Int Parrot_api_pmc_invoke(ARGIN(Parrot_PMC interp_pmc), ARGIN(Parrot_PMC sub), ARGIN(Parrot_PMC signature)) { ASSERT_ARGS(Parrot_api_pmc_invoke) EMBED_API_CALLIN(interp_pmc, interp) PMC * const old_call_obj = Parrot_pcc_get_signature(interp, CURRENT_CONTEXT(interp)); Parrot_pcc_invoke_from_sig_object(interp, sub, signature); Parrot_pcc_set_signature(interp, CURRENT_CONTEXT(interp), old_call_obj); EMBED_API_CALLOUT(interp_pmc, interp) } /* =item C Wraps an C string array of C size into a PMC array and stores it in C. This function returns a true value if this call is successful and false value otherwise. =cut */ PARROT_API Parrot_Int Parrot_api_pmc_wrap_string_array(ARGIN(Parrot_PMC interp_pmc), Parrot_Int argc, ARGIN(const char ** argv), ARGOUT(Parrot_PMC * args)) { ASSERT_ARGS(Parrot_api_pmc_wrap_string_array) EMBED_API_CALLIN(interp_pmc, interp) *args = Parrot_pmc_box_c_string_array(interp, argc, argv); EMBED_API_CALLOUT(interp_pmc, interp) } /* =item C Lookup the PMC class named C and stores it in the C PMC. This function returns a true value if this call is successful and false value otherwise. =cut */ PARROT_API Parrot_Int Parrot_api_pmc_get_class(ARGIN(Parrot_PMC interp_pmc), ARGIN(Parrot_PMC key), ARGOUT(Parrot_PMC *class_pmc)) { ASSERT_ARGS(Parrot_api_pmc_get_class) EMBED_API_CALLIN(interp_pmc, interp) *class_pmc = Parrot_oo_get_class(interp, key); EMBED_API_CALLOUT(interp_pmc, interp); } /* =item C Find a method PMC by name on the given object PMC. =cut */ PARROT_API Parrot_Int Parrot_api_pmc_find_method(Parrot_PMC interp_pmc, Parrot_PMC object, Parrot_String name, ARGOUT(Parrot_PMC *method)) { ASSERT_ARGS(Parrot_api_pmc_find_method) EMBED_API_CALLIN(interp_pmc, interp); *method = VTABLE_find_method(interp, object, name); EMBED_API_CALLOUT(interp_pmc, interp); } /* =item C Serialize a PMC into an archived String format. Also known as freezing or pickling. =cut */ PARROT_API Parrot_Int Parrot_api_pmc_serialize(Parrot_PMC interp_pmc, Parrot_PMC object, ARGOUT(Parrot_String *frozen)) { ASSERT_ARGS(Parrot_api_pmc_serialize) EMBED_API_CALLIN(interp_pmc, interp); *frozen = Parrot_freeze(interp, object); EMBED_API_CALLOUT(interp_pmc, interp); } /* =item C Force the alive status of a PMC with respect to Parrot's Garbage collector. if C is non-zero, the PMC becomes immune to garbage collection. This is important if you have a reference to a PMC which is used by places that the GC does not search. If C is zero, the PMC loses its protection and can be reclaimed by the GC like normal if it falls out of scope. =cut */ PARROT_API Parrot_Int Parrot_api_pmc_keep_alive(Parrot_PMC interp_pmc, Parrot_PMC pmc, Parrot_Int alive) { ASSERT_ARGS(Parrot_api_pmc_keep_alive) EMBED_API_CALLIN(interp_pmc, interp); if (alive) Parrot_pmc_gc_register(interp, pmc); else Parrot_pmc_gc_unregister(interp, pmc); EMBED_API_CALLOUT(interp_pmc, interp); } /* =item C Convenience API to create a new CallContext PMC, suitable for invoking a Sub. =cut */ PARROT_API Parrot_Int Parrot_api_pmc_new_call_object(Parrot_PMC interp_pmc, ARGOUT(Parrot_PMC *cc)) { ASSERT_ARGS(Parrot_api_pmc_new_call_object) EMBED_API_CALLIN(interp_pmc, interp); *cc = Parrot_pcc_new_call_object(interp); EMBED_API_CALLOUT(interp_pmc, interp); } /* =item C Convenience API to setup a CallContext with a signature and arguments as a single variadic argument list. =cut */ PARROT_API Parrot_Int Parrot_api_pmc_setup_signature(Parrot_PMC interp_pmc, Parrot_PMC callcontext, ARGIN(const char * const signature), ...) { ASSERT_ARGS(Parrot_api_pmc_setup_signature) va_list args; EMBED_API_CALLIN(interp_pmc, interp); if (PMC_IS_NULL(callcontext)) Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, "You must provide a CallContext to Parrot_api_pmc_setup_signature"); if (!signature) Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, "You must provide a signature to Parrot_api_pmc_setup_signature"); va_start(args, signature); callcontext = Parrot_pcc_build_call_from_varargs(interp, callcontext, signature, &args); va_end(args); EMBED_API_CALLOUT(interp_pmc, interp); } /* =back =cut */ /* * Local variables: * c-file-style: "parrot" * End: * vim: expandtab shiftwidth=4 cinoptions='\:2=2' : */ mime_base64.t000644000765000765 2600512101554067 15701 0ustar00bruce000000000000parrot-6.6.0/t/library#!./parrot # Copyright (C) 2006-2012, Parrot Foundation. =head1 NAME t/library/mime_base64.t - MIME::Base64 tests =head1 SYNOPSIS % prove t/library/mime_base64.t =head1 DESCRIPTION This file contains various tests related to base64 encoding and decoding. Some test cases were taken from base64.t of MIME::Base64 from Perl 5. =cut .sub test :main load_bytecode "dumper.pbc" load_bytecode 'Test/More.pbc' load_bytecode 'MIME/Base64.pbc' load_bytecode 'PGE.pbc' load_bytecode 'PGE/Util.pbc' load_language 'data_json' .local pmc plan, is, ok, lives_ok plan = get_hll_global [ 'Test'; 'More' ], 'plan' is = get_hll_global [ 'Test'; 'More' ], 'is' ok = get_hll_global [ 'Test'; 'More' ], 'ok' plan(551) .local pmc json json = compreg 'data_json' .local pmc encode_decode_tests, decode_tests encode_decode_tests = json.'compile'( <<'END_JSON' ) [ ["Hello, World!\n","SGVsbG8sIFdvcmxkIQo="], ["aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", "YWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFh\nYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYQ=="], ["\u0000","AA=="], ["\u0001","AQ=="], ["\u0002","Ag=="], ["\u0003","Aw=="], ["\u0004","BA=="], ["\u0005","BQ=="], ["\u0006","Bg=="], ["\u0007","Bw=="], ["\b","CA=="], ["\t","CQ=="], ["\n","Cg=="], ["\u000b","Cw=="], ["\f","DA=="], ["\r","DQ=="], ["\u000e","Dg=="], ["\u000f","Dw=="], ["\u0010","EA=="], ["\u0011","EQ=="], ["\u0012","Eg=="], ["\u0013","Ew=="], ["\u0014","FA=="], ["\u0015","FQ=="], ["\u0016","Fg=="], ["\u0017","Fw=="], ["\u0018","GA=="], ["\u0019","GQ=="], ["\u001a","Gg=="], ["\u001b","Gw=="], ["\u001c","HA=="], ["\u001d","HQ=="], ["\u001e","Hg=="], ["\u001f","Hw=="], [" ","IA=="], ["!","IQ=="], ["\"","Ig=="], ["#","Iw=="], ["$","JA=="], ["%","JQ=="], ["&","Jg=="], ["'","Jw=="], ["(","KA=="], [")","KQ=="], ["*","Kg=="], ["+","Kw=="], [",","LA=="], ["-","LQ=="], [".","Lg=="], ["/","Lw=="], ["0","MA=="], ["1","MQ=="], ["2","Mg=="], ["3","Mw=="], ["4","NA=="], ["5","NQ=="], ["6","Ng=="], ["7","Nw=="], ["8","OA=="], ["9","OQ=="], [":","Og=="], [";","Ow=="], ["<","PA=="], ["=","PQ=="], [">","Pg=="], ["?","Pw=="], ["@","QA=="], ["A","QQ=="], ["B","Qg=="], ["C","Qw=="], ["D","RA=="], ["E","RQ=="], ["F","Rg=="], ["G","Rw=="], ["H","SA=="], ["I","SQ=="], ["J","Sg=="], ["K","Sw=="], ["L","TA=="], ["M","TQ=="], ["N","Tg=="], ["O","Tw=="], ["P","UA=="], ["Q","UQ=="], ["R","Ug=="], ["S","Uw=="], ["T","VA=="], ["U","VQ=="], ["V","Vg=="], ["W","Vw=="], ["X","WA=="], ["Y","WQ=="], ["Z","Wg=="], ["[","Ww=="], ["\\","XA=="], ["]","XQ=="], ["^","Xg=="], ["_","Xw=="], ["`","YA=="], ["a","YQ=="], ["b","Yg=="], ["c","Yw=="], ["d","ZA=="], ["e","ZQ=="], ["f","Zg=="], ["g","Zw=="], ["h","aA=="], ["i","aQ=="], ["j","ag=="], ["k","aw=="], ["l","bA=="], ["m","bQ=="], ["n","bg=="], ["o","bw=="], ["p","cA=="], ["q","cQ=="], ["r","cg=="], ["s","cw=="], ["t","dA=="], ["u","dQ=="], ["v","dg=="], ["w","dw=="], ["x","eA=="], ["y","eQ=="], ["z","eg=="], ["{","ew=="], ["|","fA=="], ["}","fQ=="], ["~","fg=="], ["\u007f","fw=="], ["\u0080","woA="], ["\u0081","woE="], ["\u0082","woI="], ["\u0083","woM="], ["\u0084","woQ="], ["\u0085","woU="], ["\u0086","woY="], ["\u0087","woc="], ["\u0088","wog="], ["\u0089","wok="], ["\u008a","woo="], ["\u008b","wos="], ["\u008c","wow="], ["\u008d","wo0="], ["\u008e","wo4="], ["\u008f","wo8="], ["\u0090","wpA="], ["\u0091","wpE="], ["\u0092","wpI="], ["\u0093","wpM="], ["\u0094","wpQ="], ["\u0095","wpU="], ["\u0096","wpY="], ["\u0097","wpc="], ["\u0098","wpg="], ["\u0099","wpk="], ["\u009a","wpo="], ["\u009b","wps="], ["\u009c","wpw="], ["\u009d","wp0="], ["\u009e","wp4="], ["\u009f","wp8="], ["\u00a0","wqA="], ["\u00a1","wqE="], ["\u00a2","wqI="], ["\u00a3","wqM="], ["\u00a4","wqQ="], ["\u00a5","wqU="], ["\u00a6","wqY="], ["\u00a7","wqc="], ["\u00a8","wqg="], ["\u00a9","wqk="], ["\u00aa","wqo="], ["\u00ab","wqs="], ["\u00ac","wqw="], ["\u00ad","wq0="], ["\u00ae","wq4="], ["\u00af","wq8="], ["\u00b0","wrA="], ["\u00b1","wrE="], ["\u00b2","wrI="], ["\u00b3","wrM="], ["\u00b4","wrQ="], ["\u00b5","wrU="], ["\u00b6","wrY="], ["\u00b7","wrc="], ["\u00b8","wrg="], ["\u00b9","wrk="], ["\u00ba","wro="], ["\u00bb","wrs="], ["\u00bc","wrw="], ["\u00bd","wr0="], ["\u00be","wr4="], ["\u00bf","wr8="], ["\u00c0","w4A="], ["\u00c1","w4E="], ["\u00c2","w4I="], ["\u00c3","w4M="], ["\u00c4","w4Q="], ["\u00c5","w4U="], ["\u00c6","w4Y="], ["\u00c7","w4c="], ["\u00c8","w4g="], ["\u00c9","w4k="], ["\u00ca","w4o="], ["\u00cb","w4s="], ["\u00cc","w4w="], ["\u00cd","w40="], ["\u00ce","w44="], ["\u00cf","w48="], ["\u00d0","w5A="], ["\u00d1","w5E="], ["\u00d2","w5I="], ["\u00d3","w5M="], ["\u00d4","w5Q="], ["\u00d5","w5U="], ["\u00d6","w5Y="], ["\u00d7","w5c="], ["\u00d8","w5g="], ["\u00d9","w5k="], ["\u00da","w5o="], ["\u00db","w5s="], ["\u00dc","w5w="], ["\u00dd","w50="], ["\u00de","w54="], ["\u00df","w58="], ["\u00e0","w6A="], ["\u00e1","w6E="], ["\u00e2","w6I="], ["\u00e3","w6M="], ["\u00e4","w6Q="], ["\u00e5","w6U="], ["\u00e6","w6Y="], ["\u00e7","w6c="], ["\u00e8","w6g="], ["\u00e9","w6k="], ["\u00ea","w6o="], ["\u00eb","w6s="], ["\u00ec","w6w="], ["\u00ed","w60="], ["\u00ee","w64="], ["\u00ef","w68="], ["\u00f0","w7A="], ["\u00f1","w7E="], ["\u00f2","w7I="], ["\u00f3","w7M="], ["\u00f4","w7Q="], ["\u00f5","w7U="], ["\u00f6","w7Y="], ["\u00f7","w7c="], ["\u00f8","w7g="], ["\u00f9","w7k="], ["\u00fa","w7o="], ["\u00fb","w7s="], ["\u00fc","w7w="], ["\u00fd","w70="], ["\u00fe","w74="], ["\u00ff","w78="], ["\u0000\u00ff","AMO/"], ["\u00ff\u0000","w78A"], ["\u0000\u0000\u0000","AAAA"], ["",""], ["a","YQ=="], ["aa","YWE="], ["aaa","YWFh"], ["aaa","YWFh"], ["aaa","YWFh"], ["aaa","YWFh"], ["Aladdin:open sesame","QWxhZGRpbjpvcGVuIHNlc2FtZQ=="], ["Multipurpose Internet Mail Extensions: The Base64 Content-Transfer-Encoding is designed to represent sequences of octets in a form that is not humanly readable. ", "TXVsdGlwdXJwb3NlIEludGVybmV0IE1haWwgRXh0ZW5zaW9uczogVGhlIEJhc2U2NCBDb250ZW50\nLVRyYW5zZmVyLUVuY29kaW5nIGlzIGRlc2lnbmVkIHRvIHJlcHJlc2VudCBzZXF1ZW5jZXMgb2Yg\nb2N0ZXRzIGluIGEgZm9ybSB0aGF0IGlzIG5vdCBodW1hbmx5IHJlYWRhYmxlLiA="] ] END_JSON decode_tests = json.'compile'( <<'END_JSON' ) [ ["YWE=","aa"], [" YWE=","aa"], ["Y WE=","aa"], ["YWE= ","aa"], ["Y\nW\r\nE=","aa"], ["YWE=====","aa"], ["YWE","aa"], ["YWFh====","aaa"], ["YQ","a"], ["",""] ] END_JSON # TODO: These decoding tests seem to cause weird output # ["Y",""], # ["x==",""], .local int count count = 0 .local pmc test_iterator, test_case .local string plain, base64, comment, comment_count, enc, esc_plain encode_decode_tests = encode_decode_tests() test_iterator = iter encode_decode_tests enc_dec_loop: unless test_iterator goto enc_dec_loop_end test_case = shift test_iterator plain = shift test_case base64 = shift test_case comment = 'encode' comment_count = count $I0 = encoding plain enc = encodingname $I0 esc_plain = escape plain comment = concat comment, comment_count comment = concat comment, " " comment = concat comment, enc comment = concat comment, ":\"" comment = concat comment, esc_plain comment = concat comment, "\"" test_encode( plain, base64, comment ) comment = 'decode' comment_count = count comment = concat comment, comment_count test_decode( plain, base64, comment ) inc count goto enc_dec_loop enc_dec_loop_end: decode_tests = decode_tests() test_iterator = iter decode_tests dec_loop: unless test_iterator goto dec_loop_end test_case = shift test_iterator base64 = shift test_case plain = shift test_case comment = 'decode' comment_count = count comment = concat comment, comment_count test_decode( plain, base64, comment ) inc count goto dec_loop dec_loop_end: gh813_base64_utf8() .end .sub gh813_base64_utf8 .local pmc lives_ok lives_ok = get_hll_global [ 'Test'; 'More' ], 'lives_ok' lives_ok(<<'CODE', 'enc_sub("\x{203e}") # Github issue #813') .sub foo .local pmc enc_sub enc_sub = get_global [ "MIME"; "Base64" ], 'encode_base64' .local string result_encode result_encode = enc_sub(utf8:"\x{203e}") .end CODE .end .sub test_encode .param string plain .param string base64 .param string comment .local pmc enc_sub enc_sub = get_global [ "MIME"; "Base64" ], 'encode_base64' .local pmc is is = get_hll_global [ 'Test'; 'More' ], 'is' .local string result_encode result_encode = enc_sub( plain ) is( result_encode, base64, comment ) .end .sub test_decode .param string plain .param string base64 .param string comment .include "iglobals.pasm" .local pmc interp interp = getinterp .local pmc config config = interp[.IGLOBALS_CONFIG_HASH] .local int has_icu has_icu = config['has_icu'] .local int bigendian bigendian = config['bigendian'] .local pmc dec_sub dec_sub = get_global [ "MIME"; "Base64" ], 'decode_base64' .local pmc is, skip is = get_hll_global [ 'Test'; 'More' ], 'is' skip = get_hll_global [ 'Test'; 'More' ], 'skip' $S0 = 'AAAA' ne base64, $S0, CONT_TEST ## Note: also fails on solaris little-endian skip(1, '\0\0\0 fails to compare for unknown reasons GH #855') goto END unless bigendian goto CONT_TEST skip(1, 'multi-byte codepoint test in big-endian') goto END CONT_TEST: .local string decode, result_decode .local string enc, enc1 $I0 = encoding plain enc = encodingname $I0 if $I0 > 2 goto DEC_ENC # ascii, latin1 decode = dec_sub( base64 ) decode = trans_encoding decode, $I0 goto DEC_2 DEC_ENC: decode = dec_sub( base64, enc ) DEC_2: $I1 = encoding decode enc1 = encodingname $I1 comment = concat comment, " " comment = concat comment, enc1 comment = concat comment, " <-" comment = concat comment, enc .local string plain_norm, result_norm if has_icu goto HAS_ICU is( decode, plain, comment ) goto END HAS_ICU: result_norm = compose decode plain_norm = compose plain is( result_norm, plain_norm, comment ) END: .end =head1 AUTHOR Bernhard Schmalhofer and Reini Urban. =cut # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: ptrbuf.pmc000644000765000765 211512356767111 15047 0ustar00bruce000000000000parrot-6.6.0/src/pmc/* Copyright (C) 2011-2014, Parrot Foundation. =head1 NAME src/pmc/ptrbuf.pmc - PtrBuf PMC =head1 DESCRIPTION C is a pointer to a buffer. No affordances for memory management have been made. It has two things - a pointer and a size. =head2 VTABLEs =over 4 =cut */ /* HEADERIZER HFILE: none */ /* HEADERIZER BEGIN: static */ /* HEADERIZER END: static */ pmclass PtrBuf extends Ptr auto_attrs { ATTR UINTVAL size; /* =item C C is always C and manages its own attributes. Let C know about this. =cut */ VTABLE void init() { PTR_FAT_SET(INTERP, SELF); } /* =item C =item C Get and set the buffer size. =cut */ VTABLE INTVAL get_integer() :no_wb { INTVAL i; GET_ATTR_size(INTERP, SELF, i); return i; } VTABLE void set_integer_native(INTVAL i) { SET_ATTR_size(INTERP, SELF, i); } } /* =back =cut */ /* * Local variables: * c-file-style: "parrot" * End: * vim: expandtab shiftwidth=4 cinoptions='\:2=2' : */ ch11_directive_reference.pod000644000765000765 621211533177634 21777 0ustar00bruce000000000000parrot-6.6.0/docs/book/draft=pod =head1 Directive Reference Z X This is a summary of PIR directives. Directives are preprocessed by the Parrot interpreter. Since PIR and PASM run on the same interpreter, many of the directives listed here are also valid in PASM code. =head3 .arg X<.arg directive> .arg R pass a value to a subroutine according to PCC. =head3 .const X<.const directive> .const RR = R Define a named constant. =head3 .macro_const X<.macro_const directive> .macro_const RR Define a named macro that expands to a given value. Macros are called as directives, i.e. .R (PASM code only). =head3 .emit X<.emit directive> .emit Define a block of PASM code. Always paired with C<.eom>. =head3 .end X<.end directive> .end End a subroutine. Always paired with C<.sub>. =head3 .endm X<.endm directive> .endm End a macro definition. Always paired with C<.macro>. =head3 .eom X<.eom directive> .eom End a block of PASM code. Always paired with C<.emit>. =head3 .flatten_arg X<.flatten_arg directive> .flatten_arg R Flatten the passed array PMC and provide args for PCC calls. =head3 .globalconst X<.globalconst directive> .globalconst RR = R Define a named, file visible constant. =head3 .include X<.include directive> .include " R " Include the contents of an external file by inserting it in place. =head3 .invocant X<.invocant directive> .invocant R Set the invocant for a method call. =head3 .local X<.local directive> .local RR Define a local named variable. =head3 .macro X<.macro directive> .macro R (R) Define a named macro with a list of parameters. The macro is called as .R(R,R,...). Always paired with C<.endm>. =head3 .namespace X<.namespace directive> .namespace R< [ "namespace" ] > Define a namespace. =head3 .param X<.param directive> .param R .param RR Define a subroutine parameter. =head3 .begin_call X<.begin_call directive> Start a call sequence. Always paired with C<.end_call> =head3 .begin_return X<.begin_return directive> Start a return sequence. Always paired with C<.end_return> =head3 .begin_yield X<.begin_yield directive> Start a return of a coroutine sequence. Always paired with C<.end_yield> =head3 .call X<.call directive> .call R .call R, R Create a subroutine call. =head3 .pcc_sub X<.pcc_sub directive> .pcc_sub R<_LABEL> Create a symbol entry for subroutine at the _LABEL. This directive is for PASM code only. =head3 .result X<.result directive> .result R Get a return value according to PCC. =head3 .return X<.return directive> .return R Return a value to the calling subroutine according to PCC. =head3 .sub X<.sub directive> .sub R Define a subroutine. Always paired with C<.end>. Names begin with "C<_>" by convention. =head3 .sym X<.sym directive> .sym R R Same as C<.local>. =cut # Local variables: # c-file-style: "parrot" # End: # vim: expandtab shiftwidth=4: nci_thunk_gen.pir000644000765000765 7705612101554067 16773 0ustar00bruce000000000000parrot-6.6.0/tools/dev# Copyright (C) 2010-2012, Parrot Foundation. =head1 NAME tools/dev/nci_thunk_gen.pir - Build up native call thunk routines =head1 SYNOPSIS % ./parrot tools/dev/nci_thunk_gen.pir -o src/nci/extra_thunks.c [][#] ... Empty lines and lines containing only whitespace or comment are ignored. The types specifiers are documented in F. =head1 SEE ALSO F. F. =cut .loadlib 'bit_ops' .include 'hash_key_type.pasm' .include 'datatypes.pasm' .macro_const VERSION 0.02 .macro_const SIG_TABLE_GLOBAL_NAME 'signature_table' .macro_const OPTS_GLOBAL_NAME 'options' .sub 'main' :main .param pmc argv # initialize global variables 'gen_sigtable'() 'get_options'(argv) .local string targ targ = 'read_from_opts'('target') .local pmc sigs sigs = 'read_sigs'() $S0 = 'read_from_opts'('output') $P0 = new ['FileHandle'] $P0.'open'($S0, 'w') $P1 = getinterp $P1.'stdout_handle'($P0) if targ == 'head' goto get_targ if targ == 'thunks' goto get_targ if targ == 'loader' goto get_targ if targ == 'loader-dynext' goto get_dynext_loader if targ == 'coda' goto get_targ if targ == 'all' goto all if targ == 'all-dynext' goto all_dynext if targ == 'names' goto names if targ == 'signatures' goto signatures # unknown target $S0 = 'sprintf'("Unknown target type '%s'", targ) die $S0 all: $S0 = 'get_head'(sigs) say $S0 .local string core core = 'read_from_opts'('core') unless core goto end_core # core decl already in include/parrot/nci.h $S0 = 'get_loader_decl'(sigs) print $S0 say ";" end_core: $S0 = 'end_head'(sigs) say $S0 $S0 = 'get_thunks'(sigs) say $S0 $S0 = 'get_loader'(sigs) say $S0 $S0 = 'get_coda'(sigs) say $S0 exit 0 all_dynext: $S0 = 'get_head'(sigs) say $S0 $S0 = 'get_dynext_loader_decl'(sigs) print $S0 say ";" $S0 = 'end_head'(sigs) say $S0 $S0 = 'get_thunks'(sigs) say $S0 $S0 = 'get_dynext_loader'(sigs) say $S0 $S0 = 'get_coda'(sigs) say $S0 exit 0 get_dynext_loader: $S0 = 'get_dynext_loader'(sigs) say $S0 exit 0 get_targ: $S0 = concat 'get_', targ $P0 = get_global $S0 $S1 = $P0(sigs) say $S1 exit 0 names: die "names not yet implemented" signatures: die "signatures not yet implemented" .end # getopt stuff {{{ .macro_const OUTPUT 'output' .macro_const THUNK_STORAGE_CLASS 'thunk-storage-class' .macro_const THUNK_NAME_PROTO 'thunk-name-proto' .macro_const LOADER_STORAGE_CLASS 'loader-storage-class' .macro_const LOADER_NAME 'loader-name' .macro_const CORE 'core' .macro_const NO_WARN_DUPS 'no-warn-dups' .sub 'get_options' .param pmc argv load_bytecode 'Getopt/Obj.pbc' .local pmc getopt getopt = new ['Getopt';'Obj'] push getopt, 'help|h' push getopt, 'version|v' push getopt, 'no-warn-dups|f' push getopt, 'core' push getopt, 'dynext' push getopt, 'output|o=s' push getopt, 'target=s' push getopt, 'thunk-storage-class=s' push getopt, 'thunk-name-proto=s' push getopt, 'loader-storage-class=s' push getopt, 'loader-name=s' .local string prog_name prog_name = shift argv .local pmc opt opt = getopt.'get_options'(argv) $I0 = opt['help'] if $I0 goto print_help $I0 = opt['version'] if $I0 goto print_version 'fixup_opts'(opt) set_global .OPTS_GLOBAL_NAME, opt .return() print_help: 'usage'(prog_name) print_version: 'version'(prog_name) .end .sub 'usage' .param string prog_name print prog_name say ' - Parrot NCI thunk library creation utility' say <<'USAGE' Creates a C file of routines suitable for use as Parrot NCI thunks. Usage ./parrot nci_thunk_gen.pir [options] -o output_c_file.c specify output file to use. --target select what to output (valid options are 'head', 'thunks', 'loader', 'loader-dynext', 'coda', 'all', 'all-dynext', 'names', and 'signatures'). Default value is 'all' --thunk-storage-class set the storage class used for the thunks. Default value is 'static'. --thunk-name-proto set the prototype used for the thunk function names. Must be a printf format with arity 1. Default value is 'pcf_%s' --loader-storage-class set the storage class used for the loader function. Default value is none. --loader-name set the name used for the loader function. Default value is 'Parrot_load_nci_thunks'. USAGE exit 0 .end .sub 'version' .param string prog_name print prog_name print ' version ' say .VERSION exit 0 .end .sub 'fixup_opts' .param pmc opts $I0 = defined opts['no-warn-dups'] if $I0 goto end_no_warn_dups opts['no-warn-dups'] = '' end_no_warn_dups: $I0 = defined opts['core'] if $I0 goto in_core opts['core'] = '' goto end_core in_core: opts['core'] = 'true' end_core: $I0 = defined opts['dynext'] if $I0 goto is_dynext opts['dynext'] = '' goto end_dynext is_dynext: $I0 = defined opts['target'] if $I0 goto end_dynext_target opts['target'] = 'all-dynext' end_dynext_target: $I0 = defined opts['loader-storage-class'] if $I0 goto end_dynext_loader_storage_class opts['loader-storage-class'] = 'PARROT_DYNEXT_EXPORT' end_dynext_loader_storage_class: $I0 = defined opts['loader-name'] if $I0 goto end_dynext_loader_name $S0 = opts['output'] ($S0, $S1, $S0) = 'file_basename'($S0, '.c') $S0 = 'sprintf'('Parrot_lib_%s_init', $S1) opts['loader-name'] = $S0 end_dynext_loader_name: end_dynext: $I0 = defined opts['target'] if $I0 goto end_target opts['target'] = 'all' end_target: $I0 = defined opts['thunk-storage-class'] if $I0 goto end_thunk_storage_class opts['thunk-storage-class'] = 'static' end_thunk_storage_class: $I0 = defined opts['thunk-name-proto'] if $I0 goto end_thunk_name_proto opts['thunk-name-proto'] = 'pcf_%s' end_thunk_name_proto: $S0 = opts['thunk-name-proto'] $I0 = 'printf_arity'($S0) if $I0 == 1 goto end_thunk_name_proto_printf_arity 'sprintf'("Provided proto for 'thunk-name-proto' is of incorrect arity %i (expected 1)", $I0) die $S0 end_thunk_name_proto_printf_arity: $I0 = defined opts['loader-storage-class'] if $I0 goto end_loader_storage_class opts['loader-storage-class'] = '' end_loader_storage_class: $I0 = defined opts['loader-name'] if $I0 goto end_loader_name opts['loader-name'] = 'Parrot_load_nci_thunks' end_loader_name: .end .sub 'read_from_opts' .param string key .local pmc opts opts = get_global .OPTS_GLOBAL_NAME $I0 = defined opts[key] unless $I0 goto not_present $S0 = opts[key] .return ($S0) not_present: $S0 = 'sprintf'("Parameter '%s' required but not provided", key) die $S0 .end # }}} # get_{head,thunks,loader,dynext_loader,coda} {{{ .sub 'get_head' .param pmc ignored :slurpy .local string in_core in_core = 'read_from_opts'(.CORE) .local string ext_defn ext_defn = '' if in_core goto end_ext_defn ext_defn = '#define PARROT_IN_EXTENSION' end_ext_defn: .local string c_file c_file = 'read_from_opts'(.OUTPUT) .local string str_file ($S0, str_file, $S0) = 'file_basename'(c_file, '.c') str_file = concat str_file, '.str' .local string head head = 'sprintf'(<<'HEAD', c_file, ext_defn, str_file) /* ex: set ro ft=c: * !!!!!!! DO NOT EDIT THIS FILE !!!!!!! * * This file is generated automatically by tools/dev/nci_thunk_gen.pir * * Any changes made here will be lost! * */ /* %s * Copyright (C) 2010-2012, Parrot Foundation. * Overview: * Native Call Interface routines. * Code to call C from parrot. */ %s #include "parrot/parrot.h" #include "parrot/nci.h" #include "pmc/pmc_nci.h" #ifdef PARROT_IN_EXTENSION /* external libraries can't have strings statically compiled into parrot */ # define CONST_STRING(i, s) Parrot_str_new_constant((i), (s)) #else # include "%s" #endif /* HEADERIZER HFILE: none */ HEAD .return (head) .end .sub 'end_head' .param pmc ignored :slurpy .local string head head = 'sprintf'(<<'HEAD') /* HEADERIZER STOP */ /* All our static functions that call in various ways. */ HEAD .return (head) .end .sub 'get_thunks' .param pmc sigs .local string code .local int i, n code = '' i = 0 n = sigs loop: if i >= n goto end_loop .local pmc sig sig = sigs[i] $S0 = 'sig_to_fn_code'(sig) code = concat code, $S0 inc i goto loop end_loop: .return (code) .end .sub 'get_loader' .param pmc sigs $S0 = 'get_loader_decl'(sigs) $S1 = 'get_loader_body'(sigs) $S2 = 'sprintf'(<<'LOADER', $S0, $S1) %s { %s } LOADER .return ($S2) .end .sub 'get_loader_decl' .param pmc sigs $S0 = 'read_from_opts'(.LOADER_STORAGE_CLASS) $S1 = 'read_from_opts'(.LOADER_NAME) $S2 = 'sprintf'("%s void\n%s(PARROT_INTERP)", $S0, $S1) .return ($S2) .end .sub 'get_dynext_loader' .param pmc sigs $S0 = 'get_dynext_loader_decl'(sigs) $S1 = 'get_loader_body'(sigs) $S2 = 'sprintf'(<<'LOADER', $S0, $S1) %s { %s } LOADER .return ($S2) .end .sub 'get_dynext_loader_decl' .param pmc sigs $S0 = 'read_from_opts'(.LOADER_STORAGE_CLASS) $S1 = 'read_from_opts'(.LOADER_NAME) $S2 = 'sprintf'("%s void\n%s(PARROT_INTERP, SHIM(PMC *lib))", $S0, $S1) .return ($S2) .end .sub 'get_loader_body' .param pmc sigs .local string code code = 'sprintf'(<<'HEADER', $S0, $S1) PMC * const iglobals = interp->iglobals; PMC *nci_funcs; PMC *temp_pmc; PARROT_ASSERT(!(PMC_IS_NULL(iglobals))); nci_funcs = VTABLE_get_pmc_keyed_int(interp, iglobals, IGLOBALS_NCI_FUNCS); PARROT_ASSERT(!(PMC_IS_NULL(nci_funcs))); HEADER .local int i, n i = 0 n = sigs loop: unless i < n goto end_loop .local pmc sig sig = shift sigs .local string fn_name fn_name = 'sig_to_fn_name'(sig) .local pmc sb sb = new ['StringBuilder'] push sb, "{ " $I0 = 0 $I1 = elements sig array_loop: unless $I0 < $I1 goto end_array_loop $I2 = sig[$I0] $S1 = $I2 push sb, $S1 push sb, ", " inc $I0 goto array_loop end_array_loop: push sb, "}" $S0 = sb $S0 = 'sprintf'(<<'TEMPLATE', $I1, $S0, fn_name) { const int n = %s; static const int sig[] = %s; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)%s); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } TEMPLATE code = concat code, $S0 inc i goto loop end_loop: .return (code) .end .sub 'get_coda' .param pmc ignored :slurpy .return (<<'CODA') /* * Local variables: * c-file-style: "parrot" * End: * vim: expandtab shiftwidth=4 cinoptions='\:2=2' : */ CODA .end # }}} # sig_to_* {{{ .sub 'sig_to_fn_code' .param pmc sig .local string fn_decl fn_decl = 'sig_to_fn_decl'(sig) .local string var_decls var_decls = 'sig_to_var_decls'(sig) .local string preamble preamble = 'sig_to_preamble'(sig) .local string call call = 'sig_to_call'(sig) .local string postamble postamble = 'sig_to_postamble'(sig) .local string fn_code fn_code = 'sprintf'("%s{\n%s%s%s%s}\n", fn_decl, var_decls, preamble, call, postamble) .return (fn_code) .end .sub 'sig_to_postamble' .param pmc sig .local pmc postamble, pcc_sig, pcc_retv postamble = new ['ResizableStringArray'] pcc_sig = new ['ResizableStringArray'] pcc_retv = new ['ResizableStringArray'] .local int i, n, sig_elt i = 0 n = elements sig loop: unless i < n goto end_loop sig_elt = sig[i] if sig_elt == .DATATYPE_VOID goto next $I1 = iseq i, 0 $I2 = band sig_elt, .DATATYPE_REF_FLAG $I3 = or $I1, $I2 unless $I3 goto next $P0 = 'map_from_sig_table'('postamble_tmpl', sig_elt) $S0 = $P0[0] $S0 = 'fill_tmpl_int'($S0, i) push postamble, $S0 $P0 = 'map_from_sig_table'('sig_char', sig_elt) $S0 = $P0[0] $S0 = 'fill_tmpl_int'($S0, i) push pcc_sig, $S0 $S0 = "t_%i" $S0 = 'fill_tmpl_int'($S0, i) push pcc_retv, $S0 next: inc i goto loop end_loop: $I0 = elements pcc_sig unless $I0 goto empty_ret $S0 = join ";\n ", postamble $S1 = join '', pcc_sig $S2 = join ', ', pcc_retv $S3 = 'sprintf'(<<'TEMPLATE', $S0, $S1, $S2) %s; Parrot_pcc_set_call_from_c_args(interp, call_object, "%s", %s); TEMPLATE .return ($S3) empty_ret: $S0 = <<'RET' Parrot_pcc_set_call_from_c_args(interp, call_object, ""); RET .return ($S0) .end .sub 'sig_to_call' .param pmc sig .local string return_assign $I0 = sig[0] $P0 = 'map_from_sig_table'('func_call_assign', $I0) return_assign = $P0[0] .local int i, n .local string call_params i = 1 n = elements sig dec n $P0 = 'xtimes'('v_%i', n) 'fill_tmpls_ascending_ints'($P0, 1) loop: unless i <= n goto end_loop $I0 = sig[i] $I1 = band $I0, .DATATYPE_REF_FLAG unless $I1 goto next $I0 = i - 1 $S0 = $P0[$I0] $S0 = concat "&", $S0 $P0[$I0] = $S0 next: inc i goto loop end_loop: call_params = join ', ', $P0 .local string pcc_sig $P0 = 'map_from_sig_table'('sig_char', sig :flat) $S0 = shift $P0 pcc_sig = join "", $P0 if pcc_sig != "v" goto end_call_params_void call_params = "" end_call_params_void: .local string call call = 'sprintf'(<<'TEMPLATE', return_assign, call_params) GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); %s (*fn_pointer)(%s); TEMPLATE .return (call) .end .sub 'sig_to_preamble' .param pmc sig .local string preamble preamble = "" .local string pcc_sig $P0 = 'map_from_sig_table'('sig_char', sig :flat) $S0 = shift $P0 pcc_sig = join "", $P0 if pcc_sig != "v" goto end_handle_v preamble = 'sprintf'(<<'TEMPLATE') Parrot_pcc_fill_params_from_c_args(interp, call_object, ""); TEMPLATE goto return end_handle_v: .local string fill_params $I0 = elements sig dec $I0 $P0 = 'xtimes'(', &t_%i', $I0) 'fill_tmpls_ascending_ints'($P0, 1) fill_params = join '', $P0 .local string extra_preamble $P0 = 'map_from_sig_table'('preamble_tmpl', sig :flat) $S0 = shift $P0 'fill_tmpls_ascending_ints'($P0, 1) extra_preamble = join ";\n ", $P0 preamble = 'sprintf'(<<'TEMPLATE', pcc_sig, fill_params, extra_preamble) Parrot_pcc_fill_params_from_c_args(interp, call_object, "%s"%s); %s; TEMPLATE return: .return (preamble) .end .sub 'sig_to_var_decls' .param pmc sig .local string ret_csig $I0 = sig[0] $P0 = 'map_from_sig_table'('c_type', $I0) ret_csig = $P0[0] .local int i, n i = 1 n = elements sig .local string params_csig $P0 = 'map_from_sig_table'('c_type', sig :flat) $S0 = shift $P0 by_ref_loop: unless i < n goto end_by_ref_loop $I0 = sig[i] $I1 = band $I0, .DATATYPE_REF_FLAG unless $I1 goto next $I0 = i - 1 $S0 = $P0[$I0] $S0 = concat $S0, '*' $P0[$I0] = $S0 next: inc i goto by_ref_loop end_by_ref_loop: params_csig = join ', ', $P0 if params_csig goto end_default_params_csig_to_void params_csig = 'void' end_default_params_csig_to_void: .local string params_tdecl $P0 = 'map_from_sig_table'('temp_tmpl', sig :flat) 'fill_tmpls_ascending_ints'($P0, 0) $P0 = 'grep_for_true'($P0) params_tdecl = join ";\n ", $P0 .local string var_decls var_decls = 'sprintf'(<<'TEMPLATE', ret_csig, params_csig, params_tdecl) typedef %s(* func_t)(%s); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); %s; TEMPLATE .return (var_decls) .end .sub 'sig_to_fn_decl' .param pmc sig .local string storage_class, fn_name, fn_decl storage_class = 'read_from_opts'(.THUNK_STORAGE_CLASS) fn_name = 'sig_to_fn_name'(sig) fn_decl = 'sprintf'(<<'TEMPLATE', storage_class, fn_name) %s void %s(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) TEMPLATE .return (fn_decl) .end .sub 'sig_to_fn_name' .param pmc sig .local int i, n $P0 = 'map_from_sig_table'('cname', sig :flat) i = 0 n = elements sig loop: unless i < n goto end_loop $I0 = sig[i] $I1 = band $I0, .DATATYPE_REF_FLAG unless $I1 goto next $S0 = $P0[i] $S0 = concat $S0, 'ref' $P0[i] = $S0 next: inc i goto loop end_loop: $S0 = join '_', $P0 $S1 = 'read_from_opts'(.THUNK_NAME_PROTO) $S2 = 'sprintf'($S1, $S0) .return ($S2) .end .sub 'map_from_sig_table' .param string field_name .param pmc sig :slurpy .local pmc sig_table sig_table = get_global .SIG_TABLE_GLOBAL_NAME .local int i, n i = 0 n = elements sig .local pmc result result = new ['ResizableStringArray'], n loop: unless i < n goto end_loop $I0 = sig[i] $I1 = bnot .DATATYPE_REF_FLAG $I2 = band $I0, $I1 $I1 = exists sig_table[$I2] unless $I1 goto unsupported_type $S1 = sig_table[$I2; field_name] result[i] = $S1 inc i goto loop unsupported_type: $P0 = null $P0 = dlfunc $P0, "Parrot_dt_get_datatype_name", "SpI" $P1 = getinterp $S0 = $P0($P1, $I0) $S0 = 'sprintf'("Unsupported type: `%s'", $S0) die $S0 end_loop: .return (result) .end # }}} # read_sigs {{{ .sub 'read_sigs' .local pmc stdin, seen, sigs $P0 = getinterp stdin = $P0.'stdin_handle'() seen = new ['Hash'] seen.'set_key_type'(.Hash_key_type_PMC) sigs = new ['ResizablePMCArray'] .local int no_warn_dups no_warn_dups = 'read_from_opts'(.NO_WARN_DUPS) .local int lineno lineno = 0 read_loop: unless stdin goto end_read_loop .local pmc sig sig = 'read_one_sig'(stdin) inc lineno # filter out empty sigs (and empty lines) if_null sig, read_loop # de-dup sigs $I0 = seen[sig] unless $I0 goto unseen if no_warn_dups goto end_dup_warn $S0 = get_repr sig $S0 = 'sprintf'(<<'ERROR', $S0, lineno, $I0) Ignored signature '%s' on line %d (previously seen on line %d) ERROR 'warn'($S0) end_dup_warn: goto read_loop unseen: seen[sig] = lineno push sigs, sig goto read_loop end_read_loop: .return (sigs) .end .sub 'read_one_sig' .param pmc fh load_bytecode 'String/Utils.pbc' .local pmc chomp chomp = get_global ['String';'Utils'], 'chomp' # init pcre load_bytecode 'pcre.pbc' $P0 = get_global ['PCRE'], 'init' $P0() .local pmc pcre_comp, pcre_match, pcre_dollar pcre_comp = get_global ['PCRE'], 'compile' pcre_match = get_global ['PCRE'], 'match' pcre_dollar = get_global ['PCRE'], 'dollar' .local pmc empty_line_regex, old_style_sig_line_regex, new_style_sig_line_regex .local pmc old_style_sig_item_regex, new_style_sig_item_regex .local string pcre_errstr, pcre_errint .const int pcre_extended = 0x00000008 $S0 = "^ [[:space:]]* (?: [#] .* )? $" (empty_line_regex, pcre_errstr, pcre_errint) = pcre_comp($S0, pcre_extended) if pcre_errint goto pcre_comp_err $S0 = "^ [[:space:]]* ( (?: [INSPcsilfdpv] [[:space:]]* )+ ) (?: [#] .* )? $" (old_style_sig_line_regex, pcre_errstr, pcre_errint) = pcre_comp($S0, pcre_extended) if pcre_errint goto pcre_comp_err $S0 = ".*? ([INSPcsilfdpv])" (old_style_sig_item_regex, pcre_errstr, pcre_errint) = pcre_comp($S0, pcre_extended) if pcre_errint goto pcre_comp_err $S0 = <<'REGEX' ^ [[:space:]]* ( [[:word:]]+ [[:space:]]* [(] [[:space:]]* (?: [[:word:]]+ [&]? [[:space:]]* (?: [,] [[:space:]]* [[:word:]]+ [&]? [[:space:]]* )* )? [)] ) [[:space:]]* (?: [#] .* )? $ REGEX (new_style_sig_line_regex, pcre_errstr, pcre_errint) = pcre_comp($S0, pcre_extended) if pcre_errint goto pcre_comp_err $S0 = ".*? ([[:word:]]+ [&]?)" (new_style_sig_item_regex, pcre_errstr, pcre_errint) = pcre_comp($S0, pcre_extended) if pcre_errint goto pcre_comp_err goto match_line pcre_comp_err: $S0 = 'sprintf'("Error in PCRE compilation: `%Ss' (%d)", pcre_errstr, pcre_errint) die $S0 match_line: .local string line line = fh.'readline'() line = chomp(line) .local int ok .local pmc match (ok, match) = pcre_match(empty_line_regex, line, 0, 0) if ok > 0 goto return (ok, match) = pcre_match(old_style_sig_line_regex, line, 0, 0) if ok > 0 goto old_style_sig (ok, match) = pcre_match(new_style_sig_line_regex, line, 0, 0) if ok > 0 goto new_style_sig say ok $S0 = 'sprintf'("Invalid signature line: `%Ss'", line) die $S0 old_style_sig: $S0 = pcre_dollar( line, ok, match, 1 ) $P0 = 'comb'($S0, old_style_sig_item_regex) $S0 = join '', $P0 $P1 = null $P1 = dlfunc $P1, "Parrot_nci_parse_signature", "PpS" $P0 = getinterp $P3 = $P1($P0, $S0) goto return new_style_sig: $S0 = pcre_dollar( line, ok, match, 1 ) $P0 = 'comb'($S0, new_style_sig_item_regex) $P1 = null $P1 = dlfunc $P1, "Parrot_dt_get_datatype_enum", "IpS" $P2 = getinterp $I0 = 0 $I1 = elements $P0 $P3 = new ['FixedIntegerArray'], $I1 get_type_enum_loop: unless $I0 < $I1 goto end_get_type_enum_loop $S0 = $P0[$I0] $I2 = $P1($P2, $S0) $P3[$I0] = $I2 inc $I0 goto get_type_enum_loop end_get_type_enum_loop: goto return return: .yield ($P3) goto match_line .end #}}} # gen_sigtable {{{ .sub 'gen_sigtable' .local pmc table table = new ['Hash'] table.'set_key_type'(.Hash_key_type_int) $P1 = 'from_json'(<<'JSON') { "c_type": "void *", "pcc_type": "PMC *", "preamble_tmpl": "v_%i = PMC_IS_NULL(t_%i) ? NULL : VTABLE_get_pointer(interp, t_%i);", "sig_char": "P", "postamble_tmpl": "if (v_%i != NULL) { t_%i = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, t_%i, v_%i); } else { t_%i = PMCNULL; }" } JSON table[.DATATYPE_PTR] = $P1 $P1 = 'from_json'('{ "c_type": "char", "sig_char": "I", "pcc_type": "INTVAL" }') table[.DATATYPE_CHAR] = $P1 $P1 = 'from_json'('{ "c_type": "short", "sig_char": "I", "pcc_type": "INTVAL" }') table[.DATATYPE_SHORT] = $P1 $P1 = 'from_json'('{ "c_type": "int", "sig_char": "I", "pcc_type": "INTVAL" }') table[.DATATYPE_INT] = $P1 $P1 = 'from_json'('{ "c_type": "long", "sig_char": "I", "pcc_type": "INTVAL" }') table[.DATATYPE_LONG] = $P1 $P1 = 'from_json'('{ "c_type": "long long", "sig_char": "I", "pcc_type": "INTVAL" }') table[.DATATYPE_LONGLONG] = $P1 $P1 = 'from_json'('{ "c_type": "Parrot_Int1", "sig_char": "I", "pcc_type": "INTVAL" }') table[.DATATYPE_INT8] = $P1 $P1 = 'from_json'('{ "c_type": "Parrot_Int2", "sig_char": "I", "pcc_type": "INTVAL" }') table[.DATATYPE_INT16] = $P1 $P1 = 'from_json'('{ "c_type": "Parrot_Int4", "sig_char": "I", "pcc_type": "INTVAL" }') table[.DATATYPE_INT32] = $P1 $P1 = 'from_json'('{ "c_type": "Parrot_Int8", "sig_char": "I", "pcc_type": "INTVAL" }') table[.DATATYPE_INT64] = $P1 $P1 = 'from_json'('{ "c_type": "float", "sig_char": "N", "pcc_type": "FLOATVAL" }') table[.DATATYPE_FLOAT] = $P1 $P1 = 'from_json'('{ "c_type": "double", "sig_char": "N", "pcc_type": "FLOATVAL" }') table[.DATATYPE_DOUBLE] = $P1 $P1 = 'from_json'('{ "c_type": "long double", "sig_char": "N", "pcc_type": "FLOATVAL" }') table[.DATATYPE_LONGDOUBLE] = $P1 $P1 = 'from_json'(<<'JSON') { "c_type": "void", "sig_char": "v", "ret_assign": "", "func_call_assign": "" } JSON table[.DATATYPE_VOID] = $P1 $P1 = 'from_json'('{ "c_type": "PMC *", "pcc_type": "PMC *", "sig_char": "P" }') table[.DATATYPE_PMC] = $P1 $P1 = 'from_json'('{ "c_type": "STRING *", "pcc_type": "STRING *", "sig_char": "S" }') table[.DATATYPE_STRING] = $P1 $P1 = 'from_json'('{ "c_type": "INTVAL", "pcc_type": "INTVAL", "sig_char": "I" }') table[.DATATYPE_INTVAL] = $P1 $P1 = 'from_json'('{ "c_type": "FLOATVAL", "pcc_type": "FLOATVAL", "sig_char": "N" }') table[.DATATYPE_FLOATVAL] = $P1 # fixup table .local pmc table_iter table_iter = iter table iter_loop: unless table_iter goto iter_end .local int k .local pmc v $S0 = shift table_iter k = $S0 v = table[k] $P0 = null $P0 = dlfunc $P0, "Parrot_dt_get_datatype_name", "SpI" $P1 = getinterp $S0 = $P0($P1, k) v['cname'] = $S0 $I0 = exists v['ret_assign'] $I1 = exists v['sig_char'] $I1 = !$I1 $I0 = $I0 || $I1 # not (not exists v[ret_assign] and exists v[sig_char]) if $I0 goto has_ret_assign $S0 = 'Parrot_pcc_set_call_from_c_args(interp, call_object, "' $S1 = v['sig_char'] $S0 = concat $S0, $S1 $S0 = concat $S0, '", return_data);' v['ret_assign'] = $S0 has_ret_assign: $I0 = exists v['func_call_assign'] if $I0 goto has_func_call_assign v['func_call_assign'] = 'v_0 = ' has_func_call_assign: $I1 = exists v['preamble_tmpl'] if $I1 goto end_preamble_tmpl v['preamble_tmpl'] = "v_%i = t_%i" end_preamble_tmpl: $I1 = exists v['postamble_tmpl'] if $I1 goto end_postamble_tmpl v['postamble_tmpl'] = "t_%i = v_%i" end_postamble_tmpl: $I0 = exists v['c_type'] $I1 = exists v['pcc_type'] $I2 = and $I0, $I1 unless $I2 goto end_temp_tmpl $S0 = v['c_type'] $S1 = v['pcc_type'] $S0 = 'sprintf'("%s t_%%i; %s v_%%i", $S1, $S0) v['temp_tmpl'] = $S0 end_temp_tmpl: goto iter_loop iter_end: set_global .SIG_TABLE_GLOBAL_NAME, table .end .sub 'from_json' .param string json_str .local pmc compiler load_language 'data_json' compiler = compreg 'data_json' $P0 = compiler.'compile'(json_str) .tailcall $P0() .end # }}} # utility fn's {{{ .sub 'sprintf' .param string tmpl .param pmc args :slurpy $S0 = sprintf tmpl, args .return ($S0) .end .sub 'fill_tmpls_ascending_ints' .param pmc tmpls .param int start .local int idx, n idx = 0 n = tmpls loop: if idx >= n goto end_loop $S0 = tmpls[idx] $I0 = start + idx $S1 = 'fill_tmpl_int'($S0, $I0) tmpls[idx] = $S1 inc idx goto loop end_loop: .end .sub 'fill_tmpl_int' .param string tmpl .param int i $I0 = 'printf_arity'(tmpl) $P0 = 'xtimes'(i, $I0) $S0 = sprintf tmpl, $P0 .return ($S0) .end .sub 'printf_arity' .param string tmpl .local int count, idx idx = 0 count = 0 loop: idx = index tmpl, '%', idx if idx < 0 goto end_loop # check against '%%' escapes $I0 = idx + 1 $S0 = substr tmpl, $I0, 1 unless $S0 == '%' goto is_valid_placeholder idx = idx + 2 # skip both '%'s goto loop is_valid_placeholder: inc idx inc count goto loop end_loop: .return (count) .end .sub 'xtimes' .param pmc what .param int times .local pmc retv retv = new ['ResizablePMCArray'] retv = times $I0 = 0 loop: if $I0 >= times goto end_loop retv[$I0] = what inc $I0 goto loop end_loop: .return (retv) .end .sub 'grep_for_true' .param pmc input .local pmc output .local int i, n output = new ['ResizableStringArray'] i = 0 n = input loop: if i >= n goto end_loop $S0 = input[i] unless $S0 goto end_cond push output, $S0 end_cond: inc i goto loop end_loop: .return (output) .end .sub 'file_basename' .param string full_path .param pmc extns :slurpy .local string dir, file, extn # replace native file separator with '/' $S0 = 'native_file_separator'() $P0 = split $S0, full_path file = join "/", $P0 $P0 = split '/', file file = pop $P0 dir = join '/', $P0 extn_loop: unless extns goto end_extn_loop $S0 = shift extns $I0 = length $S0 $I1 = -$I0 $S1 = substr file, $I1, $I0 unless $S1 == $S0 goto extn_loop extn = $S1 file = replace file, $I1, $I0, '' end_extn_loop: .return (dir, file, extn) .end .sub 'native_file_separator' load_bytecode 'config.pbc' $P0 = '_config'() $S0 = $P0['slash'] .return ($S0) .end .sub 'alternate_whitespaces' :anon :immediate $P0 = new ['ResizableStringArray'] push $P0, "\t" push $P0, "\n" push $P0, "\r" .return ($P0) .end .sub 'comb' .param string s .param pmc pat .local pmc pcre_match, pcre_dollar pcre_match = get_global ['PCRE'], 'match' pcre_dollar = get_global ['PCRE'], 'dollar' .local pmc items items = new ['ResizableStringArray'] .local int i i = 0 match_loop: .local int ok .local pmc match (ok, match) = pcre_match( pat, s, i, 0 ) unless ok > 0 goto return $S0 = pcre_dollar( s, ok, match, 1) push items, $S0 $S0 = pcre_dollar( s, ok, match, 0) $I0 = bytelength $S0 i += $I0 goto match_loop return: .return (items) .end .sub 'warn' .param string msg $P0 = getinterp $P1 = $P0.'stderr_handle'() $P1.'print'(msg) .end # }}} # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: pprof2cg.pl000755000765000765 3275611606346603 15530 0ustar00bruce000000000000parrot-6.6.0/tools/dev#! perl # Copyright (C) 2009, Parrot Foundation. use strict; use warnings; =head1 NAME tools/dev/pprof2cg.pl =head1 DESCRIPTION Convert the output of Parrot's profiling runcore to a Callgrind-compatible format. =head1 SYNOPSIS perl tools/dev/pprof2cg.pl parrot.pprof.1234 =head1 USAGE Generate a profile by passing C<-Rprofiling> to parrot, for example C<./parrot -Rprofiling perl6.pbc hello.p6>. Once execution completes, C will print a message specifying the location of the parrot profile (pprof). The profile will be named parrot.pprof.XXXX, where XXXX is the PID of the parrot process unless another name is specified by the B environment variable. To generate a Callgrind-compatible profile, run this script with the pprof filename as the first argument. The output file usable by kcachegrind will be in parrot.out.XXXX, where XXXX again is the PID of the original parrot process. =head1 ENVIRONMENT VARIABLES =head2 PARROT_PROFILING_OUTPUT If the environment variable PARROT_PROFILING_OUTPUT is set, the profiling runcore will attempt to use its value as the profile filename. Note that it does not check whether the file already exists and will happily overwrite existing files. =cut main(@ARGV); =head1 INTERNAL DATA STRUCTURES =over 4 =item notes Parrot's execution model is built on continuation-passing style and does not precisely fit the straightforward function-based format that Callgrind-compatible tools expect. For this reason, the profiling runcore captures information about context switches (CS lines in the pprof file) and pprof2cg.pl maintains a context stack that functions similarly to a typical call stack. pprof2cg.pl then maps these context switches as if they were function calls and returns. See C<$call_stack> for more information. =item C<$call_stack> Variables which are named C<$call_stack> hold a reference to an array of hashes which contain information about the currently active contexts. When collecting timing information about an op, it is necessary to add that information to all function calls on the stack because Callgrind-compatible tools expect the cost of a function call to include the cost of all calls made by that function, etc. When a context switch is detected, C looks at the context stack to determine if the context switch looks like a function call (if the context hasn't been seen before) or a return (if the context is somewhere on the stack). There are some other cases that the code handles, but these can be ignored for now in the interest of simplicity. If the context has been seen, C shifts contexts off the stack until it finds the context that has been switched to. When C detects a new context, it adds a fake op representing a function call to C<$stats> and unshifts a new context onto the stack. Each element of C<@$call_stack> contains the information needed to uniquely identify the site of the original context switch. =item C<$stats> Variables which are named C<$stats> contain a reference to a deeply nested HoHoH.. which contains all information gathered about a profiled PIR program. The nested hashes and arrays refer to the file, namespace, line of source code and op number, respectively. The op number is used to allow multiple instructions per line because PIR instructions often represent multiple low-level instructions. This also makes it easy to inject pseudo-ops to represent function calls. Each op always has a time value representing the total amount of time spent in that op. Ops may also have an op_name value that gives the name of the op. When control flow similar to a function call is detected, a pseudo-op representing a function call is injected. These pseudo-ops have zero cost when initialized and are used to determine the total time spent between when the context becomes active and when control flow returns to or past the context. Although they're not exactly like functions calls, they're close enough that it may help to think of them as such. Uncomment the print_stats line in main to see a representation of the data contained in C<$stats>. =back =head1 FUNCTIONS =over 4 =item C
This function is minimal driver for the other functions in this file, taking the name of a Parrot profile and writing a Callgrind-compatible profile to a similarly-named file. =cut sub main { my $filename = shift; my $stats = {}; die "Usage: $0 filename\n" unless defined $filename; $stats->{global_stats}{total_time} = 0; open(my $in_fh, '<', $filename) or die "couldn't open $filename for reading: $!"; process_input($in_fh, $stats); close($in_fh) or die "couldn't close $filename: $!"; unless ($filename =~ s/pprof/out/) { $filename = "$filename.out"; } open(my $out_fh, '>', $filename) or die "couldn't open $filename for writing: $!"; my $cg_profile = get_cg_profile($stats); print $out_fh $cg_profile; close($out_fh) or die "couldn't close $filename: $!"; print "$filename can now be used with kcachegrind or other callgrind-compatible tools.\n"; } =item C This function takes a file handle open to a Parrot profile and a reference to a hash of fine-grained statistics about the current PIR program. It modifies the statistics according to the information from the Parrot profile. =cut sub process_input { my ($input, $stats) = @_; my $call_stack = []; while(my $line = <$input>) { if ($line =~ /^OP:(.*)$/) { # Decode string in the format C<{x{key1:value1}x}{x{key2:value2}x}> my %op_hash = $1 =~ /{x{([^:]+):(.*?)}x}/g or die "invalidly formed line '$line'"; my $cur_ctx = $call_stack->[0] or die "input file did not specify an initial context"; # If we've already seen this line, bump the op number. Otherwise reset it. if (exists $cur_ctx->{line} && $op_hash{line} == $cur_ctx->{line}) { $cur_ctx->{op_num}++; } else { $cur_ctx->{op_num} = 0; } $cur_ctx->{line} = $op_hash{line}; my $extra = { op_name => $op_hash{op} }; my $time = $op_hash{time}; $stats->{global_stats}{total_time} += $time; store_stats($stats, $cur_ctx, $time, $extra); # Add the time spent by this op to each op on the call "stack". $stats->{ $_->{file} }{ $_->{ns} }{ $_->{line} }[ $_->{op_num} ]{time} += $time for @$call_stack[1 .. $#$call_stack]; } #context switch elsif ($line =~ /^CS:(.*)$/) { # Decode string in the format C<{x{key1:value1}x}{x{key2:value2}x}> my %cs_hash = $1 =~ /{x{([^:]+):(.*?)}x}/g or die "invalidly formed line '$line'"; if (!@$call_stack) { $call_stack->[0] = \%cs_hash; } else { my $cur_ctx = $call_stack->[0]; my $hash_ctx = $cs_hash{ctx}; my $is_redundant = $cur_ctx->{ctx} eq $hash_ctx; my $reused_ctx = $is_redundant && $cur_ctx->{sub} ne $cs_hash{sub}; # If we're calling a new sub with the same context, modify the # current context to have the name and address of the new sub. if ($reused_ctx) { $cur_ctx->{ns} = $cs_hash{ns}; $cur_ctx->{sub} = $cs_hash{sub}; } # The new context is the same as the old one, so don't modify the call stack. elsif ($is_redundant) { # This space intentionally left blank. } # If the new context isn't in the current call stack, unshift # it onto the start of the stack. elsif (!grep {$_->{ctx} eq $hash_ctx} @$call_stack) { $cur_ctx->{op_num}++; my $extra = { op_name => "CALL", target => $cs_hash{ns} }; store_stats($stats, $call_stack->[0], 0, $extra); unshift @$call_stack, \%cs_hash; } else { #shift contexts off the stack until one matches the current ctx shift @$call_stack while $call_stack->[0]{ctx} ne $hash_ctx; } } #print Dumper($call_stack); } elsif ($line =~ /^VERSION:(\d+)$/) { my $version = $1; if ($version != 2) { die "profile was generated by an incompatible version of the profiling runcore."; } } elsif ($line =~ /^CLI:(.*)$/) { $stats->{'global_stats'}{'cli'} = $1; } elsif ($line =~ /^END_OF_RUNLOOP:(.*)$/) { # This is the end of an outermost runloop. Several of these can # occur during the execution of a script, e.g. for :init subs. @$call_stack = (); } elsif ($line =~ /^AN:/) { #ignore annotations for now } elsif ($line =~ /^#/) { #comments are always ignored } else { die "Unrecognized line format: '$line'"; } } } =item C This function prints a complete, human-readable representation of the statistical data that have been collected into the C<$stats> argument to stdout. It is primarily intended to ease debugging and is not necessary to create a Callgrind-compatible profile. =cut sub print_stats { my $stats = shift; for my $file (grep {$_ ne 'global_stats'} sort keys %$stats) { for my $ns (sort keys %{ $stats->{$file} }) { for my $line_num (sort {$a<=>$b} keys %{ $stats->{$file}{$ns} }) { for my $op_num (0 .. $#{$stats->{$file}{$ns}{$line_num}}) { print "$file $ns line/op:$line_num/$op_num "; for my $attr (sort keys %{ $stats->{$file}{$ns}{$line_num}[$op_num] }) { print "{ $attr => $stats->{$file}{$ns}{$line_num}[$op_num]{$attr} } "; } print "\n"; } } print "\n"; } } } =item C This function adds statistical data to the C<$stats> hash reference. The C<$loc> argument specifies information such as the namespace, file, line and op number where the data should go. C<$time> is an integer representing the amount of time spent at the specified location. C<$extra> contains any ancillary data that should be stored in the hash. This includes data on (faked) subroutine calls and op names. =cut sub store_stats { my ($stats, $loc, $time, $extra) = @_; my $by_op = ( $stats->{ $loc->{file} }{ $loc->{ns} }{ $loc->{line} }[ $loc->{op_num} ] ||= {} ); if ($by_op->{hits}) { $by_op->{hits} ++; $by_op->{time} += $time; } else { $by_op->{hits} = 1; $by_op->{time} = $time; $by_op->{$_} = $extra->{$_} for keys %$extra; } } =item C This function takes a reference to a hash of statistical information about a PIR program and returns a string containing a Callgrind-compatible profile. Although some information in the profile may not be accurate (namely PID and creator), tools such as kcachegrind are able to consume files generated by this function. =cut sub get_cg_profile { my $stats = shift; my @output = (); push @output, <<"HEADER"; version: 1 creator: 3.4.1-Debian pid: 5751 cmd: $stats->{'global_stats'}{'cli'} part: 1 desc: I1 cache: desc: D1 cache: desc: L2 cache: desc: Timerange: Basic block 0 - $stats->{'global_stats'}{'total_time'} desc: Trigger: Program termination positions: line events: Ir summary: $stats->{'global_stats'}{'total_time'} HEADER for my $file (grep {$_ ne 'global_stats'} keys %$stats) { push @output, "fl=$file"; for my $ns (keys %{ $stats->{$file} }) { push @output, "\nfn=$ns"; for my $line (sort keys %{ $stats->{$file}{$ns} }) { my $curr_op = 0; my $line_stats = $stats->{$file}{$ns}{$line}; my $op_count = scalar(@$line_stats); my $op_time = 0; while ($curr_op < $op_count && $line_stats->[$curr_op]{'op_name'} ne 'CALL') { $op_time += $line_stats->[$curr_op]{'time'}; $curr_op++; } push @output, "$line $op_time"; if ($curr_op < $op_count && $line_stats->[$curr_op]{'op_name'} eq 'CALL') { my $call_target = $line_stats->[$curr_op]{'target'}; my $call_count = $line_stats->[$curr_op]{'hits'}; my $call_cost = $line_stats->[$curr_op]{'time'}; push @output, "cfn=$call_target"; push @output, "calls=$call_count $call_cost"; } if ($curr_op < $op_count) { $op_time = 0; while ($curr_op < $op_count) { $op_time += $line_stats->[$curr_op]{'time'}; $curr_op++; } push @output, "$line $op_time"; } } } } push @output, "totals: $stats->{'global_stats'}{'total_time'}"; return join("\n", @output); } =back =cut # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: Harness.pir000644000765000765 2152312101554067 20713 0ustar00bruce000000000000parrot-6.6.0/runtime/parrot/library/TAP# Copyright (C) 2010-2012, Parrot Foundation. =head1 NAME TAP/Harness =head1 DESCRIPTION Simplified port of TAP::Harness (version 3.21) and TAP::Harness::Archive (version 0.14) See L end L. =head3 Class TAP;Harness This is a simple test harness which allows tests to be run and results automatically aggregated and output to STDOUT. =over 4 =cut .namespace ['TAP';'Harness'] .sub '' :init :load :anon load_bytecode 'TAP/Parser.pbc' load_bytecode 'TAP/Formatter.pbc' $P0 = subclass ['TAP';'Base'], ['TAP';'Harness'] $P0.'add_attribute'('formatter') $P0.'add_attribute'('exec') $P0.'add_attribute'('ignore_exit') $P0.'add_attribute'('merge') $P0.'add_attribute'('opts') $P0 = new 'Hash' $P1 = split ' ', 'parser_args made_parser before_runtests after_runtests after_test' L1: unless $P1 goto L2 $S0 = shift $P1 $P0[$S0] = 1 goto L1 L2: set_global ['TAP';'Harness'], 'LEGAL_CALLBACK', $P0 .end .sub 'init' :vtable :method $P0 = get_global ['TAP';'Harness'], 'LEGAL_CALLBACK' setattribute self, 'ok_callbacks', $P0 .end =item process_args =cut .sub 'process_args' :method .param pmc opts setattribute self, 'opts', opts $I0 = exists opts['exec'] unless $I0 goto L1 $S0 = opts['exec'] $P0 = box $S0 setattribute self, 'exec', $P0 L1: $I0 = exists opts['ignore-exit'] unless $I0 goto L2 $S0 = opts['ignore-exit'] $P0 = new 'Boolean' set $P0, 1 setattribute self, 'ignore_exit', $P0 L2: $I0 = exists opts['merge'] unless $I0 goto L3 $S0 = opts['merge'] $P0 = new 'Boolean' set $P0, 1 setattribute self, 'merge', $P0 L3: .end =item formatter =cut .sub 'formatter' :method .param pmc formatter setattribute self, 'formatter', formatter .end =item runtests =cut .sub 'runtests' :method :nsentry .param pmc tests $P0 = getattribute self, 'formatter' unless null $P0 goto L1 $P0 = new ['TAP';'Formatter';'Console'] setattribute self, 'formatter', $P0 $P1 = getattribute self, 'opts' $P0.'process_args'($P1) L1: .local pmc aggregate aggregate = new ['TAP';'Parser';'Aggregator'] self.'_make_callback'('before_runtests', aggregate) aggregate.'start'() self.'aggregate_tests'(aggregate, tests) aggregate.'stop'() self.'summary'(aggregate) self.'_make_callback'('after_runtests', aggregate) .return (aggregate) .end .sub 'aggregate_tests' :method .param pmc aggregate .param pmc tests $P0 = getattribute self, 'formatter' $P0.'prepare'(tests) .local string exec exec = '' $P0 = getattribute self, 'exec' if null $P0 goto L1 exec = $P0 L1: $P0 = iter tests L2: unless $P0 goto L3 $S0 = shift $P0 .local pmc parser, session (parser, session) = self.'make_parser'($S0) unless exec == '' goto L4 parser.'file'($S0) goto L5 L4: parser.'exec'(exec, $S0) L5: .local pmc coro $P1 = get_hll_global ['TAP';'Parser'], 'next' coro = newclosure $P1 L6: .local pmc result result = coro(parser) if null result goto L7 session.'result'(result) $I0 = isa result, ['TAP';'Parser';'Result';'Bailout'] unless $I0 goto L6 self.'_bailout'(result) L7: self.'finish_parser'(parser, session) self.'_after_test'(aggregate, $S0, parser) goto L2 L3: .end .sub '_after_test' :method .param pmc aggregate .param pmc desc .param pmc parser self.'_make_callback'('after_test', parser) aggregate.'add'(desc, parser) .end .sub '_bailout' :method .param pmc result $S0 = ".\n" $P0 = result.'bailout'() if null $P0 goto L1 $S0 = $P0 L1: $S0 = "FAILED--Further testing stopped" . $S0 die $S0 .end .sub 'summary' :method .param pmc aggregate $P0 = getattribute self, 'formatter' $P0.'summary'(aggregate) .end .sub 'make_parser' :method .param string desc .local pmc parser, session parser = new ['TAP';'Parser'] $P0 = getattribute self, 'merge' if null $P0 goto L1 parser.'merge'($P0) L1: $P0 = getattribute self, 'ignore_exit' if null $P0 goto L2 parser.'ignore_exit'($P0) L2: self.'_open_spool'(parser, desc) self.'_make_callback'('made_parser', parser) $P0 = getattribute self, 'formatter' session = $P0.'open_test'(desc, parser) .return (parser, session) .end .sub 'finish_parser' :method .param pmc parser .param pmc session session.'close_test'() self.'_close_spool'(parser) .return (parser) .end .sub '_open_spool' :method .param pmc parser .param string test $P0 = new 'Env' $I0 = exists $P0['PARROT_TEST_HARNESS_DUMP_TAP'] unless $I0 goto L1 .local string spool $S0 = $P0['PARROT_TEST_HARNESS_DUMP_TAP'] spool = catfile($S0, test) $S0 = dirname(spool) mkpath($S0) $P0 = new 'FileHandle' $P0.'open'(spool, 'w') parser.'spool'($P0) L1: .end .sub '_close_spool' :method .param pmc parser $P0 = parser.'delete_spool'() if null $P0 goto L1 $P0.'close'() L1: .end =back =head3 Class TAP';Harness;Archive This module is a direct subclass of C and behaves in exactly the same way except for one detail. In addition to outputting a running progress of the tests and an ending summary it can also capture all of the raw TAP from the individual test files or streams into an archive file (C<.tar.gz>). =over 4 =cut .namespace ['TAP';'Harness';'Archive'] .sub '' :init :load :anon $P0 = subclass ['TAP';'Harness'], ['TAP';'Harness';'Archive'] $P0.'add_attribute'('archive_file') $P0.'add_attribute'('archive_extra_files') $P0.'add_attribute'('archive_extra_props') .end =item archive =cut .sub 'archive' :method .param pmc archive setattribute self, 'archive_file', archive .end =item extra_files =cut .sub 'extra_files' :method .param pmc extra_files $I0 = does extra_files, 'array' if $I0 goto L1 die "extra_files must be an array!" L1: setattribute self, 'archive_extra_files', extra_files .end =item extra_props =cut .sub 'extra_props' :method .param pmc extra_props $I0 = does extra_props, 'hash' if $I0 goto L1 die "extra_props must be an hash!" L1: setattribute self, 'archive_extra_props', extra_props .end =item runtests =cut .sub 'runtests' :method .param pmc files load_bytecode 'Archive/Tar.pbc' $P0 = getattribute self, 'archive_file' unless null $P0 goto L1 die "You must provide the name of the archive to create!" L1: .local string archive_file, dir archive_file = $P0 dir = tempdir() .local pmc env env = new 'Env' env['PARROT_TEST_HARNESS_DUMP_TAP'] = dir .local pmc aggregate $P0 = get_hll_global ['TAP';'Harness'], 'runtests' aggregate = $P0(self, files) .local string current_dir, cmd current_dir = cwd() chdir(dir) .local pmc archive archive = new ['Archive';'Tar'] archive.'add_files'(files :flat) chdir(current_dir) rmtree(dir) $P0 = getattribute self, 'archive_extra_files' if null $P0 goto L2 archive.'add_files'($P0 :flat) L2: $S0 = self.'_mk_meta'(aggregate) archive.'add_data'('meta.yml', $S0) $P0 = loadlib 'gziphandle' $P0 = new 'GzipHandle' $P0.'open'(archive_file, 'wb') archive.'write'($P0) $P0.'close'() .return (aggregate) .end .sub '_mk_meta' :method .param pmc aggregate $P0 = new 'StringBuilder' push $P0, "---" push $P0, "\nfile_attributes:" $P1 = aggregate.'descriptions'() $P2 = iter $P1 L1: unless $P2 goto L2 $S2 = shift $P2 .local pmc parser parser = aggregate.'parsers'($S2) push $P0, "\n -" push $P0, "\n description: " push $P0, $S2 $N0 = parser.'start_time'() push $P0, "\n start_time: " $S0 = $N0 push $P0, $S0 $N0 = parser.'end_time'() push $P0, "\n stop_time: " $S0 = $N0 push $P0, $S0 goto L1 L2: push $P0, "\nfile_order:" $P2 = iter $P1 L3: unless $P2 goto L4 $S2 = shift $P2 push $P0, "\n - " push $P0, $S2 goto L3 L4: $I0 = aggregate.'start_time'() push $P0, "\nstart_time: " $S0 = $I0 push $P0, $S0 $I0 = aggregate.'end_time'() push $P0, "\nstop_time: " $S0 = $I0 push $P0, $S0 $P1 = getattribute self, 'archive_extra_props' if null $P1 goto L5 push $P0, "\nextra_properties:" $P2 = iter $P1 L6: unless $P2 goto L5 .local string key, value key = shift $P2 value = $P1[key] if value == '' goto L6 push $P0, "\n " push $P0, key push $P0, ": '" push $P0, value push $P0, "'" goto L6 L5: push $P0, "\n" .return ($P0) .end =back =head1 AUTHOR Francois Perrad =cut # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: Trace.pm000644000765000765 3305111567202623 17046 0ustar00bruce000000000000parrot-6.6.0/lib/Parrot/Configure# Copyright (C) 2001-2007, Parrot Foundation. package Parrot::Configure::Trace; use strict; use warnings; use Carp; use Storable qw(nstore retrieve); sub new { my $class = shift; my $argsref = shift || {}; croak "Constructor correctly failed due to non-hashref argument" unless ref($argsref) eq 'HASH'; my $self = bless( [], $class ); my $sto = $argsref->{storable} || q{.configure_trace.sto}; eval { @{$self} = @{ retrieve($sto) }; }; if ($@) { croak "Unable to retrieve storable file of configuration step data"; } else { return $self; } } sub list_steps { my $self = shift; return $self->[0]; } sub index_steps { my $self = shift; my @steps = @{ $self->list_steps() }; my %index = (); for ( my $i = 0 ; $i <= $#steps ; $i++ ) { $index{ $steps[$i] } = $i + 1; } return \%index; } sub trace_options_c { my ( $self, $argsref ) = @_; my @data = @{$self}; my @c = (); for ( my $step = 1 ; $step <= $#data ; $step++ ) { my $value = $data[$step]->{options}->{c}->{ $argsref->{attr} }; if ( $argsref->{verbose} ) { push @c, { $self->[0]->[ $step - 1 ] => $value }; } else { push @c, $value; } } return \@c; } sub trace_options_triggers { my ( $self, $argsref ) = @_; my @data = @{$self}; my @triggers = (); for ( my $step = 1 ; $step <= $#data ; $step++ ) { my $value = $data[$step]->{options}->{triggers}->{ $argsref->{trig} }; if ( $argsref->{verbose} ) { push @triggers, { $self->[0]->[ $step - 1 ] => $value }; } else { push @triggers, $value; } } return \@triggers; } sub trace_data_c { my ( $self, $argsref ) = @_; my @data = @{$self}; my @c = (); for ( my $step = 1 ; $step <= $#data ; $step++ ) { my $value = $data[$step]->{data}->{c}->{ $argsref->{attr} }; if ( $argsref->{verbose} ) { push @c, { $self->[0]->[ $step - 1 ] => $value }; } else { push @c, $value; } } return \@c; } sub diff_data_c { my ( $self, $argsref ) = @_; $argsref->{verbose} = 1; my @traces = @{ $self->trace_data_c($argsref) }; my @results = (); for (my $i = 1; $i < scalar(@traces); $i++) { my %prior = %{$traces[$i - 1]}; my %this = %{$traces[$i]}; my ($prior_key, $prior_value) = each %prior; my ($this_key, $this_value) = each %this; $prior_value = q{} unless defined $prior_value; $this_value = q{} unless defined $this_value; if ($prior_value ne $this_value) { push @results, { number => $i, name => $this_key, before => $prior_value, after => $this_value, }; } } return \@results; } sub trace_data_triggers { my ( $self, $argsref ) = @_; my @data = @{$self}; my @triggers = (); for ( my $step = 1 ; $step <= $#data ; $step++ ) { my $value = $data[$step]->{data}->{triggers}->{ $argsref->{trig} }; if ( $argsref->{verbose} ) { push @triggers, { $self->[0]->[ $step - 1 ] => $value }; } else { push @triggers, $value; } } return \@triggers; } sub get_state_at_step { my $self = shift; my $step = shift; my $state; if ( $step =~ /^\d+$/ ) { croak "Must supply positive integer as step number" unless $step > 0 and $step <= $#{ $self->[0] }; return $self->[$step]; } else { my $index = $self->index_steps(); croak "Must supply valid step name" unless $index->{$step}; return $self->[ $index->{$step} ]; } } ################### DOCUMENTATION ################### =head1 NAME Parrot::Configure::Trace - Trace development of Parrot::Configure object through the configuration steps =head1 SYNOPSIS When calling F: $ perl Configure.pl --configure_trace After configuration has completed: use Parrot::Configure::Trace; $obj = Parrot::Configure::Trace->new(); $steps_list = $obj->list_steps(); $steps_index = $obj->index_steps(); $attr = $obj->trace_options_c( { attr => 'some_attr', verbose => 1, # optional } ); $attr = $obj->trace_options_triggers( { trig => 'some_trig', verbose => 1, # optional } ); $attr = $obj->trace_data_c( { attr => 'some_attr', verbose => 1, # optional } ); $list_diff_steps = $obj->diff_data_c( { attr => 'some_attr', } ); $attr = $obj->trace_data_triggers( { trig => 'some_trig', verbose => 1, # optional } ); $state = $obj->get_state_at_step($step_no); $state = $obj->get_state_at_step('some::step'); =head1 DESCRIPTION This module provides ways to trace the evolution of the data structure within the Parrot::Configure object over the various steps in the configuration process. An understanding of this data structure's development may be useful to Parrot developers working on the configuration process or its results. To make use of Parrot::Configure::Trace's methods, first configure with the C<--configure_trace> option. As configuration proceeds through what are currently 65 individual steps, the state of the Parrot::Configuration object is recorded in a Perl array reference. That array ref is stored on disk via the Storable module in a file called F<.configure_trace.sto> found in the top-level of your Parrot sandbox directory. Once that storable file has been created, you can write programs which retrieve its data into a Parrot::Configure::Trace object and then call methods on that object. =head1 METHODS =head2 C $obj = Parrot::Configure::Trace->new(); =over 4 =item * Purpose Parrot::Configure::Trace constructor. Retrieve configuration data recorded on disk over the course of the configuration steps and populate a Parrot::Configure::Trace object with that data. =item * Arguments None currently required. However, to provide for future extensibility, you may provide a reference to a hash in which various attributes are set which will affect the Parrot::Configure::Trace object. Currently, the only such attribute is C, whose value is the name of the Storable file holding configuration data if that file is named something other than F<.configure_trace.sto>. =item * Return Value Parrot::Configure::Trace object. =item * Comment The Parrot::Configure::Trace object is a blessed array reference. Element C<0> of that array is a reference to an array holding the names of the individual configuration steps; elements C<1> through C<$#array> hold the state of the Parrot::Configure object at the conclusion of each step. Since the purpose of Parrot::Configure::Trace is to track the B of the Parrot::Configure object through the configuration steps, there is no point in recording information about those parts of the Parrot::Configure object which are invariant. The C element is set in F before the configuration steps are run and does not change during those steps. Hence, no information about the C element is recorded and no methods are provided herein to retrieve that information. Since the C and (especially) C elements of the Parrot::Configure object do change over the course of configuration, methods are provided to access that data. =back =head2 C $steps_list = $obj->list_steps(); =over 4 =item * Purpose Provide list of the names of the configuration steps. =item * Arguments None. =item * Return Value Array reference: [ 'init::manifest', 'init::defaults', ... 'gen::config_pm' ] =back =head2 C $steps_index = $obj->index_steps(); =over 4 =item * Purpose Provide lookup table showing which step number a given configuration step is. =item * Arguments None. =item * Return Value Hash reference: { 'inter::ops' => 19, 'init::optimize' => 13, ... 'init::defaults' => 2, } =back =head2 C =over 4 =item * Purpose Provide a list of the values which a given attribute in the C<{options}-E{c}> part of the Parrot::Configure object takes over the course of the configuration steps. =item * Arguments Hash reference. Key C is mandatory; it is the key whose value you wish to trace over the course of the configuration steps. Key C is optional. =item * Return Value Array reference. Element C of this array holds the value of the attribute in the C<{options}-E{c}> part of the Parrot::Configure object at configuration step C. If, however, C is set, each element C of the array holds a hash reference where the hash key is the name of configuration step C and the value is the value of the attribute at step C. =back =head2 C =over 4 =item * Purpose Provide a list of the values which a given attribute in the C<{options}-E{triggers}> part of the Parrot::Configure object takes over the course of the configuration steps. =item * Arguments Hash reference. Key C is mandatory; it is the key whose value you wish to trace over the course of the configuration steps. Key C is optional. =item * Return Value Array reference. Element C of this array holds the value of the attribute in the C<{options}-E{triggers}> part of the Parrot::Configure object at configuration step C. If, however, C is set, each element C of the array holds a hash reference where the hash key is the name of configuration step C and the value is the value of the attribute at step C. =back =head2 C =over 4 =item * Purpose Provide a list of the values which a given attribute in the C<{data}-E{c}> part of the Parrot::Configure object takes over the course of the configuration steps. =item * Arguments Hash reference. Key C is mandatory; it is the key whose value you wish to trace over the course of the configuration steps. Key C is optional. =item * Return Value Array reference. Element C of this array holds the value of the attribute in the C<{data}-E{c}> part of the Parrot::Configure object at configuration step C. If, however, C is set, each element C of the array holds a hash reference where the hash key is the name of configuration step C and the value is the value of the attribute at step C. =back =head2 C =over 4 =item * Purpose Provide a list of those configuration steps where the value of a given attribute in the C<{data}-E{c}> part of the Parrot::Configure object changed from that in effect at the conclusion of the previous configuration step. =item * Arguments Hash reference. Key C is mandatory; it is the key whose changes in value between various steps you wish to trace over the course of configuration. =item * Return Value Array reference. Each element of the array is a reference to a hash holding information about those configuration steps where the value of a given attribute changed from the previous configuration step. The hash has the following key-value pairs: =over 4 =item * number Index position of the configuration step where the value of the given attribute changed. Example: C has index position C<1>. =item * name Name of the configuration step where the value of the given attribute changed. =item * before For step C, the value of the attribute at step C. =item * after For step C, the value of the attribute at step C. =back =item * Comment The array whose reference is the return value of this method only contains elements for those configuration steps where the value of the given attribute changed. Nothing is reported if nothing changed. =back =head2 C =over 4 =item * Purpose Provide a list of the values which a given attribute in the C<{data}-E{triggers}> part of the Parrot::Configure object takes over the course of the configuration steps. =item * Arguments Hash reference. Key C is mandatory; it is the key whose value you wish to trace over the course of the configuration steps. Key C is optional. =item * Return Value Array reference. Element C of this array holds the value of the attribute in the C<{data}-E{triggers}> part of the Parrot::Configure object at configuration step C. If, however, C is set, each element C of the array holds a hash reference where the hash key is the name of configuration step C and the value is the value of the attribute at step C. =back =head2 C =over 4 =item * Purpose Get a snapshot of the data structure in the Parrot::Configure object at the conclusion of a given configuration step. =item * Arguments Either a positive integer corresponding to the step number: $state = $obj->get_state_at_step(54); ... or the C string corresponding to the step's name in Parrot::Configure::Step::List. $state = $obj->get_state_at_step('gen::makefiles'); =item * Return Value Hash reference. =back =head1 AUTHOR James E Keenan (jkeenan@cpan.org) =head1 SEE ALSO L, L, F. =cut 1; # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: postalcodes.pir000755000765000765 432211533177634 17327 0ustar00bruce000000000000parrot-6.6.0/examples/json#!../../parrot # Copyright (C) 2001-2010, Parrot Foundation. =head1 NAME postalcodes.pir - Show info about a postal code =head1 SYNOPSIS % parrot postalcodes.pir =head1 DESCRIPTION Given a postal code (e.g. '06382'), print some information about various places with that code from around the world. =cut .include 'socket.pasm' .loadlib 'io_ops' .sub _main :main .param pmc argv .local string postal, url $I0 = elements argv if $I0 != 2 goto bad_args postal = argv[1] .local pmc sock, address .local string buf, json_result json_result = '' .local int ret .local int len # create the socket handle sock = new 'Socket' sock.'socket'(.PIO_PF_INET, .PIO_SOCK_STREAM, .PIO_PROTO_TCP) # Pack a sockaddr_in structure with IP and port address = sock.'sockaddr'('ws.geonames.org', 80) ret = sock.'connect'(address) .local string url url = 'http://ws.geonames.org/postalCodeSearchJSON?maxRows=10&postalcode=' url .= postal $S0 = 'GET ' $S0 .= url $S0 .= " HTTP/1.0\r\nUser-agent: Parrot\r\n\r\n" ret = sock.'send'($S0) MORE: buf = sock.'recv'() ret = length buf if ret <= 0 goto END json_result .= buf goto MORE ERR: print "Socket error\n" end END: close sock $I1 = find_encoding 'utf8' json_result = trans_encoding json_result, $I1 # Strip off http headers. $I0 = index json_result, "\r\n\r\n" json_result = replace json_result, 0, $I0, "" load_language 'data_json' $P1 = compreg 'data_json' push_eh bad_code $P2 = $P1.'compile'(json_result) pop_eh $P3 = $P2() $P4 = $P3['postalCodes'] .local pmc it, code it = iter $P4 code_loop: push_eh code_end code = shift it pop_eh unless code goto code_end $S0 = code['placeName'] print "Place: " print $S0 print ', ' $S0 = code['countryCode'] print $S0 print '; Code: ' $S0 = code['postalCode'] print $S0 print "\n" goto code_loop code_end: end bad_args: say "Usage: postcalcodes.pir " .return() bad_code: say $P2 .end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: packfileannotation.t000644000765000765 177711533177645 16576 0ustar00bruce000000000000parrot-6.6.0/t/pmc#!./parrot # Copyright (C) 2006-2010, Parrot Foundation. =head1 NAME t/pmc/packfileannotation.t - test the PackfileAnnotation PMC =head1 SYNOPSIS % prove t/pmc/packfileannotation.t =head1 DESCRIPTION Tests the PackfileAnnotation PMC. =cut # PackfileAnnotation constructor .sub 'test' :main .include 'test_more.pir' .local pmc pa plan(5) pa = new ['PackfileAnnotation'] $I0 = defined pa ok($I0, 'PackfileAnnotation created') pa.'set_name'('line') pa.'set_offset'(115200) pa = 42 $S0 = pa.'get_name'() is($S0, 'line', 'Name stored and fetched') $I0 = pa.'get_offset'() is($I0, 115200, 'Offset stored and fetched') $I0 = pa is($I0, 42, 'Value stored and fetched') # We can't fetch string from integer annotation push_eh check $I1 = 1 $S0 = pa $I0 = 0 check: pop_eh ok($I0, "Can't fetch wrong value from Annotation") .end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: hello000644000765000765 54011533177645 15362 0ustar00bruce000000000000parrot-6.6.0/t/perl/testlib# Copyright (C) 2001-2008, Parrot Foundation. # Get @ARGV as a ResizableStringArray get_params "0", P0 # Discard the program name shift S0, P0 # Look for additional args if P0, FOUND_EXTRA_ARG print "Hello World\n" end FOUND_EXTRA_ARG: shift S1, P0 print "Hello " print S1 print "\n" end oo6.pir000644000765000765 212111533177634 16646 0ustar00bruce000000000000parrot-6.6.0/examples/benchmarks# Copyright (C) 2004-2009, Parrot Foundation. .sub bench :main .local pmc cl cl = newclass "Foo" addattribute cl, ".i" addattribute cl, ".j" .local int typ .local int i i = 1 .local pmc o o = new "Foo" loop: $P4 = new 'Integer' $P4 = i o."i"($P4) o."j"($P4) inc i if i <= 500000 goto loop $P2 = o."i"() print $P2 print "\n" end .end .namespace ["Foo"] .sub init :method :vtable new $P10, 'Integer' set $P10, 10 setattribute self, '.i', $P10 new $P10, 'Integer' set $P10, 20 setattribute self, '.j', $P10 .end .sub i :method .param pmc v :optional .param int has_v :opt_flag .local pmc r r = getattribute self, '.i' unless has_v goto get assign r, v get: .return( r ) .end .sub j :method .param pmc v :optional .param int has_v :opt_flag .local pmc r r = getattribute self, '.j' unless has_v goto get assign r, v get: .return( r ) .end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: blue_font.pir000644000765000765 464212101554066 16565 0ustar00bruce000000000000parrot-6.6.0/examples/sdl# Copyright (C) 2001-2012, Parrot Foundation. =head1 NAME blue_font.pir - draw a friendly message to the screen =head1 SYNOPSIS To run this file, run the following command from the Parrot directory: $ ./parrot examples/sdl/blue_font.pir $ Note that you need to have a font named C in the current directory. I recommend making a symlink. Yes, getting this to work across platforms is tricky, as is distributing a royalty-free font file. Maybe soon. =head1 DESCRIPTION This is a PIR program which draws a message to the screen. =cut .sub main :main # first load the necessary libraries load_bytecode "SDL/App.pir" load_bytecode "SDL/Rect.pir" load_bytecode "SDL/Color.pir" load_bytecode "SDL/Font.pir" # create an SDL::App object .local pmc app app = new ['SDL'; 'App'] app.'init'( 'height' => 480, 'width' => 640, 'bpp' => 0, 'flags' => 1 ) # fetch the SDL::Surface representing the main window .local pmc main_screen main_screen = app.'surface'() # create an SDL::Rect object .local pmc rect new rect, ['SDL'; 'Rect'] rect.'init'( 'height' => 100, 'width' => 100, 'x' => 194, 'y' => 208 ) # create SDL::Color objects .local pmc blue new blue, ['SDL'; 'Color'] blue.'init'( 'r' => 0, 'g' => 0, 'b' => 255 ) .local pmc white new white, ['SDL'; 'Color'] white.'init'( 'r' => 255, 'g' => 255, 'b' => 255 ) .local pmc file_pmc file_pmc = new 'File' .local int font_exists font_exists = file_pmc.'exists'( 'times.ttf' ) if font_exists goto have_font print "No font found (expect times.ttf in this directory); exiting...\n" end have_font: .local pmc font new font, ['SDL'; 'Font'] font.'init'( 'font_file' => 'times.ttf', 'point_size' => 48 ) .local pmc full_rect full_rect = new ['SDL'; 'Rect'] full_rect.'init'( 'width' => 640, 'height' => 480, 'x' => 0, 'y' => 0 ) main_screen.'fill_rect'( full_rect, white ) main_screen.'update_rect'( full_rect ) # draw the rectangle to the surface and update it font.'draw'( 'Hello, world!', blue, main_screen, rect ) main_screen.'update_rect'( rect ) # pause for people to see it sleep 2 # and that's it! app.'quit'() end .end =head1 AUTHOR chromatic, Echromatic at wgz dot orgE. =cut # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: README.pod000644000765000765 65012101554066 15704 0ustar00bruce000000000000parrot-6.6.0/examples/mops# Copyright (C) 2001-2012, Parrot Foundation. =pod =head1 NAME examples/mops/README.pod - Readme file for mops example command lines. =head1 DESCRIPTION Here are example comannd lines: =over 4 =over 8 =item mops.pl: perl mops.pl =item mops.ps: gs -q -DNODISPLAY mops.ps =item mops.py: python mops.py =item mops.rb: ruby mops.rb =back =back =head1 COPYRIGHT Copyright (C) 2001-2012, Parrot Foundation. =cut null.t000644000765000765 112411533177645 13661 0ustar00bruce000000000000parrot-6.6.0/t/pmc#!./parrot # Copyright (C) 2006-2008, Parrot Foundation. =head1 NAME t/pmc/null.t - test Null PMC =head1 SYNOPSIS % prove t/pmc/null.t =head1 DESCRIPTION Tests the Null PMC. =cut .sub main :main .include 'test_more.pir' plan(3) new $P0, ['Null'] ok(1, 'Instantiated a Null PMC') new $P1, ['Null'] $I0 = issame $P0, $P1 ok ($I0, 'Null is same as Null') new $P2, ['Undef'] $I0 = issame $P0, $P2 nok($I0, 'Null is not same as not Undef') .end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: podextract.pl000644000765000765 445712302713345 16451 0ustar00bruce000000000000parrot-6.6.0/tools/build#! perl # Copyright (C) 2014, Parrot Foundation. =head1 NAME tools/build/podextract.pl =head1 DESCRIPTION Simple POD Extraction =head1 SYNOPSIS Now: perl podextract.pl $source $target Previously: perldoc -ud $target $source or perldoc -u $source > $target =head1 RATIONALE C does many things, and is somewhat complex. For instance, normally, perldoc perldoc inspects various paths, and paths that are controlled by C<%ENV> to find relevant documentation for "perldoc". And because of this, it is a little security concious, and pre-emptively drops root to UID=nobody But Parrot is not using this feature of C. Parrot is simply using C as a content filter to extract C from source files. And as such, it only needs the alternative function perldoc $PATH To work, which doesn't require C<%ENV>, and additionally, dropping root to C makes it impossible for some parrot to invoke C on some systems, because it drops privileges and can then no longer read C<$source>, and can no longer write C<$target>. However, some means vendor tooling that B execute C as root, by proxy, C invoke C as root, and as such, invokes the security problem, which is impossible to work around. Given a simple C is not enough, because parent directories also are not readable or writeable by C, and additionally, vendor tooling causes fatal access violations when a process running as C even attempts to do directory lookaround ( which C does much of as part of C<%ENV> handling ) So this tool is simple: It takes the very core utility in C that parrot needed to utilize, and calls it directly. And this avoids the misguided attempts of increasing security, which simply does nothing useful. =cut use strict; use warnings; if ( not $ARGV[1] ) { die "pod_extract "; } if ( not -e $ARGV[0] ) { die " $ARGV[0] does not exist"; } require Pod::Perldoc::ToPod; my $parser = Pod::Perldoc::ToPod->new(); open my $output, '>', $ARGV[1] or die "Cant write to $ARGV[1] $! $?"; $parser->parse_from_file( $ARGV[0], $output ); exit 0; # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: context_accessors.c000644000765000765 4017612307662657 17133 0ustar00bruce000000000000parrot-6.6.0/src/call/* Copyright (C) 2009-2011, Parrot Foundation. =head1 NAME src/context.c =head1 DESCRIPTION Parrot_Context functions. =cut */ #include "parrot/parrot.h" /* HEADERIZER HFILE: include/parrot/context.h */ /* =head2 Context API Functions =over 4 =item C Fetch Parrot_Context from Context PMC. =cut */ PARROT_EXPORT PARROT_CAN_RETURN_NULL PARROT_PURE_FUNCTION Parrot_Context* Parrot_pcc_get_context_struct_func(SHIM_INTERP, ARGIN_NULLOK(PMC *ctx)) { ASSERT_ARGS(Parrot_pcc_get_context_struct_func) if (PMC_IS_NULL(ctx)) return NULL; return CONTEXT_STRUCT(ctx); } /* =item C =item C =item C =item C Get/set constants from context. =cut */ PARROT_EXPORT PARROT_CANNOT_RETURN_NULL PARROT_PURE_FUNCTION FLOATVAL * Parrot_pcc_get_num_constants_func(SHIM_INTERP, ARGIN(const PMC *ctx)) { ASSERT_ARGS(Parrot_pcc_get_num_constants_func) return CONTEXT_STRUCT(ctx)->num_constants; } PARROT_EXPORT PARROT_CANNOT_RETURN_NULL PARROT_PURE_FUNCTION STRING ** Parrot_pcc_get_str_constants_func(SHIM_INTERP, ARGIN(const PMC *ctx)) { ASSERT_ARGS(Parrot_pcc_get_str_constants_func) return CONTEXT_STRUCT(ctx)->str_constants; } PARROT_EXPORT PARROT_CANNOT_RETURN_NULL PARROT_PURE_FUNCTION PMC ** Parrot_pcc_get_pmc_constants_func(SHIM_INTERP, ARGIN(const PMC *ctx)) { ASSERT_ARGS(Parrot_pcc_get_pmc_constants_func) PARROT_ASSERT(ctx->vtable->base_type == enum_class_CallContext); return CONTEXT_STRUCT(ctx)->pmc_constants; } PARROT_EXPORT PARROT_CAN_RETURN_NULL void Parrot_pcc_set_constants_func(SHIM_INTERP, ARGIN(PMC *ctx), ARGIN(const struct PackFile_ConstTable *ct)) { ASSERT_ARGS(Parrot_pcc_set_constants_func) Parrot_Context * const c = CONTEXT_STRUCT(ctx); PARROT_ASSERT(ctx->vtable->base_type == enum_class_CallContext); c->num_constants = ct->num.constants; c->str_constants = ct->str.constants; c->pmc_constants = ct->pmc.constants; } /* =item C Get recursion depth from context. =cut */ PARROT_EXPORT PARROT_PURE_FUNCTION UINTVAL Parrot_pcc_get_recursion_depth_func(SHIM_INTERP, ARGIN(const PMC *ctx)) { ASSERT_ARGS(Parrot_pcc_get_recursion_depth_func) PARROT_ASSERT(ctx->vtable->base_type == enum_class_CallContext); return CONTEXT_STRUCT(ctx)->recursion_depth; } /* =item C Set recursion depth of the current context to new_depth. =cut */ PARROT_EXPORT UINTVAL Parrot_pcc_set_recursion_depth_func(SHIM_INTERP, ARGIN(const PMC *ctx), const int new_depth) { ASSERT_ARGS(Parrot_pcc_set_recursion_depth_func) PARROT_ASSERT(ctx->vtable->base_type == enum_class_CallContext); return CONTEXT_STRUCT(ctx)->recursion_depth = new_depth; } /* =item C Increase recursion depth. Returns previous recursion_depth value. =cut */ PARROT_EXPORT UINTVAL Parrot_pcc_inc_recursion_depth_func(SHIM_INTERP, ARGIN(PMC *ctx)) { ASSERT_ARGS(Parrot_pcc_inc_recursion_depth_func) PARROT_ASSERT(ctx->vtable->base_type == enum_class_CallContext); return ++CONTEXT_STRUCT(ctx)->recursion_depth; } /* =item C Decrease recursion depth. Returns new recursion_depth value. =cut */ PARROT_EXPORT UINTVAL Parrot_pcc_dec_recursion_depth_func(SHIM_INTERP, ARGIN(PMC *ctx)) { ASSERT_ARGS(Parrot_pcc_dec_recursion_depth_func) PARROT_ASSERT(ctx->vtable->base_type == enum_class_CallContext); return --CONTEXT_STRUCT(ctx)->recursion_depth; } /* =item C =item C Get/set caller Context. =cut */ PARROT_EXPORT PARROT_PURE_FUNCTION PARROT_CAN_RETURN_NULL PMC* Parrot_pcc_get_caller_ctx_func(SHIM_INTERP, ARGIN(const PMC *ctx)) { ASSERT_ARGS(Parrot_pcc_get_caller_ctx_func) PARROT_ASSERT(ctx->vtable->base_type == enum_class_CallContext); return CONTEXT_STRUCT(ctx)->caller_ctx; } PARROT_EXPORT void Parrot_pcc_set_caller_ctx_func(PARROT_INTERP, ARGIN(PMC *ctx), ARGIN(PMC *caller_ctx)) { ASSERT_ARGS(Parrot_pcc_set_caller_ctx_func) PARROT_ASSERT(ctx->vtable->base_type == enum_class_CallContext); PARROT_ASSERT(caller_ctx->vtable->base_type == enum_class_CallContext); PARROT_GC_WRITE_BARRIER(interp, ctx); CONTEXT_STRUCT(ctx)->caller_ctx = caller_ctx; } /* =item C =item C Get/set outer Context. =cut */ PARROT_EXPORT PARROT_PURE_FUNCTION PARROT_CAN_RETURN_NULL PMC* Parrot_pcc_get_outer_ctx_func(SHIM_INTERP, ARGIN(const PMC *ctx)) { ASSERT_ARGS(Parrot_pcc_get_outer_ctx_func) PARROT_ASSERT(ctx->vtable->base_type == enum_class_CallContext); return CONTEXT_STRUCT(ctx)->outer_ctx; } PARROT_EXPORT void Parrot_pcc_set_outer_ctx_func(PARROT_INTERP, ARGIN(PMC *ctx), ARGIN(PMC *outer_ctx)) { ASSERT_ARGS(Parrot_pcc_set_outer_ctx_func) PARROT_ASSERT(ctx->vtable->base_type == enum_class_CallContext); PARROT_ASSERT(outer_ctx->vtable->base_type == enum_class_CallContext); PARROT_GC_WRITE_BARRIER(interp, ctx); CONTEXT_STRUCT(ctx)->outer_ctx = outer_ctx; } /* =item C =item C Get/set LexPad. =cut */ PARROT_EXPORT PARROT_PURE_FUNCTION PARROT_CANNOT_RETURN_NULL PMC* Parrot_pcc_get_lex_pad_func(SHIM_INTERP, ARGIN(const PMC *ctx)) { ASSERT_ARGS(Parrot_pcc_get_lex_pad_func) PARROT_ASSERT(ctx->vtable->base_type == enum_class_CallContext); return CONTEXT_STRUCT(ctx)->lex_pad; } PARROT_EXPORT void Parrot_pcc_set_lex_pad_func(PARROT_INTERP, ARGIN(PMC *ctx), ARGIN(PMC *lex_pad)) { ASSERT_ARGS(Parrot_pcc_set_lex_pad_func) PARROT_ASSERT(ctx->vtable->base_type == enum_class_CallContext); PARROT_GC_WRITE_BARRIER(interp, ctx); CONTEXT_STRUCT(ctx)->lex_pad = lex_pad; } /* =item C =item C Get/set namespace of Context. =cut */ PARROT_EXPORT PARROT_PURE_FUNCTION PARROT_CAN_RETURN_NULL PMC* Parrot_pcc_get_namespace_func(SHIM_INTERP, ARGIN(const PMC *ctx)) { ASSERT_ARGS(Parrot_pcc_get_namespace_func) PARROT_ASSERT(ctx->vtable->base_type == enum_class_CallContext); return CONTEXT_STRUCT(ctx)->current_namespace; } PARROT_EXPORT void Parrot_pcc_set_namespace_func(PARROT_INTERP, ARGIN(PMC *ctx), ARGIN_NULLOK(PMC *_namespace)) { ASSERT_ARGS(Parrot_pcc_set_namespace_func) PARROT_ASSERT(ctx->vtable->base_type == enum_class_CallContext); PARROT_GC_WRITE_BARRIER(interp, ctx); CONTEXT_STRUCT(ctx)->current_namespace = _namespace; } /* =item C =item C Get/set HLL of Context. =cut */ PARROT_EXPORT PARROT_PURE_FUNCTION INTVAL Parrot_pcc_get_HLL_func(SHIM_INTERP, ARGIN(const PMC *ctx)) { ASSERT_ARGS(Parrot_pcc_get_HLL_func) PARROT_ASSERT(ctx->vtable->base_type == enum_class_CallContext); return CONTEXT_STRUCT(ctx)->current_HLL; } PARROT_EXPORT void Parrot_pcc_set_HLL_func(SHIM_INTERP, ARGIN(PMC *ctx), INTVAL hll) { ASSERT_ARGS(Parrot_pcc_set_HLL_func) PARROT_ASSERT(ctx->vtable->base_type == enum_class_CallContext); CONTEXT_STRUCT(ctx)->current_HLL = hll; } /* =item C =item C Get/set scheduler handlers. =cut */ PARROT_EXPORT PARROT_PURE_FUNCTION PARROT_CAN_RETURN_NULL PMC* Parrot_pcc_get_handlers_func(SHIM_INTERP, ARGIN(const PMC *ctx)) { ASSERT_ARGS(Parrot_pcc_get_handlers_func) PARROT_ASSERT(ctx->vtable->base_type == enum_class_CallContext); return CONTEXT_STRUCT(ctx)->handlers; } PARROT_EXPORT void Parrot_pcc_set_handlers_func(PARROT_INTERP, ARGIN(PMC *ctx), ARGIN(PMC *handlers)) { ASSERT_ARGS(Parrot_pcc_set_handlers_func) PARROT_ASSERT(ctx->vtable->base_type == enum_class_CallContext); PARROT_GC_WRITE_BARRIER(interp, ctx); CONTEXT_STRUCT(ctx)->handlers = handlers; } /* =item C =item C Get/set continuation of Context. =cut */ PARROT_EXPORT PARROT_PURE_FUNCTION PARROT_CAN_RETURN_NULL PMC* Parrot_pcc_get_continuation_func(SHIM_INTERP, ARGIN(const PMC *ctx)) { ASSERT_ARGS(Parrot_pcc_get_continuation_func) PARROT_ASSERT(ctx->vtable->base_type == enum_class_CallContext); return CONTEXT_STRUCT(ctx)->current_cont; } PARROT_EXPORT void Parrot_pcc_set_continuation_func(PARROT_INTERP, ARGIN(PMC *ctx), ARGIN_NULLOK(PMC *_continuation)) { ASSERT_ARGS(Parrot_pcc_set_continuation_func) PARROT_ASSERT(ctx->vtable->base_type == enum_class_CallContext); PARROT_GC_WRITE_BARRIER(interp, ctx); CONTEXT_STRUCT(ctx)->current_cont = _continuation; } /* =item C =item C Get/set call signature object of Context (in sub/method call). =cut */ PARROT_EXPORT PARROT_PURE_FUNCTION PARROT_CAN_RETURN_NULL PMC* Parrot_pcc_get_signature_func(SHIM_INTERP, ARGIN(const PMC *ctx)) { ASSERT_ARGS(Parrot_pcc_get_signature_func) PARROT_ASSERT(ctx->vtable->base_type == enum_class_CallContext); return CONTEXT_STRUCT(ctx)->current_sig; } PARROT_EXPORT void Parrot_pcc_set_signature_func(PARROT_INTERP, ARGIN(PMC *ctx), ARGIN_NULLOK(PMC *sig_object)) { ASSERT_ARGS(Parrot_pcc_set_signature_func) PARROT_ASSERT(ctx->vtable->base_type == enum_class_CallContext); PARROT_GC_WRITE_BARRIER(interp, ctx); CONTEXT_STRUCT(ctx)->current_sig = sig_object; } /* =item C =item C Get/set program counter of Sub invocation. =cut */ PARROT_EXPORT PARROT_PURE_FUNCTION PARROT_CAN_RETURN_NULL opcode_t* Parrot_pcc_get_pc_func(SHIM_INTERP, ARGIN(const PMC *ctx)) { ASSERT_ARGS(Parrot_pcc_get_pc_func) PARROT_ASSERT(ctx->vtable->base_type == enum_class_CallContext); return CONTEXT_STRUCT(ctx)->current_pc; } PARROT_EXPORT void Parrot_pcc_set_pc_func(SHIM_INTERP, ARGIN(const PMC *ctx), ARGIN_NULLOK(opcode_t *pc)) { ASSERT_ARGS(Parrot_pcc_set_pc_func) PARROT_ASSERT(ctx->vtable->base_type == enum_class_CallContext); CONTEXT_STRUCT(ctx)->current_pc = pc; } /* =item C Set warnings flags. =cut */ PARROT_EXPORT UINTVAL Parrot_pcc_warnings_on_func(SHIM_INTERP, ARGIN(PMC *ctx), UINTVAL flags) { ASSERT_ARGS(Parrot_pcc_warnings_on_func) Parrot_Context * const c = CONTEXT_STRUCT(ctx); PARROT_ASSERT(ctx->vtable->base_type == enum_class_CallContext); c->warns |= flags; return c->warns; } /* =item C Clear warnings flags. =cut */ PARROT_EXPORT void Parrot_pcc_warnings_off_func(SHIM_INTERP, ARGIN(PMC *ctx), UINTVAL flags) { ASSERT_ARGS(Parrot_pcc_warnings_off_func) Parrot_Context * const c = CONTEXT_STRUCT(ctx); PARROT_ASSERT(ctx->vtable->base_type == enum_class_CallContext); c->warns &= ~flags; } /* =item C Test warnings flags. =cut */ PARROT_EXPORT PARROT_PURE_FUNCTION UINTVAL Parrot_pcc_warnings_test_func(SHIM_INTERP, ARGIN(const PMC *ctx), UINTVAL flags) { ASSERT_ARGS(Parrot_pcc_warnings_test_func) PARROT_ASSERT(ctx->vtable->base_type == enum_class_CallContext); return CONTEXT_STRUCT(ctx)->warns & flags; } /* =item C Set errors flags. =cut */ PARROT_EXPORT void Parrot_pcc_errors_on_func(SHIM_INTERP, ARGIN(PMC *ctx), UINTVAL flags) { ASSERT_ARGS(Parrot_pcc_errors_on_func) PARROT_ASSERT(ctx->vtable->base_type == enum_class_CallContext); CONTEXT_STRUCT(ctx)->errors |= flags; } /* =item C Clear errors flags. =cut */ PARROT_EXPORT void Parrot_pcc_errors_off_func(SHIM_INTERP, ARGIN(PMC *ctx), UINTVAL flags) { ASSERT_ARGS(Parrot_pcc_errors_off_func) PARROT_ASSERT(ctx->vtable->base_type == enum_class_CallContext); CONTEXT_STRUCT(ctx)->errors &= ~flags; } /* =item C Test errors flags. =cut */ PARROT_EXPORT PARROT_PURE_FUNCTION UINTVAL Parrot_pcc_errors_test_func(SHIM_INTERP, ARGIN(PMC *ctx), UINTVAL flags) { ASSERT_ARGS(Parrot_pcc_errors_test_func) PARROT_ASSERT(ctx->vtable->base_type == enum_class_CallContext); return CONTEXT_STRUCT(ctx)->errors & flags; } /* =item C Set trace flags. =cut */ PARROT_EXPORT void Parrot_pcc_trace_flags_on_func(SHIM_INTERP, ARGIN(PMC *ctx), UINTVAL flags) { ASSERT_ARGS(Parrot_pcc_trace_flags_on_func) PARROT_ASSERT(ctx->vtable->base_type == enum_class_CallContext); CONTEXT_STRUCT(ctx)->trace_flags |= flags; } /* =item C Clear trace flags. =cut */ PARROT_EXPORT void Parrot_pcc_trace_flags_off_func(SHIM_INTERP, ARGIN(PMC *ctx), UINTVAL flags) { ASSERT_ARGS(Parrot_pcc_trace_flags_off_func) PARROT_ASSERT(ctx->vtable->base_type == enum_class_CallContext); CONTEXT_STRUCT(ctx)->trace_flags &= ~flags; } /* =item C Test trace flags. =cut */ PARROT_EXPORT PARROT_PURE_FUNCTION UINTVAL Parrot_pcc_trace_flags_test_func(SHIM_INTERP, ARGIN(PMC *ctx), UINTVAL flags) { ASSERT_ARGS(Parrot_pcc_trace_flags_test_func) PARROT_ASSERT(ctx->vtable->base_type == enum_class_CallContext); return CONTEXT_STRUCT(ctx)->trace_flags & flags; } /* =item C =item C =item C Get typed constant from context. =cut */ PARROT_EXPORT PARROT_PURE_FUNCTION PARROT_CAN_RETURN_NULL FLOATVAL Parrot_pcc_get_num_constant_func(SHIM_INTERP, ARGIN(const PMC *ctx), INTVAL idx) { ASSERT_ARGS(Parrot_pcc_get_num_constant_func) PARROT_ASSERT(ctx->vtable->base_type == enum_class_CallContext); return CONTEXT_STRUCT(ctx)->num_constants[idx]; } PARROT_EXPORT PARROT_PURE_FUNCTION PARROT_CAN_RETURN_NULL STRING* Parrot_pcc_get_string_constant_func(SHIM_INTERP, ARGIN(const PMC *ctx), INTVAL idx) { ASSERT_ARGS(Parrot_pcc_get_string_constant_func) PARROT_ASSERT(ctx->vtable->base_type == enum_class_CallContext); return CONTEXT_STRUCT(ctx)->str_constants[idx]; } PARROT_EXPORT PARROT_PURE_FUNCTION PARROT_CAN_RETURN_NULL PMC* Parrot_pcc_get_pmc_constant_func(SHIM_INTERP, ARGIN(const PMC *ctx), INTVAL idx) { ASSERT_ARGS(Parrot_pcc_get_pmc_constant_func) PARROT_ASSERT(ctx->vtable->base_type == enum_class_CallContext); return CONTEXT_STRUCT(ctx)->pmc_constants[idx]; } /* =back */ /* * Local variables: * c-file-style: "parrot" * End: * vim: expandtab shiftwidth=4 cinoptions='\:2=2' : */ readline_c.in000644000765000765 163511567202622 20113 0ustar00bruce000000000000parrot-6.6.0/config/auto/readline/* Copyright (C) 2001-2011, Parrot Foundation. */ #include #include /* #include #include */ /* Since we are not #include:ing we cannot know * the typedefs or prototypes of readline. Let's boldly make stuff up * and even lie for the sake of this test. */ #ifdef __cplusplus extern "C" { #endif char * readline(const char *); void * rl_get_keymap(void); #ifdef __cplusplus } #endif int main(int argc, char *argv[]) { /* Cannot use readline() since we will actually run this * and readline() would hang waiting for input. * Instead, we use rl_get_keymap(). */ #if 0 char * r = readline("hello polly>"); #endif void* keymap = rl_get_keymap(); puts("1"); return EXIT_SUCCESS; } /* * Local variables: * c-file-style: "parrot" * End: * vim: expandtab shiftwidth=4 cinoptions='\:2=2' : */ api.c000644000765000765 513312233541455 13751 0ustar00bruce000000000000parrot-6.6.0/src/nci/* Copyright (C) 2001-2011, Parrot Foundation. =head1 NAME src/nci/api.c - Native Call Interface routines =head1 DESCRIPTION This file implements the interface to the Parrot Native Call Interface system, which builds parrot to C call frames. =head2 Functions =over 4 =cut */ #include "parrot/parrot.h" #include "parrot/nci.h" #include "api.str" /* HEADERIZER HFILE: include/parrot/nci.h */ /* =item C This function serves a single purpose. It takes the function signature for a C function we want to call and returns a PMC with a pointer to a function that can call it. =cut */ PARROT_CANNOT_RETURN_NULL PMC * build_call_func(PARROT_INTERP, ARGIN(PMC *sig)) { ASSERT_ARGS(build_call_func) PMC * const iglobals = interp->iglobals; PMC *nci_funcs; PMC *thunk; if (PMC_IS_NULL(iglobals)) PANIC(interp, "iglobals isn't created yet"); nci_funcs = VTABLE_get_pmc_keyed_int(interp, iglobals, IGLOBALS_NCI_FUNCS); if (PMC_IS_NULL(nci_funcs)) PANIC(interp, "iglobals.nci_funcs isn't created_yet"); /* signatures are FIA internally */ if (sig->vtable->base_type != enum_class_FixedIntegerArray) { size_t i; size_t n = VTABLE_elements(interp, sig); PMC *new_sig = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, new_sig, i, VTABLE_get_integer_keyed_int(interp, sig, i)); sig = new_sig; } thunk = VTABLE_get_pmc_keyed(interp, nci_funcs, sig); if (PMC_IS_NULL(thunk)) { /* try to dynamically build a thunk */ PMC * const nci_fb_cb = VTABLE_get_pmc_keyed_int(interp, iglobals, IGLOBALS_NCI_FB_CB); if (!PMC_IS_NULL(nci_fb_cb)) { void * const cb_ptr = VTABLE_get_pointer(interp, nci_fb_cb); const nci_fb_func_t cb = (nci_fb_func_t)D2FPTR(cb_ptr); if (cb_ptr) { PMC * const nci_fb_ud = VTABLE_get_pmc_keyed_int(interp, iglobals, IGLOBALS_NCI_FB_UD); thunk = cb(interp, nci_fb_ud, sig); } } } if (!PMC_IS_NULL(thunk)) { PARROT_ASSERT(thunk->vtable); return thunk; } Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_UNIMPLEMENTED, "No NCI thunk available for signature `%Ss'", Parrot_nci_describe_sig(interp, sig)); } /* =back =cut */ /* * Local variables: * c-file-style: "parrot" * End: * vim: expandtab shiftwidth=4 cinoptions='\:2=2' : */ support_policy.pod000644000765000765 2427112101554066 17711 0ustar00bruce000000000000parrot-6.6.0/docs/project# Copyright (C) 2009-2011, Parrot Foundation. =pod =head1 NAME docs/project/support_policy.pod - Parrot Release and Support Policy =head1 DESCRIPTION This document describes Parrot's release schedule and support policy. =head1 PARROT RELEASE AND SUPPORT POLICY Parrot's support policy -- for bug reporting, patches, and releases -- relies strongly on its release schedule. =head2 Release Schedule The Parrot team makes twelve releases a year, on the third Tuesday of every month. We make two kinds of releases, "supported" releases and "developer" releases. The supported releases happen quarterly, with the first release in January, numbered X.0.0, then X.1.0, etc. The X.0, X.3, X.6, and X.9 releases are considered supported, they: =over 4 =item * Receive update releases for critical bug/security fixes (1.0.1, etc). =item * Have documented deprecations between each supported release. =item * Are intended for distribution packaging. =item * Are intended for users. =back The developer releases happen every month between two supported releases. The developer releases: =over 4 =item * Track the latest monthly feature additions and removals from master =item * Do not receive bug/security releases. (Fixes appear in the next developer or supported release). =item * Are intended for developers. =back =head2 Deprecations To allow for healthy growth in the project, in addition to adding new features we will also regularly deprecate features and remove them. To ease the burden of these changes on the users, our policy is to notify users of these deprecations in at least one supported release before removal and to provide users with a reasonable upgrade path. Deprecation notices are listed in the file L, together with a version number to help us track when the feature is safe to remove. The suggested upgrade paths for deprecated features can be found on the ParrotDeprecations wiki page. Note that deprecation removals that are committed without an appropriate upgrade path are subject to reversion. For example, if a feature exists in Parrot 2.0 (January 2010), and is not listed for deprecation in that release, the user can be confident that it will still exist at the next supported release, Parrot 2.3 (April 2010). After a feature is announced as deprecated, it might not appear in the next supported release. We sometimes delay removing deprecated features for various reasons, including dependencies by other parts of the core. The developer releases have more flexibility in feature removal, while still meeting the deprecation requirements for support releases. A feature that has a deprecation notification in the 2.0 release may be removed from any monthly developer release between 2.0 and the next supported release, though we're likely to stagger the removals. api.yaml is the definitive source of information about deprecations. If conflicting information is presented on the wiki, in tickets or elsewhere, api.yaml should be considered correct. =head2 Deprecation Notifications HLLs, libraries and other users of Parrot will inevitably find that we deprecate some core features which they depend on. In order to minimize the pain caused by this deprecation and the subsequent "upgrade tax" (i.e. the time users must spend to keep their code working after an upgrade), we now forbid the removal of any deprecated feature until an appropriate upgrade path has been documented. Any deprecated features that are removed without an appropriate notification are subject to reversion until such notifications have been added. The single (rare) exception to this rule is any core feature which is broken or incomplete to the point that it is deemed unusable by any user. These notifications must be listed on the ParrotDeprecations wiki page, along with ticket numbers, a short summary of the deprecation and the expected impact on users. A longer explanation of each deprecation must be put on a page dedicated to the deprecations for a specific supported release. This page provides a short description of each change, its rationale and at least one example of how affected code can be modified to work after the deprecation takes effect. The purpose of these notifications is to make life easier for users of Parrot. If an existing feature is incomplete or broken to the degree that no external projects is likely to be able to make use of it, the removal of that feature does not require a documented upgrade path. We expect such deprecations to be very rare. =head2 Experimental Features From time to time, we may add features to get feedback on their utility and design. Marking them as "Experimental" in F indicates that we may modify or remove them without official deprecation notices. Use them at your own risk--and please provide feedback through official channels if you use them successfully or otherwise. =head2 Changes Requiring Users to Add Code Internal changes to Parrot which require users to add code in order to continue functioning normally also fall under our support policy. An example of this kind of change is the addition of the generational gc, which required a write barrier on VTABLE functions which modified the contents of a PMC. =head2 Supported Older Versions We support a version of Parrot by accepting patches and bug reports for that version and by answering questions and helping to explain the code to users and developers. We will do our best to fix all reported bugs, though we triage bugs based on their severity, the difficulty of reproducing them, their platform characteristics, and other criteria. As we are primarily volunteers, we offer no warranty nor guarantee of support other than our pride in producing great software as a community. For supported releases, we will make additional releases (1.0.1, 1.0.2, etc) to address critical bugs or security problems. What's considered "critical" we'll have to judge on a case-by-case basis, but the users can be confident that bugfix releases will not add or remove features, and we'll work to keep the changes as minimal as possible while resolving the problem. If you decide to use developer releases to get the latest feature developments, we encourage you to update to each monthly release. If you do encounter a problem, it may have already been fixed in a later supported or developer release. On the whole, we're happy to support releases as much as a year old. We might even go as far as making a bug/security release for a supported release up to two years old, depending on the circumstances. As a volunteer project we don't have the resources to commit to making bug/security releases farther back than that. Depending on the nature of your problem, it's likely you'll be able to get help from individual volunteers within the project or commercial support organizations, though that help may take the form of helping you upgrade. If you have received an older release packaged by an operating system vendor or third party, please ask your vendor to get in touch with us, as we're glad to provide them with guidance for the upgrade. We heartily recommend that you take the initiative to help us help you, by providing useful information about potential bugs and by answering diagnostic questions -- perhaps even trying patches or specific revisions. =head2 Bytecode Compatibility In future releases, we might make changes to the bytecode format that would prevent bytecode generated on one supported release from running on a later supported release. These changes will follow our usual deprecation guidelines, with adequate advance notice. We plan to develop tools to migrate between bytecode formats (let us know if you have an urgent need for them), but we generally recommend that you distribute your code in a source form (in the high-level language or PIR), and allow Parrot to generate the bytecode as a local optimization. =head2 Platform Support We commit to running (passing all tests) on our supported platforms. We support recent versions of the three major operating system families: GNU/Linux, Mac OS X, and Microsoft Windows. Any version less than two years old counts as "recent". We support the most recent version of the dominant compiler which conforms to the C89 standard on each supported platform. We may not support all additional features on every platform (JIT, native binaries, alternate runcores), but the default configuration and runstate of Parrot will work on all supported platforms. Other platforms and compilers will also be supported, but we can't commit to supporting a platform without at least one champion who has the skills to make portability fixes, and is willing to test the monthly developer releases, or preferably a regular checkout of master. We might not include a platform in our official support list (even with a champion) if supporting that platform would create an undesirable support burden for the other major platforms. =head2 Deprecation Candidates If it has been included in at least one supported release, a backwards-incompatible change requires deprecation: =over 4 =item * bytecode changes (opcode or core PMC removals, renames) =item * C function changes =item * PIR or PASM syntax changes =item * API changes in the compiler tools =item * changes to Parrot that require HLLs or libraries to add code =back Please note that these features I require deprecation notices: =over 4 =item * Parrot functions I marked with C or documented as part of the public API (listed in docs/embed.pod) =item * The layout of Parrot's internal data structures =item * Parrot internals hidden behind a public API =item * Items otherwise eligible but marked as "experimental" in F =back Note that all pointers passed to and returned from functions marked with C are considered opaque. We do not guarantee backwards compatibility between monthly releases for the layout of these pointers; dereference them at your own risk. =head1 HISTORICAL NOTES Before 1.0, version numbers were ad hoc. Our 1.0 release did not occur in January, so no 1.X releases are from the same months as their 2.X counterparts. Also, the frequency of supported releases is not constant over the life of the project. See F for details about which existing releases were considered supported. =cut move_parrot_logo.pir000644000765000765 715312101554066 20165 0ustar00bruce000000000000parrot-6.6.0/examples/sdl =head1 DESCRIPTION move_parrot_logo.pir - move a Parrot logo with the SDL Parrot bindings =head1 SYNOPSIS To run this file, run the following command from the Parrot directory: $ parrot examples/sdl/move_parrot_logo.pir $ =cut .sub _main :main load_bytecode "SDL/App.pir" load_bytecode "SDL/Color.pir" load_bytecode "SDL/Rect.pir" load_bytecode "SDL/Image.pir" load_bytecode "SDL/Sprite.pir" load_bytecode "SDL/EventHandler.pir" load_bytecode "SDL/Event.pir" .local pmc app .local int app_type app = new ['SDL'; 'App'] app.'init'( 'width' => 640, 'height' => 480, 'bpp' => 0, 'flags' => 0 ) .local pmc main_screen main_screen = app.'surface'() .local pmc black .local int color_type black = new ['SDL'; 'Color'] black.'init'( 'r' => 0, 'g' => 0, 'b' => 0 ) .local pmc image .local int image_type .local string filename image = new ['SDL'; 'Image'] filename = 'examples/sdl/parrot_small.png' image.'init'( 'file' => filename ) .local pmc sprite_args .local pmc sprite .local int sprite_type sprite = new ['SDL'; 'Sprite'] sprite.'init'( 'surface' => image, 'source_x' => 0, 'source_y' => 0, 'dest_x' => 270, 'dest_y' => 212, 'bgcolor' => black ) .local pmc parent_class .local pmc class_type get_class parent_class, ['SDL'; 'EventHandler'] subclass class_type, parent_class, 'MoveLogo::EventHandler' .local pmc event_handler .local int handler_type event_handler = new 'MoveLogo::EventHandler' .local pmc event .local int event_type event = new ['SDL'; 'Event'] event.'init'() .local pmc handler_args handler_args = new 'Hash' handler_args[ 'screen' ] = main_screen handler_args[ 'sprite' ] = sprite event_handler.'init'( handler_args ) event_handler.'draw_screen'( main_screen, sprite ) event.'process_events'( event_handler, handler_args ) .end .namespace [ 'MoveLogo::EventHandler' ] .sub draw_screen :method .param pmc screen .param pmc sprite .local pmc prev_rect .local pmc rect .local pmc rect_array rect_array = new 'ResizablePMCArray' set rect_array, 2 (prev_rect, rect) = sprite.'draw_undraw'( screen ) set rect_array[ 0 ], prev_rect set rect_array[ 1 ], rect screen.'update_rects'( rect_array ) .return() .end .sub key_down_down :method .param pmc event_args .local pmc screen .local pmc sprite screen = event_args[ 'screen' ] sprite = event_args[ 'sprite' ] .local int y y = sprite.'y'() if y == 424 goto _draw inc y sprite.'y'( y ) _draw: self.'draw_screen'( screen, sprite ) .end .sub key_down_up :method .param pmc event_args .local pmc screen .local pmc sprite screen = event_args[ 'screen' ] sprite = event_args[ 'sprite' ] .local int y y = sprite.'y'() if y == 0 goto _draw dec y sprite.'y'( y ) _draw: self.'draw_screen'( screen, sprite ) .end .sub key_down_left :method .param pmc event_args .local pmc screen .local pmc sprite screen = event_args[ 'screen' ] sprite = event_args[ 'sprite' ] .local int x x = sprite.'x'() if x == 0 goto _draw dec x sprite.'x'( x ) _draw: self.'draw_screen'( screen, sprite ) .end .sub key_down_right :method .param pmc event_args .local pmc screen .local pmc sprite screen = event_args[ 'screen' ] sprite = event_args[ 'sprite' ] .local int x x = sprite.'x'() if x == 540 goto _draw inc x sprite.'x'( x ) _draw: self.'draw_screen'( screen, sprite ) .end .sub key_down_escape :method .param pmc event_args end .end =head1 AUTHOR chromatic, Echromatic at wgz dot orgE. =head1 COPYRIGHT Copyright (C) 2004-2008, Parrot Foundation. =cut # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: number.t000644000765000765 3725112307662657 14072 0ustar00bruce000000000000parrot-6.6.0/t/op#!./parrot # Copyright (C) 2001-2010, Parrot Foundation. =head1 NAME t/op/number.t - Number Registers =head1 SYNOPSIS % prove t/op/number.t =head1 DESCRIPTION Tests the use of Parrot floating-point number registers. =cut .sub main :main .include 'test_more.pir' plan(126) test_set_n_nc() test_set_n() test_add_n_n_n() test_add_n_n() test_sub_n_n_n() test_sub_n_n() test_abs_n_i_ic_n_nc() test_mul_i() test_div_i() test_mod_n() test_eq_n_ic() test_eq_nc_ic() test_ne_n_ic() test_ne_n_nc_ic() test_lt_n_ic() test_lt_nc_ic() test_le_n_ic() test_le_nc_ic() test_gt_n_ic() test_gt_nc_ic() test_ge_n_ic() test_ge_nc_ic() test_if_n_ic() test_inc_n() test_dec_n() test_set_i_n() test_neg_n() test_neg_0_dot_0() test_mul_n_n() test_op_n_nc_nc() test_lt_nc_nc_ic() test_string_gt_num() test_null() test_dot_dig_parsing() test_sqrt_n_n() test_exception_div_n_n_by_zero() test_exception_div_n_nc_by_zero() test_exception_div_n_n_n_by_zero() test_exception_div_n_nc_n_by_zero() test_exception_div_n_n_nc_by_zero() test_exception_fdiv_n_n_by_zero() test_exception_fdiv_n_nc_by_zero() test_exception_fdiv_n_n_n_by_zero() test_exception_fdiv_n_nc_n_by_zero() test_exception_fdiv_n_n_nc_by_zero() test_mod_n_n_n_by_zero() test_mod_n_nc_n_by_zero() test_mod_n_n_nc_by_zero() # END_OF_TESTS .end .macro exception_is ( M ) .local pmc exception .local string message .get_results (exception) message = exception['message'] is( message, .M, .M ) .endm .sub test_set_n_nc set $N0, 1.0 set $N1, 4.0 set $N2, 16.0 set $N3, 64.0 set $N4, 256.0 set $N5, 1024.0 set $N6, 4096.0 set $N7, 16384.0 set $N8, 65536.0 set $N9, 262144.0 set $N10, 1048576.0 set $N11, 4194304.0 set $N12, 16777216.0 set $N13, 67108864.0 set $N14, 268435456.0 set $N15, 1073741824.0 set $N16, 4294967296.0 set $N17, 17179869184.0 set $N18, 68719476736.0 set $N19, 274877906944.0 set $N20, 1099511627776.0 set $N21, 4398046511104.0 set $N22, 17592186044416.0 set $N23, 70368744177664.0 set $N24, 281474976710656.0 set $N25, 1.12589990684262e+15 is( $N0, "1", 'set_n_nc' ) is( $N1, "4", 'set_n_nc' ) is( $N2, "16", 'set_n_nc' ) is( $N3, "64", 'set_n_nc' ) is( $N4, "256", 'set_n_nc' ) is( $N5, "1024", 'set_n_nc' ) is( $N6, "4096", 'set_n_nc' ) is( $N7, "16384", 'set_n_nc' ) is( $N8, "65536", 'set_n_nc' ) is( $N9, "262144", 'set_n_nc' ) is( $N10, "1048576", 'set_n_nc' ) is( $N11, "4194304", 'set_n_nc' ) is( $N12, "16777216", 'set_n_nc' ) is( $N13, "67108864", 'set_n_nc' ) is( $N14, "268435456", 'set_n_nc' ) is( $N15, "1073741824", 'set_n_nc' ) is( $N16, "4294967296", 'set_n_nc' ) is( $N17, "17179869184", 'set_n_nc' ) is( $N18, "68719476736", 'set_n_nc' ) is( $N19, "274877906944", 'set_n_nc' ) is( $N20, "1099511627776", 'set_n_nc' ) is( $N21, "4398046511104", 'set_n_nc' ) is( $N22, "17592186044416", 'set_n_nc' ) is( $N23, "70368744177664", 'set_n_nc' ) is( $N24, "281474976710656", 'set_n_nc' ) is( $N25, "1.12589990684262e+15", 'set_n_nc' ) .end .sub test_set_n set $N0, 42.0 set $N1, $N0 is( $N1, "42", 'set_n' ) .end .sub test_add_n_n_n set $N0, 1.0 add $N1, $N0, $N0 is( $N1, "2", 'add_n_n_n' ) add $N2, $N0, $N1 is( $N2, "3", 'add_n_n_n' ) add $N2, $N2, $N2 is( $N2, "6", 'add_n_n_n' ) .end .sub test_add_n_n set $N0, 1.0 add $N0, $N0 is( $N0, "2", 'add_n_n' ) set $N1, 1.0 add $N0, $N1 is( $N0, "3", 'add_n_n' ) add $N0, 3.0 is( $N0, "6", 'add_n_n' ) .end .sub test_sub_n_n_n set $N0, 424242.0 set $N1, 4200.0 sub $N2, $N0, $N1 is( $N2, "420042", 'sub_n_n_n' ) .end .sub test_sub_n_n set $N0, 424242.0 set $N1, 4200.0 sub $N0, $N1 is( $N0, "420042", 'sub_n_n' ) sub $N0, $N0 is( $N0, "0", 'sub_n_n' ) .end .sub test_abs_n_i_ic_n_nc set $I0, -1 abs $N0, $I0 abs $N1, -1 set $I1, 1 abs $N2, $I1 abs $N3, 1 set $N4, -1 abs $N4, $N4 abs $N5, -1.0 set $N6, 1.0 abs $N6, $N6 abs $N7, 1.0 is( $N0, "1", 'abs(n, i|ic|n|nc)' ) is( $N1, "1", 'abs(n, i|ic|n|nc)' ) is( $N2, "1", 'abs(n, i|ic|n|nc)' ) is( $N3, "1", 'abs(n, i|ic|n|nc)' ) is( $N4, "1", 'abs(n, i|ic|n|nc)' ) is( $N5, "1", 'abs(n, i|ic|n|nc)' ) is( $N6, "1", 'abs(n, i|ic|n|nc)' ) is( $N7, "1", 'abs(n, i|ic|n|nc)' ) .end .sub test_mul_i set $N0, 2.0 mul $N1, $N0, $N0 mul $N1, $N1, $N0 mul $N1, $N1, $N0 mul $N1, $N1, $N0 mul $N1, $N1, $N0 mul $N1, $N1, $N0 mul $N1, $N1, $N0 is( $N1, "256", 'mul_i' ) .end .sub test_div_i set $N0, 10.0 set $N1, 2.0 div $N2, $N0, $N1 is( $N2, "5", 'div_i' ) set $N3, 7.0 set $N4, 2.0 div $N3, $N3, $N4 is( $N3, "3.5", 'div_i' ) set $N5, 9.0 set $N6, -4.0 div $N7, $N5, $N6 is( $N7, "-2.25", 'div_i' ) .end .sub test_mod_n set $N0, 5.0 set $N1, 0.0 mod $N2, $N0, $N1 is( $N2, "5", 'mod_n' ) set $N0, 0.0 set $N1, 3.0 mod $N2, $N0, $N1 # TT 1930: on PPC optimized we got $N2 = -0, PPC has_negative_zero # abs $N0, $N2 is( $N0, "0", 'mod_n' ) set $N0, 5.0 set $N1, 3.0 mod $N2, $N0, $N1 is( $N2, "2", 'mod_n' ) set $N0, 5.0 set $N1, -3.0 mod $N2, $N0, $N1 is( $N2, "-1", 'mod_n' ) set $N0, -5.0 set $N1, 3.0 mod $N2, $N0, $N1 is( $N2, "1", 'mod_n' ) set $N0, -5.0 set $N1, -3.0 mod $N2, $N0, $N1 is( $N2, "-2", 'mod_n' ) .end .sub test_eq_n_ic set $N0, 5.000001 set $N1, 5.000001 set $N2, 5.000002 eq $N0, $N1, ONE branch ERROR ok( 0, 'test eq_n_ic bad' ) ONE: ok( 1, 'eq_n_ic ok 1') eq $N1, $N2, ERROR branch TWO ok( 0, 'eq_n_ic bad 1' ) TWO: ok( 1, 'eq_n_ic ok 2') goto END ERROR: ok( 0, 'eq_n_ic bad 2' ) END: .end .sub test_eq_nc_ic set $N0, 1.000001 eq $N0, 1, ERROR branch ONE ok( 0, 'eq_nc_ic') ONE: ok( 1, 'eq_nc_ic ok 1') eq $N0, 1.000001, TWO branch ERROR ok( 0, 'eq_nc_ic') TWO: ok( 1, 'eq_nc_ic ok 2') goto END ERROR: ok( 0, 'eq_nc_ic') END: .end .sub test_ne_n_ic set $N0, -22.222222 set $N1, -22.222222 set $N2, 0.0 ne $N0, $N2, ONE branch ERROR ok( 0, 'ne_n_ic') ONE: ok( 1, 'ne_n_ic ok 1') ne $N0, $N1, ERROR branch TWO ok( 0, 'ne_n_ic') TWO: ok( 1, 'ne_n_ic ok 2') goto END ERROR: ok( 0, 'ne_n_ic') END: .end .sub test_ne_n_nc_ic set $N0, 1073741824.0 ne $N0, 1073741824.0, nok1 ok( 1, 'ne_n_nc_ic ok 1') branch ONE nok1: ok( 0, 'ne_n_nc_ic') ONE: ne $N0, 0.0, TWO branch ERROR TWO: ok( 1, 'ne_n_nc_ic ok 2') goto END ERROR: ok( 0, 'ne_n_nc_ic') END: .end .sub test_lt_n_ic set $N0, 1000.0 set $N1, 500.0 set $N2, 0.0 set $N3, 0.0 lt $N1, $N0, ONE branch ERROR ok( 0, 'lt_n_ic') ONE: ok( 1, 'lt_n_ic ok 1') lt $N0, $N1, ERROR branch TWO ok( 0, 'lt_n_ic') TWO: ok( 1, 'lt_n_ic ok 2') lt $N2, $N3, ERROR branch THREE ok( 0, 'lt_n_ic') THREE: ok( 1, 'lt_n_ic ok 3') goto END ERROR: ok( 0, 'lt_n_ic') END: .end .sub test_lt_nc_ic set $N0, 1000.0 set $N1, 500.0 set $N2, 0.0 lt $N0, 500.0, ERROR branch ONE ok( 0, 'lt_nc_ic') ONE: ok( 1, 'lt_nc_ic ok 1') lt $N1, 1000.0, TWO branch ERROR ok( 0, 'lt_nc_ic') TWO: ok( 1, 'lt_nc_ic ok 2') lt $N0, 0.0, ERROR branch THREE ok( 0, 'lt_nc_ic') THREE: ok( 1, 'lt_nc_ic ok 3') goto END ERROR: ok( 0, 'lt_nc_ic') END: .end .sub test_le_n_ic set $N0, 1000.0 set $N1, 500.0 set $N2, 0.0 set $N3, 0.0 le $N1, $N0, ONE branch ERROR ok( 0, 'le_n_ic') ONE: ok( 1, 'le_n_ic ok 1') le $N0, $N1, ERROR branch TWO ok( 0, 'le_n_ic') TWO: ok( 1, 'le_n_ic ok 2') le $N2, $N3, THREE branch ERROR ok( 0, 'le_n_ic') THREE: ok( 1, 'le_n_ic ok 3') goto END ERROR: ok( 0, 'le_n_ic') END: .end .sub test_le_nc_ic set $N0, 1000.0 set $N1, 500.0 set $N2, 0.0 le $N0, 500.0, ERROR branch ONE ok( 0, 'le_nc_ic') ONE: ok( 1, 'le_nc_ic ok 1') le $N1, 1000.0, TWO branch ERROR ok( 0, 'le_nc_ic') TWO: ok( 1, 'le_nc_ic ok 2') le $N2, 0.0, THREE branch ERROR ok( 0, 'le_nc_ic') THREE: ok( 1, 'le_nc_ic ok 3') goto END ERROR: ok( 0, 'le_nc_ic') END: .end .sub test_gt_n_ic set $N0, 500.0 set $N1, 1000.0 set $N2, 0.0 set $N3, 0.0 gt $N1, $N0, ONE branch ERROR ok( 0, 'gt_n_ic') ONE: ok( 1, 'gt_n_ic ok 1') gt $N0, $N1, ERROR branch TWO ok( 0, 'gt_n_ic') TWO: ok( 1, 'gt_n_ic ok 2') gt $N2, $N3, ERROR branch THREE ok( 0, 'gt_n_ic') THREE: ok( 1, 'gt_n_ic ok 3') goto END ERROR: ok( 0, 'gt_n_ic') END: .end .sub test_gt_nc_ic set $N0, 500.0 set $N1, 1000.0 set $N2, 0.0 gt $N0, 1000.0, ERROR branch ONE ok( 0, 'gt_nc_ic') ONE: ok( 1, 'gt_nc_ic ok 1') gt $N1, 500.0, TWO branch ERROR ok( 0, 'gt_nc_ic') TWO: ok( 1, 'gt_nc_ic ok 2') gt $N2, 0.0, ERROR branch THREE ok( 0, 'gt_nc_ic') THREE: ok( 1, 'gt_nc_ic ok 3') goto END ERROR: ok( 0, 'gt_nc_ic') END: .end .sub test_ge_n_ic set $N0, 500.0 set $N1, 1000.0 set $N2, 0.0 set $N3, 0.0 ge $N1, $N0, ONE branch ERROR ok( 0, 'ge_n_ic') ONE: ok( 1, 'ge_n_ic ok 1') ge $N0, $N1, ERROR branch TWO ok( 0, 'ge_n_ic') TWO: ok( 1, 'ge_n_ic ok 2') ge $N2, $N3, THREE branch ERROR ok( 0, 'ge_n_ic') THREE: ok( 1, 'ge_n_ic ok 3') goto END ERROR: ok( 0, 'ge_n_ic') END: .end .sub test_ge_nc_ic set $N0, 500.0 set $N1, 1000.0 set $N2, 0.0 ge $N0, 1000.0, ERROR branch ONE ok( 0, 'ge_nc_ic') ONE: ok( 1, 'ge_nc_ic ok 1') ge $N1, 500.0, TWO branch ERROR ok( 0, 'ge_nc_ic') TWO: ok( 1, 'ge_nc_ic ok 2') ge $N2, 0.0, THREE branch ERROR ok( 0, 'ge_nc_ic') THREE: ok( 1, 'ge_nc_ic ok 3') goto END ERROR: ok( 0, 'ge_nc_ic') END: .end .sub test_if_n_ic set $N0, 1000.0 set $N1, 500.0 set $N2, 0.0 if $N0, ONE branch ERROR ok( 0, 'if_n_ic') ONE: ok( 1, 'if_n_ic ok 1') if $N1, TWO branch ERROR ok( 0, 'if_n_ic') TWO: ok( 1, 'if_n_ic ok 2') if $N2, ERROR branch THREE ok( 0, 'if_n_ic') THREE: ok( 1, 'if_n_ic ok 3') goto END ERROR: ok( 0, 'if_n_ic') END: .end .sub test_inc_n set $N0, 0.0 inc $N0 is( $N0, "1", 'inc_n' ) inc $N0 inc $N0 inc $N0 inc $N0 is( $N0, "5", 'inc_n' ) .end .sub test_dec_n set $N0, 0.0 dec $N0 is( $N0, "-1", 'dec_n' ) dec $N0 dec $N0 dec $N0 dec $N0 is( $N0, "-5", 'dec_n' ) .end .sub test_set_i_n set $N0, 0.0 set $I0, $N0 is( $I0, "0", 'set_i_n' ) set $N1, 2147483647.0 set $I1, $N1 is( $I1, "2147483647", 'set_i_n' ) set $N2, -2147483648.0 set $I2, $N2 is( $I2, "-2147483648", 'set_i_n' ) .end .sub test_neg_n neg $N0,3.0 neg $N0,$N0 neg $N0 is( $N0, "-3", 'neg_n' ) .end .sub test_neg_0_dot_0 load_bytecode 'config.pbc' $P1 = _config() $P2 = $P1['has_negative_zero'] unless $P2 goto negative_zero_todoed set $N1, 0 neg $N1 is( $N1, "-0", 'neg 0.0' ) .return () negative_zero_todoed: todo(0, '-0.0 not implemented, GH #366') .end .sub test_mul_n_n set $N0,3.0 set $N1,4.0 mul $N0,$N1 is( $N0, "12", 'mul_n_n' ) .end .sub test_op_n_nc_nc add $N1, 2.0, 3.0 is( $N1, "5", 'op_n_nc_nc' ) sub $N1, 2.0, 4.0 is( $N1, "-2", 'op_n_nc_nc' ) .end .sub test_lt_nc_nc_ic lt 2.0, 1.0, nok ok( 1, 'lt_nc_nc_ic ok 1') lt 3.0, 4.0, ok_2 nok: ok( 0, 'lt_nc_nc_ic') goto END ok_2: ok( 1, 'lt_nc_nc_ic ok 2') END: .end .sub test_string_gt_num set $S0, "1" set $S1, "12.0" set $S2, "-2.45" set $S3, "25e2" set $S4, "Banana" set $N0, $S0 set $N1, $S1 set $N2, $S2 set $N3, $S3 set $N4, $S4 is( $N0, "1", 'string -> num' ) is( $N1, "12", 'string -> num' ) is( $N2, "-2.45", 'string -> num' ) is( $N3, "2500", 'string -> num' ) is( $N4, "0", 'string -> num' ) .end .sub test_null set $N31, 12.5 is( $N31, "12.5", 'null' ) null $N31 is( $N31, "0", 'null' ) .end .sub test_dot_dig_parsing set $N0, .5 is( $N0, "0.5", '.dig parsing' ) .end # Don't check exact string representation. Last digit part can be different */ .sub test_sqrt_n_n $P0 = new 'Float' $N1 = 2 $N2 = sqrt $N1 $P0 = $N2 is( $P0, 1.414213562373, 'sqrt_n_n', 1e-6 ) $N2 = sqrt 2.0 $P0 = $N2 is( $P0, 1.414213562373, 'sqrt_n_n', 1e-6 ) .end .sub test_exception_div_n_n_by_zero push_eh handler set $N0, 0 set $N1, 10 div $N1, $N0 handler: .exception_is( 'Divide by zero' ) .end .sub test_exception_div_n_nc_by_zero push_eh handler set $N1, 10 div $N1, 0 handler: .exception_is( 'Divide by zero' ) .end .sub test_exception_div_n_n_n_by_zero push_eh handler set $N0, 0 set $N1, 10 div $N2, $N1, $N0 handler: .exception_is( 'Divide by zero' ) .end .sub test_exception_div_n_nc_n_by_zero push_eh handler set $N0, 0 div $N2, 10, $N0 handler: .exception_is( 'Divide by zero' ) .end .sub test_exception_div_n_n_nc_by_zero push_eh handler set $N1, 10 div $N2, $N1, 0 handler: .exception_is( 'Divide by zero' ) .end .sub test_exception_fdiv_n_n_by_zero push_eh handler set $N0, 0 set $N1, 10 fdiv $N1, $N0 handler: .exception_is( 'Divide by zero' ) .end .sub test_exception_fdiv_n_nc_by_zero push_eh handler set $N1, 10 fdiv $N1, 0 handler: .exception_is( 'Divide by zero' ) .end .sub test_exception_fdiv_n_n_n_by_zero push_eh handler set $N0, 0 set $N1, 10 fdiv $N2, $N1, $N0 handler: .exception_is( 'Divide by zero' ) .end .sub test_exception_fdiv_n_nc_n_by_zero push_eh handler set $N0, 0 fdiv $N2, 10, $N0 handler: .exception_is( 'Divide by zero' ) .end .sub test_exception_fdiv_n_n_nc_by_zero push_eh handler set $N1, 10 fdiv $N2, $N1, 0 handler: .exception_is( 'Divide by zero' ) .end .sub test_mod_n_n_n_by_zero set $N0, 0 set $N1, 10 mod $N2, $N1, $N0 is( $N2, "10", 'mod_n_n_n by zero' ) .end .sub test_mod_n_nc_n_by_zero set $N0, 0 mod $N2, 10, $N0 is( $N2, 10, 'mod_n_nc_n by zero' ) .end .sub test_mod_n_n_nc_by_zero set $N1, 10 mod $N2, $N1, 0 is( $N2, '10', 'mod_n_n_nc by zero' ) .end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: trailing_space.t000644000765000765 335711533177643 17102 0ustar00bruce000000000000parrot-6.6.0/t/codingstd#! perl # Copyright (C) 2006-2009, Parrot Foundation. use strict; use warnings; use lib qw( . lib ../lib ../../lib ); use Parrot::Distribution; use Test::More tests => 1; use Parrot::Test::Util::Runloop; use Parrot::Config qw/ %PConfig /; use File::Spec; =head1 NAME t/codingstd/trailing_space.t - checks for superfluous trailing space or tab characters =head1 SYNOPSIS # test all files % prove t/codingstd/trailing_space.t # test specific files % perl t/codingstd/trailing_space.t src/foo.c include/parrot/bar.h =head1 DESCRIPTION Checks that files don't have trailing space or tab characters between the last nominal character on the line and the end of line character. =head1 SEE ALSO L =cut my $DIST = Parrot::Distribution->new; my @files = @ARGV ? <@ARGV> : ( $DIST->get_c_language_files(), $DIST->get_make_language_files(), $DIST->get_perl_language_files(), $DIST->get_pir_language_files(), ); # skip files listed in the __DATA__ section my $build_dir = $PConfig{build_dir}; my %skip_files; while () { next if m{^#}; next if m{^\s*$}; chomp; $_ = File::Spec->catfile($build_dir, $_); $skip_files{$_}++; } Parrot::Test::Util::Runloop->testloop( name => 'no trailing whitespace', files => [grep {not $skip_files{$_->path}} @files], per_line => sub { $_[0] !~ m{[ \t]$}m }, diag_prefix => 'Trailing space or tab char found' ); # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: __DATA__ # generated by tools/dev/nci_thunk_gen.pir src/nci/core_thunks.c src/nci/extra_thunks.c t/examples/pir.t t/examples/tutorial.t t/library/getopt_obj.t t/perl/Parrot_Test.t t/run/options.t Base64.pir000644000765000765 1604412101554067 20441 0ustar00bruce000000000000parrot-6.6.0/runtime/parrot/library/MIME =head1 NAME MIME::Base64 - Encoding and decoding of base64 strings =head1 SYNOPSIS # load this library load_bytecode 'MIME/Base64.pbc' =head1 DESCRIPTION MIME::Base64 is inspired by the Perl5 module MIME::Base64. =head1 METHODS This module defines the following subroutines: =over 4 =item C Encode data by calling the encode_base64() function. The first argument is the string to encode. The returned encoded string is broken into lines of no more than 76 characters each. Note: Unicode stored as MIME::Base64 is inherently endian-dependent. =item C Decode a base64 string by calling the decode_base64() function. This function takes as first argument the string to decode, as optional second argument the encoding string for the decoded data. It returns the decoded data. Any character not part of the 65-character base64 subset is silently ignored. Characters occurring after a '=' padding character are never decoded. =back =cut .include "iterator.pasm" .namespace [ "MIME"; "Base64" ] .sub init :load # Base64 encoded strings are made of printable 8bit long chars, # of which each carries 6 bit worth of information .local string printables printables = ascii:"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" # TODO: find saner names .local pmc six_to_eight, eight_to_six six_to_eight = new 'FixedIntegerArray' six_to_eight = 64 # 2 ** 6 eight_to_six = new 'FixedIntegerArray' eight_to_six = 256 # 2 ** 8 # TODO: find easier way to initialize with undef or so eight_to_six[0] = 0 .local int i i = 1 START_2: if i >= 256 goto END_2 eight_to_six[i] = -1 inc i goto START_2 END_2: .local int six, eight .local string tmp six = 0 START_1: tmp = substr printables, six, 1 eight = ord tmp eight_to_six[eight] = six six_to_eight[six] = eight inc six if six < 64 goto START_1 set_global 'eight_to_six', eight_to_six set_global 'six_to_eight', six_to_eight .end .sub encode_base64 .param string plain .local string base64 .local pmc six_to_eight six_to_eight = get_global 'six_to_eight' .local int len, len_mod_3 .local pmc bb # For unicode we cannot use chr/ord. This breaks endianness. # GH 813 and #814 len = bytelength plain bb = new ['ByteBuffer'], len bb = plain len_mod_3 = len % 3 # Fill up with with null bytes if len_mod_3 == 0 goto END_1 push bb, 0 if len_mod_3 == 2 goto END_1 push bb, 0 END_1: base64 = '' .local int i, j .local int eight_0, eight_1, eight_2 .local int six_0, six_1, six_2, six_3 .local int tmp_int_1, tmp_int_2 .local string s_tmp_1 i = 0 j = 0 START_3: if i >= len goto END_3 # read 3*8 bits eight_0 = bb[i] inc i eight_1 = bb[i] inc i eight_2 = bb[i] inc i # d[i]>>2; shr six_0, eight_0, 2 # ((d[i]&3)<<4) | (d[i+1]>>4) band tmp_int_1, eight_0, 3 shl tmp_int_1, 4 shr tmp_int_2, eight_1, 4 bor six_1, tmp_int_1, tmp_int_2 # ((d[i+1]&15)<<2) | (d[i+2]>>6) band tmp_int_1, eight_1, 15 shl tmp_int_1, 2 shr tmp_int_2, eight_2, 6 bor six_2, tmp_int_1, tmp_int_2 # d[i+2]&63 band six_3, eight_2, 63 # write 4*6 bits, encoded as 4*8 bits, # output is larger than input tmp_int_1 = six_to_eight[six_0] s_tmp_1 = chr tmp_int_1 base64 = concat base64, s_tmp_1 tmp_int_1 = six_to_eight[six_1] s_tmp_1 = chr tmp_int_1 base64 = concat base64, s_tmp_1 tmp_int_1 = six_to_eight[six_2] s_tmp_1 = chr tmp_int_1 base64 = concat base64, s_tmp_1 tmp_int_1 = six_to_eight[six_3] s_tmp_1 = chr tmp_int_1 base64 = concat base64, s_tmp_1 inc j if j == 19 goto line_split goto START_3 line_split: base64 = concat base64, "\n" j = 0 goto START_3 END_3: # padding with '=' if len_mod_3 == 0 goto END_2 base64 = replace base64, -1, 1, ascii:"=" if len_mod_3 == 2 goto END_2 base64 = replace base64, -2, 1, ascii:"=" END_2: .return( base64 ) .end .sub decode_base64 .param string base64 .param string enc :optional .param int has_enc :opt_flag .local string result, base64_cleaned .local int enc_num base64_cleaned = '' if has_enc goto HAS_ENC enc = 'ascii' HAS_ENC: .local pmc eight_to_six, bb eight_to_six = get_global 'eight_to_six' .local int i, len .local int tmp_int_1, tmp_int_2 # Get rid of non-base64 chars len = length base64 i = 0 START_5: .local string s_tmp_1 if i >= len goto END_5 tmp_int_1 = ord base64, i inc i tmp_int_2 = eight_to_six[tmp_int_1] if tmp_int_2 == -1 goto START_5 s_tmp_1 = chr tmp_int_1 base64_cleaned = concat base64_cleaned, s_tmp_1 goto START_5 END_5: .local int len_mod_4 len = length base64_cleaned len_mod_4 = len % 4 # make sure that there are dummy bits beyond base64_cleaned = concat base64_cleaned, ascii:"\0\0\0" bb = new ['ByteBuffer'] .local int eight_0, eight_1, eight_2 .local int six_0, six_1, six_2, six_3 i = 0 START_2: if i >= len goto END_2 # read 4*6 bits tmp_int_1 = ord base64_cleaned, i six_0 = eight_to_six[tmp_int_1] inc i tmp_int_1 = ord base64_cleaned, i six_1 = eight_to_six[tmp_int_1] inc i tmp_int_1 = ord base64_cleaned, i six_2 = eight_to_six[tmp_int_1] inc i tmp_int_1 = ord base64_cleaned, i six_3 = eight_to_six[tmp_int_1] inc i # (f64[t.charAt(i)]<<2) | (f64[t.charAt(i+1)]>>4) shl tmp_int_1, six_0, 2 shr tmp_int_2, six_1, 4 bor eight_0, tmp_int_1, tmp_int_2 # (f64[t.charAt(i+1)]&15)<<4) | (f64[t.charAt(i+2)]>>2) band tmp_int_1, six_1, 15 shl tmp_int_1, 4 shr tmp_int_2, six_2, 2 bor eight_1, tmp_int_1, tmp_int_2 # (f64[t.charAt(i+2)]&3)<<6) | (f64[t.charAt(i+3)]) band tmp_int_1, six_2, 3 shl tmp_int_1, 6 bor eight_2, tmp_int_1, six_3 # write 3*8 bits # output is larger than input push bb, eight_0 push bb, eight_1 push bb, eight_2 goto START_2 END_2: # cut padded '=' if len_mod_4 == 0 goto END_3 if len_mod_4 == 1 goto END_3 len = elements bb dec len bb = len if len_mod_4 == 3 goto END_3 dec len bb = len END_3: result = bb.'get_string'(enc) .return( result ) .end =head1 SEE ALSO L L =head1 AUTHOR Written and maintained by Bernhard Schmalhofer, C<< Bernhard dot Schmalhofer at gmx dot de >>, based on the Perl 5 Module MIME::Base64 by Gisle Aas and on the article on de.selfhtml.org. =head1 COPYRIGHT Copyright (C) 2006-2012, Parrot Foundation. =cut # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: oofib.pl000644000765000765 143611533177634 17072 0ustar00bruce000000000000parrot-6.6.0/examples/benchmarks# Copyright (C) 2004-2007, Parrot Foundation. use strict; use warnings; package A; sub fib { my $self = shift; my $n = shift; return $n if ( $n < 2 ); return $self->fibA( $n - 1 ) + $self->fibB( $n - 2 ); } sub fibA { my $self = shift; my $n = shift; return $n if ( $n < 2 ); return $self->fib( $n - 1 ) + $self->fibB( $n - 2 ); } package B; @B::ISA = qw(A); sub new { return bless {}, $_[0] } sub fibB { my $self = shift; my $n = shift; return $n if ( $n < 2 ); return $self->fib( $n - 1 ) + $self->fibA( $n - 2 ); } package main; my $N = shift || 24; my $b = B->new(); print "fib($N) = ", $b->fib($N), "\n"; # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: comp.t000644000765000765 475311715102034 13475 0ustar00bruce000000000000parrot-6.6.0/t/op#!./parrot # Copyright (C) 2001-2010, Parrot Foundation. =head1 NAME t/op/comp.t - Conditionals =head1 SYNOPSIS % prove t/op/comp.t =head1 DESCRIPTION Tests various conditional branch operations. =cut # some of these were failing with JIT/i386 .sub main :main .include 'test_more.pir' plan(17) test_gt_ic_i_ic() test_ge_ic_i_ic() test_le_ic_i_ic() test_lt_ic_i_ic() test_eq_ic_i_ic() test_ne_ic_i_ic() test_eq_num() .end .sub test_gt_ic_i_ic set $I0, 10 gt 11, $I0, ok1 ok(0, "nok gt1") branch nok1 ok1: ok(1, "ok gt1") nok1: gt 9, $I0, nok2 ok(1, "ok gt2") .return() nok2: ok(0,"nok gt 2") .end .sub test_ge_ic_i_ic set $I0, 10 ge 11, $I0, ok1 ok(0, "nok ge1") branch nok1 ok1: ok(1, "ok ge1") nok1: ge 9, $I0, nok2 ok(1, "ok ge2") branch ok2 nok2: ok(0, "nok ge2") ok2: ge 10, $I0, ok3 ok(0, "nok ge3") .return() ok3: ok(1, "ok ge3") .end .sub test_le_ic_i_ic set $I0, 10 le 9, $I0, ok1 ok(0, "nok le1") branch nok1 ok1: ok(1, "ok le1") nok1: le 11, $I0, nok2 ok(1, "ok le2") branch ok2 nok2: ok(0, "nok le2") ok2: le 10, $I0, ok3 ok(0, "nok le2") .return() ok3: ok(1, "ok le3") .end .sub test_lt_ic_i_ic set $I0, 10 lt 9, $I0, ok1 ok(0, "nok lt1") branch nok1 ok1: ok(1, "ok lt1") nok1: lt 10, $I0, nok2 ok(1, "ok lt2") .return() nok2: ok(0, "nok lt2") .end .sub test_eq_ic_i_ic set $I0, 10 eq 9, $I0, nok1 ok(1, "ok eq1") branch ok1 nok1: ok(0, "nok eq1") ok1: eq 10, $I0, ok2 ok(0, "nok eq2") branch nok2 ok2: ok(1, "ok eq2") nok2: eq 11, 10, nok3 ok(1, "ok eq3") .return() nok3: ok(0, "nok eq3") .end .sub test_ne_ic_i_ic set $I0, 10 ne 9, $I0, ok1 ok(0, "nok neq1") branch nok1 ok1: ok(1, "ok neq1") nok1: ne 10, $I0, nok2 ok(1, "ok neq2") branch ok2 nok2: ok(0, "nok neq2") ok2: ne 11, 10, ok3 ok(0, "nok neq2") .return() ok3: ok(1, "ok neq3") .end .sub test_eq_num new $P0, 'Float' set $P0, -1.2 new $P1, 'String' # # fix problems with g++ 4.4.1 (with --optimize) on i386 - GH #677 # set $P1, "-1.2" set $P1, "-1.2000000000" eq_num $P0, $P1, OK ok(0, "not eq_num") .return() OK: ok(1, "eq_num") .end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: static-triangle-hll.pir000644000765000765 402611533177634 21167 0ustar00bruce000000000000parrot-6.6.0/examples/opengl# Copyright (C) 2006-2009, Parrot Foundation. =head1 TITLE static-triangle-hll.pir - Minimal OpenGL/GLUT setup and render for NCI tests =head1 SYNOPSIS $ cd parrot-home $ ./parrot examples/opengl/static-triangle-hll.pir =head1 DESCRIPTION This is a version of F, to examplify and test usage from HLLs. To quit the example, close the window using your window manager (using the X in the corner of the window title bar, for example), since all keyboard handling has been removed. =cut .include 'opengl_defines.pasm' .HLL 'somelanguage' .sub main :main .param pmc argv # Load OpenGL library and a helper library for calling glutInit load_bytecode 'OpenGL.pbc' load_bytecode 'NCI/Utils.pbc' # Import all OpenGL/GLU/GLUT functions to current namespace # (in this example, the HLL namespace). .local pmc import_gl import_gl = get_root_global ['parrot';'OpenGL'], '_export_all_functions' import_gl() # Initialize GLUT .local pmc call_toolkit_init call_toolkit_init = get_root_global ['parrot';'NCI'; 'Utils'], 'call_toolkit_init' .const 'Sub' glutInit = 'glutInit' argv = call_toolkit_init(glutInit, argv) # Set display mode, create GLUT window, save window handle .local int mode mode = .GLUT_DOUBLE | .GLUT_RGBA glutInitDisplayMode(mode) .local pmc window window = new 'Integer' window = glutCreateWindow('Static Triangle NCI Test') set_global 'glut_window', window # Set up GLUT callbacks .const 'Sub' draw = 'draw' glutDisplayFunc (draw) # Enter the GLUT main loop glutMainLoop() .end .sub draw .local int buffers buffers = .GL_COLOR_BUFFER_BIT | .GL_DEPTH_BUFFER_BIT glClear(buffers) glBegin(.GL_TRIANGLES) glColor3d(1,0,0) glVertex3f(-1, -1, 0) glColor3d(0, 1, 0) glVertex3f(1, -1, 0) glColor3d(0, 0, 1) glVertex3f(0, 1, 0) glEnd() glutSwapBuffers() .end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: mines.pir000644000765000765 411212101554066 20236 0ustar00bruce000000000000parrot-6.6.0/examples/sdl/minesweeper# Copyright (C) 2001-2012, Parrot Foundation. =head1 NAME mines.pir - a minesweeper clone for parrot (with parrot's SDL bindings) =head1 SYNOPSIS To run this game, be in the Parrot directory and run the following command: $ parrot examples/sdl/minesweeper/mines.pir $ =head1 DESCRIPTION This is a PIR program of a minesweeper clone for Parrot. =head1 FUNCTIONS =over 4 =item _main The main function. =cut .sub _main :main .param pmc args .local pmc field .local pmc screen .local int debug # the debug mode is activated if you pass in any argument debug = args dec debug load_bytecode "library/SDL/App.pir" load_bytecode "library/SDL/Event.pir" load_bytecode "library/SDL/EventHandler.pir" load_bytecode "library/SDL/Rect.pir" load_bytecode "library/SDL/Surface.pir" load_bytecode "library/SDL/Color.pir" load_bytecode "library/SDL/Image.pir" load_bytecode "examples/sdl/minesweeper/field.pir" # setup the screen properties $P0 = new 'Hash' $P0["height"] = 480 $P0["width"] = 640 $P0["bpp"] = 32 $P0["flags"] = 5 # create the SDL object $P0 = new ['SDL'; 'App'], $P0 screen = $P0."surface"() # choose a "random" field $I0 = time # setup field properties $P0 = new 'Hash' $P0['width'] = 40 $P0['height'] = 28 $P0['mines'] = 0.1075 # $P0['mines'] = 0.0075 $P0['level'] = $I0 $P0['screen'] = screen $P0['debug'] = debug # create the field field = new "Mines::Field", $P0 # draw the field field.'draw'() # runloop $P0 = new ['SDL'; 'Event'] $P1 = new "Mines::EventHandler" $P0."process_events"( 0.1, $P1, field ) end .end =back =head1 CREDITS The graphics were taken from KMines L screenshots. =head1 AUTHOR Jens Rieks Eparrot at jensbeimsurfen dot deE is the author and maintainer. Please send patches and suggestions to the Perl 6 Internals mailing list. =cut # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: args.c000644000765000765 17364212356767111 14356 0ustar00bruce000000000000parrot-6.6.0/src/call/* Copyright (C) 2001-2011, Parrot Foundation. =head1 NAME src/call/args.c =head1 DESCRIPTION B: Functions in this file handle argument/return value passing to and from subroutines following the Parrot Calling Conventions. =head1 FUNCTIONS =over 4 =cut */ #include "parrot/parrot.h" #include "parrot/oplib/ops.h" #include "args.str" #include "pmc/pmc_key.h" #include "pmc/pmc_fixedintegerarray.h" #include "pmc/pmc_callcontext.h" /* HEADERIZER HFILE: include/parrot/call.h */ /* Set of functions used in generic versions of fill_params and fill_returns. */ typedef INTVAL* (*intval_ptr_func_t)(PARROT_INTERP, void *arg_info, INTVAL index); typedef FLOATVAL* (*numval_ptr_func_t)(PARROT_INTERP, void *arg_info, INTVAL index); typedef STRING** (*string_ptr_func_t)(PARROT_INTERP, void *arg_info, INTVAL index); typedef PMC** (*pmc_ptr_func_t) (PARROT_INTERP, void *arg_info, INTVAL index); typedef INTVAL (*intval_func_t)(PARROT_INTERP, void *arg_info, INTVAL index); typedef FLOATVAL (*numval_func_t)(PARROT_INTERP, void *arg_info, INTVAL index); typedef STRING* (*string_func_t)(PARROT_INTERP, void *arg_info, INTVAL index); typedef PMC* (*pmc_func_t) (PARROT_INTERP, void *arg_info, INTVAL index); typedef struct pcc_funcs_ptr { intval_ptr_func_t intval; numval_ptr_func_t numval; string_ptr_func_t string; pmc_ptr_func_t pmc; intval_func_t intval_constant; numval_func_t numval_constant; string_func_t string_constant; pmc_func_t pmc_constant; } pcc_funcs_ptr; /* HEADERIZER BEGIN: static */ /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */ static void assign_default_param_value(PARROT_INTERP, INTVAL param_index, INTVAL param_flags, ARGIN(void *arg_info), ARGIN(const struct pcc_funcs_ptr *accessor)) __attribute__nonnull__(1) __attribute__nonnull__(4) __attribute__nonnull__(5); static void dissect_aggregate_arg(PARROT_INTERP, ARGMOD(PMC *call_object), ARGIN(PMC *aggregate)) __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__nonnull__(3) FUNC_MODIFIES(*call_object); static void extract_named_arg_from_op(PARROT_INTERP, ARGMOD(PMC *call_object), ARGIN(STRING *name), ARGIN(PMC *raw_sig), ARGIN(opcode_t *raw_args), INTVAL arg_index) __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__nonnull__(3) __attribute__nonnull__(4) __attribute__nonnull__(5) FUNC_MODIFIES(*call_object); static void fill_params(PARROT_INTERP, ARGMOD_NULLOK(PMC *call_object), ARGIN(PMC *raw_sig), ARGIN(void *arg_info), ARGIN(const struct pcc_funcs_ptr *accessor), Errors_classes direction) __attribute__nonnull__(1) __attribute__nonnull__(3) __attribute__nonnull__(4) __attribute__nonnull__(5) FUNC_MODIFIES(*call_object); PARROT_WARN_UNUSED_RESULT static INTVAL intval_constant_from_op(PARROT_INTERP, ARGIN(const opcode_t *raw_params), INTVAL param_index) __attribute__nonnull__(2); PARROT_WARN_UNUSED_RESULT static INTVAL intval_constant_from_varargs(PARROT_INTERP, ARGIN(void *data), INTVAL index) __attribute__nonnull__(2); PARROT_WARN_UNUSED_RESULT PARROT_CANNOT_RETURN_NULL static INTVAL* intval_param_from_c_args(PARROT_INTERP, ARGIN(va_list *args), INTVAL param_index) __attribute__nonnull__(2); PARROT_WARN_UNUSED_RESULT PARROT_CANNOT_RETURN_NULL static INTVAL* intval_param_from_op(PARROT_INTERP, ARGIN(const opcode_t *raw_params), INTVAL param_index) __attribute__nonnull__(1) __attribute__nonnull__(2); PARROT_COLD PARROT_DOES_NOT_RETURN static void named_argument_arity_error(PARROT_INTERP, int named_arg_count, ARGFREE(Hash *named_used_list), ARGIN(Hash *named_arg_list)) __attribute__nonnull__(1) __attribute__nonnull__(4); PARROT_WARN_UNUSED_RESULT static FLOATVAL numval_constant_from_op(PARROT_INTERP, ARGIN(const opcode_t *raw_params), INTVAL param_index) __attribute__nonnull__(1) __attribute__nonnull__(2); PARROT_WARN_UNUSED_RESULT static FLOATVAL numval_constant_from_varargs(PARROT_INTERP, ARGIN(void *data), INTVAL index) __attribute__nonnull__(2); PARROT_WARN_UNUSED_RESULT PARROT_CANNOT_RETURN_NULL static FLOATVAL* numval_param_from_c_args(PARROT_INTERP, ARGIN(va_list *args), INTVAL param_index) __attribute__nonnull__(2); PARROT_WARN_UNUSED_RESULT PARROT_CANNOT_RETURN_NULL static FLOATVAL* numval_param_from_op(PARROT_INTERP, ARGIN(const opcode_t *raw_params), INTVAL param_index) __attribute__nonnull__(1) __attribute__nonnull__(2); static void parse_signature_string(PARROT_INTERP, ARGIN(const char *signature), ARGMOD(PMC **arg_flags)) __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__nonnull__(3) FUNC_MODIFIES(*arg_flags); PARROT_WARN_UNUSED_RESULT PARROT_CAN_RETURN_NULL static PMC* pmc_constant_from_op(PARROT_INTERP, ARGIN(const opcode_t *raw_params), INTVAL param_index) __attribute__nonnull__(1) __attribute__nonnull__(2); PARROT_CAN_RETURN_NULL PARROT_WARN_UNUSED_RESULT static PMC* pmc_constant_from_varargs(PARROT_INTERP, ARGIN(void *data), INTVAL index) __attribute__nonnull__(2); PARROT_WARN_UNUSED_RESULT PARROT_CANNOT_RETURN_NULL static PMC** pmc_param_from_c_args(PARROT_INTERP, ARGIN(va_list *args), INTVAL param_index) __attribute__nonnull__(2); PARROT_WARN_UNUSED_RESULT PARROT_CANNOT_RETURN_NULL static PMC** pmc_param_from_op(PARROT_INTERP, ARGIN(const opcode_t *raw_params), INTVAL param_index) __attribute__nonnull__(1) __attribute__nonnull__(2); static void set_call_from_varargs(PARROT_INTERP, ARGIN(PMC *signature), ARGIN(const char *sig), ARGMOD(va_list *args)) __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__nonnull__(3) __attribute__nonnull__(4) FUNC_MODIFIES(*args); PARROT_WARN_UNUSED_RESULT PARROT_CAN_RETURN_NULL static STRING* string_constant_from_op(PARROT_INTERP, ARGIN(const opcode_t *raw_params), INTVAL param_index) __attribute__nonnull__(1) __attribute__nonnull__(2); PARROT_CAN_RETURN_NULL PARROT_WARN_UNUSED_RESULT static STRING* string_constant_from_varargs(PARROT_INTERP, ARGIN(void *data), INTVAL index) __attribute__nonnull__(2); PARROT_WARN_UNUSED_RESULT PARROT_CANNOT_RETURN_NULL static STRING** string_param_from_c_args(PARROT_INTERP, ARGIN(va_list *args), INTVAL param_index) __attribute__nonnull__(2); PARROT_WARN_UNUSED_RESULT PARROT_CANNOT_RETURN_NULL static STRING** string_param_from_op(PARROT_INTERP, ARGIN(const opcode_t *raw_params), INTVAL param_index) __attribute__nonnull__(1) __attribute__nonnull__(2); #define ASSERT_ARGS_assign_default_param_value __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(arg_info) \ , PARROT_ASSERT_ARG(accessor)) #define ASSERT_ARGS_dissect_aggregate_arg __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(call_object) \ , PARROT_ASSERT_ARG(aggregate)) #define ASSERT_ARGS_extract_named_arg_from_op __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(call_object) \ , PARROT_ASSERT_ARG(name) \ , PARROT_ASSERT_ARG(raw_sig) \ , PARROT_ASSERT_ARG(raw_args)) #define ASSERT_ARGS_fill_params __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(raw_sig) \ , PARROT_ASSERT_ARG(arg_info) \ , PARROT_ASSERT_ARG(accessor)) #define ASSERT_ARGS_intval_constant_from_op __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(raw_params)) #define ASSERT_ARGS_intval_constant_from_varargs __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(data_unused)) #define ASSERT_ARGS_intval_param_from_c_args __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(args)) #define ASSERT_ARGS_intval_param_from_op __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(raw_params)) #define ASSERT_ARGS_named_argument_arity_error __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(named_arg_list)) #define ASSERT_ARGS_numval_constant_from_op __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(raw_params)) #define ASSERT_ARGS_numval_constant_from_varargs __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(data_unused)) #define ASSERT_ARGS_numval_param_from_c_args __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(args)) #define ASSERT_ARGS_numval_param_from_op __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(raw_params)) #define ASSERT_ARGS_parse_signature_string __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(signature) \ , PARROT_ASSERT_ARG(arg_flags)) #define ASSERT_ARGS_pmc_constant_from_op __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(raw_params)) #define ASSERT_ARGS_pmc_constant_from_varargs __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(data_unused)) #define ASSERT_ARGS_pmc_param_from_c_args __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(args)) #define ASSERT_ARGS_pmc_param_from_op __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(raw_params)) #define ASSERT_ARGS_set_call_from_varargs __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(signature) \ , PARROT_ASSERT_ARG(sig) \ , PARROT_ASSERT_ARG(args)) #define ASSERT_ARGS_string_constant_from_op __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(raw_params)) #define ASSERT_ARGS_string_constant_from_varargs __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(data_unused)) #define ASSERT_ARGS_string_param_from_c_args __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(args)) #define ASSERT_ARGS_string_param_from_op __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(raw_params)) /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */ /* HEADERIZER END: static */ /* =item C Take a raw signature and argument list from a set_args opcode and convert it to a CallContext PMC. =cut */ PARROT_EXPORT PARROT_WARN_UNUSED_RESULT PARROT_CANNOT_RETURN_NULL PMC* Parrot_pcc_build_sig_object_from_op(PARROT_INTERP, ARGIN_NULLOK(PMC *signature), ARGIN(PMC *raw_sig), ARGIN(opcode_t *raw_args)) { ASSERT_ARGS(Parrot_pcc_build_sig_object_from_op) PMC * const ctx = CURRENT_CONTEXT(interp); PMC *call_object; INTVAL *int_array; INTVAL arg_count; INTVAL arg_index = 0; INTVAL arg_named_count = 0; if (UNLIKELY(PMC_IS_NULL(signature))) call_object = Parrot_pmc_new(interp, enum_class_CallContext); else { call_object = signature; VTABLE_morph(interp, call_object, PMCNULL); } /* this macro is much, much faster than the VTABLE STRING comparisons */ PARROT_GC_WRITE_BARRIER(interp, call_object); SETATTR_CallContext_arg_flags(interp, call_object, raw_sig); GETATTR_FixedIntegerArray_size(interp, raw_sig, arg_count); GETATTR_FixedIntegerArray_int_array(interp, raw_sig, int_array); for (; arg_index < arg_count; ++arg_index) { const INTVAL arg_flags = int_array[arg_index]; const int constant = 0 != PARROT_ARG_CONSTANT_ISSET(arg_flags); const INTVAL raw_index = raw_args[arg_index + 2]; if (arg_named_count && !(arg_flags & PARROT_ARG_NAME)) Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, "named arguments must follow all positional arguments"); switch (PARROT_ARG_TYPE_MASK_MASK(arg_flags)) { case PARROT_ARG_INTVAL: VTABLE_push_integer(interp, call_object, constant ? raw_index : CTX_REG_INT(interp, ctx, raw_index)); break; case PARROT_ARG_FLOATVAL: VTABLE_push_float(interp, call_object, constant ? Parrot_pcc_get_num_constant(interp, ctx, raw_index) : CTX_REG_NUM(interp, ctx, raw_index)); break; case PARROT_ARG_STRING: { STRING * const string_value = constant ? Parrot_pcc_get_string_constant(interp, ctx, raw_index) : CTX_REG_STR(interp, ctx, raw_index); if (arg_flags & PARROT_ARG_NAME) { ++arg_index; ++arg_named_count; if (!PMC_IS_NULL(call_object) && VTABLE_exists_keyed_str(interp, call_object, string_value)) { Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, "duplicate named argument in call"); } extract_named_arg_from_op(interp, call_object, string_value, raw_sig, raw_args, arg_index); } else VTABLE_push_string(interp, call_object, string_value); break; } case PARROT_ARG_PMC: { PMC * const pmc_value = constant ? Parrot_pcc_get_pmc_constant(interp, ctx, raw_index) : CTX_REG_PMC(interp, ctx, raw_index); if (arg_flags & PARROT_ARG_FLATTEN) { dissect_aggregate_arg(interp, call_object, pmc_value); } else { VTABLE_push_pmc(interp, call_object, pmc_value); } break; } default: break; } } return call_object; } /* =item C Pulls in the next argument from a set_args opcode, and sets it as the value of a named argument in the CallContext PMC. =cut */ static void extract_named_arg_from_op(PARROT_INTERP, ARGMOD(PMC *call_object), ARGIN(STRING *name), ARGIN(PMC *raw_sig), ARGIN(opcode_t *raw_args), INTVAL arg_index) { ASSERT_ARGS(extract_named_arg_from_op) PMC * const ctx = CURRENT_CONTEXT(interp); const INTVAL arg_flags = VTABLE_get_integer_keyed_int(interp, raw_sig, arg_index); const int constant = 0 != PARROT_ARG_CONSTANT_ISSET(arg_flags); const INTVAL raw_index = raw_args[arg_index + 2]; switch (PARROT_ARG_TYPE_MASK_MASK(arg_flags)) { case PARROT_ARG_INTVAL: VTABLE_set_integer_keyed_str(interp, call_object, name, constant ? raw_index : CTX_REG_INT(interp, ctx, raw_index)); break; case PARROT_ARG_FLOATVAL: VTABLE_set_number_keyed_str(interp, call_object, name, constant ? Parrot_pcc_get_num_constant(interp, ctx, raw_index) : CTX_REG_NUM(interp, ctx, raw_index)); break; case PARROT_ARG_STRING: VTABLE_set_string_keyed_str(interp, call_object, name, constant ? Parrot_pcc_get_string_constant(interp, ctx, raw_index) : CTX_REG_STR(interp, ctx, raw_index)); break; case PARROT_ARG_PMC: VTABLE_set_pmc_keyed_str(interp, call_object, name, constant ? Parrot_pcc_get_pmc_constant(interp, ctx, raw_index) : CTX_REG_PMC(interp, ctx, raw_index)); break; default: break; } } /* =item C Takes an aggregate PMC and splits it up into individual arguments, adding each one to the CallContext PMC. If the aggregate is an array, its elements are added as positional arguments. If the aggregate is a hash, its key/value pairs are added as named arguments. =cut */ static void dissect_aggregate_arg(PARROT_INTERP, ARGMOD(PMC *call_object), ARGIN(PMC *aggregate)) { ASSERT_ARGS(dissect_aggregate_arg) if (VTABLE_does(interp, aggregate, CONST_STRING(interp, "array"))) { const INTVAL elements = VTABLE_elements(interp, aggregate); INTVAL index; for (index = 0; index < elements; ++index) { VTABLE_push_pmc(interp, call_object, VTABLE_get_pmc_keyed_int(interp, aggregate, index)); } } else if (VTABLE_does(interp, aggregate, CONST_STRING(interp, "hash"))) { const Hash * const hash = (Hash *)VTABLE_get_pointer(interp, aggregate); parrot_hash_iterate(hash, VTABLE_set_pmc_keyed_str(interp, call_object, (STRING *)_bucket->key, Parrot_hash_value_to_pmc(interp, hash, _bucket->value));); } else { Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, "flattened parameters must be a hash or array"); } } /* =item C Converts a variable list of C args into an existent CallContext PMC. The CallContext stores the original short signature string and an array of integer types to pass on to the multiple dispatch search. =cut */ PARROT_EXPORT void Parrot_pcc_set_call_from_c_args(PARROT_INTERP, ARGIN(PMC *signature), ARGIN(const char *sig), ...) { ASSERT_ARGS(Parrot_pcc_set_call_from_c_args) va_list args; va_start(args, sig); Parrot_pcc_set_call_from_varargs(interp, signature, sig, &args); va_end(args); } /* =item C Converts a variable list of C args into a CallContext PMC, creating a new one if needed. The CallContext stores the original short signature string and an array of integer types to pass on to the multiple dispatch search. =cut */ PARROT_EXPORT PARROT_WARN_UNUSED_RESULT PARROT_CANNOT_RETURN_NULL PMC* Parrot_pcc_build_call_from_c_args(PARROT_INTERP, ARGIN_NULLOK(PMC *signature), ARGIN(const char *sig), ...) { ASSERT_ARGS(Parrot_pcc_build_call_from_c_args) PMC *call_object; va_list args; va_start(args, sig); call_object = Parrot_pcc_build_call_from_varargs(interp, signature, sig, &args); va_end(args); return call_object; } /* =item C Helper for Parrot_pcc_build_call_from_varargs and Parrot_pcc_set_call_from_varargs. =cut */ static void set_call_from_varargs(PARROT_INTERP, ARGIN(PMC *signature), ARGIN(const char *sig), ARGMOD(va_list *args)) { ASSERT_ARGS(set_call_from_varargs) PMC *arg_flags = PMCNULL; INTVAL i = 0; parse_signature_string(interp, sig, &arg_flags); SETATTR_CallContext_arg_flags(interp, signature, arg_flags); /* Process the varargs list */ for (; sig[i] != '\0'; ++i) { const INTVAL type = sig[i]; /* Regular arguments just set the value */ switch (type) { case 'P': { const INTVAL type_lookahead = sig[i+1]; PMC * const pmc_arg = va_arg(*args, PMC *); if (type_lookahead == 'f') { dissect_aggregate_arg(interp, signature, pmc_arg); ++i; /* skip 'f' */ } else if (type_lookahead == 'i') { if (i) Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, "Dispatch: only the first argument can be an invocant"); else { VTABLE_push_pmc(interp, signature, pmc_arg); ++i; /* skip 'i' */ } } else VTABLE_push_pmc(interp, signature, pmc_arg); break; } case 'S': VTABLE_push_string(interp, signature, va_arg(*args, STRING *)); break; case 'I': VTABLE_push_integer(interp, signature, va_arg(*args, INTVAL)); break; case 'N': VTABLE_push_float(interp, signature, va_arg(*args, FLOATVAL)); break; case '-': return; break; default: Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, "Dispatch: invalid argument type %c!", type); } } } /* =item C Converts a varargs list into an existent CallContext PMC. The CallContext stores the original short signature string and an array of integer types to pass on to the multiple dispatch search. =cut */ PARROT_EXPORT void Parrot_pcc_set_call_from_varargs(PARROT_INTERP, ARGIN(PMC *signature), ARGIN(const char *sig), ARGMOD(va_list *args)) { ASSERT_ARGS(Parrot_pcc_set_call_from_varargs) PARROT_ASSERT(PMCNULL != signature); VTABLE_morph(interp, signature, PMCNULL); set_call_from_varargs(interp, signature, sig, args); } /* =item C Converts a varargs list into a CallContext PMC, creating a new one if needed. The CallContext stores the original short signature string and an array of integer types to pass on to the multiple dispatch search. =cut */ PARROT_EXPORT PARROT_WARN_UNUSED_RESULT PARROT_CANNOT_RETURN_NULL PMC* Parrot_pcc_build_call_from_varargs(PARROT_INTERP, ARGIN_NULLOK(PMC *signature), ARGIN(const char *sig), ARGMOD(va_list *args)) { ASSERT_ARGS(Parrot_pcc_build_call_from_varargs) PMC *call_object; if (PMC_IS_NULL(signature)) call_object = Parrot_pmc_new(interp, enum_class_CallContext); else { call_object = signature; VTABLE_morph(interp, call_object, PMCNULL); } set_call_from_varargs(interp, call_object, sig, args); return call_object; } /* =item C Converts a varargs list into a CallContext PMC. The CallContext stores the original short signature string and an array of integer types to pass on to the multiple dispatch search. =cut */ PARROT_EXPORT PARROT_WARN_UNUSED_RESULT PARROT_CANNOT_RETURN_NULL PMC* Parrot_pcc_build_sig_object_from_varargs(PARROT_INTERP, ARGIN_NULLOK(PMC *obj), ARGIN(const char *sig), va_list args) { ASSERT_ARGS(Parrot_pcc_build_sig_object_from_varargs) PMC * arg_flags = PMCNULL; PMC * const call_object = Parrot_pmc_new(interp, enum_class_CallContext); INTVAL in_return_sig = 0; INTVAL i; int append_pi = 1; /* empty args or empty returns */ if (*sig == '-' || *sig == '\0') return call_object; parse_signature_string(interp, sig, &arg_flags); SETATTR_CallContext_arg_flags(interp, call_object, arg_flags); /* Process the varargs list */ for (i = 0; sig[i] != '\0'; ++i) { const INTVAL type = sig[i]; /* Don't process returns */ if (in_return_sig) break; /* Regular arguments just set the value */ switch (type) { case 'I': VTABLE_push_integer(interp, call_object, va_arg(args, INTVAL)); break; case 'N': VTABLE_push_float(interp, call_object, va_arg(args, FLOATVAL)); break; case 'S': VTABLE_push_string(interp, call_object, va_arg(args, STRING *)); break; case 'P': { const INTVAL type_lookahead = sig[i+1]; PMC * const pmc_arg = va_arg(args, PMC *); if (type_lookahead == 'f') { dissect_aggregate_arg(interp, call_object, pmc_arg); ++i; /* skip 'f' */ } else { VTABLE_push_pmc(interp, call_object, pmc_arg); if (type_lookahead == 'i') { if (i != 0) Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, "Dispatch: only the first argument " "can be an invocant"); ++i; /* skip 'i' */ append_pi = 0; /* Don't prepend Pi to signature */ } } break; } case '-': in_return_sig = 1; break; default: Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, "Dispatch: invalid argument type %c!", type); } } /* Add invocant to the front of the arguments iff needed */ if (!PMC_IS_NULL(obj) && append_pi) VTABLE_unshift_pmc(interp, call_object, obj); return call_object; } /* =item C Gets args for the current function call and puts them into position. First it gets the positional non-slurpy parameters, then the positional slurpy parameters, then the named parameters, and finally the named slurpy parameters. =cut */ static void fill_params(PARROT_INTERP, ARGMOD_NULLOK(PMC *call_object), ARGIN(PMC *raw_sig), ARGIN(void *arg_info), ARGIN(const struct pcc_funcs_ptr *accessor), Errors_classes direction) { ASSERT_ARGS(fill_params) INTVAL *raw_params; Hash *named_used_list = NULL; INTVAL param_index = 0; INTVAL arg_index = 0; INTVAL named_count = 0; INTVAL param_count; INTVAL positional_args; /* Check if we should be throwing errors. This is configured separately * for parameters and return values. */ const INTVAL err_check = PARROT_ERRORS_test(interp, direction); GETATTR_FixedIntegerArray_size(interp, raw_sig, param_count); /* Get number of positional args */ if (UNLIKELY(PMC_IS_NULL(call_object))) { /* A null call object is fine if there are no arguments and no returns. */ if (LIKELY(param_count == 0)) return; if (err_check) { Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, "too few arguments: 0 passed, %d expected", param_count); } positional_args = 0; call_object = NULL; /* so we don't need to use PMC_IS_NULL below */ } else { GETATTR_CallContext_num_positionals(interp, call_object, positional_args); } GETATTR_FixedIntegerArray_int_array(interp, raw_sig, raw_params); /* EXPERIMENTAL! This block adds provisional :call_sig param support on the callee side only. Does not add :call_sig arg support on the caller side. This is not the final form of the algorithm, but should provide the tools that HLL designers need in the interim. */ if (LIKELY(param_count > 2 || param_count == 0)) /* help branch predictors */; else { const INTVAL second_flag = raw_params[param_count - 1]; if (second_flag & PARROT_ARG_CALL_SIG) { *accessor->pmc(interp, arg_info, param_count - 1) = call_object ? call_object : PMCNULL; if (param_count == 1) return; } } /* First iterate over positional args and positional parameters. */ while (param_index < param_count) { INTVAL param_flags = raw_params[param_index]; /* If it's a call_sig, we're done. */ if (param_flags & PARROT_ARG_CALL_SIG) return; /* If the parameter is slurpy, collect all remaining positional * arguments into an array.*/ if (param_flags & PARROT_ARG_SLURPY_ARRAY) { /* Can't handle named slurpy here, go to named argument handling */ if (!(param_flags & PARROT_ARG_NAME)) { PMC *collect_positional; int j; INTVAL num_positionals = positional_args - arg_index; if (num_positionals < 0) num_positionals = 0; if (named_count > 0) { if (named_used_list != NULL) Parrot_hash_destroy(interp, named_used_list); Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, "named parameters must follow all positional parameters"); } collect_positional = Parrot_pmc_new_init_int(interp, Parrot_hll_get_ctx_HLL_type(interp, enum_class_ResizablePMCArray), num_positionals); for (j = 0; arg_index < positional_args; ++arg_index) VTABLE_set_pmc_keyed_int(interp, collect_positional, j++, VTABLE_get_pmc_keyed_int(interp, call_object, arg_index)); *accessor->pmc(interp, arg_info, param_index) = collect_positional; ++param_index; } break; /* Terminate the positional arg loop. */ } /* We have a positional argument, fill the parameter with it. */ if (arg_index < positional_args) { /* Fill a named parameter with a positional argument. */ if (param_flags & PARROT_ARG_NAME) { STRING *param_name; if (!(param_flags & PARROT_ARG_STRING)) { if (named_used_list != NULL) Parrot_hash_destroy(interp, named_used_list); Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, "named parameters must have a name specified"); } param_name = PARROT_ARG_CONSTANT_ISSET(param_flags) ? accessor->string_constant(interp, arg_info, param_index) : *accessor->string(interp, arg_info, param_index); ++named_count; ++param_index; if (param_index >= param_count) continue; param_flags = raw_params[param_index]; /* Mark the name as used, cannot be filled again. */ if (named_used_list == NULL) /* Only created if needed. */ named_used_list = Parrot_hash_create(interp, enum_type_INTVAL, Hash_key_type_STRING); Parrot_hash_put(interp, named_used_list, param_name, (void *)1); } /* XXX Big L1 instr fetch miss */ else if (named_count > 0) { if (named_used_list != NULL) Parrot_hash_destroy(interp, named_used_list); Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, "named parameters must follow all positional parameters"); } /* Check for :lookahead parameter goes here. */ /* Go ahead and fill the parameter with a positional argument. */ switch (PARROT_ARG_TYPE_MASK_MASK(param_flags)) { case PARROT_ARG_PMC: *accessor->pmc(interp, arg_info, param_index) = VTABLE_get_pmc_keyed_int(interp, call_object, arg_index); break; case PARROT_ARG_STRING: *accessor->string(interp, arg_info, param_index) = VTABLE_get_string_keyed_int(interp, call_object, arg_index); break; case PARROT_ARG_INTVAL: *accessor->intval(interp, arg_info, param_index) = VTABLE_get_integer_keyed_int(interp, call_object, arg_index); break; case PARROT_ARG_FLOATVAL: *accessor->numval(interp, arg_info, param_index) = VTABLE_get_number_keyed_int(interp, call_object, arg_index); break; default: if (named_used_list != NULL) Parrot_hash_destroy(interp, named_used_list); Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, "invalid parameter type"); break; } /* Mark the option flag for the filled parameter. */ if (param_flags & PARROT_ARG_OPTIONAL) { if (param_index + 1 < param_count) { const int next_param_flags = raw_params[param_index + 1]; if (next_param_flags & PARROT_ARG_OPT_FLAG) { ++param_index; *accessor->intval(interp, arg_info, param_index) = 1; } } } } /* We have no more positional arguments, fill the optional parameter * with a default value. */ else if (param_flags & PARROT_ARG_OPTIONAL) { /* We don't handle optional named params here, handle them in the * next loop. */ if (param_flags & PARROT_ARG_NAME) break; assign_default_param_value(interp, param_index, param_flags, arg_info, accessor); /* Mark the option flag for the parameter to FALSE, it was filled * with a default value. */ if (param_index + 1 < param_count) { const INTVAL next_param_flags = raw_params[param_index + 1]; if (next_param_flags & PARROT_ARG_OPT_FLAG) { ++param_index; *accessor->intval(interp, arg_info, param_index) = 0; } } } /* We don't have an argument for the parameter, and it's not optional, * so it's an error. */ else { /* We don't handle named params here, go to the next loop. */ if (param_flags & PARROT_ARG_NAME) break; if (err_check) { if (named_used_list != NULL) Parrot_hash_destroy(interp, named_used_list); Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, "too few positional arguments: " "%d passed, %d (or more) expected", positional_args, param_index + 1); } assign_default_param_value(interp, param_index, param_flags, arg_info, accessor); } /* Go on to next argument and parameter. */ ++arg_index; ++param_index; } if (err_check && arg_index < positional_args) { /* We have extra positional args left over. */ if (named_used_list != NULL) Parrot_hash_destroy(interp, named_used_list); Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, "too many positional arguments: %d passed, %d expected", positional_args, arg_index); } /* Now iterate over the named arguments and parameters. */ while (param_index < param_count) { STRING *param_name; INTVAL param_flags = raw_params[param_index]; /* All remaining parameters must be named. */ if (!(param_flags & PARROT_ARG_NAME)) { if (named_used_list != NULL) Parrot_hash_destroy(interp, named_used_list); Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, "named parameters must follow all positional parameters"); } /* Collected ("slurpy") named parameter */ if (param_flags & PARROT_ARG_SLURPY_ARRAY) { PMC * const collect_named = Parrot_pmc_new(interp, Parrot_hll_get_ctx_HLL_type(interp, enum_class_Hash)); Hash *h = NULL; /* Early exit to avoid vtable call */ if (call_object) GETATTR_CallContext_hash(interp, call_object, h); if (h && h->entries) { /* Named argument iteration. */ parrot_hash_iterate(h, STRING * const name = (STRING *)_bucket->key; if ((named_used_list == NULL) || !Parrot_hash_exists(interp, named_used_list, name)) { VTABLE_set_pmc_keyed_str(interp, collect_named, name, VTABLE_get_pmc_keyed_str(interp, call_object, name)); /* Mark the name as used, cannot be filled again. */ if (named_used_list==NULL) /* Only created if needed. */ named_used_list = Parrot_hash_create(interp, enum_type_INTVAL, Hash_key_type_STRING); Parrot_hash_put(interp, named_used_list, name, (void *)1); ++named_count; }); } *accessor->pmc(interp, arg_info, param_index) = collect_named; break; /* End of named parameters. */ } /* Store the name. */ if (!(param_flags & PARROT_ARG_STRING)) { if (named_used_list != NULL) Parrot_hash_destroy(interp, named_used_list); Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, "named parameters must have a name specified"); } param_name = PARROT_ARG_CONSTANT_ISSET(param_flags) ? accessor->string_constant(interp, arg_info, param_index) : *accessor->string(interp, arg_info, param_index); if (!STRING_IS_NULL(param_name)) { /* The next parameter is the actual value. */ if (++param_index >= param_count) continue; param_flags = raw_params[param_index]; if (call_object && VTABLE_exists_keyed_str(interp, call_object, param_name)) { /* Mark the name as used, cannot be filled again. */ if (named_used_list==NULL) /* Only created if needed. */ named_used_list = Parrot_hash_create(interp, enum_type_INTVAL, Hash_key_type_STRING); Parrot_hash_put(interp, named_used_list, param_name, (void *)1); ++named_count; /* Fill the named parameter. */ switch (PARROT_ARG_TYPE_MASK_MASK(param_flags)) { case PARROT_ARG_INTVAL: *accessor->intval(interp, arg_info, param_index) = VTABLE_get_integer_keyed_str(interp, call_object, param_name); break; case PARROT_ARG_FLOATVAL: *accessor->numval(interp, arg_info, param_index) = VTABLE_get_number_keyed_str(interp, call_object, param_name); break; case PARROT_ARG_STRING: *accessor->string(interp, arg_info, param_index) = VTABLE_get_string_keyed_str(interp, call_object, param_name); break; case PARROT_ARG_PMC: *accessor->pmc(interp, arg_info, param_index) = VTABLE_get_pmc_keyed_str(interp, call_object, param_name); break; default: if (named_used_list != NULL) Parrot_hash_destroy(interp, named_used_list); Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, "invalid parameter type"); break; } /* Mark the option flag for the filled parameter. */ if (param_flags & PARROT_ARG_OPTIONAL) { if (param_index + 1 < param_count) { const INTVAL next_param_flags = raw_params[param_index + 1]; if (next_param_flags & PARROT_ARG_OPT_FLAG) { ++param_index; *accessor->intval(interp, arg_info, param_index) = 1; } } } } else if (param_flags & PARROT_ARG_OPTIONAL) { assign_default_param_value(interp, param_index, param_flags, arg_info, accessor); /* Mark the option flag for the parameter to FALSE; * it was filled with a default value. */ if (param_index + 1 < param_count) { const INTVAL next_param_flags = raw_params[param_index + 1]; if (next_param_flags & PARROT_ARG_OPT_FLAG) { ++param_index; *accessor->intval(interp, arg_info, param_index) = 0; } } } /* We don't have an argument for the parameter, and it's not * optional, so it's an error. */ else { if (err_check) { if (named_used_list != NULL) Parrot_hash_destroy(interp, named_used_list); Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, "too few named arguments: " "no argument for required parameter '%S'", param_name); } } } ++param_index; } /* Double check that all named arguments were assigned to parameters. */ if (err_check) { Hash *h = NULL; /* Early exit to avoid vtable call */ if (call_object) GETATTR_CallContext_hash(interp, call_object, h); if (!h || !h->entries) { if (named_used_list != NULL) Parrot_hash_destroy(interp, named_used_list); return; } if (named_used_list == NULL || (int)h->entries > named_count) named_argument_arity_error(interp, h->entries, named_used_list, h); } if (named_used_list != NULL) Parrot_hash_destroy(interp, named_used_list); } /* =item C In the case of a mismatch between passed and expected named arguments, throw a helpful exception. =cut */ PARROT_COLD PARROT_DOES_NOT_RETURN static void named_argument_arity_error(PARROT_INTERP, int named_arg_count, ARGFREE(Hash *named_used_list), ARGIN(Hash *named_arg_list)) { ASSERT_ARGS(named_argument_arity_error) if (named_used_list == NULL) { Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, "too many named arguments: %d passed, 0 used", named_arg_count); } /* Named argument iteration. */ parrot_hash_iterate(named_arg_list, STRING * const name = (STRING *)_bucket->key; if (!Parrot_hash_exists(interp, named_used_list, name)) { Parrot_hash_destroy(interp, named_used_list); Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, "too many named arguments: '%S' not used", name); };); Parrot_hash_destroy(interp, named_used_list); Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, "Invalid named arguments, unspecified error"); } /* =item C Assign an appropriate default value to the parameter depending on its type =cut */ static void assign_default_param_value(PARROT_INTERP, INTVAL param_index, INTVAL param_flags, ARGIN(void *arg_info), ARGIN(const struct pcc_funcs_ptr *accessor)) { ASSERT_ARGS(assign_default_param_value) switch (PARROT_ARG_TYPE_MASK_MASK(param_flags)) { case PARROT_ARG_INTVAL: *accessor->intval(interp, arg_info, param_index) = 0; break; case PARROT_ARG_FLOATVAL: *accessor->numval(interp, arg_info, param_index) = 0.0; break; case PARROT_ARG_STRING: *accessor->string(interp, arg_info, param_index) = STRINGNULL; break; case PARROT_ARG_PMC: *accessor->pmc(interp, arg_info, param_index) = PMCNULL; break; default: Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, "invalid parameter type"); break; } } /* =item C Gets args for the current function call and puts them into position. First it gets the positional non-slurpy parameters, then the positional slurpy parameters, then the named parameters, and finally the named slurpy parameters. C used to distinguish set_returns vs set_params for checking different flags. =cut */ PARROT_EXPORT void Parrot_pcc_fill_params_from_op(PARROT_INTERP, ARGMOD_NULLOK(PMC *call_object), ARGIN(PMC *raw_sig), ARGIN(opcode_t *raw_params), Errors_classes direction) { ASSERT_ARGS(Parrot_pcc_fill_params_from_op) static const pcc_funcs_ptr function_pointers = { (intval_ptr_func_t)intval_param_from_op, (numval_ptr_func_t)numval_param_from_op, (string_ptr_func_t)string_param_from_op, (pmc_ptr_func_t)pmc_param_from_op, (intval_func_t)intval_constant_from_op, (numval_func_t)numval_constant_from_op, (string_func_t)string_constant_from_op, (pmc_func_t)pmc_constant_from_op, }; fill_params(interp, call_object, raw_sig, raw_params, &function_pointers, direction); } /* =item C Gets args for the current function call and puts them into position. First it gets the positional non-slurpy parameters, then the positional slurpy parameters, then the named parameters, and finally the named slurpy parameters. The signature is a string in the format used for C, but with no return arguments. The parameters are passed in as a list of references to the destination variables. =cut */ PARROT_EXPORT void Parrot_pcc_fill_params_from_c_args(PARROT_INTERP, ARGMOD(PMC *call_object), ARGIN(const char *signature), ...) { ASSERT_ARGS(Parrot_pcc_fill_params_from_c_args) va_list args; va_start(args, signature); Parrot_pcc_fill_params_from_varargs(interp, call_object, signature, &args, PARROT_ERRORS_PARAM_COUNT_FLAG); va_end(args); } /* =item C Gets args for the current function call and puts them into position. First it gets the positional non-slurpy parameters, then the positional slurpy parameters, then the named parameters, and finally the named slurpy parameters. The signature is a string in the format used for C, but with no return arguments. The parameters are passed in as a list of references to the destination variables. =cut */ PARROT_EXPORT void Parrot_pcc_fill_params_from_varargs(PARROT_INTERP, ARGMOD_NULLOK(PMC *call_object), ARGIN(const char *signature), ARGMOD(va_list *args), Errors_classes direction) { ASSERT_ARGS(Parrot_pcc_fill_params_from_varargs) PMC *raw_sig = PMCNULL; static const pcc_funcs_ptr function_pointers = { (intval_ptr_func_t)intval_param_from_c_args, (numval_ptr_func_t)numval_param_from_c_args, (string_ptr_func_t)string_param_from_c_args, (pmc_ptr_func_t)pmc_param_from_c_args, (intval_func_t)intval_constant_from_varargs, (numval_func_t)numval_constant_from_varargs, (string_func_t)string_constant_from_varargs, (pmc_func_t)pmc_constant_from_varargs, }; /* empty args or empty returns */ if (*signature == '-' || *signature == '\0') return; parse_signature_string(interp, signature, &raw_sig); fill_params(interp, call_object, raw_sig, args, &function_pointers, direction); } /* =item C Splits a full signature string and creates call and return signature strings. The two result strings should be passed in as references to a C string. =cut */ void Parrot_pcc_split_signature_string(ARGIN(const char *signature), ARGOUT(const char **arg_sig), ARGOUT(const char **return_sig)) { ASSERT_ARGS(Parrot_pcc_split_signature_string) const char *cur; *arg_sig = signature; for (cur = signature; *cur != '\0'; ++cur) { if (*cur == '-') { *return_sig = cur + 2; return; } } *return_sig = cur; } /* =item C Parses a signature string and creates call and return signature integer arrays. The two integer arrays should be passed in as references to a PMC. =cut */ static void parse_signature_string(PARROT_INTERP, ARGIN(const char *signature), ARGMOD(PMC **arg_flags)) { ASSERT_ARGS(parse_signature_string) PMC *current_array; const char *x; INTVAL flags = 0; INTVAL set = 0; INTVAL count = 0; for (x = signature; *x; ++x) { if (*x == '-') break; switch (*x) { case 'I': count++; break; case 'N': count++; break; case 'S': count++; break; case 'P': count++; break; default: break; } } if (UNLIKELY(PMC_IS_NULL(*arg_flags))) current_array = *arg_flags = Parrot_pmc_new_init_int(interp, enum_class_ResizableIntegerArray, count); else { current_array = *arg_flags; VTABLE_set_integer_native(interp, current_array, count); } count = 0; for (x = signature; *x != '\0'; ++x) { /* detect -> separator */ if (*x == '-') break; /* parse arg type */ else if (isupper((unsigned char)*x)) { /* Starting a new argument, so store the previous argument, * if there was one. */ if (set) { VTABLE_set_integer_keyed_int(interp, current_array, count++, flags); set = 0; } switch (*x) { case 'I': flags = PARROT_ARG_INTVAL; ++set; break; case 'N': flags = PARROT_ARG_FLOATVAL; ++set; break; case 'S': flags = PARROT_ARG_STRING; ++set; break; case 'P': flags = PARROT_ARG_PMC; ++set; break; case ' ': break; default: Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, "invalid signature string element %c!", *x); } } /* parse arg adverbs */ else if (islower((unsigned char)*x)) { switch (*x) { case 'c': flags |= PARROT_ARG_CONSTANT; break; case 'f': flags |= PARROT_ARG_FLATTEN; break; case 'i': flags |= PARROT_ARG_INVOCANT; break; case 'l': flags |= PARROT_ARG_LOOKAHEAD; break; case 'n': flags |= PARROT_ARG_NAME; break; case 'o': flags |= PARROT_ARG_OPTIONAL; break; case 'p': flags |= PARROT_ARG_OPT_FLAG; break; case 's': flags |= PARROT_ARG_SLURPY_ARRAY; break; case ' ': break; default: Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, "invalid signature string element %c!", *x); } } } /* Store the final argument, if there was one. */ if (set) VTABLE_set_integer_keyed_int(interp, current_array, count, flags); } /* =item C Parses a signature string and creates call and return signature integer arrays. The two integer arrays should be passed in as references to a PMC. =cut */ PARROT_CAN_RETURN_NULL void Parrot_pcc_parse_signature_string(PARROT_INTERP, ARGIN(STRING *signature), ARGMOD(PMC **arg_flags), ARGMOD(PMC **return_flags)) { ASSERT_ARGS(Parrot_pcc_parse_signature_string) char * const s = Parrot_str_to_cstring(interp, signature); const char *arg_sig, *ret_sig; Parrot_pcc_split_signature_string(s, &arg_sig, &ret_sig); *arg_flags = PMCNULL; *return_flags = PMCNULL; parse_signature_string(interp, arg_sig, arg_flags); parse_signature_string(interp, ret_sig, return_flags); Parrot_str_free_cstring(s); } /* =item C merge in signatures for tailcall =cut */ void Parrot_pcc_merge_signature_for_tailcall(PARROT_INTERP, ARGMOD(PMC *parent), ARGMOD(PMC *tailcall)) { ASSERT_ARGS(Parrot_pcc_merge_signature_for_tailcall) if (LIKELY(PMC_IS_NULL(parent) || PMC_IS_NULL(tailcall) || (parent == tailcall))) return; else { /* Broke encapsulation. Direct poking into CallContext is much faster */ PMC * temp; /* Store raw signature */ GETATTR_CallContext_return_flags(interp, parent, temp); SETATTR_CallContext_return_flags(interp, tailcall, temp); GETATTR_CallContext_current_cont(interp, parent, temp); SETATTR_CallContext_current_cont(interp, tailcall, temp); PARROT_GC_WRITE_BARRIER(interp, tailcall); } } /* Get the appropriate argument value from the op. =item C =item C =item C =item C Get the appropriate parameter value from the op (these are pointers, so the argument value can be stored into them.) =item C =item C =item C =item C =item C =item C =item C =item C Get the appropriate argument value from varargs. =item C =item C =item C =item C Get the appropriate parameter value from varargs (these are pointers, so they can be set with the argument value). =item C =item C =item C =item C Parrot constants cannot be passed from varargs, so these functions are dummies that throw exceptions. =item C =item C =item C =item C - More specific comments can be added later =cut */ PARROT_WARN_UNUSED_RESULT PARROT_CANNOT_RETURN_NULL static INTVAL* intval_param_from_op(PARROT_INTERP, ARGIN(const opcode_t *raw_params), INTVAL param_index) { ASSERT_ARGS(intval_param_from_op) const INTVAL raw_index = raw_params[param_index + 2]; return ®_INT(interp, raw_index); } PARROT_WARN_UNUSED_RESULT PARROT_CANNOT_RETURN_NULL static FLOATVAL* numval_param_from_op(PARROT_INTERP, ARGIN(const opcode_t *raw_params), INTVAL param_index) { ASSERT_ARGS(numval_param_from_op) const INTVAL raw_index = raw_params[param_index + 2]; return ®_NUM(interp, raw_index); } PARROT_WARN_UNUSED_RESULT PARROT_CANNOT_RETURN_NULL static STRING** string_param_from_op(PARROT_INTERP, ARGIN(const opcode_t *raw_params), INTVAL param_index) { ASSERT_ARGS(string_param_from_op) const INTVAL raw_index = raw_params[param_index + 2]; return ®_STR(interp, raw_index); } PARROT_WARN_UNUSED_RESULT PARROT_CANNOT_RETURN_NULL static PMC** pmc_param_from_op(PARROT_INTERP, ARGIN(const opcode_t *raw_params), INTVAL param_index) { ASSERT_ARGS(pmc_param_from_op) const INTVAL raw_index = raw_params[param_index + 2]; return ®_PMC(interp, raw_index); } PARROT_WARN_UNUSED_RESULT static INTVAL intval_constant_from_op(SHIM_INTERP, ARGIN(const opcode_t *raw_params), INTVAL param_index) { ASSERT_ARGS(intval_constant_from_op) const INTVAL raw_index = raw_params[param_index + 2]; return raw_index; } PARROT_WARN_UNUSED_RESULT static FLOATVAL numval_constant_from_op(PARROT_INTERP, ARGIN(const opcode_t *raw_params), INTVAL param_index) { ASSERT_ARGS(numval_constant_from_op) const INTVAL raw_index = raw_params[param_index + 2]; return Parrot_pcc_get_num_constant(interp, CURRENT_CONTEXT(interp), raw_index); } PARROT_WARN_UNUSED_RESULT PARROT_CAN_RETURN_NULL static STRING* string_constant_from_op(PARROT_INTERP, ARGIN(const opcode_t *raw_params), INTVAL param_index) { ASSERT_ARGS(string_constant_from_op) const INTVAL raw_index = raw_params[param_index + 2]; return Parrot_pcc_get_string_constant(interp, CURRENT_CONTEXT(interp), raw_index); } PARROT_WARN_UNUSED_RESULT PARROT_CAN_RETURN_NULL static PMC* pmc_constant_from_op(PARROT_INTERP, ARGIN(const opcode_t *raw_params), INTVAL param_index) { ASSERT_ARGS(pmc_constant_from_op) const INTVAL raw_index = raw_params[param_index + 2]; return Parrot_pcc_get_pmc_constant(interp, CURRENT_CONTEXT(interp), raw_index); } PARROT_WARN_UNUSED_RESULT PARROT_CANNOT_RETURN_NULL static INTVAL* intval_param_from_c_args(SHIM_INTERP, ARGIN(va_list *args), SHIM(INTVAL param_index)) { ASSERT_ARGS(intval_param_from_c_args) return va_arg(*args, INTVAL*); } PARROT_WARN_UNUSED_RESULT PARROT_CANNOT_RETURN_NULL static FLOATVAL* numval_param_from_c_args(SHIM_INTERP, ARGIN(va_list *args), SHIM(INTVAL param_index)) { ASSERT_ARGS(numval_param_from_c_args) return va_arg(*args, FLOATVAL*); } PARROT_WARN_UNUSED_RESULT PARROT_CANNOT_RETURN_NULL static STRING** string_param_from_c_args(SHIM_INTERP, ARGIN(va_list *args), SHIM(INTVAL param_index)) { ASSERT_ARGS(string_param_from_c_args) return va_arg(*args, STRING**); } PARROT_WARN_UNUSED_RESULT PARROT_CANNOT_RETURN_NULL static PMC** pmc_param_from_c_args(SHIM_INTERP, ARGIN(va_list *args), SHIM(INTVAL param_index)) { ASSERT_ARGS(pmc_param_from_c_args) return va_arg(*args, PMC**); } PARROT_WARN_UNUSED_RESULT static INTVAL intval_constant_from_varargs(SHIM_INTERP, ARGIN(SHIM(void *data)), SHIM(INTVAL index)) { ASSERT_ARGS(intval_constant_from_varargs) PARROT_FAILURE("Wrong call"); return 0; } PARROT_WARN_UNUSED_RESULT static FLOATVAL numval_constant_from_varargs(SHIM_INTERP, ARGIN(SHIM(void *data)), SHIM(INTVAL index)) { ASSERT_ARGS(numval_constant_from_varargs) PARROT_FAILURE("Wrong call"); return 0.0; } PARROT_CAN_RETURN_NULL PARROT_WARN_UNUSED_RESULT static STRING* string_constant_from_varargs(SHIM_INTERP, ARGIN(SHIM(void *data)), SHIM(INTVAL index)) { ASSERT_ARGS(string_constant_from_varargs) PARROT_FAILURE("Wrong call"); return NULL; } PARROT_CAN_RETURN_NULL PARROT_WARN_UNUSED_RESULT static PMC* pmc_constant_from_varargs(SHIM_INTERP, ARGIN(SHIM(void *data)), SHIM(INTVAL index)) { ASSERT_ARGS(pmc_constant_from_varargs) PARROT_FAILURE("Wrong call"); return PMCNULL; } /* =back =head1 SEE ALSO F, F, F. =cut */ /* * Local variables: * c-file-style: "parrot" * End: * vim: expandtab shiftwidth=4 cinoptions='\:2=2' : */ chXX_hlls.pod000644000765000765 2655111533177634 17113 0ustar00bruce000000000000parrot-6.6.0/docs/book/draft=pod =head1 HLLs and Interoperation Z =head2 Parrot HLL Environment In the earliest days Parrot was designed to be the single-purpose backend for the Perl 6 language. It quickly blossomed beyond that, and now has a much grander purpose: to host all dynamic languages, and to host them together on a single platform. If we look back through the history of dynamic programming languages, they've had a more difficult time interoperating with each other then compiled languages have because compiled languages operate at the same machine-code level and typically can make use of the same application binary interface (ABI). With the right compiler settings, programs written in Visual Basic can interoperate with programs written in C N, which can call functions written in C++, in Ada, Fortran, Pascal and so on. To try to mix two common dynamic languages, like Perl and Python, or Ruby and PHP, you would need to write some kind of custom "glue" function to try to include an interpreter object from one language as a library for another language, and then write code to try and get the parser for one to interact nicely with the parser for the other. It's a nightmare, frankly, and you don't see it happen too often. In Parrot, the situation is different because high level languages (HLL) are almost all written with the PCT tools, and are compiled to the same PIR and PBC code. Once compiled into PBC, a library written in any HLL language can be loaded and called by any other HLL N. A language can have a syntax to include code snippets from other languages inline in the same file. We can write a binding for a popular library such as opengl or xlib once, and include that library into any language that needs it. Compare this to the current situation where a library like Gtk2 needs to have bindings for every language that wants to use it. In short, Parrot should make interoperation easier for everybody. This chapter is going to talk about HLLs, the way they operate, and the way they interoperate on Parrot. =head2 HLLs on Parrot =head2 Working with HLLs =head3 Fakecutables It's possible to turn compilers created with PCT into stand-alone executables that run without the Parrot executable. To do this, the compiler bytecode is linked together with a small driver program in C and the Parrot library, C X. These programs have been given a special name by the Parrot development community: I X. They're called fake because the PBC is not converted to native machine code like in a normal binary executable file, but instead is left in original PBC format. =head3 Compiler Objects The C opcode has two forms that are used with HLL compilers. The first form stores an object as a compiler object to be retrieved later, and the second form retrieves a stored compiler object for a given language. The exact type of compiler object stored with C can vary for each different language implementation, although most of the languages using PCT will have a common form. If a compiler object is in register C<$P0>, it can be stored using the following C syntax: =begin PIR_FRAGMENT compreg 'MyCompiler', $P0 =end PIR_FRAGMENT There are two built-in compiler objects: One for PIR and one for PASM. These two don't need to be stored first, they can simply be retrieved and used. The PIR and PASM compiler objects are Sub PMCs that take a single string argument and return an array PMC containing a list of all the compiled subroutines from the string. Other compiler objects might be different entirely, and may need to be used in different ways. A common convention is for a compiler to be an object with a C method. This is done with PCT-based compilers and for languages who use a stateful compiler. Compiler objects allow programs in Parrot to compile arbitrary code strings at runtime and execute them. This ability, to dynamically compile code that is represented in a string variable at runtime, is of fundamental importance to many modern dynamic languages. Here's an example using the PIR compiler: =begin PIR_FRAGMENT .local string code code = "..." $P0 = compreg 'PIR' # Get the compiler object $P1 = $P0(code) # Compile the string variable "code" =end PIR_FRAGMENT The returned value from invoking the compiler object is an array of PMCs that contains the various executable subroutines from the compiled source. Here's a more verbose example of this: =begin PIR_FRAGMENT $P0 = compreg 'PIR' $S0 = <<"END_OF_CODE" .sub 'hello' say 'hello world!' .end .sub 'goodbye' say 'goodbye world!' .end END_OF_CODE $P1 = $P0($S0) $P2 = $P1[0] # The sub "hello" $P3 = $P1[0] # The sub "goodbye" $P2() # "hello world!" $P3() # "goodbye world!" =end PIR_FRAGMENT Here's an example of a Read-Eval-Print-Loop (REPL) in PIR: =begin PIR .sub main $P0 = getinterp $P0 = $P0.'stdin_handle'() $P1 = compreg 'PIR' loop_top: $S0 = $P0.'readline'() $S0 = ".sub '' :anon\n" . $S0 $S0 = $S0 . "\n.end\n" $P2 = $P1($S0) $P2() goto loop_top .end =end PIR The exact list of HLL packages installed on your system may vary. Some language compiler packages will exist as part of the Parrot source code repository, but many will be developed and maintained separately. In any case, these compilers will typically need to be loaded into your program first, before a compiler object for them can be retrieved and used. =head2 HLL Namespaces Let's take a closer look at namespaces then we have in previous chapters. Namespaces, as we mentioned before can be nested to an arbitrary depth starting with the root namespace. In practice, the root namespace is not used often, and is typically left for use by the Parrot internals. Directly beneath the root namespace are the X HLL Namespaces, named after the HLLs that the application software is written in. HLL namespaces are all lower-case, such as "perl6", or "cardinal", or "pynie". By sticking to this convention, multiple HLL compilers can operate on Parrot simultaneously while staying completely oblivious to each other. =head2 HLL Mapping HLL mapping enables Parrot to use a custom data type for internal operations instead of using the normal built-in types. Mappings can be created with the C<"hll_map"> method of the interpreter PMC. =begin PIR_FRAGMENT $P0 = newclass "MyNewClass" # New type $P1 = get_class "ResizablePMCArray" # Built-in type $P2 = getinterp $P2.'hll_map'($P1, $P0) =end PIR_FRAGMENT With the mapping in place, anywhere that Parrot would have used a ResizablePMCArray it now uses a MyNewClass object instead. Here's one example of this: =begin PIR .sub 'MyTestSub' .param pmc arglist :slurpy # A MyNewClass array of args .return(arglist) .end =end PIR =head2 Interoperability Guidelines =head3 Libraries and APIs As a thought experiment, imagine a library written in Common Lisp that uses Common Lisp data types. We like this library, so we want to include it in our Ruby project and call the functions from Ruby. Immediately we might think about writing a wrapper to convert parameters from Ruby types into Common Lisp types, and then to convert the Common Lisp return values back into Ruby types. This seems sane, and it would probably even work well. Now, expand this to all the languages on Parrot. We would need wrappers or converters to allow every pair of languages to communicate, which requires C libraries to make it work! As the number of languages hosted on the platform increases, this clearly becomes an untenable solution. So, what do we do? How do we make very different languages like Common Lisp, Ruby, Scheme, PHP, Perl and Python to interoperate with each other at the data level? There are two ways: =over 4 =item * VTable Functions VTable functions are the standard interface for PMC data types, and all PMCs have them. If the PMCs were written properly to satisfy this interface all the necessary information from those PMCs. Operate on the PMCs at the VTable level, and we can safely ignore the implementation details of them. =item * Class Methods If a library returns data in a particular format, the library reuser should know, understand, and make use of that format. Classes written in other languages will have a whole set of documented methods to be interfaced with and the reuser of those classes should use those methods. This only works, of course, in HLLs that allow object orientation and classes and methods, so for languages that don't have this the vtable interface should be used instead. =back =head3 Mixing and Matching Datatypes =head2 Linking and Embedding Not strictly a topic about HLLs and their interoperation, but it's important for us to also mention another interesting aspect of Parrot: Linking and embedding. We've touched on one related topic above, that of creating the compiler fakecutables. The fakecutables contain a link to C, which contains all the necessary guts of Parrot. When the fakecutable is executed, a small driver program loads the PBC data into libparrot through its API functions. The Parrot executable is just one small example of how Parrot's functionality can be implemented, and we will talk about a few other ways here too. =head3 Embedding Parrot C is a library that can be statically or dynamically linked to any other executable program that wants to use it. This linking process is known as I, and is a great way to interoperate =head3 Creating and Interoperating Interpreters Parrot's executable, which is the interface which most users are going to be familiar with, uses a single interpreter structure to perform a single execution task. However, this isn't the only supported structural model that Parrot supports. In fact, the interpreter structure is not a singleton, and multiple interpreters can be created by a single program. This allows separate tasks to be run in separate environments, which can be very helpful if we are writing programs and libraries in multiple languages. Interpreters can communicate and share data between each other, and can run independently from others in the same process. =head3 Small, Toy, and Domain-Specific Languages How many programs are out there with some sort of scripting capability? You can probably name a few off the top of your head with at least some amount of scripting or text-based commands. In developing programs like this, typically it's necessary to write a custom parser for the input commands, and a custom execution engine to make the instructions do what they are intended to do. Instead of doing all this, why not embed an instance of Parrot in the program, and let Parrot handle the parsing and executing details? Small scripting components which are not useful in a general sense like most programming languages, and are typically limited to use in very specific environments (such as within a single program) are called I (DSL). DSLs are a very popular topic because a DSL allows developers to create a custom language that makes dealing with a given problem space or data set very easy. Parrot and its suite of compiler tools in turn make creating the DSLs very easy. It's all about ease of use. =head3 Parrot API =cut # Local variables: # c-file-style: "parrot" # End: # vim: expandtab shiftwidth=4: trans.t000644000765000765 2303711567202625 15303 0ustar00bruce000000000000parrot-6.6.0/t/dynoplibs#!./parrot # Copyright (C) 2001-2011, Parrot Foundation. =head1 NAME t/op/trans.t - Trancendental Mathematical Ops =head1 SYNOPSIS % prove t/op/trans.t =head1 DESCRIPTION Tests various transcendental operations =cut .loadlib 'trans_ops' .sub main :main .include 'test_more.pir' .local num epsilon epsilon = _epsilon() plan(111) test_sin_n(epsilon) test_sin_i(epsilon) test_cos_n(epsilon) test_cos_i(epsilon) test_tan_n(epsilon) test_tan_i(epsilon) test_cot_n(epsilon) test_cot_i(epsilon) test_sec_n(epsilon) test_sec_i(epsilon) test_csc_n(epsilon) test_csc_i(epsilon) test_atan_n(epsilon) test_atan_i(epsilon) test_asin_n(epsilon) test_asin_i(epsilon) test_acos_n(epsilon) test_acos_i(epsilon) test_asec_n(epsilon) test_asec_i(epsilon) test_sinh_n(epsilon) test_sinh_i(epsilon) test_cosh_n(epsilon) test_cosh_i(epsilon) test_sech_n(epsilon) test_sech_i(epsilon) test_tanh_n(epsilon) test_tanh_i(epsilon) test_exp_n(epsilon) test_ln_n(epsilon) test_log2_n(epsilon) test_log10_n(epsilon) test_pow_p_p_p() test_pow_p_p_i() test_pow_p_p_n() test_pow_n_nc_i(epsilon) integer_overflow_with_pow() e_raised_pi_time_i__plus_1_equal_0() .end .sub _pi .return (3.1415926535897) .end .sub _e .return (2.7182818459045) .end .sub _epsilon .return (0.0001) .end .sub test_sin_n .param num epsilon $N0 = sin 0.0 is($N0, 0.0, "sin(0.0)", epsilon) $N0 = sin 1.0 is($N0, 0.841471, "sin(1.0)", epsilon) $N1 = _pi() $N0 = sin $N1 is($N0, 0.0, "sin(pi)", epsilon) $N1 = _pi() $N1 = $N1 / 2 $N0 = sin $N1 is($N0, 1.0, "sin(pi/2)", epsilon) .end .sub test_sin_i .param num epsilon $N0 = sin 0 is($N0, 0.0, "sin(0)", epsilon) $N0 = sin 1 is($N0, 0.841471, "sin(1)", epsilon) .end .sub test_cos_n .param num epsilon $N0 = cos 0.0 is($N0, 1.0, "cos(0.0)", epsilon) $N0 = cos 1.0 is($N0, 0.540302, "cos(1.0)", epsilon) $N1 = _pi() $N0 = cos $N1 is($N0, -1.0, "cos(pi)", epsilon) $N1 = _pi() $N1 = $N1 / 2 $N0 = cos $N1 is($N0, 0.0, "cos(pi/2)", epsilon) .end .sub test_cos_i .param num epsilon $N0 = cos 0 is($N0, 1.0, "cos(0)", epsilon) $N0 = cos 1 is($N0, 0.540302, "cos(1)", epsilon) .end .sub test_tan_n .param num epsilon $N0 = tan 0.0 is($N0, 0.0, "tan(0.0)", epsilon) $N0 = tan 1.0 is($N0, 1.557408, "tan(1.0)", epsilon) .end .sub test_tan_i .param num epsilon $N0 = tan 0 is($N0, 0.0, "tan(0)", epsilon) $N0 = tan 1 is($N0, 1.557408, "tan(1)", epsilon) .end .sub test_cot_n .param num epsilon $N0 = cot 0.5 is($N0, 1.8305, "cot(0.5)", epsilon) $N0 = cot 1.0 is($N0, 0.64209, "cot(1.0)", epsilon) .end .sub test_cot_i .param num epsilon $N0 = cot 1 is($N0, 0.64209, "cot(1)", epsilon) $N0 = cot 2 is($N0, -0.45766, "cot(2)", epsilon) .end .sub test_sec_n .param num epsilon $N1 = 1.0 $N2 = sec $N1 is($N2, 1.850816, "sec(1.0)", epsilon) $N2 = sec 1.0 is($N2, 1.850816, "sec(1.0)", epsilon) .end .sub test_sec_i .param num epsilon $I1 = 1 $N1 = sec $I1 is($N1, 1.850816, "sec(1)", epsilon) .end .sub test_csc_n .param num epsilon $N0 = csc 0.5 is($N0, 2.0858, "csc(0.5)", epsilon) $N0 = csc 1.0 is($N0, 1.1884, "csc(1.0)", epsilon) .end .sub test_csc_i .param num epsilon $N0 = csc 1 is($N0, 1.1884, "csc(1)", epsilon) $N0 = csc 2 is($N0, 1.0998, "csc(2)", epsilon) .end .sub test_atan_n .param num epsilon $N1 = 1.0 $N2 = atan $N1 is($N2, 0.785398, "atan(1.0)", epsilon) .end .sub test_atan_i .param num epsilon $I1 = 1 $N1 = atan $I1 is($N1, 0.785398, "atan(1)", epsilon) .end .sub test_asin_n .param num epsilon .local num pi2 pi2 = _pi() pi2 /= 2 $N1 = 1.0 $N2 = asin $N1 is($N2, pi2, "asin(1.0)", epsilon) $N2 = asin 1.0 is($N2, pi2, "asin(1.0)", epsilon) .end .sub test_asin_i .param num epsilon .local num pi2 pi2 = _pi() pi2 /= 2 $I1 = 1 $N1 = asin $I1 is($N1, pi2, "asin(1)", epsilon) .end .sub test_acos_n .param num epsilon $N1 = 1.0 $N2 = acos $N1 is($N2, 0.0, "acos(1.0)", epsilon) $N2 = acos 1.0 is($N2, 0.0, "acos(1.0)", epsilon) .end .sub test_acos_i .param num epsilon $I1 = 1 $N1 = acos $I1 is($N1, 0.0, "acos(1)", epsilon) .end .sub test_asec_n .param num epsilon $N1 = 1.0 $N2 = asec $N1 is($N2, 0.0, "asec(1.0)", epsilon) $N2 = asec 1.0 is($N2, 0.0, "asec(1.0)", epsilon) .end .sub test_asec_i .param num epsilon $I1 = 1 $N1 = asec $I1 is($N1, 0.0, "asec(1)", epsilon) .end .sub test_sinh_n .param num epsilon .local num result $N1 = 1.0 $N2 = sinh $N1 is($N2, 1.175201, "sinh(1.0)", epsilon) $N2 = sinh 1.0 is($N2, 1.175201, "sinh(1.0)", epsilon) .end .sub test_sinh_i .param num epsilon $I1 = 1 $N1 = sinh $I1 is($N1, 1.175201, "sinh(1)", epsilon) .end .sub test_cosh_n .param num epsilon .local num result $N1 = 1.0 $N2 = cosh $N1 is($N2, 1.543081, "cosh(1.0)", epsilon) $N2 = cosh 1.0 is($N2, 1.543081, "cosh(1.0)", epsilon) .end .sub test_cosh_i .param num epsilon $I1 = 1 $N1 = cosh $I1 is($N1, 1.543081, "cosh(1)", epsilon) .end .sub test_sech_n .param num epsilon .local num result $N1 = 1.0 $N2 = sech $N1 is($N2, 0.648054, "sech(1.0)", epsilon) $N2 = sech 1.0 is($N2, 0.648054, "sech(1.0)", epsilon) .end .sub test_sech_i .param num epsilon $I1 = 1 $N1 = sech $I1 is($N1, 0.648054, "sech(1)", epsilon) .end .sub test_tanh_n .param num epsilon .local num result $N1 = 1.0 $N2 = tanh $N1 is($N2, 0.761594, "tanh(1.0)", epsilon) $N2 = tanh 1.0 is($N2, 0.761594, "tanh(1.0)", epsilon) .end .sub test_tanh_i .param num epsilon $I1 = 1 $N1 = tanh $I1 is($N1, 0.761594, "tanh(1)", epsilon) .end .sub test_exp_n .param num epsilon .local num result $N1 = 2.0 $N2 = exp $N1 is($N2, 7.389056, "exp(2.0)", epsilon) $N2 = exp 2.0 is($N2, 7.389056, "exp(2.0)", epsilon) .end .sub test_ln_n .param num epsilon .local num result $N1 = 2.0 $N2 = ln $N1 is($N2, 0.693147, "ln(2.0)", epsilon) $N2 = ln 2.0 is($N2, 0.693147, "ln(2.0)", epsilon) .end .sub test_log2_n .param num epsilon .local num result $N1 = 16.0 $N2 = log2 $N1 is($N2, 4.0, "ln(2.0)", epsilon) $N2 = log2 16.0 is($N2, 4.0, "ln(2.0)", epsilon) .end .sub test_log10_n .param num epsilon .local num result $N1 = 100.0 $N2 = log10 $N1 is($N2, 2.0, "log10(100.0)", epsilon) $N2 = log10 100.0 is($N2, 2.0, "log10(100.0)", epsilon) .end .sub test_pow_p_p_p $P1 = new ['Integer'] $P1 = 2 $P2 = new ['Integer'] $P2 = 2 null $P3 $P3 = pow $P1, $P2 is($P3, 4, "pow(2, 2) with null register") $P3 = pow $P1, $P2 is($P3, 4, "pow(2, 2)") .end .sub test_pow_p_p_i $P1 = new ['Integer'] $P1 = 2 null $P2 $P2 = pow $P1, 2 is($P2, 4, "pow(2, const 2) with null register") $P2 = pow $P1, 2 is($P2, 4, "pow(2, const 2)") $I1 = 2 null $P2 $P2 = pow $P1, $I1 is($P2, 4, "pow(2, 2) with null register") $P2 = pow $P1, $I1 is($P2, 4, "pow(2, 2)") .end .sub test_pow_p_p_n $P1 = new ['Integer'] $P1 = 2 null $P2 $P2 = pow $P1, 2.0 is($P2, 4, "pow(2, const 2.0) with null register") $P2 = pow $P1, 2.0 is($P2, 4, "pow(2, const 2.0)") $N1 = 2.0 null $P2 $P2 = pow $P1, $N1 is($P2, 4, "pow(2, 2.0) with null register") $P2 = pow $P1, $N1 is($P2, 4, "pow(2, 2.0)") .end .sub test_pow_n_nc_i .param num epsilon $I1 = 2 $N0 = pow 2.0, $I1 is($N0, 4, "pow(2, 2)") $I1 = -2 $N0 = pow 2.0, $I1 is($N0, 0.25, "pow(2, -2)", epsilon) .end .sub integer_overflow_with_pow .include "iglobals.pasm" # Check that we aren't 32-bit INTVALs without GMP .local pmc interp # a handle to our interpreter object. interp = getinterp .local pmc config config = interp[.IGLOBALS_CONFIG_HASH] .local int intvalsize intvalsize = config['intvalsize'] .local string gmp gmp = config['gmp'] if intvalsize == 4 goto skipthem if gmp == 'define' goto can_test goto skipthem can_test: .local pmc i1, i2, r i1 = new 'Integer' i2 = new 'Integer' i1 = 2 i2 = 1 $I1 = 1 next: null r r = pow i1, i2 $S0 = r $I1 = $I1 * 2 is( $S0, $I1, 'integer_overflow_with_pow' ) inc i2 # XXX: this must be extended to at least 64 bit range # when sure that the result is not floating point. # In the meantime, make sure it overflows nicely # on 32 bit. unless i2 > 40 goto next goto end skipthem: skip(40,'No integer overflow tests for 32-bit INTVALs') end: .end .macro sprintf_is(fmt, number, message) c = .number $S0 = sprintf .fmt, c $S1 = .message is( $S0, $S1, $S1 ) .endm .sub e_raised_pi_time_i__plus_1_equal_0 .local pmc c, c2, c3 c = new ['Complex'] c2 = new ['Complex'] c3 = new ['Complex'] # e^(pi * i) + 1 = 0 $N0 = atan 1 $N0 *= 4 c[0] = 0.0 c[1] = $N0 c2 = c.'exp'() c2 += 1.0 .sprintf_is( "%.3f%+.3fi", c2, "0.000+0.000i" ) .end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: linelength.t000644000765000765 540012307662657 16242 0ustar00bruce000000000000parrot-6.6.0/t/codingstd#! perl # Copyright (C) 2006-2009, Parrot Foundation. =head1 NAME t/codingstd/linelength.t - Test code lines length =head1 SYNOPSIS # test all files % prove t/codingstd/linelength.t # test specific files % perl t/codingstd/linelength.t src/foo.c include/parrot/bar.h =head1 DESCRIPTION Tests source files for the line length limit as defined in F. Only files for some language implementations are checked. =head1 SEE ALSO L =cut use strict; use warnings; use lib qw( . lib ../lib ../../lib ); use File::Spec; use Test::More tests => 1; use ExtUtils::Manifest qw( maniread ); use Parrot::Config qw/ %PConfig /; my $num_col_limit = 100; my $build_dir = $PConfig{build_dir}; my $manifest = maniread( File::Spec->catfile( $build_dir, 'MANIFEST' ) ); # skip files listed in the __DATA__ section my %skip_files; while () { next if m{^#}; next if m{^\s*$}; chomp; $skip_files{$_}++; } # find the files that we need to check my @files = @ARGV ? <@ARGV> : source_files(); # check all the files and keep a list of those failing my @lines_too_long; foreach (@files) { my $lineinfo = info_for_first_long_line($_); next unless $lineinfo; push @lines_too_long => $lineinfo; } ## L ok( !@lines_too_long, 'Line length ok' ) or diag( "Lines longer than coding standard limit ($num_col_limit columns) in " . scalar @lines_too_long . " files:\n" . join( "\n", @lines_too_long ) ); sub info_for_first_long_line { my $file = shift; open my $fh, '<', $file or die "Can't open file '$file'"; while ( my $line = <$fh> ) { chomp $line; $line =~ s/\t/' ' x (1 + length($`) % 8)/eg; # expand \t next if $line =~ m/https?:\/\//; # skip long web addresses next if $line =~ m/CONST_STRING\(/; return sprintf '%s:%d: %d cols', $file, $., length($line) if length($line) > $num_col_limit; } return; } sub source_files { my @files; foreach my $file ( sort keys(%$manifest) ) { my $full_path = File::Spec->catfile( $build_dir, $file ); # skip files specified in __DATA__ section next if exists $skip_files{$file}; push @files => $full_path if $file =~ m{\.(c|h|pmc|ops|pod)$}; } return @files; } # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: __DATA__ # Lex and Bison generated compilers/imcc/imclexer.c compilers/imcc/imcparser.c # generated files src/ops/core_ops.c # generated by tools/dev/nci_thunk_gen.pir src/nci/core_thunks.c src/nci/extra_thunks.c # these ones include long POD docs/embed.pod gen_release_info.pl000644000765000765 270611533177647 20112 0ustar00bruce000000000000parrot-6.6.0/tools/release#! perl # Copyright (C) 2008, Parrot Foundation. use strict; use warnings; =head1 NAME tools/release/gen_release_info.pl - generate release info for graphs and charts =head1 DESCRIPTION This utility generates release information from git in csv format, suitable for graphs, charts, and reports. =cut ## create a release information data structure my $r = { map { $_->{number} => $_ } map { m{^(RELEASE_)([0-9_]+)} ? { tag => "$1$2", number => sub{$a = shift; $a =~ y/_/./; $a }->($2), } : () } qx { git tag -l 'RELEASE_*' } }; ## gather interesting release-related information from the tag map { ## ask git for info about the tag my $tag = $r->{$_}{tag}; my $commit_id = qx{ git rev-parse $tag }; chomp $commit_id; my $info = qx{ git show $commit_id --quiet --format="Author: %an%nCommit: %H%nDate: %ai" }; ## pull the interesting items $info =~ m{Author: (\S+)} and $r->{$_}{author} = $1; $info =~ m{Commit: (\S+)} and $r->{$_}{commit} = $1; $info =~ m{Date: (\S+)} and $r->{$_}{date} = $1; } keys %{ $r }; ## output info in csv format print map { "$_\n" } map { my $n = $_; join ',' => map { $r->{$n}{$_} || '' } qw{ tag number author commit date } } sort keys %$r; # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: compiler_faq.pod000644000765000765 4132412101554066 15607 0ustar00bruce000000000000parrot-6.6.0/docs# Copyright (C) 2001-2012, Parrot Foundation. =head1 NAME docs/compiler_faq.pod - Parrot FAQ for compiler writers in PIR =head1 DESCRIPTION This is the FAQ for anyone interested in writing compilers in PIR, targeting the Parrot Virtual Machine. =head1 GENERAL QUESTIONS =head2 Which C compilers can I use with Parrot? Whoa, there--you're looking at the wrong FAQ. This document is for people writing compilers that target Parrot. To answer your question, though, Parrot should theoretically work with any C89-compliant C compiler. See the F files in the root directory for more information about building Parrot. =head2 How can I implement a compiler to use as a compiler object from within Parrot? See L. =head2 How do I embed source locations in my code for debugging? Use C<.line 42 "file.pir"> for this. =head1 SUBROUTINES =head2 How do I generate a sub call in PIR? This looks like a function call in many HLLs: =begin PIR_FRAGMENT $P0( $P1, $P2, $P3 ) =end PIR_FRAGMENT where $P0 is the function object, and $P1, $P2, and $P3 are its parameters. You can also use a function's name in place of the object, as long as it's in the same namespace. =begin PIR_FRAGMENT somefunctionlabel( $P1, $P2, $P3 ) =end PIR_FRAGMENT You can also get return value(s): =begin PIR_FRAGMENT ($P1,$P2) = $P0( $P1, $P2, $P3 ) =end PIR_FRAGMENT If the function name might collide with a Parrot opcode, quote it: =begin PIR_FRAGMENT .local int i i = 'new'(42) =end PIR_FRAGMENT You can also use the full PCC for these calls. See L and other questions below for more information. =head2 How do I generate a method call in PIR? Similar to function calls, just append C<.> and the method name to the object. You should quote a literal method name to avoid confusion. =begin PIR_FRAGMENT .local pmc ret_val, some_obj, arg ret_val = some_obj.'some_meth'(arg) =end PIR_FRAGMENT The method name may also be a string variable representing a method name: =begin PIR_FRAGMENT .local string m .local pmc curses_obj m = 'bold' curses_obj.m() =end PIR_FRAGMENT =head2 How do I locate or create a subroutine object? There are several ways to achieve this, depending on the location of the subroutine. If the sub is in the same file use a Sub constant: =begin PIR_FRAGMENT .const 'Sub' foo = 'foo' # ... foo() =end PIR_FRAGMENT A more dynamic way is: =begin PIR_FRAGMENT .local pmc foo foo = find_name 'foo' =end PIR_FRAGMENT This searches for a subroutine 'foo' in the current lexical pad, in the current namespace, in the global, and in the builtin namespace in that order. This opcode is generated, if I is used, but the compiler can't figure out, where the function is. If the subroutine is in a different namespace, use the C or C opcodes: =begin PIR_FRAGMENT .local pmc foo foo = get_root_global ['Foo'], 'foo' =end PIR_FRAGMENT This fetches the sub C in the C namespace. =head2 How do I create a Closure or Coroutine? Closure and Coroutine carry both a dynamic state. Therefore you need to perform two steps. First use one of the above ways to locate the Sub object. Then use the op C to capture the environment. =begin PIR_FRAGMENT .local pmc coro coro = find_name 'my_coro' coro = newclosure coro =end PIR_FRAGMENT Any subroutine that contains a C<.yield> directive is automatically created as a Coroutine PMC: =begin PIR .sub my_coro # automagically a Coroutine PMC .param pmc result #... .yield (result) #... .end =end PIR =head2 How do I generate a tail call in PIR? =begin PIR .sub foo # ... .tailcall bar(42) # tail call sub bar .end .sub bar .param int answer inc answer .return(answer) .end =end PIR The sub C will return to the caller of C. (Warning! This fails in some cases. XXX Find the Trac ticket and reference it here.) =head2 How do I generate a sub call with a variable-length parameter list in PIR? If you have a variable amounts of arguments in an array, you can pass all items of that array with the C<:flat> directive. =begin PIR_FRAGMENT .local pmc ar, foo ar = new 'ResizablePMCArray' push ar, "arg 1\n" push ar, "arg 2\n" #... foo(ar :flat) #... =end PIR_FRAGMENT =head2 How to I retrieve the contents of a variable-length parameter list being passed to me? Use a slurpy array: =begin PIR .sub mysub .param pmc argv :slurpy .local int argc argc = argv #... .end =end PIR If you have a few fixed parameters too, you can use a slurpy array to get the rest of the arguments =begin PIR .sub mysub .param pmc arg0 .param pmc arg1 .param pmc varargs :slurpy .local int num_varargs num_varargs = varargs # ... .end =end PIR =head2 How do I pass optional arguments? Use the C<:optional> and C<:opt_flag> pragmas: =begin PIR .sub foo .param pmc arg1 :optional .param int has_arg1 :opt_flag .param pmc arg2 :optional .param int has_arg2 :opt_flag if has_arg1 goto got_arg1 # ... got_arg1: # ... .end =end PIR =head2 How do I create nested subroutines? Please refer to L for details. =head1 VARIABLES =head2 How do I fetch a variable from the global namespace? Use the C or C op: =begin PIR_FRAGMENT get_hll_global $P0, ['name'; 'space'], 'name_of_the_global' get_hll_global $P1, 'name_of_the_global' =end PIR_FRAGMENT =head2 How can I delete a global? You can retrieve the namespace hash and use the C opcode. =begin PIR .sub main :main $P0 = new 'Integer' $P0 = 42 set_hll_global 'foo', $P0 set_hll_global ['Bar'], 'baz', $P0 show_baz() .local pmc ns, Bar_ns ns = get_hll_namespace delete ns['foo'] # delete from top level Bar_ns = ns['Bar'] # get Bar namespace delete Bar_ns['baz'] show_baz() .end .sub show_baz $P0 = get_hll_global ['Bar'], 'baz' print "'baz' is " if null $P0 goto is_null print $P0 print ".\n" .return () is_null: print "null.\n" .end =end PIR =head2 How do I use lexical pads to have both a function scope and a global scope? Please refer to L for details. =head2 How can I delete a lexical variable? You can't. You can store a PMCNULL as the value though, which will catch all further access to that variable and throw an exception. (You can create a PMCNULL with the C opcode.) =head2 How do I resolve a variable name? Use C: =begin PIR_FRAGMENT $P0 = find_name '$x' find_name $P0, 'foo' # same thing =end PIR_FRAGMENT This will find the name C in the lexical, global, or builtin namespace, in that order, and store it in C<$P0>. =head2 How do I fetch a variable from the current lexical pad? =begin PIR_FRAGMENT find_lex $P0, 'foo' =end PIR_FRAGMENT or much better, if possible just use the variable defined along with the C<.lex> definition of C. =head2 How do I fetch a variable from any nesting depth? That is still the same: =begin PIR_FRAGMENT find_lex $P0, 'foo' =end PIR_FRAGMENT This finds a C variable at any B depth starting from the top. If your language looks up variables differently, you have to walk the 'caller' chain. See also F. =head2 How can I produce more efficient code for lexicals? Don't emit C at all. Use C only if the compiler doesn't know the variable. You can always just use the register that was defined in the C<.lex> directive as an alias to that lexical, if you are in the same scope. =head1 MODULES, CLASSES, and OBJECTS =head2 How do I create a module? XXX =head2 How do I create a class? With the C op: =begin PIR_FRAGMENT newclass $P0, 'Animal' =end PIR_FRAGMENT =head2 How do I add instance variables/attributes? Each class knows which attributes its objects can have. You can add attributes to a class (not to individual objects) like so: =begin PIR_FRAGMENT addattribute $P0, 'legs' =end PIR_FRAGMENT =head2 How do I add instance methods to a class? Methods are declared as functions in the class namespace with the C<:method> keyword appended to the function declaration: =begin PIR .namespace [ 'Animal' ] .sub run :method print "slow and steady\n" .end =end PIR =head2 How do I override a vtable on a class? As with methods, but note the new keyword. The vtable name specified B be an existing vtable slot. =begin PIR .namespace [ 'NearlyPi' ] .sub get_string :vtable .return ('three and a half') .end =end PIR Now, given an instance of NearlyPi in $P0 =begin PIR_FRAGMENT $S0 = $P0 say $S0 # prints 'three and a half' =end PIR_FRAGMENT =head2 How do I access attributes? You can access attributes by a short name: =begin PIR_FRAGMENT_INVALID $P0 = getattribute self, 'legs' assign $P0, 4 # set attribute's value =end PIR_FRAGMENT_INVALID =head2 When should I use properties vs. attributes? Properties aren't inherited. If you have some additional data that don't fit into the class's hierarchy, you could use properties. =head2 How do I create a class that is a subclass of another class? You first have to get the class PMC of the class you want to subclass. Either you use the PMC returned by the C op if you created the class, or use the C op: =begin PIR_FRAGMENT get_class $P0, 'Animal' =end PIR_FRAGMENT Then you can use the C op to create a new class that is a subclass of this class: =begin PIR_FRAGMENT subclass $P1, $P0, 'Dog' =end PIR_FRAGMENT This stores the newly created class PMC in $P1. =head2 How do I create a class that has more than one parent class? First, create a class without a parent class using C (or with only one subclass, see previous question). Then add the other parent classes to it. Please refer to the next question for an example. =head2 How do I add another parent class to my class? If you have a class PMC (created with C or by C), you can add more parent classes to it with the C op: =begin PIR_FRAGMENT get_class $P1, 'Dog' subclass $P2, $P1, 'SmallDog' get_class $P3, 'Pet' addparent $P2, $P3 # make "SmallDog" also a "Pet" =end PIR_FRAGMENT =head2 How can I specify the constructor of a class? Just override the init vtable for that class. =begin PIR .sub _ :main newclass $P0, 'Dog' # create a class named Dog .end .namespace ['Dog'] .sub init :vtable # ... .end =end PIR Or you can specify the constructor method by setting the BUILD property of the class PMC: =begin PIR_FRAGMENT newclass $P0, 'Dog' # create a class named Dog new $P1, 'String' # create a string set $P1, 'initialise' # set it to the name of the constructor method setprop $P0, 'BUILD', $P1 # set the BUILD property =end PIR_FRAGMENT =head2 How do I instantiate a class? You can do so either with the class name: =begin PIR_FRAGMENT new $P0, 'Dog' =end PIR_FRAGMENT or with the class object: =begin PIR_FRAGMENT_INVALID .loadlib 'io_ops' $P1 = get_class 'Dog' # find the 'Dog' class unless null $P1 goto have_dog_class printerr "Oops; can't find the 'Dog' class.\n" .return () have_dog_class: new $P0, $P1 # creates a Dog object and stores it in register $P0 =end PIR_FRAGMENT_INVALID The chief difference is that using a string constant will produce the specific error "Class 'Dog' not found" if that happens to be the case; the other code has to check explicitly. During the C opcode the constructor is called. =head2 How can I pass arguments to a constructor? You can pass only a single argument to a constructor. By convention, a hash PMC is passed to the constructor that contains the arguments as key/value pairs: =begin PIR_FRAGMENT new $P0, 'Hash' set $P0['greeting'], 'hello' set $P0['size'], 1.23 new $P1, 'Alien', $P0 # create an Alien object and pass # the hash to the constructor =end PIR_FRAGMENT =head2 How do I add module/class methods? XXX =head2 How do I access module/class variables? XXX =head1 EXCEPTIONS =head2 How do I throw an exception in PIR? The easiest way is the perl-like =begin PIR_FRAGMENT die 'Eeeek!' =end PIR_FRAGMENT You can also explicitly create an exception object and throw it: =begin PIR_FRAGMENT $P0 = new 'Exception' $P0 = 'something happened' throw $P0 =end PIR_FRAGMENT =head2 How do I catch an exception in PIR? Use C to push an exception handler onto the stack. End the set of instructions that might throw the exception you're interested in with C. =begin PIR_FRAGMENT_INVALID push_eh handler die 'whoops' # or any other code that might throw an exception... pop_eh # ok =end PIR_FRAGMENT_INVALID An exception handler is called with one argument, which is the exception object. The message of the exception can be easily extracted, as follows: =begin PIR_FRAGMENT handler: # exception .get_results ($P0) print 'Exception caught:' $S0 = $P0['message'] say $S0 =end PIR_FRAGMENT =head2 How do I let exceptions from C pass through my handler? Rethrow the exception if it has a severity of C. =begin PIR_FRAGMENT .include 'except_severity.pasm' # ... handler: .get_results ($P0) $I0 = $P0['severity'] if $I0 == .EXCEPT_EXIT goto handle_exit say 'Exception caught!' # ... handle_exit: rethrow $P0 # let the next handler deal with it. =end PIR_FRAGMENT Exception example: =begin PIR_FRAGMENT push_eh handler $P0 = new 'Exception' $P0 = 'something happened' throw $P0 pop_eh exit 0 handler: .local pmc exception .local string message .get_results (exception) print 'Exception: ' message = exception['message'] print message print "\n" exit 1 =end PIR_FRAGMENT =head1 C EXTENSIONS =head2 How do I create PMCs for my compiler? Parrot supports dynamic PMCs, loadable at runtime, to allow compiler writers to extend Parrot with additional types. For more information about writing PMCs, see L and L. See L for an example of how to build your dynamic PMCS. =head2 How do I add another op to Parrot? Parrot supports dynamic op libraries. These allow for ops specific to one language to be used without having to place them into the Parrot core itself. For examples of dynamic op libraries, see L. =head2 How do I use the Native Calling Interface (NCI)? Using the NCI you can invoke functions written in C from a Parrot script. To every NCI invocation, there are two parts: the native function to be invoked, and the PIR code to do the invocation. First the native function, to be written in C. On Windows, it is necessary to do a DLL export specification of the NCI function: /* foo.c */ /* specify the function prototype */ #ifdef __WIN32 __declspec(dllexport) void foo(void); #else void foo(void); #endif void foo(void) { printf("Hello Parrot!\n"); } Then, after having compiled the file as a shared library, the PIR code looks like this: =begin PIR .sub main :main .local pmc lib, func # load the shared library lib = loadlib "hello" # no extension, .so or .dll is assumed # get a reference to the function from the library just # loaded, called "foo", and signature "void" (and no arguments) func = dlfunc lib, "foo", "v" # invoke func() .end =end PIR If you embedded a Parrot in your C file and you want to invoke another function in that same C file, you should pass a null string to loadlib. Do that as follows: =begin PIR_FRAGMENT .local pmc lib .local string libname null libname lib = loadlib libname =end PIR_FRAGMENT Under Linux, the .c file must then be linked with the -export-dynamic option. =head1 MISC. =head2 How can I access a program's environment? Create a new C PMC and access it like a hash. =begin PIR_FRAGMENT .local pmc e e = new 'Env' $P0 = e['USER'] # lt =end PIR_FRAGMENT =head2 How can I access Parrot's configuration? =begin PIR_FRAGMENT .include 'iglobals.pasm' .local pmc interp, cfg interp = getinterp cfg = interp[.IGLOBALS_CONFIG_HASH] $S0 = cfg['VERSION'] # "0.3.0" =end PIR_FRAGMENT See F for all the keys in the config hash - or iterate over the config hash. =cut osdummy.pmc000644000765000765 65012101554067 15727 0ustar00bruce000000000000parrot-6.6.0/src/dynpmc/* Copyright (C) 2001-2012, Parrot Foundation. =head1 NAME src/dynpmc/osdummy.pmc - Dummy dynpmc placeholder =head1 DESCRIPTION This dynpmc is copied to dynpmc/os. It does nothing, OS is now a builtin. For backwards compatiblity with existing C calls. =cut */ pmclass OSdummy dynpmc {} /* * Local variables: * c-file-style: "parrot" * End: * vim: expandtab shiftwidth=4 cinoptions='\:2=2' : */ Rand.pir000644000765000765 373511533177636 20441 0ustar00bruce000000000000parrot-6.6.0/runtime/parrot/library/Math# Copyright (C) 2009, Parrot Foundation. =head1 NAME Math/rand.pir - the ANSI C rand pseudorandom number generator =head1 DESCRIPTION The C function computes a sequence of pseudo-random integers in the range 0 to C. The C function uses the argument as a seed for a new sequence of pseudo-random numbers to be returned by subsequent calls to C. If C is then called with the same seed value, the sequence of pseudo-random numbers shall be repeated. If C is called before any calls to C have been made, the same sequence shall be generated as when C is first called with a seed value of 1. Portage of the following C implementation, given as example by ISO/IEC 9899:1999. static unsigned long int next = 1; // int rand(void) { next = next * 1103515245 + 12345; return (unsigned int)(next/65536) % 32768; } // void srand(unsigned int seed) { next = seed; } =head1 USAGE load_bytecode 'Math/Rand.pbc' .local pmc rand rand = get_global [ 'Math'; 'Rand' ], 'rand' .local pmc srand srand = get_global [ 'Math'; 'Rand' ], 'srand' .local int seed srand(seed) $I0 = rand() .local pmc rand_max rand_max = get_global [ 'Math'; 'Rand' ], 'RAND_MAX' .local int RAND_MAX RAND_MAX = rand_max() =cut .namespace [ 'Math'; 'Rand' ] .sub '__onload' :anon :load $P0 = box 1 set_global 'next', $P0 .end .sub 'RAND_MAX' .return (32767) .end .sub 'rand' $P0 = get_global 'next' $I0 = $P0 $I0 *= 1103515245 $I0 += 12345 ge $I0, 0, noadj $I0 += 0x80000000 # not hit for 64bit int goto done noadj: $I0 &= 0xffffffff # noop for 32bit int done: set $P0, $I0 $I0 /= 65536 $I0 %= 32768 .return ($I0) .end .sub 'srand' .param int seed $P0 = get_global 'next' set $P0, seed .end =head1 AUTHORS Francois Perrad =cut # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: arithmetics.t000644000765000765 2555611715102034 15077 0ustar00bruce000000000000parrot-6.6.0/t/op#!./parrot # Copyright (C) 2001-2010, Parrot Foundation. =head1 NAME t/op/arithmetics.t - Arithmetic Ops =head1 SYNOPSIS % prove t/op/arithmetics.t =head1 DESCRIPTION Tests basic arithmetic on various combinations of Parrot integer and number types. =cut .sub main :main .include 'test_more.pir' .include 'iglobals.pasm' plan(80) take_the_negative_of_a_native_integer() take_the_absolute_of_a_native_integer() add_native_integer_to_native_integer() subtract_native_integer_from_native_integer() multiply_native_integer_with_native_integer() divide_native_integer_by_native_integer() negate_minus_zero_point_zero() negate_a_native_number() take_the_absolute_of_a_native_number() ceil_of_a_native_number() floor_of_a_native_number() add_native_integer_to_native_number() subtract_native_integer_from_native_number() multiply_native_number_with_native_integer() divide_native_number_by_native_integer() add_native_number_to_native_number() subtract_native_number_from_native_number() multiply_native_number_with_native_number() divide_native_number_by_native_number() # END_OF_TESTS .end # # Operations on a single INTVAL # .sub take_the_negative_of_a_native_integer set $I0, 0 neg $I0 is( $I0, "0", 'take_the_negative_of_a_native_integer' ) set $I0, 1234567890 neg $I0 is( $I0, "-1234567890", 'take_the_negative_of_a_native_integer' ) set $I0, -1234567890 neg $I0 is( $I0, "1234567890", 'take_the_negative_of_a_native_integer' ) set $I0, 0 set $I1, 0 neg $I1, $I0 is( $I1, "0", 'take_the_negative_of_a_native_integer' ) set $I0, 1234567890 neg $I1, $I0 is( $I1, "-1234567890", 'take_the_negative_of_a_native_integer' ) set $I0, -1234567890 neg $I1, $I0 is( $I1, "1234567890", 'take_the_negative_of_a_native_integer' ) .end .sub take_the_absolute_of_a_native_integer set $I0, 0 abs $I0 is( $I0, "0", 'take_the_absolute_of_a_native_integer' ) set $I0, 1234567890 abs $I0 is( $I0, "1234567890", 'take_the_absolute_of_a_native_integer' ) set $I0, -1234567890 abs $I0 is( $I0, "1234567890", 'take_the_absolute_of_a_native_integer' ) set $I0, 0 set $I1, 0 abs $I1, $I0 is( $I1, "0", 'take_the_absolute_of_a_native_integer' ) set $I0, 1234567890 abs $I1, $I0 is( $I1, "1234567890", 'take_the_absolute_of_a_native_integer' ) set $I0, -1234567890 abs $I1, $I0 is( $I1, "1234567890", 'take_the_absolute_of_a_native_integer' ) .end # # first arg is INTVAL, second arg is INTVAL # .sub add_native_integer_to_native_integer set $I0, 4000 set $I1, -123 add $I2, $I0, $I1 is( $I2, "3877", 'add_native_integer_to_native_integer' ) add $I0, $I0, $I1 is( $I0, "3877", 'add_native_integer_to_native_integer' ) .end .sub subtract_native_integer_from_native_integer set $I0, 4000 set $I1, -123 sub $I2, $I0, $I1 is( $I2, "4123", 'subtract_native_integer_from_native_integer' ) sub $I0, $I0, $I1 is( $I0, "4123", 'subtract_native_integer_from_native_integer' ) .end .sub multiply_native_integer_with_native_integer set $I0, 4000 set $I1, -123 mul $I2, $I0, $I1 is( $I2, "-492000", 'multiply_native_integer_with_native_integer' ) mul $I0, $I0, $I1 is( $I0, "-492000", 'multiply_native_integer_with_native_integer' ) .end .sub divide_native_integer_by_native_integer set $I0, 4000 set $I1, -123 div $I2, $I0, $I1 is( $I2, "-32", 'divide_native_integer_by_native_integer' ) div $I0, $I0, $I1 is( $I0, "-32", 'divide_native_integer_by_native_integer' ) .end # # print -0.0 as -0 # .sub negate_minus_zero_point_zero .local pmc interp, config_hash .local string has_negative_zero interp = getinterp config_hash = interp[.IGLOBALS_CONFIG_HASH] has_negative_zero = config_hash['has_negative_zero'] set $N0, 0 neg $N0 $S0 = $N0 unless has_negative_zero goto Todo_test1 is( $S0, "-0", '1' ) goto End_test1 Todo_test1: $I0 = $S0 == "-0" todo($I0, 'negative zero, GH #366') End_test1: set $N0, -0.0 neg $N0 $S0 = $N0 is( $S0, "0", '2' ) set $N0, -0.0 neg $N1, $N0 $S0 = $N1 is( $S0, "0", '3' ) set $N0, 0 set $N1, 1 neg $N1, $N0 $S0 = $N1 unless has_negative_zero goto Todo_test4 is( $S0, "-0", '4' ) goto End_test4 Todo_test4: $I0 = $S0 == "-0" todo($I0, 'negative zero, GH #366') End_test4: .end # # Operations on a single NUMVAL # .sub negate_a_native_number set $N0, 123.4567890 neg $N0 is( $N0, "-123.456789", 'negate_a_native_number' ) set $N0, -123.4567890 neg $N0 is( $N0, "123.456789", 'negate_a_native_number' ) set $N0, 123.4567890 neg $N1, $N0 is( $N1, "-123.456789", 'negate_a_native_number' ) set $N0, -123.4567890 neg $N1, $N0 is( $N1, "123.456789", 'negate_a_native_number' ) .end .sub take_the_absolute_of_a_native_number set $N0, 0 abs $N0 is( $N0, "0", 'take_the_absolute_of_a_native_number' ) set $N0, -0.0 abs $N0 is( $N0, "0", 'take_the_absolute_of_a_native_number' ) set $N0, 123.45678901 abs $N0 is( $N0, "123.45678901", 'take_the_absolute_of_a_native_number' ) set $N0, -123.45678901 abs $N0 is( $N0, "123.45678901", 'take_the_absolute_of_a_native_number' ) set $N0, 0 set $N1, 1 abs $N1, $N0 is( $N1, "0", 'take_the_absolute_of_a_native_number' ) set $N0, 0.0 set $N1, 1 abs $N1, $N0 is( $N1, "0", 'take_the_absolute_of_a_native_number' ) set $N0, 123.45678901 set $N1, 1 abs $N1, $N0 is( $N1, "123.45678901", 'take_the_absolute_of_a_native_number' ) set $N0, -123.45678901 set $N1, 1 abs $N1, $N0 is( $N1, "123.45678901", 'take_the_absolute_of_a_native_number' ) .end .sub ceil_of_a_native_number set $N0, 0 ceil $N0 is( $N0, "0", 'ceil_of_a_native_number' ) set $N0, 123.45678901 ceil $N0 is( $N0, "124", 'ceil_of_a_native_number' ) set $N0, -123.45678901 ceil $N0 is( $N0, "-123", 'ceil_of_a_native_number' ) set $N0, 0 set $N1, 1 ceil $N1, $N0 is( $N1, "0", 'ceil_of_a_native_number' ) set $N0, 0.0 set $N1, 1 ceil $N1, $N0 is( $N1, "0", 'ceil_of_a_native_number' ) set $N0, 123.45678901 set $N1, 1 ceil $N1, $N0 is( $N1, "124", 'ceil_of_a_native_number' ) set $N0, -123.45678901 set $N1, 1 ceil $N1, $N0 is( $N1, "-123", 'ceil_of_a_native_number' ) set $N0, 0 set $I1, 1 ceil $I1, $N0 is( $I1, "0", 'ceil_of_a_native_number' ) set $N0, 0.0 set $I1, 1 ceil $I1, $N0 is( $I1, "0", 'ceil_of_a_native_number' ) set $N0, 123.45678901 set $I1, 1 ceil $I1, $N0 is( $I1, "124", 'ceil_of_a_native_number' ) set $N0, -123.45678901 set $I1, 1 ceil $I1, $N0 is( $I1, "-123", 'ceil_of_a_native_number' ) .end .sub floor_of_a_native_number set $N0, 0 floor $N0 is( $N0, "0", 'floor_of_a_native_number' ) set $N0, 123.45678901 floor $N0 is( $N0, "123", 'floor_of_a_native_number' ) set $N0, -123.45678901 floor $N0 is( $N0, "-124", 'floor_of_a_native_number' ) set $N0, 0 set $N1, 1 floor $N1, $N0 is( $N1, "0", 'floor_of_a_native_number' ) set $N0, 0.0 set $N1, 1 floor $N1, $N0 is( $N1, "0", 'floor_of_a_native_number' ) set $N0, 123.45678901 set $N1, 1 floor $N1, $N0 is( $N1, "123", 'floor_of_a_native_number' ) set $N0, -123.45678901 set $N1, 1 floor $N1, $N0 is( $N1, "-124", 'floor_of_a_native_number' ) set $N0, 0 set $I1, 1 floor $I1, $N0 is( $I1, "0", 'floor_of_a_native_number' ) set $N0, 0.0 set $I1, 1 floor $I1, $N0 is( $I1, "0", 'floor_of_a_native_number' ) set $N0, 123.45678901 set $I1, 1 floor $I1, $N0 is( $I1, "123", 'floor_of_a_native_number' ) set $N0, -123.45678901 set $I1, 1 floor $I1, $N0 is( $I1, "-124", 'floor_of_a_native_number' ) .end # # FLOATVAL and INTVAL tests # .sub add_native_integer_to_native_number set $I0, 4000 set $N0, -123.123 add $N1, $N0, $I0 is( $N1, "3876.877", 'add_native_integer_to_native_number' ) add $N0, $N0, $I0 is( $N0, "3876.877", 'add_native_integer_to_native_number' ) add $N0, $I0 is( $N0, "7876.877", 'add_native_integer_to_native_number' ) .end .sub subtract_native_integer_from_native_number set $I0, 4000 set $N0, -123.123 sub $N1, $N0, $I0 is( $N1, "-4123.123", 'subtract_native_integer_from_native_number' ) sub $N0, $N0, $I0 is( $N0, "-4123.123", 'subtract_native_integer_from_native_number' ) sub $N0, $I0 is( $N0, "-8123.123", 'subtract_native_integer_from_native_number' ) .end .sub multiply_native_number_with_native_integer set $I0, 4000 set $N0, -123.123 mul $N1, $N0, $I0 is( $N1, "-492492", 'multiply_native_number_with_native_integer' ) mul $N0, $N0, $I0 is( $N0, "-492492", 'multiply_native_number_with_native_integer' ) mul $N0, -2 is( $N0, "984984", 'multiply_native_number_with_native_integer' ) .end .sub divide_native_number_by_native_integer set $I0, 4000 set $N0, -123.123 div $N1, $N0, $I0 is( $N1, "-0.03078075", 'divide_native_number_by_native_integer' ) div $N0, $N0, $I0 is( $N0, "-0.03078075", 'divide_native_number_by_native_integer' ) div $N0, 1 is( $N0, "-0.03078075", 'divide_native_number_by_native_integer' ) set $N0, 100.000 div $N0, 100 is( $N0, "1", 'divide_native_number_by_native_integer' ) div $N0, 0.01 is( $N0, "100", 'divide_native_number_by_native_integer' ) .end # # FLOATVAL and FLOATVAL tests # .sub add_native_number_to_native_number set $N2, 4000.246 set $N0, -123.123 add $N1, $N0, $N2 is( $N1, "3877.123", 'add_native_number_to_native_number' ) add $N0, $N0, $N2 is( $N0, "3877.123", 'add_native_number_to_native_number' ) .end .sub subtract_native_number_from_native_number set $N2, 4000.246 set $N0, -123.123 sub $N1, $N0, $N2 is( $N1, "-4123.369", 'subtract_native_number_from_native_number' ) sub $N0, $N0, $N2 is( $N0, "-4123.369", 'subtract_native_number_from_native_number' ) .end .sub multiply_native_number_with_native_number set $N2, 4000.246 set $N0, -123.123 mul $N1, $N0, $N2 is( $N1, "-492522.288258", 'multiply_native_number_with_native_number' ) mul $N0, $N0, $N2 is( $N0, "-492522.288258", 'multiply_native_number_with_native_number' ) .end .sub divide_native_number_by_native_number set $N2, 4000.246 set $N0, -123.123 div $N1, $N0, $N2 is( $N1, "-0.0307788571002883", 'divide_native_number_by_native_number' ) div $N0, $N0, $N2 is( $N0, "-0.0307788571002883", 'divide_native_number_by_native_number' ) .end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: pmctree.pl000755000765000765 103011606346603 15402 0ustar00bruce000000000000parrot-6.6.0/tools/dev#! perl # Copyright (C) 2001-2007, Parrot Foundation. use strict; use warnings; use lib qw( lib ); use Parrot::Pmc2c::PMC::PrintTree; my ( %action, %options, @pmc_include_paths ); my @args = @ARGV; my $self = Parrot::Pmc2c::PMC::PrintTree->new( { include => [ qw( src/pmc src/dynpmc ) ], opt => {}, args => \@args, bin => q{}, } ); $self->print_tree(); exit; # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: debugger.h000644000765000765 4113112307662657 16413 0ustar00bruce000000000000parrot-6.6.0/include/parrot/* * Copyright (C) 2002-2009, Parrot Foundation. */ /* * debugger.h * * Overview: * Parrot debugger header files * History: * Initial version by Daniel Grunblatt on 2002.5.19 * Notes: * References: */ #ifndef PARROT_PDB_H_GUARD #define PARROT_PDB_H_GUARD enum { PDB_NO_RUN = 1 << 0, PDB_SRC_LOADED = 1 << 1, PDB_RUNNING = 1 << 2, PDB_STOPPED = 1 << 3, PDB_BREAK = 1 << 4, /* Set only from debug_break */ PDB_EXIT = 1 << 5, PDB_ENTER = 1 << 6, PDB_GCDEBUG = 1 << 7, PDB_TRACING = 1 << 8, PDB_ECHO = 1 << 9 }; enum { PDB_cond_int = 1 << 0, PDB_cond_num = 1 << 1, PDB_cond_str = 1 << 2, PDB_cond_pmc = 1 << 3, PDB_cond_gt = 1 << 4, PDB_cond_ge = 1 << 5, PDB_cond_eq = 1 << 6, PDB_cond_ne = 1 << 7, PDB_cond_le = 1 << 8, PDB_cond_lt = 1 << 9, PDB_cond_const = 1 << 10, PDB_cond_notnull = 1 << 11 }; /* PDB_condition_t * Conditions for breakpoint or watchpoints. * * type: The type of condition and the way to use arguments. * reg: The register involved, there must be at least one. * value: A pointer to the second argument. * next: A pointer to the next condition - used to construct a * list of watchpoints; not used for conditional breakpoints */ typedef struct PDB_condition *PDB_condition_ptr; typedef struct PDB_condition { unsigned short type; unsigned char reg; unsigned char dummy; /* For alignment XXX ?? */ void *value; /* What neeeds to be aligned with what? */ PDB_condition_ptr next; } PDB_condition_t; /* PDB_label_t * A label in the source file. * * opcode: The pointer to the bytecode where the label is. * number: Number label. * next: The next label. */ typedef struct PDB_label *PDB_label_ptr; typedef struct PDB_label { const opcode_t *opcode; long number; PDB_label_ptr next; } PDB_label_t; /* PDB_line_t * A line in the source file. * * opcode: A pointer to the opcode in the bytecode corresponding to * this line. * source_offset: Offset from the source file start. * number: Line number. * label: The label if any. * next: The next line (if any). */ typedef struct PDB_line *PDB_line_ptr; typedef struct PDB_line { opcode_t *opcode; ptrdiff_t source_offset; unsigned long number; PDB_label_t *label; PDB_line_ptr next; } PDB_line_t; /* PDB_file_t * A source code file. * * sourcefilename: The source code file name. * source: The file itself. * size: The size of the file in bytes. * list_line: The next line to list. * line: The first line of the source code. * label: The first label. * next: The next file (if any); multiple files are not currently * supported */ typedef struct PDB_file *PDB_file_ptr; typedef struct PDB_file { char *sourcefilename; char *source; size_t size; unsigned long list_line; PDB_line_t *line; PDB_label_t *label; PDB_file_ptr next; } PDB_file_t; /* PDB_breakpoint_t * List of breakpoints. * * id: The identification number of this breakpoint * pc: Where the breakpoint is * line: The source file line number * skip: The number of times to skip this breakpoint * condition: The condition attached to the breakpoint; may be NULL * prev, next: The previous & next breakpoints in the list; may be NULL. */ typedef struct PDB_breakpoint *PDB_breakpoint_ptr; typedef struct PDB_breakpoint { unsigned long id; opcode_t *pc; unsigned long line; long skip; PDB_condition_t *condition; PDB_breakpoint_ptr prev; PDB_breakpoint_ptr next; } PDB_breakpoint_t; /* PDB_t * The debugger. * * file: Source code file. * breakpoint: The first breakpoint. * watchpoint: The first watchpoint * breakpoint_skip: Number of breakpoints to skip. * cur_command: The command being executed. * last_command: Last command executed. * cur_opcode: Current opcode. * state: The status of the program being debugged. * debugee: The interpreter we are debugging * debugger: The debugger interpreter */ typedef struct PDB { PDB_file_t *file; PDB_breakpoint_t *breakpoint; PDB_condition_t *watchpoint; unsigned long breakpoint_skip; char *cur_command; char *last_command; opcode_t *cur_opcode; int state; Interp *debugee; Interp *debugger; unsigned long tracing; FILE *script_file; unsigned long script_line; } PDB_t; /* HEADERIZER BEGIN: src/debug.c */ /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */ PARROT_EXPORT void Parrot_debugger_break(PARROT_INTERP, ARGIN(opcode_t * cur_opcode)) __attribute__nonnull__(1) __attribute__nonnull__(2); PARROT_EXPORT void Parrot_debugger_destroy(PARROT_INTERP) __attribute__nonnull__(1); PARROT_EXPORT void Parrot_debugger_init(PARROT_INTERP) __attribute__nonnull__(1); PARROT_EXPORT void Parrot_debugger_load(PARROT_INTERP, ARGIN_NULLOK(const STRING *filename)) __attribute__nonnull__(1); PARROT_EXPORT void Parrot_debugger_start(PARROT_INTERP, ARGIN_NULLOK(opcode_t * cur_opcode)) __attribute__nonnull__(1); PARROT_EXPORT void PDB_backtrace(PARROT_INTERP) __attribute__nonnull__(1); PARROT_EXPORT void PDB_load_source(PARROT_INTERP, ARGIN(const char *command)) __attribute__nonnull__(1) __attribute__nonnull__(2); PARROT_EXPORT void PDB_print(PARROT_INTERP, ARGIN(const char *command)) __attribute__nonnull__(1) __attribute__nonnull__(2); PARROT_EXPORT void PDB_script_file(PARROT_INTERP, ARGIN(const char *command)) __attribute__nonnull__(1) __attribute__nonnull__(2); PARROT_WARN_UNUSED_RESULT PARROT_CANNOT_RETURN_NULL STRING * Parrot_dbg_get_exception_backtrace(PARROT_INTERP, ARGMOD(PMC * exception)) __attribute__nonnull__(1) __attribute__nonnull__(2) FUNC_MODIFIES(* exception); long PDB_add_label(PARROT_INTERP, ARGMOD(PDB_file_t *file), ARGIN(const opcode_t *cur_opcode), opcode_t offset) __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__nonnull__(3) FUNC_MODIFIES(*file); void PDB_assign(PARROT_INTERP, ARGIN(const char *command)) __attribute__nonnull__(1) __attribute__nonnull__(2); PARROT_WARN_UNUSED_RESULT char PDB_break(PARROT_INTERP) __attribute__nonnull__(1); PARROT_WARN_UNUSED_RESULT char PDB_check_condition(PARROT_INTERP, ARGIN(const PDB_condition_t *condition)) __attribute__nonnull__(1) __attribute__nonnull__(2); PARROT_CAN_RETURN_NULL PDB_condition_t * PDB_cond(PARROT_INTERP, ARGIN(const char *command)) __attribute__nonnull__(1) __attribute__nonnull__(2); void PDB_continue(PARROT_INTERP, ARGIN_NULLOK(const char *command)) __attribute__nonnull__(1); void PDB_delete_breakpoint(PARROT_INTERP, ARGIN(const char *command)) __attribute__nonnull__(1) __attribute__nonnull__(2); void PDB_delete_condition(PARROT_INTERP, ARGMOD(PDB_breakpoint_t *breakpoint)) __attribute__nonnull__(1) __attribute__nonnull__(2) FUNC_MODIFIES(*breakpoint); void PDB_disable_breakpoint(PARROT_INTERP, ARGIN(const char *command)) __attribute__nonnull__(1) __attribute__nonnull__(2); void PDB_disassemble(PARROT_INTERP, ARGIN_NULLOK(const char *command)) __attribute__nonnull__(1); size_t PDB_disassemble_op(PARROT_INTERP, ARGOUT(char *dest), size_t space, ARGIN(const op_info_t *info), ARGIN(const opcode_t *op), ARGMOD_NULLOK(PDB_file_t *file), ARGIN_NULLOK(const opcode_t *code_start), int full_name) __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__nonnull__(4) __attribute__nonnull__(5) FUNC_MODIFIES(*dest) FUNC_MODIFIES(*file); void PDB_enable_breakpoint(PARROT_INTERP, ARGIN(const char *command)) __attribute__nonnull__(1) __attribute__nonnull__(2); PARROT_WARN_UNUSED_RESULT PARROT_CAN_RETURN_NULL PARROT_MALLOC char * PDB_escape(PARROT_INTERP, ARGIN(const char *string), UINTVAL length) __attribute__nonnull__(1) __attribute__nonnull__(2); void PDB_eval(PARROT_INTERP, const char *command) __attribute__nonnull__(1); PARROT_CAN_RETURN_NULL PARROT_WARN_UNUSED_RESULT PDB_breakpoint_t * PDB_find_breakpoint(PARROT_INTERP, ARGIN(const char *command)) __attribute__nonnull__(1) __attribute__nonnull__(2); void PDB_free_file(PARROT_INTERP, ARGIN_NULLOK(PDB_file_t *file)) __attribute__nonnull__(1); void PDB_get_command(PARROT_INTERP) __attribute__nonnull__(1); PARROT_WARN_UNUSED_RESULT PARROT_PURE_FUNCTION char PDB_hasinstruction(ARGIN(const char *c)) __attribute__nonnull__(1); void PDB_help(PARROT_INTERP, ARGIN(const char *command)) __attribute__nonnull__(1) __attribute__nonnull__(2); void PDB_info(PARROT_INTERP) __attribute__nonnull__(1); void PDB_init(PARROT_INTERP, ARGIN_NULLOK(const char *command)) __attribute__nonnull__(1); void PDB_list(PARROT_INTERP, ARGIN(const char *command)) __attribute__nonnull__(1) __attribute__nonnull__(2); void PDB_next(PARROT_INTERP, ARGIN_NULLOK(const char *command)) __attribute__nonnull__(1); char PDB_program_end(PARROT_INTERP) __attribute__nonnull__(1); PARROT_IGNORABLE_RESULT int /*@alt void@*/ PDB_run_command(PARROT_INTERP, ARGIN(const char *command)) __attribute__nonnull__(1) __attribute__nonnull__(2); void PDB_set_break(PARROT_INTERP, ARGIN_NULLOK(const char *command)) __attribute__nonnull__(1); void PDB_skip_breakpoint(PARROT_INTERP, unsigned long i) __attribute__nonnull__(1); void PDB_trace(PARROT_INTERP, ARGIN_NULLOK(const char *command)) __attribute__nonnull__(1); int PDB_unescape(ARGMOD(char *string)) __attribute__nonnull__(1) FUNC_MODIFIES(*string); void PDB_watchpoint(PARROT_INTERP, ARGIN(const char *command)) __attribute__nonnull__(1) __attribute__nonnull__(2); #define ASSERT_ARGS_Parrot_debugger_break __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(cur_opcode)) #define ASSERT_ARGS_Parrot_debugger_destroy __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp)) #define ASSERT_ARGS_Parrot_debugger_init __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp)) #define ASSERT_ARGS_Parrot_debugger_load __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp)) #define ASSERT_ARGS_Parrot_debugger_start __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp)) #define ASSERT_ARGS_PDB_backtrace __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp)) #define ASSERT_ARGS_PDB_load_source __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(command)) #define ASSERT_ARGS_PDB_print __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(command)) #define ASSERT_ARGS_PDB_script_file __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(command)) #define ASSERT_ARGS_Parrot_dbg_get_exception_backtrace \ __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(exception)) #define ASSERT_ARGS_PDB_add_label __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(file) \ , PARROT_ASSERT_ARG(cur_opcode)) #define ASSERT_ARGS_PDB_assign __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(command)) #define ASSERT_ARGS_PDB_break __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp)) #define ASSERT_ARGS_PDB_check_condition __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(condition)) #define ASSERT_ARGS_PDB_cond __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(command)) #define ASSERT_ARGS_PDB_continue __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp)) #define ASSERT_ARGS_PDB_delete_breakpoint __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(command)) #define ASSERT_ARGS_PDB_delete_condition __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(breakpoint)) #define ASSERT_ARGS_PDB_disable_breakpoint __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(command)) #define ASSERT_ARGS_PDB_disassemble __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp)) #define ASSERT_ARGS_PDB_disassemble_op __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(dest) \ , PARROT_ASSERT_ARG(info) \ , PARROT_ASSERT_ARG(op)) #define ASSERT_ARGS_PDB_enable_breakpoint __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(command)) #define ASSERT_ARGS_PDB_escape __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(string)) #define ASSERT_ARGS_PDB_eval __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp)) #define ASSERT_ARGS_PDB_find_breakpoint __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(command)) #define ASSERT_ARGS_PDB_free_file __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp)) #define ASSERT_ARGS_PDB_get_command __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp)) #define ASSERT_ARGS_PDB_hasinstruction __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(c)) #define ASSERT_ARGS_PDB_help __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(command)) #define ASSERT_ARGS_PDB_info __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp)) #define ASSERT_ARGS_PDB_init __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp)) #define ASSERT_ARGS_PDB_list __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(command)) #define ASSERT_ARGS_PDB_next __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp)) #define ASSERT_ARGS_PDB_program_end __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp)) #define ASSERT_ARGS_PDB_run_command __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(command)) #define ASSERT_ARGS_PDB_set_break __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp)) #define ASSERT_ARGS_PDB_skip_breakpoint __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp)) #define ASSERT_ARGS_PDB_trace __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp)) #define ASSERT_ARGS_PDB_unescape __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(string)) #define ASSERT_ARGS_PDB_watchpoint __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(command)) /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */ /* HEADERIZER END: src/debug.c */ #endif /* PARROT_PDB_H_GUARD */ /* * Local variables: * c-file-style: "parrot" * End: * vim: expandtab shiftwidth=4 cinoptions='\:2=2' : */ oofib.rb000644000765000765 57411533177634 17044 0ustar00bruce000000000000parrot-6.6.0/examples/benchmarks#! ruby class A def fib(n) return n if (n < 2) return fibA(n - 1) + fibB(n - 2) end def fibA(n) return n if (n < 2) return fib(n - 1) + fibB(n - 2) end end class B < A def fibB(n) return n if (n < 2) return fib(n - 1) + fibA(n - 2) end end b = B.new N = Integer( ARGV.shift || 24 ) puts "fib(#{N}) = #{ b.fib(N) }" basic.t000644000765000765 1045311567202625 13646 0ustar00bruce000000000000parrot-6.6.0/t/op#!perl # Copyright (C) 2001-2007, Parrot Foundation. use strict; use warnings; use lib qw( . lib ../lib ../../lib ); use Test::More; use Parrot::Test tests => 23; =head1 NAME t/op/basic.t - Basic Ops =head1 SYNOPSIS % prove t/op/basic.t =head1 DESCRIPTION Tests basic string and branching operations. =cut # It would be very embarrassing if these didnt work... pasm_output_is( <<'CODE', '', "noop, end" ); .pcc_sub :main main: noop end CODE pasm_output_is( <<'CODE', '1', "print 1" ); .pcc_sub :main main: print 1 end CODE pasm_output_is( <<'CODE', 'Parrot flies', "print string" ); .pcc_sub :main main: print 'Parrot flies' end CODE pasm_output_is( <<'CODE', 'Parrot flies', "print double-quoted string" ); .pcc_sub :main main: print "Parrot flies" end CODE pasm_output_is( <<'CODE', "Parrot\tflies", "print double-quoted string, tabs" ); .pcc_sub :main main: print "Parrot\tflies" end CODE pasm_output_is( <<'CODE', q('Parrot' flies), "print double-quoted string, nested single" ); .pcc_sub :main main: print "'Parrot' flies" end CODE pasm_output_is( <<'CODE', q("Parrot" flies), "print single-quoted string, nested double" ); .pcc_sub :main main: print '"Parrot" flies' end CODE pasm_output_is( <<'CODE', q(Parrot flies), "print string with embedded hex escape" ); .pcc_sub :main main: print "Parrot\x20flies" end CODE pasm_output_is( <<'CODE', q(Parrot flies), "escaped non-special" ); .pcc_sub :main main: print "Parrot fl\ies" end CODE pasm_output_is( <<'CODE', < The build prefix. Defaults to ''. =item C The install prefix. Defaults to '/usr'. =item C The exec prefix. Defaults to '/usr'. =item C The executables directory. Defaults to '/usr/bin'. =item C The library directory. Defaults to '/usr/lib'. =item C The header directory. Defaults to '/usr/include'. =item C The man directory. Defaults to '/usr/share/man'. =item C The data directory. Defaults to '/usr/share'. =back =head1 SEE ALSO See F for a detailed description of the MANIFEST format. =cut ################################################################################ use strict; use warnings; use File::Basename qw(basename); use lib qw( lib ); use Parrot::Install qw( install_files create_directories lines_to_files ); # When run from the makefile, which is probably the only time this # script will ever be used, all of these defaults will get overridden. my %options = ( buildprefix => '', prefix => '/usr', destdir => '', exec_prefix => '/usr', bindir => '/usr/bin', libdir => '/usr/lib', # parrot/ subdir added below includedir => '/usr/include', # parrot/ subdir added below docdir => '/usr/share/doc', # parrot/ subdir added below datadir => '/usr/share/', # parrot/ subdir added below mandir => '/usr/share/man', versiondir => '', 'dry-run' => 0, packages => 'doc|examples', ); my @manifests; foreach (@ARGV) { if (/^--([^=]+)=(.*)/) { $options{$1} = $2; } else { push @manifests, $_; } } my $parrotdir = $options{versiondir}; # Set up transforms on filenames my(@transformorder) = (qw(doc man examples)); my(%metatransforms) = ( doc => { optiondir => 'doc', transform => sub { my($filehash) = @_; $filehash->{Dest} =~ s#^docs/resources#resources#; # resources go in the top level of docs $filehash->{Dest} =~ s/^docs/pod/; # other docs are actually raw Pod $filehash->{DestDirs} = [$parrotdir]; return($filehash); }, }, man => { ismeta => 1, optiondir => 'man', transform => sub { my($filehash) = @_; $filehash->{Dest} =~ s{^.*/}{}; # basedir only $filehash->{Dest} =~ s{^(.+\.)(.+)$}{man$2/$1$2}; return($filehash); }, }, examples => { optiondir => 'doc', transform => sub { my($filehash) = @_; $filehash->{DestDirs} = [$parrotdir]; return($filehash); }, }, ); my($filehashes, $directories) = lines_to_files( \%metatransforms, \@transformorder, \@manifests, \%options, $parrotdir ); unless ( $options{'dry-run'} ) { $directories->{File::Spec->catdir( $options{datadir}, $parrotdir)} = 1; create_directories($options{destdir}, $directories); } install_files(\%options, 'doc', $filehashes); print "Finished install_doc_files.pl\n"; # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: pir_vim.in000644000765000765 1105211533177634 15002 0ustar00bruce000000000000parrot-6.6.0/editor" Vim syntax file " Language: Parrot IMCC " Maintainer: Luke Palmer " Modified: Joshua Isom " Last Change: Jan 6 2006 " For installation please read: " :he filetypes " :he syntax " " For version 5.x: Clear all syntax items " For version 6.x: Quit when a syntax file was already loaded " if version < 600 syntax clear elseif exists("b:current_syntax") finish endif syntax clear syn include @Pod syntax/pod.vim syn region pirPod start="^=[a-z]" end="^=cut" keepend contains=@Pod fold syn keyword pirType int float num string pmc syn match pirPMC /\.\(Compiler\|Continuation\|Coroutine\|CSub\|NCI\|Eval\|Sub\|Scratchpad\)/ syn match pirPMC /\.\(BigInt\|Boolean\|Complex\|Float\|Integer\|PMC\|String\|Hash\)/ syn match pirPMC /\.\(Fixed\|Resizable\)\(Boolean\|Float\|Integer\|PMC\|String\)Array/ syn match pirPMC /\.\(IntList\|Iterator\|Key\|ManagedStruct\|UnManagedStruct\|Pointer\)/ syn match pirPMC /\.\(FloatVal\|Multi\|S\|String\)\?Array/ syn match pirPMC /\.Perl\(Array\|Env\|Hash\|Int\|Num\|Scalar\|String\|Undef\)/ syn match pirPMC /\.Parrot\(Class\|Interpreter\|IO\|Library\|Object\|Thread\)/ syn keyword pirPMC self syn keyword pirOp goto if unless global addr syn match pirDirectiveSub /\.\(sub\|end\s*$\)/ syn match pirDirectiveMacro /\.\(macro\|endm\)/ syn match pirDirective /\.\(pcc_sub\|emit\|eom\)/ syn match pirDirective /\.\(local\|sym\|const\|lex\|global\|globalconst\)/ syn match pirDirective /\.\(endnamespace\|namespace\)/ syn match pirDirective /\.\(param\|arg\|return\|yield\)/ syn match pirDirective /\.\(pragma\|HLL\|include\|loadlib\)/ syn match pirDirective /\.\(pcc_begin\|pcc_call\|pcc_end\|invocant\|meth_call\|nci_call\)/ syn match pirDirective /\.\(pcc_begin_return\|pcc_end_return\)/ syn match pirDirective /\.\(pcc_begin_yield\|pcc_end_yield\)/ syn match pirDirective /:\(main\|method\|load\|init\|anon\|multi\|immediate\|outer\|lex\|vtable|nsentry\|subid\)/ syn match pirDirective /:\(flat\|slurpy\|optional\|opt_flag\|named\)/ " Macro invocation syn match pirDirective /\.\I\i*(/he=e-1 " pirWord before pirRegister " FIXME :: in identifiers and labels syn match pirWord /[A-Za-z_][A-Za-z0-9_]*/ syn match pirComment /#.*/ syn match pirLabel /[A-Za-z0-9_]\+:/he=e-1 syn match pirRegister /[INPS]\([12][0-9]\|3[01]\|[0-9]\)/ syn match pirDollarRegister /\$[INPS][0-9]\+/ syn match pirNumber /[+-]\?[0-9]\+\(\.[0-9]*\([Ee][+-]\?[0-9]\+\)\?\)\?/ syn match pirNumber /0[xX][0-9a-fA-F]\+/ syn match pirNumber /0[oO][0-7]\+/ syn match pirNumber /0[bB][01]\+/ syn region pirString start=/"/ skip=/\\"/ end=/"/ contains=pirStringSpecial syn region pirString start=/<<"\z(\I\i*\)"/ end=/^\z1$/ contains=pirStringSpecial syn region pirString start=/<<'\z(\I\i*\)'/ end=/^\z1$/ syn region pirString start=/'/ end=/'/ syn match pirStringSpecial "\\\([abtnvfre\\"]\|\o\{1,3\}\|x{\x\{1,8\}}\|x\x\{1,2\}\|u\x\{4\}\|U\x\{8\}\|c[A-Z]\)" contained " Define the default highlighting. " For version 5.7 and earlier: only when not done already " For version 5.8 and later: only when an item doesn't have highlighting yet if version >= 508 || !exists("did_pasm_syntax_inits") if version < 508 let did_pasm_syntax_inits = 1 command -nargs=+ HiLink hi link else command -nargs=+ HiLink hi def link endif HiLink pirPod Comment HiLink pirWord Normal HiLink pirComment Comment HiLink pirLabel Label HiLink pirRegister Identifier HiLink pirDollarRegister Identifier HiLink pirType Type HiLink pirPMC Type HiLink pirString String HiLink pirStringSpecial Special HiLink pirNumber Number HiLink pirDirective Macro HiLink pirDirectiveSub Macro HiLink pirDirectiveMacro Macro HiLink pirOp Conditional delcommand HiLink endif let b:current_syntax = "pir" " Folding rules syn region foldManual start=/^\s*#.*{{{/ end=/^\s*#.*}}}/ contains=ALL keepend fold syn region foldMakro start=/\.macro/ end=/^\s*\.endm/ contains=ALLBUT,pirDirectiveMacro keepend fold syn region foldSub start=/\.sub/ end=/^\s*\.end/ contains=ALLBUT,pirDirectiveSub,pirDirectiveMacro keepend fold syn region foldIf start=/^\s*if.*goto\s*\z(\I\i*\)\s*$/ end=/^\s*\z1:\s*$/ contains=ALLBUT,pirDirectiveSub,pirDirectiveMacro keepend fold syn region foldUnless start=/^\s*unless.*goto\s*\z(\I\i*\)\s*$/ end=/^\s*\z1:\s*$/ contains=ALLBUT,pirDirectiveSub,pirDirectiveMacro keepend fold " Ops -- dynamically generated from ops2vim.pl pod_description.t000644000765000765 427112101554067 17266 0ustar00bruce000000000000parrot-6.6.0/t/codingstd#! perl # Copyright (C) 2001-2012, Parrot Foundation. use strict; use warnings; use Carp; use Test::More; use lib qw( lib ); BEGIN { eval 'use Parrot::Test::Pod'; if ($@) { plan skip_all => 'Prerequisites for Parrot::Test::Pod not satisfied'; exit; } eval 'use Parrot::Test::Pod::Utils qw( file_pod_ok empty_description )'; if ($@) { plan skip_all => 'Prerequisites for Parrot::Test::Pod::Utils not satisfied'; exit; } } plan tests => 2; my $self = Parrot::Test::Pod->new( { argv => [ @ARGV ], } ); ok( defined $self, "Parrot::Test::Pod returned defined value" ); my $need_testing_ref = $self->identify_files_for_POD_testing( { second_analysis => 'oreilly_summary_malformed', } ); my @empty_description; foreach my $file ( @{ $need_testing_ref } ) { # check DESCRIPTION section on valid POD files if ( file_pod_ok($file) and empty_description($file) ) { # Pod::Simple cannot handle perl6 pod yet (=begin pod/=end pod) push @empty_description, $file unless $file =~ /\.p6$/; } } my $empty_description_files = join( "\n", sort @empty_description); my $nempty_description = scalar( @empty_description ); is( $empty_description_files, q{}, 'All Pod files have non-empty DESCRIPTION sections' ); diag("\nFound $nempty_description files without DESCRIPTION sections.\n") if $nempty_description; #################### SUBROUTINES #################### =head1 NAME t/codingstd/pod_description.t - Identify files lacking 'DESCRIPTION' in POD =head1 SYNOPSIS # test all files % prove t/codingstd/pod_description.t # test specific files % perl t/codingstd/pod_description.t perl_module.pm perl_file.pl # test and obtain a list of those files which fail to pass the test % prove -v t/codingstd/pod_description.t =head1 DESCRIPTION Tests the Pod syntax for all files listed in F and F that appear to contain Pod markup. If any files contain with valid POD markup lack C sections, list them. =cut # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: ack.pir_output000644000765000765 2111466337261 20024 0ustar00bruce000000000000parrot-6.6.0/examples/shootoutAck(3, 7) = 1021 parrot_fuzzer.py000755000765000765 4105711644422131 16722 0ustar00bruce000000000000parrot-6.6.0/tools/dev#!/usr/bin/env python # Copyright (C) 2009-2011, Parrot Foundation. from fusil.application import Application from fusil.process.watch import WatchProcess from fusil.process.create import CreateProcess from fusil.process.stdout import WatchStdout from fusil.project_agent import ProjectAgent from fusil.process.tools import locateProgram from fusil.write_code import WriteCode from optparse import OptionGroup import re import string import random ''' =head1 NAME parrot_fuzzer.py - opcode fuzzer =head1 DESCRIPTION This is a fuzzer for Parrot, written in Python using the Fusil library. It attempts to break Parrot by generating calls to random PIR opcodes. =head1 DEPENDENCIES This script requires Python 2.5+ to run. The Fusil L and python-ptrace L libraries are also required. =head1 USAGE Short version: C C is run like any other Fusil-based fuzzer. Fusil likes to be run as the root user so that the child process in which Parrot runs can be put in a more restricted environment, limiting potential damage. Fusil assumes the existence of a C user and group. Parrot runs as this user/group as part of its restricted environment. Passing C<--unsafe> allows it to run as the current user. Although it is not likely that this will cause any damage to your system, it is possible. C needs access to Parrot's source code in order to figure out which PMCs and ops are available. It assumes that it's running in the root directory of Parrot's source code. You can specify a different directory using the C<--parrot-root> switch. =head1 OPTIONS =over 4 =item C<--parrot-root=/path/to/parrot> Represents the path to the Parrot root directory. By default, this is the current directory. =item C<--runcore=--some-runcore> Specifies which runcore to use when running Parrot. The default is the I core. This option corresponds directly to Parrot's C<--runcore> option. Other runcores include I. Run C for more details. =item C<--ignore-blacklist> Some PMC's and opcodes are known to cause false positives or results of limited value. These are blacklisted by default. Using C<--ignore-blacklist> causes the fuzzer to use all available PMC's and opcodes, even those known to behave badly during testing. =item C<--instructions=10> Represents the number of instructions during the test run. Note that a larger number such as 20 does not necessarily result in more failures. Defaults to 3. =back =head1 LICENSE This program is distributed under the same license as Parrot itself. =cut ''' class ParrotFuzzer(Application): # Base name of the dir where temp files and successful results will be stored NAME="parrot_fuzz" def createFuzzerOptions(self, parser): options = OptionGroup(parser, "Parrot fuzzer") options.add_option("--parrot-root", help="Parrot program path (default: .)", type="str", default=".") options.add_option("--runcore", help="Run Parrot with the specified runcore (default: --slow-core)", type="str", default="--slow-core") options.add_option("--instructions", help="Generate this many instructions per test run (default: 3)", type="int", default="3") options.add_option("--ignore-blacklist", help="Use opcodes and PMCs known to cause bad or questionable results (default: use blacklists)", action="store_true", default=False) return options def setupProject(self): parrot_root = self.options.parrot_root runcore = self.options.runcore parrot = locateProgram(parrot_root + "/parrot") process = ParrotProcess(self.project, [parrot, runcore, ""]) pirgen = PirGenerator(self.project, self.options) WatchProcess(process) WatchStdout(process) class PirGenerator(ProjectAgent, WriteCode): def __init__(self, project, options): self.parrot_root = options.parrot_root self.instruction_count = options.instructions self.ignore_blacklist = options.ignore_blacklist self.opfunc_gen = OpfuncGenerator() self.arg_gen = ArgGenerator(self.parrot_root, self.ignore_blacklist) self.opfunc_gen.populateOpfuncList(self.parrot_root, self.ignore_blacklist) ProjectAgent.__init__(self, project, "pir_source") WriteCode.__init__(self) def generatePir(self, filename): self.pir_body = '' self.pir_preamble = """ .sub main $P0 = new ['ExceptionHandler'] set_addr $P0, catchall push_eh $P0 #pokemon: gotta catch 'em all """ self.pir_postamble = """ catchall: # Don't do anything with exceptions: we're hoping for a segfault or similar. .end """ # How many instructions to generate # Strangely, a low number like 3 seems to generate slightly more faults # than a high number like 20 opfunc_count = self.instruction_count self.pir_body += " # generating "+str(opfunc_count)+" instructions\n" arg_types = ['s', 'p', 'i', 'n', 'sc', 'ic', 'nc'] opfuncs = [] arg_counts = dict() self.createFile(filename) arg_gen = self.arg_gen # Pick some opfuncs for i in range(opfunc_count): opfuncs.append(OpfuncCall(*self.opfunc_gen.getOpfunc())) # Calculate how many of each type of arg will be needed for arg_type in arg_types: arg_counts[arg_type] = 0 for opfunc in opfuncs: arg_counts[arg_type] += opfunc.getArgCount(arg_type) for arg_type in arg_types: arg_gen.setArgCount(arg_type, arg_counts[arg_type]) # Generate the args, adding any supporting code to the preamble self.pir_preamble += arg_gen.generateStringArgs() self.pir_preamble += arg_gen.generatePMCArgs() self.pir_preamble += arg_gen.generateIntArgs() self.pir_preamble += arg_gen.generateNumArgs() self.pir_preamble += arg_gen.generateStringConstArgs() self.pir_preamble += arg_gen.generateIntConstArgs() self.pir_preamble += arg_gen.generateNumConstArgs() # Put the args into the opfunc calls for opfunc in opfuncs: for arg_num in range(opfunc.getTotalArgCount()): arg_type = opfunc.getArgType(arg_num) opfunc.setArgVal(arg_num, arg_gen.getArgVal(arg_type)) self.pir_body += opfunc.getOpfuncCall() # Write the code self.write(0, self.pir_preamble) self.write(0, self.pir_body) self.write(0, self.pir_postamble) self.close() def on_session_start(self): filename = self.session().createFilename('fuzzy.pir') self.generatePir(filename) self.send('pir_source', filename) # Representation of a call to an opfunc, including values of arguments # Note that argumens are literal, e.g. '$P0', '"foo"', etc class OpfuncCall: def __init__(self, name, sig): self.arg_types = [] self.arg_vals = [] self.name = name if sig == '': self.long_name = name else: self.long_name = name + '_' + sig self.total_arg_count = 0 if sig != '': for arg in string.split(sig, "_"): self.arg_types.append(arg) self.arg_vals.append('') self.total_arg_count += 1 def getLongName(self): return self.long_name def getArgCount(self, arg): return self.arg_types.count(arg) def getTotalArgCount(self): return self.total_arg_count def getArgType(self, n): return self.arg_types[n] def getArgType(self, n): return self.arg_types[n] def setArgVal(self, n, arg_val): self.arg_vals[n] = arg_val def getOpfuncCall(self): opfunc_call = '\n # '+self.long_name+'\n ' + self.name for arg_val in self.arg_vals: opfunc_call += ' ' + arg_val + ',' opfunc_call = string.rstrip(opfunc_call, ",") opfunc_call += "\n" return opfunc_call class ArgGenerator: arg_counts = {} args = {} def __init__(self, parrot_root, ignore_blacklist): self.pmc_gen = PMCTypeGenerator() self.pmc_gen.populatePMCList(parrot_root, ignore_blacklist) def setArgCount(self, arg_type, count): self.arg_counts[arg_type] = count def getArgVal(self, arg_type): return random.choice(self.args[arg_type]) def generateStringArgs(self): pir_preamble = "" self.args['s'] = [] for n in range(self.arg_counts['s']): str_val = self.getString() pir_preamble += " $S" + str(n) + " = \"" + str_val + "\"\n" self.args['s'].append('$S' + str(n)) return pir_preamble def generatePMCArgs(self): pir_preamble = "" self.args['p'] = [] for n in range(self.arg_counts['p']): pir_preamble += " $P" + str(n) + " = new ['" + self.pmc_gen.getPMCType() + "']\n" self.args['p'].append('$P' + str(n)) return pir_preamble def generateIntArgs(self): pir_preamble = "" self.args['i'] = [] for n in range(self.arg_counts['i']): num = random.choice(['neg_many','neg_one','zero','pos_one','pos_many']) if num == 'neg_many': num_val = random.randint(-999999,-2) if num == 'neg_one': num_val = -1 if num == 'zero': num_val = 0 if num == 'pos_one': num_val = 1 if num == 'pos_many': num_val = random.randint(2, 999999) pir_preamble += " $I" + str(n) + " = "+str(num_val)+"\n" self.args['i'].append('$I' + str(n)) return pir_preamble def generateNumArgs(self): pir_preamble = "" self.args['n'] = [] for n in range(self.arg_counts['n']): num = random.choice(['neg_many','neg_one','zero','pos_one','pos_many']) if num == 'neg_many': num_val = (random.random() * -999999) - 1 if num == 'neg_one': num_val = -1.0 if num == 'zero': num_val = 0.0 if num == 'pos_one': num_val = 1.0 if num == 'pos_many': num_val = (random.random() * 999999) + 1 pir_preamble += " $N" + str(n) + " = "+str(num_val)+"\n" self.args['n'].append('$N' + str(n)) return pir_preamble def generateStringConstArgs(self): pir_preamble = "" self.args['sc'] = [] for n in range(self.arg_counts['sc']): self.args['sc'].append('"'+self.getString()+'"') return pir_preamble def generateIntConstArgs(self): pir_preamble = "" self.args['ic'] = [] for n in range(self.arg_counts['ic']): # Negative numbers and zero mess up control flow-related ops #num = random.choice(['neg_many','neg_one','zero','pos_one','pos_many']) num = random.choice(['pos_one','pos_many']) if num == 'neg_many': num_val = random.randint(-999999,-2) if num == 'neg_one': num_val = -1 if num == 'zero': num_val = 0 if num == 'pos_one': num_val = 1 if num == 'pos_many': num_val = random.randint(2, 999999) self.args['ic'].append(str(num_val)) return pir_preamble def generateNumConstArgs(self): pir_preamble = "" self.args['nc'] = [] for n in range(self.arg_counts['nc']): num = random.choice(['neg_many','neg_one','zero','pos_one','pos_many']) if num == 'neg_many': num_val = (random.random() * -999999) - 1 if num == 'neg_one': num_val = -1.0 if num == 'zero': num_val = 0.0 if num == 'pos_one': num_val = 1.0 if num == 'pos_many': num_val = (random.random() * 999999) + 1 self.args['nc'].append(str(num_val)) return pir_preamble def getString(self): str_val = '' chars = string.printable + string.punctuation + string.whitespace str_len = random.randint(0,10) for m in range(str_len): char = chars[random.randint(0, len(chars)-1)] if char == '"': char = '\\"' if char == '\\': char = '\\\\' if char == '\n' or char == '\r': char = '' str_val += char return str_val class PMCTypeGenerator: pmc_list = [] pmc_blacklist = [ 'Packfile', 'PackfileAnnotation', 'PackfileAnnotationKeys', 'PackfileAnnotations', 'PackfileConstantTable', 'PackfileDirectory', 'PackfileFixupEntry', 'PackfileFixupTable', 'PackfileRawSegment', 'PackfileSegment', ] def populatePMCList(self, parrot_root, ignore_blacklist): pmc_pm = parrot_root + "/lib/Parrot/PMC.pm" pmc_f = open(pmc_pm, 'r') for line in pmc_f: if re.search('\t[a-zA-Z]+ => [0-9]+,', line): line = re.sub('\t', '', line) line = re.sub(' =>.*\n', '', line) if ignore_blacklist or line not in self.pmc_blacklist: self.pmc_list.append(line) def getPMCType(self): return random.choice(self.pmc_list) class OpfuncGenerator: opfunc_list = [] opfunc_blacklist = [ 'check_events', # Only for testing 'check_events__', # Not for direct use 'clears', # Clearing all [SPIN] registers isn't useful 'clearp', 'cleari', 'clearn', 'cpu_ret', 'debug', 'debug_break', 'debug_init', 'debug_load', 'debug_print', 'die', 'exit', 'gc_debug', 'if', 'pic_callr__', 'pic_get_params__', 'pic_infix__', 'pic_inline_sub__', 'pic_set_returns__', 'pin', 'pop_eh', 'prederef__', 'profile', 'push_eh', 'returncc', 'rethrow', 'runinterp', 'setn_ind', 'sets_ind', 'seti_ind', 'setp_ind', 'sleep', 'tailcall', 'trace', 'trap', 'unless', 'unpin', 'yield', ] def populateOpfuncList(self, parrot_root, ignore_blacklist): ops_h = parrot_root + "/src/ops/core_ops.c" ops_f = open(ops_h, 'r') # This is a moderately fragile hack that relies on the specific # format of some generated code, expect breakage for line in ops_f: if line.find('PARROT_INLINE_OP') > -1 or line.find('PARROT_FUNCTION_OP') > -1: line = ops_f.next() short_name = line line = ops_f.next() long_name = line # Strip leading space and opening double-quote short_name = re.sub('[ ]+"', '', short_name) long_name = re.sub('[ ]+"', '', long_name) # Strip everything after closing double-quote short_name = re.sub('".*\n', '', short_name) long_name = re.sub('".*\n', '', long_name) if long_name == short_name: sig = '' else: sig = string.replace(long_name, short_name + '_', '') #XXX: Don't know how to handle these args if (not re.search('(pc|k|ki|kc|kic)', sig)): if ignore_blacklist or short_name not in self.opfunc_blacklist: self.opfunc_list.append([short_name, sig]) # print "accepted "+long_name+"("+sig+")" #else: # print "REJECTED "+long_name+"("+sig+")" def getOpfunc(self): return random.choice(self.opfunc_list) class ParrotProcess(CreateProcess): def on_pir_source(self, filename): self.cmdline.arguments[1] = filename self.createProcess() if __name__ == "__main__": ParrotFuzzer().main() pbcversion_h.pl000644000765000765 235611533177646 16766 0ustar00bruce000000000000parrot-6.6.0/tools/build#! perl # Copyright (C) 2001-2007, Parrot Foundation. =head1 NAME tools/build/pbcversion_h.pl - Create pbcversion.h =head1 SYNOPSIS % perl tools/build/pbcversion_h.pl > include/parrot/pbcversion.h =head1 DESCRIPTION The F file is used to maintain Parrot bytecode compatibility. This script extracts the latest major and minor bytecode version numbers and places them in a header file. =cut use warnings; use strict; use lib 'lib'; use Parrot::BuildUtil; my ( $major, $minor ) = Parrot::BuildUtil::get_bc_version(); unless ( defined $major && defined $minor ) { die "No bytecode version found in 'PBC_COMPAT'."; } print << "EOF"; /* ex: set ro: * !!!!!!! DO NOT EDIT THIS FILE !!!!!!! * * This file is generated automatically from 'PBC_COMPAT' * by $0. * * Any changes made here will be lost! * */ #ifndef PARROT_PBCVERSION_H_GUARD #define PARROT_PBCVERSION_H_GUARD #define PARROT_PBC_MAJOR $major #define PARROT_PBC_MINOR $minor #endif /* PARROT_PBCVERSION_H_GUARD */ /* * Local variables: * c-file-style: "parrot" * buffer-read-only: t * End: * vim: expandtab shiftwidth=4: */ EOF # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: faces.pl000755000765000765 212612101554067 15027 0ustar00bruce000000000000parrot-6.6.0/tools/dev#! perl # Copyright (C) 2010, Parrot Foundation. use strict; use warnings; use Gravatar::URL; =head1 NAME faces.pl - Generate source for Parrot wiki ParrotFaces page =head1 SYNOPSIS perl tools/dev/faces.pl =head1 DESCRIPTION Used to create L =head1 PREREQUISITE Gravatar::URL (L). =cut open my $fh, '<', 'CREDITS'; my %urls; while(<$fh>) { next unless /^E: (.*)/; my $email = lc $1; next if $email eq 'svn@perl.org' or $email eq 'cvs@perl.org'; if (!exists $urls{$email}) { $urls{$email} = gravatar_url( email => $email, rating => 'r', size => 80, default => 'wavatar', ); } else { warn "duplicated email address in CREDITS: $email\n"; } } foreach my $email (sort keys %urls) { print "![]($urls{$email} \"$email\")\n"; } print "\n\n_Generated by $0_\n"; # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: Make_VERSION_File.pm000644000765000765 137611533177644 20761 0ustar00bruce000000000000parrot-6.6.0/t/configure/testlib# Copyright (C) 2007, Parrot Foundation. package Make_VERSION_File; use strict; use warnings; our (@ISA, @EXPORT_OK); @ISA = qw( Exporter ); @EXPORT_OK = qw( make_VERSION_file ); sub make_VERSION_file { my $v = shift; my $vfile = 'VERSION'; open my $FH, '>', $vfile or die "Unable to open $vfile for writing: $!"; print $FH $v; close $FH or die "Unable to close $vfile after writing: $!"; } 1; =head1 NAME t/configure/testlib/Make_VERSION_File.pm - Subroutines used in testing C =head1 DESCRIPTION Use only in test scripts. =head1 AUTHOR James E Keenan =cut # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: structview.pmc000644000765000765 11441112356767111 16027 0ustar00bruce000000000000parrot-6.6.0/src/pmc/* Copyright (C) 2001-2014, Parrot Foundation. =head1 NAME src/pmc/structview.pmc - StructView PMC =head1 DESCRIPTION PMC class to view pointers as C Cs, required for NCI. This includes read, write, allocate, and deallocate operations. Bounds checking is implemented where the pointer class reports a non-zero bound. Recursive definition through nesting is not supported but can be emulated by interpreting pointer or buffer elements as structs once dereferenced. Elements are get/set using keyed access of the form C<[Ptr; Idx]>, which will interpret the C PMC and lookup the C'th element. =head2 Vtables and Methods =over 4 =cut */ #include "pmc/pmc_ptrobj.h" BEGIN_PMC_HEADER_PREAMBLE typedef enum { int_access = 1, unaligned_access, num_access, str_access, pmc_access } elt_access_t; typedef struct elt_desc_t { elt_access_t access; PARROT_DATA_TYPE type; size_t byte_offset; unsigned char bit_offset; size_t size; } elt_desc_t; END_PMC_HEADER_PREAMBLE /* HEADERIZER HFILE: none */ /* HEADERIZER BEGIN: static */ /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */ PARROT_DOES_NOT_RETURN static void buffer_too_small(PARROT_INTERP, size_t self_size, size_t buf_size) __attribute__nonnull__(1); static void deallocate_ptrobj(PARROT_INTERP, PMC *obj, ARGFREE(void *ptr)); PARROT_DOES_NOT_RETURN static void dereference_null(PARROT_INTERP) __attribute__nonnull__(1); PARROT_DOES_NOT_RETURN static void dereference_unaligned(PARROT_INTERP, ARGIN(const void *base_ptr), size_t align) __attribute__nonnull__(1) __attribute__nonnull__(2); PARROT_DOES_NOT_RETURN static void index_out_of_bounds(PARROT_INTERP, INTVAL i) __attribute__nonnull__(1); #define ASSERT_ARGS_buffer_too_small __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp)) #define ASSERT_ARGS_deallocate_ptrobj __attribute__unused__ int _ASSERT_ARGS_CHECK = (0) #define ASSERT_ARGS_dereference_null __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp)) #define ASSERT_ARGS_dereference_unaligned __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(base_ptr)) #define ASSERT_ARGS_index_out_of_bounds __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp)) /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */ /* HEADERIZER END: static */ #define ALIGN_UP(addr, align) (((addr) + ((align) - 1)) & ~((align) - 1)) #define MAX(x, y) ((y) > (x) ? (y) : (x)) #define BEGIN_KEYED(interp, s, k) \ size_t n_elts; \ elt_desc_t *elts; \ PMC *ptr_pmc; \ void *ptr, *base_ptr; \ INTVAL i; \ PMC *orig_k = (k); \ GETATTR_StructView_n_elts((interp), (s), n_elts); \ GETATTR_StructView_elts((interp), (s), elts); \ ptr_pmc = Parrot_key_pmc((interp), (k)); \ (k) = Parrot_key_next((interp), (k)); \ i = Parrot_key_integer((interp), (k)); \ (k) = orig_k; \ if (i < 0 || n_elts <= (size_t)i) \ index_out_of_bounds((interp), i); \ base_ptr = VTABLE_get_pointer((interp), ptr_pmc); \ ptr = ((char *)base_ptr) + elts[i].byte_offset; \ /* guard against null pointer dereference */ \ if (!base_ptr) \ dereference_null((interp)); \ /* guard against out of bounds access */ \ { \ size_t buf_size = VTABLE_get_integer((interp), ptr_pmc); \ size_t self_size; \ GETATTR_StructView_size((interp), (s), self_size); \ if (buf_size && buf_size < self_size) \ buffer_too_small((interp), self_size, buf_size); \ } \ /* guard against unaligned access */ \ { \ size_t align; \ GETATTR_StructView_align((interp), (s), align); \ if ((size_t)base_ptr != ALIGN_UP((size_t)base_ptr, align)) \ dereference_unaligned((interp), base_ptr, align); \ } pmclass StructView auto_attrs { ATTR PARROT_DATA_TYPE pack_type; ATTR size_t n_elts; ATTR elt_desc_t *elts; ATTR size_t align; ATTR size_t size; /* =item C Creating an instance without an initializer is dissallowed and will throw an exception. =cut */ VTABLE void init() { Parrot_ex_throw_from_c_args(INTERP, NULL, 0, "Meaningless creation of %Ss without initializer", SELF->vtable->whoami); } /* =item C Create a new StructView for viewing buffers as described by the initializer. An initializer is an array-aggregate of integers. For example, C will work for this purpose. The first element of the initializer is interpreted as the type of the C. There are three supported types of view: struct, indicated with the C flag; union, indicated with the C flag; and custom, indicated with the C flag. The second element of the initializer is interpreted as the number of elements contained within the view. If using a custom view, the third and fourth elements are interpreted as the size and alignment in bytes respectively. The remainder of the initializer is interpreted as a description of the elements of the view. For struct and union views, elements are described by a single integer flag from C, with layout being determined automatically identical to what your C compiler would have done. For custom views, elements are represented by a 3-tuple of C<{type, byte-offset, bit-offset}>, which can be used for arbitrary layouts. Note, however, that unaligned access is only supported on unsigned integers, and even then, it is inefficient. You have been warned. Supported element types are include: =over 4 =item Parrot Types C, C, C, and C =item C-Native Types Integer: C, C, C, C, C, C, C, C, C (*), and C (*) Float: C, C, C PMC: data pointer (C), function pointer (C), buffer (C) (**) (*) Only available if your C system sports a C type. (**) Requires 2 additional following parameters - buffer size and alignment. =item Explicitly Sized Types C (also known as C), C, C, C, C, C, C, C, C(*), and C(*) (*) Only available if your C system sports a 64 bit integer type. =back =cut */ VTABLE void init_pmc(PMC *p) { const INTVAL init_len = VTABLE_elements(INTERP, p); const PARROT_DATA_TYPE pack_type = (PARROT_DATA_TYPE) VTABLE_get_integer_keyed_int(INTERP, p, 0); const INTVAL n_elts = VTABLE_get_integer_keyed_int(INTERP, p, 1); elt_desc_t *elt_ary; size_t bit_cursor = 0; size_t byte_cursor = 0; size_t size, align; int incr, i, j; switch (pack_type) { case enum_type_struct: case enum_type_union: size = 0; align = 1; /* sorry, no sub-byte alignment */ incr = 1; i = 2; break; case enum_type_sized: size = VTABLE_get_integer_keyed_int(INTERP, p, 2); align = VTABLE_get_integer_keyed_int(INTERP, p, 3); incr = 3; i = 4; break; default: Parrot_ex_throw_from_c_args(INTERP, NULL, 0, "Unknown struct type `%Ss'", Parrot_dt_get_datatype_name(INTERP, pack_type)); } if (init_len < n_elts + i) Parrot_ex_throw_from_c_args(INTERP, NULL, 0, "Initializer too short (%d) for struct type `%Ss' with %d elements", init_len, Parrot_dt_get_datatype_name(INTERP, pack_type), n_elts); elt_ary = mem_gc_allocate_n_zeroed_typed(INTERP, n_elts, elt_desc_t); PObj_custom_destroy_SET(SELF); SET_ATTR_pack_type(INTERP, SELF, pack_type); SET_ATTR_elts(INTERP, SELF, elt_ary); SET_ATTR_n_elts(INTERP, SELF, n_elts); for (/* i already initialized */ j = 0; i < init_len && j < n_elts; i += incr, j++) { elt_desc_t * const elt = &elt_ary[j]; const PARROT_DATA_TYPE elt_type = (PARROT_DATA_TYPE) VTABLE_get_integer_keyed_int(INTERP, p, i); size_t elt_size, elt_align; elt_access_t elt_access; if ((elt_type & ~enum_type_ref_flag) < enum_first_type || (elt_type & ~enum_type_ref_flag) >= enum_last_type) Parrot_ex_throw_from_c_args(INTERP, NULL, 0, "Invalid type flag for struct element (%d)", elt_type); elt->type = elt_type; elt_size = data_types[elt_type - enum_first_type].size; elt_align = data_types[elt_type - enum_first_type].align; switch (elt_type) { /* aligned integer types */ case enum_type_INTVAL: case enum_type_char: case enum_type_short: case enum_type_int: case enum_type_long: #if PARROT_HAS_LONGLONG case enum_type_longlong: #endif case enum_type_int8: case enum_type_int16: case enum_type_int32: #if PARROT_HAS_INT64 case enum_type_int64: #endif case enum_type_uchar: case enum_type_ushort: case enum_type_uint: case enum_type_ulong: #if PARROT_HAS_LONGLONG case enum_type_ulonglong: #endif case enum_type_uint8: case enum_type_uint16: case enum_type_uint32: #if PARROT_HAS_INT64 case enum_type_uint64: #endif elt_access = int_access; break; /* unaligned integer types */ case enum_type_uint1: case enum_type_uint4: elt_access = unaligned_access; break; /* float types */ case enum_type_FLOATVAL: case enum_type_float: case enum_type_double: case enum_type_longdouble: elt_access = num_access; break; /* other types */ case enum_type_STRING: elt_access = str_access; break; case enum_type_sized: /* arbitrary buffers extended with size and align fields */ elt->size = elt_size = VTABLE_get_integer_keyed_int(INTERP, p, ++i); elt_align = VTABLE_get_integer_keyed_int(INTERP, p, ++i); /* fallthrough */ case enum_type_PMC: case enum_type_ptr: case enum_type_func_ptr: elt_access = pmc_access; break; /* locally unsupported types */ #if !PARROT_HAS_LONGLONG case enum_type_longlong: case enum_type_ulonglong: #endif #if !PARROT_HAS_INT64 case enum_type_int64: case enum_type_uint64: #endif Parrot_ex_throw_from_c_args(INTERP, NULL, 0, "Unsupported struct element type `%Ss' (index %d)", Parrot_dt_get_datatype_name(INTERP, elt_type), j); default: Parrot_ex_throw_from_c_args(INTERP, NULL, 0, "Unknown struct element type `%Ss' (index %i)", Parrot_dt_get_datatype_name(INTERP, elt_type), j); } switch (pack_type) { case enum_type_struct: elt->access = elt_access; align = MAX(align, elt_align); switch (elt_access) { case int_access: case num_access: case pmc_access: if (bit_cursor) { byte_cursor += 1; bit_cursor = 0; } elt->byte_offset = ALIGN_UP(byte_cursor, elt_align); byte_cursor = elt->byte_offset + elt_size; break; case unaligned_access: elt->byte_offset = byte_cursor; elt->bit_offset = bit_cursor; byte_cursor = (bit_cursor + 1) / 8; bit_cursor = (bit_cursor + 1) % 8; break; default: break; } break; case enum_type_union: elt->access = elt_access; size = MAX(size, elt_size); align = MAX(align, elt_align); /* all union elements are at 0 offset */ break; case enum_type_sized: elt->byte_offset = VTABLE_get_integer_keyed_int(INTERP, p, i + 1); elt->bit_offset = VTABLE_get_integer_keyed_int(INTERP, p, i + 2); switch (elt_access) { case num_access: case str_access: case pmc_access: if (align < elt_align || elt->bit_offset || elt->byte_offset % elt_align) Parrot_ex_throw_from_c_args(INTERP, NULL, 0, "Unaligned access unsupported on type `%Ss' (index: %i)", Parrot_dt_get_datatype_name(INTERP, elt_type), j); elt->access = elt_access; break; case int_access: if (align < elt_align || elt->bit_offset || elt->byte_offset % elt_align) { switch (elt_type) { case enum_type_uchar: case enum_type_ushort: case enum_type_uint: case enum_type_ulong: #if PARROT_HAS_LONGLONG case enum_type_ulonglong: #endif case enum_type_uint8: case enum_type_uint16: case enum_type_uint32: #if PARROT_HAS_INT64 case enum_type_uint64: #endif elt->access = unaligned_access; break; default: Parrot_ex_throw_from_c_args(INTERP, NULL, 0, "Unaligned access unsupported on type `%Ss' (index: %i)", Parrot_dt_get_datatype_name(INTERP, elt_type), j); } } else { elt->access = int_access; } break; case unaligned_access: elt->access = unaligned_access; break; default: break; } default: break; } } if (pack_type == enum_type_struct) { size = byte_cursor + !!bit_cursor; } SET_ATTR_align(INTERP, SELF, align); SET_ATTR_size(INTERP, SELF, size); } /* =item C Free internal offsets array. =cut */ VTABLE void destroy() :no_wb { elt_desc_t *elts; GET_ATTR_elts(INTERP, SELF, elts); mem_gc_free(INTERP, elts); } /* =item C =item C Get/Set an integer-type element from a struct-pointer PMC. =cut */ VTABLE INTVAL get_integer_keyed(PMC *k) :no_wb { BEGIN_KEYED(INTERP, SELF, k) switch (elts[i].access) { case int_access: switch (elts[i].type) { #define CASE_RET2(type, name) \ case enum_type_ ## name: return *(type *)ptr; #define CASE_RET1(type) \ CASE_RET2(type, type) \ CASE_RET2(unsigned type, u ## type) CASE_RET2(INTVAL, INTVAL) CASE_RET1(char); CASE_RET1(short); CASE_RET1(int); CASE_RET1(long); #if PARROT_HAS_LONGLONG CASE_RET2(long long, longlong); CASE_RET2(unsigned long long, ulonglong); #endif CASE_RET2(Parrot_Int1, int8); CASE_RET2(Parrot_UInt1, uint8); CASE_RET2(Parrot_Int2, int16); CASE_RET2(Parrot_UInt2, uint16); CASE_RET2(Parrot_Int4, int32); CASE_RET2(Parrot_UInt4, uint32); #if PARROT_HAS_INT64 CASE_RET2(Parrot_Int8, int64); CASE_RET2(Parrot_UInt8, uint64); #endif #undef CASE_RET1 #undef CASE_RET2 default: break; } /* should not get here - inserted to avoid compiler warnings */ return 0; case unaligned_access: { INTVAL acc = 0; size_t bits, n; unsigned char *cptr = (unsigned char *)ptr; switch (elts[i].type) { case enum_type_uint1: bits = 1; break; case enum_type_uint4: bits = 4; break; default: bits = 8 * data_types[elts[i].type - enum_first_type].size; break; } /* fetch hi bits of first byte */ acc = *cptr++ >> elts[i].bit_offset; n = 8 - elts[i].bit_offset; /* read whole bytes until complete */ while (n < bits) { acc |= ((UINTVAL)*cptr++) << n; n += 8; } /* mask off hi bits of last byte */ acc &= (~(UINTVAL)0) >> (sizeof (UINTVAL) * 8 - bits); return acc; } /* should not get here - inserted to avoid compiler warnings */ return 0; default: Parrot_ex_throw_from_c_args(INTERP, NULL, 0, "Not a valid integer type (`%Ss')", Parrot_dt_get_datatype_name(INTERP, elts[i].type)); } } VTABLE void set_integer_keyed(PMC *k, INTVAL x) { BEGIN_KEYED(INTERP, SELF, k) switch (elts[i].access) { case int_access: switch (elts[i].type) { #define CASE_SET2(type, name) \ case enum_type_ ## name: *(type *)ptr = x; return; #define CASE_SET1(type) \ CASE_SET2(type, type) \ CASE_SET2(unsigned type, u ## type) CASE_SET2(INTVAL, INTVAL) CASE_SET1(char); CASE_SET1(short); CASE_SET1(int); CASE_SET1(long); #if PARROT_HAS_LONGLONG CASE_SET2(long long, longlong); CASE_SET2(unsigned long long, ulonglong); #endif CASE_SET2(Parrot_Int1, int8); CASE_SET2(Parrot_UInt1, uint8); CASE_SET2(Parrot_Int2, int16); CASE_SET2(Parrot_UInt2, uint16); CASE_SET2(Parrot_Int4, int32); CASE_SET2(Parrot_UInt4, uint32); #if PARROT_HAS_INT64 CASE_SET2(Parrot_Int8, int64); CASE_SET2(Parrot_UInt8, uint64); #endif #undef CASE_SET1 #undef CASE_SET2 default: break; } break; case unaligned_access: { UINTVAL ux = x; size_t bits, n; unsigned char tempc = 0; unsigned char *cptr = (unsigned char *)ptr; switch (elts[i].type) { case enum_type_uint1: bits = 1; break; case enum_type_uint4: bits = 4; break; default: bits = 8 * data_types[elts[i].type - enum_first_type].size; break; } /* cache last byte (for restoring hi bits) */ if (bits > 1) { tempc = cptr[(bits + elts[i].bit_offset - 1)/8]; } /* write hi bits of first byte */ n = 8 - elts[i].bit_offset; *cptr &= (1 << elts[i].bit_offset) - 1; *cptr++ |= (ux & ((1 << n) - 1)) << elts[i].bit_offset; /* write whole bytes until complete */ while (n < bits) { *cptr++ = ux >> n; n += 8; } /* restore hi bits of last byte */ cptr--; n = 8 - (n - bits); /* how many bits of last byte we should have written */ *cptr &= (1 << n) - 1; *cptr |= tempc & ~((1 << n) - 1); } break; default: Parrot_ex_throw_from_c_args(INTERP, NULL, 0, "Not a valid integer type (`%Ss')", Parrot_dt_get_datatype_name(INTERP, elts[i].type)); } } /* =item C =item C Get/Set a float-like element from a struct-pointer PMC. =cut */ VTABLE FLOATVAL get_number_keyed(PMC *k) :no_wb { BEGIN_KEYED(INTERP, SELF, k) switch (elts[i].access) { case num_access: switch (elts[i].type) { case enum_type_FLOATVAL: return *(FLOATVAL *)ptr; case enum_type_float: return *(float *)ptr; case enum_type_double: return *(double *)ptr; case enum_type_longdouble: return *(long double *)ptr; default: break; } default: Parrot_ex_throw_from_c_args(INTERP, NULL, 0, "Not a valid number type (`%Ss')", Parrot_dt_get_datatype_name(INTERP, elts[i].type)); } } VTABLE void set_number_keyed(PMC *k, FLOATVAL n) { BEGIN_KEYED(INTERP, SELF, k) switch (elts[i].access) { case num_access: switch (elts[i].type) { case enum_type_FLOATVAL: *(FLOATVAL *)ptr = n; return; case enum_type_float: *(float *)ptr = n; return; case enum_type_double: *(double *)ptr = n; return; case enum_type_longdouble: *(long double *)ptr = n; return; default: break; } default: Parrot_ex_throw_from_c_args(INTERP, NULL, 0, "Not a valid number type (`%Ss')", Parrot_dt_get_datatype_name(INTERP, elts[i].type)); } } /* =item C =item C Get/Set a string element from a struct-pointer PMC. =cut */ VTABLE STRING *get_string_keyed(PMC *k) :no_wb { BEGIN_KEYED(INTERP, SELF, k) switch (elts[i].access) { case str_access: switch (elts[i].type) { case enum_type_STRING: return *(STRING **)ptr; default: break; } default: Parrot_ex_throw_from_c_args(INTERP, NULL, 0, "Not a valid string type (`%Ss')", Parrot_dt_get_datatype_name(INTERP, elts[i].type)); } } VTABLE void set_string_keyed(PMC *k, STRING *s) { BEGIN_KEYED(INTERP, SELF, k) switch (elts[i].access) { case str_access: switch (elts[i].type) { case enum_type_STRING: *(STRING **)ptr = s; return; default: break; } default: Parrot_ex_throw_from_c_args(INTERP, NULL, 0, "Not a valid string type (`%Ss')", Parrot_dt_get_datatype_name(INTERP, elts[i].type)); } } /* =item C =item C Get/Set a PMC-like element from a struct-pointer PMC or box/unbox values from any other type of element. =cut */ VTABLE PMC *get_pmc_keyed(PMC *k) :no_wb { BEGIN_KEYED(INTERP, SELF, k) switch (elts[i].access) { case int_access: case unaligned_access: return Parrot_pmc_box_integer(INTERP, SELF.get_integer_keyed(k)); case num_access: return Parrot_pmc_box_number(INTERP, SELF.get_number_keyed(k)); case str_access: return Parrot_pmc_box_string(INTERP, SELF.get_string_keyed(k)); case pmc_access: { PMC *ret; switch (elts[i].type) { case enum_type_PMC: return *(PMC **)ptr; case enum_type_func_ptr: case enum_type_ptr: return Parrot_pmc_new_init_int(INTERP, enum_class_Ptr, (INTVAL)*(void **)ptr); case enum_type_sized: ret = Parrot_pmc_new_init_int(INTERP, enum_class_PtrBuf, (INTVAL)*(void **)ptr); VTABLE_set_integer_native(INTERP, ret, elts[i].size); return ret; default: /* should never get here - put in to quiet compiler warnings */ return NULL; } } default: /* should never get here - put in to quiet compiler warnings */ return NULL; } } VTABLE void set_pmc_keyed(PMC *k, PMC *p) { BEGIN_KEYED(INTERP, SELF, k) switch (elts[i].access) { case int_access: case unaligned_access: SELF.set_integer_keyed(k, VTABLE_get_integer(INTERP, p)); break; case num_access: SELF.set_number_keyed(k, VTABLE_get_number(INTERP, p)); break; case str_access: SELF.set_string_keyed(k, VTABLE_get_string(INTERP, p)); break; case pmc_access: { switch (elts[i].type) { case enum_type_PMC: *(PMC **)ptr = p; break; case enum_type_func_ptr: case enum_type_ptr: *(void **)ptr = VTABLE_get_pointer(INTERP, p); break; case enum_type_sized: if (VTABLE_does(INTERP, p, CONST_STRING(INTERP, "buffer"))) { void * const q = VTABLE_get_pointer(INTERP, p); size_t len = VTABLE_get_integer(INTERP, p); if (len == 0 || len > elts[i].size) len = elts[i].size; memcpy(ptr, q, len); break; } else { Parrot_ex_throw_from_c_args(INTERP, NULL, 0, "Type `%Ss' unsuitable for buffer assignment", p->vtable->whoami); } default: break; } } default: break; } } /* =item C =item C Get the size (in bytes) required for one instance. =cut */ VTABLE INTVAL get_integer() :no_wb { size_t size; GET_ATTR_size(INTERP, SELF, size); return size; } METHOD size() :no_wb { size_t size; GET_ATTR_size(INTERP, SELF, size); RETURN(INTVAL size); } /* =item C Get the alignment (in bytes) required for an instance. =cut */ METHOD align() :no_wb { size_t align; GET_ATTR_align(INTERP, SELF, align); RETURN(INTVAL align); } /* =item C Get the size of one instance plus the pad bytes to align a subsequent instance. =cut */ METHOD aligned_size() :no_wb { size_t size, align; INTVAL ret; GET_ATTR_size(INTERP, SELF, size); GET_ATTR_align(INTERP, SELF, align); ret = ALIGN_UP(size, align); RETURN(INTVAL ret); } /* =item C Allocate an instance, or an array of instances when C has been provided. =cut */ METHOD alloc(INTVAL n :optional, int has_n :opt_flag) { size_t size, align; PMC *ret; void *buf; GET_ATTR_size(INTERP, SELF, size); if (has_n) { GET_ATTR_align(INTERP, SELF, align); size = ALIGN_UP(size, align) * n; } buf = mem_sys_allocate_zeroed(size); ret = Parrot_pmc_new_init_int(INTERP, enum_class_PtrObj, (INTVAL)buf); SETATTR_PtrObj_destroy(INTERP, ret, deallocate_ptrobj); RETURN(PMC ret); } /* =item C Return a C to the Cth element of an array of structs. =cut */ METHOD array_offs(PMC *array, INTVAL n) :no_wb { void * const p = VTABLE_get_pointer(INTERP, array); const INTVAL array_size = VTABLE_get_integer(INTERP, array); PMC *ret; size_t size, align; GET_ATTR_size(INTERP, SELF, size); GET_ATTR_align(INTERP, SELF, align); /* sanity checks */ if (!p) dereference_null(INTERP); if (array_size && array_size < (int)size * n) Parrot_ex_throw_from_c_args(INTERP, NULL, 0, "Buffer length too small for struct array " "(at least %d required, got %d)", size * n, array_size); if ((size_t)p != ALIGN_UP((size_t)p, align)) dereference_unaligned(INTERP, p, align); size = ALIGN_UP(size, align); ret = Parrot_pmc_new_init_int(INTERP, enum_class_Ptr, (INTVAL)((char *)p + size * n)); RETURN(PMC ret); } /* =item C Return a C to the Cth element of a struct. =cut */ METHOD elt_offs(PMC *array, INTVAL n) :no_wb { void *p = VTABLE_get_pointer(INTERP, array); PMC *ret; size_t n_elts; elt_desc_t *elts; GET_ATTR_n_elts(INTERP, SELF, n_elts); GET_ATTR_elts(INTERP, SELF, elts); /* sanity checks */ if (n < 0 || n_elts <= (size_t)n) index_out_of_bounds(INTERP, n); if (!p) dereference_null(INTERP); { const size_t buf_size = VTABLE_get_integer(INTERP, array); size_t self_size; GET_ATTR_size(INTERP, SELF, self_size); if (buf_size && buf_size < self_size) Parrot_ex_throw_from_c_args(INTERP, NULL, 0, "Buffer length too small for struct " "(at least %d required, got %d)", self_size, buf_size); } { size_t align; GET_ATTR_align(INTERP, SELF, align); if ((size_t)p != ALIGN_UP((size_t)p, align)) dereference_unaligned(INTERP, p, align); } p = ((char *)p) + elts[n].byte_offset; ret = Parrot_pmc_new_init_int(INTERP, enum_class_Ptr, (INTVAL)p); RETURN(PMC ret); } /* =item C Obtain an integer array which describes the shape of this object. The returned array is of the same format as the one used for C. =cut */ METHOD get_shape() :no_wb { int i, j; size_t n; elt_desc_t *elts; PARROT_DATA_TYPE pack_type; PMC *result; GET_ATTR_n_elts(INTERP, SELF, n); GET_ATTR_elts(INTERP, SELF, elts); GET_ATTR_pack_type(INTERP, SELF, pack_type); switch (pack_type) { case enum_type_struct: case enum_type_union: result = Parrot_pmc_new_init_int(INTERP, enum_class_ResizableIntegerArray, n + 2); VTABLE_set_integer_keyed_int(INTERP, result, 0, pack_type); VTABLE_set_integer_keyed_int(INTERP, result, 1, n); break; case enum_type_sized: result = Parrot_pmc_new_init_int(INTERP, enum_class_ResizableIntegerArray, n * 3 + 4); { size_t s; VTABLE_set_integer_keyed_int(INTERP, result, 0, pack_type); VTABLE_set_integer_keyed_int(INTERP, result, 1, n); GET_ATTR_size(INTERP, SELF, s); VTABLE_set_integer_keyed_int(INTERP, result, 2, s); GET_ATTR_align(INTERP, SELF, s); VTABLE_set_integer_keyed_int(INTERP, result, 3, s); } break; default: break; } for (i = 1, j = 1; i <= (int)n; i++) { switch (pack_type) { case enum_type_struct: case enum_type_union: VTABLE_set_integer_keyed_int(INTERP, result, i + j, elts[i - 1].type); if (elts[i - 1].type == enum_type_sized) { VTABLE_set_integer_keyed_int(interp, result, i + ++j, elts[i - 1].size); VTABLE_set_integer_keyed_int(interp, result, i + ++j, 0); } break; case enum_type_sized: VTABLE_set_integer_keyed_int(INTERP, result, i * 3 + j, elts[i - 1].type); if (elts[i - 1].type == enum_type_sized) { VTABLE_set_integer_keyed_int(interp, result, i * 3 + ++j, elts[i - 1].size); VTABLE_set_integer_keyed_int(interp, result, i * 3 + ++j, 0); } VTABLE_set_integer_keyed_int(INTERP, result, i * 3 + j + 1, elts[i - 1].byte_offset); VTABLE_set_integer_keyed_int(INTERP, result, i * 3 + j + 2, elts[i - 1].bit_offset); default: break; } } RETURN(PMC result); } /* =item C =item C Implement the freeze/thaw API. =cut */ VTABLE void freeze(PMC *v) :no_wb { PMC *shape; Parrot_pcc_invoke_method_from_c_args(INTERP, SELF, CONST_STRING(INTERP, "get_shape"), "->P", &shape); VTABLE_freeze(INTERP, shape, v); } VTABLE void thaw(PMC *v) :manual_wb { PMC *shape = Parrot_pmc_new_noinit(INTERP, enum_class_ResizableIntegerArray); VTABLE_thaw(INTERP, shape, v); SELF.init_pmc(shape); } } /* =back =head2 Auxiliary functions =over 4 =item C Deallocation function to be attached to allocated instances. =item C Throw an exception relating to attempting to derefence a NULL pointer. =item C Throw an exception about attempting to index outside the data. =item C Throw an exception about a buffer being too small. =item C Throw an exception relating to attempting to derefence an un-aligned pointer. =cut */ static void deallocate_ptrobj(SHIM_INTERP, SHIM(PMC *obj), ARGFREE(void *ptr)) { ASSERT_ARGS(deallocate_ptrobj) mem_sys_free(ptr); } PARROT_DOES_NOT_RETURN static void dereference_null(PARROT_INTERP) { ASSERT_ARGS(dereference_null) Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_UNEXPECTED_NULL, "Attempt to derefrence null pointer"); } PARROT_DOES_NOT_RETURN static void index_out_of_bounds(PARROT_INTERP, INTVAL i) { ASSERT_ARGS(index_out_of_bounds) Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_OUT_OF_BOUNDS, "Struct index out of bounds (%d)", i); } PARROT_DOES_NOT_RETURN static void buffer_too_small(PARROT_INTERP, size_t self_size, size_t buf_size) { ASSERT_ARGS(buffer_too_small) Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_BAD_BUFFER_SIZE, "Buffer length too small for struct (at least %d required, got %d)", self_size, buf_size); } PARROT_DOES_NOT_RETURN static void dereference_unaligned(PARROT_INTERP, ARGIN(const void *base_ptr), size_t align) { ASSERT_ARGS(dereference_unaligned) Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, "Attempt to dereference unaligned pointer (%x, required alignment: %d)", base_ptr, align); } /* =back =cut */ /* * Local variables: * c-file-style: "parrot" * End: * vim: expandtab shiftwidth=4 cinoptions='\:2=2' : */ threads.t000644000765000765 311212101554067 14335 0ustar00bruce000000000000parrot-6.6.0/t/src#!./parrot # Copyright (C) 2011, Parrot Foundation. .sub main :main .local pmc task, tasks, sayer, starter, ender, number, interp, end_sub .local int i interp = getinterp sayer = get_global 'sayer' starter = new 'Integer', 0 ender = new 'Integer', 0 tasks = new 'ResizablePMCArray' end_sub = get_global 'end_this' i = 1 say "1..21" start: number = new ['String'] number = i task = new ['Task'] push task, starter push task, ender push task, end_sub setattribute task, 'code', sayer setattribute task, 'data', number print "ok " say number push tasks, task schedule task inc i if i > 10 goto end goto start end: starter = 1 wait_for_tasks: task = shift tasks wait task print "ok " say i inc i if i > 20 goto check goto wait_for_tasks check: if ender == 1 goto win say "not ok" goto done win: say "ok 21" done: .end .sub sayer .param pmc name .local pmc interp, task, starter, ender, end_sub, end_task, tmp .local int i interp = getinterp task = interp.'current_task'() end_sub = pop task ender = pop task starter = pop task start: if starter > 0 goto end sleep 0.1 goto start end: end_task = new ['Task'] setattribute end_task, 'code', end_sub setattribute end_task, 'data', ender interp.'schedule_proxied'(end_task, ender) returncc .end .sub end_this .param pmc ender ender = 1 .end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: Configure.pm000644000765000765 24211533177646 22474 0ustar00bruce000000000000parrot-6.6.0/t/tools/install/testlib/lib/Parrot# Copyright (C) 2009, Parrot Foundation. # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: demo.pir000644000765000765 554611533177634 15543 0ustar00bruce000000000000parrot-6.6.0/examples/pge# Copyright (C) 2005-2010, Parrot Foundation. .include "errors.pasm" .sub _main .local string x .local string pattern .local int istraced .local pmc stdin .local pmc rulesub .local pmc pir .local pmc exp .local pmc match .local pmc p6rule_compile .local pmc p5regexp_compile .local pmc glob_compile .local int istrace .local string gname errorson .PARROT_ERRORS_PARAM_COUNT_FLAG load_bytecode "PGE.pbc" load_bytecode "dumper.pir" load_bytecode "PGE/Dumper.pir" load_bytecode "PGE/Glob.pir" load_bytecode "PGE/Text.pir" load_bytecode "PGE/Util.pir" p6rule_compile = compreg "PGE::Perl6Regex" glob_compile = compreg "PGE::Glob" p5regexp_compile = compreg "PGE::P5Regex" istrace = 0 null rulesub read_loop: print "\ninput \"regex \", \"glob \", \"save \",\n" print "target string, \"pir\", \"exp\", \"trace\", \"next\"\n" $P0 = getinterp stdin = $P0.'stdin_handle'() x = stdin.'readline'() length $I0, x if $I0 < 1 goto end_demo $I0 = index x, " " if $I0 > 0 goto get_cmd $I0 = index x, "\n" get_cmd: $S0 = substr x, 0, $I0 x = chopn x, 1 if $S0 == "next" goto match_next if $S0 == "regex" goto make_p6rule if $S0 == "glob" goto make_glob if $S0 == "save" goto save_rule if $S0 == "pir" goto print_pir if $S0 == "exp" goto print_exp if $S0 == "trace" goto toggle_trace if $S0 == "p5regex" goto make_regexp if_null rulesub, match_nopattern match = rulesub(x) match_result: unless match goto match_fail print "match succeeded\n" $P0 = get_global "_dumper" $P0(match, "$/") goto read_loop match_fail: print "match failed\n" goto read_loop match_nopattern: print "no pattern entered yet\n" goto read_loop match_next: match."next"() goto match_result make_glob: pattern = substr x, 5 (rulesub) = glob_compile(pattern) goto read_loop make_p6rule: pattern = substr x, 5 (rulesub) = p6rule_compile(pattern) goto read_loop make_regexp: pattern = substr x, 7 (rulesub) = p5regexp_compile(pattern) goto read_loop save_rule: if_null rulesub, match_nopattern x = substr x, 5 set_global x, rulesub print "Saved as " print x print "\n" goto read_loop print_pir: if_null rulesub, match_nopattern print pir goto read_loop print_exp: if_null rulesub, match_nopattern $P0 = get_global "_dumper" $P0(exp, "exp") goto read_loop toggle_trace: istrace = not istrace trace istrace unless istrace goto trace_off print "Tracing is now on\n" goto read_loop trace_off: print "Tracing is now off\n" goto read_loop end_demo: .end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: as2c.pl000755000765000765 616711606346603 14613 0ustar00bruce000000000000parrot-6.6.0/tools/dev#! perl # Copyright (C) 2004-2007, Parrot Foundation. =head1 NAME as2c.pl - convert GNU Assembler listing to i386 code array =head1 DESCRIPTION The plan behind of F is to create compiler independent machine code for an architecture. Code in, I MASM, GAS, NASM syntax doesn't fit all compilers. Therefore F translates GAS syntax to a bytestring, which is then used as the asm code. F is used very rarely. Once the code is generated and checked in, there's usually no need to change it later. =cut use strict; use warnings; my $src = $ARGV[0]; my $cmd = "cc -c $src.c -Wall -O3 -fomit-frame-pointer -DNDEBUG -Wa,-a > $src.s"; my ($func); print_header($src); create_s($cmd); parse_s("$src.s"); add_glue("$src.c"); print_coda(); sub print_header { my $s = shift; print <) { next if (/^\f/); # FF next if (/#(?:NO_)?APP/); # APP, NO_APP chomp; if (/^\s*\d+\s[\da-fA-F]{4}\s([\dA-F]{2,8})\s+(.*)/) { if ($in_comment) { print " */\n"; } my ( $bytes, $src ) = ( $1, $2 ); $src =~ s/\t/ /g; my $len = length($bytes); my @pairs = ( $bytes =~ m/../g ); print " " . join '', map { "0x$_, " } @pairs; print " " x ( 3 * ( 8 - $len ) ); print " /* $src */\n"; } elsif (/\.type\s+(\w+)\s*,\s*\@function/) { $in_comment = 0; $func = $1; print " *\n */\n"; print "static const char ${func}_code[] = {\n"; } elsif (/^\s*\d+\s+(\w+):/) { print " " x 26, " /* $1: */\n"; } elsif ($in_comment) { s/\s+//g; print " * $_\n"; } } print " 0x00\n"; print "};\n"; close $IN; } sub add_glue { my $s = shift; open $IN, "<", "$s" or die "Can't read '$s': $1"; while (<$IN>) { if (/\/\*INTERFACE/) { my $text = ""; while (<$IN>) { last if (/INTERFACE\*\//); $text .= $_; } $text =~ s/\@FUNC\@/$func/g; $text =~ s!\@\*!/*!g; $text =~ s!\*\@!*/!g; print $text; } } close $IN; } =head1 REFERENCES GNU Assembler: (GAS) L Microsoft Macro Assembler (MASM): L Netwide Assembler (NASM) L =cut # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: ipv6-01.t000644000765000765 353111567202625 15336 0ustar00bruce000000000000parrot-6.6.0/t/steps/auto#! perl # Copyright (C) 2007, Parrot Foundation. # auto/ipv6-01.t use strict; use warnings; use Test::More tests => 10; use Carp; use lib qw( lib t/configure/testlib ); use_ok('config::auto::ipv6'); use Parrot::Configure::Options qw( process_options ); use Parrot::Configure::Step::Test; use Parrot::Configure::Test qw( test_step_constructor_and_description ); my ($args, $step_list_ref) = process_options( { argv => [ ], mode => q{configure}, } ); my $conf = Parrot::Configure::Step::Test->new; $conf->include_config_results( $args ); my $pkg = q{auto::ipv6}; $conf->add_steps($pkg); $conf->options->set( %{$args} ); my $step = test_step_constructor_and_description($conf); my $ret = $step->runstep($conf); ok( $ret, "runstep() returned true value" ); ##### _handle_ipv6_status ##### my ($ipv6_status, $exp); $conf->data->set( HAS_IPV6 => undef ); $ipv6_status = 1; $exp = 'yes'; $step->_handle_ipv6_status($conf, $ipv6_status); ok( $conf->data->get( 'HAS_IPV6' ), "HAS_IPV6 is true value" ); is( $step->result(), $exp, "Got expected result '$exp'" ); $conf->data->set( HAS_IPV6 => undef ); $ipv6_status = 0; $exp = 'no'; $step->_handle_ipv6_status($conf, $ipv6_status); ok( ! $conf->data->get( 'HAS_IPV6' ), "HAS_IPV6 is false value" ); is( $step->result(), $exp, "Got expected result '$exp'" ); pass("Completed all tests in $0"); ################### DOCUMENTATION ################### =head1 NAME auto/ipv6-01.t - test auto::ipv6 =head1 SYNOPSIS % prove t/steps/auto/ipv6-01.t =head1 DESCRIPTION The files in this directory test functionality used by F. The tests in this file test auto::ipv6. =head1 AUTHOR James E Keenan =head1 SEE ALSO config::auto::ipv6, F. =cut # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: mk_inno_language.pl000755000765000765 1203712157123051 17261 0ustar00bruce000000000000parrot-6.6.0/tools/dev#! perl # Copyright (C) 2009-2012, Parrot Foundation. =head1 TITLE tools/dev/mk_inno_language.pl - Create a script for Inno Setup =head1 SYNOPSIS % cd languages/lang % perl ../../tools/dev/mk_inno_language.pl lang =head1 DESCRIPTION From L: Inno Setup is a free installer for Windows programs. =cut use strict; use warnings; use lib qw( ../../lib ); use Parrot::Config; unless (@ARGV) { die "usage: $0 lang\n"; } ## determine the language we're trying to build my $lang = $ARGV[0]; my $lclang = lc $lang; my $uclang = ucfirst $lang; my $version = $PConfig{VERSION} . $PConfig{DEVEL}; my $prefix = $PConfig{prefix}; $prefix =~ s/\//\\/g; my @now = gmtime; my $date = sprintf("%04d%02d%02d", 1900 + $now[5], 1 + $now[4], $now[3]); my $license = -f 'LICENSE' ? qq{LicenseFile=LICENSE} : -f 'COPYING' ? qq{LicenseFile=COPYING} : -f 'COPYRIGHT' ? qq{LicenseFile=COPYRIGHT} : '; no LicenseFile'; my $exe = $lang eq 'rakudo' ? ( -f 'perl6.exe' ? qq{Source: ".\\perl6.exe"; DestDir: "{app}\\bin"; Flags:} : '; no perl6.exe' ) : ( ? qq{Source: ".\\parrot-*.exe"; DestDir: "{app}\\bin"; Flags:} : '; no .exe' ); my $pbc = <*.pbc> && ! -d $lang && $lang ne 'rakudo' ? qq{Source: ".\\*.pbc"; DestDir: "{app}\\lib\\parrot\\languages\\$lang"; Flags:} : '; no .pbc'; my $lng = -d $lang ? qq{Source: ".\\$lang\\*.pbc"; DestDir: "{app}\\lib\\parrot\\languages\\$lang"; Flags: ignoreversion recursesubdirs} : '; no lang'; my $pmc = ? qq{Source: ".\\src\\pmc\\*.dll"; DestDir: "{app}\\lib\\parrot\\dynext"; Flags:} : '; no pmc'; my $ops = ? qq{Source: ".\\src\\ops\\*.dll"; DestDir: "{app}\\lib\\parrot\\dynext"; Flags:} : '; no ops'; my $dynext = && ! && ! ? qq{Source: ".\\dynext\\*.dll"; DestDir: "{app}\\lib\\parrot\\dynext"; Flags:} : '; no dynext'; my $man = -d 'man' ? qq{Source: ".\\man\\*"; DestDir: "{app}\\man\\parrot"; Flags: ignoreversion recursesubdirs} : '; no man'; my $doc = -d 'doc' ? qq{Source: ".\\doc\\*"; DestDir: "{app}\\share\\doc\\parrot\\languages\\$lang"; Flags: ignoreversion recursesubdirs} : -d 'docs' ? qq{Source: ".\\docs\\*"; DestDir: "{app}\\share\\doc\\parrot\\languages\\$lang"; Flags: ignoreversion recursesubdirs} : '; no doc'; my $readme = -f 'README' ? qq{Source: ".\\README"; DestDir: "{app}\\share\\doc\\parrot\\languages\\$lang"; Flags:} : '; no README'; my $rakudo = $lang eq 'rakudo' ? <<'RAKUDO' : ''; ; nqp is required by rakudo Source: ".\nqp\nqp.exe"; DestDir: "{app}\bin"; Flags: Source: ".\nqp\src\vm\parrot\pmc\*.dll"; DestDir: "{app}\lib\parrot\dynext"; Flags: Source: ".\nqp\src\vm\parrot\ops\*.dll"; DestDir: "{app}\lib\parrot\dynext"; Flags: Source: ".\nqp\ModuleLoader.pbc"; DestDir: "{app}\lib\parrot\library"; Flags: Source: ".\nqp\QAST.pbc"; DestDir: "{app}\lib\parrot\languages\nqp\lib"; Flags: Source: ".\nqp\QASTNode.pbc"; DestDir: "{app}\lib\parrot\languages\nqp\lib"; Flags: Source: ".\nqp\NQPP6QRegex.pbc"; DestDir: "{app}\lib\parrot\languages\nqp\lib"; Flags: Source: ".\nqp\NQPP5QRegex.pbc"; DestDir: "{app}\lib\parrot\languages\nqp\lib"; Flags: Source: ".\nqp\NQPHLL.pbc"; DestDir: "{app}\lib\parrot\languages\nqp\lib"; Flags: Source: ".\nqp\NQPCORE.setting.pbc"; DestDir: "{app}\lib\parrot\languages\nqp\lib"; Flags: Source: ".\nqp\nqpmo.pbc"; DestDir: "{app}\lib\parrot\languages\nqp\lib"; Flags: Source: ".\nqp\nqp.pbc"; DestDir: "{app}\lib\parrot\languages\nqp\lib"; Flags: Source: ".\nqp\QRegex.pbc"; DestDir: "{app}\lib\parrot\languages\nqp\lib"; Flags: Source: ".\blib\Perl6\*.pbc"; DestDir: "{app}\lib\parrot\languages\nqp\lib\Perl6"; Flags: Source: ".\perl6.pbc"; DestDir: "{app}\lib\parrot\languages\perl6"; Flags: Source: ".\*.setting.pbc"; DestDir: "{app}\lib\parrot\languages\perl6\lib"; Flags: Source: ".\lib\Test.pm"; DestDir: "{app}\lib\parrot\languages\perl6\lib"; Flags: Source: ".\lib\lib.pm6"; DestDir: "{app}\lib\parrot\languages\perl6\lib"; Flags: Source: ".\lib\Pod\To\Text.pm"; DestDir: "{app}\lib\parrot\languages\perl6\lib\Pod\To"; Flags: RAKUDO my $filename = 'parrot-' . $lclang . '.iss'; open my $OUT, '>', $filename or die "Can't open $filename ($!)"; print $OUT qq{ ; generated by tools/dev/mk_inno_language.pl for the Inno Setup Script Compiler. [Setup] AppName=Parrot-$uclang AppVerName=Parrot-$version-$uclang-$date AppPublisher=Parrot Foundation AppPublisherURL=http://www.parrot.org/ DefaultDirName={sd}$prefix DefaultGroupName=Parrot AllowNoIcons=yes $license OutputDir=.\\ OutputBaseFilename=setup-parrot-$version-$lclang-$date Compression=lzma SolidCompression=yes Uninstallable=no [Files] $rakudo $exe $pbc $lng $pmc $ops $dynext $man $doc $readme }; close $OUT; # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: 21_string_ops_repeat.pir000644000765000765 71712101554066 21701 0ustar00bruce000000000000parrot-6.6.0/examples/tutorial# Copyright (C) 2007-2012, Parrot Foundation. =pod =head1 DESCRIPTION A tutorial lesson about Parrot's string operations (continued). =head1 STRING OPERATIONS PIR has a string repeat opcode, that concatenates a string with itself N times. =cut .sub main :main $S0 = "Hello " $S1 = repeat $S0, 3 say $S1 # prints "Hello Hello Hello \n" .end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: pmc2c.pl000644000765000765 542512101554067 15275 0ustar00bruce000000000000parrot-6.6.0/tools/build#! perl # Copyright (C) 2001-2007, Parrot Foundation. use strict; use warnings; use Getopt::Long (); use FindBin qw($Bin); use File::Spec (); use lib File::Spec->catdir($Bin,'..','lib'); # install location use lib File::Spec->catdir($Bin,'..','..','lib'); # build location use Parrot::Pmc2c::Pmc2cMain (); my ( %action, %options, @pmc_include_paths ); Getopt::Long::GetOptions( #pmc include paths "include=s" => \@pmc_include_paths, #program actions "vtable" => \$action{default}, "dump" => \$action{dump}, "c|gen-c" => \$action{gen_c}, #command line options "no-lines" => \$options{nolines}, # Configure.pl --no-line-directives "library=s" => \$options{library}, "testing" => \$options{testing}, ) or exit 1; if ( 0 == grep { $action{$_} } keys %action ) { die "No action specified!\n"; } my @args = @ARGV; my $self = Parrot::Pmc2c::Pmc2cMain->new( { include => \@pmc_include_paths, opt => \%options, args => \@args, bin => $Bin, } ); if ( $action{default} ) { $self->dump_vtable(File::Spec->catfile($Bin,'..','..','src','vtable.tbl')); exit; } if ( $action{dump} ) { $self->dump_pmc(); exit; } if ( $options{library} ) { $self->gen_library( $options{library} ); exit; } if ( $action{gen_c} ) { $self->gen_c(); exit; } __END__ =head1 NAME tools/build/pmc2c.pl - PMC definition to C compiler =head1 SYNOPSIS =head2 Options used in Parrot F Create F: % perl tools/build/pmc2c.pl --dump src/pmc/foo.pmc ... Create F: % perl tools/build/pmc2c.pl --vtable Create F and C from F: % perl tools/build/pmc2c.pl -c src/pmc/foo.pmc ... =head2 Other Options Create foo.c and pmc_foo.h from foo.dump files, also create libfoo.c containing the initialization function for all foo PMCs. % perl tools/build/pmc2c.pl --library libfoo -c \ src/pmc/foo1.pmc src/pmc/foo2.pmc ... =head1 DESCRIPTION The job of the PMC compiler is to take .pmc files and create C files that can be compiled for use with the Parrot interpreter. =head1 COMMAND-LINE OPTIONS =over 4 =item C<--no-lines> Omit source line info =item C<--include=/path/to/pmc> Specify include path where to find PMCs. =item C<--library=libname> Specify the library name. This will create FlibnameE.c> and FlibnameE.h>. The initialization function will be named after libname and will initialize all PMCs in the library. =back =head1 NOTES You must use lowercase filenames for C<.pmc> files, and lowercase group names in the PMC specification in those files. =cut # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: itimer.c000644000765000765 327412233541455 17164 0ustar00bruce000000000000parrot-6.6.0/src/platform/generic/* * Copyright (C) 2004-2010, Parrot Foundation. */ /* =head1 NAME src/platform/generic/itimer.c =head1 DESCRIPTION itimer stuff =head2 Functions =over 4 =cut */ #include "parrot/parrot.h" /* HEADERIZER HFILE: none */ #ifdef PARROT_HAS_SETITIMER /* =item C Start a system timer with the passed value in milli seconds. The handle is that, what new_sys_timer_ms() returned. We could pass ITIMER_REAL in handle, but for now we ignore it as we are just having one timer. =cut */ void start_sys_timer_ms(SHIM(void *handle), int ms) { struct itimerval its; memset(&its, 0, sizeof (its)); if (ms) { its.it_interval.tv_sec = its.it_value.tv_sec = ms/1000; its.it_interval.tv_usec = its.it_value.tv_usec = 1000 *(ms%1000); } setitimer(ITIMER_REAL, &its, NULL); } /* =item C Stop the given timer. =cut */ void stop_sys_timer_ms(void *handle) { start_sys_timer_ms(handle, 0); } /* =item C Return the programmed timer interval or 0 if none for the given timer handle. =cut */ int get_sys_timer_ms(SHIM(void *handle)) { struct itimerval ots; getitimer(ITIMER_REAL, &ots); return ots.it_interval.tv_sec * 1000 + ots.it_interval.tv_usec/1000; } /* =item C Create a new system timer with ~ms resolution. The returned handle is passed to the other timer functions. =cut */ PARROT_CAN_RETURN_NULL void * new_sys_timer_ms(void) { return NULL; } #else #endif /* =back =cut */ /* * Local variables: * c-file-style: "parrot" * End: * vim: expandtab shiftwidth=4 cinoptions='\:2=2' : */ script.source000644000765000765 16011466337263 17232 0ustar00bruce000000000000parrot-6.6.0/t/compilers/pct# This file is currently not used. # It was saved from the deleted directory 't/compilers/past-pm' test thingy parrot_config.t000644000765000765 262111533177646 16130 0ustar00bruce000000000000parrot-6.6.0/t/tools#! perl # Copyright (C) 2010, Parrot Foundation. =head1 NAME t/tools/parrot_config.t - test parrot_config =head1 SYNOPSIS % prove t/tools/parrot_config.t - test parrot_config =head1 DESCRIPTION Tests the C tool. =cut use strict; use warnings; use lib qw(lib); use Test::More; use IO::File (); use Parrot::Config; use Parrot::Test; use File::Spec; my ($path, $exefile); BEGIN { $path = File::Spec->catfile( ".", "parrot_config" ); $exefile = $path . $PConfig{exe}; unless ( -f $exefile ) { plan skip_all => "$exefile hasn't been built yet."; exit(0); } plan tests => 3; } config_output_like( 'pmc_names', qr/\bHash\b/, 'parrot_config basic sanity' ); config_output_like( 'non_existent_key', qr/no such key: 'non_existent_key'/, 'missing keys' ); config_output_like( 'slash has_icu', qr/slash \s+ => \s+ '.' \n has_icu \s+ => \s+ '.'/x, 'multiple keys' ); =head1 HELPER SUBROUTINES =head2 dump_output_like config_output_like($keys, /regexp/, $description); Runs parrot_config with $keys as the argument and verifies the output. =cut sub config_output_like { my ($options, $snippet, $desc) = @_; my $out = `$exefile $options`; like( $out, $snippet, $desc ); return; } # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: addrregistry.t000644000765000765 134411533177645 15416 0ustar00bruce000000000000parrot-6.6.0/t/pmc#!./parrot # Copyright (C) 2006-2008, Parrot Foundation. =head1 NAME t/pmc/addrregistry.t - test AddrRegistry PMC =head1 SYNOPSIS % prove t/pmc/addrregistry.t =head1 DESCRIPTION Tests the AddrRegistry PMC. =cut .sub main :main .include 'test_more.pir' plan(3) $P0 = new ['AddrRegistry'] ok(1, 'Instantiated .AddrRegistry') $I0 = 0 if $P0 goto isnotempty inc $I0 isnotempty: ok($I0, 'vtable get_bool gives false when empty') $P1 = new [ 'Integer' ] $P0[0] = $P1 $I0 = 0 unless $P0 goto isempty inc $I0 isempty: ok($I0, 'vtable get_bool gives true when non empty') .end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: encoding.c000644000765000765 3143212356767112 15552 0ustar00bruce000000000000parrot-6.6.0/src/string/* Copyright (C) 2004-2014, Parrot Foundation. =head1 NAME src/string/encoding.c - global encoding functions =head1 DESCRIPTION These are parrot's generic encoding handling functions =over 4 =cut */ #include "parrot/encoding.h" #include "parrot/namealias.h" #if PARROT_HAS_ICU # include #endif #include "encoding.str" STR_VTABLE *Parrot_default_encoding_ptr = NULL; STR_VTABLE *Parrot_platform_encoding_ptr = NULL; static STR_VTABLE **encodings; static int n_encodings = 0; static STRING *platform_str; /* for backwards compatibility */ static STRING *unicode_str; static STRING *fixed_8_str; #define ENC_NAME_PLATFORM "platform" #define ENC_NAME_UNICODE "unicode" #define ENC_NAME_FIXED8 "fixed_8" /* HEADERIZER HFILE: include/parrot/encoding.h */ /* HEADERIZER BEGIN: static */ /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */ PARROT_PURE_FUNCTION PARROT_WARN_UNUSED_RESULT PARROT_CAN_RETURN_NULL static const STR_VTABLE * find_encoding(PARROT_INTERP, ARGIN(const STRING *encodingname)) __attribute__nonnull__(1) __attribute__nonnull__(2); #define ASSERT_ARGS_find_encoding __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(encodingname)) /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */ /* HEADERIZER END: static */ /* =item C Deinitialize encodings and free all memory used by them. =cut */ void Parrot_deinit_encodings(PARROT_INTERP) { ASSERT_ARGS(Parrot_deinit_encodings) mem_gc_free(interp, encodings); encodings = NULL; n_encodings = 0; } /* =item C Allocates the memory for a new string vtable from the system. =cut */ PARROT_EXPORT PARROT_MALLOC PARROT_CANNOT_RETURN_NULL STR_VTABLE * Parrot_new_encoding(PARROT_INTERP) { ASSERT_ARGS(Parrot_new_encoding) return mem_gc_allocate_typed(interp, STR_VTABLE); } /* =item C Finds an encoding with the STRING name C. Returns the encoding if it is successfully found, returns NULL otherwise. =cut */ PARROT_PURE_FUNCTION PARROT_WARN_UNUSED_RESULT PARROT_CAN_RETURN_NULL static const STR_VTABLE * find_encoding(PARROT_INTERP, ARGIN(const STRING *encodingname)) { ASSERT_ARGS(find_encoding) const int n = n_encodings; int i; for (i = 0; i < n; ++i) if (STRING_equal(interp, encodings[i]->name_str, encodingname)) return encodings[i]; /* backwards compatibility */ if (STRING_equal(interp, encodingname, unicode_str)) return Parrot_utf8_encoding_ptr; if (STRING_equal(interp, encodingname, platform_str)) return Parrot_platform_encoding_ptr; if (STRING_equal(interp, encodingname, fixed_8_str)) return Parrot_ascii_encoding_ptr; return NULL; } /* =item C Finds an encoding with the C string name C. Returns the encoding if it is successfully found, returns NULL otherwise. =cut */ PARROT_EXPORT PARROT_PURE_FUNCTION PARROT_WARN_UNUSED_RESULT PARROT_CAN_RETURN_NULL const STR_VTABLE * Parrot_find_encoding(SHIM_INTERP, ARGIN(const char *encodingname)) { ASSERT_ARGS(Parrot_find_encoding) const int n = n_encodings; int i; for (i = 0; i < n; ++i) if (STREQ(encodings[i]->name, encodingname)) return encodings[i]; /* backwards compatibility */ if (strcmp(encodingname, ENC_NAME_UNICODE) == 0) return Parrot_utf8_encoding_ptr; if (strcmp(encodingname, ENC_NAME_PLATFORM) == 0) return Parrot_platform_encoding_ptr; if (strcmp(encodingname, ENC_NAME_FIXED8) == 0) return Parrot_ascii_encoding_ptr; return NULL; } /* =item C Finds an encoding with the STRING name C. Returns the encoding if it is successfully found, throws an exception otherwise. Returns the default encoding for the NULL string. =cut */ PARROT_EXPORT PARROT_PURE_FUNCTION PARROT_WARN_UNUSED_RESULT PARROT_CAN_RETURN_NULL const STR_VTABLE * Parrot_find_encoding_by_string(PARROT_INTERP, ARGIN(STRING *encodingname)) { ASSERT_ARGS(Parrot_find_encoding_by_string) if (STRING_IS_NULL(encodingname)) return Parrot_default_encoding_ptr; else { const STR_VTABLE * const result = find_encoding(interp, encodingname); if (result) return result; } Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_ENCODING, "invalid encoding '%Ss'", encodingname); } /* =item C Loads an encoding. Currently throws an exception because we cannot load encodings. See https://trac.parrot.org/parrot/wiki/StringsTasklist. =cut */ /* Yep, this needs to be a char * parameter -- it's tough to load in encodings and such for strings if we can't be sure we've got enough info set up to actually build strings... Also remember to use PARROT_WARN_UNUSED_RESULT and PARROT_CANNOT_RETURN_NULL when this actually works. */ PARROT_EXPORT PARROT_DOES_NOT_RETURN PARROT_CANNOT_RETURN_NULL const STR_VTABLE * Parrot_load_encoding(PARROT_INTERP, SHIM(const char *encodingname)) { ASSERT_ARGS(Parrot_load_encoding) Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_UNIMPLEMENTED, "Can't load encodings yet"); } /* =item C Return the number of the encoding or -1 if not found. =cut */ PARROT_EXPORT PARROT_PURE_FUNCTION PARROT_WARN_UNUSED_RESULT INTVAL Parrot_encoding_number(PARROT_INTERP, ARGIN(const STRING *encodingname)) { ASSERT_ARGS(Parrot_encoding_number) const STR_VTABLE * const result = find_encoding(interp, encodingname); return result ? result->num : -1; } /* =item C Return the number of the encoding of the given string or -1 if not found. This could be converted to a macro. =cut */ PARROT_EXPORT PARROT_PURE_FUNCTION PARROT_WARN_UNUSED_RESULT INTVAL Parrot_encoding_number_of_str(SHIM_INTERP, ARGIN(const STRING *src)) { ASSERT_ARGS(Parrot_encoding_number_of_str) return src->encoding->num; } /* =item C Returns the name of a character encoding based on the INTVAL index C to the All_encodings array. This could be converted to a macro. =cut */ PARROT_EXPORT PARROT_PURE_FUNCTION PARROT_WARN_UNUSED_RESULT PARROT_CAN_RETURN_NULL STRING* Parrot_encoding_name(SHIM_INTERP, INTVAL number_of_encoding) { ASSERT_ARGS(Parrot_encoding_name) if (number_of_encoding >= n_encodings || number_of_encoding < 0) return NULL; return encodings[number_of_encoding]->name_str; } /* =item C Returns the encoding given by the INTVAL index C. =cut */ PARROT_EXPORT PARROT_PURE_FUNCTION PARROT_WARN_UNUSED_RESULT PARROT_CAN_RETURN_NULL const STR_VTABLE* Parrot_get_encoding(SHIM_INTERP, INTVAL number_of_encoding) { ASSERT_ARGS(Parrot_get_encoding) if (number_of_encoding >= n_encodings || number_of_encoding < 0) return NULL; return encodings[number_of_encoding]; } /* =item C Returns the NULL-terminated C string representation of the encodings name given by the C. =cut */ PARROT_EXPORT PARROT_PURE_FUNCTION PARROT_WARN_UNUSED_RESULT PARROT_CAN_RETURN_NULL const char * Parrot_encoding_c_name(SHIM_INTERP, INTVAL number_of_encoding) { ASSERT_ARGS(Parrot_encoding_c_name) if (number_of_encoding >= n_encodings || number_of_encoding < 0) return NULL; return encodings[number_of_encoding]->name; } /* =item C Helper function for initializing characterset encoding names. We can't create the STRING names until the default encodings are already initted, so the name generation is split into a second init stage. =cut */ void Parrot_str_internal_register_encoding_names(PARROT_INTERP) { ASSERT_ARGS(Parrot_str_internal_register_encoding_names) int n; for (n = 0; n < n_encodings; ++n) encodings[n]->name_str = Parrot_str_new_constant(interp, encodings[n]->name); /* Can't use CONST_STRING here, not setup yet */ unicode_str = Parrot_str_new_constant(interp, ENC_NAME_UNICODE); fixed_8_str = Parrot_str_new_constant(interp, ENC_NAME_FIXED8); platform_str = Parrot_str_new_constant(interp, ENC_NAME_PLATFORM); } /* =item C Registers a character encoding C with name C. Only allows one of 5 possibilities: fixed_8, utf8, utf16, ucs2 and ucs4. =cut */ PARROT_EXPORT INTVAL Parrot_register_encoding(PARROT_INTERP, ARGIN(STR_VTABLE *encoding)) { ASSERT_ARGS(Parrot_register_encoding) int i; int n = n_encodings; for (i = 0; i < n_encodings; ++i) { if (STREQ(encodings[i]->name, encoding->name)) return 0; } if (!n) encodings = mem_gc_allocate_zeroed_typed(interp, STR_VTABLE *); else encodings = mem_gc_realloc_n_typed_zeroed(interp, encodings, n + 1, n, STR_VTABLE *); encoding->num = n; encodings[n] = encoding; ++n_encodings; return 1; } /* =item C Creates the initial encodings. =cut */ PARROT_EXPORT void Parrot_encodings_init(PARROT_INTERP) { ASSERT_ARGS(Parrot_encodings_init) Parrot_register_encoding(interp, Parrot_ascii_encoding_ptr); Parrot_register_encoding(interp, Parrot_latin1_encoding_ptr); Parrot_register_encoding(interp, Parrot_binary_encoding_ptr); Parrot_register_encoding(interp, Parrot_utf8_encoding_ptr); Parrot_register_encoding(interp, Parrot_utf16_encoding_ptr); Parrot_register_encoding(interp, Parrot_ucs2_encoding_ptr); Parrot_register_encoding(interp, Parrot_ucs4_encoding_ptr); Parrot_default_encoding_ptr = Parrot_ascii_encoding_ptr; Parrot_init_platform_encoding(interp); /* Now that the plugins are registered, we can create STRING * names for them. */ Parrot_str_internal_register_encoding_names(interp); } /* =item C Sets the default encoding to C with name C. =cut */ PARROT_EXPORT INTVAL Parrot_make_default_encoding(SHIM_INTERP, ARGIN(SHIM(const char *encodingname)), ARGIN(STR_VTABLE *encoding)) { ASSERT_ARGS(Parrot_make_default_encoding) Parrot_default_encoding_ptr = encoding; return 1; } /* =item C Gets the default encoding. =cut */ PARROT_EXPORT PARROT_PURE_FUNCTION PARROT_WARN_UNUSED_RESULT PARROT_CANNOT_RETURN_NULL const STR_VTABLE * Parrot_default_encoding(SHIM_INTERP) { ASSERT_ARGS(Parrot_default_encoding) return Parrot_default_encoding_ptr; } /* =item C Helper function for string.ops in the ICU and non-ICU variant. At first search for ICU names. This will not find name aliases for control characters starting with ICU 5.2. U_CHAR_NAME_ALIAS started with ICU 4.4, U_UNICODE_10_CHAR_NAME (the "old name" like "LINE FEED") was deprecated with ICU 4.9, but U_CHAR_NAME_CHOICE_COUNT is stable since 2.0. =cut */ PARROT_PURE_FUNCTION PARROT_WARN_UNUSED_RESULT INTVAL Parrot_str_internal_find_codepoint(PARROT_INTERP, ARGIN(const STRING *name)) { ASSERT_ARGS(Parrot_str_internal_find_codepoint) INTVAL retval = -1; char * const cstr = Parrot_str_to_cstring(interp, name); #if PARROT_HAS_ICU UErrorCode err = U_ZERO_ERROR; unsigned int i = 0; for (; i < U_CHAR_NAME_CHOICE_COUNT; i++) { UChar32 codepoint = u_charFromName((UCharNameChoice)i, cstr, &err); if (U_SUCCESS(err)) { retval = (INTVAL) codepoint; goto found; } } #endif { const struct Parrot_namealias *namealias = Parrot_namealias_lookup(cstr, STRING_byte_length(name)); if (namealias) retval = (INTVAL) namealias->codepoint; } found: Parrot_str_free_cstring(cstr); return retval; } /* =back */ /* * Local variables: * c-file-style: "parrot" * End: * vim: expandtab shiftwidth=4 cinoptions='\:2=2' : */ hires_timer.c000644000765000765 225211656271051 17526 0ustar00bruce000000000000parrot-6.6.0/src/platform/win32/* * Copyright (C) 2009-2011, Parrot Foundation. */ /* =head1 NAME src/platform/win32/hires_timer.c =head1 DESCRIPTION High-resolution timer support for win32 =head2 Functions =over 4 =cut */ #include "parrot/parrot.h" #include /* HEADERIZER HFILE: none */ /* =item C Return a high-resolution number representing how long Parrot has been running. =cut */ UHUGEINTVAL Parrot_hires_get_time(void) { LARGE_INTEGER ticks; QueryPerformanceCounter(&ticks); return (UHUGEINTVAL) ticks.QuadPart; } /* =item C Return the number of nanoseconds that each time unit from Parrot_hires_get_time represents. =cut */ PARROT_CONST_FUNCTION UINTVAL Parrot_hires_get_tick_duration(void) { LARGE_INTEGER ticks; /* QueryPerformanceCounter returns ticks per second, so divide 1 billion by * that to find the length of each tick */ QueryPerformanceFrequency(&ticks); return (UINTVAL) (1000*1000*1000 / ticks.QuadPart); } /* =back =cut */ /* * Local variables: * c-file-style: "parrot" * End: * vim: expandtab shiftwidth=4 cinoptions='\:2=2' : */ basic.t000644000765000765 154312101554067 13772 0ustar00bruce000000000000parrot-6.6.0/t/src#! perl # Copyright (C) 2001-2010, Parrot Foundation. use strict; use warnings; use lib qw( . lib ../lib ../../lib ); use Test::More; use Parrot::Test; use Parrot::Config; use File::Spec::Functions; my $parrot_config = "parrot_config" . $PConfig{o}; plan skip_all => 'src/parrot_config.o does not exist' unless -e catfile("src", $parrot_config); plan tests => 1; =head1 NAME t/src/basic.t - Basics =head1 SYNOPSIS % prove t/src/basic.t =head1 DESCRIPTION Tests C =cut c_output_is( <<'CODE', <<'OUTPUT', "hello world" ); #include #include int main(int argc, const char* argv[]) { printf("Hello, World!\n"); exit(0); } CODE Hello, World! OUTPUT # for $EDITOR ' # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: PGE.pir000644000765000765 136212101554066 15367 0ustar00bruce000000000000parrot-6.6.0/compilers/pge# Copyright (C) 2005-2009, Parrot Foundation. =head1 TITLE PGE - the Parrot/Perl Grammar Engine =head1 DESCRIPTION This is the base file for the grammar engine. It basically combines (via .include) each of the separate PGE modules into a single compilation unit, calling the subroutines marked with the C<:load> subpragma for each. =cut .namespace [ "PGE" ] .include "compilers/pge/PGE/Match.pir" .include "compilers/pge/PGE/OPTable.pir" .include "compilers/pge/PGE/Regex.pir" .include "compilers/pge/PGE/Exp.pir" .include "compilers/pge/PGE/Perl6Regex.pir" .include "compilers/pge/PGE/P5Regex.pir" .include "compilers/pge/PGE/builtins_gen.pir" # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: auto.pm000644000765000765 202112101554066 16555 0ustar00bruce000000000000parrot-6.6.0/config/auto/cpu/ppc# Copyright (C) 2001-2013, Parrot Foundation. =head1 NAME config/auto/cpu/ppc/auto.pm =head1 DESCRIPTION Test =cut package auto::cpu::ppc::auto; use strict; use warnings; sub runstep { my ( $self, $conf ) = @_; my @files = qw( test_gcc_cmpset_c.in ); for my $f (@files) { $conf->debug(" $f "); my ($suffix) = $f =~ /test_(\w+)/; $f = "config/auto/cpu/ppc/$f"; $conf->cc_gen($f); eval { $conf->cc_build("-DPARROT_CONFIG_TEST") }; if ($@) { $conf->debug(" $@ "); } else { if ( $conf->cc_run() =~ /ok/ ) { $conf->data->set( "ppc_has_$suffix" => '1', "HAS_PPC_$suffix" => '1', ); $conf->debug(" (\U$suffix) "); $conf->add_to_generated( $f, "[]" ); } } $conf->cc_clean(); } } 1; # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: Shared.pm000644000765000765 475412101554067 21523 0ustar00bruce000000000000parrot-6.6.0/lib/Parrot/Configure/Options/Conf# Copyright (C) 2007-2012, Parrot Foundation. package Parrot::Configure::Options::Conf::Shared; use strict; use warnings; use base qw( Exporter ); our @EXPORT_OK = qw( @shared_valid_options ); our @shared_valid_options = qw{ ar arflags bindir cage cc ccflags ccwarn configure_trace coveragedir cxx darwin_no_fink darwin_no_macports datadir debugging define disable-rpath exec-prefix fatal fatal-step floatval gc help hintsfile icu-config icuheaders icushared includedir infodir inline intval ld ldflags lex libdir libexecdir libs link linkflags llvm-config localstatedir m make maintainer mandir nomanicheck no-line-directives oldincludedir opcode ops optimize parrot_is_shared prefix profile sbindir sharedstatedir silent sysconfdir test verbose verbose-step version with-llvm without-crypto without-core-nci-thunks without-extra-nci-thunks without-gdbm without-gettext without-gmp without-icu without-opengl without-libffi without-readline without-pcre without-threads without-zlib yacc }; ################### DOCUMENTATION ################### =head1 NAME Parrot::Configure::Options::Conf::Shared - Configuration options shared by both Command-Line and Configuration-File configuration modes =head1 SYNOPSIS use Parrot::Configure::Options::Conf::Shared qw( @shared_valid_options ); our @valid_options = ( 'ask', @shared_valid_options ); =head1 DESCRIPTION This package exports a single variable, C<@shared_valid_options()>, which holds the list of options which may be used either on: =over 4 =item * the L command-line (corresponding to use of C configure> in C); or =item * inside a configuration file where L is called with the C<--file=path/to/configfile> option (corresponding to use of C file> in C). =back =head1 AUTHOR Refactored from earlier code by James E Keenan. Parrot::Configure::Options. Parrot::Configure::Options::Conf::CLI. Parrot::Configure::Options::Conf::File. Configure.pl. =head1 SEE ALSO =cut 1; # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: README.pt-BR000644000765000765 1360111715102032 16753 0ustar00bruce000000000000parrot-6.6.0/docs/translationsEste é o Parrot, versão 2.10.1 ------------------------------ Parrot Copyright (C) 2001-2010, Parrot Foundation. INFORMAÇÕES SOBRE A LICENÇA --------------------------- Este código é distribuído através dos termos da Licença Artística 2.0. Para mais detalhes, veja o texto completo da licença no arquivo LICENSE. RESUMO ------ Parrot é uma máquina virtual desenhada para compilar e executar de maneira eficiente bytecode para linguagens dinâmicas. PRÉ-REQUISITOS -------------- Você vai precisar de um compilador de C, um ligador (linker) e, é claro, um programa de "make". Se você for usar a biblioteca ICU você vai precisar fazer o download e a instalação antes de configurar o Parrot. A biblioteca está disponível através do site http://site.icu-project.org/download. Você também vai precisar do Perl 5.8.4 ou mais novo, e do Storable 2.12 ou mais novo para executar os scripts de configuração e de compilação. Para a maioria das plataformas que nós damos suporte, Parrot consegue ser compilado sem a necessidade de pacotes adicionais. docs/parrot.pod contém uma lista com estas plataformas. O arquivo PLATFORMS dispõe de relatórios sobre as plataformas a qual o Parrot já foi compilado e testado. COMO INSTALAR O PARROT PELO GITHUB ---------------------------------- I. Instalando o Git. Linux: Esta etapa depende da sua distribuição. Para instalar pacotes você deve executar os comandos como "root" (ou através do comando "sudo"): No Ubuntu/Debian (baseado no apt): apt-get install git-core No Red Hat, Fedora (baseado em rpm): yum install git No Gentoo (portage): emerge -av dev-vcs/git Windows: Existe 2 versões de compatibilidade do Git no Windows: msysgit http://code.google.com/p/msysgit/downloads/list TortoiseGit http://code.google.com/p/tortoisegit/downloads/list Macintosh OS X: Uma busca na Internet irá resultar em uma varidade de instaladores do Git para o Mac OS X, incluíndo este: http://help.github.com/mac-git-installation/ II. Obtendo o Parrot pelo github.com Para obter uma cópia do repositório Git do Parrot: git clone git://github.com/parrot/parrot.git Por padrão, apenas a "branch" "master" é baixada. Para criar um "branch" local que que siga o curso da branch "some_branch": git checkout -b --track some_branch origin/some_branch Todas as URLs acima são apenas para leitura. Se você é um desenvolvedor do núcleo do Parrot você deve usar a URL com permissão de escrita: git clone git@github.com:parrot/parrot.git Uma lista com todos os "branches" pode ser encontrada em http://github.com/parrot/parrot INSTRUÇÕES ---------- Se você baixou uma versão compactada do Parrot você vai precisar descompactar o pacote antes de prosseguir. Em seguida, entre na pasta do Parrot e execute o seguinte comando perl Configure.pl para rodar o script de configuração. Este script extrai a configuração do perl5 que está sendo executado. Pode ser que você precise mostrar explicitamente ao Configure.pl qual compilador e qual ligador (linker) você deseja usar. Por exemplo, para compilar os arquivos em C com o "cc", os arquivos em C++ com o "CC" e ligar tudo com o "CC", basta executar o script da seguinte forma: perl Configure.pl --cc=cc --link=CC --ld=CC Consulte "perl Configure.pl --help" para mais informações e docs/configuration.pod para mais detalhes. Para sistemas como o HPUX, que não contém o inet_pton, execute perl Configure.pl --define=inet_aton O Configure.pl irá gerar o cabeçalho config.h, o módulo Parrot::Config, arquivos específicos da plataforma e vários arquivos "Makefile". O arquivo "myconfig" contém um resumo com todas as opções de configuração. A seguir, execute o comando "make". Configure.pl irá reportar qual a versão do make que ele recomenda ao seu sistema. Agora o interpretador será compilado. Se você está compilando a biblioteca ICU (padrão na maioria dos sistemas), você vai precisar do GNU make (ou algo compatível com ele). Você pode testar o Parrot através do comando "make test". Também é possível rodar os testes em paralelo, executando "make TEST_JOBS=3 test". Para rodar a suíte completa de testes, execute: make fulltest Nota: o arquivo PLATFORMS contém notas sobre falhas esperadas nos testes de acordo com os diferentes sistemas. Para instalar o Parrot: make install Por padrão ele será instalado em /usr/local, com os executáveis em /usr/local/bin. Se você quer instalar Parrot em alguum outro lugar, use: perl Configure.pl --prefix=/home/joe/bird make install Mas por favor, note que as bibliotecas dinâmicas não serão encontradas nos lugares não convencionais, ao menos que você as inclua no LD_LIBRARY_PATH ou similar. Leia o docs/parrot.pod e docs/intro.pod para saber onde ir a partir daqui. Se você encontrar algum problema, olhe a seção "How To Submit A Bug Report" em docs/submissions.pod. Esses documentos estão no formato POD. Você pode os ler através do comando: perldoc -F docs/intro.pod ATUALIZAÇÕES ------------ Para documentação sobre as mudanças visíveis aos usuários ao longo das diferentes versões, por favor confira o arquivo NEWS. LISTAS DE EMAIL --------------- A lista de usuários do Parrot é parrot-users@lists.parrot.org. Subscreva-se preenchendo o formulário em http://lists.parrot.org/mailman/listinfo/parrot-users. A lista é arquivada em http://lists.parrot.org/pipermail/parrot-users/. Para discussões sobre desenvolvimento, confira o arquivo docs/gettingstarted.pod. FEEDBACK, PATCHES, etc. ----------------------- Dê uma olhada em docs/submissions.pod para mais informações sobre como reportar bugs e submeter patches. WEB SITES --------- Os seguintes sites contém todas as informações que você precisa saber sobre Parrot. http://www.parrot.org/ http://docs.parrot.org/ https://github.com/parrot/parrot/ Se divirta, A equipe do Parrot. addopstags.pl000755000765000765 145611606346603 16110 0ustar00bruce000000000000parrot-6.6.0/tools/dev#!perl # Copyright (C) 2004-2006, Parrot Foundation. use strict; use warnings; =head1 NAME tools/dev/addopstags.pl - add src/ops/*.ops to tags =head1 SYNOPSIS perl tools/dev/addopstags.pl src/ops/*.ops =head1 DESCRIPTION Add src/ops/*.ops to tags file. =cut my %seen; my @tags; # Pull ops tags while (<>) { if (/\bop \s+ (\w+) \s* \(/x) { next if $seen{$1}++; # tag file excmd xflags push @tags, join( "\t", $1, $ARGV, qq{$.;"}, "f" ) . "\n"; } } continue { close ARGV if eof; # reset $. } # Pull existing tags open my $T, '<', 'tags'; push @tags, <$T>; close $T; # Spit 'em out sorted open $T, '>', 'tags'; print $T sort @tags; close $T; # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: string.t000644000765000765 5257612101554067 14243 0ustar00bruce000000000000parrot-6.6.0/t/pmc#!./parrot # Copyright (C) 2001-2010, Parrot Foundation. =head1 NAME t/pmc/string.t - Strings =head1 SYNOPSIS % prove t/pmc/string.t =head1 DESCRIPTION Tests the C PMC. =cut .include 'except_types.pasm' .sub main :main .include 'test_more.pir' plan(160) set_or_get_strings() setting_integers() setting_numbers() ensure_that_concat_ppp_copies_strings() ensure_that_concat_pps_copies_strings() test_repeat() test_repeat_without_creating_dest_pmc() test_repeat_int() test_repeat_int_without_declaring_dest() test_if_string() test_concat() test_concat_without_defining_dest() test_cmp_num() test_cmp() cmp_with_integer() test_substr() test_eq_num() test_eq_str() test_ne_str() check_whether_interface_is_done() test_clone() test_set_px_i() test_set_px_s() test_set_bool() test_string_replace() set_i0__p0__string_to_int() test_string_trans() reverse_string() is_integer__check_integer() instantiate_str() get_string_returns_cow_string() to_int_1() elements_gives_length_of_string() test_string_reverse_index() out_of_bounds_substr_positive_offset() out_of_bounds_substr_negative_offset() exception_to_int_2() exception_to_int_3() exception_to_int_noalphanum() assign_null_string() access_keyed() exists_keyed() test_unescape() # END_OF_TESTS .end .sub set_or_get_strings new $P0, ['String'] new $P1, ['Boolean'] set $P0, "foo" set $S0, $P0 is( $S0, "foo", 'String obj set with literal string' ) set $P0, "\0" set $S0, $P0 is( $S0, "\0", 'String obj set with \0 string' ) set $P0, "" set $S0, $P0 is( $S0, "", 'String obj set with "" string' ) set $P0, 123 set $S0, $P0 is( $S0, "123", 'String obj set with literal int' ) set $P0, 1.23456789 set $S0, $P0 is( $S0, "1.23456789", 'String obj set with literal floating point' ) set $P0, "0xFFFFFF" set $S0, $P0 is( $S0, "0xFFFFFF", 'String obj set with literal hex string' ) new $P1, ['Float'] set $P1, 3.14159 setref $P0, $P1 is( $P0, "3.14159", 'String obj set with Float PMC' ) null $S0 set $P0, $S0 set $S1, $P0 isnull $I0, $S1 ok( $I0, 'String obj is null-in null-out' ) .end .sub setting_integers new $P0, ['String'] set $P0, "1" set $I0, $P0 is( $I0, 1, 'string "1" -> int' ) new $P0, ['String'] set $P0, "2.0" set $I0, $P0 is( $I0, 2, 'string "2.0" -> int' ) new $P0, ['String'] set $P0, "" set $I0, $P0 is( $I0, 0, 'string "" -> int' ) new $P0, ['String'] set $P0, "\0" set $I0, $P0 is( $I0, 0, 'string "\0" -> int' ) new $P0, ['String'] set $P0, "foo" set $I0, $P0 is( $I0, 0, 'string "foo" -> int' ) .end .sub setting_numbers .include 'fp_equality.pasm' new $P0, ['String'] set $P0, "1" set $N0, $P0 .fp_eq_ok($N0, 1.0, 'String 1 -> $N0 == 1.0') new $P0, ['String'] set $P0, "2.0" set $N0, $P0 .fp_eq_ok($N0, 2.0, 'String "2.0" -> $N0 == 2.0') new $P0, ['String'] set $P0, "" set $N0, $P0 .fp_eq_ok($N0, 0.0, 'String "" -> $N0 == 0.0') new $P0, ['String'] set $P0, "\0" set $N0, $P0 .fp_eq_ok($N0, 0.0, 'String "\0" -> $N0 == 0.0') new $P0, ['String'] set $P0, "foo" set $N0, $P0 .fp_eq_ok($N0, 0.0, 'String "foo" -> $N0 == 0.0') new $P0, ['String'] set $P0, "1.3e5" set $N0, $P0 .fp_eq_ok($N0, 130000.0, 'String "1.3e5" -> $N0 == 130000.0') .end .sub ensure_that_concat_ppp_copies_strings new $P0, ['String'] new $P1, ['String'] new $P2, ['String'] set $P0, "foo" concat $P1, $P0, $P0 is( $P0, 'foo', 'original String is unchanged' ) is( $P1, 'foofoo', 'concat on String' ) set $P1, "You can't teach an old dog new..." set $P2, "clear physics" concat $P0, $P1, $P2 is( $P1, "You can't teach an old dog new...", 'original String is unchanges' ) is( $P2, 'clear physics', 'original String is unchanges' ) is( $P0, "You can't teach an old dog new...clear physics", 'concat on String' ) .end .sub ensure_that_concat_pps_copies_strings new $P0, ['String'] new $P1, ['String'] set $S0, "Grunties" set $P1, "fnargh" concat $P0, $P1, $S0 is( $S0, 'Grunties', 'original untouched' ) is( $P1, 'fnargh', 'original untouched' ) is( $P0, 'fnarghGrunties', 'concat success' ) .end .sub test_repeat new $P0, ['String'] set $P0, "x" new $P1, ['Integer'] set $P1, 12 new $P2, ['String'] repeat $P2, $P0, $P1 is( $P2, 'xxxxxxxxxxxx', 'Integer arg to repeat' ) set $P0, "y" new $P1, ['Float'] set $P1, 6.5 repeat $P2, $P0, $P1 is( $P2, 'yyyyyy', 'Float arg to repeat' ) set $P0, "z" new $P1, ['String'] set $P1, "3" repeat $P2, $P0, $P1 is( $P2, 'zzz', 'String "3" arg to repeat' ) set $P0, "a" new $P1, ['Undef'] repeat $P2, $P0, $P1 is( $P2, '', 'undef PMC arg to repeat' ) .end .sub test_repeat_without_creating_dest_pmc new $P0, ['String'] set $P0, "x" new $P1, ['Integer'] set $P1, 12 repeat $P2, $P0, $P1 is( $P2, 'xxxxxxxxxxxx', 'Integer argument to repeat' ) set $P0, "y" new $P1, ['Float'] set $P1, 6.5 repeat $P3, $P0, $P1 is( $P3, 'yyyyyy', 'Float arg to repeat' ) set $P0, "z" new $P1, ['String'] set $P1, "3" repeat $P4, $P0, $P1 is( $P4, 'zzz', 'String "3" arg to repeat' ) set $P0, "a" new $P1, ['Undef'] repeat $P5, $P0, $P1 is( $P5, '', 'Undef PMC arg to repeat' ) .end .sub test_repeat_int new $P0, ['String'] set $P0, "x" set $I1, 12 new $P2, ['String'] repeat $P2, $P0, $I1 is( $P2, 'xxxxxxxxxxxx', 'repeat with int arg' ) set $P0, "za" set $I1, 3 repeat $P2, $P0, $I1 is( $P2, 'zazaza', 'repeat with int arg' ) .end .sub test_repeat_int_without_declaring_dest new $P0, ['String'] set $P0, "x" set $I1, 12 repeat $P2, $P0, $I1 is( $P2, "xxxxxxxxxxxx", 'repeat with int arg' ) # print $P2 set $P0, "za" repeat $P3, $P0, 3 is( $P3, "zazaza", 'repeat with literal int arg' ) # print $P3 .end .sub test_if_string new $P0, ['String'] set $S0, "True" set $P0, $S0 set $I0, 1 if $P0, TRUE set $I0, 0 TRUE: ok( $I0, 'String "String" is true' ) new $P1, ['String'] set $S1, "" set $P1, $S1 set $I0, 1 if $P1, TRUE2 set $I0, 0 TRUE2: nok( $I0, 'String "" is false' ) new $P2, ['String'] set $S2, "0" set $P2, $S2 set $I0, 1 if $P2, TRUE3 set $I0, 0 TRUE3: nok( $I0, 'String "0" is false' ) new $P3, ['String'] set $S3, "0123" set $P3, $S3 set $I0, 1 if $P3, TRUE4 set $I0, 0 TRUE4: ok( $I0, 'String "0123" is true' ) new $P4, ['String'] set $I0, 1 if $P4, TRUE5 set $I0, 0 TRUE5: nok( $I0, 'uninitialized String is false' ) .end .sub test_concat new $P0, ['String'] new $P1, ['Undef'] set $P0, "foo" concat $P1, $P0, $P0 is( $P0, "foo", 'original String is untouched' ) is( $P1, "foofoo", '...and concat worked' ) new $P0, ['String'] new $P1, ['Undef'] set $P0, "bar" concat $P0, $P0, $P1 is( $P0, "bar", '"bar" + Undef = "bar"' ) is( $P1, "", '... Undef is ""' ) new $P0, ['String'] new $P1, ['Undef'] set $P1, "str" concat $P1, $P0, $P1 is( $P0, "", 'original Undef is ""' ) is( $P1, "str", '"str" + Undef = "str"' ) .end .sub test_concat_without_defining_dest new $P0, ['String'] set $P0, "foo" concat $P1, $P0, $P0 is( $P0, "foo", 'original String is unchanged' ) is( $P1, "foofoo", '... concat String x2' ) new $P0, ['String'] set $P0, "foo" concat $P2, $P0, "bar" is( $P0, "foo", 'original String is unchanged' ) is( $P2, "foobar", '... concat String and "bar"' ) .end .sub test_cmp new $P1, ['String'] new $P2, ['String'] set $P1, "abc" set $P2, "abc" cmp $I0, $P1, $P2 is( $I0, "0", 'cmp "abc", "abc" = 0' ) set $P1, "abcde" set $P2, "abc" cmp $I0, $P1, $P2 is( $I0, "1", 'cmp "abcde", "abc" = 1' ) set $P1, "abc" set $P2, "abcde" cmp $I0, $P1, $P2 is( $I0, "-1", 'cmp "abcde", "abc" = -1' ) .end .sub test_cmp_num new $P1, ['String'] new $P2, ['Integer'] set $P1, "10" set $P2, 10 cmp_num $I0, $P1, $P2 is( $I0, 0, 'cmp_num "10"(String PMC), 10(Integer PMC) = 0' ) set $P2, 20 cmp_num $I0, $P1, $P2 is( $I0, -1, 'cmp_num "10", 20 = -1' ) set $P2, 5 cmp_num $I0, $P1, $P2 is( $I0, 1, 'cmp_num "10", 5 = 1' ) set $P1, "asd" cmp_num $I0, $P1, $P2 is( $I0, -1, 'cmp_num "asd", 5 = -1' ) .end .sub cmp_with_integer new $P1, ['Integer'] new $P2, ['String'] set $P2, "10" # Int. vs Str. set $P1, 10 cmp $I0, $P1, $P2 is( $I0, 0, 'cmp 10(Integer PMC), "10"(String PMC) = 0' ) set $P1, 20 cmp $I0, $P1, $P2 is( $I0, 1, 'cmp 20, "10" = 1' ) set $P1, 0 cmp $I0, $P1, $P2 is( $I0, -1, 'cmp 0, "10" = -1' ) # Str. vs Int. set $P1, 0 cmp $I0, $P2, $P1 is( $I0, 1, 'cmp "10", 0 = 1' ) set $P1, 20 cmp $I0, $P2, $P1 is( $I0, -1, 'cmp "10", 20 = -1' ) set $P1, 10 cmp $I0, $P2, $P1 is( $I0, 0, 'cmp "10", 10 = 0' ) .end .sub test_substr new $P0, ['String'] set $P0, "This is a test\n" substr $S0, $P0, 0, 5 substr $S1, $P0, 10, 4 substr $S2, $P0, -11, 3 substr $S3, $P0, 7, 1000 # Valid offset, but length > string length is( $S0, 'This ', 'first 5 chars' ) is( $S1, 'test', '10-14' ) is( $S2, ' is', 'start from the end' ) is( $S3, " a test\n", 'valid offset, but length > string length' ) is( $P0, "This is a test\n", 'original is unmodified' ) .end .sub test_eq_num new $P1, ['String'] new $P2, ['Float'] set $P1, "124" set $P2, 124 set $I0, 1 eq_num $P2, $P1, OK1 set $I0, 0 OK1: ok( $I0, 'eq_num "124"(String), 124(Float) -> true' ) set $P2, 124.2 set $I0, 1 eq_num $P2, $P1, OK2 set $I0, 0 OK2: nok( $I0, 'eq_num "124"(String), 124.2(Float) -> false' ) set $P2, 0 set $I0, 1 eq_num $P1, $P2, OK3 set $I0, 0 OK3: nok( $I0, 'eq_num 0(Float), "124"(String) -> false' ) .end .sub test_eq_str new $P1, ['String'] new $P2, ['String'] set $P1, "ABC" set $P2, "ABC" set $I0, 1 eq_str $P2, $P1, OK1 set $I0, 0 OK1: ok( $I0, 'eq_str "ABC"(String), "ABC"(String) -> true' ) set $P2, "abc" set $I0, 1 eq_str $P2, $P1, OK2 set $I0, 0 OK2: nok( $I0, 'eq_str "abc"(String), 1(Int) -> false' ) new $P3, ['Integer'] set $P3, 0 set $I0, 1 eq_str $P2, $P3, OK3 set $I0, 0 OK3: nok( $I0, 'eq_str "abc"(String), 0(Integer) -> false' ) set $I0, 1 eq_str $P3, $P2, OK4 set $I0, 0 OK4: nok( $I0, 'eq_str 0(Integer), "abc"(String) -> false' ) .end .sub test_ne_str new $P1, ['String'] new $P2, ['String'] set $P1, "ABC" set $P2, "abc" set $I0, 1 ne_str $P2, $P1, OK1 set $I0, 0 OK1: ok( $I0, 'ne_str "abc", "ABC" -> true' ) set $P2, "ABC" set $I0, 1 ne_str $P2, $P1, OK2 set $I0, 0 OK2: nok( $I0, 'ne_str "ABC", "ABC" -> false' ) new $P3, ['Integer'] set $P3, 0 set $I0, 1 ne_str $P2, $P3, OK3 set $I0, 0 OK3: ok( $I0, 'ne_str "ABC", 0(Integer) -> true' ) set $I0, 1 ne_str $P3, $P2, OK4 set $I0, 0 OK4: ok( $I0, 'ne_str "0(Integer), "ABC" -> true' ) .end .sub check_whether_interface_is_done .local pmc pmc1 pmc1 = new ['String'] .local int bool1 does bool1, pmc1, "scalar" ok( bool1, 'String does scalar' ) does bool1, pmc1, "string" ok( bool1, 'String does string' ) does bool1, pmc1, "no_interface" nok( bool1, 'String !does no_interface' ) .end .sub test_clone new $P0, ['String'] set $P0, "Tacitus\n" clone $P1, $P0 set $P0, "" is( $P1, "Tacitus\n", 'clone creates a copy' ) .end .sub test_set_px_i new $P0, ['String'] set $P0, "abcdef\n" set $P0[2], 65 is( $P0, "abAdef\n", 'set p[x] = int' ) .end .sub test_set_px_s new $P0, ['String'] set $P0, "abcdef\n" set $P0[2], "AB" is( $P0, "abABef\n", 'set p[x] = string' ) .end .sub test_set_bool new $P0, ['String'] set $P0, "1" not $P0 is( $P0, "0", 'not "1" = "0"' ) not $P0 is( $P0, "1", 'not "0" = "1"' ) set $P0, "false" not $P0 is( $P0, "0", 'not "false" = "0"' ) set $P0, 0 not $P0 is( $P0, "1", 'not 0 = "1"' ) .end .sub test_string_replace $P0 = new ['String'] $P0 = "hello world" is( $P0, "hello world", 'original' ) $P0."replace"("l", "-") is( $P0, "he--o wor-d", 'String."replace" l with -' ) $P0."replace"("wo", "!!!!") is( $P0, "he--o !!!!r-d", 'String."replace" wo with !!!!' ) $P0."replace"("he-", "") is( $P0, "-o !!!!r-d", 'String."replace" he- with ""' ) .end .sub set_i0__p0__string_to_int new $P0, ['String'] set $P0, "12.3E5\n" set $I0, $P0 is( $I0, 12, '"12.3E4\n" -> $I0 = 12' ) .end .sub test_string_trans # tr{wsatugcyrkmbdhvnATUGCYRKMBDHVN} # {WSTAACGRYMKVHDBNTAACGRYMKVHDBN}; .local string s, t .local int el s = "atugcsATUGCS" .const 'Sub' tr_00 = 'tr_00_init' el = elements tr_00 is( el, 256, 'elements' ) $P0 = new ['String'] t = $P0.'trans'(s, tr_00) is( t, 'TAACGSTAACGS', 'trans' ) is( s, 'atugcsATUGCS', "trans doesn't touch source string") push_eh THROWN $I0 = 1 $P0.'trans'(unicode:"abc", tr_00) goto TEST THROWN: $I0 = 0 TEST: pop_eh todo( $I0, 'trans works with unicode' ) .end # create tr table at compile-time .sub tr_00_init :immediate .local pmc tr_array tr_array = new ['FixedIntegerArray'] # Todo char array tr_array = 256 # Python compat ;) .local string from, to from = 'wsatugcyrkmbdhvnATUGCYRKMBDHVN' to = 'WSTAACGRYMKVHDBNTAACGRYMKVHDBN' .local int i, ch, r, len len = length from null i loop: ch = ord from, i r = ord to, i tr_array[ch] = r inc i if i < len goto loop .return(tr_array) .end .sub reverse_string $P0 = box 'torrap' $P0.'reverse'() is( $P0, "parrot", 'reverse string' ) $P0 = box 'x' $P0.'reverse'('hsifyllej') is( $P0, 'jellyfish', "reverse string with optional arg") $P0 = box unicode:"科ムウオ" $P0.'reverse'() is( $P0, unicode:"オウム科", 'reverse unicode string') .end .sub is_integer__check_integer $P0 = new ['String'] $I0 = $P0.'is_integer'('543') ok( $I0, 'String."is_integer("543")' ) $I0 = $P0.'is_integer'('4.3') nok( $I0, '... 4.3' ) $I0 = $P0.'is_integer'('foo') nok( $I0, '... foo' ) $I0 = $P0.'is_integer'('-1') ok( $I0, '... -1' ) $I0 = $P0.'is_integer'('+-1') nok( $I0, '... +-1' ) $I0 = $P0.'is_integer'('+1') ok( $I0, '... +1' ) $S0 = 'abc123abc' $S1 = substr $S0, 3, 3 $I0 = $P0.'is_integer'($S1) ok( $I0, '... substr' ) push_eh THROWN $I0 = 1 $P0.'is_integer'(utf8:"123") goto TEST THROWN: $I0 = 0 TEST: pop_eh ok( $I0, 'is_integer works with utf8' ) .end .sub instantiate_str .const 'String' ok = "ok" is( ok, "ok", ".const 'String'" ) .end .sub get_string_returns_cow_string $P0 = new ['String'] $P0 = "Foo44" $S0 = $P0 $S0 = replace $S0, 0, 1, "B" is( $S0, "Boo44", 'substr replace' ) is( $P0, "Foo44", '... no change to original' ) .end .sub to_int_1 .local pmc s s = new ['String'] s = "123" $I0 = s.'to_int'(10) is( $I0, "123", 'String.to_int(10)' ) s = "2a" $I0 = s.'to_int'(16) is( $I0, "42", '... 16' ) s = "2B" $I0 = s.'to_int'(16) is( $I0, "43", '... 16 upper' ) s = "1001" $I0 = s.'to_int'(2) is( $I0, "9", '... 2' ) .end .sub elements_gives_length_of_string .local pmc s s = new ['String'] s = "123456789" $I0 = elements s is( $I0, "9", 'elements gives length of string' ) .end .sub test_string_reverse_index $P0 = new ['String'] $I0 = $P0.'reverse_index'('hello', 0) is( $I0, -1, "main empty -1" ) $P0 = "Hello world" $I0 = $P0.'reverse_index'('', 0) is( $I0, -1, "search empty -1" ) $I0 = $P0.'reverse_index'('o', -1) is( $I0, -1, "negative start -1" ) $I0 = $P0.'reverse_index'('o', 999) is( $I0, -1, "far far away -1" ) $I0 = $P0.'reverse_index'('l', 0) is( $I0, -1, "reverse_index starting from 0 is -1" ) $I0 = $P0.'reverse_index'('l', 8) is( $I0, 3, "search2 3" ) $P0 = utf8:"string strin \x{12345}-\x{aa}-\x{ab} world" $I0 = $P0.'reverse_index'('', 0) is( $I0, -1, "search empty -1 unicode" ) $I0 = $P0.'reverse_index'('o', -1) is( $I0, -1, "negative start -1 unicode" ) $I0 = $P0.'reverse_index'('o', 24) is( $I0, 20, "start = strlen works" ) $I0 = $P0.'reverse_index'('string', 23) is( $I0, 0, "search1 unicode" ) $I0 = $P0.'reverse_index'(utf16:"\x{aa}-\x{ab}", 15) is( $I0, 15, "search2 unicode" ) $I0 = $P0.'reverse_index'(utf16:"\x{aa}-\x{ab}", 14) is( $I0, -1, "search3 unicode" ) .end .macro exception_is ( M ) .local pmc exception .local string message .get_results (exception) message = exception['message'] is( message, .M, .M ) .endm .sub out_of_bounds_substr_positive_offset new $P0, ['String'] set $P0, "Woburn" set $I0, 0 push_eh handler substr $S0, $P0, 123, 22 handler: .exception_is( 'Cannot take substr outside string' ) .end .sub out_of_bounds_substr_negative_offset new $P0, ['String'] set $P0, "Woburn" push_eh handler substr $S0, $P0, -123, 22 handler: .exception_is( 'Cannot take substr outside string' ) .end .sub exception_to_int_2 .local pmc s s = new ['String'] s = "123" push_eh handler $I0 = s.'to_int'(3) handler: .exception_is( 'invalid conversion to int - bad char 3' ) .end .sub exception_to_int_3 .local pmc s s = new ['String'] s = "123" push_eh handler $I0 = s.'to_int'(37) handler: .exception_is( 'invalid conversion to int - bad base 37' ) .end .sub to_int_noalnum .local pmc s s = new ['String'] s = "?" $I0 = s.'to_int'(10) .end .sub exception_to_int_noalphanum .const 'Sub' noalnum = 'to_int_noalnum' throws_type(noalnum, .EXCEPTION_INVALID_OPERATION, 'to_int - no aplhanumeric') .end .sub assign_null_string .local pmc s .local string m s = new ['String'] null m assign s, m m = 'Any other thing' m = s $I0 = 0 if null m goto check inc $I0 check: is( $I0, 0, 'assign null string, TT #729' ) .end .sub access_keyed .local pmc s s = new ['String'] s = "BAR" # Second character is zero, not 'o' # Get $S0 = s[0] is($S0, 'B', 'Get string by index') $I0 = s[1] $I1 = ord 'A' is($I0, $I1, 'Get integer by index') $P0 = s[2] is($P0, 'R', 'Get PMC by index') .local pmc k k = new ['Integer'] k = 2 $S0 = s[k] is($S0, 'R', 'Get string keyed with PMC') $I0 = s[k] $I1 = ord 'R' is($I0, $I1, 'Get integer keyed with PMC') $P0 = s[k] $S0 = $P0 is($S0, 'R', 'Get PMC keyed with PMC') # Set s = new ['String'] s = '' $S0 = 'f' s[0] = $S0 is(s, 'f', 'Set string keyed') $I0 = ord 'o' s[1] = $I0 is(s, 'fo', 'Set integer keyed') $P0 = new ['String'] $P0 = 'o' s[2] = $P0 is(s, 'foo', 'Set PMC keyed') s = '' k = 0 s[k] = $S0 is(s, 'f', 'Set string keyed with PMC') k = 1 $I0 = ord 'g' s[k] = $I0 is(s, 'fg', 'Set integer keyed with PMC') k = 2 $P0 = new ['String'] $P0 = 'h' s[k] = $P0 is(s, 'fgh', 'Set PMC keyed with PMC') push_eh null_replace s = new ['String'] s[0] = 'f' nok('Replace on null string throws') goto done_null_replace null_replace: ok(1, 'Replace on null string throws') done_null_replace: .end .sub exists_keyed .local pmc s, i .local int r s = new['String'] s = '' i = new['Integer'] i = 0 r = exists s[i] is(r, 0, 'exists_keyed on empty String') s = 'a' r = exists s[i] is(r, 1, 'exists_keyed within bounds') i = 1 r = exists s[i] is(r, 0, 'exists_keyed out of bounds') i = -1 r = exists s[i] is(r, 1, 'exists_keyed negative within bounds') i = -2 r = exists s[i] is(r, 0, 'exists_keyed negative out of bounds') .end .sub test_unescape .local pmc s1, s2 s1 = new['String'] s1 = '\n' s2 = s1.'unescape'('ascii') is( s2, "\n", "unescape('\\n') == \"\\n\"" ) s1 = '\x41\x42' s2 = s1.'unescape'('ascii') is( s2, 'AB', "unescape('\\x41\\x42') == 'AB'" ) s1 = '\u0043\u0044' s2 = s1.'unescape'('ascii') is( s2, 'CD', "unescape('\\u0043\\u0044') == 'CD'" ) .end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: pcre_c.in000644000765000765 66411567202622 16410 0ustar00bruce000000000000parrot-6.6.0/config/auto/pcre/* Copyright (C) 2008-2011, Parrot Foundation. */ #include #include #include int main(int argc, char *argv[]) { if (pcre_exec == NULL) { printf("pcre_exec is NULL\n"); return EXIT_FAILURE; } printf("pcre %s\n", pcre_version()); return EXIT_SUCCESS; } /* * Local variables: * c-file-style: "parrot" * End: * vim: expandtab shiftwidth=4 cinoptions='\:2=2' : */ nopaste.pl000755000765000765 346311606346603 15430 0ustar00bruce000000000000parrot-6.6.0/tools/dev#!perl # Copyright (C) 2008, Parrot Foundation. use 5.008; use strict; use warnings; use WWW::Mechanize; use Getopt::Std; use Pod::Usage; my $server = 'nopaste.snit.ch'; my $url = "http://$server:8001/paste"; my $opt = { c => '#parrot', # channel n => getlogin || getpwuid($<) || 'someone', # name t => undef, # title }; getopt( 'c:n:t:', $opt ); pod2usage(2) unless defined $opt->{t}; my $text; while(<>) { $text .= $_; } my $mech = WWW::Mechanize->new( cookie_jar => undef, autocheck => 1, ); $mech->get( $url ); $mech->submit_form( form_name => 'pasteForm', fields => { (defined $opt->{c} ? (channel => $opt->{c}) : () ), nick => $opt->{n}, summary => $opt->{t}, paste => $text, }, button => 'Paste it', ); my @link = $mech->links; print "Your paste can be found at ", $link[0]->url, "\n"; =head1 NAME tools/dev/nopaste.pl - paste the contents of a file via a pastebot server =head1 SYNOPSIS nopaste.pl -t "TITLE" [ -c CHANNEL ] [ -n NAME ] [ FILENAME ] TITLE the title of the paste CHANNEL the irc channel (defaults to #parrot) NAME the username (defaults to username or 'someone') FILENAME the name of the file to paste (defaults to STDIN) =head1 DESCRIPTION This program can be used to paste the contents of a file on a pastebot server -- specifically, B -- for immediate linkage on an IRC channel -- by default, B<#parrot>. =head1 AUTHOR Originally written by particle, with subsequent contributions to functionality by LimbicRegion, paultcochrane and cotto. =cut # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: float.pmc000644000765000765 3340512356767111 14700 0ustar00bruce000000000000parrot-6.6.0/src/pmc/* Copyright (C) 2003-2014, Parrot Foundation. =head1 NAME src/pmc/float.pmc - Float PMC =head1 DESCRIPTION C PMC extends the abstract C PMC to provide floating-point number operations. =head2 Functions =over 4 =cut */ /* HEADERIZER HFILE: none */ /* HEADERIZER BEGIN: static */ /* HEADERIZER END: static */ pmclass Float extends scalar provides float provides scalar auto_attrs { ATTR FLOATVAL fv; /* =item C Initializes the number to zero. =cut */ VTABLE void init() { SET_ATTR_fv(INTERP, SELF, 0.0); } /* =item C Make an exact copy of this PMC. =cut */ VTABLE PMC *clone() :no_wb { FLOATVAL fv; PMC * const dest = Parrot_pmc_new(INTERP, SELF->vtable->base_type); GET_ATTR_fv(INTERP, SELF, fv); SET_ATTR_fv(INTERP, dest, fv); return dest; } /* =item C Return the memory address of an Float PMC. This is needed for certain NCI applications and may be disabled in certain security contexts. =cut */ VTABLE void *get_pointer() :no_wb { UNUSED(INTERP) return &(PARROT_FLOAT(SELF)->fv); } /* =item C Returns the value of the number. =cut */ VTABLE FLOATVAL get_number() :no_wb { FLOATVAL fv; GET_ATTR_fv(INTERP, SELF, fv); return fv; } /* =item C Returns an integer representation of the number by truncating (rounding toward zero). =cut */ VTABLE INTVAL get_integer() :no_wb { /* two steps avoid casting warnings */ const FLOATVAL n = SELF.get_number(); return (INTVAL) n; } /* =item C Evaluates the number as a boolean, i.e. it's true if it's not zero. =cut */ VTABLE INTVAL get_bool() :no_wb { const FLOATVAL f = SELF.get_number(); return !FLOAT_IS_ZERO(f); } /* =item C Returns a Parrot string representation of the number. =item C =cut */ VTABLE STRING *get_string() :no_wb { return Parrot_str_from_num(INTERP, SELF.get_number()); } VTABLE STRING *get_repr() :no_wb { const FLOATVAL val = SELF.get_number(); const double d = fabs((double)val); const char * const sign = val < 0 ? "-" : ""; return Parrot_sprintf_c(INTERP, "%s" FLOATVAL_FMT, sign, d); } /* =item C =item C =cut */ VTABLE void set_integer_native(INTVAL value) :manual_wb { Parrot_pmc_reuse(INTERP, SELF, Parrot_hll_get_ctx_HLL_type(INTERP, enum_class_Integer), 0); SELF.set_integer_native(value); } VTABLE void set_bool(INTVAL value) :manual_wb { Parrot_pmc_reuse(INTERP, SELF, Parrot_hll_get_ctx_HLL_type(INTERP, enum_class_Boolean), 0); SELF.set_bool(value); } /* =item C Sets the value of the number to C. =cut */ VTABLE void set_number_native(FLOATVAL value) { SET_ATTR_fv(INTERP, SELF, value); } /* =item C Sets the value of the number to the value of C<*value>. Note that this method morphs the number into a C. =cut */ VTABLE void set_string_native(STRING *value) :manual_wb { Parrot_pmc_reuse(INTERP, SELF, Parrot_hll_get_ctx_HLL_type(INTERP, enum_class_String), 0); SELF.set_string_native(value); } /* =item C Sets the value of the number to the value in C<*value>. =cut */ VTABLE void set_pmc(PMC *value) { SET_ATTR_fv(INTERP, SELF, VTABLE_get_number(INTERP, value)); } /* =item C =item C Set C to the negated value of C. =cut */ VTABLE PMC *neg(PMC *dest) :no_wb { const FLOATVAL a = -SELF.get_number(); dest = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); VTABLE_set_number_native(INTERP, dest, a); return dest; } VTABLE void i_neg() :manual_wb { const FLOATVAL a = -SELF.get_number(); VTABLE_set_number_native(INTERP, SELF, a); } /* =item C The C<==> operation. =cut */ MULTI INTVAL is_equal(Float value) :no_wb { return (INTVAL)(SELF.get_number() == VTABLE_get_number(INTERP, value)); } MULTI INTVAL is_equal(DEFAULT *value) :no_wb { return (INTVAL)(SELF.get_number() == VTABLE_get_number(INTERP, value)); } MULTI INTVAL is_equal_num(Float value) :no_wb { return (INTVAL)(SELF.get_number() == VTABLE_get_number(INTERP, value)); } MULTI INTVAL is_equal_num(DEFAULT value) :no_wb { return (INTVAL)(SELF.get_number() == VTABLE_get_number(INTERP, value)); } /* =item C The C operation. =cut */ MULTI INTVAL cmp(Float value) :no_wb { const FLOATVAL diff = SELF.get_number() - VTABLE_get_number(INTERP, value); return diff > 0 ? 1 : diff < 0 ? -1 : 0; } MULTI INTVAL cmp(DEFAULT value) :no_wb { const FLOATVAL diff = SELF.get_number() - VTABLE_get_number(INTERP, value); return diff > 0 ? 1 : diff < 0 ? -1 : 0; } /* =item C Returns the result of comparing the number with C<*value>. =cut */ MULTI INTVAL cmp_num(Float value) :no_wb { const FLOATVAL diff = SELF.get_number() - VTABLE_get_number(INTERP, value); return diff > 0 ? 1 : diff < 0 ? -1 : 0; } MULTI INTVAL cmp_num(DEFAULT value) :no_wb { /* fix an apparent gcc 4.4.x and 4.5.x bug that manifests itself when * using g++ and an optimized build. See TT #1978. */ volatile FLOATVAL n1 = SELF.get_number(); volatile FLOATVAL n2 = VTABLE_get_number(INTERP, value); const FLOATVAL diff = n1 - n2; return diff > 0 ? 1 : diff < 0 ? -1 : 0; } /* =item C Increments the number. =cut */ VTABLE void increment() { FLOATVAL fv; GET_ATTR_fv(INTERP, SELF, fv); ++fv; SET_ATTR_fv(INTERP, SELF, fv); } /* =item C Decrements the number. =cut */ VTABLE void decrement() { FLOATVAL fv; GET_ATTR_fv(INTERP, SELF, fv); --fv; SET_ATTR_fv(INTERP, SELF, fv); } /* =item C =item C Sets C to the absolute value of SELF. =cut */ VTABLE PMC *absolute(PMC *dest) :no_wb { const FLOATVAL a = fabs(SELF.get_number()); dest = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); VTABLE_set_number_native(INTERP, dest, a); return dest; } VTABLE void i_absolute() :manual_wb { const FLOATVAL a = fabs(SELF.get_number()); VTABLE_set_number_native(INTERP, SELF, a); } /* =item C Used to archive the number. =cut */ VTABLE void freeze(PMC *info) :no_wb { SUPER(info); VTABLE_push_float(INTERP, info, SELF.get_number()); } /* =item C Used to unarchive the number. =cut */ VTABLE void thaw(PMC *info) { SUPER(info); SET_ATTR_fv(INTERP, SELF, VTABLE_shift_float(INTERP, info)); } /* =back =head2 Methods =over 4 =item C Calculate and return the inverse cosine (a.k.a C) of the input argument. =item C Calculate and return the inverse cotangent (a.k.a. C) of the input argument. =item C Calculate and return the inverse secant (a.k.a. C) of the input argument. =item C Calculate and return the inverse sine (a.k.a. C) of the input argument. =item C Calculate and return the inverse tangent (a.k.a. C) of the input argument. =item C Calculate and return the two argument inverse tangent (a.k.a. C) of the input argument. =item C Calculate and return the cosine of the input argument. =item C Calculate and return the hyperbolic cosine of the input argument. =item C Calculate and return the cotangent of the input argument. =item C Calculate and return the hyperbolic cotangent of the input argument. =item C Calculate and return the cosecant of the input argument. =item C Calculate and return the exponential of the input argument. =item C Calculate and return the natural log (logarithm with base C) of the input argument. =item C Calculate and return the base 10 logarithm of the input argument. =item C Calculate and return the base 2 logarithm of the input argument. =item C Calculate and return the secant of the input argument. =item C Calculate and return the hyperbolic secant of the input argument. =item C Calculate and return the sine of the input argument. =item C Calculate and return the hyperbolic sine of the input argument. =item C Calculate and return the tangent of the input argument. =item C Calculate and return the hyperbolic tangent of the input argument. =item C Calculate and return the square root of the input argument. =cut */ METHOD acos() :no_wb { PMC * const d = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); SET_ATTR_fv(INTERP, d, acos(SELF.get_number())); RETURN(PMC *d); } METHOD acot() :no_wb { PMC * const d = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); SET_ATTR_fv(INTERP, d, atan(1.0 / SELF.get_number())); RETURN(PMC *d); } METHOD asec() :no_wb { PMC * const d = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); SET_ATTR_fv(INTERP, d, acos(1.0 / SELF.get_number())); RETURN(PMC *d); } METHOD asin() :no_wb { PMC * const d = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); SET_ATTR_fv(INTERP, d, asin(SELF.get_number())); RETURN(PMC *d); } METHOD atan() :no_wb { PMC * const d = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); SET_ATTR_fv(INTERP, d, atan(SELF.get_number())); RETURN(PMC *d); } METHOD atan2(PMC *val) :no_wb { PMC * const d = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); SET_ATTR_fv(INTERP, d, atan2(SELF.get_number(), VTABLE_get_number(INTERP, val))); RETURN(PMC *d); } METHOD cos() :no_wb { PMC * const d = Parrot_pmc_new(INTERP, Parrot_hll_get_ctx_HLL_type(INTERP, enum_class_Float)); SET_ATTR_fv(INTERP, d, cos(SELF.get_number())); RETURN(PMC *d); } METHOD cosh() :no_wb { PMC * const d = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); SET_ATTR_fv(INTERP, d, cosh(SELF.get_number())); RETURN(PMC *d); } METHOD cot() :no_wb { PMC * const d = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); SET_ATTR_fv(INTERP, d, 1.0 / tan(SELF.get_number())); RETURN(PMC *d); } METHOD coth() :no_wb { PMC * const d = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); SET_ATTR_fv(INTERP, d, 1.0 / tanh(SELF.get_number())); RETURN(PMC *d); } METHOD csc() :no_wb { PMC * const d = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); SET_ATTR_fv(INTERP, d, 1.0 / sin(SELF.get_number())); RETURN(PMC *d); } METHOD exp() :no_wb { PMC * const d = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); SET_ATTR_fv(INTERP, d, exp(SELF.get_number())); RETURN(PMC *d); } METHOD ln() :no_wb { PMC * const d = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); SET_ATTR_fv(INTERP, d, log(SELF.get_number())); RETURN(PMC *d); } METHOD log10() :no_wb { PMC * const d = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); SET_ATTR_fv(INTERP, d, log10(SELF.get_number())); RETURN(PMC *d); } METHOD log2() :no_wb { PMC * const d = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); SET_ATTR_fv(INTERP, d, log(SELF.get_number()) / log(2.0)); RETURN(PMC *d); } METHOD sec() :no_wb { PMC * const d = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); SET_ATTR_fv(INTERP, d, 1.0 / cos(SELF.get_number())); RETURN(PMC *d); } METHOD sech() :no_wb { PMC * const d = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); SET_ATTR_fv(INTERP, d, 1.0 / cosh(SELF.get_number())); RETURN(PMC *d); } METHOD sin() :no_wb { PMC * const d = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); SET_ATTR_fv(INTERP, d, sin(SELF.get_number())); RETURN(PMC *d); } METHOD sinh() :no_wb { PMC * const d = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); SET_ATTR_fv(INTERP, d, sinh(SELF.get_number())); RETURN(PMC *d); } METHOD tan() :no_wb { PMC * const d = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); SET_ATTR_fv(INTERP, d, tan(SELF.get_number())); RETURN(PMC *d); } METHOD tanh() :no_wb { PMC * const d = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); SET_ATTR_fv(INTERP, d, tanh(SELF.get_number())); RETURN(PMC *d); } METHOD sqrt() :no_wb { PMC * const d = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); SET_ATTR_fv(INTERP, d, sqrt(SELF.get_number())); RETURN(PMC *d); } } /* =back =cut */ /* * Local variables: * c-file-style: "parrot" * End: * vim: expandtab shiftwidth=4 cinoptions='\:2=2' : */ foo-02.t000644000765000765 54312101554067 14375 0ustar00bruce000000000000parrot-6.6.0/t/dynpmc#!./parrot # Copyright (C) 2011, Parrot Foundation. .sub main :main .include 'test_more.pir' plan(1) loadlib $P1, 'foo_group' sweep 1 $P2 = getprop $P1, '_type' $S0 = $P2 is($S0, 'PMC', 'ParrotLibrary props survive GC') .end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: fixedintegerarray.pmc000644000765000765 3451312356767111 17310 0ustar00bruce000000000000parrot-6.6.0/src/pmc/* Copyright (C) 2001-2014, Parrot Foundation. =head1 NAME src/pmc/fixedintegerarray.pmc - FixedIntegerArray PMC =head1 DESCRIPTION Fixed size array for integers only. This class, FixedIntegerArray, implements an array of fixed size which stores INTVALs. It uses Integer PMCs for all of the conversions. =cut */ /* HEADERIZER HFILE: none */ /* HEADERIZER BEGIN: static */ /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */ PARROT_PURE_FUNCTION static int auxcmpfunc(ARGIN(const INTVAL *i), ARGIN(const INTVAL *j)) __attribute__nonnull__(1) __attribute__nonnull__(2); #define ASSERT_ARGS_auxcmpfunc __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(i) \ , PARROT_ASSERT_ARG(j)) /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */ /* HEADERIZER END: static */ pmclass FixedIntegerArray auto_attrs provides array { ATTR INTVAL size; /* number of INTVALs stored in this array */ ATTR INTVAL * int_array; /* INTVALs are stored here */ /* =head2 Vtable functions =over 4 =item C Initializes the array. =cut */ VTABLE void init() { PObj_custom_destroy_SET(SELF); } /* =item C Initializes the array. =cut */ VTABLE void init_int(INTVAL size) { if (size < 0) Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_OUT_OF_BOUNDS, _("FixedIntegerArray: Cannot set array size to a negative number (%d)"), size); if (size > 0) { SET_ATTR_size(INTERP, SELF, size); SET_ATTR_int_array(INTERP, SELF, mem_gc_allocate_n_typed(INTERP, size, INTVAL)); } PObj_custom_destroy_SET(SELF); } /* =item C Destroys the array. =cut */ VTABLE void destroy() :no_wb { INTVAL* int_array; GET_ATTR_int_array(INTERP, SELF, int_array); if (int_array) Parrot_gc_free_memory_chunk(INTERP, int_array); } /* =item C Creates and returns a copy of the array. =cut */ VTABLE PMC *clone() :no_wb { /* a quick hack to create a clone in the constant PMC arena * this is needed for the call signatures * * a better way would be probably to supply a flag to the clone * vtable */ INTVAL * int_array; PMC * const dest = Parrot_pmc_new(INTERP, SELF->vtable->base_type); GET_ATTR_int_array(INTERP, SELF, int_array); if (int_array) { INTVAL size; GET_ATTR_size(INTERP, SELF, size); { INTVAL * const dest_int_array = mem_gc_allocate_n_typed(INTERP, size, INTVAL); mem_copy_n_typed(dest_int_array, int_array, size, INTVAL); SET_ATTR_int_array(INTERP, dest, dest_int_array); } SET_ATTR_size(INTERP, dest, size); PObj_custom_destroy_SET(dest); } RETURN(PMC *dest); } /* =item C Returns whether the array has any elements (meaning been initialized, for a fixed sized array). =cut */ VTABLE INTVAL get_bool() :no_wb { INTVAL size; GET_ATTR_size(INTERP, SELF, size); return (INTVAL)(size != 0); } /* =item C =cut */ VTABLE INTVAL elements() :no_wb { INTVAL size; GET_ATTR_size(INTERP, SELF, size); return size; } /* =item C Returns the number of elements in the array. =cut */ VTABLE INTVAL get_integer() :no_wb { INTVAL size; /* Big L1 instr fetch miss */ GET_ATTR_size(INTERP, SELF, size); return size; } /* =item C Returns the integer value of the element at index C. =cut */ VTABLE INTVAL get_integer_keyed_int(INTVAL key) :no_wb { INTVAL *int_array; INTVAL size; GET_ATTR_size(INTERP, SELF, size); if (key < 0 || key >= size) Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_OUT_OF_BOUNDS, "FixedIntegerArray: index out of bounds!"); GET_ATTR_int_array(INTERP, SELF, int_array); return int_array[key]; } /* =item C Returns the integer value of the element at index C<*key>. =cut */ VTABLE INTVAL get_integer_keyed(PMC *key) :no_wb { /* simple int keys only */ const INTVAL k = VTABLE_get_integer(INTERP, key); return SELF.get_integer_keyed_int(k); } /* =item C Returns the floating-point value of the element at index C. =cut */ VTABLE FLOATVAL get_number_keyed_int(INTVAL key) :no_wb { const INTVAL i = SELF.get_integer_keyed_int(key); return (FLOATVAL)i; } /* =item C Returns the floating-point value of the element at index C<*key>. =cut */ VTABLE FLOATVAL get_number_keyed(PMC *key) :no_wb { const INTVAL k = VTABLE_get_integer(INTERP, key); return SELF.get_number_keyed_int(k); } /* =item C Returns the Parrot string value of the element at index C. =cut */ VTABLE STRING *get_string_keyed_int(INTVAL key) :no_wb { PMC * const temp = SELF.get_pmc_keyed_int(key); STRING *result = VTABLE_get_string(INTERP, temp); RETURN(STRING *result); } /* =item C =item C Returns the Parrot string representation C. =cut */ VTABLE STRING *get_string() :no_wb { return STATICSELF.get_repr(); } VTABLE STRING *get_repr() :no_wb { STRING *res = CONST_STRING(INTERP, "[ "); INTVAL n; INTVAL j; GET_ATTR_size(INTERP, SELF, n); for (j = 0; j < n; ++j) { PMC * const val = SELF.get_pmc_keyed_int(j); res = Parrot_str_concat(INTERP, res, VTABLE_get_repr(INTERP, val)); if (j < n - 1) res = Parrot_str_concat(INTERP, res, CONST_STRING(INTERP, ", ")); } return Parrot_str_concat(INTERP, res, CONST_STRING(INTERP, " ]")); } /* =item C Get a hashvalue for this PMC. Providing a non-default C implementation avoids creating unecessary string temporaries. =cut */ VTABLE INTVAL hashvalue() :no_wb { INTVAL *int_array; INTVAL size; GET_ATTR_int_array(INTERP, SELF, int_array); GET_ATTR_size(INTERP, SELF, size); return Parrot_hash_buffer((const unsigned char *)int_array, size * sizeof (INTVAL), INTERP->hash_seed); } /* =item C Returns the Parrot string value of the element at index C<*key>. =cut */ VTABLE STRING *get_string_keyed(PMC *key) :no_wb { const INTVAL k = VTABLE_get_integer(INTERP, key); return SELF.get_string_keyed_int(k); } /* =item C Returns the PMC value of the element at index C. =cut */ VTABLE PMC *get_pmc_keyed_int(INTVAL key) :no_wb { const INTVAL val = SELF.get_integer_keyed_int(key); return Parrot_pmc_new_init_int(INTERP, enum_class_Integer, val); } /* =item C Returns the PMC value of the element at index C<*key>. =cut */ VTABLE PMC *get_pmc_keyed(PMC *key) :no_wb { const INTVAL k = VTABLE_get_integer(INTERP, key); return SELF.get_pmc_keyed_int(k); } /* =item C Resizes the array to C elements. =cut */ VTABLE void set_integer_native(INTVAL size) { INTVAL *int_array; INTVAL cur_size; GET_ATTR_size(INTERP, SELF, cur_size); if (cur_size || size < 1) Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_OUT_OF_BOUNDS, "FixedIntegerArray: Can't resize!"); SET_ATTR_size(INTERP, SELF, size); GET_ATTR_int_array(INTERP, SELF, int_array); SET_ATTR_int_array(INTERP, SELF, mem_gc_realloc_n_typed(INTERP, int_array, size, INTVAL)); PObj_custom_destroy_SET(SELF); } /* =item C Sets the integer value of the element at index C to C. =cut */ VTABLE void set_integer_keyed_int(INTVAL key, INTVAL value) { INTVAL *int_array; INTVAL size; GET_ATTR_size(INTERP, SELF, size); if (key < 0 || key >= size) Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_OUT_OF_BOUNDS, "FixedIntegerArray: index out of bounds!"); GET_ATTR_int_array(INTERP, SELF, int_array); int_array[key] = value; } /* =item C Sets the integer value of the element at index C to C. =cut */ VTABLE void set_integer_keyed(PMC *key, INTVAL value) :manual_wb { const INTVAL k = VTABLE_get_integer(INTERP, key); SELF.set_integer_keyed_int(k, value); } /* =item C Sets the floating-point value of the element at index C to C. =cut */ VTABLE void set_number_keyed_int(INTVAL key, FLOATVAL value) :manual_wb { SELF.set_integer_keyed_int(key, (INTVAL)value); } /* =item C Sets the floating-point value of the element at index C to C. =cut */ VTABLE void set_number_keyed(PMC *key, FLOATVAL value) :manual_wb { const INTVAL k = VTABLE_get_integer(INTERP, key); SELF.set_number_keyed_int(k, value); } /* =item C Sets the Parrot string value of the element at index C to C. =cut */ VTABLE void set_string_keyed_int(INTVAL key, STRING *value) :manual_wb { const INTVAL tempInt = Parrot_str_to_int(INTERP, value); SELF.set_integer_keyed_int(key, tempInt); } /* =item C Sets the string value of the element at index C to C. =cut */ VTABLE void set_string_keyed(PMC *key, STRING *value) :manual_wb { const INTVAL k = VTABLE_get_integer(INTERP, key); SELF.set_string_keyed_int(k, value); } /* =item C Sets the PMC value of the element at index C to C<*src>. =cut */ VTABLE void set_pmc_keyed_int(INTVAL key, PMC *src) :manual_wb { const INTVAL tempInt = VTABLE_get_integer(INTERP, src); SELF.set_integer_keyed_int(key, tempInt); } /* =item C Sets the string value of the element at index C to C. =cut */ VTABLE void set_pmc_keyed(PMC *key, PMC *value) :manual_wb { const INTVAL k = VTABLE_get_integer(INTERP, key); SELF.set_pmc_keyed_int(k, value); } /* =item C The C<==> operation. Compares two array to hold equal elements. =cut */ VTABLE INTVAL is_equal(PMC *value) :no_wb { INTVAL j, n; if (value->vtable->base_type != SELF->vtable->base_type) return 0; n = SELF.elements(); if (VTABLE_elements(INTERP, value) != n) return 0; for (j = 0; j < n; ++j) { const INTVAL item1 = SELF.get_integer_keyed_int(j); const INTVAL item2 = VTABLE_get_integer_keyed_int(INTERP, value, j); if (item1 != item2) return 0; } return 1; } /* =item C Return a new Iterator for this PMC. =cut */ VTABLE PMC *get_iter() :no_wb { return Parrot_pmc_new_init(INTERP, enum_class_ArrayIterator, SELF); } /* =item C Used to archive the array. =item C Used to unarchive the array. C<*info> is the visit info, (see F). =cut */ VTABLE void freeze(PMC *info) :no_wb { INTVAL *int_array; INTVAL i, n; SUPER(info); GET_ATTR_size(INTERP, SELF, n); VTABLE_push_integer(INTERP, info, n); GET_ATTR_int_array(INTERP, SELF, int_array); for (i = 0; i < n; ++i) VTABLE_push_integer(INTERP, info, int_array[i]); } VTABLE void thaw(PMC *info) { const INTVAL n = VTABLE_shift_integer(INTERP, info); SELF.init_int(n); if (n > 0) { INTVAL i; INTVAL *int_array; GET_ATTR_int_array(INTERP, SELF, int_array); for (i = 0; i < n; ++i) int_array[i] = VTABLE_shift_integer(INTERP, info); } } /* =back =head2 Methods =over 4 =item C Sort the array and return self. =cut */ METHOD sort(PMC *cmp_func :optional) { UINTVAL n; INTVAL size; GET_ATTR_size(INTERP, SELF, size); n = (UINTVAL)size; if (n > 1) { INTVAL *int_array; GET_ATTR_int_array(INTERP, SELF, int_array); if (PMC_IS_NULL(cmp_func)) qsort(int_array, n, sizeof (INTVAL), (int (*)(const void *, const void*))auxcmpfunc); else Parrot_util_quicksort(INTERP, (void**)int_array, n, cmp_func, "II->I"); } RETURN(PMC *SELF); } /* =item C Reverse the contents of the array. =cut */ METHOD reverse() { INTVAL n; GET_ATTR_size(INTERP, SELF, n); if (n > 1) { INTVAL val; INTVAL *data; INTVAL i; GET_ATTR_int_array(INTERP, SELF, data); for (i = 0; i <= --n; i++) { val = data[i]; data[i] = data[n]; data[n] = val; } } } } /* =back =head2 Auxiliary functions =over 4 =item C INTVAL compare function for qsort usage. =cut */ PARROT_PURE_FUNCTION static int auxcmpfunc(ARGIN(const INTVAL *i), ARGIN(const INTVAL *j)) { ASSERT_ARGS(auxcmpfunc) return *i - *j; } /* =back =head1 SEE ALSO F. =cut */ /* * Local variables: * c-file-style: "parrot" * End: * vim: expandtab shiftwidth=4 cinoptions='\:2=2' : */ ticket_triaging.pod000644000765000765 2543111715102032 17754 0ustar00bruce000000000000parrot-6.6.0/docs/project# Copyright (C) 2001-2009, Parrot Foundation. =pod =head1 NAME docs/project/ticket_triaging.pod - Managing Tickets =head1 DESCRIPTION This document attempts to outline a set of best practices for dealing with tickets in Parrot's tracking system. It is targeted at Parrot developers and Ticket Wranglers and is I intended as advice or instruction for end users. Ticket filing procedures for end users are documented in F. =head1 WHAT ABOUT TRAC? Our preferred method of bug tracking at this point is github issues: L All Parrot developers are expected to pitch in and help keep the ticket tracker in a healthy state. I Most of the document below still makes sense in terms of activities in trac, but the specifics are of course different with the new system. Our previous bug tracking system was trac, hosted at L. In January 2012 the trac tickets have been migrated to github issues. The bug tracking system before trac was RT. In November 2009 all remaining RT tickets were closed, with many being reopened in Trac. No new issues should be opened in RT, but the old system is available at L. The Parrot issues are in the queue I. =head1 TICKET HANDLING PROCEDURES =head2 New Tickets Where I refers to a pre-existing ticket sitting in the Parrot queue with a status of C. =head3 Bug Triage Involves deciding whether the ticket is a real bug, a feature request, a duplicate, or spam. It is especially important to check that all C bugs which are marked [TODO], [PATCH], or [CAGE] really are bugs of the given class. This is because some bugs, such as [TODO] and [CAGE], get their status set to C to indicate that something should be done, rather than that someone is doing something. =over 4 =item Is this spam? Assign the issue to the queue I. Note that if this is successful, you will no longer have permissions to view the ticket. =item Is this a duplication of an existing ticket? Under the Action section, chose the "resolve as" option and select "duplicate" from the dropdown. Add a comment to the ticket along the lines of "Duplicate of Ticket #123". =item Is there enough information? If not, ask for more input. =item Is it a [TODO] ticket? Is the subject line in the format C<"[TODO] subsystem - issue>? Change the status of C<[TODO]> tickets to C to prevent them from appearing in a listing of C tickets. =item Is it a [PATCH] ticket? Is the subject line in the format C<"[PATCH] subsystem - issue>? Make sure that there is actually a patch attached to the ticket. If you've applied a patch, be sure to include the revision in your response when closing the ticket. =item * Is it a [CAGE] bug? Is the subject line in the format C<"[CAGE] subsystem - issue>? C<[CAGE]> bugs should have their status changed to C to prevent them from appearing in a listing of C bugs. =item * Assign the bug to someone if at all possible. =back =head2 TODO Tickets =over 4 =item Claim ownership or interest ( CC ) of the ticket. This way you will receive further correspondence about the ticket. =item Run the test suite =item make manitest =item add the patch author to F or update the author's entry =item add correspondence to the ticket stating that the patch was applied. Include the commit SHA1 in your response. =item make sure that the ticket's 'Tag' includes 'Patch' =item set the ticket's 'Patch status' to 'Applied' =item set the ticket's 'resolve as' to 'resolved' =back =head2 Old Tickets If the ticket is more then I<1 month> old, then it's I. =over 4 =item Ping the requestor Give the requestor at least I<1 week> to respond. If you receive no response, add a comment to the ticket saying that it is stalled because of no response from the requestor. Change the status to C. If it's a [PATCH] ticket, it's possible that the patch was applied but the ticket/patch status was never changed. Also, not all list traffic regarding a ticket ends up in the tracker. Look at the git repo to attempt to determine if the ticket was resolved. =item Review of stalled tickets Sometimes tickets are C because there's no hope if fixing them soon. Sometimes, no response is available from the requestor, or no one can verify the report. Review these tickets periodically. When possible, change their status to C or C as appropriate. =back =head3 Necessary Information As alluded to earlier, tickets are much easier to resolve when they include sufficient information. For bugs, this is: =over 4 =item Specific error messages. These can come from Parrot or the operating system. Copied and pasted messages are best; the exact wording is often important. =item Platform details. These include operating system and version, compiler information, processor architecture, and versions of included libraries. The file F may be useful. =item Steps to reproduce. At what point did you see the failure? Can you reproduce it? Do you have a small PIR program which demonstrates the problem? =item Failure diagnostics. Verbose diagnostics from C -- including all error messages and diagnostics -- are often necessary to resolve test failures. =item Backtraces. Segfaults and other crashes within Parrot are much easier to resolve given a backtrace on a Parrot built with debugging symbols. =back [PATCH] tickets for code almost always need tests and often need documentation. Feel free to ask the submitter to work on both, or to contact another committer for help in identifying and creating the appropriate tests and documentation. =head3 Severity Guidelines Occasionally the severity of a problem may govern how volunteers direct their resources to resolving tickets. Here are several criteria by which to determine the severity of a report. =over =item Is there an exploitable security problem? Can a malicious user destroy data, access sensitive information, or obtain undesired permissions to the rest of the system? If so, this is a high priority ticket. =item Is there a crash from a pure-PIR program? Users should never be able to crash Parrot writing normal PIR code. Such problems need high priority tickets. =item Does the defect prevent a successful configuration, build, or installation of Parrot? If Parrot cannot build, install, or run, the ticket has a high priority. =item Does the defect cause test failures on a core platform? All tests should pass on all core platforms in all releases of Parrot (as well as on trunk). Test failures, with the appropriate diagnostic information, are moderate priority. =item Is the defect reproducable in the current development version? Reproducable defects have a normal priority. Unreproducable tickets have a lower priority. =item Does the defect affect a core platform? Defects affecting non-core platforms have a lower priority (which reflects that we probably lack the expertise to deal with that platform). =item Is there a test case suitable for the test suite? A defect reported with a patch to the test suite (or a test case easily added to the test suite) may have a higher priority; it's much easier to diagnose and fix such problems. =back =head1 TIPS FOR CORRESPONDENCE =head2 Be Nice Remember that every word you type into the ticket tracker is I. Try not to say anything that could offend or hurt the feelings of I. That includes the ticket submitter and other developers. When, as a Parrot developer with commit rights, you send correspondence you are representing the Parrot project and, by proxy, The Parrot Foundation. If in doubt, either send the message privately or not at all. =head2 Say thank you! Try to add a little token of appreciation to every message you send in response to a ticket. Ticket requestors are doing labor for free! The least you can do is let them know that you appreciate their efforts. Something like: Thanks, Thanks for following up. Thanks for reporting. Thanks for X! ... can work wonders. If you can make someone feel good about themselves maybe they'll submit another ticket/patch/whatever or perhaps some day become a Parrot developer. =head2 Make it clear why the ticket status has changed Always note why you're changing a ticket's status, particularly if you're closing or rejecting it. Nothing will irritate people more then letting them think that their ticket was unimportant or ignored. =head2 Example Correspondence Hi, Can you retest for this ticket with the latest sources from git and confirm that this still an open issue? Thanks, -J or Hi, Would you mind retesting with the latest sources from git? Thanks, -J or Hi, Can you resubmit this patch against git master? Thanks, -J or Patch applied as rXXX. Thanks for submitting. -J or No response for requestor. Ticket being marked as 'rejected'. Thanks for reporting. -J or This doesn't appear to be an issue anymore. Thanks for submitting. -J or Marking this ticket as 'resolved' because it seems to have fixed itself. Thanks for following up. -J =head1 TIPS FOR WRITING COMMIT MESSAGES =over 4 =item Put a subsystem identifier out the front [json]: commit message =item If related to a Trac ticket, use the ticket number [json]: Resolve #731 =item Add a "Courtesy of " if supplied by someone else Courtesy of A. U. Thor =item Detailed commit messages are preferred Make it clear what your intent is when committing. It makes future maintenance much easier. [PGE]: * Switched "PGE::Regex" to be "PGE::Grammar", to be more accurate. * Moved default rules from PGE::Regex into PGE::Match. * Updated various languages and tools to match. =item Commit file names You don't need to include the filename in the commit message as that's part of the commit itself. However, if your commit affects multiple directories, you may mention that, especially if it's part of a group of commits. [PDD07]: whitespace -- part 5 ~ removed trailing spaces and tabs from t/exit/, t/dynpmc/, t/dynoplibs/ =item Group similar commits by parts If all commits are much the same and require basically the same commit message, it can be useful to number the commit messages. For example: [tools]: smartlink functionality -- part 3 ~ added regex attribute to Keyphrase class ~ filled in some more SmartLinkServer attribute init code ~ expanded LinkTree class functionality still TODO: merge smartlink and spec info, emit html, improve cmdline option code You may optionally include items that are still todo, as it helps make your intentions clear. =item More ideas Look at past commit messages, and L for more best practices. =back =cut 059-silent.t000644000765000765 556211533177644 15733 0ustar00bruce000000000000parrot-6.6.0/t/configure#! perl # Copyright (C) 2007, Parrot Foundation. # 059-silent.t use strict; use warnings; use Test::More tests => 13; use Carp; use lib qw( lib t/configure/testlib ); use Parrot::Configure; use Parrot::Configure::Options qw( process_options ); use IO::CaptureOutput qw | capture |; $| = 1; is( $|, 1, "output autoflush is set" ); my ($args, $step_list_ref) = process_options( { argv => [ q{--silent} ], mode => q{configure}, } ); ok( defined $args, "process_options returned successfully" ); my %args = %$args; my $conf = Parrot::Configure->new; ok( defined $conf, "Parrot::Configure->new() returned okay" ); my $serialized = $conf->pcfreeze(); my $step = q{init::gamma}; my $description = 'Determining if your computer does gamma'; $conf->add_steps($step); my @confsteps = @{ $conf->steps }; isnt( scalar @confsteps, 0, "Parrot::Configure object 'steps' key holds non-empty array reference" ); is( scalar @confsteps, 1, "Parrot::Configure object 'steps' key holds ref to 1-element array" ); my $nontaskcount = 0; foreach my $k (@confsteps) { $nontaskcount++ unless $k->isa("Parrot::Configure::Task"); } is( $nontaskcount, 0, "Each step is a Parrot::Configure::Task object" ); is( $confsteps[0]->step, $step, "'step' element of Parrot::Configure::Task struct identified" ); ok( !ref( $confsteps[0]->object ), "'object' element of Parrot::Configure::Task struct is not yet a ref" ); $conf->options->set(%args); is( $conf->options->{c}->{debugging}, 1, "command-line option '--debugging' has been stored in object" ); my $rv; my ($stdout, $stderr); capture ( sub { eval { $rv = $conf->runsteps; } }, \$stdout, \$stderr); ok(! $stdout, "silent option worked"); like( $stderr, qr/step $step died during execution: Dying gamma just to see what happens/, "Got expected error message despite silent option"); $conf->replenish($serialized); ##### --silent option; valid step ##### ($args, $step_list_ref) = process_options( { argv => [ q{--silent} ], mode => q{configure}, } ); %args = %$args; $step = q{init::lambda}; $conf->add_steps($step); $conf->options->set(%args); { my $rv; my ($stdout); capture ( sub { eval { $rv = $conf->runsteps; } }, \$stdout); ok(! $stdout, "silent option worked"); } pass("Completed all tests in $0"); ################### DOCUMENTATION ################### =head1 NAME 059-silent.t - test what happens when the C<--silent> option is set =head1 SYNOPSIS % prove t/configure/059-silent.t =head1 DESCRIPTION The files in this directory test functionality used by F. The tests in this file examine various cases occurring while using the C<--silent> option. =head1 AUTHOR James E Keenan =head1 SEE ALSO Parrot::Configure, F. =cut # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: .travis.yml000644000765000765 565012312075407 13606 0ustar00bruce000000000000parrot-6.6.0language: "perl" perl: # - "5.10" - "5.14" install: "echo" before_script: - sudo apt-get install libffi-dev libicu-dev libgmp3-dev clang llvm-dev zlib1g-dev gcc-multilib # No, we are not going to run the tests for all these dependencies on every commit - cpanm -n LWP::UserAgent TAP::Harness::Archive TAP::Harness::ReportByDescription Test::Perl::Critic - gcc --version - g++ --version - clang --version # This stuff used to be required, but was rolled into the Travis CI perl support. # - curl -L http://cpanmin.us | sudo perl - --self-upgrade # - export CI_USER=$USER # - mkdir ~/perl5 && perl -Mlocal::lib >> /tmp/local_lib_junk.sh && source /tmp/local_lib_junk.sh # - sudo chown -R $CI_USER ~/.cpanm # - sudo chown -R $CI_USER ~/perl5 # Don't run Configure.pl tests, for now #script: "perl Configure.pl --test=build $PARROT_CONFIG_ARGS $PARROT_OPTIMIZE --cc=\"$CC\" --link=\"$CC\" --ld=\"$CC\" --ccflags='-g' ; make $PARROT_TEST" script: "perl Configure.pl $PARROT_CONFIG_ARGS $PARROT_OPTIMIZE --cc=\"$CC\" --link=\"$CC\" --ld=\"$CC\"; make $PARROT_TEST" branches: only: - master - /smoke-me/ notifications: recipients: - parrot-ci@lists.parrot.org email: on_success: change on_failure: always irc: "irc.parrot.org#parrot" env: matrix: # use --optimize for most since it's stable and runs fastest - PARROT_CONFIG_ARGS="" PARROT_OPTIMIZE="--optimize" PARROT_TEST="smoke" CC="clang" - PARROT_CONFIG_ARGS="--without-gettext --without-gmp --without-libffi --without-extra-nci-thunks --without-opengl --without-readline --without-pcre --without-zlib --without-threads --without-icu" PARROT_OPTIMIZE="" PARROT_TEST="smoke" CC="clang" - PARROT_CONFIG_ARGS="" PARROT_OPTIMIZE="--optimize" PARROT_TEST="smoke" CC="gcc" - PARROT_CONFIG_ARGS="--without-gettext --without-gmp --without-libffi --without-extra-nci-thunks --without-opengl --without-readline --without-pcre --without-zlib --without-threads --without-icu" PARROT_OPTIMIZE="" PARROT_TEST="smoke" CC="gcc" - PARROT_CONFIG_ARGS="" PARROT_OPTIMIZE="--optimize" PARROT_TEST="smoke" CC="g++" - PARROT_CONFIG_ARGS="" PARROT_OPTIMIZE="--optimize" PARROT_TEST="testO2" CC="clang" # Use clang to run our coding standard and manifest tests, because it is the fastest # These will cause Travis to report a build failure when somebody breaks the manifest # tests by forgetting to add files to our manifest, or when they break our coding standards. # The reason we do not use smolder_fulltest is because it will intermittently trigger # the Travis CI time-out of 15 minutes. - PARROT_CONFIG_ARGS="" PARROT_OPTIMIZE="--optimize" PARROT_TEST="codingstd_tests" CC="clang" - PARROT_CONFIG_ARGS="" PARROT_OPTIMIZE="--optimize" PARROT_TEST="manifest_tests" CC="clang" matrix: allow_failures: - env: PARROT_CONFIG_ARGS="" PARROT_OPTIMIZE="--optimize" PARROT_TEST="codingstd_tests" CC="clang" 05-gen_c.t000644000765000765 2252611533177646 16704 0ustar00bruce000000000000parrot-6.6.0/t/tools/pmc2cutils#! perl # Copyright (C) 2006-2007, Parrot Foundation. # 05-gen_c.t use strict; use warnings; BEGIN { use FindBin qw($Bin); use Cwd qw(cwd realpath); realpath($Bin) =~ m{^(.*\/parrot)\/[^/]*\/[^/]*\/[^/]*$}; our $topdir = $1; if ( defined $topdir ) { print "\nOK: Parrot top directory located\n"; } else { $topdir = realpath($Bin) . "/../../.."; } unshift @INC, qq{$topdir/lib}; } use Test::More tests => 52; use Carp; use File::Basename; use File::Copy; use FindBin; use_ok('Parrot::Pmc2c::Pmc2cMain'); use IO::CaptureOutput qw| capture |; use_ok('Cwd'); use_ok( 'File::Temp', qw| tempdir | ); my ( %opt, @include, @args ); my $dump_file; my $self; my $rv; my $cwd = cwd(); my @include_orig = ( qq{$main::topdir}, qq{$main::topdir/src/pmc}, ); my ( $tie, $msg, @lines ); # basic test: @args holds default.pmc { my $tdir = tempdir( CLEANUP => 1 ); ok( chdir $tdir, 'changed to temp directory for testing' ); my $temppmcdir = qq{$tdir/src/pmc}; for ( qq{$tdir/src}, qq{$tdir/include}, qq{$tdir/include/pmc}, $temppmcdir ) { ok( mkdir($_), "created $_ under tempdir" ); } my @pmcfiles = ( "$main::topdir/src/pmc/default.pmc", "$main::topdir/src/pmc/resizablepmcarray.pmc" ); my $pmcfilecount = scalar(@pmcfiles); my $copycount; foreach my $pmcfile (@pmcfiles) { my $basename = basename($pmcfile); my $rv = copy( $pmcfile, qq{$temppmcdir/$basename} ); $copycount++ if $rv; } is( $copycount, $pmcfilecount, "all src/pmc/*.pmc files copied to tempdir" ); my @include = ( $tdir, $temppmcdir, @include_orig ); @args = ( qq{$temppmcdir/default.pmc}, ); $self = Parrot::Pmc2c::Pmc2cMain->new( { include => \@include, opt => \%opt, args => [@args], bin => $Bin, } ); isa_ok( $self, q{Parrot::Pmc2c::Pmc2cMain} ); $dump_file = $self->dump_vtable("$main::topdir/src/vtable.tbl"); ok( -e $dump_file, "dump_vtable created vtable.dump" ); ok( $self->dump_pmc(), "dump_pmc succeeded" ); ok( -f qq{$temppmcdir/default.dump}, "default.dump created as expected" ); $rv = $self->gen_c(); ok( $rv, "gen_c completed successfully; args: default.pmc" ); ok( chdir $cwd, "changed back to original directory" ); } # @args holds default.pmc and one other .pmc { my $tdir = tempdir( CLEANUP => 1 ); ok( chdir $tdir, 'changed to temp directory for testing' ); my $pmcdir = q{src/pmc}; ok( ( mkdir qq{$tdir/src} ), "created src/ under tempdir" ); ok( ( mkdir qq{$tdir/include} ), "created include/ under tempdir" ); ok( ( mkdir qq{$tdir/include/pmc} ), "created include/pmc/ under tempdir" ); my $temppmcdir = qq{$tdir/src/pmc}; ok( ( mkdir $temppmcdir ), "created src/pmc/ under tempdir" ); my @pmcfiles = ( "$main::topdir/src/pmc/default.pmc", "$main::topdir/src/pmc/resizablepmcarray.pmc" ); my $pmcfilecount = scalar(@pmcfiles); my $copycount; foreach my $pmcfile (@pmcfiles) { my $basename = basename($pmcfile); my $rv = copy( $pmcfile, qq{$temppmcdir/$basename} ); $copycount++ if $rv; } is( $copycount, $pmcfilecount, "all src/pmc/*.pmc files copied to tempdir" ); my @include = ( $tdir, $temppmcdir, @include_orig ); @args = ( qq{$temppmcdir/default.pmc}, qq{$temppmcdir/resizablepmcarray.pmc}, ); $self = Parrot::Pmc2c::Pmc2cMain->new( { include => \@include, opt => \%opt, args => [@args], bin => $Bin, } ); isa_ok( $self, q{Parrot::Pmc2c::Pmc2cMain} ); $dump_file = $self->dump_vtable("$main::topdir/src/vtable.tbl"); ok( -e $dump_file, "dump_vtable created vtable.dump" ); #create a dump for default.pmc Parrot::Pmc2c::Pmc2cMain->new( { include => \@include, opt=>\%opt, args=>[qq{$temppmcdir/default.pmc}], bin=>$Bin } )->dump_pmc(); ok( $self->dump_pmc(), "dump_pmc succeeded" ); ok( -f qq{$temppmcdir/default.dump}, "default.dump created as expected" ); ok( -f qq{$temppmcdir/resizablepmcarray.dump}, "resizablepmcarray.dump created as expected" ); $rv = $self->gen_c(); ok( $rv, "gen_c completed successfully; args: default.pmc and resizablepmcarray.pmc" ); ok( chdir $cwd, "changed back to original directory" ); } # failure case: calling gen_c() without first having called dump_pmc() { my $tdir = tempdir( CLEANUP => 1 ); ok( chdir $tdir, 'changed to temp directory for testing' ); my $pmcdir = q{src/pmc}; ok( ( mkdir qq{$tdir/src} ), "created src/ under tempdir" ); ok( ( mkdir qq{$tdir/include} ), "created include/ under tempdir" ); ok( ( mkdir qq{$tdir/include/pmc} ), "created include/pmc/ under tempdir" ); my $temppmcdir = qq{$tdir/src/pmc}; ok( ( mkdir $temppmcdir ), "created src/pmc/ under tempdir" ); my @pmcfiles = ( "$main::topdir/src/pmc/default.pmc", "$main::topdir/src/pmc/resizablepmcarray.pmc" ); my $pmcfilecount = scalar(@pmcfiles); my $copycount; foreach my $pmcfile (@pmcfiles) { my $basename = basename($pmcfile); my $rv = copy( $pmcfile, qq{$temppmcdir/$basename} ); $copycount++ if $rv; } is( $copycount, $pmcfilecount, "src/pmc/*.pmc files copied to tempdir" ); my @include = ( $tdir, $temppmcdir, @include_orig ); @args = ( qq{$temppmcdir/default.pmc}, qq{$temppmcdir/resizablepmcarray.pmc}, ); $self = Parrot::Pmc2c::Pmc2cMain->new( { include => \@include, opt => \%opt, args => [@args], bin => $Bin, } ); isa_ok( $self, q{Parrot::Pmc2c::Pmc2cMain} ); $dump_file = $self->dump_vtable("$main::topdir/src/vtable.tbl"); ok( -e $dump_file, "dump_vtable created vtable.dump" ); ### $self->dump_pmc(); { my $stdout; capture( sub { eval { $rv = $self->gen_c(); } }, \$stdout ); like( $@, qr<^cannot find file '.*/src/pmc/default.dump' in path>, "gen_c() predictably failed because dump_pmc() was not called first" ); } ok( chdir $cwd, "changed back to original directory" ); } # @args holds default.pmc and one class.pmc { my $tdir = tempdir( CLEANUP => 1 ); ok( chdir $tdir, 'changed to temp directory for testing' ); my $pmcdir = q{src/pmc}; ok( ( mkdir qq{$tdir/src} ), "created src/ under tempdir" ); ok( ( mkdir qq{$tdir/include} ), "created include/ under tempdir" ); ok( ( mkdir qq{$tdir/include/pmc} ), "created include/pmc/ under tempdir" ); my $temppmcdir = qq{$tdir/src/pmc}; ok( ( mkdir $temppmcdir ), "created src/pmc/ under tempdir" ); my @pmcfiles = ( "$main::topdir/src/pmc/default.pmc", "$main::topdir/src/pmc/class.pmc" ); my $pmcfilecount = scalar(@pmcfiles); my $copycount; foreach my $pmcfile (@pmcfiles) { my $basename = basename($pmcfile); my $rv = copy( $pmcfile, qq{$temppmcdir/$basename} ); $copycount++ if $rv; } is( $copycount, $pmcfilecount, "all src/pmc/*.pmc files copied to tempdir" ); my @include = ( $tdir, $temppmcdir, @include_orig ); @args = ( qq{$temppmcdir/default.pmc}, qq{$temppmcdir/class.pmc}, ); $self = Parrot::Pmc2c::Pmc2cMain->new( { include => \@include, opt => \%opt, args => [@args], bin => $Bin, } ); isa_ok( $self, q{Parrot::Pmc2c::Pmc2cMain} ); $dump_file = $self->dump_vtable("$main::topdir/src/vtable.tbl"); ok( -e $dump_file, "dump_vtable created vtable.dump" ); #create dumps for dependencies of boolean for my $pmc ( qq{$temppmcdir/default.pmc}, qq{$temppmcdir/class.pmc} ) { Parrot::Pmc2c::Pmc2cMain->new( { include => \@include, opt=>\%opt, args=>[$pmc], bin=>$Bin } )->dump_pmc(); } ok( $self->dump_pmc(), "dump_pmc succeeded" ); ok( -f qq{$temppmcdir/default.dump}, "default.dump created as expected" ); ok( -f qq{$temppmcdir/class.dump}, "class.dump created as expected" ); $rv = $self->gen_c(); ok( $rv, "gen_c completed successfully; args: default.pmc and class.pmc" ); ok( chdir $cwd, "changed back to original directory" ); } pass("Completed all tests in $0"); ################### DOCUMENTATION ################### =head1 NAME 05-gen_c.t - test C =head1 SYNOPSIS % prove t/tools/pmc2cutils/05-gen_c.t =head1 DESCRIPTION The files in this directory test the publicly callable methods of F. By doing so, they test the functionality of the F utility. That functionality has largely been extracted into the methods of F. F<05-gen_c.t> tests the C method. F calls this method when it calls in C. So as not to pollute the Parrot build directories with files created during the testing process, all functions which create or modify files should be called within a temporary directory. =head1 AUTHOR James E Keenan =head1 SEE ALSO Parrot::Pmc2c, F. =cut # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: parser_util.c000644000765000765 4436112307662657 17141 0ustar00bruce000000000000parrot-6.6.0/compilers/imcc/* * parser_util.c * * Intermediate Code Compiler for Parrot. * * Copyright (C) 2002 Melvin Smith * Copyright (C) 2002-2014, Parrot Foundation. * * parser support functions * * */ #include #include #include #define _PARSER #include "imc.h" #include "parrot/dynext.h" #include "pmc/pmc_sub.h" #include "pmc/pmc_callcontext.h" #include "pbc.h" #include "parser.h" #include "optimizer.h" /* =head1 NAME compilers/imcc/parser_util.c =head1 DESCRIPTION ParserUtil - Parser support functions. =cut */ /* HEADERIZER HFILE: compilers/imcc/imc.h */ /* HEADERIZER BEGIN: static */ /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */ PARROT_WARN_UNUSED_RESULT static int change_op_arg_to_num( ARGMOD(imc_info_t * imcc), ARGMOD(IMC_Unit *unit), ARGMOD(SymReg **r), int num, int emit) __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__nonnull__(3) FUNC_MODIFIES(* imcc) FUNC_MODIFIES(*unit) FUNC_MODIFIES(*r); PARROT_WARN_UNUSED_RESULT PARROT_CAN_RETURN_NULL static op_info_t * try_find_op( ARGMOD(imc_info_t * imcc), ARGMOD(IMC_Unit *unit), ARGIN(const char *name), ARGMOD(SymReg **r), int n, int keyvec, int emit) __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__nonnull__(3) __attribute__nonnull__(4) FUNC_MODIFIES(* imcc) FUNC_MODIFIES(*unit) FUNC_MODIFIES(*r); PARROT_WARN_UNUSED_RESULT PARROT_CAN_RETURN_NULL static const char * try_rev_cmp(ARGIN(const char *name), ARGMOD(SymReg **r)) __attribute__nonnull__(1) __attribute__nonnull__(2) FUNC_MODIFIES(*r); PARROT_MALLOC PARROT_CANNOT_RETURN_NULL PARROT_WARN_UNUSED_RESULT static Instruction * var_arg_ins( ARGMOD(imc_info_t * imcc), ARGMOD(IMC_Unit *unit), ARGIN(const char *name), ARGMOD(SymReg **r), int n, int emit) __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__nonnull__(3) __attribute__nonnull__(4) FUNC_MODIFIES(* imcc) FUNC_MODIFIES(*unit) FUNC_MODIFIES(*r); #define ASSERT_ARGS_change_op_arg_to_num __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(imcc) \ , PARROT_ASSERT_ARG(unit) \ , PARROT_ASSERT_ARG(r)) #define ASSERT_ARGS_try_find_op __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(imcc) \ , PARROT_ASSERT_ARG(unit) \ , PARROT_ASSERT_ARG(name) \ , PARROT_ASSERT_ARG(r)) #define ASSERT_ARGS_try_rev_cmp __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(name) \ , PARROT_ASSERT_ARG(r)) #define ASSERT_ARGS_var_arg_ins __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(imcc) \ , PARROT_ASSERT_ARG(unit) \ , PARROT_ASSERT_ARG(name) \ , PARROT_ASSERT_ARG(r)) /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */ /* HEADERIZER END: static */ /* * used in -D20 to print files with the output of every PIR compilation * this can't be attached to the imcc->interpreter or packfile because it has to be * absolutely global to prevent the files from being overwritten. * */ /* =head2 Functions =over =item C Lookup the full opcode given the short name set I0, 5 -> set_i_ic set I0, I1 -> set_i_i Obviously the registers must be examined before returning the correct opcode. =cut */ void op_fullname(ARGOUT(char *dest), ARGIN(const char *name), ARGIN(SymReg * const *args), int narg, int keyvec) { ASSERT_ARGS(op_fullname) int i; const size_t namelen = strlen(name); memcpy(dest, name, namelen+1); dest += namelen; for (i = 0; i < narg && args[i]; i++) { *dest++ = '_'; if (args[i]->type == VTADDRESS) { *dest++ = 'i'; *dest++ = 'c'; continue; } /* if one ever wants num keys, they go with 'S' */ if (keyvec & KEY_BIT(i)) { *dest++ = 'k'; if (args[i]->set=='S' || args[i]->set=='N' || args[i]->set=='K') { *dest++ = 'c'; continue; } else if (args[i]->set == 'P') continue; } if (args[i]->set == 'K') *dest++ = 'p'; else *dest++ = (char)tolower((unsigned char)args[i]->set); if (args[i]->type & (VTCONST|VT_CONSTP)) { *dest++ = 'c'; } } *dest = '\0'; } /* =item C Return opcode value for op name =cut */ void check_op(ARGMOD(imc_info_t * imcc), ARGOUT(op_info_t **op_info), ARGOUT(char *fullname), ARGIN(const char *name), ARGIN(SymReg * const * r), int narg, int keyvec) { ASSERT_ARGS(check_op) op_fullname(fullname, name, r, narg, keyvec); *op_info = (op_info_t *)Parrot_hash_get(imcc->interp, imcc->interp->op_hash, fullname); if (*op_info && !STREQ((*op_info)->full_name, fullname)) *op_info = NULL; } /* =item C Is instruction a parrot opcode? =cut */ PARROT_WARN_UNUSED_RESULT int is_op(ARGMOD(imc_info_t * imcc), ARGIN(const char *name)) { ASSERT_ARGS(is_op) return Parrot_hash_exists(imcc->interp, imcc->interp->op_hash, name); } /* =item C Create an C object for an instruction that takes a variable number of arguments. =cut */ PARROT_MALLOC PARROT_CANNOT_RETURN_NULL PARROT_WARN_UNUSED_RESULT static Instruction * var_arg_ins(ARGMOD(imc_info_t * imcc), ARGMOD(IMC_Unit *unit), ARGIN(const char *name), ARGMOD(SymReg **r), int n, int emit) { ASSERT_ARGS(var_arg_ins) op_info_t *op; Instruction *ins; char fullname[64]; /* in constant */ int dirs = 1; /* XXX: Maybe the check for n == 0 is the only one required * and the other must be assertions? */ if (n == 0 || r[0] == NULL || r[0]->name == NULL) IMCC_fataly(imcc, EXCEPTION_SYNTAX_ERROR, "The opcode '%s' needs arguments", name); if (r[0]->set == 'S') { r[0] = mk_const(imcc, r[0]->name, 'P'); r[0]->pmc_type = enum_class_FixedIntegerArray; } op_fullname(fullname, name, r, 1, 0); op = (op_info_t *)Parrot_hash_get(imcc->interp, imcc->interp->op_hash, fullname); PARROT_ASSERT(op && STREQ(op->full_name, fullname)); ins = _mk_instruction(name, "", n, r, dirs); ins->op = op; ins->opsize = n + 1; if (emit) emitb(imcc, unit, ins); return ins; } /* =item C Makes an instruction. name ... op name fmt ... optional format regs ... SymReg ** n ... number of params keyvec ... see KEY_BIT() emit ... if true, append to instructions see imc.c for usage =cut */ PARROT_IGNORABLE_RESULT PARROT_CAN_RETURN_NULL Instruction * INS(ARGMOD(imc_info_t * imcc), ARGMOD(IMC_Unit *unit), ARGIN(const char *name), ARGIN_NULLOK(const char *fmt), ARGIN(SymReg **r), int n, int keyvec, int emit) { ASSERT_ARGS(INS) if (STREQ(name, ".annotate")) { Instruction *ins = _mk_instruction(name, "", n, r, 0); if (emit) return emitb(imcc, unit, ins); else return ins; } if ((STREQ(name, "set_args")) || (STREQ(name, "get_results")) || (STREQ(name, "get_params")) || (STREQ(name, "set_returns"))) return var_arg_ins(imcc, unit, name, r, n, emit); else { Instruction *ins; int i, len; int dirs = 0; op_info_t *op; char fullname[64] = "", format[128] = ""; op_fullname(fullname, name, r, n, keyvec); op = (op_info_t *)Parrot_hash_get(imcc->interp, imcc->interp->op_hash, fullname); if (op && !STREQ(op->full_name, fullname)) op = NULL; /* maybe we have a fullname */ if (!op) { op = (op_info_t *)Parrot_hash_get(imcc->interp, imcc->interp->op_hash, name); if (op && !STREQ(op->full_name, name)) op = NULL; } /* still wrong, try reverse compare */ if (!op) { const char * const n_name = try_rev_cmp(name, r); if (n_name) { name = n_name; op_fullname(fullname, name, r, n, keyvec); op = (op_info_t *)Parrot_hash_get(imcc->interp, imcc->interp->op_hash, fullname); if (op && !STREQ(op->full_name, fullname)) op = NULL; } } /* still wrong, try to find an existing op */ if (!op) op = try_find_op(imcc, unit, name, r, n, keyvec, emit); if (!op) { int ok = 0; /* check mixed constants */ ins = IMCC_subst_constants_umix(imcc, unit, name, r, n + 1); if (ins) goto found_ins; /* and finally multiple constants */ ins = IMCC_subst_constants(imcc, unit, name, r, n + 1, &ok); if (ok) { if (ins) goto found_ins; else return NULL; } } else strcpy(fullname, name); if (!op) IMCC_fataly(imcc, EXCEPTION_SYNTAX_ERROR, "The opcode '%s' (%s<%d>) was not found. " "Check the type and number of the arguments", fullname, name, n); *format = '\0'; /* info->op_count is args + 1 * build instruction format * set LV_in / out flags */ if (n != op->op_count - 1) IMCC_fataly(imcc, EXCEPTION_SYNTAX_ERROR, "arg count mismatch: op #%d '%s' needs %d given %d", op, fullname, op->op_count-1, n); /* XXX Speed up some by keep track of the end of format ourselves */ for (i = 0; i < n; i++) { switch (op->dirs[i]) { case PARROT_ARGDIR_INOUT: dirs |= 1 << (16 + i); /* go on */ case PARROT_ARGDIR_IN: dirs |= 1 << i ; break; case PARROT_ARGDIR_OUT: dirs |= 1 << (16 + i); break; default: PARROT_ASSERT(0); }; if (keyvec & KEY_BIT(i)) { /* XXX Assert that len > 2 */ len = strlen(format) - 2; PARROT_ASSERT(len >= 0); format[len] = '\0'; strcat(format, "[%s], "); } else if (r[i]->set == 'K') strcat(format, "[%s], "); else strcat(format, "%s, "); } len = strlen(format); if (len >= 2) len -= 2; format[len] = '\0'; if (fmt && *fmt) { strncpy(format, fmt, sizeof (format) - 1); format[sizeof (format) - 1] = '\0'; } IMCC_debug(imcc, DEBUG_PARSER, "%s %s\t%s\n", name, format, fullname); /* make the instruction */ ins = _mk_instruction(name, format, n, r, dirs); ins->keys |= keyvec; /* fill in oplib's info */ ins->op = op; ins->opsize = n + 1; /* mark end as absolute branch */ if (STREQ(name, "end") || STREQ(name, "ret")) { ins->type |= ITBRANCH | IF_goto; } else if (STREQ(name, "yield")) { if (!imcc->cur_unit->instructions->symregs[0]) IMCC_fataly(imcc, EXCEPTION_SYNTAX_ERROR, "Cannot yield from non-continuation\n"); imcc->cur_unit->instructions->symregs[0]->pcc_sub->yield = 1; } /* set up branch flags * mark registers that are labels */ for (i = 0; i < op->op_count - 1; i++) { if (op->labels[i]) ins->type |= ITBRANCH | (1 << i); else { if (r[i]->type == VTADDRESS) IMCC_fataly(imcc, EXCEPTION_SYNTAX_ERROR, "undefined identifier '%s'\n", r[i]->name); } } if (op->jump) { ins->type |= ITBRANCH; /* TODO use opnum constants */ if (STREQ(name, "branch") || STREQ(name, "tailcall") || STREQ(name, "returncc")) ins->type |= IF_goto; else if (STREQ(fullname, "jump_i") || STREQ(fullname, "branch_i")) imcc->dont_optimize = 1; } found_ins: if (emit) emitb(imcc, unit, ins); return ins; } } /* =item C Change one argument of an op to be numeric in stead of integral. Used when integer argument op variants don't exist. =cut */ PARROT_WARN_UNUSED_RESULT static int change_op_arg_to_num(ARGMOD(imc_info_t * imcc), ARGMOD(IMC_Unit *unit), ARGMOD(SymReg **r), int num, int emit) { ASSERT_ARGS(change_op_arg_to_num) int changed = 0; if (r[num]->type & (VTCONST|VT_CONSTP)) { /* make a number const */ const SymReg *c = r[num]; if (c->type & VT_CONSTP) c = c->reg; r[num] = mk_const(imcc, c->name, 'N'); changed = 1; } else if (emit) { /* emit * set $N0, Iy * op Nx, $N0 * or * op Nx, ..., $N0 */ SymReg *rr[2]; rr[0] = mk_temp_reg(imcc, 'N'); rr[1] = r[num]; INS(imcc, unit, "set", NULL, rr, 2, 0, 1); r[num] = rr[0]; changed = 1; /* need to allocate the temp - run reg_alloc */ imcc->optimizer_level |= OPT_PASM; } return changed; } /* =item C Try to find valid op doing the same operation e.g. add_n_i_n => add_n_n_i div_n_ic_n => div_n_nc_n div_n_i_n => set_n_i ; div_n_n_n ge_n_ic_ic => ge_n_nc_ic acos_n_i => acos_n_n =cut */ PARROT_WARN_UNUSED_RESULT PARROT_CAN_RETURN_NULL static op_info_t * try_find_op(ARGMOD(imc_info_t * imcc), ARGMOD(IMC_Unit *unit), ARGIN(const char *name), ARGMOD(SymReg **r), int n, int keyvec, int emit) { ASSERT_ARGS(try_find_op) char fullname[64]; int changed = 0; if (n == 3 && r[0]->set == 'N') { if (r[1]->set == 'I') { const SymReg * const r1 = r[1]; changed |= change_op_arg_to_num(imcc, unit, r, 1, emit); /* op Nx, Iy, Iy: reuse generated temp Nz */ if (r[2]->set == 'I' && r[2]->type != VTADDRESS && r[2] == r1) r[2] = r[1]; } if (r[2]->set == 'I' && r[2]->type != VTADDRESS) changed |= change_op_arg_to_num(imcc, unit, r, 2, emit); } /* handle eq_i_n_ic */ else if (n == 3 && r[1]->set == 'N' && r[0]->set == 'I' && r[2]->type == VTADDRESS) { changed |= change_op_arg_to_num(imcc, unit, r, 0, emit); } else if (n == 2 && r[0]->set == 'N' && r[1]->set == 'I') { /* * transcendentals e.g. acos N, I */ if (!STREQ(name, "fact")) changed = change_op_arg_to_num(imcc, unit, r, 1, emit); } if (changed) { op_info_t *op; op_fullname(fullname, name, r, n, keyvec); op = (op_info_t *)Parrot_hash_get(imcc->interp, imcc->interp->op_hash, fullname); if (op && !STREQ(op->full_name, fullname)) op = NULL; return op; } return NULL; } /* =item C Try to find a valid op doing the same thing by reversing comparisons. =cut */ PARROT_WARN_UNUSED_RESULT PARROT_CAN_RETURN_NULL static const char * try_rev_cmp(ARGIN(const char *name), ARGMOD(SymReg **r)) { ASSERT_ARGS(try_rev_cmp) static const struct br_pairs { PARROT_OBSERVER const char * const op; PARROT_OBSERVER const char * const nop; const int to_swap; } br_pairs[] = { { "gt", "lt", 0 }, { "ge", "le", 0 }, { "isgt", "islt", 1 }, { "isge", "isle", 1 }, }; unsigned int i; for (i = 0; i < N_ELEMENTS(br_pairs); i++) { if (STREQ(name, br_pairs[i].op)) { const int to_swap = br_pairs[i].to_swap; SymReg *t; if (r[to_swap + 1]->set == 'P') return NULL; t = r[to_swap]; r[to_swap] = r[to_swap + 1]; r[to_swap + 1] = t; return br_pairs[i].nop; } } return NULL; } /* =item C Formats a given series of arguments per a given format string and prints it to the given Parrot IO PMC. =cut */ PARROT_IGNORABLE_RESULT int imcc_vfprintf(ARGMOD(imc_info_t * imcc), ARGMOD(PMC *io), ARGIN(const char *format), va_list ap) { ASSERT_ARGS(imcc_vfprintf) return Parrot_io_putps(imcc->interp, io, Parrot_vsprintf_c(imcc->interp, format, ap)); } /* =item C Checks whether string C has extension C. =cut */ int imcc_string_ends_with(ARGMOD(imc_info_t * imcc), ARGIN(const STRING *str), ARGIN(const char *ext)) { ASSERT_ARGS(imcc_string_ends_with) STRING *ext_str = Parrot_str_new(imcc->interp, ext, 0); STRING *substr; INTVAL ext_len = STRING_length(ext_str); INTVAL len = STRING_length(str); if (ext_len >= len) return 0; substr = STRING_substr(imcc->interp, str, len - ext_len, ext_len); return STRING_equal(imcc->interp, substr, ext_str); } /* =back =cut */ /* * Local variables: * c-file-style: "parrot" * End: * vim: expandtab shiftwidth=4 cinoptions='\:2=2' : */ raw_pixels.pir000644000765000765 417012101554066 16761 0ustar00bruce000000000000parrot-6.6.0/examples/sdl =head1 DESCRIPTION raw_pixels.pir - paint the screen blue, pixel by pixel =head1 SYNOPSIS To run this file, run the following command from the Parrot directory: $ ./parrot examples/sdl/raw_pixels.pir $ =cut .include 'datatypes.pasm' .sub _main :main # first load the necessary libraries load_bytecode "SDL/App.pir" load_bytecode "SDL/Rect.pir" load_bytecode "SDL/Color.pir" # create an SDL::App object .local pmc app .local int app_type app = new ['SDL'; 'App'] app.'init'( 'height' => 480, 'width' => 640, 'bpp' => 0, 'flags' => 1 ) # fetch the SDL::Surface representing the main window .local pmc main_screen main_screen = app.'surface'() # create an SDL::Rect representing the entire main screen .local pmc rect .local int rect_type rect = new ['SDL'; 'Rect'] rect.'init'( 'height' => 480, 'width' => 640, 'x' => 0, 'y' => 0 ) # create a white color to paint the background; make new pixels show up .local pmc white white = new ['SDL'; 'Color'] white.'init'( 'r' => 255, 'g' => 255, 'b' => 255 ) # create a blue color to paint the new pixels .local pmc blue blue = new ['SDL'; 'Color'] blue.'init'( 'r' => 0, 'g' => 0, 'b' => 255 ) # draw the background main_screen.'fill_rect'( rect, white ) main_screen.'update_rect'( rect ) # lock the raw framebuffer main_screen.'lock'() # if you convert the color ahead of time, it's much faster! .local int converted_blue converted_blue = blue.'color_for_surface'( main_screen ) # draw a vertical line of pixels from left to right on each iteration .local int x .local int y x = 0 loop_x: y = 0 loop_y: main_screen.'draw_pixel'( x, y, converted_blue ) inc y if y < 480 goto loop_y inc x # update the screen on each iteration main_screen.'update_rect'( rect ) if x < 640 goto loop_x loop_end: # no more raw pixel access necessary main_screen.'unlock'() # show off for a bit then exit sleep 2 app.'quit'() end .end =head1 AUTHOR chromatic, Echromatic at wgz dot orgE. =head1 COPYRIGHT Copyright (C) 2004-2008, Parrot Foundation. =cut # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: pdd31_hll.pod000644000765000765 2526612101554066 15661 0ustar00bruce000000000000parrot-6.6.0/docs/pdds# Copyright (C) 2009-2010, Parrot Foundation. =head1 PDD 31: HLL Compilers and Libraries =head2 Abstract This PDD describes the standard compiler API and support for cross-library communication between high-level languages (HLLs). =head2 Description Parrot's support for HLL interoperability is primarily focused on enabling programs written in one language to be able to use libraries and code written in a different language. At the same time, language implementors should not be overly restricted by a global specification. This PDD describes an API for HLL compiler objects to use to promote library sharing among languages. It's intended to make it easy for a program to request loading of a local or foreign module, determine the capabilities provided by the module, and potentially import and integrate them into its own namespaces. In general, the API treats library-level interoperability as a negotiation among HLL compiler objects, with each HLL compiler maintaining primary control over the operations performed in its HLL space. In particular, this HLL API does not attempt to prescribe how languages should organize their internal capabilities, objects, classes, namespaces, methods, data structures, and the like. =head2 Implementation =head3 Compiler API This section describes the abstract API for HLL compiler objects. =head4 Locating a compiler object Generally HLL compilers are loaded via the C opcode, and register themselves using the C opcode. By convention, each HLL compiler should at minimum register itself using the name of its HLL namespace (see PDD 26), although a compiler can choose to register itself under other names as well. =head4 Methods =over 4 =item C $P0 = compiler.'compile'(source [, options :named :slurpy]) Return the result of compiling C according to C. Common options include: =over 4 =item target Stop the compilation process when the stage given by target has been reached. Common values for target include "parse", "past", "pir", and "pbc". The exact target types supported are dependent on the compiler itself and are not limited or standardized. =item outer_ctx Use the supplied context as the outer (lexical) context for the compilation. Some languages require this option to be able to look up lexical symbols in outer scopes when performing a dynamic compilation at runtime. =back =item C $P0 = compiler.'eval'(source [, args :slurpy] [, options :named :slurpy]) Compile and evaluate (execute) the code given by C with C and according to C. The available options are generally the same as for the C method above; in particular, the C option can be used to specify the outer lexical context for the evaluated source. =item C $P0 = compiler.'parse_name'(name) Parse the string C using the rules specific to C, and return an array of individual name elements. For example, a Java compiler would turn 'C' to C<['a','b','c']>, while a Perl compiler would turn 'C' into the same result. Perl's sigil rules would likely turn 'C<$a::b::c>' into C<['a','b','$c']>. =item C module = compiler.'load_module'(name) Locate and load the module given by C using the rules for libraries specific to C, and return a C handle for the module just loaded. The C argument is typically an array or a string to be processed as in C above. In general the module handle returned should be considered opaque by the caller, but specific HLL compilers are allowed to specify the nature of the handle returned (e.g., a namespace for the loaded module, or a specific "handle" object). =item C module = compiler.'get_module'(name) Similar to C above, this method returns a handle to an already-loaded module given by C. =item C $P0 = compiler.'get_exports'(module [,name,name,...] [, 'tagset'=>tagset]) Requests the exported objects given by C and/or C for C within the given C. The C argument should be a module handle as obtained by C or C above. A C argument provides an identifier that a compiler and/or module can use to supply their own lists of items to be exported. By convention, a C of "DEFAULT" refers to the default set of exported items for the module, while "ALL" returns all available exports. Compilers and modules are free to define their own custom tagsets beyond these. Any C arguments supplied generally limit the export list to the tagset items corresponding to the supplied names (as determined by the compiler invocant). If names are provided without an explicit tagset, then "ALL" is assumed. If neither names nor a tagset are provided, then symbols from "DEFAULT" are returned. The returned export list is a hash of hashes; each entry in the top level hash has a key identifying the type of exported object (one of C<'namespace'>, C<'sub'>, or C<'var'>) and a value hash containing the corresponding exported symbol names and objects. This hash-of-hashes approach is intended to generally correspond to the "Typed Interface" section of PDD 21 ("Namespaces"), and allows the module's source HLL to indicate the type of exported object to the caller. The hash-of-hash approach also accommodates languages where a single name might be used to refer to several objects that differ in type. (This PDD explicitly rejects the notion that a HLL should be directly exporting or injecting symbols into a foreign HLL's namespaces.) =back =head3 HLL::Compiler class HLL::Compiler is a common base class for compiler objects based on the Parrot Compiler Toolkit (PCT) and NQP (Not Quite Perl) libraries. It provides a default implementation of the abstract Compiler API above, plus some additional methods for simple symbol table export and import. The default methods are intended to support importing and exporting symbols using standard Parrot namespace objects (PDD 21). However, it's normal (and expected) that languages will subclass HLL::Compiler to provide language-specific semantics where needed. =head4 Methods =over 4 =item C $S0 = compiler.'language'([name]) If C is provided, sets the language name of the invocant and registers the invocant as the compiler for C via the C opcode. Returns the language name of the compiler. =item C $P0 = compiler.'parse_name'(name) Splits a name based on double-colons, such that "C" becomes C<['A','B','C']>. =item C module = compiler.'get_module'(name) Returns a handle to the HLL namespace associated with C (which is processed via the invocant's C method if needed). =item C module = compiler.'load_module'(name) Loads a module C via the C opcode using both ".pbc" and ".pir" extensions. Parrot's standard library paths for C are searched. Returns the HLL namespace associated with C (which may be PMCNULL if loading failed or if the requested module did not create an associated namespace). =item C $P0 = compiler.'get_exports'(module [,name,name,...] [, 'tagset'=>tagset]) Implements a simple exporting interface that meets the "Compiler API" above. The C argument is expected to be something that supports a hash interface, such as NameSpace or LexPad. (Note that this is what gets returned by the default C and C methods above.) The C entry should return another hash-like object keyed by tagset names; each of those tagset names then identify the exportable symbols associated with that tagset. With this default arrangement, it's entirely possible for a module to indicate its tagsets by using symbol entries in namespaces. For example, a module with namespace C<['XYZ']> can define its default exports by binding symbols in the C<['XYZ';'EXPORT';'DEFAULT']> namespace. (Modules aren't required to use exactly this mechanism; it's just one possibility of many.) If the "ALL" tagset is requested and there is no "ALL" entry in the C hash, then C itself is used as the source of exportable symbols for this method. This enables C to be used to obtain symbols from modules that do not follow the "EXPORT" convention above (e.g., core Parrot modules). As described in the Compiler API section above, the return value from C is a hash-of-hashes with exported namespaces in the C hash, exported subroutines in the C hash, and all other exports in the C hash. =item C compiler.'import'(target, export_hash) Import the entries from C (typically obtained via C above) into C according to the rules for C. Any entries in C are imported first, followed by entries in C, followed by entries in C. Note that this method is not part of the abstract Compiler API -- a HLL compiler is able to implement importing in any way it deems appropriate. The C class provides this method as a useful default for many HLL compilers. For each exported item of C, import takes place by checking the invocant for an C method and using that if it exists (where C<[type]> is one of "namespace", "sub", or "var"). These methods are used to implemented "typed imports", and allows the compiler object to perform any name mangling or other operations needed to properly import an object. If the compiler invocant doesn't define an C method, C attempts to use any C method that exists on C (e.g., for the case where C is a namespace PMC supporting the typed interface defined by PDD 21). If neither of these methods are available, then C simply binds the symbol using C's hash interface. =back =head3 Examples =head4 Importing a module Acme::Boom from language xyz into language abc =begin PIR_FRAGMENT # Load the HLL library and get its compiler .local pmc xyzcompiler, module, exports load_language 'xyz' xyzcompiler = compreg 'xyz' # load xyz's module "Acme::Boom" module = xyzcompiler.'load_module'("Acme::Boom") # get the default exports for the module # (note that 'tagset'=>'DEFAULT' is optional here exports = xyzcompiler.'get_exports'(module, 'tagset'=>'DEFAULT') # import into current namespace .local pmc abccompiler abccompiler = compreg 'abc' $P0 = get_namespace abccompiler.'import'($P0, exports) =end PIR_FRAGMENT =head2 References F =cut __END__ Local Variables: fill-column:78 End: README.pod000644000765000765 52112101554066 14352 0ustar00bruce000000000000parrot-6.6.0/config# Copyright (C) 2001-2012, Parrot Foundation. =pod =head1 NAME config/README.pod - Readme file for the 'config/' top-level directory. =head1 DESCRIPTION This directory, primarily, contains Perl5 modules which F uses, during the configuration of Parrot. =head1 COPYRIGHT Copyright (C) 2012, Parrot Foundation. =cut perlhistory.txt000644000765000765 3275711611421302 16547 0ustar00bruce000000000000parrot-6.6.0/t/library This file is used as a source for ParrotIO streams in t/library/streams.t Larry 0 Classified. Don't ask. Larry 1.000 1987-Dec-18 1.001..10 1988-Jan-30 1.011..14 1988-Feb-02 Schwern 1.0.15 2002-Dec-18 Modernization Richard 1.0.16 2003-Dec-18 Larry 2.000 1988-Jun-05 2.001 1988-Jun-28 Larry 3.000 1989-Oct-18 3.001 1989-Oct-26 3.002..4 1989-Nov-11 3.005 1989-Nov-18 3.006..8 1989-Dec-22 3.009..13 1990-Mar-02 3.014 1990-Mar-13 3.015 1990-Mar-14 3.016..18 1990-Mar-28 3.019..27 1990-Aug-10 User subs. 3.028 1990-Aug-14 3.029..36 1990-Oct-17 3.037 1990-Oct-20 3.040 1990-Nov-10 3.041 1990-Nov-13 3.042..43 1991-Jan-?? 3.044 1991-Jan-12 Larry 4.000 1991-Mar-21 4.001..3 1991-Apr-12 4.004..9 1991-Jun-07 4.010 1991-Jun-10 4.011..18 1991-Nov-05 4.019 1991-Nov-11 Stable. 4.020..33 1992-Jun-08 4.034 1992-Jun-11 4.035 1992-Jun-23 Larry 4.036 1993-Feb-05 Very stable. 5.000alpha1 1993-Jul-31 5.000alpha2 1993-Aug-16 5.000alpha3 1993-Oct-10 5.000alpha4 1993-???-?? 5.000alpha5 1993-???-?? 5.000alpha6 1994-Mar-18 5.000alpha7 1994-Mar-25 Andy 5.000alpha8 1994-Apr-04 Larry 5.000alpha9 1994-May-05 ext appears. 5.000alpha10 1994-Jun-11 5.000alpha11 1994-Jul-01 Andy 5.000a11a 1994-Jul-07 To fit 14. 5.000a11b 1994-Jul-14 5.000a11c 1994-Jul-19 5.000a11d 1994-Jul-22 Larry 5.000alpha12 1994-Aug-04 Andy 5.000a12a 1994-Aug-08 5.000a12b 1994-Aug-15 5.000a12c 1994-Aug-22 5.000a12d 1994-Aug-22 5.000a12e 1994-Aug-22 5.000a12f 1994-Aug-24 5.000a12g 1994-Aug-24 5.000a12h 1994-Aug-24 Larry 5.000beta1 1994-Aug-30 Andy 5.000b1a 1994-Sep-06 Larry 5.000beta2 1994-Sep-14 Core slushified. Andy 5.000b2a 1994-Sep-14 5.000b2b 1994-Sep-17 5.000b2c 1994-Sep-17 Larry 5.000beta3 1994-Sep-?? Andy 5.000b3a 1994-Sep-18 5.000b3b 1994-Sep-22 5.000b3c 1994-Sep-23 5.000b3d 1994-Sep-27 5.000b3e 1994-Sep-28 5.000b3f 1994-Sep-30 5.000b3g 1994-Oct-04 Andy 5.000b3h 1994-Oct-07 Larry? 5.000gamma 1994-Oct-13? Larry 5.000 1994-Oct-17 Andy 5.000a 1994-Dec-19 5.000b 1995-Jan-18 5.000c 1995-Jan-18 5.000d 1995-Jan-18 5.000e 1995-Jan-18 5.000f 1995-Jan-18 5.000g 1995-Jan-18 5.000h 1995-Jan-18 5.000i 1995-Jan-26 5.000j 1995-Feb-07 5.000k 1995-Feb-11 5.000l 1995-Feb-21 5.000m 1995-Feb-28 5.000n 1995-Mar-07 5.000o 1995-Mar-13? Larry 5.001 1995-Mar-13 Andy 5.001a 1995-Mar-15 5.001b 1995-Mar-31 5.001c 1995-Apr-07 5.001d 1995-Apr-14 5.001e 1995-Apr-18 Stable. 5.001f 1995-May-31 5.001g 1995-May-25 5.001h 1995-May-25 5.001i 1995-May-30 5.001j 1995-Jun-05 5.001k 1995-Jun-06 5.001l 1995-Jun-06 Stable. 5.001m 1995-Jul-02 Very stable. 5.001n 1995-Oct-31 Very unstable. 5.002beta1 1995-Nov-21 5.002b1a 1995-Dec-04 5.002b1b 1995-Dec-04 5.002b1c 1995-Dec-04 5.002b1d 1995-Dec-04 5.002b1e 1995-Dec-08 5.002b1f 1995-Dec-08 Tom 5.002b1g 1995-Dec-21 Doc release. Andy 5.002b1h 1996-Jan-05 5.002b2 1996-Jan-14 Larry 5.002b3 1996-Feb-02 Andy 5.002gamma 1996-Feb-11 Larry 5.002delta 1996-Feb-27 Larry 5.002 1996-Feb-29 Prototypes. Charles 5.002_01 1996-Mar-25 5.003 1996-Jun-25 Security release. 5.003_01 1996-Jul-31 Nick 5.003_02 1996-Aug-10 Andy 5.003_03 1996-Aug-28 5.003_04 1996-Sep-02 5.003_05 1996-Sep-12 5.003_06 1996-Oct-07 5.003_07 1996-Oct-10 Chip 5.003_08 1996-Nov-19 5.003_09 1996-Nov-26 5.003_10 1996-Nov-29 5.003_11 1996-Dec-06 5.003_12 1996-Dec-19 5.003_13 1996-Dec-20 5.003_14 1996-Dec-23 5.003_15 1996-Dec-23 5.003_16 1996-Dec-24 5.003_17 1996-Dec-27 5.003_18 1996-Dec-31 5.003_19 1997-Jan-04 5.003_20 1997-Jan-07 5.003_21 1997-Jan-15 5.003_22 1997-Jan-16 5.003_23 1997-Jan-25 5.003_24 1997-Jan-29 5.003_25 1997-Feb-04 5.003_26 1997-Feb-10 5.003_27 1997-Feb-18 5.003_28 1997-Feb-21 5.003_90 1997-Feb-25 Ramping up to the 5.004 release. 5.003_91 1997-Mar-01 5.003_92 1997-Mar-06 5.003_93 1997-Mar-10 5.003_94 1997-Mar-22 5.003_95 1997-Mar-25 5.003_96 1997-Apr-01 5.003_97 1997-Apr-03 Fairly widely used. 5.003_97a 1997-Apr-05 5.003_97b 1997-Apr-08 5.003_97c 1997-Apr-10 5.003_97d 1997-Apr-13 5.003_97e 1997-Apr-15 5.003_97f 1997-Apr-17 5.003_97g 1997-Apr-18 5.003_97h 1997-Apr-24 5.003_97i 1997-Apr-25 5.003_97j 1997-Apr-28 5.003_98 1997-Apr-30 5.003_99 1997-May-01 5.003_99a 1997-May-09 p54rc1 1997-May-12 Release Candidates. p54rc2 1997-May-14 Chip 5.004 1997-May-15 A major maintenance release. Tim 5.004_01-t1 1997-???-?? The 5.004 maintenance track. 5.004_01-t2 1997-Jun-11 aka perl5.004m1t2 5.004_01 1997-Jun-13 5.004_01_01 1997-Jul-29 aka perl5.004m2t1 5.004_01_02 1997-Aug-01 aka perl5.004m2t2 5.004_01_03 1997-Aug-05 aka perl5.004m2t3 5.004_02 1997-Aug-07 5.004_02_01 1997-Aug-12 aka perl5.004m3t1 5.004_03-t2 1997-Aug-13 aka perl5.004m3t2 5.004_03 1997-Sep-05 5.004_04-t1 1997-Sep-19 aka perl5.004m4t1 5.004_04-t2 1997-Sep-23 aka perl5.004m4t2 5.004_04-t3 1997-Oct-10 aka perl5.004m4t3 5.004_04-t4 1997-Oct-14 aka perl5.004m4t4 5.004_04 1997-Oct-15 5.004_04-m1 1998-Mar-04 (5.004m5t1) Maint. trials for 5.004_05. 5.004_04-m2 1998-May-01 5.004_04-m3 1998-May-15 5.004_04-m4 1998-May-19 5.004_05-MT5 1998-Jul-21 5.004_05-MT6 1998-Oct-09 5.004_05-MT7 1998-Nov-22 5.004_05-MT8 1998-Dec-03 Chip 5.004_05-MT9 1999-Apr-26 5.004_05 1999-Apr-29 Malcolm 5.004_50 1997-Sep-09 The 5.005 development track. 5.004_51 1997-Oct-02 5.004_52 1997-Oct-15 5.004_53 1997-Oct-16 5.004_54 1997-Nov-14 5.004_55 1997-Nov-25 5.004_56 1997-Dec-18 5.004_57 1998-Feb-03 5.004_58 1998-Feb-06 5.004_59 1998-Feb-13 5.004_60 1998-Feb-20 5.004_61 1998-Feb-27 5.004_62 1998-Mar-06 5.004_63 1998-Mar-17 5.004_64 1998-Apr-03 5.004_65 1998-May-15 5.004_66 1998-May-29 Sarathy 5.004_67 1998-Jun-15 5.004_68 1998-Jun-23 5.004_69 1998-Jun-29 5.004_70 1998-Jul-06 5.004_71 1998-Jul-09 5.004_72 1998-Jul-12 5.004_73 1998-Jul-13 5.004_74 1998-Jul-14 5.005 beta candidate. 5.004_75 1998-Jul-15 5.005 beta1. 5.004_76 1998-Jul-21 5.005 beta2. 5.005 1998-Jul-22 Oneperl. Sarathy 5.005_01 1998-Jul-27 The 5.005 maintenance track. 5.005_02-T1 1998-Aug-02 5.005_02-T2 1998-Aug-05 5.005_02 1998-Aug-08 Graham 5.005_03-MT1 1998-Nov-30 5.005_03-MT2 1999-Jan-04 5.005_03-MT3 1999-Jan-17 5.005_03-MT4 1999-Jan-26 5.005_03-MT5 1999-Jan-28 5.005_03-MT6 1999-Mar-05 5.005_03 1999-Mar-28 Sarathy 5.005_50 1998-Jul-26 The 5.6 development track. 5.005_51 1998-Aug-10 5.005_52 1998-Sep-25 5.005_53 1998-Oct-31 5.005_54 1998-Nov-30 5.005_55 1999-Feb-16 5.005_56 1999-Mar-01 5.005_57 1999-May-25 5.005_58 1999-Jul-27 5.005_59 1999-Aug-02 5.005_60 1999-Aug-02 5.005_61 1999-Aug-20 5.005_62 1999-Oct-15 5.005_63 1999-Dec-09 5.5.640 2000-Feb-02 5.5.650 2000-Feb-08 beta1 5.5.660 2000-Feb-22 beta2 5.5.670 2000-Feb-29 beta3 5.6.0-RC1 2000-Mar-09 Release candidate 1. 5.6.0-RC2 2000-Mar-14 Release candidate 2. 5.6.0-RC3 2000-Mar-21 Release candidate 3. 5.6.0 2000-Mar-22 Sarathy 5.6.1-TRIAL1 2000-Dec-18 The 5.6 maintenance track. 5.6.1-TRIAL2 2001-Jan-31 5.6.1-TRIAL3 2001-Mar-19 5.6.1-foolish 2001-Apr-01 The "fools-gold" release. 5.6.1 2001-Apr-08 Rafael 5.6.2-RC1 2003-Nov-08 5.6.2 2003-Nov-15 Fix new build issues Jarkko 5.7.0 2000-Sep-02 The 5.7 track: Development. 5.7.1 2001-Apr-09 5.7.2 2001-Jul-13 Virtual release candidate 0. 5.7.3 2002-Mar-05 5.8.0-RC1 2002-Jun-01 5.8.0-RC2 2002-Jun-21 5.8.0-RC3 2002-Jul-13 5.8.0 2002-Jul-18 5.8.1-RC1 2003-Jul-10 5.8.1-RC2 2003-Jul-11 5.8.1-RC3 2003-Jul-30 5.8.1-RC4 2003-Aug-01 5.8.1-RC5 2003-Sep-22 5.8.1 2003-Sep-25 Nicholas 5.8.2-RC1 2003-Oct-27 5.8.2-RC2 2003-Nov-03 5.8.2 2003-Nov-05 5.8.3-RC1 2004-Jan-07 5.8.3 2004-Jan-14 5.8.4-RC1 2004-Apr-05 5.8.4-RC2 2004-Apr-15 5.8.4 2004-Apr-21 5.8.5-RC1 2004-Jul-06 5.8.5-RC2 2004-Jul-08 5.8.5 2004-Jul-19 Hugo 5.9.0 2003-Oct-27 Rafael 5.9.1 2004-Mar-16 opengl.pm000644000765000765 1350712101554066 15553 0ustar00bruce000000000000parrot-6.6.0/config/auto# Copyright (C) 2008-2011, Parrot Foundation. =head1 NAME config/auto/opengl.pm - Probe for OpenGL, GLU, and GLUT libraries =head1 DESCRIPTION Determines whether the platform supports OpenGL, GLU and GLUT. The optimal result at this time is to find OpenGL 3.2, GLU 1.3, and GLUT API version 4. You will typically need to install the headers and libraries required for compiling OpenGL/GLU/GLUT applications as a separate step in addition to the base development tools for your platform. The following sections detail the steps needed to add OpenGL support for each platform for which we have received this information -- details for additional platforms are welcome! =head2 Mac OS X You will need to install the F and the F. With these in place, everything else should be autodetected. Mac OS X uses a proprietary GLUT variant that supports more functions than standard GLUT 3.7, but fewer than F. =head2 Linux Linux distributions typically use F (L) for GLUT support, and F (L) for GLU support. Either the Mesa headers (for open source drivers) or the vendor headers (for closed source drivers) can be used for core OpenGL/GLX support. Here are the package names for various distributions; installing each of these will typically pull in a number of prerequisites as well: =head3 Debian/Ubuntu/etc. =over 4 =item GLUT F =item GLU F =item OpenGL/GLX (open source drivers) F =item OpenGL/GLX (NVIDIA drivers) F =back =head3 Fedora/RedHat/CentOS/etc. =over 4 =item GLUT F =item GLU F =item OpenGL/GLX (open source drivers) F =item OpenGL/GLX (NVIDIA drivers) F (?) =back =head2 Windows On Windows, Parrot supports four different compiler environments, each of which has different requirements for OpenGL support. Generally you should not attempt to mix the Cygwin variants (installing some X OpenGL libs and some w32api OpenGL libs) as this will almost certainly result in runtime errors like this one: freeglut ERROR: Function called without first calling 'glutInit'. =head3 MSVC =over 4 =item OpenGL/GLU/WGL F =item GLUT F (L) =back =head3 MinGW GLUT 3.7.6, see L. =head3 Cygwin/X Requires an X server and F, F, F, F and its dependencies. This is tried first. =head3 Cygwin/w32api Requires the F and F packages. Cygwin/w32api for native opengl support is only tried if F does not exist. The problem is that the OpenGL header files are used to create the OpenGL function list, and not the libraries themselves. If the F headers are found these are used, even if the w32api GLUT libraries are defined. =cut package auto::opengl; use strict; use warnings; use base qw(Parrot::Configure::Step); use Parrot::Configure::Utils ':auto'; sub _init { my $self = shift; my %data; $data{description} = q{Does your platform support OpenGL}; $data{result} = q{}; return \%data; } sub runstep { my ( $self, $conf ) = @_; my $without = $conf->options->get( qw| without-opengl | ); return $self->_handle_no_opengl($conf,'skipped') if $without; # opengl depends on thunks which depend on pcre return $self->_handle_no_opengl($conf) unless $conf->data->get('HAS_PCRE'); my $osname = $conf->data->get('osname'); my $extra_libs = $self->_select_lib( { conf => $conf, osname => $osname, cc => $conf->data->get('cc'), ($^O eq 'cygwin') ? # Cygwin/X is used when /usr/include/GL is found (-d '/usr/include/GL' ? (cygwin => '-lglut -L/usr/X11R6/lib -lGLU -lGL') : (cygwin => '-lglut32 -lglu32 -lopengl32')) : (), win32_gcc => '-lglut32 -lglu32 -lopengl32', win32_nongcc => 'opengl32.lib glu32.lib glut32.lib', darwin => '-framework OpenGL -framework GLUT', default => '-lglut -lGLU -lGL', } ); $conf->cc_gen('config/auto/opengl/opengl_c.in'); my $has_glut = 0; eval { $conf->cc_build( q{}, $extra_libs ) }; if ( $@ ) { return $self->_handle_no_opengl($conf); } else { my $test = $conf->cc_run(); return _handle_glut($conf, $extra_libs, $self->_evaluate_cc_run($conf, $test)); } } sub _evaluate_cc_run { my ($self, $conf, $test) = @_; my ($glut_api_version, $glut_brand) = split ' ', $test; $conf->debug(" (yes, $glut_brand API version $glut_api_version) "); $self->set_result("yes, $glut_brand $glut_api_version"); return ($glut_api_version, $glut_brand); } sub _handle_glut { my ($conf, $libs, $glut_api_version, $glut_brand) = @_; $conf->data->set( # Completely cargo culted opengl => 'define', has_opengl => 1, HAS_OPENGL => 1, opengl_lib => $libs, glut => 'define', glut_brand => $glut_brand, has_glut => $glut_api_version, HAS_GLUT => $glut_api_version, ); return 1; } sub _handle_no_opengl { my ($self, $conf, $msg) = @_; $conf->data->set( has_opengl => 0, HAS_OPENGL => 0, opengl_lib => '', has_glut => 0, HAS_GLUT => 0, ); $msg = 'no' unless $msg; $self->set_result($msg); return 1; } 1; # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: obscure.ops000644000765000765 742111567202624 16456 0ustar00bruce000000000000parrot-6.6.0/src/dynoplibs/* ** obscure.ops */ BEGIN_OPS_PREAMBLE #include END_OPS_PREAMBLE =head1 NAME obscure.ops - Obscure Mathematical Opcodes =cut =head1 DESCRIPTION Parrot's library of obscure mathematical ops. These turn common trig expressions into a single op. To use this library of ops, add this directive to your PIR: .loadlib 'obscure_ops' =cut ############################################################################### =head2 Obscure trigonometric operations Reference: Abramowitz, M. and Stegum, C. A. (Eds.). Handbook of Mathematical Functions with Formulas, Graphs, and Mathematical Tables, 9th printing. New York: Dover, p. 78, 1972. =over 4 =cut ######################################## =item B(out NUM, in NUM) Set $1 to the coversine (in radians) of $2. =cut inline op covers(out NUM, in NUM) :advanced_math { $1 = 1.0 - sin($2); } ######################################## =item B(out NUM, in NUM) Set $1 to the exsecant of $2 (given in radians). =cut inline op exsec(out NUM, in NUM) :advanced_math { $1 = (1.0 / cos($2)) - 1.0; } ######################################## =item B(out NUM, in NUM) Set $1 to the haversine (in radians) of $2. =cut inline op hav(out NUM, in NUM) { $1 = 0.5 * (1.0 - cos($2)); } ######################################## =item B(out NUM, in NUM) Set $1 to the versine (in radians) of $2. =cut inline op vers(out NUM, in NUM) :advanced_math { $1 = 1.0 - cos($2); } ######################################## =item B(out INT, in INT, in INT) Greatest Common divisor of $2 and $3. =cut inline op gcd(out INT, in INT, in INT) :advanced_math { INTVAL p = 0; INTVAL a = $2 < 0 ? -$2 : $2; INTVAL b = $3 < 0 ? -$3 : $3; if (a==0) { $1=b; goto NEXT(); } if (b==0) { $1=a; goto NEXT(); } while (!((a | b) & 1)) { a>>=1; b>>=1; p++; } while (a>0) { if (!(a & 1)) a>>=1; else if (!(b & 1)) b>>=1; else if (a>1; else a = (a-b)>>1; } $1 = b<(out INT, in INT, in INT) Least Common Multiple of $2 and $3 =cut inline op lcm(out INT, in INT, in INT) :advanced_math { INTVAL gcd = 0; INTVAL p = 0; INTVAL a = $2 < 0 ? -$2 : $2; INTVAL b = $3 < 0 ? -$3 : $3; INTVAL saved_var1 = a, saved_var2 = b; if (a==0 || b==0) { $1=0; goto NEXT(); } while (!((a | b) & 1)) { a>>=1; b>>=1; p++; } while (a>0) { if (!(a & 1)) a>>=1; else if (!(b & 1)) b>>=1; else if (a>1; else a = (a-b)>>1; } gcd = b<(out INT, in INT) =item B(out NUM, in INT) Factorial, n!. Calculates the product of 1 to N. =cut inline op fact(out INT, in INT) :advanced_math { /* Coercing a negative to a UINT can get pretty ugly * in this situation. */ INTVAL i = $2; UINTVAL q = 1; while (i>0) { q = q*i; i--; } $1 = q; } inline op fact(out NUM, in INT) :advanced_math { /* Coercing a negative to a UINT can get pretty ugly * in this situation. */ INTVAL i = $2; FLOATVAL q = 1; while (i>0) { q = q*i; i--; } $1 = q; } =back =cut ############################################################################### =head1 COPYRIGHT Copyright (C) 2001-2009, Parrot Foundation. =head1 LICENSE This program is free software. It is subject to the same license as the Parrot interpreter itself. =cut /* * Local variables: * c-file-style: "parrot" * End: * vim: expandtab shiftwidth=4 cinoptions='\:2=2' : */ gcc-01.t000644000765000765 2107311533177646 15236 0ustar00bruce000000000000parrot-6.6.0/t/steps/auto#! perl # Copyright (C) 2007, Parrot Foundation. # auto/gcc-01.t use strict; use warnings; use Test::More tests => 79; use Carp; use lib qw( lib t/configure/testlib ); use_ok('config::auto::gcc'); use Parrot::Configure::Options qw( process_options ); use Parrot::Configure::Step::Test; use Parrot::Configure::Test qw( test_step_constructor_and_description ); use IO::CaptureOutput qw | capture |; ########## regular ########## my ($args, $step_list_ref) = process_options( { argv => [], mode => q{configure}, } ); my $conf = Parrot::Configure::Step::Test->new; $conf->include_config_results( $args ); my $serialized = $conf->pcfreeze(); my $pkg = q{auto::gcc}; $conf->add_steps($pkg); $conf->options->set(%{$args}); my $step = test_step_constructor_and_description($conf); ok($step->runstep($conf), "runstep returned true value"); $conf->replenish($serialized); ########## _evaluate_gcc() ########## $conf->add_steps($pkg); $conf->options->set(%{$args}); $step = test_step_constructor_and_description($conf); my $gnucref = {}; ok($step->_evaluate_gcc($conf, $gnucref), "_evaluate_gcc() returned true value"); ok(! defined $conf->data->get( 'gccversion' ), "gccversion undef as expected"); $conf->replenish($serialized); ########## _evaluate_gcc() ########## $conf->add_steps($pkg); $conf->options->set(%{$args}); $step = test_step_constructor_and_description($conf); $gnucref = {}; $gnucref->{__GNUC__} = 1; $gnucref->{__INTEL_COMPILER} = 1; ok($step->_evaluate_gcc($conf, $gnucref), "_evaluate_gcc() returned true value"); ok(! defined $conf->data->get( 'gccversion' ), "gccversion undef as expected"); is($step->result(), q{no}, "Got expected result"); $conf->replenish($serialized); ########## _evaluate_gcc(); --verbose ########## ($args, $step_list_ref) = process_options( { argv => [ q{--verbose} ], mode => q{configure}, } ); $conf->add_steps($pkg); $conf->options->set(%{$args}); $step = test_step_constructor_and_description($conf); { my $rv; my $stdout; my $gnucref = {}; $gnucref->{__GNUC__} = undef; capture ( sub {$rv = $step->_evaluate_gcc($conf, $gnucref) }, \$stdout); ok($rv, "_evaluate_gcc() returned true value"); ok( $stdout, "verbose output captured" ); ok(! defined $conf->data->get( 'gccversion' ), "gccversion undef as expected"); is($step->result(), q{no}, "Got expected result"); } $conf->replenish($serialized); ########## _evaluate_gcc() ########## ($args, $step_list_ref) = process_options( { argv => [], mode => q{configure}, } ); $conf->add_steps($pkg); $conf->options->set(%{$args}); $step = test_step_constructor_and_description($conf); $gnucref = {}; $gnucref->{__GNUC__} = 1; $gnucref->{__INTEL_COMPILER} = 1; ok($step->_evaluate_gcc($conf, $gnucref), "_evaluate_gcc() returned true value"); ok(! defined $conf->data->get( 'gccversion' ), "gccversion undef as expected"); is($step->result(), q{no}, "Got expected result"); $conf->replenish($serialized); ########## _evaluate_gcc(); --verbose ########## ($args, $step_list_ref) = process_options( { argv => [ q{--verbose} ], mode => q{configure}, } ); $conf->add_steps($pkg); $conf->options->set(%{$args}); $step = test_step_constructor_and_description($conf); { my $rv; my $stdout; my $gnucref = {}; $gnucref->{__GNUC__} = q{abc123}; capture ( sub {$rv = $step->_evaluate_gcc($conf, $gnucref) }, \$stdout); ok($rv, "_evaluate_gcc() returned true value"); ok( $stdout, "verbose output captured" ); ok(! defined $conf->data->get( 'gccversion' ), "gccversion undef as expected"); is($step->result(), q{no}, "Got expected result"); } $conf->replenish($serialized); ########## _evaluate_gcc() ########## $conf->add_steps($pkg); $conf->options->set(%{$args}); $step = test_step_constructor_and_description($conf); { my $rv; my $stdout; my $gnucref = {}; $gnucref->{__GNUC__} = q{123}; $gnucref->{__GNUC_MINOR__} = q{abc}; capture ( sub {$rv = $step->_evaluate_gcc($conf, $gnucref) }, \$stdout); ok($rv, "_evaluate_gcc() returned true value"); ok( !$stdout, "verbose output captured" ); ok(defined $conf->data->get( 'gccversion' ), "gccversion defined as expected"); is($conf->data->get( 'gccversion' ), 123, "Got expected value for gccversion"); like($step->result(), qr/^yes/, "Got expected result"); } $conf->replenish($serialized); ########## _evaluate_gcc() ########## ($args, $step_list_ref) = process_options( { argv => [], mode => q{configure}, } ); $conf->add_steps($pkg); $conf->options->set(%{$args}); $step = test_step_constructor_and_description($conf); { my $rv; my $stdout; my $gnucref = {}; $gnucref->{__GNUC__} = q{123}; $gnucref->{__GNUC_MINOR__} = q{456}; capture ( sub {$rv = $step->_evaluate_gcc($conf, $gnucref) }, \$stdout); ok($rv, "_evaluate_gcc() returned true value"); ok(defined $conf->data->get( 'gccversion' ), "gccversion defined as expected"); is($conf->data->get( 'gccversion' ), q{123.456}, "Got expected value for gccversion"); like($step->result(), qr/^yes/, "Got expected result"); } $conf->replenish($serialized); ########## _evaluate_gcc(); --verbose ########## ($args, $step_list_ref) = process_options( { argv => [ q{--verbose} ], mode => q{configure}, } ); $conf->add_steps($pkg); $conf->options->set(%{$args}); $step = test_step_constructor_and_description($conf); { my $rv; my $stdout; my $gnucref = {}; $gnucref->{__GNUC__} = q{123}; $gnucref->{__GNUC_MINOR__} = q{456}; capture ( sub {$rv = $step->_evaluate_gcc($conf, $gnucref) }, \$stdout); ok($rv, "_evaluate_gcc() returned true value"); ok( !$stdout, "verbose output captured" ); ok(defined $conf->data->get( 'gccversion' ), "gccversion defined as expected"); is($conf->data->get( 'gccversion' ), q{123.456}, "Got expected value for gccversion"); like($step->result(), qr/^yes/, "Got expected result"); } $conf->replenish($serialized); ########## _evaluate_gcc() ########## ($args, $step_list_ref) = process_options( { argv => [ ], mode => q{configure}, } ); $conf->add_steps($pkg); $conf->options->set(%{$args}); $step = test_step_constructor_and_description($conf); $gnucref = {}; $gnucref->{__GNUC__} = q{abc123}; ok($step->_evaluate_gcc($conf, $gnucref), "_evaluate_gcc() returned true value"); ok(! defined $conf->data->get( 'gccversion' ), "gccversion undef as expected"); is($step->result(), q{no}, "Got expected result"); $conf->replenish($serialized); ########## _evaluate_gcc(); maintaiiner; cage ########## ($args, $step_list_ref) = process_options( { argv => [ q{--maintainer}, q{--cage} ], mode => q{configure}, } ); $conf->add_steps($pkg); $conf->options->set(%{$args}); $step = test_step_constructor_and_description($conf); $gnucref = {}; $gnucref->{__GNUC__} = q{3}; $gnucref->{__GNUC_MINOR__} = q{1}; $conf->data->set( ccwarn => q{-Wfoobar -Wnofoobaz} ); ok($step->_evaluate_gcc($conf, $gnucref), "_evaluate_gcc() returned true value"); ok(defined $conf->data->get( 'gccversion' ), "gccversion defined as expected"); like($step->result(), qr/^yes/, "Got expected result"); $conf->replenish($serialized); ########## _evaluate_gcc() ########## ($args, $step_list_ref) = process_options( { argv => [ ], mode => q{configure}, } ); $conf->add_steps($pkg); $conf->options->set(%{$args}); $step = test_step_constructor_and_description($conf); $gnucref = {}; $gnucref->{__GNUC__} = q{3}; $gnucref->{__GNUC_MINOR__} = q{1}; { $conf->data->set( OSNAME_provisional => 'hpux' ); ok($step->_evaluate_gcc($conf, $gnucref), "_evaluate_gcc() returned true value"); ok(defined $conf->data->get( 'gccversion' ), "gccversion defined as expected"); is($conf->data->get( 'gccversion' ), q{3.1}, "Got expected value for gccversion"); like($step->result(), qr/^yes/, "Got expected result"); } pass("Completed all tests in $0"); ################### DOCUMENTATION ################### =head1 NAME auto/gcc-01.t - test auto::gcc =head1 SYNOPSIS % prove t/steps/auto/gcc-01.t =head1 DESCRIPTION The files in this directory test functionality used by F. The tests in this file test auto::gcc. =head1 AUTHOR James E Keenan =head1 SEE ALSO config::auto::gcc, F. =cut # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: README.pod000644000765000765 415112101554067 15212 0ustar00bruce000000000000parrot-6.6.0/src/dynpmc# Copyright (C) 2006-2012, Parrot Foundation. =pod =head1 DESCRIPTION This is a build directory for custom PMCs with a sample foo.pmc providing the Foo PMC class. =head1 CREATING A DYNAMIC PMC =over 4 =item 1 Edit/create your foo.pmc source - For details on creating PMCs, see F There are some differences you have to be aware of when creating dynamic PMCs. When declaring the dynamic PMC, you must specify the C flag, as in: pmclass TclString extends TclObject dynpmc ... { ... } Note that regular (non-dynamic) PMCs have a type id C, but dynamic PMCs obviously cannot use the same thing. Instead, a dynamically-chosen value is assigned at runtime - so, when you refer to the type of the class , you must dynamically determine the PMC type. So, while C (a builtin) has the luxury of knowing at compile time what the class number of its child C is -- for example: if (type == enum_class_String) { ... a dynamic PMC such as C must instead perform a runtime lookup of its corresponding C PMC, resulting in the more complicated: static INTVAL dynpmc_TclString; pmclass TclInt extends TclObject extends Integer dynpmc group tcl_group { void class_init() { if (pass) { dynpmc_TclString = Parrot_pmc_get_type_str(interp, Parrot_str_new(interp, "TclString", 0)); } } } Finally, if you have a group of PMCs that are interdependent, use the C syntax to trigger a group library to be built. You will use the group name as the name of the library to load using the PASM op C. pmclass Match extends Hash dynpmc group match_group { ... } and then in your .pir or .pasm file: loadlib $P0, "match_group" =item 2 Edit C and C, appending your PMC(s) to the build target. These files are processed by Configure.pl to create the real makefile fragments. Next invoke the configure script, then make: $ perl Configure.pl $ make =item 3 If anything changes inside parrot, be sure to: $ make dynpmc-clean =back pdd09_gc.pod000644000765000765 6233512101554066 15476 0ustar00bruce000000000000parrot-6.6.0/docs/pdds# Copyright (C) 2001-2010, Parrot Foundation. =head1 PDD 9: Garbage Collection Subsystem =head2 Abstract This PDD specifies Parrot's garbage collection and memory management subsystems. =head2 Definitions =head3 Garbage collection (GC) Garbage collection is a process of freeing up memory that is no longer used by the interpreter, by determining which objects will not be referenced again and can be reclaimed. =head3 Mark and sweep (MS) Starting from a known root set, the GC traces all reachable memory objects by following pointers. Objects reached in this way, and therefore visible for use by the program, are alive. Objects which are not reached in the trace are marked dead. In the second stage, sweep, all dead objects are destroyed and reclaimed. =head3 Tri-color mark and sweep Instead of a simple separation of marked (as live) and unmarked (dead), the object set is divided into three parts: white, gray, and black. The white objects are presumed dead. The gray objects have been marked as live by some other object, but haven't yet marked the objects they refer to. The black objects are live, and have marked all objects they directly refer to. In the initial run, all objects start as white and the root set is marked gray. The marking process changes white objects to gray (marking them from another gray object), and gray objects to black (when all objects they refer to are marked). When the gray set is empty, all live objects have been marked and the white set can be collected. After a collection run, all black objects are reset to white, the root set to gray, and the process begins again. The advantage of a tri-color mark over a simple mark is that it can be broken into smaller stages. =head3 Copying collection A copying GC copies objects from one memory region to another during the mark phase. At the end of the mark, all memory in the old region is dead and the whole region can be reclaimed at once. =head3 Compacting collection The compacting GC moves live objects close together in a single region in memory. This helps to elimianate fragmented free space and allows the allocation of large live objects. Compacting and copying collectors are often similar or even identical in implementation. =head3 Uncooperative An uncooperative GC is implemented as a separate module, often without affecting the remainder of the program. The programmer can write software without needing to be aware of the operations or implementation of the GC. The alternative is a cooperative GC, which is often implemented as a reference counting scheme and requires GC-related logic to be dispersed throughout the entire program. =head3 Stop-the-world A common disadvantage of a simple mark implementation is that the entire system (including all threads that use the same memory pools) must be suspended while the whole memory set is examined during marking and collection. Normal operation continues only after the whole GC cycle is performed. This can lead to arbitrarily long pauses during program execution. =head3 Incremental In order to alleviate the arbitrarily long pauses in a stop-the-world GC, the incremental GC breaks the mark and sweep process up into smaller, shorter phases. Each GC phase may still require the entire program to pause, but the pauses are shorter and more frequent. =head3 Real-time The pauses caused by GC don't exceed a certain limit. =head3 Generational The object space is divided between a young generation (short-lived temporaries) and one or more old generations. Only young generations are reset to white (presumed dead). The older generations are scanned less often because it is assumed that long-lived objects tend to live longer. =head3 Concurrent GC marking and collection runs as a separate thread, sometimes with multiple threads participating in GC. On a multi-processor machine, concurrent GC may be truly parallel. =head3 Conservative A conservative GC traces through memory looking for pointers to living objects. The GC does not necessarily have information about the layout of memory, so it cannot differentiate between an actual pointer and an integral value which has the characteristics of a pointer. The Conservative GC follows a policy of "no false negatives" and traces any value which appears to be a pointer. =head3 Precise A precise GC has intimate knowledge of the memory layout of the system and knows where to find pointers. In this way the precise collector never has any false positives. =head2 Synopsis Not applicable. =head2 Description No GC algorithm is ideal for all workloads. To support multiple workloads, Parrot provides support for pluggable uncooperative GC cores. Parrot will attempt to provide a default core which has reasonable performance for most programs. Parrot provides no built-in support for cooperative GCs. Parrot uses two separate memory allocation mechanisms: a fixed-size system for small objects of fixed size (PMC and STRING headers, etc), and a buffer allocator for arbitrary-sized objects, such as string contents. The default fixed-size memory allocator uses a SLAB-like algorithm to allocate objects from large pre-allocated pools. The default buffer allocator uses a compacting algorithm. =head2 Implementation Parrot supports pluggable garbage collection cores, so ultimately any uncooperative garbage collection model devised can run on it. Parrot really has two independent GC models, one used for objects (PMCs) and the other used for buffers (including strings). The core difference is that buffers cannot contain other buffers, so incremental marking is unnecessary. =head3 Terminology A GC run is composed of two distinct operations: Finding objects which are dead (the "trace" or "mark" phase) and freeing dead objects for later reuse (the "sweep" phase). The sweep phase is also known as the collection phase. The trace phase is less frequently known as the "dead object detection" phase. =head3 Marking Each PMC and STRING has a C member which is a bitfield of various flags. Three flags in particular are important for GC operation. C is set if the object is currently alive and active. C is set if the object is currently on the free list and is available for reallocation. A third flag, C can be used to support tricolor mark. Despite the given names of these flags, they can be used by the active GC core for almost any purpose, or they can be ignored entirely if the GC provides another mechanism for marking the various life stages of the object. These flags are typically not used outside the GC subsystem. =head4 Special PMCs =head4 Root Set The root set for the GC mark is the interpreter object and, if necessary, the C system stack. If the C system stack is traced, the GC is conservative. =head4 Initiating a mark and sweep Depending on the core in use, the mark and sweep phases may be initiated in different ways. A concurrent core would always be running in the background. The most common mechanism for a non-concurrent core is to initiate a run of the GC system when an attempt is made to allocate =head4 Object marking To mark a PMC, the C function is called. To mark a STRING, the C function is called. These functions mark the object alive, typically by setting the C flag. If the PMC contains references to other PMCs and STRINGS, it must have the C flag set. If this flag is set, the C VTABLE for that PMC is called to mark the pointers in that PMC. The custom_mark flag is ignored in STRINGs. =head4 Buffer Marking Buffers are always attached to a fixed-size header, or several headers. During the mark phase of the fixed-size objects, owned buffers are flagged as alive. At somet time after the fixed-size objects are marked, the buffer pool is compacted by moving all alive buffers to a new pool and then freeing the old pool back to the operating system. =head3 Collection When all objects have been marked, the collection phase begins. =head4 Collecting objects During the sweep phase, objects which had previously been alive but were not traced in the most recent mark phase are dead and are collected. If the C is set on a PMC, the GC will call the C VTABLE on that PMC to do custom cleanup. This flag is ignored in STRINGs. The GC does not collect dead PMCs in any particular order and does not guarantee any ordering of collection between dependant PMCs. Some GC cores may enforce some ordering or dependency recognition, but this is not guaranteed. =head3 Finalization When the interpreter object is destroyed, the GC system is finalized. During finalization, all living PMCs in the system are destroyed unconditionally and all memory owned by the interpreter is freed back to the operating system. =head3 Internal Structures A GC core is defined in memory by a structure of function pointers to various routines that perform the primitive operations of the GC. A GC core must define most of the pointers in the C<< interp->gc_sys >> structure, which is a C structure. C has the following fields: =over 4 =item C Function to finalize the GC system, by freeing all PMCs and returning all allocated memory to the operating system. =item C =item C Perform a GC mark and sweep run, or at least run a single increment of it. =item C Compact the string pool and destroy all unused buffers. =item C Mark a special PMC. A PMC is special if it has the C flag set. =item C Flag a PMC as needing early collection. =item C Initialize a new memory pool. =item C Allocate a new PMC object from the system. =item C Free a PMC object back to the system. =item C Allocate a new STRING header from the system. =item C Free a STRING object back to the system. =item C =item C =item C Determine if the given pointer is or resembles a valid PMC pointer. =item C Determine if the given pointer is or resembles a valid STRING pointer. =item C =item C Mark a PMC alive. =item C Allocate attribute storage for a PMC. The size of the attributes structure is determined from the PMCs VTABLE. =item C Free an attribute structure back to the system. =item C Allocate buffer storage for a string. =item C Resize existing string storage to fit data of the new size. =item C Allocate buffer storage for any purpose. =item C Reallocate or resize existing buffer storage. =item C Allocate storage for a fixed-size header which is not a PMC or a STRING. The contents of this structure are not marked automatically by GC. =item C Free a fixed-size structure back to the system. =item C =item C =item C =item C =item C =item C Block the GC mark from occuring. =item C Unblock the GC mark. =item C Query the blocked state of the GC mark. =item C Block the GC sweep phase. =item C Unblock the GC sweep phase. =item C Query the blocked state of the GC sweep. =item C Query information about the GC core. =back =head4 The Memory_Pools structure The C structure contains pointers to a variety of memory pools, each used for a specific purpose. Two are Var_Size_Pool pointers (memory_pool, constant_string_pool), and six are Fixed_Size_Pool structures (pmc_pool, constant_pmc_pool, constant_string_header_pool). The C structure holds function pointers for the core defined interface of the currently active GC subsystem: C, C, C. It holds various accounting information for the GC subsystem, including how many GC runs have been completed, amount of memory allocated since the last run, and total memory allocated. This accounting information is updated by the GC system. The current block level for GC mark and sweep phases is stored in the C structure. (See L.) The pointer C is reserved for use by the currently active GC subsystem (with freedom for variation between GC implementations). =head4 The Var_Size_Pool structure The C structure is a simple memory pool. It contains a pointer to the top block of the allocated pool, the total allocated size of the pool, the block size, and some details on the reclamation characteristics of the pool. =head4 The Fixed_Size_Pool structure The C structure is a richer memory pool for object allocation. It tracks details like the number of allocated and free objects in the pool, a list of free objects, and for the generational GC implementation maintains linked lists of white, black, and gray PMCs. It contains a pointer to a simple C (the base storage of the pool). It holds function pointers for adding and retrieving free objects in the pool, and for allocating objects. =head3 Internal API Each GC core provides a standard interface for interaction with the core. =head4 Initialization Each GC core declares an initialization routine as a function pointer, which is installed in F after creating C in the interpreter struct. =over 4 =item C A routine to initialize the GC system named C. The initialization code is responsible for the creation of the header pools and fills the function pointer slots in the interpreter's C member. =back =head4 Memory_Pools structure function pointers Each GC system declares 3 function pointers, stored in the Memory_Pools structure. =over 4 =item C Initialize the GC system. Install the additional function pointers into the Memory_Pools structure, and prepare any private storage to be used by the GC in the Memory_Pools->gc_private field. =item C Trigger or perform a GC run. With an incremental GC core, this may only start/continue a partial mark phase or sweep phase, rather than performing an entire run from start to finish. It may take several calls to C in order to complete an entire run of an incremental collector. For a concurrent collector, calls to this function may activate a concurrent collection thread or, if such a thread is already running, do nothing at all. The C function is called from the C function, and should not usually be called directly. C is one of: =over 4 =item C<0> Run the GC normally, including the trace and the sweep phases, if applicable. Incremental GCs will likely only run one portion of the complete GC run, and repeated calls would be required for a complete run. A complete trace of all system areas is not required. =item GC_trace_normal | GC_trace_stack_FLAG Run a normal GC trace cycle, at least. This is typically called when there is a resource shortage in the buffer memory pools before the sweep phase is run. The processor registers and any other system areas have to be traced too. Behavior is determined by the GC implementation, and might or might not actually run a full GC cycle. If the system is an incremental GC, it might do nothing depending on the current state of the GC. In an incremental GC, if the GC is already past the trace phase it may opt to do nothing and return immediately. A copying collector may choose to run a mark phase if it hasn't yet, to prevent the unnecessary copying of dead objects later on. =item GC_lazy_FLAG Do a timely destruction run. The goal is either to detect all objects that need timely destruction or to do a full collection. This is called from the Parrot run-loop, typically when a lexical scope is exited and the local variables in that scope need to be cleaned up. Many types of PMC objects, such as line-buffered IO PMCs rely on this behavior for proper operation. No system areas have to be traced. =item GC_finish_FLAG Finalize and destroy all living PMCs. This is called during interpreter destruction. The GC subsystem must clear the live state of all objects and perform a sweep in the PMC header pool, so that destructors and finalizers get called. PMCs which have custom destructors rely on this behavior for proper operation. =back =item C Called during interpreter destruction. Free used resources and memory pools. All PMCs must be swept, and PMCs with custom destroy VTABLE functions must have those called. =item C Initialize the given pool. Populates the C structure with initial values, and sets a series of function pointers for working with the pool. The function pointers used with the pool are discussed next. =back =head4 Fixed_Size_Pool function pointers Each GC core defines 4 function pointers stored in the C structures. These function pointers are used throughout Parrot to implement basic behaviors for the pool. =over 4 =item C Get a free object from the pool. This function returns one free object from the given pool and removes that object from the pool's free list. PObject flags are returned clear, except flags that are used by the garbage collector itself, if any. If the pool is a buffer header pool all other object memory is zeroed. =item C Add a freed object to the pool's free list. This function is most often called internally to the GC itself to add items to the free list after a sweep, or when a new arena is created to add the new items to the free list. It does not need to be used in this way, however. =item C Allocate a new arena of objects for the pool. Initialize the new arena and add all new objects to the pool's free list. Some collectors implement a growth factor which increases the size of each new allocated arena. =item C Reallocation for additional objects. It has the same signature as C, and in some GC cores the same function pointer is used for both. In some GC cores, C may do a GC run in an attempt to free existing objects without having to allocate new ones. This function may also call Calloc_objects> internally, to allocate objects if a GC run fails to free any old objects. =back =head4 Write Barrier Each GC core has to provide the following macros. All of these might be defined empty, for GC cores which do not use them. =over 4 =item C This macro is invoked when in aggregate C the element C is getting overwritten by C. Either C, C, or both may be NULL. =item C Similar to C. Invoked when a hash key C is inserted into hash C with value C, possibly replacing a key/value pair C and C, respectively. Any of C, C, C or C might be C. =back =head3 Blocking GC Being able to block GC is important, so newly allocated Buffers or PMCs won't be collected before they're attached to the live tree. Parrot provides locking mechanisms to prevent the GC from taking certain actions, such as marking or sweeping. GC block functions are nesting, and multiple calls to a lock function requires the same number of calls to the corresponding unlock function in order to operate the GC normally again. The following functions are used to block the GC from performing certain actions: =over 4 =item Parrot_block_GC_mark(Interp *interpreter) Block the GC mark phase for the passed interpreter, but do not block the sweep phase. In a stop-the-world collector, this will prevent the entire collection run, but in an incremental collector this will only block if the GC is in the trace state. =item Parrot_block_GC_sweep(Interp *interpreter) Block the GC sweep phase for the passed interpreter, but do not block the trace phase. =item Parrot_unblock_GC_mark(Interp *interpreter) Unblock the GC mark phase for the passed interpreter, but do not unblock a blocked sweep phase, if it is blocked using C. =item Parrot_unblock_GC_sweep(Interp *interpreter) Unblock the GC sweep phase for the passed interpreter, but do not unblock the mark phase if it has been blocked by C. =item Parrot_is_blocked_GC_mark(Interp *interpreter) Test whether the mark phase has been blocked. Notice that the sweep phase can be locked independently and cannot be determined using this function. =item Parrot_is_blocked_GC_sweep(Interp *interpreter) Test whether the sweep phase has been blocked. Notice that the mark phase can be locked independently and cannot be determined using this function. =back =head3 PMC/Buffer API =head4 Flags For PMCs and Buffers to be collected properly, you must set the appropriate flags on them. Directly manipulating these flags is not recommended because the exact values can be changed over time. A series of macros have been created in F that set and check for these flags. Always use these provided macros when you need to test or set these flags. =over 4 =item PObj_custom_destroy_FLAG The PMC has some sort of active destructor, and will have that destructor called when the PMC is destroyed. The destructor is typically called from within C. =item PObj_custom_mark_FLAG The C vtable slot will be called during the GC mark phase. The mark function must call C for all non-NULL objects (Buffers and PMCs) that PMC refers to. This flag is typically tested and the custom mark VTABLE function called from C. =item PObj_external_FLAG Set if the buffer points to memory that came from outside Parrot's memory system. =item PObj_sysmem_FLAG Set if the memory came from the system malloc. When the buffer is considered dead, the memory will be freed back to the system. =item PObj_COW_FLAG The buffer's memory is copy on write. Any changes to the buffer must first have the buffer's memory copied. The COW flag should then be removed. =back The following flags can be used by the GC subsystem: =over 4 =item PObj_live_FLAG The system considers the object to be alive for collection purposes. Objects with this flag set should never be collected, freed, destroyed, or put on the free list. =item PObj_on_free_list_FLAG The object is unused, and on the free list for later allocation. =item PObj_custom_GC_FLAG Mark the buffer as needing GC. =back =head2 References "Uniprocessor Garbage Collection Techniques" L "A unified theory of garbage collection": L "Scalable Locality-Conscious Multithreaded Memory Allocation": L "Parallel and concurrent garbage collectors": L "Region-Based Memory Management": L Dan's first musings on the GC subsystem: L Semi-timely and ordered destruction: L =cut __END__ Local Variables: fill-column:78 End: vim: expandtab shiftwidth=4: README000644000765000765 770211567202623 14405 0ustar00bruce000000000000parrot-6.6.0/ext/nqp-rx=head1 NQP - Not Quite Perl (6) NQP is Copyright (C) 2009 by Patrick R. Michaud. See F for licensing details. This is "Not Quite Perl" -- a compiler for quickly generating PIR routines from Perl6-like code. The key feature of NQP is that it's designed to be a very small compiler (as compared with, say, perl6 or Rakudo) and is focused on being a high-level way to create transformers for Parrot (especially hll compilers). In addition, unlike Rakudo, NQP attempts to restrict itself to generating code that can run in Parrot without the existence of any NQP-specific runtime libraries. =head2 Building from source NQP comes bundled with Parrot, so if you have a recent Parrot distribution you likely also have a copy of NQP. Inside of a Parrot installation NQP is known as C. To build NQP from source, you'll just need a C utility and Perl 5.8 or newer. To automatically obtain and build Parrot you may also need a Git client. To obtain NQP directly from its repository: $ git clone git://github.com/perl6/nqp-rx.git If you don't have git installed, you can get a tarball or zip of NQP from github by visiting http://github.com/perl6/nqp-rx/tree/master and clicking "Download". Then unpack the tarball or zip. Once you have a copy of NQP, build it as follows: $ cd nqp-rx $ perl Configure.pl --gen-parrot $ make This will create a "nqp" or "nqp.exe" executable in the current (nqp-rx) directory. Programs can then be run from the build directory using a command like: $ ./nqp hello.pl The C<--gen-parrot> option above tells Configure.pl to automatically download and build the most appropriate version of Parrot into a local "parrot/" subdirectory, install that Parrot into the "parrot_install/" subdirectory, and use that for building NQP. It's okay to use the C<--gen-parrot> option on later invocations of Configure.pl; the configure system will re-build Parrot only if a newer version is needed for whatever version of Rakudo you're working with. You can use C<--parrot-config=/path/to/parrot_config> instead of C<--gen-parrot> to use an already installed Parrot for building NQP. This installed Parrot must include its development environment; typically this is done via Parrot's C target or by installing prebuilt C and/or C packages. The version of the already installed Parrot must satisfy a minimum specified by the NQP being built -- Configure.pl will verify this for you. Released versions of NQP always build against the latest release of Parrot; checkouts of the HEAD revision from github often require a version of Parrot that is newer than the most recent Parrot monthly release. Once built, NQP's C target will install NQP and its libraries into the Parrot installation that was used to create it. Until this step is performed, the "nqp" executable created by C above can only be reliably run from the root of NQP's build directory. After C is performed the executable can be run from any directory (as long as the Parrot installation that was used to create it remains intact). If the NQP compiler is invoked without an explicit script to run, it enters a small interactive mode that allows statements to be executed from the command line. Each line entered is treated as a separate compilation unit, however (which means that subroutines are preserved after they are defined, but variables are not). =head2 Differences from previous version of NQP * Sub declarations are now lexical ("my") by default, use "our sub xyz() { ... }" if you want package-scoped subroutines. * The PIR q<...>; construct is gone. Use Q:PIR or pir::opcode(...) instead. * The mainline code of modules is no longer tagged as ":load :init" by default. Use INIT { ... } for any code that you want to be run automatically at startup. * Cuddled else's are no longer valid Perl 6, 'else' requires a space after it. * Double-quoted strings now interpolate $-variables. pdd26_ast.pod000644000765000765 4666112101554066 15677 0ustar00bruce000000000000parrot-6.6.0/docs/pdds# Copyright (C) 2007-2010, Parrot Foundation. =head1 PDD 26: Compiler Tools - Abstract Syntax Tree =head2 Abstract This PDD describes the node types and semantics of the Parrot Abstract Syntax Tree representation. =head2 Description The Parrot Abstract Syntax Tree (PAST) is a set of Parrot classes useful for generating an abstract semantic representation of a program written in a high level language such as Perl or Python. Once a program has been translated into its equivalent PAST representation, the Parrot Compiler Toolkit can be used to generate executable PIR or bytecode from the abstract syntax tree representation. PAST is designed to provide the common operations and semantics needed by many of the high level languages targeted by Parrot, while also being extensible to support the unique needs of specific languages. =head2 Implementation =head3 PAST::Node C is the base class for all nodes in an abstract syntax tree. Each C element has an array of children nodes (which may be empty), as well as a number of attributes and accessor methods for the node. Every PAST node has C, C, and C attributes. The C attribute is the node's name, if any, while C and C are used to identify the location of the node in the original source code. =over 4 =item init([child1, child2, ..., ] [attr1=>val1, attr2=>val2, ...]) Initialize a PAST node with the given children and attributes. Adds each child to the node (using the C method, below) and calls the appropriate accessor method for each attribute. =item new([child1, child2, ..., ] [attr1=>val1, attr2=>val2, ...]) Create a new PAST node with the same type as the invocant and initialized with the given children and attributes. Returns the newly created node. =item push(child) Add C to the end of the node's array of children. =item pop() Remove the last child from the node's array of children. Returns the child. =item unshift(child) Add C to the beginning of the node's array of children. =item shift() Remove the first child from the node's array of children. Returns the child. =item iterator( ) Return a newly initialized C for the node's list of children. =item node(val) Set the invocant's C and C attributes to be the same as C. If C is another PAST node, then C and C are simply copied from that node. Otherwise, C is assumed to be a C object (e.g., from PGE) and the source and position information are obtained from that. =item name([value]) Accessor method -- sets/returns the C attribute of the node. =item named([value]) Accessor method -- for nodes that are being used as named arguments, sets/returns the name to be associated with the argument. =item flat([value]) Accessor method -- sets/returns the "flatten" flag on nodes being used as arguments. =item attr(STR attrname, PMC value, INT has_value) Helper method for writing accessors -- if C is true then set the node's value of C to C. Returns the (resulting) value of C for the invocant. =back =head3 PAST::Stmts C is simply a C used to contain a sequence of other PAST nodes to be evaluated. It has no specific methods or attributes. =head3 PAST::Val C nodes represent constant values in the abstract syntax tree. The C attribute represents the value of the node itself. =over 4 =item value([value]) Accessor method to get/set the constant value for this node. =item returns([typename]) Get/set the type of value to be generated by this node. If not specified, the type is taken from the type of the value attribute given above. =back =head3 PAST::Var C nodes represent variable-like items within the abstract syntax tree. The C attribute (inherited from C) identifies the name of the variable as given by the high level language program. The other attributes for C nodes provide the details of how the variable is defined and accessed. =over 4 =item scope([value]) A variable node's "scope" indicates how the variable is to be defined or accessed within the program. The available scopes include: =over 4 =item "lexical" Lexical variables are scoped to the C in which they are declared, including any nested blocks. If the node's C attribute is true, then this node defines a new lexical variable within the current block. Otherwise, the node refers to a lexical variable already declared in the current or outer block. =item "package" Package variables represent global or namespace-managed variables in the program. The node's C attribute may be used to explicitly identify the namespace of the variable, otherwise it is assumed to be within the namespace of the C containing the node. =item "parameter" Parameter variables are the formal arguments to subroutine and methods, typically represented as C nodes. The parameter's lexical name is given by the node's C attribute. Positional parameters are defined by the order in which they appear in the C node, named parameters have values for the C attribute. Optional parameters are identified via the C attribute (see below) indicating how the parameter is to be initialized if not supplied by the caller. Slurpy parameters are indicated via the node's C attribute. =item "keyed" Keyed variables represent the elements of aggregates such as arrays and hashes. Nodes representing keyed elements have two children; the first child is the PAST representation of the aggregate, and the second child is the PAST representation of the key or index. The C attribute below may be used to specify how to generate the aggregate if it doesn't already exist. =item "attribute" Attribute variables represent object attributes (in some languages they're called "member variables"). The attribute's name is given by the node's C attribute. Nodes representing attribute variables have an optional child, representing the object to which the attribute belongs. If this child is not present, the attribute is assumed to belong to the current invocant, indicated by the special variable C (which is implicitly passed to all subs that are flagged as a C<:method> or C<:vtable>). =item "register" Register variables are limited in scope to the C node in which they are declared. This is different from the C scope, which I any nested C nodes. If the node's C attribute is true, then this node defines a new register variable within the current block. Register variables are mapped to Parrot registers, and are useful for handling the PIR pseudo-variable C and storing intermediate results. Names given to the C attribute must conform to rules for PIR identifiers. If no C attribute is set, Parrot registers are used. In this case, setting the C does not have any effect. =back If C is not explicitly provided in the node, then PAST will look at the local symbol tables of any outer C nodes to try to determine the scope of the named variable. If this still does not result in a scope, then 'lexical' is assumed. =item viviself([value]) Accessor method for the C attribute, which specifies how uninitialized variables are to be initialized when first used. The C attribute may be either a string or array representing a type (e.g., C), or it may be a PAST representation for generating the variable's initial value. =item vivibase([value]) Accessor method for the C attribute, which specifies how the base portion of aggregate variables (see "keyed scope" above) is to be created if it doesn't already exist. C may either be a string or array representing the type of the newly created aggregate, or it may be a PAST representation for generating the aggregate. =item isdecl([flag]) Accessor method for the C attribute. A true value of C indicates that the variable given by this node is being created at this point within the current lexical scope. Otherwise, the node refers to a pre-existing variable (possibly from an outer scope). =item lvalue([flag]) Accessor method for the C attribute, which indicates whether this variable is being used in an lvalue context. =item slurpy([flag]) Accessor method for the C attribute of parameter variables. A true value of C indicates that the parameter variable given by this node is to be created as a slurpy parameter (consuming all remaining arguments passed in). Named slurpy parameters are indicated by having a non-empty C attribute and a true value of C. =back =head3 PAST::Op C nodes represent the operations in an abstract syntax tree. The primary function of the node is given by its C attribute, secondary functions may be indicated by the node's C, C, or other attributes as given below. =over 4 =item pasttype([value]) Accessor method for the node's C attribute. The C is the primary indicator of the type of operation to be performed, the operands are typically given as the children of the node. Defined values of C are: =over 4 =item chain A short-circuiting chain of operations. In a sequence of nodes with pasttype 'chain', the right operand of a node serves as the left operand of its parent. Each node is evaluated only once, and the first false result short-circuits the chain. In other words, C<< $x < $y < $z >> is true only if $x < $y and $y < $z, but $y only gets evaluated once. =item copy Copy the value of the node's second child into the variable expression given by its first child. =item bind Bind the variable given by the node's first child to the value given by its second child. =item if The first, second, and third children represent the "condition", "then", and "else" parts of a conditional expression. The first child is evaluated; if the result is true then the second child is evaluated and returned as the result of the C node, otherwise the third child is evaluated and returned as the result. This implements the standard if-then-else logic needed by most higher level languages, and can also be used for implementing the ternary operator. If the node is missing its second ("then") or third ("else") child, then the result of the condition is used as the corresponding result of the operation. This makes it easy to implement the "short-circuit and" operator commonly used in many high level languages. For example, the standard C<&&> operator may be implemented using an "if" node, where the left operand is the first (condition) child, the right operand is the second (then) child, and the third child is left as null or uninitialized. It's also possible to build a "short-circuit or" (C<||>) operator using this pasttype, by setting the left operand to C<||> as the first child and the right operand as the I child (leaving the second child as null). However, it's probably simpler to use the "unless" type as described below. =item unless Same as C above, except that the second child is evaluated if the first child evaluates to false and the third child is evaluated if the first child evaluates to true. The C type can be used to implement "short-circuit or" semantics; simply set the first child to the left operand and the second child to the right operand, leaving the third child empty or uninitialized. If the first child evaluates to true it is returned as the result of the operation, otherwise the second child is evaluated and returned as the result. =item while Evaluate the first child (condition), if the result is true then evaluate the second child (body) and repeat. =item until Evaluate the first child (condition), if the result is false then evaluate the second child (body) and repeat. =item repeat_while, repeat_until Same as C and C above, except the second child is evaluated before the conditional first child is evaluated for continuation of the loop. =item for Iterate over the first child in groups of elements given by C (default 1). For each iteration, invoke the second child, passing the elements as parameters. =item call Call the subroutine given by the C attribute, passing the results of any child nodes as arguments. If the node has no C attribute, then the first child is assumed to evaluate to a callable subroutine, and any remaining children are used as arguments. =item callmethod Invoke the method given by C on the first child, passing the results of any child nodes as arguments. If the node has no C attribute, then the first child is evaluated as a method to be called, the second child is the invocant, and any remaining children are arguments to the method call. =item pirop Execute the PIR opcode given by the C attribute. See the C method below for details. This is also the default behavior when a C attribute is set and C is not. =item inline Execute the sequence of PIR statements given by the node's C attribute (a string). See the C method below for details. =item return Generate a return exception, using the first child (if any) as a return value. =item try Evaluates the first child, if any exceptions occur then they are handled by the code given by the second child (if any). =item xor Evaluate the child nodes looking for exactly one true result to be returned. If two true results are encountered, the operation immediately short-circuits and returns false. Otherwise, after all children have been evaluated the result of any true child is used as the result of the operation, or the result of the last child if none of the children evaluated to true. =back =item pirop([opcode]) Get/set the PIR opcode to be executed for this node. Internally the PAST and POST (Parrot Opcode Syntax Tree) implementations understand the register types available for common PIR operations and will handle any needed register or constant conversion of operands automatically. Note that except for the C opcode, any destination is typically generated automatically and should not be explicitly given as a child operand to the node. The table of PIR opcodes that PAST "knows" about is given in F . =item lvalue([flag]) Get/set whether this node is an lvalue, or treats its first child as an lvalue (e.g., for assignment). =item inline([STRING code]) Get/set the code to be used for inline PIR when C is set to "inline". The C argument is PIR text to be inserted in the final generated code sequence. Sequences of "%0", "%1", "%2", ... "%9" in C are replaced with the evaluated results of the first, second, third, ..., tenth children nodes. (If you need more than ten arguments to your inline PIR, consider making it a subroutine call instead.) The register to hold the result of the inline PIR operation is given by "%r", "%t", or "%u" in the C string: %r - Generate a unique PMC register for the result. %t - Generate a unique PMC register for the result, and initialize it with an object of type C {{Pm: or possibly C }} before the execution of the inline PIR. %u - Re-use the first child's PMC (%0) if it's a temporary result, otherwise same as %t above. If none of %r, %t, or %u appear in C, then the first child's (%0) is used as the result of this operation. =back =head3 PAST::Block C nodes represent lexical scopes within an abstract syntax tree, and roughly translate to individual Parrot subroutines. A C node nested within another C node acts like a nested lexical scope. If the block has a C attribute, that becomes the name of the resulting Parrot sub. Otherwise, a unique name is automatically generated for the block. Each PAST::Block node can maintain its own local symbol table, see the C method below. =over 4 =item blocktype([type]) Get/set the type of the block to C. The currently understood values are 'declaration', 'immediate', and 'method'. 'Declaration' indicates that a block is simply being defined at this point, the result of the node is a reference to the block. A C of 'immediate' indicates a block that is to be immediately executed when it is evaluated in the AST, and the result of the last operation is used as the return value for the block. =item closure([value]) Get/set the closure flag for the block to C. If the closure flag on a (non-immediate) block is true, then the node returns a reference to a clone of the block that has captured the current lexical context. =item namespace([value]) Get/set the namespace for this particular block (and any nested blocks that do not explicitly provide a namespace). C may either be a simple string or an array of strings representing a nested namespace. =item hll([value]) Get/set the HLL namespace for this block (and any nested blocks that do not explicitly provide a C). =item symbol(name, [attr1 => val1, attr2 => val2, ...]) Each PAST::Block node can use the C method to maintain its own compile-time notion of a local symbol table. Each value of C is given its own hash to hold information about that symbol for the block (i.e., the symbol table acts like a hash of hashes indexed by symbol name). If the C method is called with named arguments, then the method sets the entries in the hash corresponding to C in the block's symbol table. If C is called with just a single C argument, then the current hash for local symbol C is returned. HLLs are free to place any values in the symbol hashes that may be useful. However, the C entry for a symbol is typically used to provide the C attribute for any nested C nodes that do not provide an explicit C attribute. =item symbol_defaults([attr1 => val1, attr2 => val2, ...]) Sets default attributes for symbols that aren't explicitly given by the C method above. For example, an abstract syntax tree can use this method on a top-level C to specify the C attribute to be used for all variable nodes that don't otherwise provide one. =item subid([value]) Get/set the unique subid to be used for this block. If no subid is explicitly set, a unique subid is randomly generated for the block. =item pirflags([value]) Get/set any PIR flags to be used when generating the block. =item compiler([compiler_name]) Specify that the children nodes of this block are to be compiled using C instead of being treated as standard PAST nodes. This is useful when a program may contain components of code written in other HLLs. For example, the C compiler uses this feature to use PGE to compile pre-parsed Perl 6 regular expressions, rather than trying to represent the semantics of those expressions in PAST itself. When code is generated from a C node having a C attribute, the compiler is invoked with C and C arguments so that any generated subs can have names and lexical scoping appropriate to the block (it's the responsibility of the external compiler to support this). =back =head3 PAST::CompUnit C nodes are used for the abstract representation of compilation units. Specific attributes and semantics are yet to be determined. =head2 References None. =cut __END__ Local Variables: fill-column:78 End: vim: expandtab shiftwidth=4: Util.pm000644000765000765 335412356767111 15713 0ustar00bruce000000000000parrot-6.6.0/lib/Parrot/Test# Copyright (C) 2008, Parrot Foundation. =head1 NAME Parrot::Test::Util - utilities for Parrot tests =head1 SYNOPSIS use Parrot::Test::Util 'create_tempfile'; my ($FOO, $temp_pir) = create_tempfile( SUFFIX => '.pir', UNLINK => 1 ); =head1 DESCRIPTION This module provides basic utilities for Parrot test scripts. So far, there's only one utility, C, which must be requested for import. =head1 AUTHOR Written by Jerry Gay. =cut package Parrot::Test::Util; use strict; use warnings; use File::Temp 'tempfile'; use Exporter; our @ISA = qw( Exporter ); our @EXPORT_OK = qw( create_tempfile ); =head1 Functions =over 4 =item C Creates a tempfile using File::Temp::tempfile, passing parameters through. Returns a Perl-friendly path using forward-slashes, rather than a platform- specific path that may contain unescaped backslashes which may be interpreted as (likely invalid) unicode escape codes. =cut sub create_tempfile { # platform quirks (GH 1077, cygwin 5.18 - Cwd 3.40 only): # we cannot get Cwd::abs_path on a non-existing file, and we don't # need to unlink it. my ($filehandle, $filename, $winfixup); if ($^O eq 'cygwin' and join(' ',@_) eq 'UNLINK 1 OPEN 0') { ($filehandle, $filename) = tempfile('UNLINK' => 0, 'OPEN' => 0); } else { ($filehandle, $filename) = &tempfile; } # expand msys virtual paths if($^O eq 'msys') { my $tmpdir = `cd /tmp && pwd -W`; chomp $tmpdir; $filename =~ s/^\/tmp\//$tmpdir\//; } $filename =~ s/\\/\//g; return ($filehandle, $filename); } =back =cut 1; # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: packfilerawsegment.t000644000765000765 632711533177645 16574 0ustar00bruce000000000000parrot-6.6.0/t/pmc#!./parrot # Copyright (C) 2009-2010, Parrot Foundation. =head1 NAME t/pmc/packfilerawsegment.t - test the PackfileRawSegment PMC =head1 SYNOPSIS % make test_prep % prove t/pmc/packfilerawsegment.t =head1 DESCRIPTION Tests the PackfileRawSegment PMC. =cut # Having some known data would be helpful, here. For now, just make sure # the value returned by elements() is greater than zero, and that # get_integer_keyed_int doesn't return all zeroes either. .include 't/pmc/testlib/packfile_common.pir' .include 'packfile_segments.pasm' .sub 'main' :main .include 'test_more.pir' plan(7) test_elements() test_get_integer() test_push_integer() test_type() .end # PackfileRawSegment.elements .sub 'test_elements' .local pmc pf, pfdir, pfseg push_eh load_error pf = _pbc() pop_eh pfdir = pf.'get_directory'() pfseg = '_find_segment_by_prefix'(pf, 'BYTECODE') $I0 = elements pfseg ok($I0, 'PackfileRawSegment contains some data') .return() load_error: .get_results($P0) pop_eh report_load_error($P0, 'PackfileRawSegment contains some data') .return() .end # PackfileRawSegment.get_integer_keyed_int .sub 'test_get_integer' .local pmc pf, pfdir, pfseg push_eh load_error pf = _pbc() pop_eh pfdir = pf.'get_directory'() pfseg = '_find_segment_by_prefix'(pf, 'BYTECODE') $I0 = 0 $I1 = pfseg[0] $I0 = $I0 + $I1 $I1 = pfseg[1] $I0 = $I0 + $I1 $I1 = pfseg[2] $I0 = $I0 + $I1 $I1 = pfseg[3] $I0 = $I0 + $I1 $I1 = pfseg[4] $I0 = $I0 + $I1 ok($I0, "PackfileRawSegment.get_integer_keyed_int returns some data") .return() load_error: .get_results($P0) pop_eh report_load_error($P0, "PackfileRawSegment.get_integer_keyed_int returns some data") .return() .end # PackfileRawSegment.push_integer .sub 'test_push_integer' .local pmc pfseg pfseg = new ['PackfileRawSegment'] push pfseg, 0x1d1 push pfseg, 0x002 $I0 = pfseg[0] is($I0, 0x1d1, "PackfileRawSegment.push_integer (1)") $I0 = pfseg[1] is($I0, 0x002, "PackfileRawSegment.push_integer (2)") .end # PackfileRawSegment.type .sub 'test_type' .local pmc pf, pfdir, pfseg, hash, it push_eh load_error pf = _pbc() pop_eh pfdir = pf.'get_directory'() hash = new ['Hash'] # annotations.pbc contains all available segments. -1 for directory and unknown. # So, in hash we should have 5 elements. it = iter pfdir loop: unless it goto done $S0 = shift it $P0 = pfdir[$S0] $I0 = $P0.'type'() hash[$I0] = 1 goto loop done: $I0 = elements hash is($I0, 3, "Got all types of Packfile segments") # Now create RawSegment and set type. $P0 = new ['PackfileRawSegment'] $I0 = $P0.'type'() is($I0, .PF_BYTEC_SEG, "Default type is PF_BYTEC_SEG") $P0.'type'(.PF_DEBUG_SEG) $I0 = $P0.'type'() is($I0, .PF_DEBUG_SEG, "Type successfully changed") .return() load_error: .get_results($P0) pop_eh report_load_error($P0, "can't run test_type tests") skip(2, "can't run test_type tests") .return() .end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: TODO000644000765000765 53311533177634 16462 0ustar00bruce000000000000parrot-6.6.0/examples/languages/abcStatements: * break -- This statement causes a forced exit of the most recent enclosing while statement or for statement. * continue -- The continue statement (an extension) causes the most recent enclosing for statement to start the next iteration. * halt -- TODO? (extension) * return -- Return the value of the expression from a function. keyed.t000644000765000765 125511533177643 16755 0ustar00bruce000000000000parrot-6.6.0/t/compilers/imcc/syn#!perl # Copyright (C) 2001-2005, Parrot Foundation. use strict; use warnings; use lib qw( . lib ../lib ../../lib ); use Test::More; use Parrot::Config; use Parrot::Test tests => 1; ############################## SKIP: { skip( "experimental", 1 ); pir_output_is( <<'CODE', <<'OUTPUT', "add_keyed" ); .sub test :main new P0, 'Array' new P1, 'Array' new P2, 'Array' P0 = 1 P1 = 2 P2 = 11 set P1[1], 32 set P2[10], 10 add P0[0], P1[1], P2[10] set P4, P0[0] print P4 print "\n" end .end CODE 42 OUTPUT } # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: takfp.pir_output000644000765000765 511466337261 20355 0ustar00bruce000000000000parrot-6.6.0/examples/shootout14.0 blue_rect.pl000644000765000765 322512101554066 16371 0ustar00bruce000000000000parrot-6.6.0/examples/sdl# Copyright (C) 2001-2012, Parrot Foundation. =head1 NAME blue_rect.pl - draw a blue rectangle using the SDL library and NQP =head1 SYNOPSIS To run this file, execute the following command from the Parrot directory: $ ./parrot compilers/nqp/nqp.pbc examples/sdl/blue_rect.pl =head1 DESCRIPTION This is a Perl script which draws a blue rectangle, using the SDL library and NQP. =cut # load the SDL class libraries PIR q< load_bytecode 'SDL/App.pir' >; PIR q< load_bytecode 'SDL/Rect.pir' >; PIR q< load_bytecode 'SDL/Color.pir' >; # make sure NQP has class protoobjects for the SDL classes Protomaker.new_proto('SDL::App'); Protomaker.new_proto('SDL::Rect'); Protomaker.new_proto('SDL::Color'); # create an SDL::App object my $app := SDL::App.new(); $app.init( :height(480), :width(640), :bpp(0), :flags(1) ); # fetch the SDL::Surface representing the main window my $main_screen := $app.surface(); # create an SDL::Rect object my $rect := SDL::Rect.new(); $rect.init( :height(100), :width(100), :x(270), :y(190) ); # create an SDL::Color object my $color := SDL::Color.new(); $color.init( :r(0), :g(0), :b(255) ); # draw the rectangle to the surface and update it $main_screen.fill_rect( $rect, $color ); $main_screen.update_rect( $rect ); # pause for people to see it PIR q< sleep 2 >; # and that's it! $app.quit(); =head1 AUTHOR blue_rect.pl created by Patrick R. Michaud (pmichaud@pobox.com) based on blue_rect.pir by chromatic (chromatic at wgz dot org). =head1 COPYRIGHT Copyright (C) 2004-2007, Parrot Foundation. =cut # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: cfg.h000644000765000765 1107412233541455 15335 0ustar00bruce000000000000parrot-6.6.0/compilers/imcc/* * Copyright (C) 2002-2011, Parrot Foundation. */ /* Data structures: */ /* Two-way linked list of predecessors and successors */ #ifndef PARROT_CFG_H_GUARD #define PARROT_CFG_H_GUARD typedef struct _edge { struct _basic_block *from; struct _basic_block *to; struct _edge *pred_next; struct _edge *succ_next; struct _edge *next; } Edge; typedef struct _basic_block { Instruction *start; /* First instruction in basic block */ Instruction *end; /* Last instruction in basic block */ Edge *pred_list; Edge *succ_list; int loop_depth; unsigned int index; /* on bb_list*/ int flag; } Basic_block; enum block_enum_flags_t { BB_IS_SUB = 1 << 0 }; typedef struct _loop_info { Set *loop; /* loop set containing bb's */ Set *exits; /* blocks that exit the loop */ int depth; /* depth of this loop */ unsigned int n_entries; /* nr of entries to this loop */ unsigned int header; /* header block of loop */ unsigned int preheader; /* preheader block of loop, if 1 entry point */ unsigned int size; /* no of blocks in loop */ } Loop_info; /* Functions: */ /* HEADERIZER BEGIN: compilers/imcc/cfg.c */ /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */ void build_cfg(ARGMOD(imc_info_t *imcc), ARGMOD(IMC_Unit *unit)) __attribute__nonnull__(1) __attribute__nonnull__(2) FUNC_MODIFIES(*imcc) FUNC_MODIFIES(*unit); void clear_basic_blocks(ARGMOD(IMC_Unit *unit)) __attribute__nonnull__(1) FUNC_MODIFIES(*unit); void compute_dominance_frontiers( ARGMOD(imc_info_t *imcc), ARGMOD(IMC_Unit *unit)) __attribute__nonnull__(1) __attribute__nonnull__(2) FUNC_MODIFIES(*imcc) FUNC_MODIFIES(*unit); void compute_dominators(ARGMOD(imc_info_t *imcc), ARGMOD(IMC_Unit *unit)) __attribute__nonnull__(1) __attribute__nonnull__(2) FUNC_MODIFIES(*imcc) FUNC_MODIFIES(*unit); PARROT_WARN_UNUSED_RESULT PARROT_PURE_FUNCTION int edge_count(ARGIN(const IMC_Unit *unit)) __attribute__nonnull__(1); void find_basic_blocks( ARGMOD(imc_info_t *imcc), ARGMOD(IMC_Unit *unit), int first) __attribute__nonnull__(1) __attribute__nonnull__(2) FUNC_MODIFIES(*imcc) FUNC_MODIFIES(*unit); void find_loops(ARGMOD(imc_info_t *imcc), ARGMOD(IMC_Unit *unit)) __attribute__nonnull__(1) __attribute__nonnull__(2) FUNC_MODIFIES(*imcc) FUNC_MODIFIES(*unit); PARROT_WARN_UNUSED_RESULT PARROT_PURE_FUNCTION int natural_preheader( ARGIN(const IMC_Unit *unit), ARGIN(const Loop_info *loop_info)) __attribute__nonnull__(1) __attribute__nonnull__(2); void search_predecessors_not_in( ARGIN(const Basic_block *node), ARGMOD(Set *s)) __attribute__nonnull__(1) __attribute__nonnull__(2) FUNC_MODIFIES(*s); #define ASSERT_ARGS_build_cfg __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(imcc) \ , PARROT_ASSERT_ARG(unit)) #define ASSERT_ARGS_clear_basic_blocks __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(unit)) #define ASSERT_ARGS_compute_dominance_frontiers __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(imcc) \ , PARROT_ASSERT_ARG(unit)) #define ASSERT_ARGS_compute_dominators __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(imcc) \ , PARROT_ASSERT_ARG(unit)) #define ASSERT_ARGS_edge_count __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(unit)) #define ASSERT_ARGS_find_basic_blocks __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(imcc) \ , PARROT_ASSERT_ARG(unit)) #define ASSERT_ARGS_find_loops __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(imcc) \ , PARROT_ASSERT_ARG(unit)) #define ASSERT_ARGS_natural_preheader __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(unit) \ , PARROT_ASSERT_ARG(loop_info)) #define ASSERT_ARGS_search_predecessors_not_in __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(node) \ , PARROT_ASSERT_ARG(s)) /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */ /* HEADERIZER END: compilers/imcc/cfg.c */ #endif /* PARROT_CFG_H_GUARD */ /* * Local variables: * c-file-style: "parrot" * End: * vim: expandtab shiftwidth=4 cinoptions='\:2=2' : */ object-meths.t000644000765000765 4310112101554067 15301 0ustar00bruce000000000000parrot-6.6.0/t/pmc#! perl # Copyright (C) 2001-2010, Parrot Foundation. use strict; use warnings; use lib qw( . lib ../lib ../../lib ); use Test::More; use Parrot::Test tests => 38; =head1 NAME t/pmc/object-meths.t - Object Methods =head1 SYNOPSIS % prove t/pmc/object-meths.t =head1 DESCRIPTION Tests PMC object methods. =cut pasm_error_output_like( <<'CODE', <<'OUTPUT', "callmethodcc - unknown method" ); .pcc_sub :main main: newclass P2, "Foo" set S0, "nada" callmethodcc P2, S0 print "should never reach here\n" end CODE /Method 'nada' not found for invocant of class 'Foo'/ OUTPUT pasm_error_output_like( <<'CODE', <<'OUTPUT', "callmethod (STR) - unknown method" ); .pcc_sub :main main: newclass P2, "Foo" set S1, "nada" callmethod P2, S1, P1 print "should never reach here\n" end CODE /Method 'nada' not found for invocant of class 'Foo'/ OUTPUT pasm_error_output_like( <<'CODE', <<'OUTPUT', "callmethodcc - unknown method" ); .pcc_sub :main main: newclass P2, "Foo" set S0, "nada" callmethodcc P2, S0 print "should never reach here\n" end CODE /Method 'nada' not found for invocant of class 'Foo'/ OUTPUT pasm_error_output_like( <<'CODE', <<'OUTPUT', "callmethodcc (STR) - unknown method" ); .pcc_sub :main main: newclass P2, "Foo" set S1, "nada" callmethodcc P2, S1 print "should never reach here\n" end CODE /Method 'nada' not found for invocant of class 'Foo'/ OUTPUT pir_output_is( <<'CODE', <<'OUTPUT', "callmethod 1" ); .sub main :main $P2 = newclass "Foo" $P3 = new $P2 set $S0, "meth" print "main\n" $P3.'meth'() print "back\n" end .end .namespace ["Foo"] .sub meth :method print "in meth\n" .return () .end CODE main in meth back OUTPUT pir_output_is( <<'CODE', <<'OUTPUT', "can class" ); .sub main :main $P2 = newclass "Foo" $P3 = new ['Sub'] # Add a method to the class manually $P2.'add_method'("meth", $P3) # Classes only report 'can' for class methods, not instance methods can $I0, $P2, "meth" print $I0 print "\n" end .end CODE 0 OUTPUT pir_output_is( <<'CODE', <<'OUTPUT', "can object" ); .sub main :main $P2 = newclass "Foo" $P4 = new ['Foo'] $P3 = new ['Sub'] # Add a method to the class manually $P2.'add_method'("meth", $P3) can $I0, $P4, "meth" print $I0 print "\n" can $I0, $P4, "no_such_meth" print $I0 print "\n" end .end CODE 1 0 OUTPUT pir_output_is( <<'CODE', <<'OUTPUT', "constructor" ); .sub main :main $P1 = newclass "Foo" new $P3, ['Foo'] print "ok 2\n" end .end .namespace ["Foo"] .sub init :method :vtable print "ok 1\n" .end CODE ok 1 ok 2 OUTPUT pir_output_is( <<'CODE', <<'OUTPUT', "constructor - init attr" ); .sub 'main' :main newclass $P1, "Foo" addattribute $P1, ".i" new $P3, ['Foo'] say "ok 2" say $P3 end .end .namespace ["Foo"] .sub 'init' :vtable :method say "ok 1" new $P10, ['Integer'] set $P10, 42 setattribute self, ".i", $P10 .return() .end .sub 'get_string' :vtable :method getattribute $P10, self, ".i" .return( $P10 ) .end CODE ok 1 ok 2 42 OUTPUT pir_output_is( <<'CODE', <<'OUTPUT', "constructor - parents" ); .sub 'main' :main newclass $P1, "Foo" subclass $P2, $P1, "Bar" subclass $P3, $P2, "Baz" new $P3, ['Baz'] new $P3, ['Bar'] _sub() say "done" end .end .namespace ["Foo"] .sub 'init' :vtable :method say "foo_init" typeof $S0, self say $S0 .end .namespace ["Bar"] .sub 'init' :vtable :method say "bar_init" .end .namespace ["Baz"] .sub 'init' :vtable :method say "baz_init" .end .namespace [] # main again .sub '_sub' say "in sub" .end CODE foo_init Baz bar_init baz_init foo_init Bar bar_init in sub done OUTPUT pir_output_is( <<'CODE', <<'OUTPUT', "methods: self" ); .sub _main :main .local pmc A .local pmc B newclass A, "A" newclass B, "B" new A, ['A'] new B, ['B'] setprop A, "B", B A."foo"() B."foo"() end .end .namespace ["A"] .sub foo :method .local pmc B print "A::foo\n" getprop B, self, "B" self."blah"() B."blah"() self."blah"() .end .sub blah :method print "A::blah\n" .end .namespace ["B"] .sub foo :method print "B::foo\n" .end .sub blah :method print "B::blah\n" .end CODE A::foo A::blah B::blah A::blah B::foo OUTPUT pir_output_is( <<'CODE', <<'OUTPUT', "methods: self w arg" ); .sub _main :main .local pmc A .local pmc B newclass A, "A" newclass B, "B" new A, ['A'] new B, ['B'] A."foo"(B) B."foo"() end .end .namespace ["A"] .sub foo :method .param pmc B print "A::foo\n" self."blah"() B."blah"() self."blah"() .end .sub blah :method print "A::blah\n" .end .namespace ["B"] .sub foo :method print "B::foo\n" .end .sub blah :method print "B::blah\n" .end CODE A::foo A::blah B::blah A::blah B::foo OUTPUT pir_output_is( <<'CODE', <<'OUTPUT', "methods: self w arg and ret" ); .sub _main :main .local pmc A .local pmc B newclass A, "A" newclass B, "B" new A, ['A'] new B, ['B'] .local pmc r r = A."foo"(B) r."foo"() end .end .namespace ["A"] .sub foo :method .param pmc B print "A::foo\n" self."blah"() B."blah"() self."blah"() .begin_return .set_return B .end_return .end .sub blah :method print "A::blah\n" .end .namespace ["B"] .sub foo :method print "B::foo\n" .end .sub blah :method print "B::blah\n" .end CODE A::foo A::blah B::blah A::blah B::foo OUTPUT SKIP: { skip( "currently broken", 1 ); pasm_output_is( <<'CODE', <<'OUTPUT', "exceptions and different runloops" ); .pcc_sub :main main: _main: push_eh eh newclass P0, "Foo" print "new\n" new P2, ['Foo'] eh: print "back in main\n" end .namespace ["Foo"] .pcc_sub __init: print "in __init\n" # raise an exception callmethodcc self, "qux" print "never\n" returncc CODE new in __init back in main OUTPUT } pir_output_is( <<'CODE', <<'OUTPUT', "find_method" ); .sub main :main $P3 = newclass "Foo" $P2 = new $P3 $P0 = find_method $P2, 'meth' say 'main' $P2.$P0() say 'back' $I0 = defined $P0 say $I0 end .end .namespace ["Foo"] .sub meth :method say 'in meth' .end CODE main in meth back 1 OUTPUT pir_output_is( <<'CODE', <<'OUTPUT', 'find_method builtin PMC class' ); .sub main :main $P0 = new [ 'String' ] $P0 = 'AbC' $P1 = find_method $P0, 'reverse' $P2 = $P0.$P1() say $P2 $I0 = defined $P1 say $I0 .end CODE CbA 1 OUTPUT pasm_error_output_like( <<'CODE', <<'OUTPUT', "find_method - unknown method" ); .pcc_sub :main main: newclass P2, "Foo" set S0, "nada" find_method P0, P2, S0 print "nope\n" end CODE /Method 'nada' not found for invocant of class 'Foo'/ OUTPUT pir_output_is( <<'CODE', <<'OUTPUT', "constructor - diamond parents" ); # # A B A E # \ / \ / # C D # \ / # \ / # F .sub 'main' :main newclass $P1, "A" newclass $P2, "B" subclass $P3, $P1, "C" addparent $P3, $P2 subclass $P4, $P1, "D" newclass $P5, "E" addparent $P4, $P5 subclass $P6, $P3, "F" addparent $P6, $P4 print "F isa D " isa $I0, $P6, "D" say $I0 print "D isa F " isa $I0, $P4, "F" say $I0 print "F isa C " isa $I0, $P6, "C" say $I0 print "C isa F " isa $I0, $P3, "F" say $I0 print "F isa E " isa $I0, $P6, "E" say $I0 print "E isa F " isa $I0, $P5, "F" say $I0 print "F isa A " isa $I0, $P6, "A" say $I0 print "A isa F " isa $I0, $P1, "F" say $I0 print "F isa B " isa $I0, $P6, "B" say $I0 print "B isa F " isa $I0, $P2, "F" say $I0 print "C isa A " isa $I0, $P3, "A" say $I0 print "A isa C " isa $I0, $P1, "C" say $I0 print "D isa A " isa $I0, $P4, "A" say $I0 print "A isa D " isa $I0, $P1, "D" say $I0 say "new F" new $P16, ['F'] say "done" .end .namespace ["A"] .sub 'init' :vtable :method say "A init" .end .namespace ["B"] .sub 'init' :vtable :method say "B init" .end .namespace ["C"] .sub 'init' :vtable :method say "C init" .end .namespace ["D"] .sub 'init' :vtable :method say "D init" .end .namespace ["E"] .sub 'init' :vtable :method say "E init" .end .namespace ["F"] .sub 'init' :vtable :method say "F init" .end CODE F isa D 1 D isa F 0 F isa C 1 C isa F 0 F isa E 1 E isa F 0 F isa A 1 A isa F 0 F isa B 1 B isa F 0 C isa A 1 A isa C 0 D isa A 1 A isa D 0 new F E init B init A init D init C init F init done OUTPUT pir_output_is( <<'CODE', <<'OUTPUT', "constructor - vtable override" ); .sub main :main $P0 = newclass 'Foo' $P1 = subclass 'Foo', 'Bar' $P2 = new ['Bar'] .end .namespace ['Foo'] .sub init :vtable :method print "foo init\n" .end .namespace ['Bar'] .sub init :vtable :method print "bar init\n" .end CODE foo init bar init OUTPUT pir_output_is( <<'CODE', <<'OUTPUT', "same method name in two namespaces" ); .namespace ["A"] .sub foo :method .param int i .begin_return .end_return .end .namespace ["B"] .sub foo :method .param int i .begin_return .end_return .end .namespace [] .sub _main :main print "ok\n" .end CODE ok OUTPUT pir_output_is( <<'CODE', <<'OUTPUT', "Bug in method calling with nonconst keys" ); .sub _main :main newclass $P0, "Foo" new $P1, ['Foo'] $I1 = $P1["foo"] $S0 = "foo" $I1 = $P1[$S0] end .end .namespace ["Foo"] .sub get_integer_keyed :vtable :method .param pmc key print "Key = " print key print "\n" .return(0) .end CODE Key = foo Key = foo OUTPUT pir_output_is( <<'CODE', <<'OUTPUT', "Bug in method calling with nonconst keys - clobber" ); .sub _main :main newclass $P0, "Foo" new $P1, ['Foo'] $I1 = $P1["foo"] $S0 = "foo" $I1 = $P1[$S0] end .end .namespace ["Foo"] .sub get_integer_keyed :vtable :method .param pmc key $S0 = "bar" print "Key = " print key print "\n" print $S0 print "\n" .return(0) .end CODE Key = foo bar Key = foo bar OUTPUT pir_output_is( <<'CODE', <<'OUTPUT', "method cache invalidation" ); .sub main :main .local pmc o, cl newclass cl, "Foo" subclass cl, cl, "Bar" o = new ['Bar'] print o $P0 = get_global "ok2" cl.'add_vtable_override'('get_string', $P0) print o .end .sub ok2 .return("ok 2\n") .end .namespace [ "Foo" ] .sub get_string :vtable :method .return("ok 1\n") .end CODE ok 1 ok 2 OUTPUT pir_output_is( <<'CODE', <<'OUTPUT', "callmethod - method name" ); .sub main :main $P2 = newclass "Foo" $S0 = "meth" print "main\n" $P3 = new $P2 $P3.$S0() print "back\n" end .end .namespace ["Foo"] .sub meth :method print "in meth\n" getinterp $P0 $P1 = $P0["sub"] print $P1 print "\n" .return () .end CODE main in meth meth back OUTPUT SKIP: { skip( "no bound NCI method", 1 ); pir_output_is( <<'CODE', <<'OUTPUT', "bound NCI method" ); .sub main :main .local pmc s, l, f s = new ['String'] s = "ABC\n" f = getattribute s, "lower" typeof $S0, f print $S0 print "\n" l = f() print l .end CODE Bound_NCI abc OUTPUT } pir_output_is( <<'CODE', <<'OUTPUT', "tailcallmeth" ); .sub main :main .local pmc cl, o, n cl = newclass "Foo" addattribute cl, "n" o = new ['Foo'] n = new ['Integer'] n = 2000 setattribute o, [ "Foo" ], "n", n o.'go'() n = getattribute o, [ "Foo" ], "n" print n print "\n" .end .namespace ["Foo"] .sub go :method .local pmc n n = getattribute self, [ "Foo" ], "n" dec n unless n goto done .tailcall self."go"() done: .end CODE 0 OUTPUT pir_output_is( <<'CODE', <<'OUTPUT', "kind of a super" ); .sub main :main .local pmc cl, o cl = subclass "String", "MyString" o = new ['MyString'] o = "foo" print o print "\n" .end .namespace ["MyString"] .sub set_string_native :vtable :method .param string s $P0 = getattribute self, ["String"], 'proxy' s .= s $P0 = s .end CODE foofoo OUTPUT pir_output_is( <<'CODE', <<'OUTPUT', "delegate keyed_int" ); .sub main :main .local pmc cl, o cl = newclass "MyClass" o = new ['MyClass'] $I0 = 5 $S0 = "foo" o[$I0] = 42 o[$S0] = 42 delete o[$I0] delete o[$S0] $I1 = defined o[$I0] $I1 = defined o[$S0] $I1 = exists o[$I0] $I1 = exists o[$S0] .end .namespace ["MyClass"] .sub set_integer_keyed_int :vtable :method .param int key .param int val print "ikey\n" .end .sub set_integer_keyed :vtable :method .param string key .param int val print "skey\n" .end .sub delete_keyed_int :vtable :method .param int key print "del_ikey\n" .end .sub delete_keyed :vtable :method .param string key print "del_skey\n" .end .sub defined_keyed_int :vtable :method .param int key print "def_ikey\n" .return (0) .end .sub defined_keyed :vtable :method .param string key print "def_skey\n" .return (0) .end .sub exists_keyed_int :vtable :method .param int key print "exists_ikey\n" .return (0) .end .sub exists_keyed :vtable :method .param string key print "exists_skey\n" .return (0) .end CODE ikey skey del_ikey del_skey def_ikey def_skey exists_ikey exists_skey OUTPUT pir_output_is( <<'CODE', <<'OUTPUT', "delegate keyed_int PMC derived" ); .sub main :main .local pmc cl, o cl = subclass "ResizablePMCArray", "MyClass" o = new ['MyClass'] $I0 = 5 o[$I0] = 42 $I1 = o[$I0] print $I1 print "\n" .end .namespace ["MyClass"] .sub get_integer_keyed_int :vtable :method .param int key print "ikey\n" .local pmc ar ar = getattribute self, ["ResizablePMCArray"], "proxy" $I0 = ar[key] .return ($I0) .end .sub set_integer_keyed_int :vtable :method .param int key .param int val print "pkey\n" .local pmc ar ar = getattribute self, ["ResizablePMCArray"], "proxy" ar[key] = val .end CODE pkey ikey 42 OUTPUT pir_output_is( <<'CODE', <<'OUTPUT', "delegate keyed_int PMC derived - inherit" ); .sub main :main .local pmc cl, o cl = subclass "ResizablePMCArray", "MyClass" o = new ['MyClass'] $I0 = 5 o[$I0] = 42 $I1 = o[$I0] print $I1 print "\n" .end .namespace ["MyClass"] .sub get_integer_keyed_int :vtable :method .param int key print "ikey\n" .local pmc ar ar = getattribute self, ["ResizablePMCArray"], "proxy" $I0 = ar[key] .return ($I0) .end CODE ikey 42 OUTPUT pir_output_is( <<'CODE', <<'OUTPUT', "addmethod op" ); .sub main :main .local pmc c c = newclass ['whatever'] .const 'Sub' foo = "whatever_foo" addmethod c, "foo", foo $P0 = new ['whatever'] $P0.'foo'() .end .sub whatever_foo :anon :method print "Foo!\n" .end CODE Foo! OUTPUT pir_output_is( <<'CODE', <<'OUTPUT', "inherit a PMC METHOD" ); .sub main :main .local pmc cl, o cl = subclass 'Integer', 'MyInt' o = new ['MyInt'] o = 10 $S0 = o.'get_as_base'(16) print $S0 print "\n" .end CODE a OUTPUT pir_output_is( <<'CODE', <<'OUTPUT', "init calls" ); .sub main :main .local pmc cl, o cl = newclass 'MyClass' o = new ['MyClass'] $P0 = new ['String'] o = new ['MyClass'], $P0 .end .namespace ['MyClass'] .sub init :method :vtable .param pmc initializer :optional print "init was called\n" .end .sub init_pmc :method :vtable .param pmc initializer print "init_pmc was called\n" .end CODE init was called init_pmc was called OUTPUT pir_output_is( <<'CODE', <<'OUTPUT', "overloading find_method vtable" ); .sub main :main .local pmc cl, o cl = newclass 'MyClass' o = new ['MyClass'] o.'foo'() .end .namespace ['MyClass'] .sub find_method :method :vtable .param string methodname print "find_method was called\n" $P0 = get_hll_global ["MyClass"], methodname .return($P0) .end .sub foo print "foo was called\n" .end CODE find_method was called foo was called OUTPUT pir_output_is( <<'CODE', <<'OUTPUT', "overloading attribute accessor vtable" ); .sub main :main .local pmc cl, o cl = newclass 'MyClass' o = new ['MyClass'] $P2 = new ['String'] $P2 = "blue" setattribute o, "blue", $P2 $P1 = getattribute o, "blue" .end .namespace ['MyClass'] .sub get_attr_str :method :vtable .param string attrname print "get_attr_str was called\n" .end .sub set_attr_str :method :vtable .param string attrname .param pmc val print "set_attr_str was called\n" .end CODE set_attr_str was called get_attr_str was called OUTPUT pir_error_output_like( <<'CODE', <<'OUTPUT', "method called on non-object" ); .namespace [ 'Foo' ] .sub 'blah' :method .end .namespace [] .sub main :main $P1 = get_hll_global 'Foo' $P0 = $P1.'new'() .end CODE /Method 'new' not found for non-object/ OUTPUT pir_output_is( <<'CODE', <<'OUTPUT', "overloading isa vtable" ); .namespace [ 'Foo' ] .sub 'isa' :vtable("isa") :method .param string role .return(1) .end .namespace [] .sub main :main $P0 = newclass "Foo" $P1 = new $P0 $I0 = isa $P1, "no_role_i_ever_heard_of" say $I0 .end CODE 1 OUTPUT pir_output_is( <<'CODE', <<'OUTPUT', "overloading isa_pmc vtable" ); .namespace [ 'Foo' ] .sub 'isa_pmc' :vtable("isa_pmc") :method .param string role .return(1) .end .namespace [] .sub main :main $P0 = newclass "Foo" $P1 = new $P0 $P2 = box "no_role_i_ever_heard_of" $I0 = isa $P1, $P2 say $I0 .end CODE 1 OUTPUT # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: smoke.pl000755000765000765 550511533177647 15775 0ustar00bruce000000000000parrot-6.6.0/tools/install#! perl # Copyright (C) 2007-2009, Parrot Foundation. use strict; use warnings; use 5.008; use Getopt::Long; use File::Spec::Functions; use Test::More tests => 6; =head1 NAME tools/install/smoke.pl - checks parrot in install directory =head1 SYNOPSIS parrot in install tree % cd /usr/local/parrot-$version % perl smoke.pl parrot in build tree % perl tools/install/smoke.pl --bindir=. test installation in DESTDIR: % cd /usr/src/parrot % mkdir .inst % make install DESTDIR=.inst % perl tools/install/smoke.pl DESTDIR=.inst =head1 DESCRIPTION Checks that most of things run (or just start) into the install directory, try to detect missing parts. =head1 OPTIONS =over =item --bindir=/usr/bin Override default value : 'bin' =back =cut my ($bindir, $DESTDIR); my $opts = GetOptions( 'bindir=s' => \$bindir, 'DESTDIR=s' => \$DESTDIR, ); $bindir = 'bin' unless $bindir; chdir $DESTDIR if ($DESTDIR); sub quote { my $exe = shift; $exe .= '.exe' if ($^O eq 'MSWin32'); $exe = '"' . $exe . '"' if ($exe =~ / /); return $exe; } my $filename; my $exe; my $out; my $FH; my $parrot = quote(catfile($bindir, 'parrot')); my $nqp = quote(catfile($bindir, 'parrot-nqp')); # # parrot executable # $exe = quote(catfile($bindir, 'pbc_merge')); $out = `$exe`; ok($out =~ /^pbc_merge/, "check pbc_merge"); $exe = quote(catfile($bindir, 'pbc_dump')); $out = `$exe`; ok($out =~ /^pbc_dump/, "check pbc_dump"); ok(system("$parrot -V") == 0, "display parrot version"); $out = `$parrot -V`; $out =~ m/version (\S+) built/; my $version = $1; my $libdir = ($bindir eq 'bin') ? ($^O eq 'MSWin32') ? 'lib/parrot/library' : "lib/parrot/$version/library" : 'runtime/parrot/library'; my $compdir = ($bindir eq 'bin') ? ($^O eq 'MSWin32') ? 'lib/parrot/languages' : "lib/parrot/$version/languages" : 'compilers'; # # some compiler tools # $filename = 'test.pg'; open $FH, '>', $filename or die "Can't open $filename ($!).\n"; print $FH <<'PGE'; grammar WSpace token TOP { \s* } PGE close $FH; $out = `$parrot $libdir/PGE/Perl6Grammar.pbc $filename`; ok($out =~ /## /, "check PGE"); unlink($filename); $filename = 'test.nqp'; open $FH, '>', $filename or die "Can't open $filename ($!).\n"; print $FH "say('hello world!');\n"; close $FH; $out = `$nqp $filename`; ok($out eq "hello world!\n", "check nqp-rx"); unlink($filename); # compilers/tge is typically not installed $filename = 'test.tg'; open $FH, '>', $filename or die "Can't open $filename ($!).\n"; print $FH "transform past (ROOT) { }\n"; close $FH; $out = `$parrot $compdir/tge/tgc.pir $filename`; ok($out =~ /^\n\.sub '_ROOT_past'/, "check TGE"); unlink($filename); # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: 037-run_single_step.t000644000765000765 346011533177644 17624 0ustar00bruce000000000000parrot-6.6.0/t/configure#! perl # Copyright (C) 2007, Parrot Foundation. # 037-run_single_step.t use strict; use warnings; use Test::More tests => 5; use Carp; use lib qw( lib t/configure/testlib ); use Parrot::Configure; use Parrot::Configure::Options qw( process_options ); use IO::CaptureOutput qw | capture |; my ($args, $step_list_ref) = process_options( { argv => [], mode => q{configure}, } ); ok( defined $args, "process_options returned successfully" ); my %args = %$args; my $conf = Parrot::Configure->new; ok( defined $conf, "Parrot::Configure->new() returned okay" ); my $step = q{init::defaults}; $conf->add_step($step); $conf->options->set( %{$args} ); { my $stdout; capture ( sub { eval { $conf->run_single_step($step); } }, \$stdout ); ok( !$@, "run_single_step() completed without error" ); like( $stdout, # qr/$step.*done./s, #' # qr/Setting up Configure's default values/s, #' qr/Set Configure's default values/s, #' "Got message expected upon running $step" ); } pass("Completed all tests in $0"); ################### DOCUMENTATION ################### =head1 NAME 037-run_single_step.t - test C during configuration =head1 SYNOPSIS % prove t/configure/037-run_single_step.t =head1 DESCRIPTION The files in this directory test functionality used by F. The tests in this file examine what would happen if C were run during configuration. This is not its typical or recommended use. It is more typically called post-configuration by F. =head1 AUTHOR James E Keenan =head1 SEE ALSO Parrot::Configure, F. =cut # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: global_setup.h000644000765000765 402412233541455 17255 0ustar00bruce000000000000parrot-6.6.0/include/parrot/* global_setup.h * Copyright (C) 2001-2007, Parrot Foundation. * Overview: * Contains declarations of global data and the functions * that initialize that data. * Data Structure and Algorithms: * History: * Notes: * References: */ #ifndef PARROT_GLOBAL_SETUP_H_GUARD #define PARROT_GLOBAL_SETUP_H_GUARD #include "parrot/config.h" #include "parrot/interpreter.h" void Parrot_gbl_register_core_pmcs(PARROT_INTERP, ARGIN(PMC *registry)) __attribute__nonnull__(1) __attribute__nonnull__(2); void Parrot_gbl_initialize_core_pmcs(PARROT_INTERP, int pass) __attribute__nonnull__(1); /* HEADERIZER BEGIN: src/global_setup.c */ /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */ void init_world(PARROT_INTERP) __attribute__nonnull__(1); void Parrot_gbl_init_world_once(PARROT_INTERP) __attribute__nonnull__(1); void Parrot_gbl_set_config_hash_internal( ARGIN(const unsigned char* parrot_config), unsigned int parrot_config_size) __attribute__nonnull__(1); void Parrot_set_config_hash_pmc(PARROT_INTERP, ARGIN(PMC *config)) __attribute__nonnull__(1) __attribute__nonnull__(2); #define ASSERT_ARGS_init_world __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp)) #define ASSERT_ARGS_Parrot_gbl_init_world_once __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp)) #define ASSERT_ARGS_Parrot_gbl_set_config_hash_internal \ __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(parrot_config)) #define ASSERT_ARGS_Parrot_set_config_hash_pmc __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(config)) /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */ /* HEADERIZER END: src/global_setup.c */ #endif /* PARROT_GLOBAL_SETUP_H_GUARD */ /* * Local variables: * c-file-style: "parrot" * End: * vim: expandtab shiftwidth=4 cinoptions='\:2=2' : */ stress_strings.pir000644000765000765 143211533177634 21243 0ustar00bruce000000000000parrot-6.6.0/examples/benchmarks# Copyright (C) 2010, Parrot Foundation. =head1 NAME examples/benchmarks/stress_strings.pir - GC strings stress-testing =head1 SYNOPSIS % time ./parrot examples/benchmarks/stress_strings.pir =head1 DESCRIPTION Create a lots of strings. Some of them are long-lived, most of them are short lived. Main purpose - test compact_pool performance. =cut .sub 'main' :main .local pmc rsa # array of long lived strings. .local int i rsa = new ['ResizableStringArray'] i = 0 loop: $S0 = i # allocate new string $I0 = i % 10 # every 10th string is longlived if $I0 goto inc_i push rsa, $S0 inc_i: inc i if i < 10000000 goto loop .end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: 20-return.t000644000765000765 50112101554066 16453 0ustar00bruce000000000000parrot-6.6.0/ext/nqp-rx/t/nqp#!./parrot-nqp # implicit and explicit returns from subs plan(3); sub foo() { 1; } sub bar() { return 2; 0; } sub baz() { if (1) { return 3; } 0; } ok( foo() == 1 , 'last value in block' ); ok( bar() == 2 , 'explicit return value in block'); ok( baz() == 3 , 'explicit return from nested block'); prt0.winxed000644000765000765 1576012305426127 17036 0ustar00bruce000000000000parrot-6.6.0/frontend/parrot2$include_const "iglobals.pasm"; $include_const "interpinfo.pasm"; $include_const "except_severity.pasm"; const int NO_FILE = 0; const int PASM_FILE = 1; const int PIR_FILE = 2; const int PBC_FILE = 3; const int MODE_NORMAL = 0; const int MODE_PREPROCESS = 1; const int MODE_RUNFILE = 2; function __PARROT_ENTRY_MAIN__args[anon](var args) { string exe_name; ${ shift exe_name, args }; string prog_name; int input_file_type = NO_FILE; string output_file = null; var packfile_pmc = null; string dummy; int mode = MODE_NORMAL; while (elements(args) > 0) { string sys_arg = args[0]; switch (sys_arg) { case "-o": ${ shift dummy, args }; ${ shift output_file, args }; break; case "-c": ${ shift dummy, args }; input_file_type = PBC_FILE; break; case "-r": ${ shift dummy, args }; mode = MODE_RUNFILE; break; case "-E": ${ shift dummy, args }; mode = MODE_PREPROCESS; break; case "--runtime-prefix": __show_runtime_prefix_and_exit(); case "-V": __show_version_and_exit(); case "-h": __show_help_and_exit(); default: prog_name = sys_arg; goto done_args; } } done_args: if (prog_name == null || prog_name == "") __usage_and_exit("Missing program name"); if (mode == MODE_PREPROCESS) { compreg("PIR").preprocess(prog_name); exit(0); } if (input_file_type == NO_FILE) { input_file_type = __get_input_file_type(prog_name); if (input_file_type == NO_FILE) __usage_and_exit("Invalid file type " + prog_name); } if (mode == MODE_RUNFILE) { string temp_outfile = __get_temporary_output_file(prog_name); packfile_pmc = compreg("PIR").compile_file(prog_name); packfile_pmc.write_to_file(temp_outfile); packfile_pmc = new 'PackfileView'; packfile_pmc.read_from_file(temp_outfile); } if (packfile_pmc == null) packfile_pmc = __default_get_packfile(prog_name, input_file_type); if (output_file != null) { packfile_pmc.write_to_file(output_file); exit(0); } for (var init_sub in packfile_pmc.subs_by_tag("init")) init_sub(); return packfile_pmc; } function __PARROT_ENTRY_MAIN__[anon,main](var args) { try [allowtailcall] { var packfile_pmc = __PARROT_ENTRY_MAIN__args(args); var main_sub = packfile_pmc.main_sub(); return main_sub(args); } catch (e) { __handle_error_and_exit(e); } } function __default_get_packfile[anon](string file_name, int file_type) { switch (file_type) { case PIR_FILE: var pir_compiler = compreg("PIR"); var pf = pir_compiler.compile_file(file_name); return pf; case PASM_FILE: var pasm_compiler = compreg("PASM"); return pasm_compiler.compile_file(file_name); case PBC_FILE: var packfile_pmc = new 'PackfileView'; packfile_pmc.read_from_file(file_name); return packfile_pmc; default: return null; } } function __get_input_file_type[anon](string file_name) { int len = length(file_name) - 4; string ext = len >= 0 ? substr(file_name, len) : ''; if (ext == ".pir") return PIR_FILE; if (ext == ".pbc") return PBC_FILE; if (len > 0) { ext = substr(file_name, len - 1); if (ext == ".pasm") return PASM_FILE; } return PIR_FILE; } function __handle_error_and_exit[anon](var exception) { int severity = exception.severity; if (severity == EXCEPT_EXIT) exit(exception.exit_code); var stderr_pmc = getstderr(); string message = exception.message; if (message == null || message == "") message = "No exception handler and no message"; stderr_pmc.print(sprintf("%s\n", [message])); string line_sep = ""; var bts = exception.backtrace_strings(); for (int i = elements(bts) - 1; i >= 0; i--) { string bt = bts[i]; var lines = split("\n", bt); for (string line in lines) { if (indexof(line, "__PARROT_ENTRY_MAIN__") != -1) continue; stderr_pmc.print(sprintf("%s%s", [line_sep, line])); line_sep = "\n"; } line_sep = "\nthrown from\n"; } int exit_code = exception.exit_code; if (exit_code == 0) exit_code = 1; exit(exit_code); } function __show_runtime_prefix_and_exit[anon]() { string runtime_prefix; ${ interpinfo runtime_prefix, INTERPINFO_RUNTIME_PREFIX }; say(runtime_prefix); exit(0); } function __show_version_and_exit[anon]() { var config = getinterp()[IGLOBALS_CONFIG_HASH]; string msg_fmt = <<: This is Parrot version %s%s built for %s-%s Copyright (C) 2001-2014, Parrot Foundation. This code is distributed under the terms of the Artistic License 2.0. For more details, see the full text of the license in the LICENSE file included in the Parrot source tree :>> ; var msg = sprintf(msg_fmt, [config["VERSION"], config["DEVEL"], config["cpuarch"], config["platform"]]); say(msg); exit(0); } function __show_help_and_exit[anon]() { string msg = <<: parrot [Options] [] Options: -h --help -V --version -I --include add path to include search -L --library add path to library search --hash-seed F00F specify hex value to use as hash seed -X --dynext add path to dynamic extension search -R --runcore fast|slow|bounds -R --runcore trace|profiling|subprof -t --trace [flags] -D --parrot-debug[=HEXFLAGS] --help-debug -w --warnings -G --no-gc -g --gc ms2|gms|ms|inf set GC type --gc-dynamic-threshold=percentage maximum memory wasted by GC --gc-min-threshold=KB --gc-nursery-size=percent of sysmem size of gen0 (default 2) --gc-debug --leak-test|--destroy-at-end -. --wait Read a keystroke before starting --runtime-prefix -E --pre-process-only -o --output=FILE --output-pbc -a --pasm -c --pbc -r --run-pbc -v --verbose -y --yydebug -d --imcc-debug[=HEXFLAGS] (see --help-debug) see docs/running.pod for more :>> ; say(msg); exit(0); } function __get_temporary_output_file[anon](string infile) { # TODO: Do we need anything else? return infile + ".pbc"; } function __usage_and_exit[anon](string msg [optional], int has_msg [opt_flag]) { var stderr = getstderr(); if (has_msg) stderr.print(msg + "\n"); stderr.print("parrot -[acEGhrtVvwy.] [-D [FLAGS]] "); stderr.print("[-[LIX] path] [-R runcore] [-o FILE] \n"); exit(1); } UseParrotCoda.pm000644000765000765 554012307662657 22755 0ustar00bruce000000000000parrot-6.6.0/lib/Perl/Critic/Policy/CodeLayoutpackage Perl::Critic::Policy::CodeLayout::UseParrotCoda; # Copyright (C) 2006-2014, Parrot Foundation. use strict; use warnings; use Perl::Critic::Utils; use Perl::Critic::Violation; use base 'Perl::Critic::Policy'; =head1 NAME Perl::Critic::Policy::CodeLayout::UseParrotCoda =head1 DESCRIPTION The pumpking has declared that all parrot source code must include a series of comments at the end of the source. After much discussion C<__END__> and C<__DATA__> blocks are exempt from this policy. =cut our $VERSION = '0.2'; $VERSION = eval $VERSION; ## no critic my $desc = q{Missing properly located perl coda for parrot source}; my $expl = q{According to PDD07, all perl source in parrot must contain a comment coda}; #---------------------------------------------------------------------------- sub default_severity { return $SEVERITY_LOW } sub applies_to { return 'PPI::Document' } #---------------------------------------------------------------------------- # The actual coda we're looking for: our $CODA = <<'END_CODA'; # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: (\d+) # End: # vim: expandtab shiftwidth=4: END_CODA #---------------------------------------------------------------------------- sub violates { my ( $self, $elem, $doc ) = @_; my @coda_lines = split /\n/, $CODA; my $last_node = $doc->last_element; # __END__ and __DATA__ blocks are excepted from having the coda if ( $last_node->isa('PPI::Statement::End') or $last_node->isa('PPI::Statement::Data') ) { return; } else { for ( $last_node = $doc->last_element ; $last_node && @coda_lines ; $last_node = $last_node->previous_sibling ) { next if ( $last_node->isa('PPI::Token::Whitespace') ); last if ( !$last_node->isa('PPI::Token::Comment') ); my $last_coda_line = $coda_lines[-1]; my $last_actual_line = $last_node->content; chomp $last_actual_line; # fill-column > 70 and <= 100 if ($last_coda_line eq '# fill-column: (\d+)') { if ($last_actual_line =~ m/$last_coda_line/ and $1 and ($1 == 100 or $1 == 78)) { } else { last; } } elsif ( $last_coda_line ne $last_actual_line ) { last; } pop @coda_lines; } } return if ( !@coda_lines ); # We made it through all the coda lines return $self->violation( $desc, $expl, $last_node || $doc ); } 1; # How meta! We ourselves must have this coda to be a valid perl file in the # parrot repository... # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: socklen_t.pm000644000765000765 221411533177633 16232 0ustar00bruce000000000000parrot-6.6.0/config/auto# Copyright (C) 2006-2007, Parrot Foundation. =head1 NAME config/auto/socklen_t.pm - Is there a socklen_t =head1 DESCRIPTION Determines whether there is a socklen_t =cut package auto::socklen_t; use strict; use warnings; use base qw(Parrot::Configure::Step); use Parrot::Configure::Utils ':auto'; sub _init { my $self = shift; my %data; $data{description} = q{Determine whether there is socklen_t}; $data{result} = q{}; return \%data; } sub runstep { my ( $self, $conf ) = @_; my $d_socklen_t = _probe_for_socklen_t($conf); $self->_evaluate_socklen_t($conf, $d_socklen_t); return 1; } sub _probe_for_socklen_t { my $conf = shift; return $conf->data->get('has_socklen_t') || $conf->data->get('d_socklen_t_provisional'); } sub _evaluate_socklen_t { my ($self, $conf, $d_socklen_t) = @_; my $has_socklen_t = $d_socklen_t ? 1 : 0; $self->set_result( $has_socklen_t ? 'yes' : 'no' ); $conf->data->set( has_socklen_t => $has_socklen_t ); } 1; # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: 00ff-dos.t000644000765000765 123111533177644 14062 0ustar00bruce000000000000parrot-6.6.0/t/op#!./parrot # Copyright (C) 2001-2010, Parrot Foundation. =head1 NAME t/op/00ff-dos.t - DOS File Format =head1 SYNOPSIS % prove t/op/00ff-dos.t =head1 DESCRIPTION Tests file formats. =cut .sub main :main .include 'test_more.pir' plan(2) test_fileformat_dos() test_fileformat_dos_ctrl_z() .end .sub test_fileformat_dos lives_ok( <<"CODE", 'fileformat dos') .sub main $I0 = 42\r\n .end CODE .end .sub test_fileformat_dos_ctrl_z lives_ok( <<"CODE", 'fileformat dos w ctrl-z') .sub main $I0 = 42\r\n\cZ .end CODE .end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: Makefile.msvc000644000765000765 147011533177634 17003 0ustar00bruce000000000000parrot-6.6.0/examples/embed# Copyright (C) 2009, Parrot Foundation. # # Microsoft Visual C++ Makefile # To build this example in a parrot development environment: # adjust PARROT_PREFIX below # nmake -f Makefile.msvc PARROT_PREFIX = c:\usr\src\perl\parrot\parrot-msvc6 # c:\parrot CC = cl CCFLAGS = -nologo -GF -W4 -MD -Zi -DNDEBUG -DWIN32 -D_CONSOLE -DNO_STRICT -Zm400 LD = link -nologo INCLUDEDIR = $(PARROT_PREFIX)\include LDFLAGS = $(PARROT_PREFIX)\libparrot.lib O = .obj EXE = .exe all: cotorra$(EXE) #----------------------------------------------------------------------- cotorra$(O): cotorra.c $(CC) $(CCFLAGS) -c -I $(INCLUDEDIR) cotorra.c cotorra$(EXE): cotorra$(O) $(LD) -out:cotorra$(EXE) cotorra$(O) $(LDFLAGS) #----------------------------------------------------------------------- clean: rm -f cotorra$(EXE) cotorra$(O) 06-args-pos.t000644000765000765 14512101554066 16677 0ustar00bruce000000000000parrot-6.6.0/ext/nqp-rx/t/nqp#!./parrot-nqp # positional arguments say('1..2'); say("ok ", 1); print('o', 'k', ' ', 2, "\n"); io_status.t000644000765000765 1113011533177645 14737 0ustar00bruce000000000000parrot-6.6.0/t/pmc#!perl # Copyright (C) 2006-2007, Parrot Foundation. use strict; use warnings; use lib qw( . lib ../lib ../../lib ); use Test::More; use Parrot::Test tests => 6; =head1 NAME t/pmc/io_status.t - test the Status PMC described in PDD22 =head1 SYNOPSIS % prove t/pmc/io_status.t =head1 DESCRIPTION Tests the Status PMC described in PDD22. =cut # L pir_output_is( <<'CODE', <<'OUT', 'new', todo => 'not yet implemented' ); .sub 'test' :main new P0, 'Status' say "ok 1 - $P0 = new ['Status']" .end CODE ok 1 - $P0 = new ['Status'] OUT # L pir_output_is( <<'CODE', <<'OUT', 'get_integer (vtable)', todo => 'not yet implemented' ); .sub 'test' :main $P0 = new ['Status'] # TODO test more return values # TODO figure out how to set the values to make testing possible $I0 = $P0 if $I0 == 1 goto ok_1 print 'not ' ok_1: say 'ok 1 - $I0 = $P1 # success' if $I0 == 0 goto ok_2 print 'not ' ok_2: say 'ok 2 - $I0 = $P1 # still running' if $I0 == -1 goto ok_3 print 'not ' ok_3: say 'ok 3 - $I0 = $P1 # failure .end CODE ok 1 - $I0 = $P0 # success ok 2 - $I0 = $P0 # still running ok 3 - $I0 = $P0 # failure OUT # L pir_output_is( <<'CODE', <<'OUT', 'get_bool (vtable)', todo => 'not yet implemented' ); .sub 'test' :main $P0 = new ['Status'] # TODO figure out how to set the values to make testing possible if $P0 goto ok_1 print 'not ' ok_1: say 'ok 1 - $P0 # success' if $P0 goto ok_2 print 'not ' ok_2: say 'ok 2 - $P0 # still running' unless $P0 goto ok_3 print 'not ' ok_3: say 'ok 3 - $P0 # failure .end CODE ok 1 - $P0 # success ok 2 - $P0 # still running ok 3 - $P0 # failure OUT # L pir_output_is( <<'CODE', <<'OUT', 'return', todo => 'not yet implemented' ); .sub 'test' :main $P0 = new ['Status'] # TODO test all return values # TODO figure out how to set the values to make testing possible $P1 = $P0.return() if $P1 goto ok_1 print 'not ' ok_1: say 'ok 1 - $P0 = $P1.return() # success' # TODO test return value is expected value if null $P1 goto ok_2 print 'not ' ok_2: say 'ok 2 - $P0 = $P1.return() # still running' if null $P1 goto ok_3 print 'not ' ok_3: say 'ok 3 - $P0 = $P1.return() # no return value .end CODE ok 1 - $P0 = $P1.return() # success ok 2 - $P0 = $P1.return() # still running ok 3 - $P0 = $P1.return() # no return value OUT # L pir_output_is( <<'CODE', <<'OUT', 'error', todo => 'not yet implemented' ); .sub 'test' :main $P0 = new ['Status'] # TODO test all error values # TODO figure out how to set the values to make testing possible $P1 = $P0.error() if null $P1 goto ok_1 print 'not ' ok_1: say 'ok 1 - $P0 = $P1.error() # success' $P1 = $P0.error() # need still running here if null $P1 goto ok_2 print 'not ' ok_2: say 'ok 2 - $P0 = $P1.error() # still running' $P1 = $P0.error() # need real error here unless null $P1 goto ok_3 print 'not ' ok_3: say 'ok 3 - $P0 = $P1.error() # got an error' $I0 = isa $P1, 'Exception' if $I0 goto ok_4 print 'not ' ok_4: say 'ok 4 - $P0 = $P1.error() # error isa Exception' # TODO test error value is expected value $P1 = $P0.error() # need no error here if null $P1 goto ok_5 print 'not ' ok_5: say 'ok 5 - $P0 = $P1.error() # no error .end CODE ok 1 - $P0 = $P1.error() # success ok 2 - $P0 = $P1.error() # still running ok 3 - $P0 = $P1.error() # got an error ok 4 - $P0 = $P1.error() # error isa Exception ok 5 - $P0 = $P1.error() # no error OUT # L pir_output_is( <<'CODE', <<'OUT', 'throw', todo => 'not yet implemented' ); .sub 'test' :main $P0 = new ['Status'] # TODO figure out how to set the values to make testing possible push_eh eh_no_error $P0.throw() pop_eh eh_no_error say 'ok 1 - $P0.throw() # no error' test_2: $P0 = new ['Status'] # need error here push_eh eh_error $P0.throw() pop_eh say 'not ok 2 - $P0.throw() # error' goto end eh_no_error: say 'not ok 1 - $P0.throw() # no error' goto test_2 eh_error: say 'ok 2 - $P0.throw() # error' end: .end CODE ok 1 - $P1.throw() # no error ok 2 - $P1.throw() # error OUT # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: debug.t000644000765000024 1114312346145220 16236 0ustar00brucestaff000000000000parrot-6.6.0/t/dynoplibs#!perl # Copyright (C) 2001-2014, Parrot Foundation. use strict; use warnings; use lib qw( . lib ../lib ../../lib ); use Test::More; use Parrot::Test tests => 10; use Parrot::Config; use Parrot::Test::Util 'create_tempfile'; =head1 NAME t/op/debuginfo.t - Debugging Info =head1 SYNOPSIS % prove t/op/debuginfo.t =head1 DESCRIPTION Tests the various set and get operations for line, package and file info, as well as backtrace tests. =cut $ENV{TEST_PROG_ARGS} ||= ''; my $nolineno = $ENV{TEST_PROG_ARGS} =~ /--runcore=fast/ ? "\\(unknown file\\)\n-1" : "debug_\\d+\\.pasm\n\\d"; #SKIP: { #skip "disabled on fast-core",1 if $ENV{TEST_PROG_ARGS} =~ /--runcore=fast/; pasm_output_like( <<'CODE', <<"OUTPUT", "getline, getfile" ); .loadlib 'debug_ops' .pcc_sub :main main: getfile S0 getline I0 say S0 say I0 end CODE /$nolineno/ OUTPUT pir_output_like( <<'CODE', <<"OUTPUT", "debug_print" ); .loadlib 'debug_ops' .sub main :main debug_init $I0 = 1 $S0 = "foo" $N0 = 3.1 $P0 = new ['String'] $P0 = "bar" debug_print .end CODE / I0 = 1 N0 = 3.1 S0 = foo P0 = String=PMC[(]0x[a-f0-9]+ Str:"bar"[)] / OUTPUT open STDERR, ">>&STDOUT"; pir_output_like( <<'CODE', <<"OUTPUT", "debug_print without debugger" ); .loadlib 'debug_ops' .sub main :main push_eh eh debug_print goto finally eh: .get_results($P0) say $P0 finally: pop_eh .end CODE /Initialize debugger with debug_init before using debug_print/ OUTPUT pir_output_like( <<'CODE', <<"OUTPUT", "debug_backtrace" ); .loadlib 'debug_ops' .sub main :main debug_init backtrace say "ok" .end CODE /ok/ OUTPUT SKIP: { skip("debug_break fails for no apparent reasons on windows and darwin", 1) if $^O eq 'MSWin32' or $^O eq 'darwin'; pir_stdin_output_like( <<'INPUT', <<'CODE', qr/[(]pdb[)] (print I0\n)?1/, "debug_break" ); print I0 quit INPUT .loadlib 'debug_ops' .sub main :main debug_init $I0 = 1 debug_break .end CODE } pir_error_output_like( <<'CODE', <<'OUTPUT', "debug backtrace - Null PMC access" ); .sub main :main print "ok 1\n" a() print "not ok 10\n" .end .sub a print "ok 2\n" b() print "not ok 9\n" .end .sub b print "ok 3\n" c() print "not ok 8\n" .end .sub c print "ok 4\n" d() print "not ok 7\n" .end .sub d print "ok 5\n" $P0 = null $P0() print "not ok 6\n" .end CODE /^ok 1 ok 2 ok 3 ok 4 ok 5 Null PMC access in invoke\(\) current instr\.: 'd' pc (\d+|-1) \(.*?:(\d+|-1)\) called from Sub 'c' pc (\d+|-1) \(.*?:(\d+|-1)\) called from Sub 'b' pc (\d+|-1) \(.*?:(\d+|-1)\) called from Sub 'a' pc (\d+|-1) \(.*?:(\d+|-1)\) called from Sub 'main' pc (\d+|-1) \(.*?:(\d+|-1)\)$/ OUTPUT pir_error_output_like( <<'CODE', <<'OUTPUT', "debug backtrace - method not found" ); .namespace ["Test1"] .sub main :main print "ok 1\n" foo() print "not ok 5\n" .end .sub foo print "ok 2\n" $P0 = new 'Integer' print "ok 3\n" $P0."nosuchmethod"() print "not ok 4\n" .end CODE /^ok 1 ok 2 ok 3 Method 'nosuchmethod' not found for invocant of class 'Integer' current instr.: 'parrot;Test1;foo' pc (\d+|-1) \(.*?:(\d+|-1)\) called from Sub 'parrot;Test1;main' pc (\d+|-1) \(.*?:(\d+|-1)\)$/ OUTPUT pir_error_output_like( <<'CODE', <<'OUTPUT', "debug backtrace - division by 0" ); .namespace ["Test2"] .sub main :main print "ok 1\n" foo() print "not ok 3\n" .end .sub foo :lex print "ok 2\n" $I1 = 0 div $I2, $I2, 0 print "not ok 3\n" .end CODE /^ok 1 ok 2 Divide by zero current instr.: 'parrot;Test2;foo' pc (\d+|-1) \(.*?:(\d+|-1)\) called from Sub 'parrot;Test2;main' pc (\d+|-1) \(.*?:(\d+|-1)\)$/ OUTPUT pir_error_output_like( <<'CODE', <<'OUTPUT', "debug backtrace - recursion 1" ); .sub main :main main() .end CODE /^maximum recursion depth exceeded current instr\.: 'main' pc (\d+|-1) \(.*?:(\d+|-1)\) called from Sub 'main' pc (\d+|-1) \(.*?:(\d+|-1)\) \.\.\. call repeated \d+ times/ OUTPUT pir_error_output_like( <<'CODE', <<'OUTPUT', "debug backtrace - recursion 2" ); .sub main :main rec(91) .end .sub rec .param int i if i == 0 goto END dec i rec(i) .return() END: $P0 = null $P0() .end CODE /^Null PMC access in invoke\(\) current instr\.: 'rec' pc (\d+|-1) \(.*?:(\d+|-1)\) called from Sub 'rec' pc (\d+|-1) \(.*?:(\d+|-1)\) \.\.\. call repeated 90 times called from Sub 'main' pc (\d+|-1) \(.*?:(\d+|-1)\)$/ OUTPUT $nolineno = $ENV{TEST_PROG_ARGS} =~ /--runcore=fast/ ? '\(\(unknown file\):-1\)' : '\(xyz.pir:126\)'; # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: japhc.c000644000765000765 1236412101554066 16560 0ustar00bruce000000000000parrot-6.6.0/examples/compilers/* * Copyright (C) 2004-2008, Parrot Foundation. */ /* =head1 NAME examples/compiler/japhc.c =head1 DESCRIPTION example compiler used by japh16.pasm =head1 SYNOPSIS $ make -C examples/compilers/ $ parrot examples/japh/japh16.pasm =head2 Functions =over 4 =cut */ #include "parrot/parrot.h" #define CONST_STRING(i, s) Parrot_str_new_constant((i), (s)) #define CONST_STRING_GEN(i, s) Parrot_str_new_constant((i), (s)) #include "pmc/pmc_sub.h" #define C_DEBUG 0 #if C_DEBUG # include # define cdebug(x) fprintf (x) #else # define cdebug(x) #endif INTVAL dynpmc_class_JaPHC; PMC* japh_compiler(PARROT_INTERP, const char *s); /* =item C loadlib calls the load and init hooks we use init to register the compiler =cut */ void Parrot_lib_japhc_init(PARROT_INTERP, PMC* lib) { STRING *whoami; cdebug((stderr, "japhc_init\n")); whoami = CONST_STRING_GEN(interp, "JaPHC"); dynpmc_class_JaPHC = Parrot_pmc_register_new_type(interp, whoami); /* Parrot_JaPHC_class_init(interp, dynpmc_class_JaPHC, 0); */ /* Parrot_compreg(interp, whoami, japh_compiler); */ } /* =item C Unescape a string. =cut */ static int unescape(char *string) { char *start, *p; for (start = p = string ; *string; string++) { if (*string == '\\' && string[1]) { switch (*++string) { case 'n': *p++ = '\n'; break; default: *p++ = *string; break; } } else *p++ = *string; } *p = 0; return p - start; } /* =item C add constant string to constant_table =cut */ static int add_const_str(PARROT_INTERP, PackFile_ConstTable *consts, char *str) { int k, l; char *o; char *buf = o = strdup(str); /* * TODO strip delimiters in lexer, this needs adjustment in printint strings */ if (*buf == '"') { buf++; l = unescape(buf); if (l) buf[--l] = '\0'; } else if (*buf == '\'') { buf++; l = strlen(buf); if (l) buf[--l] = '\0'; } else { l = unescape(buf); } /* Update the constant count and reallocate */ k = ++consts->const_count; if (consts->constants == NULL) consts->constants = mem_sys_allocate( k * sizeof (PackFile_Constant *)); else consts->constants = mem_sys_realloc(consts->constants, k * sizeof (PackFile_Constant *)); /* Allocate a new constant */ consts->constants[--k] = PackFile_Constant_new(interp); consts->constants[k]->type = PFC_STRING; consts->constants[k]->u.string = Parrot_str_new_init(interp, buf, (UINTVAL) l, Parrot_latin1_encoding_ptr, 0); free(o); return k; } /* =item C simple compiler - no error checking =cut */ PMC* japh_compiler(PARROT_INTERP, const char *program) { PackFile_ByteCode *cur_cs, *old_cs; PackFile_ConstTable *consts; opcode_t* pc; const char *p; PMC *sub; Parrot_sub *sub_data; #define CODE_SIZE 128 cdebug((stderr, "japh_compiler '%s'\n", program)); /* * need some packfile segments */ cur_cs = PF_create_default_segs(interp, "JAPHc", 1); old_cs = Parrot_switch_to_cs(interp, cur_cs, 0); /* * alloc byte code mem */ cur_cs->base.data = mem_sys_allocate(CODE_SIZE * sizeof (opcode_t)); cur_cs->base.size = CODE_SIZE; consts = cur_cs->const_table; /* * now start compiling */ pc = cur_cs->base.data; for (p = program; *p; ++p) { switch (*p) { case 'p': /* print_sc */ *pc++ = interp->op_lib->op_code("print_sc", 1); /* const follows */ ++p; switch (*p) { case 'J': *pc++ = add_const_str(interp, consts, "Just "); break; case 'a': *pc++ = add_const_str(interp, consts, "another "); break; case 'P': *pc++ = add_const_str(interp, consts, "Parrot "); break; case 'H': *pc++ = add_const_str(interp, consts, "Hacker"); break; case 'n': *pc++ = add_const_str(interp, consts, "\n"); break; } break; case 'e': /* end */ *pc++ = interp->op_lib->op_code("invoke_p", 1); *pc++ = 1; break; } } if (old_cs) { /* restore old byte_code, */ (void)Parrot_switch_to_cs(interp, old_cs, 0); } /* * create sub PMC */ sub = pmc_new(interp, enum_class_Eval); PMC_get_sub(interp, sub, sub_data); sub_data->seg = cur_cs; sub_data->address = cur_cs->base.data; sub_data->end = cur_cs->base.data + cur_cs->base.size; sub_data->name = string_from_literal(interp, "JaPHC"); return sub; } /* =back =cut */ /* * Local variables: * c-file-style: "parrot" * End: * vim: expandtab shiftwidth=4 cinoptions='\:2=2' : */ opengl_c.in000644000765000765 134011567202622 17306 0ustar00bruce000000000000parrot-6.6.0/config/auto/opengl/* Copyright (C) 2008-2011, Parrot Foundation. */ #include #include #ifdef __APPLE_CC__ # include #else # include #endif int main(int argc, char *argv[]) { if (glutInit == NULL) { printf("glutInit is NULL\n"); return EXIT_FAILURE; } #ifdef OPENGLUT printf("%d OpenGLUT\n", GLUT_API_VERSION); #elif FREEGLUT printf("%d freeglut\n", GLUT_API_VERSION); #elif GLUT_MACOSX_IMPLEMENTATION printf("%d MacOSX_GLUT\n", GLUT_API_VERSION); #else printf("%d GLUT\n", GLUT_API_VERSION); #endif return EXIT_SUCCESS; } /* * Local variables: * c-file-style: "parrot" * End: * vim: expandtab shiftwidth=4 cinoptions='\:2=2' : */ ipv6.pm000644000765000765 252411567202622 15133 0ustar00bruce000000000000parrot-6.6.0/config/auto# Copyright (C) 2001-2007, Parrot Foundation. =head1 NAME config/auto/ipv6.pm - determine ipv6 capabilities of local machine =head1 DESCRIPTION This configuration step probes the local machine to determine if it capable of running an ipv6 stack. =cut package auto::ipv6; use strict; use warnings; use base qw(Parrot::Configure::Step); use Parrot::Configure::Utils ':auto'; sub _init { my $self = shift; my %data; $data{description} = q{Determine IPV6 capabilities}; $data{result} = q{}; return \%data; } sub runstep { my ( $self, $conf ) = @_; my $ipv6_status = 0; $conf->cc_gen('config/auto/ipv6/test.in'); eval { $conf->cc_build(); }; if (!$@) { my $output = eval { $conf->cc_run_capture() }; if (!$@ && $output =~ /OK/) { $ipv6_status = 1; } else { $conf->debug("ipv6 not detected: <$@> <$output>"); } } $conf->cc_clean(); $self->_handle_ipv6_status($conf, $ipv6_status); return 1; } sub _handle_ipv6_status { my ($self, $conf, $ipv6_status) = @_; $conf->data->set( HAS_IPV6 => 1) if $ipv6_status; $ipv6_status ? $self->set_result('yes') : $self->set_result('no'); } 1; # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: config_h.pm000644000765000765 503712101554066 15623 0ustar00bruce000000000000parrot-6.6.0/config/gen# Copyright (C) 2001-2012, Parrot Foundation. =head1 NAME config/gen/config_h.pm - Configuration Header =head1 DESCRIPTION Generates F with platform-specific configuration values, F with platform-specific header information, and F with information on optional features. =cut package gen::config_h; use strict; use warnings; use base qw(Parrot::Configure::Step); use Parrot::Configure::Utils ':gen'; sub _init { my $self = shift; my %data; $data{description} = q{Generate C headers}; $data{result} = q{}; $data{templates} = { config_h => 'config/gen/config_h/config_h.in', feature_h => 'config/gen/config_h/feature_h.in', has_header_h => 'config/gen/config_h/has_header_h.in', }; return \%data; } sub runstep { my ( $self, $conf ) = @_; $conf->genfile($self->{templates}->{config_h}, 'include/parrot/config.h', ignore_pattern => 'PARROT_CONFIG_DATE', conditioned_lines => 1, manifest => [ "[main]", "include" ] ); $conf->genfile($self->{templates}->{feature_h}, 'include/parrot/feature.h', ignore_pattern => 'PARROT_CONFIG_DATE', feature_file => 1, manifest => [ "[main]", "include" ] ); my @sorted_keys = sort $conf->data->keys(); $conf->data->set( TEMP_header => join "\n", map { $conf->data->get($_) ? "#define PARROT_HAS_HEADER_" . uc(substr $_, 2) . " 1" : "#undef PARROT_HAS_HEADER_" . uc(substr $_, 2) } grep { /^i_\w+/ } @sorted_keys ); $conf->data->set( TEMP_has_config => join "\n", map { "#define PARROT_" . uc($_) . " 1" } grep { /^HAS_\w+/ && $conf->data->get($_) } @sorted_keys ); $conf->data->set( TEMP_d_config => join "\n", map { "#define PARROT_" . uc(substr $_, 2) . " " . $conf->data->get($_) } grep { /^D_\w+/ } @sorted_keys ); $conf->data->set( TEMP_cli_define => join "\n", map { "#define PARROT_DEF_" . uc($_) . " 1" } split /,/, $conf->options->get('define') || '' ); $conf->genfile($self->{templates}->{has_header_h}, 'include/parrot/has_header.h', manifest => [ "[main]", "include" ] ); return 1; } 1; # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: myconfig.in000644000765000765 170412133326621 17611 0ustar00bruce000000000000parrot-6.6.0/config/gen/config_pmSummary of my parrot @VERSION@ configuration: configdate='@configdate@' Platform: osname=@osname@, archname=@archname@ perl=@perl@ Compiler: cc='@cc@', ccflags='@ccflags@', Linker and Libraries: link='@link@', linkflags='@linkflags@', ld='@ld@', ldflags='@ldflags@', cc_ldflags='@cc_ldflags@', libs='@libs@' Dynamic Linking: cc_shared='@cc_shared@', link_dynamic='@link_dynamic@', ld_share_flags='@ld_share_flags@', ld_load_flags='@ld_load_flags@' Extensions: o='@o@', a='@a@', exe='@exe@', share_ext='@share_ext@', load_ext='@load_ext@' Misc Programs: ar='@ar@', ranlib='@ranlib@', make='@make@', make_set_make='@make_set_make@' Types: iv=@iv@, intvalsize=@intvalsize@, intsize=@intsize@, opcode_t=@opcode_t@, opcode_t_size=@opcodesize@, ptrsize=@ptrsize@, byteorder=@byteorder@, nv=@nv@, numvalsize=@numvalsize@, doublesize=@doublesize@, longdoublesize=@hugefloatvalsize@ list_h.in000644000765000765 1306511567202625 21304 0ustar00bruce000000000000parrot-6.6.0/t/tools/dev/headerizer/testlib/* Copyright (C) 2010, Parrot Foundation. =head1 NAME src/gc/list.h - Linked lists of allocated objects. =head1 DESCRIPTION Implementation of double linked lists used by various GC implementations. */ #ifndef PARROT_GC_LIST_H_GUARD #define PARROT_GC_LIST_H_GUARD /* Allocatable objects has headers to use in linked lists */ typedef struct List_Item_Header { struct List_Item_Header *prev; struct List_Item_Header *next; #ifndef NDEBUG struct Linked_List *owner; #endif } List_Item_Header; /* Double-linked list. */ /* N.B. List doesn't _own_ items */ typedef struct Linked_List { struct List_Item_Header *first; struct List_Item_Header *last; /* Cache object count in list. We use it very often */ size_t count; } Linked_List; /* Such headers allocated in front of real objects. */ /* There is helper macros to convert to/from real objects */ #define Obj2LLH(p) ((List_Item_Header *)((char*)(p) - sizeof (List_Item_Header))) #define LLH2Obj_typed(p, type) ((type*)((char*)(p) + sizeof (List_Item_Header))) #define LLH2Obj(p) LLH2Obj_typed(p, void) #ifdef NDEBUG # define SET_LIST_OWNER(l, i) #else # define SET_LIST_OWNER(l, i) (i)->owner = (l); #endif #define LIST_APPEND(l, i) \ do { \ List_Item_Header *_item = (i); \ Linked_List *_list = (l); \ \ if (_list->last) { \ _item->prev = _list->last; \ _list->last->next = _item; \ } \ else if (!_list->first) { \ _item->prev = NULL; \ _list->first = _item; \ } \ \ _list->last = _item; \ _item->next = NULL; \ \ SET_LIST_OWNER(_list, _item) \ _list->count++; \ } while (0); #define LIST_REMOVE(l, i) \ do { \ List_Item_Header *_item = (i); \ Linked_List *_list = (l); \ List_Item_Header *next = _item->next; \ List_Item_Header *prev = _item->prev; \ \ PARROT_ASSERT(_list == _item->owner); \ \ /* First _item */ \ if (_list->first == _item) \ _list->first = next; \ \ if (_list->last == _item) \ _list->last = prev; \ \ if (prev) \ prev->next = next; \ if (next) \ next->prev = prev; \ \ _list->count--; \ } while (0) /* HEADERIZER BEGIN: src/list.c */ /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */ PARROT_EXPORT void Parrot_list_append(SHIM_INTERP, ARGMOD(Linked_List *list), ARGMOD(List_Item_Header *item)) __attribute__nonnull__(2) __attribute__nonnull__(3) FUNC_MODIFIES(*list) FUNC_MODIFIES(*item); PARROT_EXPORT INTVAL Parrot_list_check(SHIM_INTERP, ARGIN(Linked_List *list)) __attribute__nonnull__(2); PARROT_EXPORT INTVAL Parrot_list_contains(SHIM_INTERP, ARGIN(Linked_List *list), ARGIN(List_Item_Header *item)) __attribute__nonnull__(2) __attribute__nonnull__(3); PARROT_EXPORT void Parrot_list_destroy(SHIM_INTERP, ARGMOD(Linked_List* list)) __attribute__nonnull__(2) FUNC_MODIFIES(* list); PARROT_EXPORT PARROT_CANNOT_RETURN_NULL struct Linked_List* Parrot_list_new(SHIM_INTERP); PARROT_EXPORT PARROT_CAN_RETURN_NULL List_Item_Header* Parrot_list_pop(PARROT_INTERP, ARGIN(Linked_List *list)) __attribute__nonnull__(1) __attribute__nonnull__(2); PARROT_EXPORT PARROT_CAN_RETURN_NULL List_Item_Header* Parrot_list_remove(SHIM_INTERP, ARGMOD(Linked_List *list), ARGMOD(List_Item_Header *item)) __attribute__nonnull__(2) __attribute__nonnull__(3) FUNC_MODIFIES(*list) FUNC_MODIFIES(*item); #define ASSERT_ARGS_Parrot_list_append __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(list) \ , PARROT_ASSERT_ARG(item)) #define ASSERT_ARGS_Parrot_list_check __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(list)) #define ASSERT_ARGS_Parrot_list_contains __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(list) \ , PARROT_ASSERT_ARG(item)) #define ASSERT_ARGS_Parrot_list_destroy __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(list)) #define ASSERT_ARGS_Parrot_list_new __attribute__unused__ int _ASSERT_ARGS_CHECK = (0) #define ASSERT_ARGS_Parrot_list_pop __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(list)) #define ASSERT_ARGS_Parrot_list_remove __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(list) \ , PARROT_ASSERT_ARG(item)) /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */ /* HEADERIZER END: src/list.c */ #endif /* PARROT_GC_LIST_H_GUARD */ /* * Local variables: * c-file-style: "parrot" * End: * vim: expandtab shiftwidth=4: */ genprog.bas000644000765000765 151411533177634 16241 0ustar00bruce000000000000parrot-6.6.0/examples/pir1 rem Copyright (C) 2008, Parrot Foundation. 3 rem 10 rem Hello 20 on error exit 1 100 rem ------------------ 110 rem Generating program 120 rem ------------------ 130 p = new("Program") 140 v = p.storeline(10, "rem Hello, world") 150 v = p.storeline(20, "hello = ""Hello, world""") 160 v = p.storeline(30, "print hello") 170 v = p.storeline(40, "?""Bye""") 180 v = p.storeline(100, "on error exit 42") 190 v = p.storeline(110, "error 10") 200 rem ------------------------------------------- 210 v= p.list(20, 40) 1000 rem ------------------------- 1010 rem Run the generated program 1020 rem ------------------------- 1030 r = new("Runner") 1040 v= r.set_program(p) 1050 print "----Running----" 1060 v= r.runloop(1) 1070 print "----Finished---" 1080 print "Exit code: "; v 1090 hello = r.get_var("hello") 1100 print "hello: "; hello 2000 exit resolve_deprecated.nqp000755000765000765 335511644422076 20002 0ustar00bruce000000000000parrot-6.6.0/tools/dev#! parrot-nqp # Copyright (C) 2011, Parrot Foundation. pir::load_bytecode("YAML/Tiny.pbc"); pir::load_bytecode("YAML/Dumper.pbc"); pir::load_bytecode("LWP/UserAgent.pbc"); pir::load_bytecode("nqp-setting.pbc"); pir::load_bytecode("dumper.pbc"); =begin NAME resolve_deprecated.nqp - Resolve deprecated features =end NAME =begin SYNOPSIS parrot-nqp tools/dev/resolve_deprecated.nqp =end SYNOPSIS =begin DESCRIPTION Resolve all freshly deprecated features listed in api.yaml by quering trac for status of ticket. =end DESCRIPTION =begin COMPLICATIONS YAML::Dumper produce way too complex YAML. We should extend YAML::Tiny to produce simplified version. =end COMPLICATIONS say("Parsing"); my @yaml := YAML::Tiny.new.read_string(slurp('api.yaml'))[0]; my $ua := pir::new(LWP::UserAgent); say("Processing"); for @yaml -> %e { # Skip items without ticket my $ticket := %e; next unless $ticket; # Skip already marked items next if any(-> $_ { $_ eq 'completed' }, %e); say("Checking $ticket"); # Request non-https version due limitation of LWP. my $response := $ua.get(subst($ticket ~ '?format=tab', /^https/, 'http')).content; #_dumper(['response', $response]); # cheat. split doesn't split properly on multiple tabs. So just check \tclosed\t my $/ := $response ~~ /\t ( "closed" ) \t/; next unless $/[0] eq 'closed'; say("Ticket $ticket is closed and can be marked as 'completed'"); %e.push('completed'); } say("Done"); spew("api.yaml", YAML::Tiny.new.write_string(@yaml)); sub any(&code, @list) { return 1 if &code($_) for @list; 0; } # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=perl6: 05-oplib.t000644000765000765 64711533177643 16407 0ustar00bruce000000000000parrot-6.6.0/t/compilers/opsc#!./parrot-nqp # Copyright (C) 2010, Parrot Foundation. # Checking for OpLib num and skip files parsing. pir::load_bytecode("opsc.pbc"); plan(2); my $lib := Ops::OpLib.new( :skip_file('src/ops/ops.skip'), ); ok( $lib.op_skip_table, "'abs_i_ic' in skiptable"); ok( $lib.op_skip_table, "'ne_nc_nc_ic' in skiptable"); #_dumper($lib.skiptable); # vim: expandtab shiftwidth=4 ft=perl6: random.pir000644000765000765 137511533177635 17205 0ustar00bruce000000000000parrot-6.6.0/examples/shootout#!./parrot # Copyright (C) 2005-2009, Parrot Foundation. # # random.pir N (N = 900000 for shootout) # by Joshua Isom .sub main :main .param pmc argv $S0 = argv[1] $I0 = $S0 while_1: gen_random(100.0) dec $I0 if $I0 > 1 goto while_1 $N0 = gen_random(100.0) $P0 = new 'FixedFloatArray' $P0 = 1 $P0[0] = $N0 $S0 = sprintf "%.9f\n", $P0 print $S0 .return(0) .end .const num IM = 139968.0 .const num IA = 3877.0 .const num IC = 29573.0 .sub gen_random .param num max .local num last last = 42.0 loop: $N0 = last $N0 *= IA $N0 += IC $N0 %= IM $N1 = max $N1 *= $N0 $N1 /= IM last = $N0 .yield($N1) get_params "0", max goto loop .end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: PullParserStartToken.pm000644000765000765 1005511644422074 20702 0ustar00bruce000000000000parrot-6.6.0/lib/Pod/Simple require 5; package Pod::Simple::PullParserStartToken; use Pod::Simple::PullParserToken (); use strict; use vars qw(@ISA $VERSION); @ISA = ('Pod::Simple::PullParserToken'); $VERSION = '3.19'; sub new { # Class->new(tagname, optional_attrhash); my $class = shift; return bless ['start', @_], ref($class) || $class; } # Purely accessors: sub tagname { (@_ == 2) ? ($_[0][1] = $_[1]) : $_[0][1] } sub tag { shift->tagname(@_) } sub is_tagname { $_[0][1] eq $_[1] } sub is_tag { shift->is_tagname(@_) } sub attr_hash { $_[0][2] ||= {} } sub attr { if(@_ == 2) { # Reading: $token->attr('attrname') ${$_[0][2] || return undef}{ $_[1] }; } elsif(@_ > 2) { # Writing: $token->attr('attrname', 'newval') ${$_[0][2] ||= {}}{ $_[1] } = $_[2]; } else { require Carp; Carp::croak( 'usage: $object->attr("val") or $object->attr("key", "newval")'); return undef; } } 1; __END__ =head1 NAME Pod::Simple::PullParserStartToken -- start-tokens from Pod::Simple::PullParser =head1 SYNOPSIS (See L) =head1 DESCRIPTION When you do $parser->get_token on a L object, you might get an object of this class. This is a subclass of L and inherits all its methods, and adds these methods: =over =item $token->tagname This returns the tagname for this start-token object. For example, parsing a "=head1 ..." line will give you a start-token with the tagname of "head1", token(s) for its content, and then an end-token with the tagname of "head1". =item $token->tagname(I) This changes the tagname for this start-token object. You probably won't need to do this. =item $token->tag(...) A shortcut for $token->tagname(...) =item $token->is_tag(I) or $token->is_tagname(I) These are shortcuts for C<< $token->tag() eq I >> =item $token->attr(I) This returns the value of the I attribute for this start-token object, or undef. For example, parsing a LZ<> link will produce a start-token with a "to" attribute with the value "Foo", a "type" attribute with the value "pod", and a "section" attribute with the value "Bar". =item $token->attr(I, I) This sets the I attribute for this start-token object to I. You probably won't need to do this. =item $token->attr_hash This returns the hashref that is the attribute set for this start-token. This is useful if (for example) you want to ask what all the attributes are -- you can just do C<< keys %{$token->attr_hash} >> =back You're unlikely to ever need to construct an object of this class for yourself, but if you want to, call C<< Pod::Simple::PullParserStartToken->new( I, I ) >> =head1 SEE ALSO L, L, L =head1 SEE ALSO L, L, L =head1 SUPPORT Questions or discussion about POD and Pod::Simple should be sent to the pod-people@perl.org mail list. Send an empty email to pod-people-subscribe@perl.org to subscribe. This module is managed in an open GitHub repository, L. Feel free to fork and contribute, or to clone L and send patches! Patches against Pod::Simple are welcome. Please send bug reports to . =head1 COPYRIGHT AND DISCLAIMERS Copyright (c) 2002 Sean M. Burke. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. This program is distributed in the hope that it will be useful, but without any warranty; without even the implied warranty of merchantability or fitness for a particular purpose. =head1 AUTHOR Pod::Simple was created by Sean M. Burke . But don't bother him, he's retired. Pod::Simple is maintained by: =over =item * Allison Randal C =item * Hans Dieter Pearcey C =item * David E. Wheeler C =back =cut pmcs.json000644000765000765 170712356767111 15400 0ustar00bruce000000000000parrot-6.6.0/docs/index{ "page" : "pmc", "content" : [ { "source" : [ "tools/dev/gen_class.pl" ], "title" : "Tools" }, { "source" : [ "src/pmc/default.pmc", "src/pmc/scalar.pmc", "src/pmc/packfilesegment.pmc" ], "title" : "Abstract PMCs" }, { "source" : "src/pmc/*.pmc", "title" : "Core PMCs", "exclude" : [ "src/pmc/default.pmc", "src/pmc/scalar.pmc", "src/pmc/packfilesegment.pmc" ] }, { "source" : "src/dynpmc/*.pmc", "title" : "Dynamic PMCs", "exclude" : [ "src/dynpmc/rotest.pmc", "src/dynpmc/subproxy.pmc", "src/dynpmc/pccmethod_test.pmc", "src/dynpmc/foo.pmc", "src/dynpmc/foo2.pmc", "src/dynpmc/osdummy.pmc" ] } ], "title" : "PMCs" } subs.pod000644000765000765 3246112101554066 14703 0ustar00bruce000000000000parrot-6.6.0/docs/pmc# Copyright (C) 2003-2012, Parrot Foundation. =pod =head1 NAME Parrot Subroutines =head1 ABSTRACT This document describes how to define, call, and return from Parrot subroutine objects and other invokables. =head1 DESCRIPTION Parrot comes with different subroutine and related classes which implement CPS (Continuation Passing Style) and PCC (Parrot Calling Conventions) F. =head2 Class Tree These are all of the built-in classes that are directly callable, or "invokable": Sub Closure Coroutine Eval Continuation ExceptionHandler By "invokable" we mean that they can be supplied as the first argument to the C, C, or C instructions. Generally speaking, invokable objects are divided into two subtypes: C and classes that are built on it create a new context when invoked, and C classes return control to an existing context that was captured when the C was created. There are (of course) two classes that straddle this distinction: =over 4 =item 1. Invoking a C object creates a new context for the sub it refers to directly, but it also captures an "outer" context that provides bindings for the immediately-enclosing lexical scope (and, if that context is itself is for a C, the subsequent scopes working outwards). [add a C example? -- rgr, 6-Apr-08.] =item 2. A C acts like a normal sub when called initially, and can also return normally, but acts like a continuation when exited via the C instruction and re-entered by re-invoking. [need a reference to a C example. -- rgr, 6-Apr-08.] =back =head1 SYNOPSIS =head2 Creating subs Subs are created by IMCC (the PIR compiler) via the B<.sub> directive. Unless the C<:anon> pragma is included, they are stored in the constant table associated with the bytecode and can be fetched with the B and B opcodes. Within the PIR source, they can also be put in registers with a C<.const 'Sub'> declaration: =begin PIR_FRAGMENT .const 'Sub' rsub = 'random_sub' =end PIR_FRAGMENT This uses C under the hood to look up the sub named "random_sub". Here's an example of fetching a sub from another namespace: =begin PIR .sub main :main get_hll_global $P0, ['Other'; 'Namespace'], "the_sub" $P0() print "back\n" .end .namespace ['Other'; 'Namespace'] .sub the_sub print "in sub\n" .end =end PIR Note that C could be defined in a different bytecode or PIR source file from C
. =head2 Program entry point One subroutine in the first executed source or bytecode file may be flagged as the "main" subroutine, where execution starts. =begin PIR .sub the_main_event :main # ... .end =end PIR In the absence of a B<:main> entry Parrot starts execution at the first statement. Any C<:main> directives in a subsequent PIR or bytecode file that are loaded under program control are ignored. Note that if the first executed source or bytecode file contains more than one sub flagged as C<:main>, Parrot currently picks the I such sub to start execution. This is arguably a bug, so users should not depend upon it. =head2 Load-time initialization If a subroutine is marked as B<:load> this subroutine is run, before the B opcode returns. e.g. =begin PIR .sub main :main print "in main\n" load_bytecode "library_code.pir" print "back to main\n" .end # library_code.pir .sub _my_lib_init :load print "initializing library\n" .end =end PIR If a subroutine is marked as B<:init> this subroutine is run before the B<:main> or the first subroutine in the source file runs. Unlike B<:main> subs, B<:init> subs are also run when compiling from memory. B<:load> subs are run only in any source or bytecode files loaded subsequently. These markers are called "pragmas", and are defined fully in L. The following table summarizes the behavior of the five pragmas that cause Parrot to run a sub implicitly: ------ Executed when -------- compiling to -- loading -- Sub Pragma disk memory first after ========== ==== ====== ===== ===== :immediate yes yes no no :postcomp yes no no no :load no no no yes :init no yes yes no :main no no yes no The same load-time behavior applies regardless of whether the loaded file is PIR source or bytecode. Note that it is possible to mark a sub with both B<:load> and B<:init>. =head2 Defining subs A sub is defined by a block of code starting with C<.sub> and ending with C<.end>. Parameters which the sub can be called with are defined by C<.param>: =begin PIR .sub do_something .param pmc a_pmc .param string some_string #do something .end =end PIR The set of C<.param> instructions are converted to a single C instruction. The compiler will decide which registers to use. =begin PIR_FRAGMENT get_params '(0,0)', $P0, $S0 =end PIR_FRAGMENT A parameter can be declared optional with the C<:optional> command. If an optional parameter is followed by parameter declared C<:opt_flag>, this parameter will store an integer indicating whether the optional parameter was used. =begin PIR_FRAGMENT .param string maybe :optional .param int has_maybe :opt_flag unless has_maybe goto no_maybe #do something with maybe no_maybe: #don't use maybe =end PIR_FRAGMENT A sub can accept an arbitrary number of parameters by declaring a C<:slurpy> parameter. This creates a pmc containing an array of all parameters passed to the sub, these can be accessed like so: =begin PIR_FRAGMENT .param pmc all_params :slurpy $P0 = all_params[0] $S0 = all_params[1] =end PIR_FRAGMENT A slurpy parameter can also be defined after a set of positional parameters, in which case it will only hold any additional parameters passed. A parameter may also be declared C<:named>, giving them a string which can be used when calling the sub to explicitly assign a parameter, ignoring position. =begin PIR_FRAGMENT .param int counter :named("counter") =end PIR_FRAGMENT This can be combined with C<:optional> as well as C<:opt_flag>, so that the parameter need only be passed when necessary. If a parameter is declared with C<:slurpy> and C<:named> (with no string), it creates an associative array containing all named parameters which can be accessed like so: =begin PIR_FRAGMENT .param pmc all_params :slurpy :named $S0 = all_params['name'] $I0 = all_params['counter'] =end PIR_FRAGMENT =head2 Calling the sub PIR sub invocation syntax is similar to HLL syntax: =begin PIR_FRAGMENT $P0 = do_something($P1, $S3) =end PIR_FRAGMENT This is syntactic sugar for the following four bytecode instructions: =begin PIR_FRAGMENT # Establish arguments. set_args '(0,0)', $P1, $S3 # Find the sub. $P8 = find_sub_not_null "do_something" # Establish return values. get_results '(0)', $P0 # Call the sub in $P8, implicitly creating a return continuation. invokecc $P8 =end PIR_FRAGMENT The sub name could be replaced with a PMC register, in which case the C instruction would not be needed. If the return values from the sub were ignored (by dropping the C<$P0 => part), the C instruction would be omitted. However, C is emitted even in the case of a call without arguments. The first operands to the C and C instructions are actually placeholders for an integer array that describes the register types. For example, the '(0,0)' for C is replaced internally with C<[2, 1]>, which means "two arguments, of type PMC and string". Note that return values get the same register type coercion as sub parameters. This is all described in much more detail in L. Named parameters can be explicity called in one of two ways: =begin PIR_FRAGMENT $P5 = do_something($I6 :named("counter"), $S4 :named("name")) #or equivalently $P5 = do_something("counter" => $I6, "name" => $S4) =end PIR_FRAGMENT To receive multiple values, put the register names in parentheses: =begin PIR_FRAGMENT ($P10, $P11) = do_something($P1, $S3) ($P10, $P11) = do_something($P1, $S3) =end PIR_FRAGMENT To test whether a value was returned, declare it C<:optional>, and follow it with an integer register declared C<:opt_val>: =begin PIR_FRAGMENT_INVALID ($P10 :optional, $I10 :opt_val) = do_something($P1, $S3) =end PIR_FRAGMENT_INVALID A C<:slurpy> value can be declared, as in parameter declarations, to catch an arbitrary number of return values: =begin PIR_FRAGMENT ($P12, $P13 :slurpy) = do_something($P1, $S3) =end PIR_FRAGMENT Note that the parameters stored in a C<:slurpy>, or C<:slurpy> C<:named> array can be used as parameters for another call using the C<:flat> declaration: =begin PIR_FRAGMENT ($P14, $P15) = do_something($P13 :flat) =end PIR_FRAGMENT Subs may also return C<:named> values, which can be explicitly accessed similar to parameter declarations: =begin PIR_FRAGMENT ($I11 :named("counter"), $S4 :named("name")) = do_something($P1, $S3) =end PIR_FRAGMENT All of these affect only the signature provided via C. [not sure what this is for, leaving it alone for now -aninhumer] =begin PIR_FRAGMENT # Call the sub in $P8, with continuation (created earlier) in $P9. invoke $P8, $P9 =end PIR_FRAGMENT =head2 Returning from a sub PIR supports a convenient syntax for returning any number of values from a sub or closure: =begin PIR .sub main .return ($P0, $I1, $S3) .end =end PIR Integer, float, and string constants are also accepted. This is translated to: =begin PIR_FRAGMENT set_returns '(0,0,0)', $P0, $I1, $S3 returncc # return by calling the current continuation =end PIR_FRAGMENT As for C, the '(0,0,0)' is actually a placeholder for an integer array that describes the register types; it is replaced internally with C<[2, 0, 1]>, which means "three arguments, of type PMC, integer, and string". All of the declarations allowed for calls to a sub can also be used with return values. (C<:named>, C<:flat>) Another way to return from a sub is to use tail-calling, which calls a new sub with the current continuation, so that the new sub returns directly to the caller of the old sub (i.e. without first returning to the old sub). This passes the three values to C via tail-calling: =begin PIR .sub main .tailcall another_sub($P0, $I1, $S3) .end =end PIR This is translated into a C instruction for the call, but with C instead of C: =begin PIR_FRAGMENT set_args '(0,0,0)', $P0, $I1, $S3 $P8 = find_sub_not_null "another_sub" tailcall $P8 =end PIR_FRAGMENT As for calling, the sub name could be replaced with a PMC register, in which case the C instruction would not be needed. If needed, the current continuation can be extracted and called explicitly as follows: =begin PIR_FRAGMENT ## This is what defines .INTERPINFO_CURRENT_CONT. .include 'interpinfo.pasm' ## Store our return continuation as exit_cont. .local pmc exit_cont exit_cont = interpinfo .INTERPINFO_CURRENT_CONT ## Invoke it explicitly: invokecc exit_cont ## ... or equivalently: tailcall exit_cont =end PIR_FRAGMENT To return values, use C as before. =head2 All together now The following complete example illustrates the typical call/return pattern: =begin PIR .sub main :main print "in main\n" the_sub() print "back to main\n" .end .sub the_sub print "in sub\n" .end =end PIR Notice that we are not passing or returning values here. [example of passing values. this could get pretty elaborate; look for other examples first. -- rgr, 6-Apr-08.] If a short subroutine is called several times, for instance inside a loop, the creation of the return continuation can be done outside the loop: =begin PIR_INVALID .sub main :main ## Initialize the sub and the return cont. .local pmc cont cont = new 'Continuation' set_addr cont, ret_label .const .Sub rsub = 'random_sub' ## Loop initialization. .local int loop_max, i loop_max = 1000000 i = 0 ## Main loop. again: set_args '(0)', i invoke rsub, cont ret_label: ## This is where "cont" returns. inc i if i < loop_max goto again .end .sub random_sub .param int foo ## do_something .end =end PIR_INVALID If the sub returns values, the C must be B C in order to receive them. Since this is much more obscure than the PIR calling syntax, it should only be done if there is a measurable performance advantage. Even in this trivial example, calling "rsub(i)" is only about a third slower on x86. =head1 FILES F, F, F, F, F, F =head1 SEE ALSO F F =head1 AUTHOR Leopold Toetsch =cut __END__ Local Variables: fill-column:78 End: Methody.pm000644000765000765 674711644422074 16200 0ustar00bruce000000000000parrot-6.6.0/lib/Pod/Simple require 5; package Pod::Simple::Methody; use strict; use Pod::Simple (); use vars qw(@ISA $VERSION); $VERSION = '3.19'; @ISA = ('Pod::Simple'); # Yes, we could use named variables, but I want this to be impose # as little an additional performance hit as possible. sub _handle_element_start { $_[1] =~ tr/-:./__/; ( $_[0]->can( 'start_' . $_[1] ) || return )->( $_[0], $_[2] ); } sub _handle_text { ( $_[0]->can( 'handle_text' ) || return )->( @_ ); } sub _handle_element_end { $_[1] =~ tr/-:./__/; ( $_[0]->can( 'end_' . $_[1] ) || return )->( $_[0] ); } 1; __END__ =head1 NAME Pod::Simple::Methody -- turn Pod::Simple events into method calls =head1 SYNOPSIS require 5; use strict; package SomePodFormatter; use base qw(Pod::Simple::Methody); sub handle_text { my($self, $text) = @_; ... } sub start_head1 { my($self, $attrs) = @_; ... } sub end_head1 { my($self) = @_; ... } ...and start_/end_ methods for whatever other events you want to catch. =head1 DESCRIPTION This class is of interest to people writing Pod formatters based on Pod::Simple. This class (which is very small -- read the source) overrides Pod::Simple's _handle_element_start, _handle_text, and _handle_element_end methods so that parser events are turned into method calls. (Otherwise, this is a subclass of L and inherits all its methods.) You can use this class as the base class for a Pod formatter/processor. =head1 METHOD CALLING When Pod::Simple sees a "=head1 Hi there", for example, it basically does this: $parser->_handle_element_start( "head1", \%attributes ); $parser->_handle_text( "Hi there" ); $parser->_handle_element_end( "head1" ); But if you subclass Pod::Simple::Methody, it will instead do this when it sees a "=head1 Hi there": $parser->start_head1( \%attributes ) if $parser->can('start_head1'); $parser->handle_text( "Hi there" ) if $parser->can('handle_text'); $parser->end_head1() if $parser->can('end_head1'); If Pod::Simple sends an event where the element name has a dash, period, or colon, the corresponding method name will have a underscore in its place. For example, "foo.bar:baz" becomes start_foo_bar_baz and end_foo_bar_baz. See the source for Pod::Simple::Text for an example of using this class. =head1 SEE ALSO L, L =head1 SUPPORT Questions or discussion about POD and Pod::Simple should be sent to the pod-people@perl.org mail list. Send an empty email to pod-people-subscribe@perl.org to subscribe. This module is managed in an open GitHub repository, L. Feel free to fork and contribute, or to clone L and send patches! Patches against Pod::Simple are welcome. Please send bug reports to . =head1 COPYRIGHT AND DISCLAIMERS Copyright (c) 2002 Sean M. Burke. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. This program is distributed in the hope that it will be useful, but without any warranty; without even the implied warranty of merchantability or fitness for a particular purpose. =head1 AUTHOR Pod::Simple was created by Sean M. Burke . But don't bother him, he's retired. Pod::Simple is maintained by: =over =item * Allison Randal C =item * Hans Dieter Pearcey C =item * David E. Wheeler C =back =cut uuid.t000644000765000765 555311533177644 14553 0ustar00bruce000000000000parrot-6.6.0/t/library#!./parrot # Copyright (C) 2008-2010, Parrot Foundation. =head1 NAME t/library/uuid.t =head1 SYNOPSIS % prove t/library/uuid.t =head1 DESCRIPTION uuid library tests =cut .sub main :main load_bytecode 'uuid.pbc' .include 'test_more.pir' plan(20) test_generate_1() test_generate_2() test_generate_random() test_generate_time() test_parse_1() test_parse_2() test_time() test_type() test_variant() .end .sub test_generate_1 $P0 = get_global ['uuid'], 'generate' $P1 = $P0() $S1 = typeof $P1 is($S1,'uuid', 'generate 1') .end .sub test_generate_2 $P0 = get_global ['uuid'], 'generate' $P1 = $P0() like($P1, '<[0..9a..f]>**8\-<[0..9a..f]>**4\-<[0..9a..f]>**4\-<[0..9a..f]>**4\-<[0..9a..f]>**12', 'generate 2' ) .end .sub test_generate_random $P0 = get_global ['uuid'], 'generate_random' $P1 = $P0() like($P1, '<[0..9a..f]>**8\-<[0..9a..f]>**4\-<[0..9a..f]>**4\-<[0..9a..f]>**4\-<[0..9a..f]>**12', 'generate random') .end .sub test_generate_time $P0 = get_global ['uuid'], 'generate_time' $P1 = $P0() like($P1, '<[0..9a..f]>**8\-<[0..9a..f]>**4\-<[0..9a..f]>**4\-<[0..9a..f]>**4\-<[0..9a..f]>**12', 'generate time') .end .sub test_parse_1 $P0 = get_global ['uuid'], 'parse' ($I0, $P1) = $P0("84949cc5-4701-4a84-895b-354c584a981b") is($I0, 0, 'parse 1') $S1 = typeof $P1 is($S1, 'uuid', 'parse 1') .end .sub test_parse_2 $P0 = get_global ['uuid'], 'parse' $I0 = $P0("84949cc5-4701-4a84-895b-354c584a981b") is($I0, 0, 'parse 2') $I0 = $P0("84949CC5-4701-4A84-895B-354C584A981B") is($I0, 0, 'parse 2') $I0 = $P0("84949cc5-4701-4a84-895b-354c584a981bc") is($I0, -1, 'parse 2') $I0 = $P0("84949cc5-4701-4a84-895b-354c584a981") is($I0, -1, 'parse 2') $I0 = $P0("84949cc5x4701-4a84-895b-354c584a981b") is($I0, -1, 'parse 2') $I0 = $P0("84949cc504701-4a84-895b-354c584a981b") is($I0, -1, 'parse 2') $I0 = $P0("84949cc5-470104a84-895b-354c584a981b") is($I0, -1, 'parse 2') $I0 = $P0("84949cc5-4701-4a840895b-354c584a981b") is($I0, -1, 'parse 2') $I0 = $P0("84949cc5-4701-4a84-895b0354c584a981b") is($I0, -1, 'parse 2') $I0 = $P0("g4949cc5-4701-4a84-895b-354c584a981b") is($I0, -1, 'parse 2') $I0 = $P0("84949cc5-4701-4a84-895b-354c584a981g") is($I0, -1, 'parse 2') .end .sub test_time $P0 = get_global ['uuid'], 'parse' ($I0, $P1) = $P0("84949cc5-4701-4a84-895b-354c584a981b") $I1 = $P1.'time'() is($I1, -1, 'time') .end .sub test_type $P0 = get_global ['uuid'], 'generate' $P1 = $P0() $I0 = $P1.'type'() is($I0, 4, 'type') .end .sub test_variant $P0 = get_global ['uuid'], 'generate' $P1 = $P0() $I0 = $P1.'variant'() is($I0, 1, 'variant') .end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: index.json000644000765000765 457512101554066 15542 0ustar00bruce000000000000parrot-6.6.0/docs/index{ "page" : "index", "content" : [ { "source" : [ "docs/intro.pod", "docs/book/pct/ch02_getting_started.pod", "docs/parrot.pod", "docs/project/roles_responsibilities.pod", "docs/parrothist.pod", "DONORS.pod", "docs/glossary.pod", "docs/project/support_policy.pod" ], "title" : "Introduction" }, { "source" : [ "docs/running.pod", "docs/tests.pod", "docs/gettingstarted.pod", "docs/submissions.pod" ], "title" : "Working with Parrot" }, { "source" : [ "docs/book/pct/ch03_compiler_tools.pod", ":pct_tutorial", "docs/book/pct/ch04_pge.pod", "docs/book/pct/ch05_nqp.pod", "docs/compiler_faq.pod" ], "title" : "Implementing Languages on Parrot" }, { "source" : [ "docs/overview.pod", ":pdds", ":pmc", ":ops", ":developer", ":tools", "editor/README.pod" ], "title" : "Design, Internals & Development" }, { "source" : [ "docs/book/pir/*" ], "title" : "PIR Book" }, { "source" : [ "docs/book/pct/*" ], "title" : "PCT Book" }, { "source" : [ "docs/book/draft/ch01_introduction.pod", "docs/book/draft/ch02_getting_started.pod", "docs/book/draft/ch07_dynpmcs.pod", "docs/book/draft/ch08_dynops.pod", "docs/book/draft/ch10_opcode_reference.pod", "docs/book/draft/ch11_directive_reference.pod", "docs/book/draft/ch12_operator_reference.pod", "docs/book/draft/chXX_hlls.pod", "docs/book/draft/chXX_library.pod", "docs/book/draft/chXX_testing_and_debugging.pod", "docs/book/draft/appa_glossary.pod", "docs/book/draft/appb_patch_submission.pod", "docs/book/draft/appc_command_line_options.pod", "docs/book/draft/appd_build_options.pod", "docs/book/draft/appe_source_code.pod" ], "title" : "Parrot Developer's Guide: PIR (draft)" } ], "title" : "Home" } Compiler.pir000644000765000765 2516612234733135 17204 0ustar00bruce000000000000parrot-6.6.0/compilers/tge/TGE# Copyright (C) 2005-2009, Parrot Foundation. =head1 NAME TGE::Compiler - A compiler for the grammar syntax of TGE. =head1 DESCRIPTION TGE::Compiler is a compiler for the grammar syntax of Tree Grammar Engine. =cut .namespace [ 'TGE'; 'Compiler' ] .sub __onload :load $P0 = get_class [ 'TGE'; 'Grammar' ] $P1 = subclass $P0, [ 'TGE'; 'Compiler' ] .end =head2 parse_grammar Take the source string for a tree grammar, and return a sensible data structure. =cut .sub parse_grammar :method .param string source # Parse the source string and build a match tree .local pmc match .local pmc start_rule start_rule = get_hll_global ['TGE';'Parser'], "start" match = start_rule(source, 'grammar'=>'TGE::Parser') # Verify the parse unless match goto err_parse # if parse fails, stop # say 'parse succeeded' # say 'Match tree dump:' # load_bytecode "dumper.pbc" # load_bytecode "PGE/Dumper.pbc" # '_dumper'(match, "match") # Transform the parse tree and return the result .local pmc tree_match tree_match = self.'apply'(match) $P5 = tree_match.'get'('result') # say 'Data structure dump:' # '_dumper'($P5, "syntax tree") .return($P5) err_parse: print "Unable to parse the tree grammar.\n" exit 1 end .end .sub init :vtable :method self.'add_rule'("ROOT", "result", ".", "ROOT_result") self.'add_rule'("statements", "result", ".", "statements_result") self.'add_rule'("statement", "result", ".", "statement_result") self.'add_rule'("transrule", "result", ".", "transrule_result") self.'add_rule'("grammardec", "result", ".", "grammardec_result") self.'add_rule'("type", "value", ".", "type_value") self.'add_rule'("inherit", "value", ".", "inherit_value") self.'add_rule'("name", "value", ".", "name_value") self.'add_rule'("parent", "value", ".", "parent_value") self.'add_rule'("action", "value", ".", "action_value") self.'add_rule'("language", "value", ".", "language_value") .end .sub ROOT_result :method .param pmc tree .param pmc node $I0 = exists node["TGE::Parser::statements"] unless $I0 goto err_no_tree $P0 = node["TGE::Parser::statements"] $P2 = tree.'get'('result', $P0, 'statements') .return ($P2) err_no_tree: print "Top-level rule did not match.\n" .return () .end .sub statements_result :method .param pmc tree .param pmc node .local pmc statements statements = new 'ResizablePMCArray' # Iterate over the list of statements, and generate a processed tree for # each statement. Return an array of all the processed statements. .local pmc it it = iter node # loop over the array loop_start: unless it goto loop_end $P1 = shift it $P2 = tree.'get'('result', $P1, 'statement') push statements, $P2 goto loop_start loop_end: .return (statements) err_no_tree: print "This grammar contained no statements.\n" .return (statements) .end .sub statement_result :method .param pmc tree .param pmc node .local pmc result .local pmc it $P0 = node.'hash'() it = iter $P0 # setup iterator for node iter_loop: unless it, iter_end # while (entries) ... shift $S1, it # get the key of the iterator $P2 = it[$S1] result = tree.'get'('result', $P2, $S1) goto iter_loop iter_end: .return (result) .end .sub transrule_result :method .param pmc tree .param pmc node .local pmc rule rule = new 'Hash' .local pmc it $P0 = node.'hash'() it = iter $P0 # setup iterator for node iter_loop: unless it, iter_end # while (entries) ... $P3 = new 'Undef' shift $S1, it # get the key of the iterator $P2 = it[$S1] $P3 = tree.'get'('value', $P2, $S1) rule[$S1] = $P3 goto iter_loop iter_end: $I0 = defined rule["parent"] if $I0 goto parent_defined rule["parent"] = "." parent_defined: rule["build"] = "rule" .return (rule) err_no_rule: print "Unable to find all the components of a rule definition\n" exit 1 .return () .end .sub grammardec_result :method .param pmc tree .param pmc node .local pmc decl decl = new 'Hash' .local pmc it $P0 = node.'hash'() it = iter $P0 # setup iterator for node iter_loop: unless it, iter_end # while (entries) ... $P3 = new 'Undef' shift $S1, it # get the key of the iterator $P2 = it[$S1] $P3 = tree.'get'('value', $P2, $S1) decl[$S1] = $P3 goto iter_loop iter_end: decl["build"] = "grammar" .return (decl) .end # The attribute 'value' on nodes of type 'inherit'. .sub inherit_value :method .param pmc tree .param pmc node $P1 = node[0] $P2 = $P1['type'] .local pmc value value = tree.'get'('value', $P2, 'type') .return (value) .end # The attribute 'value' on nodes of type 'type'. .sub type_value :method .param pmc tree .param pmc node .local pmc value value = new 'String' $S2 = node value = $S2 .return (value) .end # The attribute 'value' on nodes of type 'name'. .sub name_value :method .param pmc tree .param pmc node .local pmc name name = new 'String' $P2 = node $S1 = $P2 name = $S1 .return (name) .end # The attribute 'value' on nodes of type 'parent'. .sub parent_value :method .param pmc tree .param pmc node .local pmc value value = new 'String' $P2 = node[0] $P3 = $P2[0] $S1 = $P3 value = $S1 .return (value) .end # The attribute 'value' on nodes of type 'action'. .sub action_value :method .param pmc tree .param pmc node .local pmc value, infile .local int lineno value = new 'StringBuilder' infile = get_global '$!infile' $P2 = node[0] (lineno) = $P2.'line_number'() push value, '#line ' $S0 = lineno push value, $S0 push value, ' ' push value, infile push value, "\n" push value, $P2 .return (value) .end # The attribute 'value' on nodes of type 'language'. # (This will be refactored out to a general syntax for modifiers.) .sub language_value :method .param pmc tree .param pmc node .local pmc value value = new 'String' $P2 = node[0] $P3 = $P2[0] $S1 = $P3 value = $S1 .return (value) .end =head2 precompile Compile a grammar from a source string. =cut .sub 'precompile' :method .param string source .param string infile :optional .param int has_infile :opt_flag .local pmc rule_data .local string outstring .local string header_string if has_infile goto quote_infile infile = '' goto have_infile quote_infile: infile = concat '"', infile infile = concat infile, '"' have_infile: $P0 = new 'String' $P0 = infile set_global '$!infile', $P0 # Unnamed grammars are class 'AnonGrammar' .local string grammarname grammarname = 'AnonGrammar' rule_data = self.'parse_grammar'(source) # Construct grammar rules from the data structure of rule info .local pmc statement .local pmc it it = iter rule_data # loop over the rule info loop_start: unless it goto loop_end statement = shift it $S0 = statement['build'] unless $S0 == 'rule' goto grammar_build $S1 = self.'rule_string'(statement) outstring .= $S1 $S2 = self.'rule_header'(statement) header_string .= $S2 goto loop_start grammar_build: $S1 = self.'grammar_string'(statement) outstring .= $S1 grammarname = statement['type'] goto loop_start loop_end: outstring .= "\n.sub init :vtable :method\n" outstring .= header_string outstring .= "\n.end\n" .return (outstring, grammarname) .end .sub 'compile' :method .param string source .local pmc compiler compiler = compreg "PIR" .local string code .local string grammarname .local pmc libloader .local pmc new_grammar (code, grammarname) = self.'precompile'(source) unless grammarname == 'AnonGrammar' goto named_grammar $P2 = new 'Hash' $P2['type'] = 'AnonGrammar' $P2['inherit'] = 'TGE::Grammar' $S1 = self.'grammar_string'($P2) code = $S1 . code named_grammar: libloader = compiler(code) libloader = libloader.'first_sub_in_const_table'() libloader() new_grammar = new grammarname .return (new_grammar) .end .sub 'rule_header' :method .param pmc rule .local string output .local string type .local string name .local string parent type = rule["type"] name = rule["name"] parent = rule["parent"] output = " self.'add_rule'('" output .= type output .= "', '" output .= name output .= "', '" output .= parent output .= "', '_" output .= type output .= "_" output .= name output .= "')\n" .return (output) .end .sub 'rule_string' :method .param pmc rule .local string code code = "\n.sub '_" $S1 = rule["type"] code .= $S1 code .= "_" $S2 = rule["name"] code .= $S2 code .= "' :method\n" code .= " .param pmc tree\n" code .= " .param pmc node\n" $S3 = rule["action"] code .= $S3 code .= "\n.end\n\n" .return (code) .end # NOTE - this code assumes that a type of '' is impossible # (in older versions of Parrot, it was) .sub 'grammar_string' :method .param pmc grammar .local string code .local string type .local string inherit type = grammar["type"] inherit = grammar["inherit"] .local string inherit_key, type_key inherit_key = self.'classname_key'(inherit) type_key = self.'classname_key'(type) code = "\n.namespace" code .= type_key no_type: code .= "\n\n" code .= ".sub '__onload' :load :init\n" code .= " load_bytecode 'TGE.pbc'\n" code .= " push_eh class_loaded\n" code .= " $P1 = subclass " code .= inherit_key code .= ", " code .= type_key code .= "\n" code .= " class_loaded:\n" code .= " pop_eh\n" code .= "\n.end\n\n" .return (code) .end .sub 'classname_key' :method .param string name .local string key .local pmc parts parts = split '::', name # If splitting on '::' doesn't break down name, try splitting on ';'. $I0 = elements parts if $I0 > 1 goto build_key parts = split ';', name build_key: key = " [ '" $S0 = join "'; '", parts key .= $S0 key .= "' ]" .return (key) .end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: single_retval.pir000644000765000765 165711533177635 17656 0ustar00bruce000000000000parrot-6.6.0/examples/subs# Copyright (C) 2001-2008, Parrot Foundation. =head1 NAME examples/subs/single_retval.pir - Subroutine example =head1 SYNOPSIS % ./parrot examples/subs/single_retval.pir =head1 DESCRIPTION Simple subroutine calls with 1 return value. =head1 SEE ALSO F F =cut .sub example :main .local int i i = 7 $I1 = 8 .local string s s = "nine" $I2 = 10 # subs accept locals and registers $I0 = foo(i, $I1, s, $I2) print "return: " print $I0 print "\n" # subs accept locals and registers ( $I3 ) = foo(i, $I1, s, $I2) print "return: " print $I3 print "\n" .end .sub foo .param int i .param int j .param string s .param string k print i print " " print j print " " print s print " " print k print "\n" .return( 10 ) .end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: 42-cond-loop.t000644000765000765 162012101554067 17056 0ustar00bruce000000000000parrot-6.6.0/ext/nqp-rx/t/nqp#!./parrot-nqp # combination of conditional modifier and loop modifier plan(8); my $a; my $s; $a := 0; $s := 0; $s := 5 if $a > 7 while $a++ < 9; ok( $s == 5 && $a == 10, 'true if + while'); $a := 0; $s := 0; $s := 5 if $a > 17 while $a++ < 9; ok( $s == 0 && $a == 10, 'false if + while'); $a := 0; $s := 0; $s := 5 if $a > 7 until $a++ > 9; ok( $s == 5 && $a == 11, 'true if + until'); $a := 0; $s := 0; $s := 5 if $a > 17 until $a++ > 9; ok( $s == 0 && $a == 11, 'false if + until'); $a := 0; $s := 0; $s := 5 unless $a > 0 while $a++ < 9; ok( $s == 0 && $a == 10, 'true unless + while'); $a := 0; $s := 0; $s := 5 unless $a < 0 while $a++ < 9; ok( $s == 5 && $a == 10, 'false unless + while'); $a := 0; $s := 0; $s := 5 if $a > 0 until $a++ > 9; ok( $s == 5 && $a == 11, 'true unless + until'); $a := 0; $s := 0; $s := 5 if $a < 0 until $a++ > 9; ok( $s == 0 && $a == 11, 'false unless + until'); select.pmc000644000765000765 2363012356767111 15564 0ustar00bruce000000000000parrot-6.6.0/src/dynpmc/* Copyright (C) 2011,2014, Parrot Foundation. =head1 NAME src/dynpmc/select.pmc - Select PMC =head1 DESCRIPTION This is the base-class for non-blocking IO using select(). =head2 Functions =over 4 =cut */ #include "parrot/parrot.h" #include "../src/io/io_private.h" #include "pmc/pmc_filehandle.h" #include #include #include #include #define SELECT_READ 1 #define SELECT_WRITE 2 #define SELECT_ERROR 4 /* HEADERIZER HFILE: none */ /* HEADERIZER BEGIN: static */ /* HEADERIZER END: static */ /* =item C Returns the maximum of all the c89 standard integer file descriptors held by the Hash PMC =back =head2 Vtable Functions =over 4 =cut */ static INTVAL find_max_fd(PARROT_INTERP, ARGIN(PMC *fd_map)) { PMC * const iter = VTABLE_get_iter(interp, fd_map); const INTVAL n = VTABLE_elements(interp, fd_map); INTVAL maxid = -1; INTVAL j; for (j = 0; j < n; ++j) { const INTVAL id = VTABLE_shift_integer(interp, iter); if (maxid < id) maxid = id; } return maxid; } pmclass Select auto_attrs dynpmc { ATTR PMC *fd_map; /* map a fd to its PMC */ ATTR fd_set rb_array; /* read bit array */ ATTR fd_set wb_array; /* write bit array */ ATTR fd_set eb_array; /* error bit array */ ATTR INTVAL max_fd; /* =item C Initializes the PMC. =cut */ VTABLE void init() { PMC * const fd_map = Parrot_pmc_new(interp, enum_class_Hash); VTABLE_set_integer_native(INTERP, fd_map, Hash_key_type_int); SET_ATTR_fd_map(INTERP, SELF, fd_map); SET_ATTR_max_fd(INTERP, SELF, -1); FD_ZERO(&(PARROT_SELECT(SELF)->rb_array)); FD_ZERO(&(PARROT_SELECT(SELF)->wb_array)); FD_ZERO(&(PARROT_SELECT(SELF)->eb_array)); PObj_custom_mark_SET(SELF); } /* =item C Mark fd_map hash as live. =cut */ VTABLE void mark() :no_wb { PMC *fd_map; GET_ATTR_fd_map(INTERP, SELF, fd_map); Parrot_gc_mark_PMC_alive(interp, fd_map); } /* =back =head2 Methods =over 4 =item C Returns the maximum of all the c89 standard integer file descriptors held by the Select PMC =cut */ METHOD max_fd() :no_wb { INTVAL v; GET_ATTR_max_fd(INTERP, SELF, v); RETURN(INTVAL v); } /* =item C Returns the Hash PMC that holds the mapping from file descriptor to the opaque PMC associated with the file descriptor when it was added to the Select PMC. Used mainly for testing purposes. =cut */ METHOD fd_map() :no_wb { PMC *fd_map; GET_ATTR_fd_map(INTERP, SELF, fd_map); RETURN(PMC *fd_map); } /* =item C Adds filehandle PMC to the Select PMC for monitoring based on the read_write_error_flags read_write_error_flag = READ (0x1) | WRITE (0x2) | ERROR (0x4) An array of data PMCs are returned by the can_read, can_read, has_exception, and select methods when the filehandles meet one of read_write_error_flag conditions. =cut */ METHOD update(PMC *handle, PMC* data, INTVAL rwe) { PMC *fd_map; INTVAL maxid, fdkey; GETATTR_FileHandle_os_handle(INTERP, handle, fdkey); GET_ATTR_fd_map(INTERP, SELF, fd_map); GET_ATTR_max_fd(INTERP, SELF, maxid); VTABLE_set_pmc_keyed_int(interp, fd_map, fdkey, data); if (rwe & SELECT_READ) { FD_SET(fdkey, &PARROT_SELECT(SELF)->rb_array); } if (rwe & SELECT_WRITE) { FD_SET(fdkey, &PARROT_SELECT(SELF)->wb_array); } if (rwe & SELECT_ERROR) { FD_SET(fdkey, &PARROT_SELECT(SELF)->eb_array); } if (maxid < fdkey) maxid = fdkey; SET_ATTR_max_fd(INTERP, SELF, maxid); } /* =item C Removes filehandle from the Select PMC. =cut */ METHOD remove(PMC *handle) { PMC *fd_map; INTVAL fd, maxid; GETATTR_FileHandle_os_handle(INTERP, handle, fd); GET_ATTR_fd_map(INTERP, SELF, fd_map); GET_ATTR_max_fd(INTERP, SELF, maxid); VTABLE_delete_keyed_int(interp, fd_map, fd); FD_CLR(fd, &PARROT_SELECT(SELF)->rb_array); FD_CLR(fd, &PARROT_SELECT(SELF)->wb_array); FD_CLR(fd, &PARROT_SELECT(SELF)->eb_array); if (fd == maxid) { maxid = find_max_fd(interp, fd_map); SET_ATTR_max_fd(INTERP, SELF, maxid); } } /* =item C Returns the associated data for the file descriptors in the Select PMC, which are ready to be read from. Waits for a maximum of timeout seconds for a file descriptor to be ready to read before returning. =cut */ METHOD can_read(FLOATVAL timeout) :no_wb { fd_set rdset; struct timeval timeouts; PMC *results; PMC *fd_map; INTVAL maxid, i; const INTVAL sec = timeout / 1000000; const INTVAL usec = timeout - sec; GET_ATTR_fd_map(INTERP, SELF, fd_map); GET_ATTR_max_fd(INTERP, SELF, maxid); timeouts.tv_sec = sec; timeouts.tv_usec = usec; results = Parrot_pmc_new(interp, enum_class_ResizablePMCArray); memcpy(&rdset, &PARROT_SELECT(SELF)->rb_array, sizeof (fd_set)); select(maxid + 1, &rdset, NULL, NULL, &timeouts); for (i=0; i <= maxid; i++) { if (FD_ISSET(i, &rdset)) { VTABLE_push_pmc(interp, results, VTABLE_get_pmc_keyed_int(interp, fd_map, i)); } } RETURN(PMC *results); } /* =item C Returns the associated data for the file descriptors in the Select PMC, which are ready to be written to. Waits for a maximum of timeout seconds for a file descriptor to be ready to write to before returning. =cut */ METHOD can_write(FLOATVAL timeout) :no_wb { fd_set wbset; struct timeval timeouts; PMC *results, *fd_map; INTVAL maxid, i; const INTVAL sec = timeout / 1000000; const INTVAL usec = timeout - sec; GET_ATTR_fd_map(INTERP, SELF, fd_map); GET_ATTR_max_fd(INTERP, SELF, maxid); timeouts.tv_sec = sec; timeouts.tv_usec = usec; results = Parrot_pmc_new(interp, enum_class_ResizablePMCArray); memcpy(&wbset, &PARROT_SELECT(SELF)->wb_array, sizeof (fd_set)); select(maxid + 1, NULL, &wbset, NULL, &timeouts); for (i=0; i<=maxid; i++) { if (FD_ISSET(i, &wbset)) { VTABLE_push_pmc(interp, results, VTABLE_get_pmc_keyed_int(interp, fd_map, i)); } } RETURN(PMC *results); } /* =item C Returns the associated data for the file descriptors in the Select PMC, which are in an exception state. Waits for a maximum of timeout seconds for a file descriptor to be in an exception state before returning. =cut */ METHOD has_exception(FLOATVAL timeout) :no_wb { fd_set ebset; struct timeval timeouts; PMC *results, *fd_map; INTVAL maxid, i; const INTVAL sec = timeout / 1000000; const INTVAL usec = timeout - sec; GET_ATTR_fd_map(INTERP, SELF, fd_map); GET_ATTR_max_fd(INTERP, SELF, maxid); timeouts.tv_sec = sec; timeouts.tv_usec = usec; results = Parrot_pmc_new(interp, enum_class_ResizablePMCArray); memcpy(&ebset, &PARROT_SELECT(SELF)->eb_array, sizeof (fd_set)); select(maxid + 1, NULL, NULL, &ebset, &timeouts); for (i=0; i<=maxid; i++) { if (FD_ISSET(i, &ebset)) { VTABLE_push_pmc(interp, results, VTABLE_get_pmc_keyed_int(interp, fd_map, i)); } } RETURN(PMC *results); } /* =item C Returns the associated data for the file descriptors in the Select PMC, which are ready to be read, written, or have an exception to be handled. Waits for a maximum of timeout seconds for a file descriptor to be ready to be handled. =back =cut */ METHOD select(FLOATVAL timeout) :no_wb { fd_set rdset, wrset, erset; struct timeval timeouts; PMC *results, *rresults, *wresults, *eresults, *fd_map; INTVAL maxid, i; const INTVAL sec = timeout / 1000000; const INTVAL usec = timeout - sec; GET_ATTR_fd_map(INTERP, SELF, fd_map); GET_ATTR_max_fd(INTERP, SELF, maxid); timeouts.tv_sec = sec; timeouts.tv_usec = usec; results = Parrot_pmc_new(interp, enum_class_ResizablePMCArray); rresults = Parrot_pmc_new(interp, enum_class_ResizablePMCArray); wresults = Parrot_pmc_new(interp, enum_class_ResizablePMCArray); eresults = Parrot_pmc_new(interp, enum_class_ResizablePMCArray); memcpy(&rdset, &PARROT_SELECT(SELF)->rb_array, sizeof (fd_set)); memcpy(&wrset, &PARROT_SELECT(SELF)->wb_array, sizeof (fd_set)); memcpy(&erset, &PARROT_SELECT(SELF)->eb_array, sizeof (fd_set)); select(maxid + 1, &rdset, &wrset, &erset, &timeouts); for (i=0; i<=maxid; i++) { if (FD_ISSET(i, &rdset)) { VTABLE_push_pmc(interp, rresults, VTABLE_get_pmc_keyed_int(interp, fd_map, i)); } if (FD_ISSET(i, &wrset)) { VTABLE_push_pmc(interp, wresults, VTABLE_get_pmc_keyed_int(interp, fd_map, i)); } if (FD_ISSET(i, &erset)) { VTABLE_push_pmc(interp, eresults, VTABLE_get_pmc_keyed_int(interp, fd_map, i)); } } VTABLE_push_pmc(interp, results, rresults); VTABLE_push_pmc(interp, results, wresults); VTABLE_push_pmc(interp, results, eresults); RETURN(PMC *results); } } /* * Local variables: * c-file-style: "parrot" * End: * vim: expandtab shiftwidth=4 cinoptions='\:2=2' : */ readline-02.t000644000765000765 531311533177646 16245 0ustar00bruce000000000000parrot-6.6.0/t/steps/auto#! perl # Copyright (C) 2007, Parrot Foundation. # auto/readline-02.t use strict; use warnings; use Test::More tests => 14; use Carp; use Cwd; use lib qw( lib ); use_ok('config::auto::readline'); use Parrot::Configure::Options qw( process_options ); use Parrot::Configure::Step::Test; use Parrot::Configure::Test qw( test_step_constructor_and_description ); use IO::CaptureOutput qw| capture |; my ($args, $step_list_ref) = process_options( { argv => [ ], mode => q{configure}, } ); my $conf = Parrot::Configure::Step::Test->new; $conf->include_config_results( $args ); my $pkg = q{auto::readline}; $conf->add_steps($pkg); $conf->options->set( %{$args} ); my $step = test_step_constructor_and_description($conf); ########## _evaluate_cc_run() ########## my ($has_readline); $conf->options->set(verbose => undef); $has_readline = $step->_evaluate_cc_run($conf); is($has_readline, 1, "Got expected value for has_readline"); is($step->result(), 'yes', "Expected result was set"); # Prepare for next test $step->set_result(undef); { my $stdout; $conf->options->set(verbose => 1); capture( sub { $has_readline = $step->_evaluate_cc_run($conf); }, \$stdout, ); is($has_readline, 1, "Got expected value for has_readline"); is($step->result(), 'yes', "Expected result was set"); like($stdout, qr/\(yes\)/, "Got expected verbose output"); # Prepare for next test $step->set_result(undef); $conf->options->set(verbose => undef); } ########## _handle_readline() ########## $has_readline = 0; ok(auto::readline::_handle_readline($conf, 'lib', $has_readline), "_handle_readline() returned true value"); is($conf->data->get('readline'), 'define', "Got expected value for 'readline'"); # Prepare for next test $conf->data->set( readline => undef ); $conf->data->set( HAS_READLINE => undef ); $has_readline = 1; ok(auto::readline::_handle_readline($conf, 'lib', $has_readline), "_handle_readline() returned true value"); is($conf->data->get('readline'), 'define', "Got expected value for 'readline'"); # Prepare for next test $conf->data->set( readline => undef ); $conf->data->set( HAS_READLINE => undef ); pass("Completed all tests in $0"); ################### DOCUMENTATION ################### =head1 NAME auto/readline-02.t - test auto::readline =head1 SYNOPSIS % prove t/steps/auto/readline-02.t =head1 DESCRIPTION The files in this directory test functionality used by F. The tests in this file test auto::readline. =head1 AUTHOR James E Keenan =head1 SEE ALSO config::auto::readline, F. =cut # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: merge_review_guidelines.pod000644000765000765 1346711567202623 21517 0ustar00bruce000000000000parrot-6.6.0/docs/project# Copyright (C) 2010, Parrot Foundation. =head1 NAME docs/project/merge_review_guidelines.pod - Guidelines for pending merge reviews =head1 DESCRIPTION To maintain Parrot's standards of quality, we evaluate each branch proposed for merging to trunk in terms of several criteria. Not every criterion applies to every branch; these guidelines are guidelines to which we apply our best judgment. As well, these guidelines are not exhaustive. =head2 Documentation The purpose of the branch governs the amount and type of documentation it requires. Documentation falls into three broad categories: =over 4 =item * User-visible documentation How do users (language developers, people running Parrot directly, people embedding Parrot, people writing PIR, people packaging Parrot) use the feature? What do they need to know to enable it, how does it work, and what configuration options are available? =item * Design documentation How does the feature fit into Parrot as a whole? What design considerations did you make? Are there patterns you followed, or is there literature to read? =item * Developer documentation What functions are available, and to whom are they available? What data structures are present, and what do other developers need to understand about them? What are areas of future work, and what are invariants that underlie the whole system? =back =head2 Testing We know that well-tested features work and we know that well-tested features will continue to work. Under-tested features give us and users much less confidence. A well-tested branch demonstrates several attributes: =over 4 =item * Coverage A full coverage report from an automated testing tool is very valuable, but in lieu of that the tests for the branch's feature should pass the eyeball test. Is everything documented as working tested effectively? If there are gaps in testing, are they clear? Do they have tickets for cage cleaners and other volunteers? =item * Language Testing If your feature affects languages running on Parrot (and what feature doesn't?), the branch needs testing from a couple of major languages to demonstrate that it does not harm those languages. If those languages need changes to accommodate the branch, we must work with the language to schedule those changes or to review them as per our deprecation policy. =item * Platform Testing Does your feature work on the platform combinations we support? Be especially aware of the differences between C and C++ compilers and 32-bit and 64-bit support, as well as any deviations from POSIX. C should pass on all of our target platforms. =back =head2 Deprecation Policy We manage incompatible changes of features and interfaces in multiple ways: =over 4 =item * Replacements for removed features If the branch supplants or supersedes an existing feature, follow the deprecation policy to provide alternatives, shims, compatibility layers, and whatever other mechanisms the deprecation notice promises. =item * New deprecations recorded If the branch necessitates new deprecations, the deprecation list needs sufficient detail to help affected users plan their upgrades. =item * Removals marked clearly If you've removed any deprecated items, have you marked them as such? =item * User-visible exclusions to policy marked and dated clearly If you need any exclusions to the deprecation policy, have you asked for and received them? Have you documented them appropriately? =back =head2 Roadmap Branches may implement features requested on the roadmap in whole or in part. They may also affect the schedule of other roadmap items. Have you documented the implications? =head2 Code Quality Any branch proposed for merging must meet our quality standards in several areas not previously mentioned: =over 4 =item * Coding standards At a minimum, the code must pass all of our active coding standards tests. It must also follow our naming conventions and organizational principles. This means review from other developers. This also means a clean run of C. =item * User-visible features We have no strict guideline for how user-visible features should work apart from a few systems (vtables, embedding and extension API). In general, any public features need review from the user point of view. =item * API review Internal features for developers also need a review, especially of any functions or data structures you expose to other parts of Parrot. Where possible, stick with Parrot conventions, especially for constness and the avoiding of null parameters. =item * Performance characteristics How does your branch affect performance on our selected benchmarks? For hosted languages? Does it have memory leaks? Does it affect memory use or startup time? We have traditionally let these questions go unanswered, but we can be more disciplined here. =back =head2 Integration into Parrot Proper Your branch must also integrate into Parrot as well as possible. In particular: =over 4 =item * Manage dependencies This includes proper dependencies in our configuration and build system for building the code as well as any external configuration or dependencies. Certain parts of Parrot core can depend on external tools such as NQP, while others cannot. =item * Identify configuration options If your feature adds configuration options, they need documentation and review outside of the code itself. If your feature depends on configuration options, it needs explicit testing and documentation. This should be self-evident, but it is worth detailed review. =item * Encapsulation and isolation Does your branch respect the encapsulation of other parts of Parrot? Does it provide its own sensible encapsulation boundaries? If you need to make changes to other parts of Parrot, should we consider them as a separate branch? =back =cut __END__ Local Variables: fill-column:78 End: va_ptr.pm000644000765000765 223612101554066 15537 0ustar00bruce000000000000parrot-6.6.0/config/auto# Copyright (C) 2001-2007, Parrot Foundation. =head1 NAME config/auto/va_ptr.pm - va_list to va_ptr conversion test =head1 DESCRIPTION Tests which kind of PARROT_VA_TO_VAPTR to use. =cut package auto::va_ptr; use strict; use warnings; use base qw(Parrot::Configure::Step); use Parrot::Configure::Utils ':auto'; sub _init { my $self = shift; my %data; $data{description} = q{Test the type of va_ptr}; $data{result} = q{}; return \%data; } sub runstep { my ( $self, $conf ) = @_; my $va_type; $conf->cc_gen('config/auto/va_ptr/test_c.in'); eval { $conf->cc_build('-DVA_TYPE_STACK'); }; if ( $@ || $conf->cc_run_capture() !~ /^ok/ ) { eval { $conf->cc_build('-DVA_TYPE_REGISTER'); }; if ( $@ || $conf->cc_run_capture() !~ /^ok/ ) { die "Unknown va_ptr type"; } $va_type = 'register'; } else { $va_type = 'stack'; } $conf->cc_clean(); $self->set_result($va_type); $conf->data->set( va_ptr_type => $va_type ); return 1; } 1; # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: llvm.pm000644000765000765 2235712101554066 15244 0ustar00bruce000000000000parrot-6.6.0/config/auto# Copyright (C) 2009-2012, Parrot Foundation. =head1 NAME config/auto/llvm - Check whether the Low Level Virtual Machine is present =head1 DESCRIPTION Determines whether the Low Level Virtual Machine (LLVM) is installed and functional on the system. It is okay when it is not present. When a sufficiently up-to-date version of LLVM is present, you will need to specify C<--with-llvm> as an option to C in order to tell Parrot to link to LLVM, I building without LLVM is Parrot's default setting. =cut package auto::llvm; use strict; use warnings; use base qw(Parrot::Configure::Step); use Parrot::Configure::Utils ':auto'; sub _init { my $self = shift; my %data; $data{description} = q{Is minimum version of LLVM installed}; $data{result} = q{}; $data{lli_min_version} = 2.7; return \%data; } sub runstep { my ( $self, $conf ) = @_; my $verbose = $conf->options->get( 'verbose' ); unless ( $conf->options->get( 'with-llvm' ) ) { $self->_handle_result( $conf, 0 ); $self->set_result('skipped'); print "--with-llvm not requested.\n" if $verbose; return 1; } # We will run various probes for LLVM. If the probes are unsuccessful, we # will set_result to 'no', set 'has_llvm' to '', then return from # runstep() with a value of 1. If a given probe does not rule out LLVM, # we will proceed onward. my $llvm_config = $conf->options->get( 'llvm-config' ); my $llvm_bindir; if ( $llvm_config and -e "$llvm_config" ) { $llvm_bindir = capture_output( $llvm_config, "--bindir" ) || ''; chomp $llvm_bindir; } else { for my $ver ('',qw(-3.2 -3.1 -3.0 -2.9 -2.8 -2.7)) { my $bin = 'llvm-config'.$ver; $llvm_bindir = capture_output( $bin, "--bindir" ) || ''; chomp $llvm_bindir; if ( $llvm_bindir ) { $llvm_config = $bin; last; } } } if (! $llvm_bindir ) { print "Unable to find directory for 'llvm-config' executable\n" if $verbose; $self->_handle_result( $conf, 0 ); return 1; } my @output; chomp(@output = `"$llvm_bindir/lli" --version`); my $rv = $self->version_check($conf, \@output, $verbose); return 1 unless $rv; my $version = $rv; # Find flags my ($cflags, $cxxflags, $ldflags, $libs); if ($ldflags = $self->_llvm_config($llvm_config, '--ldflags')) { $conf->data->set( llvm_ldflags => $ldflags ); } if ($libs = $self->_llvm_config($llvm_config, '--libs')) { $conf->data->set( llvm_libs => $libs ); } if ($cflags = $self->_llvm_config($llvm_config, '--cflags')) { $conf->data->set( llvm_cflags => $cflags ); } if ($cxxflags = $self->_llvm_config($llvm_config, '--cxxflags')) { $conf->data->set( llvm_cxxflags => $cxxflags ); } # $self->_handle_result($conf, $version); # return 1; # Having gotten this far, we will take a simple C file, compile it into # an LLVM bitcode file, execute it as bitcode, then compile it to native # assembly using the LLC code generator, then assemble the native assembly # language file into a program and execute it. Cf.: # http://llvm.org/releases/2.5/docs/GettingStarted.html#overview my $stem = q|hello|; my $cfile = qq|$stem.c|; my $fullcfile = qq|config/auto/llvm/$cfile|; my $bcfile = qq|$stem.bc|; my $sfile = qq|$stem.s|; my $nativefile = qq|$stem.native|; unlink $bcfile; for my $cc ($conf->data->get('cc'), "$llvm_bindir/clang", "$llvm_bindir/llvm-gcc", qw(llvm-gcc clang)) { # Note: gcc and g++ with -c just skips over -emit-llvm and produce native code # without -c: ld: warning: cannot find entry symbol 'mit-llvm' my $err; (undef,undef,$err) = capture_output( qq{$cc $cflags -emit-llvm -O3 $fullcfile -c -o $bcfile} ); if (!$err and -e $bcfile and $self->_check_bcfile($bcfile)) { $conf->data->set( llvm_gcc => $cc ); last; } } if (! $conf->data->get( 'llvm_gcc' )) { $rv = $self->_handle_failure_to_compile_into_bitcode( $conf, $verbose, ); if (! $rv) { uconf->cc_clean(); return 1; } } else { my $output; eval { $output = capture_output( "$llvm_bindir/lli", $bcfile ); }; if ( $@ or $output !~ /hello world/ ) { $rv = $self->_handle_failure_to_execute_bitcode( $conf, $verbose ); if (! $rv) { $conf->cc_clean(); return 1; } } else { eval { system(qq{"$llvm_bindir/llc" $bcfile -o $sfile}); }; if ( $@ or (! -e $sfile) ) { $rv = $self->_handle_failure_to_compile_to_assembly( $conf, $verbose, ); if (! $rv) { $conf->cc_clean(); return 1; } } else { eval { my $cc = $conf->data->get('cc'); system(qq{$cc $sfile -o $nativefile}); }; if ( $@ or (! -e $nativefile) ) { $rv = $self->_handle_failure_to_assemble_assembly( $conf, $verbose, ); if (! $rv) { $conf->cc_clean(); return 1; } } else { eval { $output = capture_output(qq{./$nativefile}); }; $self->_handle_native_assembly_output( $conf, $output, $verbose, $version ); } } } } my $count_unlinked = _cleanup_llvm_files( $bcfile, $sfile, $nativefile ); $conf->cc_clean(); return 1; } sub _check_bcfile { my ($self, $bcfile) = @_; open my $fh, '<', $bcfile or return; my $read = read $fh, my $bytes, 2; my $result = ($read == 2 and $bytes eq 'BC') ? 1 : ''; close $fh; return $result; } sub _llvm_config { my ($self, $llvm_config, $arg) = @_; my $result = `"$llvm_config" $arg`; chomp $result; return $result; } sub version_check { my ($self, $conf, $outputref, $verbose) = @_; my $version; if ( $outputref->[1] =~ m/llvm\sversion\s(\d+\.\d+)/is ) { $version = $1; if ($version < $self->{lli_min_version}) { if ($verbose) { my $msg = "LLVM component 'lli' must be at least version "; $msg .= "$self->{lli_min_version}; found version $version\n"; print $msg; } $self->_handle_result( $conf, 0 ); return; } else { if ($verbose) { print "Found 'lli' version $version\n"; } return $version; } } else { print "Unable to extract version for LLVM component 'lli'\n" if $verbose; $self->_handle_result( $conf, 0 ); return 0; } } sub _handle_failure_to_compile_into_bitcode { my ($self, $conf, $verbose ) = @_; print "Unable to compile C file into LLVM bitcode file\n" if $verbose; $self->_handle_result( $conf, 0 ); return 0; } sub _handle_failure_to_execute_bitcode { my ($self, $conf, $verbose ) = @_; print "Unable to run LLVM bitcode file with 'lli'\n" if $verbose; $self->_handle_result( $conf, 0 ); } sub _handle_failure_to_compile_to_assembly { my ($self, $conf, $verbose ) = @_; print "Unable to compile program to native assembly using 'llc'\n" if $verbose; $self->_handle_result( $conf, 0 ); } sub _handle_failure_to_assemble_assembly { my ($self, $conf, $verbose ) = @_; print "Unable to assemble native assembly into program\n" if $verbose; $self->_handle_result( $conf, 0 ); } sub _handle_result { my ($self, $conf, $result) = @_; if ( $result ) { if ($result == 1) { $self->set_result( "yes" ); } else { $self->set_result( "yes, ".$result ); } $conf->data->set( has_llvm => 1 ); } else { $self->set_result('no'); $conf->data->set( has_llvm => '' ); } return 1; } sub _handle_native_assembly_output { my ($self, $conf, $output, $verbose, $rv) = @_; if ( $@ or ( $output !~ /hello world/ ) ) { print "Unable to execute native assembly program successfully\n" if $verbose; $self->_handle_result( $conf, 0 ); } else { $self->_handle_result( $conf, $rv ); } } sub _cleanup_llvm_files { my @llvm_files = @_; my $count_unlinked = 0; foreach my $f ( @llvm_files ) { if ( defined($f) and ( -e $f ) ) { unlink $f; $count_unlinked++; } } return $count_unlinked; }; 1; =head1 AUTHOR James E Keenan, Reini Urban =cut # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: 26-methodops.t000644000765000765 63512101554067 17155 0ustar00bruce000000000000parrot-6.6.0/ext/nqp-rx/t/nqp#!./parrot-nqp # method ops (just method calls for now) plan(3); class Foo { method blarg() { 'ok 1 # method calls work'; } method blargless() { 'ok 3 # argument-less method calls work' } } class Bar { method blarg() { 'not ok 1'; } } sub blarg() { 'ok 2 # regular subs aren\'t confused with methods'; } my $foo := Foo.new(); say($foo.blarg()); say(blarg()); say($foo.blargless); NQPProfile.nqp000644000765000765 64411533177636 22371 0ustar00bruce000000000000parrot-6.6.0/runtime/parrot/library/ProfTest # Copyright (C) 2010, Parrot Foundation. class ProfTest::NQPProfile is ProfTest::PIRProfile; method new($nqp_code, $canonical? = 1) { my $nqp_compiler := pir::compreg__ps("NQP-rx"); my $pir_code := $nqp_compiler.compile($nqp_code, :target('pir')); ProfTest::PIRProfile.new($pir_code, $canonical); } # Local Variables: # mode: perl6 # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=perl packfile.pmc000644000765000765 3351612346145241 15345 0ustar00bruce000000000000parrot-6.6.0/src/pmc/* Copyright (C) 2001-2014, Parrot Foundation. =head1 NAME src/pmc/packfile.pmc - Packfile PMC =head1 DESCRIPTION This class implements a Packfile object, as specified in PDD13. This object is the top level parser and serializer for *.pbc files. =head2 Methods =over 4 =cut */ #include "pmc/pmc_packfiledirectory.h" typedef enum { attr_wordsize, attr_byteorder, attr_fptype, attr_version_major, attr_version_minor, attr_version_patch, attr_bytecode_major, attr_bytecode_minor, attr_uuid_type, attr_NONE = -1 } AttrEnumPackfile; /* HEADERIZER HFILE: none */ /* HEADERIZER BEGIN: static */ /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */ static void copy_packfile_header(PARROT_INTERP, ARGMOD(PMC *self), ARGIN(PackFile *pf)) __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__nonnull__(3) FUNC_MODIFIES(*self); static AttrEnumPackfile getAttrEnum(PARROT_INTERP, ARGIN(const STRING *name)) __attribute__nonnull__(1) __attribute__nonnull__(2); #define ASSERT_ARGS_copy_packfile_header __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(self) \ , PARROT_ASSERT_ARG(pf)) #define ASSERT_ARGS_getAttrEnum __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(name)) /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */ /* HEADERIZER END: static */ /* =item C Copy attributes from PackFile* to Packfile PMC. =cut */ static void copy_packfile_header(PARROT_INTERP, ARGMOD(PMC *self), ARGIN(PackFile *pf)) { ASSERT_ARGS(copy_packfile_header) Parrot_Packfile_attributes * const attrs = PARROT_PACKFILE(self); attrs->wordsize = pf->header->wordsize; attrs->byteorder = pf->header->byteorder; attrs->fptype = pf->header->floattype; attrs->version_major = pf->header->major; attrs->version_minor = pf->header->minor; attrs->version_patch = pf->header->patch; attrs->bytecode_major = pf->header->bc_major; attrs->bytecode_minor = pf->header->bc_minor; attrs->uuid_type = pf->header->uuid_type; attrs->uuid = Parrot_str_new(interp, (char*)pf->header->uuid_data, pf->header->uuid_size); } pmclass Packfile auto_attrs { ATTR INTVAL wordsize; ATTR INTVAL byteorder; ATTR INTVAL fptype; ATTR INTVAL version_major; ATTR INTVAL version_minor; ATTR INTVAL version_patch; ATTR INTVAL bytecode_major; ATTR INTVAL bytecode_minor; ATTR INTVAL uuid_type; ATTR STRING *uuid; ATTR PMC *directory; /* =item C Initialize the structure. (Create a blank PackFile object.) =item C Create a new PackFile from an existing PackFileView. =cut */ VTABLE void init() { Parrot_Packfile_attributes * const attrs = PMC_data_typed(SELF, Parrot_Packfile_attributes*); PackFile *pf; /* copy_packfile_header can trigger GC. Set custom_mark flag early */ PObj_custom_mark_SET(SELF); attrs->uuid = CONST_STRING(INTERP, ""); attrs->directory = Parrot_pmc_new(INTERP, enum_class_PackfileDirectory); /* Create dummy PackFile and copy default attributes to self */ pf = PackFile_new(INTERP, 0); copy_packfile_header(INTERP, SELF, pf); PackFile_destroy(INTERP, pf); } VTABLE void init_pmc(PMC *view) :manual_wb { VTABLE_init(interp, SELF); VTABLE_set_pointer(interp, SELF, VTABLE_get_pointer(interp, view)); } /* =item C Marks the Packfile as alive. =cut */ VTABLE void mark() :no_wb { Parrot_Packfile_attributes * const attrs = PARROT_PACKFILE(SELF); Parrot_gc_mark_STRING_alive(INTERP, attrs->uuid); Parrot_gc_mark_PMC_alive(INTERP, attrs->directory); } /* =item C Return raw serialized PBC file data. =cut Implementation note: all hard stuff done by PackfileDirectory. */ VTABLE STRING *get_string() :no_wb { STRING *str; const Parrot_Packfile_attributes * const attrs = PARROT_PACKFILE(SELF); PackFile * const pf = (PackFile*)VTABLE_get_pointer(INTERP, attrs->directory); /* Copy related attributes to header */ pf->header->major = attrs->version_major; pf->header->minor = attrs->version_minor; pf->header->patch = attrs->version_patch; pf->header->uuid_type = attrs->uuid_type; str = Parrot_pf_serialize(INTERP, pf); PackFile_destroy(INTERP, pf); return str; } /* =item C Parse raw serialized PBC file data into the Packfile data structure. =cut Implementation note: taken from the bottom end of Parrot_pbc_read(). */ VTABLE void set_string_native(STRING *str) { Parrot_Packfile_attributes * const attrs = PARROT_PACKFILE(SELF); PackFile * const pf = Parrot_pf_deserialize(INTERP, str); /* Disable GC during copy data into internal structures. */ Parrot_block_GC_mark(INTERP); /* Copy values from PackFile header to own attributes */ copy_packfile_header(INTERP, SELF, pf); VTABLE_set_pointer(INTERP, attrs->directory, &pf->directory); Parrot_unblock_GC_mark(INTERP); /* XXX memory leak * Destroying the packfile here frees segments that may still have live references * (eg: sub->seg) * A memory leak is better than an invalid memory access */ #if 0 PackFile_destroy(INTERP, pf); #endif } /* =item C Set a raw PackFile* pointer to this Packfile PMC =cut */ VTABLE void set_pointer(void * ptr) { Parrot_Packfile_attributes * const attrs = PARROT_PACKFILE(SELF); PackFile * const pf = (PackFile *)ptr; Parrot_block_GC_mark(INTERP); copy_packfile_header(INTERP, SELF, pf); VTABLE_set_pointer(INTERP, attrs->directory, &pf->directory); Parrot_unblock_GC_mark(INTERP); } /* =item C Fetch an integer keyed value from the packfile object. Valid keys are: =over 4 =item wordsize =item byteorder =item fptype =item version_major =item version_minor =item version_patch =item bytecode_major =item bytecode_minor =item uuid_type =back =cut */ VTABLE INTVAL get_integer_keyed_str(STRING *key) :no_wb { const Parrot_Packfile_attributes * const attrs = PARROT_PACKFILE(SELF); INTVAL result; switch (getAttrEnum(INTERP, key)) { case attr_wordsize: result = attrs->wordsize; break; case attr_byteorder: result = attrs->byteorder; break; case attr_fptype: result = attrs->fptype; break; case attr_version_major: result = attrs->version_major; break; case attr_version_minor: result = attrs->version_minor; break; case attr_version_patch: result = attrs->version_patch; break; case attr_bytecode_major: result = attrs->bytecode_major; break; case attr_bytecode_minor: result = attrs->bytecode_minor; break; case attr_uuid_type: result = attrs->uuid_type; break; default: Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_KEY_NOT_FOUND, "Packfile: No such integer key \"%Ss\"", key); } return result; } /* =item C Fetch a string keyed value from the packfile object. Valid keys are: =over 4 =item uuid =back =cut */ VTABLE STRING *get_string_keyed_str(STRING *key) :no_wb { if (STRING_equal(INTERP, key, CONST_STRING(INTERP, "uuid"))) return PARROT_PACKFILE(SELF)->uuid; Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_KEY_NOT_FOUND, "Packfile: No such string key \"%Ss\"", key); } /* =item C Fetch a keyed integer value from the packfile object. Dispatches to get_integer_keyed_str. =cut */ VTABLE INTVAL get_integer_keyed(PMC *key) :no_wb { STRING * const s = VTABLE_get_string(INTERP, key); return SELF.get_integer_keyed_str(s); } /* =item C Fetch a keyed string value from the packfile object. Dispatches to get_string_keyed_str. =cut */ VTABLE STRING *get_string_keyed(PMC *key) :no_wb { STRING * const s = VTABLE_get_string(INTERP, key); return SELF.get_string_keyed_str(s); } /* =item C Set an integer keyed value to the specified value. Valid keys are: =over 4 =item version_major =item version_minor =item version_patch =item uuid_type =back =cut */ VTABLE void set_integer_keyed_str(STRING *key, INTVAL value) { Parrot_Packfile_attributes * const attrs = PARROT_PACKFILE(SELF); switch (getAttrEnum(INTERP, key)) { case attr_version_major: attrs->version_major = value; break; case attr_version_minor: attrs->version_minor = value; break; case attr_version_patch: attrs->version_patch = value; break; case attr_uuid_type: attrs->uuid_type = value; break; default: Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_KEY_NOT_FOUND, "Packfile: No such integer key \"%Ss\"", key); } } /* =item C Set a keyed integer value in the packfile object. Dispatches to set_integer_keyed_str. =cut */ VTABLE void set_integer_keyed(PMC *key, INTVAL val) :manual_wb { STRING * const s = VTABLE_get_string(INTERP, key); SELF.set_integer_keyed_str(s, val); } /* =item * C (v-table) Used to get data about fields in the header that have a string value. Valid keys are: =over 4 =item uuid =back =cut */ VTABLE void set_string_keyed_str(STRING *key, STRING *value) :manual_wb { if (STRING_equal(INTERP, key, CONST_STRING(INTERP, "uuid"))) { PARROT_PACKFILE(SELF)->uuid = value; PARROT_GC_WRITE_BARRIER(INTERP, SELF); return; } Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_KEY_NOT_FOUND, "Packfile: No such string key \"%Ss\"", key); } /* =item C Set a keyed string value in the packfile object. Dispatches to set_string_keyed_str. =cut */ VTABLE void set_string_keyed(PMC *key, STRING *val) :manual_wb { STRING * const s = VTABLE_get_string(INTERP, key); SELF.set_string_keyed_str(s, val); } /* =item C Return raw serialized PBC file data. Synonym for get_string. =cut */ METHOD pack() :no_wb { STRING * const ret = SELF.get_string(); RETURN(STRING * ret); } /* =item C Parse raw serialized PBC file data into the Packfile data structure. Synonym for set_string. =cut */ METHOD unpack(STRING *str) :manual_wb { SELF.set_string_native(str); } /* =item C Fetch the PackfileDirectory PMC that represents the directory segment at the start of the packfile. =cut */ METHOD get_directory() :no_wb { PMC * const dir = PARROT_PACKFILE(SELF)->directory; RETURN(PMC *dir); } /* =item C Get a PackfileView for the current packfile. PackfileView is a read-only wrapper around a static packfile structure. This method creates a fresh copy of the packfile structure and assigns that copy to the new PackfileView PMC. =cut */ METHOD view() :no_wb { const Parrot_Packfile_attributes * const attrs = PARROT_PACKFILE(SELF); PackFile * const pf = (PackFile*)VTABLE_get_pointer(INTERP, attrs->directory); PMC * const view = Parrot_pf_get_packfile_pmc(INTERP, pf, STRINGNULL); RETURN(PMC * view); } } /* =back =cut =head2 Auxliary functions =over 4 =item C Gets an enumerated value corresponding to the attribute with that name. =cut */ static AttrEnumPackfile getAttrEnum(PARROT_INTERP, ARGIN(const STRING *name)) { ASSERT_ARGS(getAttrEnum) AttrEnumPackfile r; if (STRING_equal(interp, name, CONST_STRING(interp, "wordsize"))) r = attr_wordsize; else if (STRING_equal(interp, name, CONST_STRING(interp, "byteorder"))) r = attr_byteorder; else if (STRING_equal(interp, name, CONST_STRING(interp, "fptype"))) r = attr_fptype; else if (STRING_equal(interp, name, CONST_STRING(interp, "version_major"))) r = attr_version_major; else if (STRING_equal(interp, name, CONST_STRING(interp, "version_minor"))) r = attr_version_minor; else if (STRING_equal(interp, name, CONST_STRING(interp, "version_patch"))) r = attr_version_patch; else if (STRING_equal(interp, name, CONST_STRING(interp, "bytecode_major"))) r = attr_bytecode_major; else if (STRING_equal(interp, name, CONST_STRING(interp, "bytecode_minor"))) r = attr_bytecode_minor; else if (STRING_equal(interp, name, CONST_STRING(interp, "uuid_type"))) r = attr_uuid_type; else r = attr_NONE; return r; } /* =back =cut */ /* * Local variables: * c-file-style: "parrot" * End: * vim: expandtab shiftwidth=4 cinoptions='\:2=2' : */ pdd21_namespaces.pod000644000765000765 4663412101554066 17222 0ustar00bruce000000000000parrot-6.6.0/docs/pdds# Copyright (C) 2005-2010, Parrot Foundation. =head1 PDD 21: Namespaces =head2 Abstract Description and implementation of Parrot namespaces. =head2 Description =over 4 =item - Namespaces should be stored under first-level namespaces corresponding to the HLL language name =item - Namespaces should be hierarchical =item - The C opcode takes a multidimensional hash key or an array of name strings =item - Namespaces follow the semantics of the HLL in which they're defined =item - exports follow the semantics of the library's language =item - Two interfaces: typed and untyped =back =head2 Definitions =head3 "HLL" A High Level Language, such as Perl, Python, or Tcl, in contrast to PIR, which is a low-level language. =head3 "current namespace" The I at runtime is the namespace associated with the currently executing subroutine. PASM assigns each subroutine a namespace when compilation of the subroutine begins. Don't change the associated namespace of a subroutine unless you're prepared for weird consequences. (PASM also has its own separate concept of current namespace which is used to initialize the runtime current namespace as well as determine where to store compiled symbols.) =head2 Implementation =head3 Namespace Indexing Syntax Namespaces are denoted in Parrot as simple strings, multidimensional hash keys, or arrays of name strings. A namespace may appear in Parrot source code as the string C<"a"> or the key C<["a"]>. A nested namespace "b" inside the namespace "a" will appear as the key C<["a"; "b"]>. There is no limit to namespace nesting. =head3 Naming Conventions Parrot's target languages have a wide variety of namespace models. By implementing an API and standard conventions, it should be possible to allow interoperability while still allowing each one to choose the best internal representation. =over 4 =item True Root Namespace The true root namespace is hidden from common usage, but it is available via the C opcode. For example: $P0 = get_root_namespace This root namespace stringifies to the empty string. =item HLL Root Namespaces Each HLL must store public items in a namespace named with the lowercased name of the HLL. This is the HLL root namespace. For instance, Tcl's user-created namespaces should live in the C namespace. This eliminates any accidental collisions between languages. An HLL root namespace must be stored at the first level in Parrot's namespace hierarchy. These top-level namespaces should also be specified in a standard unicode encoding. The reasons for these restrictions is to allow compilers to remain completely ignorant of each other. Parrot internals are stored in the default HLL root namespace C. =item HLL Implementation Namespaces Each HLL must store implementation internals (private items) in an HLL root namespace named with an underscore and the lowercased name of the HLL. For instance, Tcl's implementation internals should live in the C<_tcl> namespace. =item HLL User-Created Namespaces Each HLL must store all user-created namespaces under the HLL root namespace. It is suggested that HLLs use hierarchical namespaces to practical extent. A single flat namespace can be made to work, but it complicates symbol exportation. =back =head3 Namespace PMC API Most languages leave their symbols plain, which makes lookups quite straightforward. Others use sigils or other mangling techniques, complicating the problem of interoperability. Parrot namespaces assist with interoperability by providing two interface subsets: the I and the I. =head4 Untyped Interface Each HLL may, when working with its own namespace objects, use the I, which allows direct naming in the native style of the namespace's HLL. This interface consists of the standard Parrot hash interface, with all its keys, values, lookups, deletions, etc. Just treat the namespace like a hash. (It probably is one, really, deep down.) The untyped interface also has one method: =over 4 =item C =begin PIR_FRAGMENT $P1 = $P2.'get_name'() =end PIR_FRAGMENT Gets the name of the namespace $P2 as an array of strings. For example, if $P2 is a Perl 5 namespace "Some::Module", within the Perl 5 HLL, then get_name() on $P2 returns an array of "perl5", "Some", "Module". It returns the literal namespace names as the HLL stored them, without filtering for name mangling. NOTE: Due to aliasing, this value may be wrong -- i.e. it may disagree with the namespace name with which you found the namespace in the first place. =back =head4 Typed Interface When a given namespace's HLL is either different from the current HLL or unknown, an HLL should generally use only the language-agnostic namespace interface. This interface isolates HLLs from each others' naming quirks. It consists of C, C, and C methods, for values of "foo" including "sub" (something executable), "namespace" (something in which to find more names), and "var" (anything). NOTE: The job of the typed interface is to bridge I differences, and I naming differences. Therefore: 1) It does not enforce, nor even notice, the interface requirements of "sub" or "namespace": e.g. execution of C does I automatically guarantee that $P0 is an invokable subroutine; and 2) it does not prevent overwriting one type with another. =over 4 =item C =begin PIR_FRAGMENT $P1.'add_namespace'($S2, $P3) =end PIR_FRAGMENT Store $P3 as a namespace under the namespace $P1, with the name of $S2. =item C =begin PIR_FRAGMENT $P1.'add_sub'($S2, $P3) =end PIR_FRAGMENT Store $P3 as a subroutine with the name of $S2 in the namespace $P1. =item C =begin PIR_FRAGMENT $P1.'add_var'($S2, $P3) =end PIR_FRAGMENT Store $P3 as a variable with the name of $S2 in the namespace $P1. IMPLEMENTATION NOTE: Perl namespace implementations may choose to implement add_var() by checking which parts of the variable interface are implemented by $P0 (scalar, array, and/or hash) so it can decide on an appropriate sigil. =item C, C, C =begin PIR_FRAGMENT $P1.'del_namespace'($S2) $P1.'del_sub'($S2) $P1.'del_var'($S2) =end PIR_FRAGMENT Delete the sub, namespace, or variable named $S2 from the namespace $P1. =item C, C, C =begin PIR_FRAGMENT $P1 = $P2.'find_namespace'($S3) $P1 = $P2.'find_sub'($S3) $P1 = $P2.'find_var'($S3) =end PIR_FRAGMENT Find the sub, namespace, or variable named $S3 in the namespace $P2. IMPLEMENTATION NOTE: Perl namespace implementations should implement find_var() to check all variable sigils, but the order is not to be counted on by users. If you're planning to let Python code see your module, you should avoid exporting both C and C. (Well, you might want to consider not exporting variables at all, but that's a style issue.) =item C =begin PIR_FRAGMENT $P1.'export_to'($P2, $P3) =end PIR_FRAGMENT Export items from the namespace $P1 into the namespace $P2. The items to export are named in $P3, which may be an array of strings, a hash, or null. If $P3 is an array of strings, interpretation of items in an array follows the conventions of the source (exporting) namespace. If $P3 is a hash, the keys correspond to the names in the source namespace, and the values correspond to the names in the destination namespace. If a hash value is null or an empty string, the name in the hash key is used. A null $P3 requests the 'default' set of items. Any other type passed into $P3 throws an exception. The base Parrot namespace export_to() function interprets item names as literals -- no wildcards or other special meaning. There is no default list of items to export, so $P3 of null and $P3 of an empty array have the same behavior. NOTE: Exportation may entail non-obvious, odd, or even mischievous behavior. For example, Perl's pragmata are implemented as exports, and they don't actually export anything. IMPLEMENTATION EXAMPLES: Suppose a Perl program were to import some Tcl module with an import pattern of "c*" -- something that might be expressed in Perl 6 as C. This operation would import all the commands that start with 'c' from the given Tcl namespace into the current Perl namespace. This is so because, regardless of whether 'c*' is a Perl 6 style export pattern, it I a valid Tcl export pattern. {XXX - The ':' for HLL is just proposed. This example will need to be updated later.} IMPLEMENTATION NOTE: Most namespace C implementations will restrict themselves to using the typed interface on the target namespace. However, they may also decide to check the type of the target namespace and, if it turns out to be of a compatible type, to use same-language shortcuts. DESIGN TODO: Figure out a good convention for a default export list in the base namespace PMC. Maybe a standard method "expand_export_list()"? =back =head3 Compiler PMC API =head4 Methods =over 4 =item C =begin PIR_FRAGMENT $P1 = $P2.'parse_name'($S3) =end PIR_FRAGMENT Parse the name in $S3 using the rules specific to the compiler $P2, and return an array of individual name elements. For example, a Java compiler would turn 'C' to C<['a','b','c']>, while a Perl compiler would turn 'C' into the same result. Meanwhile, due to Perl's sigil rules, 'C<$a::b::c>' would become C<['a','b','$c']>. =item C =begin PIR_FRAGMENT $P1 = $P2.'get_namespace'($P3) =end PIR_FRAGMENT Ask the compiler $P2 to find its namespace which is named by the elements of the array in $P3. If $P3 is a null PMC or an empty array, C retrieves the base namespace for the HLL. It returns a namespace PMC on success and a null PMC on failure. This method allows other HLLs to know one name (the HLL) and then work with that HLL's modules without having to know the name it chose for its namespace tree. (If you really want to know the name, the get_name() method should work on the returned namespace PMC.) Note that this method is basically a convenience and/or performance hack, as it does the equivalent of C followed by zero or more calls to .get_namespace(). However, any compiler is free to cheat if it doesn't get caught, e.g. to use the untyped namespace interface if the language doesn't mangle namespace names. =item C =begin PIR_FRAGMENT $P1.'load_library'($P2, $P3) =end PIR_FRAGMENT Ask this compiler to load a library/module named by the elements of the array in $P2, with optional control information in $P3. For example, Perl 5's module named "Some::Module" should be loaded using (in pseudo Perl 6): C. The meaning of $P3 is compiler-specific. The only universal legal value is Null, which requests a "normal" load. The meaning of "normal" varies, but the ideal would be to perform only the minimal actions required. On failure, an exception is thrown. =back =head3 Subroutine PMC API Some information must be available about subroutines to implement the correct behavior about namespaces. =head4 Methods =over 4 =item C =begin PIR_FRAGMENT $P1 = $P2.'get_namespace'() =end PIR_FRAGMENT Retrieve the namespace $P1 where the subroutine $P2 was defined. (As opposed to the namespace(s) that it may have been exported to.) =back =head3 Namespace Opcodes The namespace opcodes all have 3 variants: one that operates from the currently selected namespace (i.e. the namespace of the currently executing subroutine), one that operates from the HLL root namespace (identified by "hll" in the opcode name), and one that operates from the true root namespace (identified by "root" in the name). =over 4 =item C =begin PIR_FRAGMENT_INVALID set_namespace ['key'], $P1 set_hll_namespace ['key'], $P1 set_root_namespace ['key'], $P1 =end PIR_FRAGMENT_INVALID Add the namespace PMC $P1 under the name denoted by a multidimensional hash key. =begin PIR_FRAGMENT_INVALID set_namespace $P1, $P2 set_hll_namespace $P1, $P2 set_root_namespace $P1, $P2 =end PIR_FRAGMENT_INVALID Add the namespace PMC $P2 under the name denoted by an array of name strings $P1. =item C =begin PIR_FRAGMENT $P1 = get_namespace $P1 = get_hll_namespace $P1 = get_root_namespace =end PIR_FRAGMENT Retrieve the current namespace, the HLL root namespace, or the true root namespace and store it in $P1. =begin PIR_FRAGMENT_INVALID $P1 = get_namespace [key] $P1 = get_hll_namespace [key] $P1 = get_root_namespace [key] =end PIR_FRAGMENT_INVALID Retrieve the namespace denoted by a multidimensional hash key and store it in C<$P1>. =begin PIR_FRAGMENT $P1 = get_namespace $P2 $P1 = get_hll_namespace $P2 $P1 = get_root_namespace $P2 =end PIR_FRAGMENT Retrieve the namespace denoted by the array of names $P2 and store it in C<$P1>. Thus, to get the "Foo::Bar" namespace from the top-level of the HLL if the name was known at compile time, you could retrieve the namespace with a key: =begin PIR_FRAGMENT $P0 = get_hll_namespace ["Foo"; "Bar"] =end PIR_FRAGMENT If the name was not known at compile time, you would retrieve the namespace with an array instead: =begin PIR_FRAGMENT $P1 = split "::", "Foo::Bar" $P0 = get_hll_namespace $P1 =end PIR_FRAGMENT =item C =begin PIR_FRAGMENT_INVALID $P1 = make_namespace [key] $P1 = make_hll_namespace [key] $P1 = make_root_namespace [key] =end PIR_FRAGMENT_INVALID Create and retrieve the namespace denoted by a multidimensional hash key and store it in C<$P1>. If the namespace already exists, only retrieve it. =begin PIR_FRAGMENT_INVALID $P1 = make_namespace $P2 $P1 = make_hll_namespace $P2 $P1 = make_root_namespace $P2 =end PIR_FRAGMENT_INVALID Create and retrieve the namespace denoted by the array of names $P2 and store it in C<$P1>. If the namespace already exists, only retrieve it. =item C =begin PIR_FRAGMENT $P1 = get_global $S2 $P1 = get_hll_global $S2 $P1 = get_root_global $S2 =end PIR_FRAGMENT Retrieve the symbol named $S2 in the current namespace, HLL root namespace, or true root namespace. =begin PIR_FRAGMENT .local pmc key $P1 = get_global [key], $S2 $P1 = get_hll_global [key], $S2 $P1 = get_root_global [key], $S2 =end PIR_FRAGMENT Retrieve the symbol named $S2 by a multidimensional hash key relative to the current namespace, HLL root namespace, or true root namespace. =begin PIR_FRAGMENT $P1 = get_global $P2, $S3 $P1 = get_hll_global $P2, $S3 $P1 = get_root_global $P2, $S3 =end PIR_FRAGMENT Retrieve the symbol named $S3 by the array of names $P2 relative to the current namespace, HLL root namespace, or true root namespace. =item C =begin PIR_FRAGMENT set_global $S1, $P2 set_hll_global $S1, $P2 set_root_global $S1, $P2 =end PIR_FRAGMENT Store $P2 as the symbol named $S1 in the current namespace, HLL root namespace, or true root namespace. =begin PIR_FRAGMENT .local pmc key set_global [key], $S1, $P2 set_hll_global [key], $S1, $P2 set_root_global [key], $S1, $P2 =end PIR_FRAGMENT Store $P2 as the symbol named $S1 by a multidimensional hash key, relative to the current namespace, HLL root namespace, or true root namespace. If the given namespace does not exist it is created. =begin PIR_FRAGMENT set_global $P1, $S2, $P3 set_hll_global $P1, $S2, $P3 set_root_global $P1, $S2, $P3 =end PIR_FRAGMENT Store $P3 as the symbol named $S2 by the array of names $P1, relative to the current namespace, HLL root namespace, or true root namespace. If the given namespace does not exist it is created. =back =head3 HLL Namespace Mapping In order to make this work, Parrot must somehow figure out what type of namespace PMC to create. =head4 Default Namespace The default namespace PMC will implement Parrot's current behavior. =head4 Compile-time Creation This Perl: #!/usr/bin/perl package Foo; $x = 5; should map roughly to this PIR: =begin PIR_INVALID .HLL "Perl5" .loadlib "perl5_group" .namespace [ "Foo" ] .sub main :main $P0 = new 'PerlInt' $P0 = 5 set_global "$x", $P0 .end =end PIR_INVALID In this case, the C
sub would be tied to Perl 5 by the C<.HLL> directive, so a Perl 5 namespace would be created. =head4 Run-time Creation Consider the following Perl 5 program: #!/usr/bin/perl $a = 'x'; ${"Foo::$a"} = 5; The C namespace is created at run-time (without any optimizations). In these cases, Parrot should create the namespace based on the HLL of the PIR subroutine that calls the store function. =begin PIR_INVALID .HLL "Perl5" .loadlib "perl5_group" .sub main :main # $a = 'x'; $P0 = new 'PerlString' $P0 = "x" set_global "$a", $P0 # ${"Foo::$a"} = 5; $P1 = new 'PerlString' $P1 = "Foo::" $P1 .= $P0 $S0 = $P1 $P2 = split "::", $S0 $S0 = pop $P2 $S0 = "$" . $S0 $P3 = new 'PerlInt' $P3 = 5 set_global $P2, $S0, $P3 .end =end PIR_INVALID In this case, C should see that it was called from "main", which is in a Perl 5 namespace, so it will create the "Foo" namespace as a Perl 5 namespace. =head2 Language Notes =head3 Perl 6 =head4 Sigils Perl 6 may wish to be able to access the namespace as a hash with sigils. That is certainly possible, even with subroutines and methods. It's not important that a HLL use the typed namespace API, it is only important that it provides it for others to use. So Perl 6 may implement C and C VTABLE slots that allow the namespace PMC to be used as a hash. The C method would, in this case, append a "&" sigil to the front of the sub/method name and search in the internal hash. =head3 Python =head4 Importing from Python Since functions and variables overlap in Python's namespaces, when exporting to another HLL's namespace, the Python namespace PMC's C method should use introspection to determine whether C should be added using C or C. C<$I0 = does $P0, "Sub"> may be enough to decide correctly. =head4 Subroutines and Namespaces Since Python's subroutines and namespaces are just variables (the namespace collides there), the Python PMC's C method may return subroutines as variables. =head3 Examples =head4 Aliasing Perl: #!/usr/bin/perl6 sub foo {...} %Foo::{"&bar"} = &foo; PIR: =begin PIR .sub main :main $P0 = get_global "&foo" $P1 = get_namespace ["Foo"] # A smart perl6 compiler would emit this, # because it knows that Foo is a perl6 namespace: $P1["&bar"] = $P0 # But a naive perl6 compiler would emit this: $P1.'add_sub'("bar", $P0) .end .sub foo #... .end =end PIR =head4 Cross-language Exportation Perl 5: #!/usr/bin/perl use tcl:Some::Module 'w*'; # XXX - ':' after HLL may change in Perl 6 write("this is a tcl command"); PIR (without error checking): =begin PIR .sub main :main .local pmc tcl .local pmc ns tcl = compreg "tcl" ns = new 'Array' ns = 2 ns[0] = "Some" ns[1] = "Module" null $P0 tcl.'load_library'(ns, $P0) $P0 = tcl.'get_namespace'(ns) $P1 = get_namespace $P0.'export_to'($P1, 'w*') "write"("this is a tcl command") .end =end PIR =head2 References None. =cut __END__ Local Variables: fill-column:78 End: vim: expandtab shiftwidth=4: class.t000644000765000765 4704511715102036 14030 0ustar00bruce000000000000parrot-6.6.0/t/pmc#!./parrot # Copyright (C) 2007-2010, Parrot Foundation. =head1 NAME t/pmc/class.t - test the Class PMC =head1 SYNOPSIS % prove t/pmc/class.t =head1 DESCRIPTION Tests the Class PMC. =cut .sub 'main' :main .include 'test_more.pir' plan(89) 'new op'() 'class flag'() 'name'() 'new method'() 'attributes'() 'add_attribute'() 'set_attr/get_attr'() 'add_method'() 'remove_method'() 'find_method'() 'vtable_override'() 'parents'() 'roles'() 'inspect'() 'clone'() 'clone_pmc'() 'new with init hash'() 'new with init hash exceptions'() 'isa'() 'does'() 'more does'() 'anon_inherit'() 'method_cache_tt1497'() .end # L .sub 'new op' .local pmc class .local int isa_class class = new ['Class'] ok(1, "$P0 = new ['Class']") isa_ok(class, 'Class') .end # L .sub 'class flag' .local pmc class, class_flags_pmc .local int class_flags, class_flag_set .const int POBJ_IS_CLASS_FLAG = 536870912 # 1 << 29 class = new ['Class'] class_flags_pmc = inspect class, 'flags' class_flags = class_flags_pmc class_flag_set = class_flags & POBJ_IS_CLASS_FLAG ok(class_flag_set, 'Class PMC has "I am a class" flag set') .end # L .sub 'name' .local pmc class, result class = new ['Class'] result = class.'name'() is(result, '', 'name() with no args returns class name, which is empty at first') class.'name'('Alex') result = class.'name'() is(result, 'Alex', 'name() with args sets class name') $I0 = 1 # hack for testing exceptions push_eh t_too_many_args class.'name'('Alice', 'Bob') $I0 = 0 pop_eh t_too_many_args: ok($I0, 'name() with too many args fails') result = class.'get_namespace'() is(result, 'Alex', 'name() with args sets namespace too') .end # L .sub 'new method' .local pmc class, result, attrib .local int isa_object class = new ['Class'] result = class.'new'() isa_ok(result, 'Object') $I0 = 1 push_eh t_non_attribute_key result = class.'new'('abc' => '123' ) $I0 = 0 pop_eh t_non_attribute_key: ok($I0, 'new() with non-attribute key fails') $I0 = 1 class = new ['Class'] class.'add_attribute'('foo') class.'add_attribute'('bar') result = class.'new'('foo' => 1, 'bar' => 2) attrib = getattribute result, 'foo' if attrib != 1 goto nok_3 attrib = getattribute result, 'bar' if attrib != 2 goto nok_3 goto ok_3 nok_3: $I0 = 0 ok_3: ok($I0, 'new() with key/value pairs sets attributes') .end # L .sub 'attributes' .local pmc class, attribs .local int test_val class = new ['Class'] attribs = class.'attributes'() test_val = isa attribs, 'Hash' ok(test_val, 'attributes() returns a Hash') test_val = attribs is(test_val, 0, 'New Class PMC has no attributes') $I0 = 1 push_eh ok_ro_accessor attribs = class.'attributes'( 'foo' ) $I0 = 0 pop_eh ok_ro_accessor: ok($I0, 'attributes() is read-only accessor') .end # L .sub 'add_attribute' .local pmc class, attribs, object .local int test_val class = new ['Class'] $I0 = 1 push_eh t_no_args class.'add_attribute'() $I0 = 0 pop_eh t_no_args: ok($I0, 'add_attribute() with no args fails') class.'add_attribute'( 'foo' ) attribs = class.'attributes'() test_val = attribs is(test_val, 1, 'add_attribute() with valid single arg adds an attribute') class.'add_attribute'( 'bar', 'Integer' ) attribs = class.'attributes'() test_val = attribs is(test_val, 2, 'add_attribute() with valid args adds an attribute') $I0 = 1 push_eh t_existing_attribute class.'add_attribute'( 'foo', 'String' ) $I0 = 0 pop_eh t_existing_attribute: ok($I0, 'add_attribute() with existing attribute name fails') push_eh t_after_instantiation $I0 = 1 object = class.'new'() class.'add_attribute'( 'bar', 'Integer' ) $I0 = 0 pop_eh t_after_instantiation: ok($I0, 'add_attribute() after instantiation fails') .end # L .sub 'set_attr/get_attr' .local pmc class, class_instance, attrib_in, attrib_out class = new ['Class'] class.'name'("Test") class.'add_attribute'("foo") ok(1, 'created a class with one attribute') class_instance = class.'new'() ok(1, 'instantiated the class') attrib_in = new ['Integer'] attrib_in = 42 setattribute class_instance, "foo", attrib_in ok(1, 'set an attribute') attrib_out = getattribute class_instance, "foo" is(attrib_out, 42, 'got an attribute') .end # L .sub 'add_method' .local pmc class, attribs, test_attr_val, obj_inst .local int test_val class = new ['Class'] $I0 = 1 push_eh t_no_args class.'add_method'() $I0 = 0 pop_eh t_no_args: ok($I0, 'add_method() with no args fails') $I0 = 1 push_eh t_one_arg class.'add_method'( 'foo' ) $I0 = 0 pop_eh t_one_arg: ok($I0, 'add_method() with valid single arg fails') # note this test depends on 'add_attribute' and 'attributes' class.'add_attribute'( 'foo', 'String' ) attribs = class.'attributes'() attribs['foo'] = 'bar' .const 'Sub' meth_to_add = 'foo' .const 'Sub' another_meth_to_add = 'foobar' class.'add_method'( 'foo', meth_to_add ) attribs = class.'methods'() test_val = attribs is(test_val, 1, 'add_method() one method added') test_val = exists attribs['foo'] ok(test_val, 'add_method() method has correct name') test_val = defined attribs['foo'] ok(test_val, 'add_method() method is defined') test_attr_val = attribs['foo'] isa_ok(test_attr_val, 'Sub', 'add_method() with valid args adds a method') .local string test_string_val $I0 = 1 push_eh t_class_meth test_string_val = class.'foo'() $I0 = 0 pop_eh is(test_string_val, 'bar', 'add_method() invoking method added to class works') t_class_meth: todo( 0, 'add_method() invoking method added to class works', "classes don't seem to call methods yet: GH #396") obj_inst = class.'new'() test_string_val = obj_inst.'foo'() is(test_string_val, 'bar', 'add_method() invoking method added to class through instance works') $I0 = 1 push_eh t_existing_method # Adding the same method with the same name is OK class.'add_method'( 'foo', meth_to_add ) class.'add_method'( 'foo', meth_to_add ) # Adding another method with the same name should raise exception class.'add_method'( 'foo', another_meth_to_add ) $I0 = 0 pop_eh t_existing_method: ok($I0, 'add_method() with existing method name fails') .end .sub 'foo' :method .return ('bar') .end .sub 'foobar' :method .return ('bar') .end # L .sub 'remove_method' .local pmc class, attribs .local int test_val class = new ['Class'] $I0 = 1 push_eh t_no_args class.'remove_method'() $I0 = 0 pop_eh t_no_args: ok($I0, 'remove_method() with no args fails') .const 'Sub' meth_to_add = 'foo' class.'add_method'( 'foo', meth_to_add ) class.'remove_method'( 'foo' ) attribs = class.'methods'() test_val = exists attribs['foo'] is(test_val, 0, 'remove_method() removed the method') $I0 = 1 push_eh t_remove_inexistent_method class.'remove_method'( 'bar' ) $I0 = 0 pop_eh t_remove_inexistent_method: ok($I0, 'remove_method() with inexistent method fails') .end # L .sub 'find_method' .local pmc class .local int test_val class = new ['Class'] .const 'Sub' meth_to_add = 'foo' class.'add_method'( 'foo1', meth_to_add ) class.'add_method'( 'foo2', meth_to_add ) class.'add_method'( 'foo3', meth_to_add ) $P0 = class.'find_method'( 'foo2' ) is($P0, 'foo', 'find_method() found the method') $P0 = class.'find_method'( 'zzzz' ) $I0 = isnull $P0 ok($I0, 'find_method() returned null for inexistent method') .end # L .sub 'vtable_override' .local pmc class, obj class = new ['Class'] $P0 = get_global 'new_add_role' class.'add_vtable_override'('add_role', $P0) ok(1, 'add_vtable_override() overrode a vtable') obj = class.'new'() $P0 = class.'inspect'('vtable_overrides') $S0 = $P0['add_role'] is($S0, 'new_add_role', 'add_vtable_override() confirmed by inspect()') $P0 = new ['Role'] addrole obj, $P0 $I0 = 1 push_eh t_invalid_name class.'add_vtable_override'('zzz', $P0) $I0 = 0 pop_eh t_invalid_name: ok($I0, 'add_vtable_override() with invalid name fails') .end .sub 'new_add_role' ok(1, 'overridden vtable method called') .end # L .sub 'parents' .local pmc class, parents .local int isa_parent class = new ['Class'] parents = class.'parents'() ## XXX is this really what's expected? isa_ok(parents, 'ResizablePMCArray', 'parents() returns a ResizablePMCArray') .end ## NOTE test that accessor is read-only ## NOTE figure out what parents the base Class has by default (if any) ## A: It has no parents by default. (Note, the parents stored in the 'parents' # attribute aren't the parents of Class, they're the parents of the class object # that is an instance of Class.) ## TODO add_parent # L .sub 'roles' .local pmc class, array .local int is_array class = new ['Class'] array = class.'roles'() ## XXX is this really what's expected? isa_ok(array, 'ResizablePMCArray', 'roles() returns a ResizablePMCArray') .end ## NOTE test that accessor is read-only ## NOTE figure out what roles the base Class has by default (if any) # A: None. See comment for parents(). ## TODO add_role # L .sub 'inspect' .local pmc class, result .local int test_val class = new ['Class'] class.'name'('foo') class.'add_attribute'('a') result = class.'inspect'() ok(1, 'inspect() with no args called returns successfully') test_val = elements result is(test_val, 7, 'inspect() returns correctly sized value') result = class.'inspect'('name') is(result, 'foo', 'inspect() "name" param returns expected value') result = class.'inspect'('attributes') test_val = elements result is(test_val, 1, 'inspect() "attributes" param returns correctly sized value') result = class.'inspect'('id') $I0 = class is(result, $I0, 'inspect() "id" returns expected default value') result = class.'inspect'('attrib_index') $I0 = isnull result ok($I0, 'inspect() "attrib_index" returns expected default value') result = class.'inspect'('vtable_overrides') $S0 = typeof result is($S0, 'Hash', 'inspect() "vtable_overrides" param returns expected value') $I0 = 1 push_eh t_inexistent_attribute result = class.'inspect'('zzzzzz') $I0 = 0 pop_eh t_inexistent_attribute: ok($I0, 'inspect() with inexistent attribute fails') .end # TODO more tests .sub 'clone' .local pmc attrs, class, class_instance, test_pmc .local string test_name .local int test_val attrs = new ['Hash'] attrs['name'] = 'Monkey' class = new ['Class'], attrs class.'add_attribute'('banana') class_instance = class.'new'() ok(1, 'clone() created class Monkey and instantiated it') class_instance = clone class ok(1, 'cloned class Monkey') test_name = class_instance.'inspect'('name') is(test_name, '', 'clone() name is empty') test_pmc = class_instance.'inspect'('namespace') $I0 = isnull test_pmc ok($I0, 'clone() namespace is null') test_pmc = class_instance.'inspect'('attributes') test_val = elements test_pmc is(test_val, 1, 'clone() attribute survived cloning') class_instance.'add_attribute'('jungle') ok(1, 'clone() can modify cloned class') .end .sub 'clone_pmc' .local pmc class, class_instance, monkey, mandrill, test_ns .local string test_string_val .local int num_elems class = new ['Hash'] class['name'] = 'Monkey2' class_instance = new ['Class'], class class_instance.'add_attribute'('banana') monkey = class_instance.'new'() ok(1, 'clone_pmc() created class Monkey and instantiated it') class = new ['Hash'] class['name'] = 'Mandrill' mandrill = clone class_instance, class ok(1, 'clone_pmc() cloned class Monkey with Hash argument') test_string_val = mandrill.'inspect'('name') is(test_string_val, 'Mandrill', 'clone_pmc() name is new one set in the Hash') test_ns = mandrill.'inspect'('namespace') test_string_val = test_ns is(test_string_val, 'Mandrill', 'clone_pmc() namespace is Mandrill too') test_ns = mandrill.'inspect'('attributes') num_elems = elements test_ns is(num_elems, 1, 'clone_pmc() attribute survived cloning') mandrill.'add_attribute'('jungle') ok(1, 'clone_pmc() can modify cloned class') .end .sub 'new with init hash' .local pmc class, init_hash, attrs, methods, meth_to_add, class_instance, role, roles .local pmc attr_val, result init_hash = new ['Hash'] # We'll have some attributes... attrs = new ['ResizablePMCArray'] attrs[0] = 'x' attrs[1] = 'y' init_hash['attributes'] = attrs # And a method. methods = new ['Hash'] meth_to_add = get_global 'add' methods['add'] = meth_to_add init_hash['methods'] = methods # And a role $P0 = new ['Hash'] $P0['name'] = 'Flob' $P0['namespace'] = 'Bob' role = new ['Role'], $P0 roles = new ['ResizablePMCArray'] roles[0] = role init_hash['roles'] = roles class = new ['Class'], init_hash ok(1, 'new() created new class with attributes and methods supplied') # Instantiate and try setting each attribute. class_instance = class.'new'() attr_val = new ['Integer'] attr_val = 37 setattribute class_instance, 'x', attr_val ok(1, 'new() set first attribute') attr_val = new ['Integer'] attr_val = 5 setattribute class_instance, 'y', attr_val ok(1, 'new() set second attribute') # Call method. result = class_instance.'add'() is(result, 42, 'new() added method returns expected value') .end .sub 'new with init hash exceptions' .local pmc class, init_hash, null_pmc null_pmc = new ['Null'] init_hash = new ['Hash'] init_hash['name'] = "" $I0 = 1 push_eh t_invalid_name class = new ['Class'], init_hash $I0 = 0 pop_eh t_invalid_name: ok($I0, 'new() with invalid name raises exception') .end .sub add :method :nsentry('add') $P0 = getattribute self, "x" $P1 = getattribute self, "y" $P2 = new ['Integer'] $P2 = $P0 + $P1 .return($P2) .end # L .sub 'isa' .local pmc class class = new ['Class'] test_isa( class, 'Class', 1 ) test_isa( class, 'Hash', 0 ) test_isa( class, 'Foo', 0 ) .end .sub 'test_isa' .param pmc obj .param string class .param int expected .local int isa_class .local string message $I0 = 0 message = 'isa() ' isa_class = obj.'isa'( class ) if isa_class goto is_class message .= "The object isn't a " message .= class goto test is_class: $I0 = 1 message .= "The object is a " message .= class test: is($I0, expected, message) .return() .end # L .sub 'does' .local pmc class .local pmc attrs attrs = new ['Hash'] .local pmc red, green, blue attrs['name'] = 'Red' red = new ['Role'], attrs attrs['name'] = 'Green' green = new ['Role'], attrs attrs['name'] = 'Blue' blue = new ['Role'], attrs green.'add_role'( blue ) .local pmc color color = new ['Class'] test_does( color, 'Red', 0 ) color.'add_role'( red ) test_does( color, 'Red', 1 ) color.'add_role'( green ) test_does( color, 'Green', 1 ) test_does( color, 'Blue', 1 ) test_does( color, 'Class', 1 ) .end .sub 'test_does' .param pmc obj .param string role_name .param int expected .local int does_a_role .local string message $I0 = 0 message = 'does() ' does_a_role = obj.'does'( role_name ) if does_a_role goto does_role message .= "The object doesn't " message .= role_name goto test does_role: $I0 = 1 message .= "The object does " message .= role_name test: is($I0, expected, message) .return() .end # L .sub 'more does' .local pmc attrs attrs = new ['Hash'] .local pmc red, green, blue attrs['name'] = 'Red' red = new ['Role'], attrs attrs['name'] = 'Green' green = new ['Role'], attrs attrs['name'] = 'Blue' blue = new ['Role'], attrs green.'add_role'( blue ) .local pmc color color = new ['Class'] $S0 = 'Red' $I0 = color.'does'($S0) is($I0, 0, 'does not Red') color.'add_role'( red ) $I0 = color.'does'($S0) is($I0, 1, 'does Red') .end .sub 'anon_inherit' $P0 = new 'Class' $P1 = new 'Class' $P2 = new 'Class' addparent $P2, $P0 addparent $P2, $P1 ok(1, 'inheritance of two different anonymous classes works') push_eh t_after_instantiation $I0 = 1 $P3 = $P2.'new'() addparent $P2, $P1 $I0 = 0 pop_eh t_after_instantiation: ok($I0, 'addparent VTABLE after instantiation fails') .end .sub 'method_cache_tt1497' $P0 = new ["tt1497_Object"] $P1 = find_method $P0, "foo" $I0 = isnull $P1 is($I0, 0, "can find foo. Sanity") $I0 = $P0.$P1() is($I0, 1, "found the correct foo") $P9 = box 2 setattribute $P0, "state", $P9 $P1 = find_method $P0, "foo" $I0 = isnull $P1 is($I0, 0, "can find foo. Sanity") $I0 = $P0.$P1() is($I0, 1, "we've cached the old foo") $P2 = get_class "tt1497_Object" $P2.'clear_method_cache'() $P1 = find_method $P0, "foo" $I0 = isnull $P1 is($I0, 0, "can find foo. Sanity") $I0 = $P0.$P1() is($I0, 2, "cleared cache, can find the next foo") $P3 = $P2.'get_method_cache'() $P1 = $P3["foo"] $I0 = isnull $P1 is($I0, 0, "can find foo in method cache") $I0 = $P0.$P1() is($I0, 2, "cleared cache, can find the next foo") $P9 = box 1 setattribute $P0, "state", $P9 $P3 = $P2.'get_method_cache'() $P1 = $P3["foo"] $I0 = isnull $P1 is($I0, 0, "can find foo in method cache") $I0 = $P0.$P1() is($I0, 2, "cleared cache, can find the next foo") .end .namespace ["tt1497_Object"] .sub '__tt1497_init' :anon :load :init $P0 = newclass "tt1497_Object" addattribute $P0, "state" .end .sub 'foo1' .return(1) .end .sub 'foo2' .return(2) .end .sub 'find_method' :vtable .param string name $P0 = getattribute self, "state" unless null $P0 goto have_state $P0 = box 1 setattribute self, "state", $P0 have_state: if $P0 == 1 goto getfoo1 if $P0 == 2 goto getfoo2 $P0 = null goto return_meth getfoo1: .const 'Sub' foo1 = "foo1" $P0 = foo1 goto return_meth getfoo2: .const 'Sub' foo2 = "foo2" $P0 = foo2 return_meth: .return($P0) .end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: number.pasm000644000765000765 405611631440404 16332 0ustar00bruce000000000000parrot-6.6.0/t/pmc/testlib# Copyright (C) 2009-2010, Parrot Foundation. # This file is used from Packfile PMCs tests set N0, 1.0 set N1, 4.0 set N2, 16.0 set N3, 64.0 set N4, 256.0 set N5, 1024.0 set N6, 4096.0 set N7, 16384.0 set N8, 65536.0 set N9, 262144.0 set N10, 1048576.0 set N11, 4194304.0 set N12, 16777216.0 set N13, 67108864.0 set N14, 268435456.0 set N15, 1073741824.0 set N16, 4294967296.0 set N17, 17179869184.0 set N18, 68719476736.0 set N19, 274877906944.0 set N20, 1099511627776.0 set N21, 4398046511104.0 set N22, 17592186044416.0 set N23, 70368744177664.0 set N24, 281474976710656.0 set N25, 1.12589990684262e+15 print N0 print "\n" print N1 print "\n" print N2 print "\n" print N3 print "\n" print N4 print "\n" print N5 print "\n" print N6 print "\n" print N7 print "\n" print N8 print "\n" print N9 print "\n" print N10 print "\n" print N11 print "\n" print N12 print "\n" print N13 print "\n" print N14 print "\n" print N15 print "\n" print N16 print "\n" print N17 print "\n" print N18 print "\n" print N19 print "\n" print N20 print "\n" print N21 print "\n" print N22 print "\n" print N23 print "\n" print N24 print "\n" print N25 print "\n" returncc # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: main.c000644000765000765 2407412307662657 15067 0ustar00bruce000000000000parrot-6.6.0/src/runcore/* Copyright (C) 2001-2010, Parrot Foundation. =head1 NAME src/runcore/main.c - main functions for Parrot runcores =head1 DESCRIPTION The runcore API handles running the operations. =head2 Functions =over 4 =cut */ #include "parrot/parrot.h" #include "parrot/runcore_api.h" #include "parrot/runcore_profiling.h" #include "parrot/runcore_subprof.h" #include "parrot/oplib/core_ops.h" #include "parrot/oplib/ops.h" #include "main.str" #include "parrot/dynext.h" #include "pmc/pmc_parrotlibrary.h" #include "pmc/pmc_callcontext.h" /* HEADERIZER HFILE: include/parrot/runcore_api.h */ /* XXX Needs to get done at the same time as the other interpreter files */ /* HEADERIZER BEGIN: static */ /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */ PARROT_WARN_UNUSED_RESULT PARROT_CANNOT_RETURN_NULL static oplib_init_f get_dynamic_op_lib_init(PARROT_INTERP, ARGIN(const PMC *lib)) __attribute__nonnull__(2); #define ASSERT_ARGS_get_dynamic_op_lib_init __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(lib)) /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */ /* HEADERIZER END: static */ /* =item C Initializes the runcores. =cut */ void Parrot_runcore_init(PARROT_INTERP) { ASSERT_ARGS(Parrot_runcore_init) STRING * const default_core = CONST_STRING(interp, "fast"); interp->cores = NULL; interp->num_cores = 0; Parrot_runcore_slow_init(interp); Parrot_runcore_fast_init(interp); Parrot_runcore_subprof_init(interp); /* Parrot_runcore_exec_init(interp); */ Parrot_runcore_gc_debug_init(interp); Parrot_runcore_debugger_init(interp); Parrot_runcore_profiling_init(interp); /* set the default runcore */ Parrot_runcore_switch(interp, default_core); } /* =item C Registers a new runcore with Parrot. Returns 1 on success, 0 on failure. =cut */ PARROT_EXPORT INTVAL Parrot_runcore_register(PARROT_INTERP, ARGIN(Parrot_runcore_t *coredata)) { ASSERT_ARGS(Parrot_runcore_register) size_t i = interp->num_cores++; interp->cores = mem_gc_realloc_n_typed_zeroed(interp, interp->cores, interp->num_cores, i, Parrot_runcore_t *); interp->cores[i] = coredata; return 1; } /* =item C Switches to a named runcore. Throws an exception on an unknown runcore. =cut */ PARROT_EXPORT void Parrot_runcore_switch(PARROT_INTERP, ARGIN(STRING *name)) { ASSERT_ARGS(Parrot_runcore_switch) size_t num_cores = interp->num_cores; size_t i; if (interp->run_core && STRING_equal(interp, name, interp->run_core->name)) return; for (i = 0; i < num_cores; ++i) { if (STRING_equal(interp, name, interp->cores[i]->name)) { interp->run_core = interp->cores[i]; return; } } Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_UNIMPLEMENTED, "Invalid runcore %Ss requested\n", name); } /* =item C Returns an dynamic oplib's opcode's library C init function. C will be a C PMC. =cut */ PARROT_WARN_UNUSED_RESULT PARROT_CANNOT_RETURN_NULL static oplib_init_f get_dynamic_op_lib_init(SHIM_INTERP, ARGIN(const PMC *lib)) { ASSERT_ARGS(get_dynamic_op_lib_init) return (oplib_init_f)D2FPTR( ((Parrot_ParrotLibrary_attributes *)PMC_data(lib))->oplib_init); } /* =item C Prepares to run the interpreter's run core. =cut */ void prepare_for_run(PARROT_INTERP) { ASSERT_ARGS(prepare_for_run) const runcore_prepare_fn_type prepare_run = interp->run_core->prepare_run; if (prepare_run) (*prepare_run)(interp, interp->run_core); } /* =item C Run Parrot operations of loaded code segment until an end opcode is reached. Run core is selected depending on the C. When a C opcode is encountered, a different core may be selected and evaluation of opcode continues. =cut */ void runops_int(PARROT_INTERP, size_t offset) { ASSERT_ARGS(runops_int) interp->resume_offset = offset; interp->resume_flag |= RESUME_RESTART; while (interp->resume_flag & RESUME_RESTART) { opcode_t * const pc = (opcode_t *) interp->code->base.data + interp->resume_offset; const runcore_runops_fn_type core = interp->run_core->runops; interp->resume_offset = 0; interp->resume_flag &= ~(RESUME_RESTART | RESUME_INITIAL); (*core)(interp, interp->run_core, pc); /* if we have fallen out with resume and we were running CGOTO, set * the stacktop again to a sane value, so that restarting the runloop * is ok. */ if (interp->resume_flag & RESUME_RESTART) { if ((int)interp->resume_offset < 0) Parrot_ex_throw_from_c_args(interp, NULL, 1, "branch_cs: illegal resume offset"); } } } /* =item C Shuts down the runcores and deallocates any dynops memory. =cut */ void Parrot_runcore_destroy(PARROT_INTERP) { ASSERT_ARGS(Parrot_runcore_destroy) size_t num_cores = interp->num_cores; size_t i; for (i = 0; i < num_cores; ++i) { Parrot_runcore_t * const core = interp->cores[i]; const runcore_destroy_fn_type destroy = core->destroy; if (destroy) (*destroy)(interp, core); mem_gc_free(interp, core); } if (interp->cores) mem_gc_free(interp, interp->cores); interp->cores = NULL; interp->run_core = NULL; if (interp->all_op_libs) mem_gc_free(interp, interp->all_op_libs); interp->all_op_libs = NULL; } /* =back =head2 Dynamic Loading Functions =over 4 =item C Register a dynamic oplib. =cut */ PARROT_EXPORT void dynop_register(PARROT_INTERP, ARGIN(PMC *lib_pmc)) { ASSERT_ARGS(dynop_register) op_lib_t *lib; oplib_init_f init_func; if (!interp->all_op_libs) interp->all_op_libs = mem_gc_allocate_n_zeroed_typed(interp, interp->n_libs + 1, op_lib_t*); else interp->all_op_libs = mem_gc_realloc_n_typed_zeroed(interp, interp->all_op_libs, interp->n_libs + 1, interp->n_libs, op_lib_t *); init_func = get_dynamic_op_lib_init(interp, lib_pmc); lib = init_func(interp, 1); interp->all_op_libs[interp->n_libs++] = lib; /* if we are registering an op_lib variant, called from below the base * names of this lib and the previous one are the same */ if (interp->n_libs >= 2 && (STREQ(interp->all_op_libs[interp->n_libs-2]->name, lib->name))) return; parrot_hash_oplib(interp, lib); } /* =item C Add the ops in C to the global name => op_info hash. =cut */ void parrot_hash_oplib(PARROT_INTERP, ARGIN(op_lib_t *lib)) { ASSERT_ARGS(parrot_hash_oplib) int i; DECL_CONST_CAST; for (i = 0; i < lib->op_count; i++) { op_info_t *op = &lib->op_info_table[i]; Parrot_hash_put(interp, interp->op_hash, PARROT_const_cast(char *, op->full_name), (void *)op); if (!Parrot_hash_exists(interp, interp->op_hash, PARROT_const_cast(char *, op->name))) Parrot_hash_put(interp, interp->op_hash, PARROT_const_cast(char *, op->name), (void *)op); } } /* =item C Restore old function table. XXX This is only implemented for the function core at present. =cut */ PARROT_EXPORT void Parrot_runcore_disable_event_checking(PARROT_INTERP) { ASSERT_ARGS(Parrot_runcore_disable_event_checking) PackFile_ByteCode *cs = interp->code; /* restore func table */ PARROT_ASSERT(cs->save_func_table); cs->op_func_table = cs->save_func_table; cs->save_func_table = NULL; } /* =item C Replace func table with one that does event checking for all opcodes. NOTE: C is called async by the event handler thread. All action done from here has to be async safe. XXX This is only implemented for the function core at present. =cut */ PARROT_EXPORT void Parrot_runcore_enable_event_checking(PARROT_INTERP) { ASSERT_ARGS(Parrot_runcore_enable_event_checking) PackFile_ByteCode *cs = interp->code; /* only save if we're not already event checking */ if (cs->save_func_table == NULL) cs->save_func_table = cs->op_func_table; /* ensure event checking table is big enough */ if (interp->evc_func_table_size < cs->op_count) { size_t i; op_lib_t *core_lib = get_core_op_lib_init(interp, interp->run_core)(interp, 1); interp->evc_func_table = interp->evc_func_table ? mem_gc_realloc_n_typed_zeroed(interp, interp->evc_func_table, cs->op_count, interp->evc_func_table_size, op_func_t) : mem_gc_allocate_n_zeroed_typed(interp, cs->op_count, op_func_t); for (i = interp->evc_func_table_size; i < cs->op_count; i++) interp->evc_func_table[i] = core_lib->op_func_table[PARROT_OP_check_events__]; interp->evc_func_table_size = cs->op_count; } /* put evc table in place */ cs->op_func_table = interp->evc_func_table; } /* =back =head1 SEE ALSO F, F, F, F, F. =cut */ /* * Local variables: * c-file-style: "parrot" * End: * vim: expandtab shiftwidth=4 cinoptions='\:2=2' : */ Writer.pir000644000765000765 215412101554066 16754 0ustar00bruce000000000000parrot-6.6.0/examples/streams =head1 DESCRIPTION This example shows the usage of C. =head1 FUNCTIONS =over 4 =item _main Creates a C and writes to it. =cut .sub _main :main .local pmc stream load_bytecode 'Stream/Writer.pbc' stream = new ['Stream'; 'Writer'] # set the stream's source sub .const 'Sub' temp = "_reader" assign stream, temp print "main start\n" stream."write"( "hello" ) stream."write"( "world!" ) stream."write"( "parrot" ) stream."write"( "is cool" ) stream."close"() print "main done\n" end .end =item _reader This sub is used as the target for the stream. It just reads from the stream. =cut .sub _reader :method print "reader start\n" self."dump"() print "reader done\n" .end =back =head1 AUTHOR Jens Rieks Eparrot at jensbeimsurfen dot deE is the author and maintainer. Please send patches and suggestions to the Perl 6 Internals mailing list. =head1 COPYRIGHT Copyright (C) 2004-2009, Parrot Foundation. =cut # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: integer_8_be.pbc000644000765000765 244012356767112 17075 0ustar00bruce000000000000parrot-6.6.0/t/native_pbcPBC  BYTECODE_-&FIXUP_-.CONSTANT_-6^PIC_idx_-~XBYTECODE_-_DB ~d( 0@(null)`^pPBC   #parrot 3I!parrot"Gs-p0PBC  (null)(null)!parrot(null)s(null) regressions.t000644000765000765 1213712307662657 20244 0ustar00bruce000000000000parrot-6.6.0/t/compilers/imcc/syn#!perl # Copyright (C) 2008-2014, Parrot Foundation. use strict; use warnings; use lib qw( . lib ../lib ../../lib ); use Test::More; use Parrot::Test tests => 21; $ENV{TEST_PROG_ARGS} ||= ''; pir_error_output_like( <<'CODE', <<'OUT', 'invalid get_results syntax'); .sub main :main get_results '(0)' .end CODE /syntax error/ OUT SKIP: { skip "invalid -O2 test GH #1049", 1 if $ENV{TEST_PROG_ARGS} =~ / -O2/; pir_output_is( <<'CODE', <<'OUT', 'cannot constant fold div by 0'); .sub fold_by_zero :main push_eh ok1 $I1 = 1/0 pop_eh print "not " ok1: say "ok 1 - caught div_i_ic_ic exception" push_eh ok2 $N1 = 1.0/0.0 pop_eh print "not " ok2: say "ok 2 - caught div_n_nc_nc exception" .end CODE ok 1 - caught div_i_ic_ic exception ok 2 - caught div_n_nc_nc exception OUT } pir_output_is( <<'CODE', <<'OUT', 'fold symbolic constants (GH #473)'); .sub main :main .const int SECONDS_PER_MINUTE = 60 $I0 = 30 * SECONDS_PER_MINUTE say $I0 .const num DAYS_PER_YEAR = 365.24e0 $N0 = DAYS_PER_YEAR * 2.96460137564761618e-03 'printf'("%f\n", $N0) .const string HI = "Hello " $S0 = concat HI, "World!" say $S0 .end .sub 'printf' .param string fmt .param pmc data :slurpy $S0 = sprintf fmt, data print $S0 .end CODE 1800 1.082791 Hello World! OUT pir_output_is( <<'CODE', <<'OUT', 'comments before .param(TT #1035)'); .sub main :main comments(1,2) .end .sub comments # Testing .param pmc a .param pmc b say 'hello' .end CODE hello OUT pir_output_is( <<'CODE', <<'OUT', 'comments between .param(TT #1035)'); .sub main :main comments(1,2) .end .sub comments .param pmc a # Testing .param pmc b say 'hello' .end CODE hello OUT pir_output_is( <<'CODE', <<'OUT', 'whitespace before .param(TT #1035)'); .sub main :main comments(1,2) .end .sub comments .param pmc a .param pmc b say 'hello' .end CODE hello OUT pir_output_is( <<'CODE', <<'OUT', 'whitespace between .param(TT #1035)'); .sub main :main comments(1,2) .end .sub comments .param pmc a .param pmc b say 'hello' .end CODE hello OUT pir_error_output_like( <<'CODE', <<'OUT', 'off by one error message (TT #1016)', ); .sub foo :main $P0 = new 'Hash' $P1 = $P0['x'] unless $P1 goto no print "yes\n" no: .end CODE /(?s:Null PMC access in get_bool.*current instr.*:(4|-1)\))/ OUT pir_error_output_like( <<'CODE', <<'OUT', 'bare method names not allowed'); .sub foo :main $P0 = new 'String' $P0 = 'HI' $P0.lower() say $P0 .end CODE /Bareword method name 'lower' not allowed/ OUT pir_error_output_like( <<'CODE', <<'OUT', ':: not allowed in identifiers'); .sub foo :main .local string a::b a::b = 'HI' say a::b .end CODE /syntax error/ OUT pir_output_is( <<'CODE', <<'OUT', 'unicode lexical identifiers (TT #575)'); .sub main :main $P0 = box 'hello world' .lex utf8:"$\u03b2\u03bf\u03bf", $P0 $P1 = find_lex utf8:"$\u03b2\u03bf\u03bf" say $P1 .end CODE hello world OUT pir_output_is( <<'CODE', <<'OUT', 'unicode named identifiers (TT #654)'); .sub 'main' :main 'foo'(1 :named(utf8:"\x{e4}")) .end # Perl 6: sub foo(:$ä) { say "ok $ä"; } .sub 'foo' .param int x :named(utf8:"\x{e4}") print "ok " say x .end CODE ok 1 OUT my $register = "9" x 4096; pir_output_is( <<"CODE", <<'OUT', 'long register numbers in PIR (TT #1025)'); .sub main :main \$P$register = new 'Integer' \$P$register = 3 say \$P$register .end CODE 3 OUT pir_exit_code_is( <<'CODE', 1, 'die in immediate, TT #629'); .sub 'foo' :immediate die 'no' .end CODE pir_error_output_like( <<'CODE', <<'OUT', 'No segfault from syntax error'); .sub 'main' ($S0) = 'blah'(:pir_only=>1) .end CODE /syntax error.+unexpected/ OUT pir_output_like( <<'CODE', <<'OUT', 'Segfault, TT #1027'); .sub main :main push_eh handler test() ## NB: This makes sure the sub call PC is sufficiently ## different from the exception handler PC. print "foo\n" print "bar\n" .return () handler: .local pmc exception .local string message .get_results (exception, message) print "Error: " print message .end .sub test ## Throw an exception. $P0 = new 'Exception' $P0 = 'oops' throw $P0 .end CODE /.*/ OUT # We shouldn't crash (and valgrind shoudn't report invalid reads) pir_output_is( <<'CODE', <<'OUT', 'exit is last op in sub (TT #1009)'); .sub main :main exit 0 .end CODE OUT SKIP: { skip("No limit on key size", 1); pir_error_output_like( <<'CODE', <<'OUT', 'over long keys should not segfault (TT #641)'); .sub main :main $P0 = new [0;0;0;0;0;0;0;0;0;0;0;0] # more than MAX_KEY_LEN. .end CODE /Key too long/ OUT } # This test probably belongs in subflags.t # The test inspired by TT #744, even though it presents differently. { my @types = qw/string num pmc/; foreach my $invalid_type (@types) { pir_error_output_like( <<"CODE", <<"OUT", 'opt_flag must be an int' ); .sub bar .param pmc foo :optional .param $invalid_type joe :opt_flag say joe .end .sub main :main bar() .end CODE /:opt_flag parameter must be of type 'int', not '$invalid_type'/ OUT } } # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: Curses.pir000644000765000765 5247311533177636 20153 0ustar00bruce000000000000parrot-6.6.0/runtime/parrot/library# Copyright (C) 2004-2009, Parrot Foundation. .macro export_dl_func(lib, name, sig) .local pmc edlftmp dlfunc edlftmp, .lib, .name, .sig set_global .name, edlftmp .endm .namespace ['Curses'] .sub __ncurses_init :load loadlib $P1, 'libform' if $P1 goto has_lib loadlib $P1, 'cygform-8' has_lib: dlfunc $P2, $P1, 'new_field', 'piiiiii' set_global 'new_field', $P2 dlfunc $P2, $P1, 'dup_field', 'ppii' set_global 'dup_field', $P2 dlfunc $P2, $P1, 'link_field', 'ppii' set_global 'link_field', $P2 dlfunc $P2, $P1, 'free_field', 'ip' set_global 'free_field', $P2 dlfunc $P2, $P1, 'field_info', 'ip333333' set_global 'field_info', $P2 dlfunc $P2, $P1, 'dynamic_field_info', 'ip333' set_global 'dynamic_field_info', $P2 dlfunc $P2, $P1, 'set_max_field', 'ipi' set_global 'set_max_field', $P2 dlfunc $P2, $P1, 'move_field', 'ipii' set_global 'move_field', $P2 dlfunc $P2, $P1, 'set_new_page', 'ipl' set_global 'set_new_page', $P2 dlfunc $P2, $P1, 'set_field_just', 'ipi' set_global 'set_field_just', $P2 dlfunc $P2, $P1, 'field_just', 'ip' set_global 'field_just', $P2 dlfunc $P2, $P1, 'set_field_fore', 'ipl' set_global 'set_field_fore', $P2 dlfunc $P2, $P1, 'set_field_back', 'ipl' set_global 'set_field_back', $P2 dlfunc $P2, $P1, 'set_field_pad', 'ipi' set_global 'set_field_pad', $P2 dlfunc $P2, $P1, 'field_pad', 'ip' set_global 'field_pad', $P2 dlfunc $P2, $P1, 'set_field_buffer', 'ipit' set_global 'set_field_buffer', $P2 dlfunc $P2, $P1, 'set_field_status', 'ipl' set_global 'set_field_status', $P2 dlfunc $P2, $P1, 'set_field_userptr', 'ipp' set_global 'set_field_userptr', $P2 dlfunc $P2, $P1, 'set_field_opts', 'ipi' set_global 'set_field_opts', $P2 dlfunc $P2, $P1, 'field_opts_on', 'ipi' set_global 'field_opts_on', $P2 dlfunc $P2, $P1, 'field_opts_off', 'ipi' set_global 'field_opts_off', $P2 dlfunc $P2, $P1, 'field_fore', 'lp' set_global 'field_fore', $P2 dlfunc $P2, $P1, 'field_back', 'ip' set_global 'field_back', $P2 dlfunc $P2, $P1, 'new_page', 'lp' set_global 'new_page', $P2 dlfunc $P2, $P1, 'field_status', 'lp' set_global 'field_status', $P2 dlfunc $P2, $P1, 'field_arg', 'pp' set_global 'field_arg', $P2 dlfunc $P2, $P1, 'field_userptr', 'pp' set_global 'field_userptr', $P2 dlfunc $P2, $P1, 'field_type', 'pp' set_global 'field_type', $P2 dlfunc $P2, $P1, 'field_buffer', 'tpi' set_global 'field_buffer', $P2 dlfunc $P2, $P1, 'field_opts', 'lp' set_global 'field_opts', $P2 dlfunc $P2, $P1, 'new_form', 'pb' set_global 'new_form', $P2 dlfunc $P2, $P1, 'current_field', 'pp' set_global 'current_field', $P2 dlfunc $P2, $P1, 'form_win', 'pp' set_global 'form_win', $P2 dlfunc $P2, $P1, 'form_sub', 'pp' set_global 'form_sub', $P2 dlfunc $P2, $P1, 'free_form', 'ip' set_global 'free_form', $P2 dlfunc $P2, $P1, 'set_form_fields', 'ipb' set_global 'set_form_fields', $P2 dlfunc $P2, $P1, 'field_count', 'ip' set_global 'field_count', $P2 dlfunc $P2, $P1, 'set_form_win', 'ipp' set_global 'set_form_win', $P2 dlfunc $P2, $P1, 'set_form_sub', 'ipp' set_global 'set_form_sub', $P2 dlfunc $P2, $P1, 'set_current_field', 'ipp' set_global 'set_current_field', $P2 dlfunc $P2, $P1, 'field_index', 'ip' set_global 'field_index', $P2 dlfunc $P2, $P1, 'set_form_page', 'ipi' set_global 'set_form_page', $P2 dlfunc $P2, $P1, 'form_page', 'ip' set_global 'form_page', $P2 dlfunc $P2, $P1, 'scale_form', 'ip33' set_global 'scale_form', $P2 dlfunc $P2, $P1, 'post_form', 'ip' set_global 'post_form', $P2 dlfunc $P2, $P1, 'unpost_form', 'ip' set_global 'unpost_form', $P2 dlfunc $P2, $P1, 'pos_form_cursor', 'ip' set_global 'pos_form_cursor', $P2 dlfunc $P2, $P1, 'form_driver', 'ipi' set_global 'form_driver', $P2 dlfunc $P2, $P1, 'set_form_userptr', 'ipp' set_global 'set_form_userptr', $P2 dlfunc $P2, $P1, 'set_form_opts', 'ipi' set_global 'set_form_opts', $P2 dlfunc $P2, $P1, 'form_opts_on', 'ipi' set_global 'form_opts_on', $P2 dlfunc $P2, $P1, 'form_opts_off', 'ipi' set_global 'form_opts_off', $P2 dlfunc $P2, $P1, 'form_request_by_name', 'it' set_global 'form_request_by_name', $P2 dlfunc $P2, $P1, 'form_request_name', 'ti' set_global 'form_request_name', $P2 dlfunc $P2, $P1, 'form_userptr', 'pp' set_global 'form_userptr', $P2 dlfunc $P2, $P1, 'form_opts', 'ip' set_global 'form_opts', $P2 dlfunc $P2, $P1, 'data_ahead', 'lp' set_global 'data_ahead', $P2 dlfunc $P2, $P1, 'data_behind', 'lp' set_global 'data_behind', $P2 loadlib $P1, 'libpanel' if $P1 goto has_panel_lib loadlib $P1, 'cygpanel-8' if $P1 goto has_panel_lib goto no_panel_lib has_panel_lib: .export_dl_func($P1, 'new_panel', 'pp') .export_dl_func($P1, 'bottom_panel', 'ip') .export_dl_func($P1, 'top_panel', 'ip') .export_dl_func($P1, 'show_panel', 'ip') .export_dl_func($P1, 'update_panels', 'v') .export_dl_func($P1, 'hide_panel', 'ip') .export_dl_func($P1, 'panel_window', 'pp') .export_dl_func($P1, 'replace_panel', 'ipp') .export_dl_func($P1, 'move_panel', 'ipii') .export_dl_func($P1, 'panel_hidden', 'ip') .export_dl_func($P1, 'panel_above', 'pp') .export_dl_func($P1, 'panel_below', 'pp') .export_dl_func($P1, 'set_panel_userptr', 'ipp') .export_dl_func($P1, 'panel_userptr', 'vp') .export_dl_func($P1, 'del_panel', 'ip') no_panel_lib: loadlib $P1, 'libncurses' if $P1 goto has_lib1 loadlib $P1, 'cygncurses-8' has_lib1: dlfunc $P2, $P1, 'keybound', 'tii' set_global 'keybound', $P2 dlfunc $P2, $P1, 'curses_version', 't' set_global 'curses_version', $P2 dlfunc $P2, $P1, 'assume_default_colors', 'iii' set_global 'assume_default_colors', $P2 dlfunc $P2, $P1, 'define_key', 'iti' set_global 'define_key', $P2 dlfunc $P2, $P1, 'keyok', 'iii' set_global 'keyok', $P2 dlfunc $P2, $P1, 'resizeterm', 'iii' set_global 'resizeterm', $P2 dlfunc $P2, $P1, 'use_default_colors', 'i' set_global 'use_default_colors', $P2 dlfunc $P2, $P1, 'use_extended_names', 'ii' set_global 'use_extended_names', $P2 dlfunc $P2, $P1, 'wresize', 'ipii' set_global 'wresize', $P2 dlfunc $P2, $P1, 'addch', 'il' set_global 'addch', $P2 dlfunc $P2, $P1, 'addchnstr', 'i4i' set_global 'addchnstr', $P2 dlfunc $P2, $P1, 'addchstr', 'i4' set_global 'addchstr', $P2 dlfunc $P2, $P1, 'addnstr', 'iti' set_global 'addnstr', $P2 dlfunc $P2, $P1, 'addstr', 'it' set_global 'addstr', $P2 dlfunc $P2, $P1, 'attroff', 'il' set_global 'attroff', $P2 dlfunc $P2, $P1, 'attron', 'il' set_global 'attron', $P2 dlfunc $P2, $P1, 'attrset', 'il' set_global 'attrset', $P2 dlfunc $P2, $P1, 'attr_get', 'i42p' set_global 'attr_get', $P2 dlfunc $P2, $P1, 'attr_off', 'ilp' set_global 'attr_off', $P2 dlfunc $P2, $P1, 'attr_on', 'ilp' set_global 'attr_on', $P2 dlfunc $P2, $P1, 'attr_set', 'ilsp' set_global 'attr_set', $P2 dlfunc $P2, $P1, 'baudrate', 'i' set_global 'baudrate', $P2 dlfunc $P2, $P1, 'beep', 'i' set_global 'beep', $P2 dlfunc $P2, $P1, 'bkgd', 'il' set_global 'bkgd', $P2 dlfunc $P2, $P1, 'bkgdset', 'vl' set_global 'bkgdset', $P2 dlfunc $P2, $P1, 'border', 'villllllll' set_global 'border', $P2 dlfunc $P2, $P1, 'box', 'ipll' set_global 'box', $P2 dlfunc $P2, $P1, 'can_change_color', 'l' set_global 'can_change_color', $P2 dlfunc $P2, $P1, 'cbreak', 'i' set_global 'cbreak', $P2 dlfunc $P2, $P1, 'chgat', 'iilsp' set_global 'chgat', $P2 dlfunc $P2, $P1, 'clear', 'i' set_global 'clear', $P2 dlfunc $P2, $P1, 'clearok', 'ipl' set_global 'clearok', $P2 dlfunc $P2, $P1, 'clrtobot', 'i' set_global 'clrtobot', $P2 dlfunc $P2, $P1, 'clrtoeol', 'i' set_global 'clrtoeol', $P2 dlfunc $P2, $P1, 'color_content', 'is222' set_global 'color_content', $P2 dlfunc $P2, $P1, 'color_set', 'isp' set_global 'color_set', $P2 dlfunc $P2, $P1, 'COLOR_PAIR', 'ii' set_global 'COLOR_PAIR', $P2 dlfunc $P2, $P1, 'copywin', 'ippiiiiiiii' set_global 'copywin', $P2 dlfunc $P2, $P1, 'curs_set', 'ii' set_global 'curs_set', $P2 dlfunc $P2, $P1, 'def_prog_mode', 'i' set_global 'def_prog_mode', $P2 dlfunc $P2, $P1, 'def_shell_mode', 'i' set_global 'def_shell_mode', $P2 dlfunc $P2, $P1, 'delay_output', 'ii' set_global 'delay_output', $P2 dlfunc $P2, $P1, 'delch', 'i' set_global 'delch', $P2 dlfunc $P2, $P1, 'delscreen', 'vp' set_global 'delscreen', $P2 dlfunc $P2, $P1, 'delwin', 'ip' set_global 'delwin', $P2 dlfunc $P2, $P1, 'deleteln', 'i' set_global 'deleteln', $P2 dlfunc $P2, $P1, 'derwin', 'ppiiii' set_global 'derwin', $P2 dlfunc $P2, $P1, 'doupdate', 'i' set_global 'doupdate', $P2 dlfunc $P2, $P1, 'dupwin', 'pp' set_global 'dupwin', $P2 dlfunc $P2, $P1, 'echo', 'i' set_global 'echo', $P2 dlfunc $P2, $P1, 'echochar', 'il' set_global 'echochar', $P2 dlfunc $P2, $P1, 'erase', 'i' set_global 'erase', $P2 dlfunc $P2, $P1, 'endwin', 'i' set_global 'endwin', $P2 dlfunc $P2, $P1, 'erasechar', 'c' set_global 'erasechar', $P2 dlfunc $P2, $P1, 'filter', 'v' set_global 'filter', $P2 dlfunc $P2, $P1, 'flash', 'i' set_global 'flash', $P2 dlfunc $P2, $P1, 'flushinp', 'i' set_global 'flushinp', $P2 dlfunc $P2, $P1, 'getbkgd', 'lp' set_global 'getbkgd', $P2 dlfunc $P2, $P1, 'getch', 'i' set_global 'getch', $P2 dlfunc $P2, $P1, 'getnstr', 'iti' set_global 'getnstr', $P2 dlfunc $P2, $P1, 'getstr', 'it' set_global 'getstr', $P2 dlfunc $P2, $P1, 'getwin', 'pp' set_global 'getwin', $P2 dlfunc $P2, $P1, 'halfdelay', 'ii' set_global 'halfdelay', $P2 dlfunc $P2, $P1, 'has_colors', 'i' set_global 'has_colors', $P2 dlfunc $P2, $P1, 'has_ic', 'i' set_global 'has_ic', $P2 dlfunc $P2, $P1, 'has_il', 'i' set_global 'has_il', $P2 dlfunc $P2, $P1, 'hline', 'ili' set_global 'hline', $P2 dlfunc $P2, $P1, 'idcok', 'vpl' set_global 'idcok', $P2 dlfunc $P2, $P1, 'idlok', 'ipl' set_global 'idlok', $P2 dlfunc $P2, $P1, 'immedok', 'vpl' set_global 'immedok', $P2 dlfunc $P2, $P1, 'inch', 'l' set_global 'inch', $P2 dlfunc $P2, $P1, 'inchnstr', 'i4i' set_global 'inchnstr', $P2 dlfunc $P2, $P1, 'inchstr', 'i4' set_global 'inchstr', $P2 dlfunc $P2, $P1, 'initscr', 'p' set_global 'initscr', $P2 dlfunc $P2, $P1, 'init_color', 'issss' set_global 'init_color', $P2 dlfunc $P2, $P1, 'init_pair', 'isss' set_global 'init_pair', $P2 dlfunc $P2, $P1, 'innstr', 'iti' set_global 'innstr', $P2 dlfunc $P2, $P1, 'insstr', 'it' set_global 'insstr', $P2 dlfunc $P2, $P1, 'instr', 'it' set_global 'instr', $P2 dlfunc $P2, $P1, 'intrflush', 'ipl' set_global 'intrflush', $P2 dlfunc $P2, $P1, 'isendwin', 'l' set_global 'isendwin', $P2 dlfunc $P2, $P1, 'is_linetouched', 'lpi' set_global 'is_linetouched', $P2 dlfunc $P2, $P1, 'is_wintouched', 'lp' set_global 'is_wintouched', $P2 dlfunc $P2, $P1, 'keyname', 'ti' set_global 'keyname', $P2 dlfunc $P2, $P1, 'keypad', 'ipl' set_global 'keypad', $P2 dlfunc $P2, $P1, 'killchar', 'c' set_global 'killchar', $P2 dlfunc $P2, $P1, 'leaveok', 'ipl' set_global 'leaveok', $P2 dlfunc $P2, $P1, 'longname', 't' set_global 'longname', $P2 dlfunc $P2, $P1, 'meta', 'ipl' set_global 'meta', $P2 dlfunc $P2, $P1, 'move', 'iii' set_global 'move', $P2 dlfunc $P2, $P1, 'mvaddch', 'iiil' set_global 'mvaddch', $P2 dlfunc $P2, $P1, 'mvaddchnstr', 'iii4i' set_global 'mvaddchnstr', $P2 dlfunc $P2, $P1, 'mvaddchstr', 'iii4' set_global 'mvaddchstr', $P2 dlfunc $P2, $P1, 'mvaddnstr', 'iiiti' set_global 'mvaddnstr', $P2 dlfunc $P2, $P1, 'mvaddstr', 'iiit' set_global 'mvaddstr', $P2 dlfunc $P2, $P1, 'mvchgat', 'iiiilsp' set_global 'mvchgat', $P2 #dlfunc $P2, $P1, 'mvcur', 'iiiii' #set_global 'mvcur', $P2 dlfunc $P2, $P1, 'mvdelch', 'iii' set_global 'mvdelch', $P2 dlfunc $P2, $P1, 'mvderwin', 'ipii' set_global 'mvderwin', $P2 dlfunc $P2, $P1, 'mvgetch', 'iii' set_global 'mvgetch', $P2 dlfunc $P2, $P1, 'mvgetnstr', 'iiiti' set_global 'mvgetnstr', $P2 dlfunc $P2, $P1, 'mvgetstr', 'iiit' set_global 'mvgetstr', $P2 dlfunc $P2, $P1, 'mvhline', 'iiili' set_global 'mvhline', $P2 dlfunc $P2, $P1, 'mvinch', 'lii' set_global 'mvinch', $P2 dlfunc $P2, $P1, 'mvinchnstr', 'iiiti' set_global 'mvinchnstr', $P2 dlfunc $P2, $P1, 'mvinchstr', 'iii4' set_global 'mvinchstr', $P2 dlfunc $P2, $P1, 'mvinnstr', 'iiiti' set_global 'mvinnstr', $P2 dlfunc $P2, $P1, 'mvinsch', 'iiil' set_global 'mvinsch', $P2 dlfunc $P2, $P1, 'mvinsnstr', 'iiiti' set_global 'mvinsnstr', $P2 dlfunc $P2, $P1, 'mvinsstr', 'iiit' set_global 'mvinsstr', $P2 dlfunc $P2, $P1, 'mvvline', 'iiili' set_global 'mvvline', $P2 dlfunc $P2, $P1, 'mvwaddch', 'ipiil' set_global 'mvwaddch', $P2 dlfunc $P2, $P1, 'mvwaddchnstr', 'ipii4i' set_global 'mvwaddchnstr', $P2 dlfunc $P2, $P1, 'mvwaddchstr', 'ipii4' set_global 'mvwaddchstr', $P2 dlfunc $P2, $P1, 'mvwaddnstr', 'ipiiti' set_global 'mvwaddnstr', $P2 dlfunc $P2, $P1, 'mvwaddstr', 'ipiit' set_global 'mvwaddstr', $P2 dlfunc $P2, $P1, 'mvwchgat', 'ipiiilsp' set_global 'mvwchgat', $P2 dlfunc $P2, $P1, 'mvwdelch', 'ipii' set_global 'mvwdelch', $P2 dlfunc $P2, $P1, 'mvwgetch', 'ipii' set_global 'mvwgetch', $P2 dlfunc $P2, $P1, 'mvwgetnstr', 'ipiiti' set_global 'mvwgetnstr', $P2 dlfunc $P2, $P1, 'mvwgetstr', 'ipiit' set_global 'mvwgetstr', $P2 dlfunc $P2, $P1, 'mvwhline', 'ipiili' set_global 'mvwhline', $P2 dlfunc $P2, $P1, 'mvwin', 'ipii' set_global 'mvwin', $P2 dlfunc $P2, $P1, 'mvwinch', 'lpii' set_global 'mvwinch', $P2 dlfunc $P2, $P1, 'mvwinchnstr', 'ipii4i' set_global 'mvwinchnstr', $P2 dlfunc $P2, $P1, 'mvwinchstr', 'ipii4' set_global 'mvwinchstr', $P2 dlfunc $P2, $P1, 'mvwinnstr', 'ipiiti' set_global 'mvwinnstr', $P2 dlfunc $P2, $P1, 'mvwinsch', 'ipiil' set_global 'mvwinsch', $P2 dlfunc $P2, $P1, 'mvwinsnstr', 'ipiiti' set_global 'mvwinsnstr', $P2 dlfunc $P2, $P1, 'mvwinsstr', 'ipiit' set_global 'mvwinsstr', $P2 dlfunc $P2, $P1, 'mvwinstr', 'ipiit' set_global 'mvwinstr', $P2 dlfunc $P2, $P1, 'mvwvline', 'ipiili' set_global 'mvwvline', $P2 dlfunc $P2, $P1, 'napms', 'ii' set_global 'napms', $P2 dlfunc $P2, $P1, 'newpad', 'pii' set_global 'newpad', $P2 dlfunc $P2, $P1, 'newterm', 'ptpp' set_global 'newterm', $P2 dlfunc $P2, $P1, 'newwin', 'piiii' set_global 'newwin', $P2 dlfunc $P2, $P1, 'nl', 'i' set_global 'nl', $P2 dlfunc $P2, $P1, 'nocbreak', 'i' set_global 'nocbreak', $P2 dlfunc $P2, $P1, 'nodelay', 'ipl' set_global 'nodelay', $P2 dlfunc $P2, $P1, 'noecho', 'i' set_global 'noecho', $P2 dlfunc $P2, $P1, 'nonl', 'i' set_global 'nonl', $P2 dlfunc $P2, $P1, 'noqiflush', 'v' set_global 'noqiflush', $P2 dlfunc $P2, $P1, 'noraw', 'i' set_global 'noraw', $P2 dlfunc $P2, $P1, 'notimeout', 'ipl' set_global 'notimeout', $P2 dlfunc $P2, $P1, 'overlay', 'ipp' set_global 'overlay', $P2 dlfunc $P2, $P1, 'overwrite', 'ipp' set_global 'overwrite', $P2 dlfunc $P2, $P1, 'pair_content', 'is22' set_global 'pair_content', $P2 dlfunc $P2, $P1, 'PAIR_NUMBER', 'ii' set_global 'PAIR_NUMBER', $P2 dlfunc $P2, $P1, 'pechochar', 'ipl' set_global 'pechochar', $P2 dlfunc $P2, $P1, 'pnoutrefresh', 'ipiiiiii' set_global 'pnoutrefresh', $P2 dlfunc $P2, $P1, 'prefresh', 'ipiiiiii' set_global 'prefresh', $P2 dlfunc $P2, $P1, 'putp', 'it' set_global 'putp', $P2 dlfunc $P2, $P1, 'putwin', 'ipp' set_global 'putwin', $P2 dlfunc $P2, $P1, 'qiflush', 'v' set_global 'qiflush', $P2 dlfunc $P2, $P1, 'raw', 'i' set_global 'raw', $P2 dlfunc $P2, $P1, 'redrawwin', 'ip' set_global 'redrawwin', $P2 dlfunc $P2, $P1, 'refresh', 'i' set_global 'refresh', $P2 dlfunc $P2, $P1, 'resetty', 'i' set_global 'resetty', $P2 dlfunc $P2, $P1, 'reset_prog_mode', 'i' set_global 'reset_prog_mode', $P2 dlfunc $P2, $P1, 'reset_shell_mode', 'i' set_global 'reset_shell_mode', $P2 dlfunc $P2, $P1, 'ripoffline', 'iiip' set_global 'ripoffline', $P2 dlfunc $P2, $P1, 'savetty', 'i' set_global 'savetty', $P2 dlfunc $P2, $P1, 'scr_dump', 'it' set_global 'scr_dump', $P2 dlfunc $P2, $P1, 'scr_init', 'it' set_global 'scr_init', $P2 dlfunc $P2, $P1, 'scrl', 'ii' set_global 'scrl', $P2 dlfunc $P2, $P1, 'scroll', 'ip' set_global 'scroll', $P2 dlfunc $P2, $P1, 'scrollok', 'ipl' set_global 'scrollok', $P2 dlfunc $P2, $P1, 'scr_restore', 'it' set_global 'scr_restore', $P2 dlfunc $P2, $P1, 'scr_set', 'it' set_global 'scr_set', $P2 dlfunc $P2, $P1, 'setscrreg', 'iii' set_global 'setscrreg', $P2 dlfunc $P2, $P1, 'set_term', 'pp' set_global 'set_term', $P2 dlfunc $P2, $P1, 'slk_attroff', 'il' set_global 'slk_attroff', $P2 dlfunc $P2, $P1, 'slk_attron', 'il' set_global 'slk_attron', $P2 dlfunc $P2, $P1, 'slk_attrset', 'il' set_global 'slk_attrset', $P2 dlfunc $P2, $P1, 'slk_attr', 'l' set_global 'slk_attr', $P2 dlfunc $P2, $P1, 'slk_attr_set', 'ilsp' set_global 'slk_attr_set', $P2 dlfunc $P2, $P1, 'slk_clear', 'i' set_global 'slk_clear', $P2 dlfunc $P2, $P1, 'slk_color', 'is' set_global 'slk_color', $P2 dlfunc $P2, $P1, 'slk_init', 'ii' set_global 'slk_init', $P2 dlfunc $P2, $P1, 'slk_label', 'ti' set_global 'slk_label', $P2 dlfunc $P2, $P1, 'slk_noutrefresh', 'i' set_global 'slk_noutrefresh', $P2 dlfunc $P2, $P1, 'slk_refresh', 'i' set_global 'slk_refresh', $P2 dlfunc $P2, $P1, 'slk_restore', 'i' set_global 'slk_restore', $P2 dlfunc $P2, $P1, 'slk_set', 'iiti' set_global 'slk_set', $P2 dlfunc $P2, $P1, 'slk_touch', 'i' set_global 'slk_touch', $P2 dlfunc $P2, $P1, 'standout', 'i' set_global 'standout', $P2 dlfunc $P2, $P1, 'standend', 'i' set_global 'standend', $P2 dlfunc $P2, $P1, 'start_color', 'i' set_global 'start_color', $P2 dlfunc $P2, $P1, 'subpad', 'ppiiii' set_global 'subpad', $P2 dlfunc $P2, $P1, 'subwin', 'ppiiii' set_global 'subwin', $P2 dlfunc $P2, $P1, 'syncok', 'ipl' set_global 'syncok', $P2 dlfunc $P2, $P1, 'termattrs', 'l' set_global 'termattrs', $P2 dlfunc $P2, $P1, 'termname', 't' set_global 'termname', $P2 dlfunc $P2, $P1, 'tigetflag', 'it' set_global 'tigetflag', $P2 dlfunc $P2, $P1, 'tigetnum', 'it' set_global 'tigetnum', $P2 dlfunc $P2, $P1, 'tigetstr', 'tt' set_global 'tigetstr', $P2 dlfunc $P2, $P1, 'timeout', 'vi' set_global 'timeout', $P2 dlfunc $P2, $P1, 'typeahead', 'ii' set_global 'typeahead', $P2 dlfunc $P2, $P1, 'ungetch', 'ii' set_global 'ungetch', $P2 dlfunc $P2, $P1, 'untouchwin', 'ip' set_global 'untouchwin', $P2 dlfunc $P2, $P1, 'use_env', 'vl' set_global 'use_env', $P2 dlfunc $P2, $P1, 'vidattr', 'il' set_global 'vidattr', $P2 dlfunc $P2, $P1, 'vidputs', 'ilp' set_global 'vidputs', $P2 dlfunc $P2, $P1, 'vline', 'ili' set_global 'vline', $P2 dlfunc $P2, $P1, 'waddch', 'ipl' set_global 'waddch', $P2 dlfunc $P2, $P1, 'waddchnstr', 'ip4i' set_global 'waddchnstr', $P2 dlfunc $P2, $P1, 'waddchstr', 'ip4' set_global 'waddchstr', $P2 dlfunc $P2, $P1, 'waddnstr', 'ipti' set_global 'waddnstr', $P2 dlfunc $P2, $P1, 'waddstr', 'ipt' set_global 'waddstr', $P2 dlfunc $P2, $P1, 'wattron', 'ipi' set_global 'wattron', $P2 dlfunc $P2, $P1, 'wattroff', 'ipi' set_global 'wattroff', $P2 dlfunc $P2, $P1, 'wattrset', 'ipi' set_global 'wattrset', $P2 dlfunc $P2, $P1, 'wattr_get', 'ip42p' set_global 'wattr_get', $P2 dlfunc $P2, $P1, 'wattr_on', 'iplp' set_global 'wattr_on', $P2 dlfunc $P2, $P1, 'wattr_off', 'iplp' set_global 'wattr_off', $P2 dlfunc $P2, $P1, 'wattr_set', 'iplsp' set_global 'wattr_set', $P2 dlfunc $P2, $P1, 'wbkgd', 'ipl' set_global 'wbkgd', $P2 dlfunc $P2, $P1, 'wbkgdset', 'vpl' set_global 'wbkgdset', $P2 dlfunc $P2, $P1, 'wborder', 'ipllllllll' set_global 'wborder', $P2 dlfunc $P2, $P1, 'wchgat', 'ipilsp' set_global 'wchgat', $P2 dlfunc $P2, $P1, 'wclear', 'ip' set_global 'wclear', $P2 dlfunc $P2, $P1, 'wclrtobot', 'ip' set_global 'wclrtobot', $P2 dlfunc $P2, $P1, 'wclrtoeol', 'ip' set_global 'wclrtoeol', $P2 dlfunc $P2, $P1, 'wcolor_set', 'ipsp' set_global 'wcolor_set', $P2 dlfunc $P2, $P1, 'wcursyncup', 'vp' set_global 'wcursyncup', $P2 dlfunc $P2, $P1, 'wdelch', 'ip' set_global 'wdelch', $P2 dlfunc $P2, $P1, 'wdeleteln', 'ip' set_global 'wdeleteln', $P2 dlfunc $P2, $P1, 'wechochar', 'ipl' set_global 'wechochar', $P2 dlfunc $P2, $P1, 'werase', 'ip' set_global 'werase', $P2 dlfunc $P2, $P1, 'wgetch', 'ip' set_global 'wgetch', $P2 dlfunc $P2, $P1, 'wgetnstr', 'ipti' set_global 'wgetnstr', $P2 dlfunc $P2, $P1, 'wgetstr', 'ipt' set_global 'wgetstr', $P2 dlfunc $P2, $P1, 'whline', 'ipli' set_global 'whline', $P2 dlfunc $P2, $P1, 'winch', 'lp' set_global 'winch', $P2 dlfunc $P2, $P1, 'winchnstr', 'ip4i' set_global 'winchnstr', $P2 dlfunc $P2, $P1, 'winnstr', 'ipti' set_global 'winnstr', $P2 dlfunc $P2, $P1, 'winsch', 'ipl' set_global 'winsch', $P2 dlfunc $P2, $P1, 'winsdelln', 'ipi' set_global 'winsdelln', $P2 dlfunc $P2, $P1, 'winsertln', 'ip' set_global 'winsertln', $P2 dlfunc $P2, $P1, 'winsnstr', 'ipti' set_global 'winsnstr', $P2 dlfunc $P2, $P1, 'winsstr', 'ipt' set_global 'winsstr', $P2 dlfunc $P2, $P1, 'winstr', 'ipt' set_global 'winstr', $P2 dlfunc $P2, $P1, 'wmove', 'ipii' set_global 'wmove', $P2 dlfunc $P2, $P1, 'wnoutrefresh', 'ip' set_global 'wnoutrefresh', $P2 dlfunc $P2, $P1, 'wredrawln', 'ipii' set_global 'wredrawln', $P2 dlfunc $P2, $P1, 'wrefresh', 'ip' set_global 'wrefresh', $P2 dlfunc $P2, $P1, 'wscrl', 'ipi' set_global 'wscrl', $P2 dlfunc $P2, $P1, 'wsetscrreg', 'ipii' set_global 'wsetscrreg', $P2 dlfunc $P2, $P1, 'wstandout', 'ip' set_global 'wstandout', $P2 dlfunc $P2, $P1, 'wstandend', 'ip' set_global 'wstandend', $P2 dlfunc $P2, $P1, 'wsyncdown', 'vp' set_global 'wsyncdown', $P2 dlfunc $P2, $P1, 'wsyncup', 'vp' set_global 'wsyncup', $P2 dlfunc $P2, $P1, 'wtimeout', 'vpi' set_global 'wtimeout', $P2 dlfunc $P2, $P1, 'wtouchln', 'ipiii' set_global 'wtouchln', $P2 dlfunc $P2, $P1, 'wvline', 'ipli' set_global 'wvline', $P2 dlfunc $P2, $P1, 'getmouse', 'ip' set_global 'getmouse', $P2 dlfunc $P2, $P1, 'ungetmouse', 'ip' set_global 'ungetmouse', $P2 dlfunc $P2, $P1, 'mousemask', 'll4' set_global 'mousemask', $P2 dlfunc $P2, $P1, 'wenclose', 'lpii' set_global 'wenclose', $P2 dlfunc $P2, $P1, 'mouseinterval', 'ii' set_global 'mouseinterval', $P2 dlfunc $P2, $P1, 'wmouse_trafo', 'lp33l' set_global 'wmouse_trafo', $P2 dlfunc $P2, $P1, 'mouse_trafo', 'l33l' set_global 'mouse_trafo', $P2 dlfunc $P2, $P1, 'mcprint', 'iti' set_global 'mcprint', $P2 dlfunc $P2, $P1, 'has_key', 'ii' set_global 'has_key', $P2 .export_dl_func($P1, 'getmaxx', 'ip') .export_dl_func($P1, 'getmaxy', 'ip') .begin_return .end_return .end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: PBC_COMPAT000644000765000765 417212101554066 13064 0ustar00bruce000000000000parrot-6.6.0# This file shows the history of incompatible changes to # Parrot that invalidated existing PBC (Parrot Byte Code) files. # # The latest version number of the bytecode format in this file # is used by Parrot to version the bytecode files it writes and # is able to read. In the future, Parrot should be able to read # and/or write older bytecode versions too. # # Currently known actions that should be entered here # (and invalidate PBC are): # # - deleting/changing/inserting existing ops in ops.num # - changing operands of existing ops # - adding/deleting/renaming a PMC to classes # - changes in the packfile format itself # - changes to any PMCs that are frozen into the .pbc like # ParrotInterpreter (HLL_info), Subs and more # - other core changes that invalidate byte code :) # # After changing PBC_COMPAT either disable t/native_pbc tests or # better, if you have an i386 and ppc box at hand, regenerate the PBCs # with tools/dev/mk_native_pbc and commit the changes # TODO TT #361: all .pbc files should make-depend on PBC_COMPAT # please insert tab separated entries at the top of the list 13.0 2012.12.04 rurban opslib bytecode version, threads, Proxy 12.1 2012.09.03 rurban moved dynpmc os back to pmc 12.0 2011.10.18 dukeleto released 3.9.0 11.0 2011.07.19 jkeenan released 3.6.0 10.0 2011.01.18 cotto released 3.0.0 9.0 2010.10.19 gerd released 2.9.0 8.0 2010.07.20 coke released 2.6.0 7.0 2010.04.20 gerd released 2.3.0 (version # added ex post facto, as all previous version #s were published) 6.6 2010.04.17 bacek add replace op 6.5 2010.03.09 cotto remove cpu_ret op 6.4 2010.03.02 cotto remove prederef__ and reserved 6.3 2010.02.16 whiteknight Add OpLib and Opcode PMCs 6.2 2010.01.31 cotto serialization-related changes to ParrotInterpreter 6.1 2010.01.30 whiteknight remove Array PMC 6.0 2010.01.19 chromatic released 2.0.0 5.1 2009.08.06 cotto remove branch_cs opcode 5.0 2009.07.21 cotto released 1.4.0 4.0 2009.03.17 allison released 1.0.0 3.0 2007.07.23 jonathan implementing new PBC header format 2.0 2005.11.22 leo changed PBC format (HLL_info) 1.0 2005.10.15 jonathan changed debug segment format 0.1 2003.10.21 leo start this file H2inc.pm000644000765000765 1763412305426127 15041 0ustar00bruce000000000000parrot-6.6.0/lib/Parrotpackage Parrot::H2inc; # Copyright (C) 2010-2014, Parrot Foundation. use strict; use warnings; use Exporter; our @ISA = qw( Exporter ); our @EXPORT_OK = qw( parse_file perform_directive generate_text print_generated_file ); =head1 NAME Parrot::H2inc - Subroutines used in F =head1 DESCRIPTION This package exports on demand only four subroutines used in F. =head1 SUBROUTINES =head2 C =over 4 =item * Arguments $directive = parse_file($in_file, $out_file); List of 2 elements: string holding name of incoming file; string holding name of outgoing file. =item * Return Value If successful, returns a hash reference. =back =cut sub parse_file { my ( $in_file, $out_file) = @_; $out_file =~ s{\\}{/}g; # transform Windows backslash my ( %values, $last_val, $cur, $or_continues ); open my $fh, '<', $in_file or die "Can't open $in_file: $!\n"; while ( my $line = <$fh> ) { if ( $line =~ m{ &gen_from_(enum|def) \( ( [^)]* ) \) (?: \s+ prefix \( (\w+) \) )? (?: \s+ subst \( (s/.*?/.*?/[eig]?) \) )? }x ) { $cur and die "Missing '&end_gen' in $in_file\n"; my $file; foreach (split ' ', $2) { $file = $_ if $out_file =~ /$_$/; } $cur = { type => $1, file => $file, prefix => defined $3 ? $3 : '', defined $4 ? ( subst => $4 ) : (), }; $last_val = -1; } elsif ( $line =~ /&end_gen\b/ ) { $cur or die "Missing &gen_from_(enum|def) in $in_file\n"; return $cur if defined $cur->{file}; $cur = undef; } $cur or next; if ( $cur->{type} eq 'def' && $line =~ /^\s*#define\s+(\w+)\s+(-?\w+|"[^"]*")/ ) { push @{ $cur->{defs} }, [ $1, $2 ]; } elsif ( $cur->{type} eq 'enum' ) { # Special case: enum value is or'd combination of other values if ( $or_continues ) { $or_continues = 0; my $last_def = $cur->{defs}->[-1]; my ($k, $v) = @{$last_def}; my @or_values = grep {defined $_} $line =~ /^\s*(-?\w+)(?:\s*\|\s*(-?\w+))*/; for my $or (@or_values) { if ( defined $values{$or} ) { $v |= $values{$or}; } elsif ( $or =~ /^0/ ) { $v |= oct $or; } } if ($line =~ /\|\s*$/) { $or_continues = 1; } $values{$k} = $last_val = $v; $cur->{defs}->[-1]->[1] = $v; } elsif ( $line =~ /^\s*(\w+)\s*=\s*(-?\w+)\s*\|/ ) { my ( $k, $v ) = ( $1, $2 ); my @or_values = ($v, $line =~ /\|\s*(-?\w+)/g); $v = 0; for my $or (@or_values) { if ( defined $values{$or} ) { $v |= $values{$or}; } elsif ( $or =~ /^0/ ) { $v |= oct $or; } } if ($line =~ /\|\s*$/) { $or_continues = 1; } $values{$k} = $last_val = $v; push @{ $cur->{defs} }, [ $k, $v ]; } elsif ( $line =~ /^\s*(\w+)\s*=\s*(-?\w+)/ ) { my ( $k, $v ) = ( $1, $2 ); if ( defined $values{$v} ) { $v = $values{$v}; } elsif ( $v =~ /^0/ ) { $v = oct $v; } $values{$k} = $last_val = $v; push @{ $cur->{defs} }, [ $k, $v ]; } elsif ( $line =~ m{^\s*(\w+)\s*(?:,\s*)?(?:/\*|$)} ) { my $k = $1; my $v = $values{$k} = ++$last_val; push @{ $cur->{defs} }, [ $k, $v ]; } } } close $fh or die "Could not close handle to $in_file after reading: $!"; $cur and die "Missing '&end_gen' in $in_file\n"; return; } =head2 C =over 4 =item * Arguments $defs_ref = perform_directive($directive); Single hash reference (which is the return value from a successful run of C. =item * Return Value Array reference. =back =cut sub perform_directive { my ($d) = @_; my @defs = prepend_prefix( $d->{prefix}, @{ $d->{defs} } ); if ( my $subst = $d->{subst} ) { @defs = transform_name( sub { local $_ = shift; eval $subst; $_ }, @defs ); } return \@defs; } =head2 C =over 4 =item * Arguments $gen = join "\n", const_to_parrot(@defs); List. =item * Return Value String. =back =cut sub const_to_parrot { my $keylen = (sort { $a <=> $b } map { length($_->[0]) } @_ )[-1] ; my $vallen = (sort { $a <=> $b } map { length($_->[1]) } @_ )[-1] ; return map {sprintf ".macro_const %-${keylen}s %${vallen}s", $_->[0], $_->[1]} @_; } =head2 C =over 4 =item * Arguments $gen = join "\n", const_to_perl(@defs); List. =item * Return Value String. =back =cut sub const_to_perl { my $keylen = (sort { $a <=> $b } map { length($_->[0]) } @_ )[-1] ; return map {sprintf "use constant %-${keylen}s => %s;", $_->[0], $_->[1]} @_; } =head2 C =over 4 =item * Arguments transform_name( sub { $prefix . $_[0] }, @_ ); List of two or more elements, the first element of which is a subroutine reference. =item * Return Value List which is a mapping of the transformations executed by the first argument upon the remaining arguments. =back =cut sub transform_name { my $action = shift; return map { [ $action->( $_->[0] ), $_->[1] ] } @_; } =head2 C =over 4 =item * Arguments @defs = prepend_prefix $d->{prefix}, @{ $d->{defs} }; List of two or more elements, the first element of which is a string. =item * Return Value List. =back =cut sub prepend_prefix { my $prefix = shift; return transform_name( sub { $prefix . $_[0] }, @_ ); } =head2 C =over 4 =item * Argument $generated_text = generate_text($directive, \@defs); List of two arguments: Directive hashref; reference to array of definitions. =item * Return Value String holding main text to be printed to new file. =back =cut sub generate_text { my ($directive, $defs_ref) = @_; my $target = $directive->{file}; my $generated_text; if ($target =~ /\.pm$/) { $generated_text = join "\n", const_to_perl(@{ $defs_ref }); $generated_text .= "\n1;"; } else { $generated_text = join "\n", const_to_parrot(@{ $defs_ref }); } return $generated_text; } =head2 C =over 4 =item * Argument print_generated_file( { in => $in_file, out => $out_file, script => $0, gen => $generated_text, } ); Hash reference. Elements pertain to file being read, file being created, calling program (typically, F) and string of text to be printed to file. =item * Return Value Implicitly returns true upon success. =back =cut sub print_generated_file { my $args = shift; open my $out_fh, '>', $args->{out} or die "Can't open $args->{out}: $!\n"; print {$out_fh} <<"EOF"; # ex: set ro ft=c: # DO NOT EDIT THIS FILE. # # This file is generated automatically from # $args->{in} by $args->{script} # # Any changes made here will be lost. # $args->{gen} # Local Variables: # mode: pir # buffer-read-only: t # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: EOF close $out_fh; return; } 1; # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: extra_thunks.c000644000765000765 57122212233541455 15766 0ustar00bruce000000000000parrot-6.6.0/src/nci/* ex: set ro ft=c: * !!!!!!! DO NOT EDIT THIS FILE !!!!!!! * * This file is generated automatically by tools/dev/nci_thunk_gen.pir * * Any changes made here will be lost! * */ /* src/nci/extra_thunks.c * Copyright (C) 2010-2012, Parrot Foundation. * Overview: * Native Call Interface routines. * Code to call C from parrot. */ #include "parrot/parrot.h" #include "parrot/nci.h" #include "pmc/pmc_nci.h" #ifdef PARROT_IN_EXTENSION /* external libraries can't have strings statically compiled into parrot */ # define CONST_STRING(i, s) Parrot_str_new_constant((i), (s)) #else # include "extra_thunks.str" #endif /* HEADERIZER HFILE: none */ void Parrot_nci_load_extra_thunks(PARROT_INTERP); /* HEADERIZER STOP */ /* All our static functions that call in various ways. */ static void pcf_int_int_ptr(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(int, void *); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; INTVAL t_1; int v_1; PMC * t_2; void * v_2; Parrot_pcc_fill_params_from_c_args(interp, call_object, "IP", &t_1, &t_2); v_1 = t_1; v_2 = PMC_IS_NULL(t_2) ? NULL : VTABLE_get_pointer(interp, t_2);; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_int_ptr(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(void *); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; PMC * t_1; void * v_1; Parrot_pcc_fill_params_from_c_args(interp, call_object, "P", &t_1); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_void_ptr(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef void(* func_t)(void *); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); PMC * t_1; void * v_1; Parrot_pcc_fill_params_from_c_args(interp, call_object, "P", &t_1); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); (*fn_pointer)(v_1); Parrot_pcc_set_call_from_c_args(interp, call_object, ""); } static void pcf_void_ptr_ptr_ptr(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef void(* func_t)(void *, void *, void *); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); PMC * t_1; void * v_1; PMC * t_2; void * v_2; PMC * t_3; void * v_3; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PPP", &t_1, &t_2, &t_3); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = PMC_IS_NULL(t_2) ? NULL : VTABLE_get_pointer(interp, t_2);; v_3 = PMC_IS_NULL(t_3) ? NULL : VTABLE_get_pointer(interp, t_3);; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); (*fn_pointer)(v_1, v_2, v_3); Parrot_pcc_set_call_from_c_args(interp, call_object, ""); } static void pcf_void(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef void(* func_t)(void); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); ; Parrot_pcc_fill_params_from_c_args(interp, call_object, ""); ; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); (*fn_pointer)(); Parrot_pcc_set_call_from_c_args(interp, call_object, ""); } static void pcf_void_int(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef void(* func_t)(int); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_1; int v_1; Parrot_pcc_fill_params_from_c_args(interp, call_object, "I", &t_1); v_1 = t_1; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); (*fn_pointer)(v_1); Parrot_pcc_set_call_from_c_args(interp, call_object, ""); } static void pcf_void_int_int(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef void(* func_t)(int, int); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_1; int v_1; INTVAL t_2; int v_2; Parrot_pcc_fill_params_from_c_args(interp, call_object, "II", &t_1, &t_2); v_1 = t_1; v_2 = t_2; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); (*fn_pointer)(v_1, v_2); Parrot_pcc_set_call_from_c_args(interp, call_object, ""); } static void pcf_void_int_long_long_long_long_long_long_long_long(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef void(* func_t)(int, long, long, long, long, long, long, long, long); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_1; int v_1; INTVAL t_2; long v_2; INTVAL t_3; long v_3; INTVAL t_4; long v_4; INTVAL t_5; long v_5; INTVAL t_6; long v_6; INTVAL t_7; long v_7; INTVAL t_8; long v_8; INTVAL t_9; long v_9; Parrot_pcc_fill_params_from_c_args(interp, call_object, "IIIIIIIII", &t_1, &t_2, &t_3, &t_4, &t_5, &t_6, &t_7, &t_8, &t_9); v_1 = t_1; v_2 = t_2; v_3 = t_3; v_4 = t_4; v_5 = t_5; v_6 = t_6; v_7 = t_7; v_8 = t_8; v_9 = t_9; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); (*fn_pointer)(v_1, v_2, v_3, v_4, v_5, v_6, v_7, v_8, v_9); Parrot_pcc_set_call_from_c_args(interp, call_object, ""); } static void pcf_void_long(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef void(* func_t)(long); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_1; long v_1; Parrot_pcc_fill_params_from_c_args(interp, call_object, "I", &t_1); v_1 = t_1; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); (*fn_pointer)(v_1); Parrot_pcc_set_call_from_c_args(interp, call_object, ""); } static void pcf_void_ptr_int(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef void(* func_t)(void *, int); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); PMC * t_1; void * v_1; INTVAL t_2; int v_2; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PI", &t_1, &t_2); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = t_2; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); (*fn_pointer)(v_1, v_2); Parrot_pcc_set_call_from_c_args(interp, call_object, ""); } static void pcf_void_ptr_int_int_int_int(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef void(* func_t)(void *, int, int, int, int); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); PMC * t_1; void * v_1; INTVAL t_2; int v_2; INTVAL t_3; int v_3; INTVAL t_4; int v_4; INTVAL t_5; int v_5; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PIIII", &t_1, &t_2, &t_3, &t_4, &t_5); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = t_2; v_3 = t_3; v_4 = t_4; v_5 = t_5; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); (*fn_pointer)(v_1, v_2, v_3, v_4, v_5); Parrot_pcc_set_call_from_c_args(interp, call_object, ""); } static void pcf_void_ptr_long(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef void(* func_t)(void *, long); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); PMC * t_1; void * v_1; INTVAL t_2; long v_2; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PI", &t_1, &t_2); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = t_2; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); (*fn_pointer)(v_1, v_2); Parrot_pcc_set_call_from_c_args(interp, call_object, ""); } static void pcf_void_ptr_ptr(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef void(* func_t)(void *, void *); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); PMC * t_1; void * v_1; PMC * t_2; void * v_2; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PP", &t_1, &t_2); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = PMC_IS_NULL(t_2) ? NULL : VTABLE_get_pointer(interp, t_2);; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); (*fn_pointer)(v_1, v_2); Parrot_pcc_set_call_from_c_args(interp, call_object, ""); } static void pcf_int_PMC(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(PMC *); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; PMC * t_1; PMC * v_1; Parrot_pcc_fill_params_from_c_args(interp, call_object, "P", &t_1); v_1 = t_1; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_int_ptr_ptr_double(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(void *, void *, double); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; PMC * t_1; void * v_1; PMC * t_2; void * v_2; FLOATVAL t_3; double v_3; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PPN", &t_1, &t_2, &t_3); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = PMC_IS_NULL(t_2) ? NULL : VTABLE_get_pointer(interp, t_2);; v_3 = t_3; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_int_ptr_int_ptr_int(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(void *, int, void *, int); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; PMC * t_1; void * v_1; INTVAL t_2; int v_2; PMC * t_3; void * v_3; INTVAL t_4; int v_4; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PIPI", &t_1, &t_2, &t_3, &t_4); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = t_2; v_3 = PMC_IS_NULL(t_3) ? NULL : VTABLE_get_pointer(interp, t_3);; v_4 = t_4; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3, v_4); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_ptr_ptr_ptr_int(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef void *(* func_t)(void *, void *, int); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); PMC * t_0; void * v_0; PMC * t_1; void * v_1; PMC * t_2; void * v_2; INTVAL t_3; int v_3; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PPI", &t_1, &t_2, &t_3); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = PMC_IS_NULL(t_2) ? NULL : VTABLE_get_pointer(interp, t_2);; v_3 = t_3; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3); if (v_0 != NULL) { t_0 = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, t_0, v_0); } else { t_0 = PMCNULL; }; Parrot_pcc_set_call_from_c_args(interp, call_object, "P", t_0); } static void pcf_ptr_ptr_ptr_ptr_int(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef void *(* func_t)(void *, void *, void *, int); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); PMC * t_0; void * v_0; PMC * t_1; void * v_1; PMC * t_2; void * v_2; PMC * t_3; void * v_3; INTVAL t_4; int v_4; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PPPI", &t_1, &t_2, &t_3, &t_4); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = PMC_IS_NULL(t_2) ? NULL : VTABLE_get_pointer(interp, t_2);; v_3 = PMC_IS_NULL(t_3) ? NULL : VTABLE_get_pointer(interp, t_3);; v_4 = t_4; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3, v_4); if (v_0 != NULL) { t_0 = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, t_0, v_0); } else { t_0 = PMCNULL; }; Parrot_pcc_set_call_from_c_args(interp, call_object, "P", t_0); } static void pcf_ptr_ptr_ptr_ptr_ptr_int(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef void *(* func_t)(void *, void *, void *, void *, int); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); PMC * t_0; void * v_0; PMC * t_1; void * v_1; PMC * t_2; void * v_2; PMC * t_3; void * v_3; PMC * t_4; void * v_4; INTVAL t_5; int v_5; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PPPPI", &t_1, &t_2, &t_3, &t_4, &t_5); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = PMC_IS_NULL(t_2) ? NULL : VTABLE_get_pointer(interp, t_2);; v_3 = PMC_IS_NULL(t_3) ? NULL : VTABLE_get_pointer(interp, t_3);; v_4 = PMC_IS_NULL(t_4) ? NULL : VTABLE_get_pointer(interp, t_4);; v_5 = t_5; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3, v_4, v_5); if (v_0 != NULL) { t_0 = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, t_0, v_0); } else { t_0 = PMCNULL; }; Parrot_pcc_set_call_from_c_args(interp, call_object, "P", t_0); } static void pcf_int(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(void); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; Parrot_pcc_fill_params_from_c_args(interp, call_object, ""); ; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_long_long_ptr_ptr_long(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef long(* func_t)(long, void *, void *, long); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; long v_0; INTVAL t_1; long v_1; PMC * t_2; void * v_2; PMC * t_3; void * v_3; INTVAL t_4; long v_4; Parrot_pcc_fill_params_from_c_args(interp, call_object, "IPPI", &t_1, &t_2, &t_3, &t_4); v_1 = t_1; v_2 = PMC_IS_NULL(t_2) ? NULL : VTABLE_get_pointer(interp, t_2);; v_3 = PMC_IS_NULL(t_3) ? NULL : VTABLE_get_pointer(interp, t_3);; v_4 = t_4; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3, v_4); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_int_ptr_int_ptr(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(void *, int, void *); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; PMC * t_1; void * v_1; INTVAL t_2; int v_2; PMC * t_3; void * v_3; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PIP", &t_1, &t_2, &t_3); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = t_2; v_3 = PMC_IS_NULL(t_3) ? NULL : VTABLE_get_pointer(interp, t_3);; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_int_ptr_int_STRING(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(void *, int, STRING *); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; PMC * t_1; void * v_1; INTVAL t_2; int v_2; STRING * t_3; STRING * v_3; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PIS", &t_1, &t_2, &t_3); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = t_2; v_3 = t_3; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_STRING_int(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef STRING *(* func_t)(int); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); STRING * t_0; STRING * v_0; INTVAL t_1; int v_1; Parrot_pcc_fill_params_from_c_args(interp, call_object, "I", &t_1); v_1 = t_1; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "S", t_0); } static void pcf_long_ptr(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef long(* func_t)(void *); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; long v_0; PMC * t_1; void * v_1; Parrot_pcc_fill_params_from_c_args(interp, call_object, "P", &t_1); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_char_ptr(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef char(* func_t)(void *); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; char v_0; PMC * t_1; void * v_1; Parrot_pcc_fill_params_from_c_args(interp, call_object, "P", &t_1); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_char_ptr_ptr_ptr_ptr(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef char(* func_t)(void *, void *, void *, void *); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; char v_0; PMC * t_1; void * v_1; PMC * t_2; void * v_2; PMC * t_3; void * v_3; PMC * t_4; void * v_4; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PPPP", &t_1, &t_2, &t_3, &t_4); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = PMC_IS_NULL(t_2) ? NULL : VTABLE_get_pointer(interp, t_2);; v_3 = PMC_IS_NULL(t_3) ? NULL : VTABLE_get_pointer(interp, t_3);; v_4 = PMC_IS_NULL(t_4) ? NULL : VTABLE_get_pointer(interp, t_4);; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3, v_4); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_ptr_ptr_int(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef void *(* func_t)(void *, int); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); PMC * t_0; void * v_0; PMC * t_1; void * v_1; INTVAL t_2; int v_2; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PI", &t_1, &t_2); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = t_2; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2); if (v_0 != NULL) { t_0 = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, t_0, v_0); } else { t_0 = PMCNULL; }; Parrot_pcc_set_call_from_c_args(interp, call_object, "P", t_0); } static void pcf_ptr_ptr(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef void *(* func_t)(void *); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); PMC * t_0; void * v_0; PMC * t_1; void * v_1; Parrot_pcc_fill_params_from_c_args(interp, call_object, "P", &t_1); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1); if (v_0 != NULL) { t_0 = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, t_0, v_0); } else { t_0 = PMCNULL; }; Parrot_pcc_set_call_from_c_args(interp, call_object, "P", t_0); } static void pcf_int_ptr_ptr_ptr_ptr_ptr_ptr(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(void *, void *, void *, void *, void *, void *); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; PMC * t_1; void * v_1; PMC * t_2; void * v_2; PMC * t_3; void * v_3; PMC * t_4; void * v_4; PMC * t_5; void * v_5; PMC * t_6; void * v_6; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PPPPPP", &t_1, &t_2, &t_3, &t_4, &t_5, &t_6); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = PMC_IS_NULL(t_2) ? NULL : VTABLE_get_pointer(interp, t_2);; v_3 = PMC_IS_NULL(t_3) ? NULL : VTABLE_get_pointer(interp, t_3);; v_4 = PMC_IS_NULL(t_4) ? NULL : VTABLE_get_pointer(interp, t_4);; v_5 = PMC_IS_NULL(t_5) ? NULL : VTABLE_get_pointer(interp, t_5);; v_6 = PMC_IS_NULL(t_6) ? NULL : VTABLE_get_pointer(interp, t_6);; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3, v_4, v_5, v_6); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_long_ptr_ptr_long(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef long(* func_t)(void *, void *, long); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; long v_0; PMC * t_1; void * v_1; PMC * t_2; void * v_2; INTVAL t_3; long v_3; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PPI", &t_1, &t_2, &t_3); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = PMC_IS_NULL(t_2) ? NULL : VTABLE_get_pointer(interp, t_2);; v_3 = t_3; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_long_ptr_ptr_ptr_long(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef long(* func_t)(void *, void *, void *, long); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; long v_0; PMC * t_1; void * v_1; PMC * t_2; void * v_2; PMC * t_3; void * v_3; INTVAL t_4; long v_4; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PPPI", &t_1, &t_2, &t_3, &t_4); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = PMC_IS_NULL(t_2) ? NULL : VTABLE_get_pointer(interp, t_2);; v_3 = PMC_IS_NULL(t_3) ? NULL : VTABLE_get_pointer(interp, t_3);; v_4 = t_4; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3, v_4); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_int_ptr_int(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(void *, int); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; PMC * t_1; void * v_1; INTVAL t_2; int v_2; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PI", &t_1, &t_2); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = t_2; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_int_ptr_long(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(void *, long); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; PMC * t_1; void * v_1; INTVAL t_2; long v_2; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PI", &t_1, &t_2); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = t_2; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_long(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef long(* func_t)(void); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; long v_0; Parrot_pcc_fill_params_from_c_args(interp, call_object, ""); ; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_ptr_ptr_ptr(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef void *(* func_t)(void *, void *); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); PMC * t_0; void * v_0; PMC * t_1; void * v_1; PMC * t_2; void * v_2; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PP", &t_1, &t_2); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = PMC_IS_NULL(t_2) ? NULL : VTABLE_get_pointer(interp, t_2);; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2); if (v_0 != NULL) { t_0 = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, t_0, v_0); } else { t_0 = PMCNULL; }; Parrot_pcc_set_call_from_c_args(interp, call_object, "P", t_0); } static void pcf_ptr_ptr_ptr_ptr_ptr_ptr_int_ptr_int(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef void *(* func_t)(void *, void *, void *, void *, void *, int, void *, int); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); PMC * t_0; void * v_0; PMC * t_1; void * v_1; PMC * t_2; void * v_2; PMC * t_3; void * v_3; PMC * t_4; void * v_4; PMC * t_5; void * v_5; INTVAL t_6; int v_6; PMC * t_7; void * v_7; INTVAL t_8; int v_8; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PPPPPIPI", &t_1, &t_2, &t_3, &t_4, &t_5, &t_6, &t_7, &t_8); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = PMC_IS_NULL(t_2) ? NULL : VTABLE_get_pointer(interp, t_2);; v_3 = PMC_IS_NULL(t_3) ? NULL : VTABLE_get_pointer(interp, t_3);; v_4 = PMC_IS_NULL(t_4) ? NULL : VTABLE_get_pointer(interp, t_4);; v_5 = PMC_IS_NULL(t_5) ? NULL : VTABLE_get_pointer(interp, t_5);; v_6 = t_6; v_7 = PMC_IS_NULL(t_7) ? NULL : VTABLE_get_pointer(interp, t_7);; v_8 = t_8; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3, v_4, v_5, v_6, v_7, v_8); if (v_0 != NULL) { t_0 = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, t_0, v_0); } else { t_0 = PMCNULL; }; Parrot_pcc_set_call_from_c_args(interp, call_object, "P", t_0); } static void pcf_ptr_ptr_ptr_PMC(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef void *(* func_t)(void *, void *, PMC *); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); PMC * t_0; void * v_0; PMC * t_1; void * v_1; PMC * t_2; void * v_2; PMC * t_3; PMC * v_3; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PPP", &t_1, &t_2, &t_3); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = PMC_IS_NULL(t_2) ? NULL : VTABLE_get_pointer(interp, t_2);; v_3 = t_3; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3); if (v_0 != NULL) { t_0 = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, t_0, v_0); } else { t_0 = PMCNULL; }; Parrot_pcc_set_call_from_c_args(interp, call_object, "P", t_0); } static void pcf_ptr_ptr_ptr_int_ptr_ptr_ptr_int(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef void *(* func_t)(void *, void *, int, void *, void *, void *, int); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); PMC * t_0; void * v_0; PMC * t_1; void * v_1; PMC * t_2; void * v_2; INTVAL t_3; int v_3; PMC * t_4; void * v_4; PMC * t_5; void * v_5; PMC * t_6; void * v_6; INTVAL t_7; int v_7; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PPIPPPI", &t_1, &t_2, &t_3, &t_4, &t_5, &t_6, &t_7); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = PMC_IS_NULL(t_2) ? NULL : VTABLE_get_pointer(interp, t_2);; v_3 = t_3; v_4 = PMC_IS_NULL(t_4) ? NULL : VTABLE_get_pointer(interp, t_4);; v_5 = PMC_IS_NULL(t_5) ? NULL : VTABLE_get_pointer(interp, t_5);; v_6 = PMC_IS_NULL(t_6) ? NULL : VTABLE_get_pointer(interp, t_6);; v_7 = t_7; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3, v_4, v_5, v_6, v_7); if (v_0 != NULL) { t_0 = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, t_0, v_0); } else { t_0 = PMCNULL; }; Parrot_pcc_set_call_from_c_args(interp, call_object, "P", t_0); } static void pcf_ptr_ptr_ptr_int_ptr_ptr_ptr_ptr_int(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef void *(* func_t)(void *, void *, int, void *, void *, void *, void *, int); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); PMC * t_0; void * v_0; PMC * t_1; void * v_1; PMC * t_2; void * v_2; INTVAL t_3; int v_3; PMC * t_4; void * v_4; PMC * t_5; void * v_5; PMC * t_6; void * v_6; PMC * t_7; void * v_7; INTVAL t_8; int v_8; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PPIPPPPI", &t_1, &t_2, &t_3, &t_4, &t_5, &t_6, &t_7, &t_8); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = PMC_IS_NULL(t_2) ? NULL : VTABLE_get_pointer(interp, t_2);; v_3 = t_3; v_4 = PMC_IS_NULL(t_4) ? NULL : VTABLE_get_pointer(interp, t_4);; v_5 = PMC_IS_NULL(t_5) ? NULL : VTABLE_get_pointer(interp, t_5);; v_6 = PMC_IS_NULL(t_6) ? NULL : VTABLE_get_pointer(interp, t_6);; v_7 = PMC_IS_NULL(t_7) ? NULL : VTABLE_get_pointer(interp, t_7);; v_8 = t_8; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3, v_4, v_5, v_6, v_7, v_8); if (v_0 != NULL) { t_0 = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, t_0, v_0); } else { t_0 = PMCNULL; }; Parrot_pcc_set_call_from_c_args(interp, call_object, "P", t_0); } static void pcf_ptr_ptr_ptr_ptr_int_ptr(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef void *(* func_t)(void *, void *, void *, int, void *); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); PMC * t_0; void * v_0; PMC * t_1; void * v_1; PMC * t_2; void * v_2; PMC * t_3; void * v_3; INTVAL t_4; int v_4; PMC * t_5; void * v_5; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PPPIP", &t_1, &t_2, &t_3, &t_4, &t_5); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = PMC_IS_NULL(t_2) ? NULL : VTABLE_get_pointer(interp, t_2);; v_3 = PMC_IS_NULL(t_3) ? NULL : VTABLE_get_pointer(interp, t_3);; v_4 = t_4; v_5 = PMC_IS_NULL(t_5) ? NULL : VTABLE_get_pointer(interp, t_5);; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3, v_4, v_5); if (v_0 != NULL) { t_0 = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, t_0, v_0); } else { t_0 = PMCNULL; }; Parrot_pcc_set_call_from_c_args(interp, call_object, "P", t_0); } static void pcf_ptr_int_int_int_long(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef void *(* func_t)(int, int, int, long); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); PMC * t_0; void * v_0; INTVAL t_1; int v_1; INTVAL t_2; int v_2; INTVAL t_3; int v_3; INTVAL t_4; long v_4; Parrot_pcc_fill_params_from_c_args(interp, call_object, "IIII", &t_1, &t_2, &t_3, &t_4); v_1 = t_1; v_2 = t_2; v_3 = t_3; v_4 = t_4; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3, v_4); if (v_0 != NULL) { t_0 = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, t_0, v_0); } else { t_0 = PMCNULL; }; Parrot_pcc_set_call_from_c_args(interp, call_object, "P", t_0); } static void pcf_int_ptr_ptr_long(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(void *, void *, long); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; PMC * t_1; void * v_1; PMC * t_2; void * v_2; INTVAL t_3; long v_3; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PPI", &t_1, &t_2, &t_3); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = PMC_IS_NULL(t_2) ? NULL : VTABLE_get_pointer(interp, t_2);; v_3 = t_3; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_void_ptr_int_ptr(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef void(* func_t)(void *, int, void *); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); PMC * t_1; void * v_1; INTVAL t_2; int v_2; PMC * t_3; void * v_3; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PIP", &t_1, &t_2, &t_3); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = t_2; v_3 = PMC_IS_NULL(t_3) ? NULL : VTABLE_get_pointer(interp, t_3);; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); (*fn_pointer)(v_1, v_2, v_3); Parrot_pcc_set_call_from_c_args(interp, call_object, ""); } static void pcf_int_ptr_ptr_ptr(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(void *, void *, void *); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; PMC * t_1; void * v_1; PMC * t_2; void * v_2; PMC * t_3; void * v_3; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PPP", &t_1, &t_2, &t_3); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = PMC_IS_NULL(t_2) ? NULL : VTABLE_get_pointer(interp, t_2);; v_3 = PMC_IS_NULL(t_3) ? NULL : VTABLE_get_pointer(interp, t_3);; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_ptr_ptr_ptr_int_int(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef void *(* func_t)(void *, void *, int, int); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); PMC * t_0; void * v_0; PMC * t_1; void * v_1; PMC * t_2; void * v_2; INTVAL t_3; int v_3; INTVAL t_4; int v_4; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PPII", &t_1, &t_2, &t_3, &t_4); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = PMC_IS_NULL(t_2) ? NULL : VTABLE_get_pointer(interp, t_2);; v_3 = t_3; v_4 = t_4; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3, v_4); if (v_0 != NULL) { t_0 = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, t_0, v_0); } else { t_0 = PMCNULL; }; Parrot_pcc_set_call_from_c_args(interp, call_object, "P", t_0); } static void pcf_ptr_ptr_ptr_ptr(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef void *(* func_t)(void *, void *, void *); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); PMC * t_0; void * v_0; PMC * t_1; void * v_1; PMC * t_2; void * v_2; PMC * t_3; void * v_3; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PPP", &t_1, &t_2, &t_3); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = PMC_IS_NULL(t_2) ? NULL : VTABLE_get_pointer(interp, t_2);; v_3 = PMC_IS_NULL(t_3) ? NULL : VTABLE_get_pointer(interp, t_3);; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3); if (v_0 != NULL) { t_0 = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, t_0, v_0); } else { t_0 = PMCNULL; }; Parrot_pcc_set_call_from_c_args(interp, call_object, "P", t_0); } static void pcf_int_ptr_ptr_int_int_ptr_int(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(void *, void *, int, int, void *, int); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; PMC * t_1; void * v_1; PMC * t_2; void * v_2; INTVAL t_3; int v_3; INTVAL t_4; int v_4; PMC * t_5; void * v_5; INTVAL t_6; int v_6; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PPIIPI", &t_1, &t_2, &t_3, &t_4, &t_5, &t_6); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = PMC_IS_NULL(t_2) ? NULL : VTABLE_get_pointer(interp, t_2);; v_3 = t_3; v_4 = t_4; v_5 = PMC_IS_NULL(t_5) ? NULL : VTABLE_get_pointer(interp, t_5);; v_6 = t_6; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3, v_4, v_5, v_6); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_char(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef char(* func_t)(void); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; char v_0; Parrot_pcc_fill_params_from_c_args(interp, call_object, ""); ; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_char_ptr_int(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef char(* func_t)(void *, int); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; char v_0; PMC * t_1; void * v_1; INTVAL t_2; int v_2; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PI", &t_1, &t_2); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = t_2; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_double(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef double(* func_t)(void); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); FLOATVAL t_0; double v_0; Parrot_pcc_fill_params_from_c_args(interp, call_object, ""); ; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "N", t_0); } static void pcf_double_double(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef double(* func_t)(double); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); FLOATVAL t_0; double v_0; FLOATVAL t_1; double v_1; Parrot_pcc_fill_params_from_c_args(interp, call_object, "N", &t_1); v_1 = t_1; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "N", t_0); } static void pcf_float(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef float(* func_t)(void); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); FLOATVAL t_0; float v_0; Parrot_pcc_fill_params_from_c_args(interp, call_object, ""); ; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "N", t_0); } static void pcf_float_float_float(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef float(* func_t)(float, float); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); FLOATVAL t_0; float v_0; FLOATVAL t_1; float v_1; FLOATVAL t_2; float v_2; Parrot_pcc_fill_params_from_c_args(interp, call_object, "NN", &t_1, &t_2); v_1 = t_1; v_2 = t_2; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "N", t_0); } static void pcf_float_int_short(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef float(* func_t)(int, short); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); FLOATVAL t_0; float v_0; INTVAL t_1; int v_1; INTVAL t_2; short v_2; Parrot_pcc_fill_params_from_c_args(interp, call_object, "II", &t_1, &t_2); v_1 = t_1; v_2 = t_2; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "N", t_0); } static void pcf_int_double(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(double); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; FLOATVAL t_1; double v_1; Parrot_pcc_fill_params_from_c_args(interp, call_object, "N", &t_1); v_1 = t_1; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_int_int(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(int); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; INTVAL t_1; int v_1; Parrot_pcc_fill_params_from_c_args(interp, call_object, "I", &t_1); v_1 = t_1; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_int_int_int(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(int, int); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; INTVAL t_1; int v_1; INTVAL t_2; int v_2; Parrot_pcc_fill_params_from_c_args(interp, call_object, "II", &t_1, &t_2); v_1 = t_1; v_2 = t_2; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_int_int_int_int_int(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(int, int, int, int); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; INTVAL t_1; int v_1; INTVAL t_2; int v_2; INTVAL t_3; int v_3; INTVAL t_4; int v_4; Parrot_pcc_fill_params_from_c_args(interp, call_object, "IIII", &t_1, &t_2, &t_3, &t_4); v_1 = t_1; v_2 = t_2; v_3 = t_3; v_4 = t_4; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3, v_4); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_int_int_int_int_long_short_ptr(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(int, int, int, long, short, void *); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; INTVAL t_1; int v_1; INTVAL t_2; int v_2; INTVAL t_3; int v_3; INTVAL t_4; long v_4; INTVAL t_5; short v_5; PMC * t_6; void * v_6; Parrot_pcc_fill_params_from_c_args(interp, call_object, "IIIIIP", &t_1, &t_2, &t_3, &t_4, &t_5, &t_6); v_1 = t_1; v_2 = t_2; v_3 = t_3; v_4 = t_4; v_5 = t_5; v_6 = PMC_IS_NULL(t_6) ? NULL : VTABLE_get_pointer(interp, t_6);; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3, v_4, v_5, v_6); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_int_int_int_long(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(int, int, long); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; INTVAL t_1; int v_1; INTVAL t_2; int v_2; INTVAL t_3; long v_3; Parrot_pcc_fill_params_from_c_args(interp, call_object, "III", &t_1, &t_2, &t_3); v_1 = t_1; v_2 = t_2; v_3 = t_3; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_int_int_int_long_int(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(int, int, long, int); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; INTVAL t_1; int v_1; INTVAL t_2; int v_2; INTVAL t_3; long v_3; INTVAL t_4; int v_4; Parrot_pcc_fill_params_from_c_args(interp, call_object, "IIII", &t_1, &t_2, &t_3, &t_4); v_1 = t_1; v_2 = t_2; v_3 = t_3; v_4 = t_4; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3, v_4); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_int_int_int_ptr(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(int, int, void *); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; INTVAL t_1; int v_1; INTVAL t_2; int v_2; PMC * t_3; void * v_3; Parrot_pcc_fill_params_from_c_args(interp, call_object, "IIP", &t_1, &t_2, &t_3); v_1 = t_1; v_2 = t_2; v_3 = PMC_IS_NULL(t_3) ? NULL : VTABLE_get_pointer(interp, t_3);; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_int_int_int_ptr_int(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(int, int, void *, int); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; INTVAL t_1; int v_1; INTVAL t_2; int v_2; PMC * t_3; void * v_3; INTVAL t_4; int v_4; Parrot_pcc_fill_params_from_c_args(interp, call_object, "IIPI", &t_1, &t_2, &t_3, &t_4); v_1 = t_1; v_2 = t_2; v_3 = PMC_IS_NULL(t_3) ? NULL : VTABLE_get_pointer(interp, t_3);; v_4 = t_4; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3, v_4); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_int_int_long_short_ptr(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(int, long, short, void *); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; INTVAL t_1; int v_1; INTVAL t_2; long v_2; INTVAL t_3; short v_3; PMC * t_4; void * v_4; Parrot_pcc_fill_params_from_c_args(interp, call_object, "IIIP", &t_1, &t_2, &t_3, &t_4); v_1 = t_1; v_2 = t_2; v_3 = t_3; v_4 = PMC_IS_NULL(t_4) ? NULL : VTABLE_get_pointer(interp, t_4);; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3, v_4); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_int_long(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(long); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; INTVAL t_1; long v_1; Parrot_pcc_fill_params_from_c_args(interp, call_object, "I", &t_1); v_1 = t_1; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_int_long_int(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(long, int); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; INTVAL t_1; long v_1; INTVAL t_2; int v_2; Parrot_pcc_fill_params_from_c_args(interp, call_object, "II", &t_1, &t_2); v_1 = t_1; v_2 = t_2; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_int_long_ptr(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(long, void *); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; INTVAL t_1; long v_1; PMC * t_2; void * v_2; Parrot_pcc_fill_params_from_c_args(interp, call_object, "IP", &t_1, &t_2); v_1 = t_1; v_2 = PMC_IS_NULL(t_2) ? NULL : VTABLE_get_pointer(interp, t_2);; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_int_long_short_ptr(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(long, short, void *); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; INTVAL t_1; long v_1; INTVAL t_2; short v_2; PMC * t_3; void * v_3; Parrot_pcc_fill_params_from_c_args(interp, call_object, "IIP", &t_1, &t_2, &t_3); v_1 = t_1; v_2 = t_2; v_3 = PMC_IS_NULL(t_3) ? NULL : VTABLE_get_pointer(interp, t_3);; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_int_ptr_int_int(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(void *, int, int); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; PMC * t_1; void * v_1; INTVAL t_2; int v_2; INTVAL t_3; int v_3; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PII", &t_1, &t_2, &t_3); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = t_2; v_3 = t_3; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_int_ptr_int_int_int(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(void *, int, int, int); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; PMC * t_1; void * v_1; INTVAL t_2; int v_2; INTVAL t_3; int v_3; INTVAL t_4; int v_4; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PIII", &t_1, &t_2, &t_3, &t_4); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = t_2; v_3 = t_3; v_4 = t_4; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3, v_4); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_int_ptr_int_int_int_int_int_int(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(void *, int, int, int, int, int, int); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; PMC * t_1; void * v_1; INTVAL t_2; int v_2; INTVAL t_3; int v_3; INTVAL t_4; int v_4; INTVAL t_5; int v_5; INTVAL t_6; int v_6; INTVAL t_7; int v_7; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PIIIIII", &t_1, &t_2, &t_3, &t_4, &t_5, &t_6, &t_7); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = t_2; v_3 = t_3; v_4 = t_4; v_5 = t_5; v_6 = t_6; v_7 = t_7; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3, v_4, v_5, v_6, v_7); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_int_ptr_int_int_int_long_short_ptr(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(void *, int, int, int, long, short, void *); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; PMC * t_1; void * v_1; INTVAL t_2; int v_2; INTVAL t_3; int v_3; INTVAL t_4; int v_4; INTVAL t_5; long v_5; INTVAL t_6; short v_6; PMC * t_7; void * v_7; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PIIIIIP", &t_1, &t_2, &t_3, &t_4, &t_5, &t_6, &t_7); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = t_2; v_3 = t_3; v_4 = t_4; v_5 = t_5; v_6 = t_6; v_7 = PMC_IS_NULL(t_7) ? NULL : VTABLE_get_pointer(interp, t_7);; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3, v_4, v_5, v_6, v_7); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_int_ptr_int_int_long(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(void *, int, int, long); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; PMC * t_1; void * v_1; INTVAL t_2; int v_2; INTVAL t_3; int v_3; INTVAL t_4; long v_4; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PIII", &t_1, &t_2, &t_3, &t_4); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = t_2; v_3 = t_3; v_4 = t_4; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3, v_4); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_int_ptr_int_int_long_int(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(void *, int, int, long, int); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; PMC * t_1; void * v_1; INTVAL t_2; int v_2; INTVAL t_3; int v_3; INTVAL t_4; long v_4; INTVAL t_5; int v_5; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PIIII", &t_1, &t_2, &t_3, &t_4, &t_5); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = t_2; v_3 = t_3; v_4 = t_4; v_5 = t_5; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3, v_4, v_5); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_int_ptr_int_int_ptr(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(void *, int, int, void *); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; PMC * t_1; void * v_1; INTVAL t_2; int v_2; INTVAL t_3; int v_3; PMC * t_4; void * v_4; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PIIP", &t_1, &t_2, &t_3, &t_4); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = t_2; v_3 = t_3; v_4 = PMC_IS_NULL(t_4) ? NULL : VTABLE_get_pointer(interp, t_4);; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3, v_4); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_int_ptr_int_ptr_long(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(void *, int, void *, long); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; PMC * t_1; void * v_1; INTVAL t_2; int v_2; PMC * t_3; void * v_3; INTVAL t_4; long v_4; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PIPI", &t_1, &t_2, &t_3, &t_4); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = t_2; v_3 = PMC_IS_NULL(t_3) ? NULL : VTABLE_get_pointer(interp, t_3);; v_4 = t_4; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3, v_4); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_int_ptr_int_long_short_ptr(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(void *, int, long, short, void *); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; PMC * t_1; void * v_1; INTVAL t_2; int v_2; INTVAL t_3; long v_3; INTVAL t_4; short v_4; PMC * t_5; void * v_5; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PIIIP", &t_1, &t_2, &t_3, &t_4, &t_5); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = t_2; v_3 = t_3; v_4 = t_4; v_5 = PMC_IS_NULL(t_5) ? NULL : VTABLE_get_pointer(interp, t_5);; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3, v_4, v_5); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_int_ptr_int_int_ptr_int(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(void *, int, int, void *, int); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; PMC * t_1; void * v_1; INTVAL t_2; int v_2; INTVAL t_3; int v_3; PMC * t_4; void * v_4; INTVAL t_5; int v_5; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PIIPI", &t_1, &t_2, &t_3, &t_4, &t_5); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = t_2; v_3 = t_3; v_4 = PMC_IS_NULL(t_4) ? NULL : VTABLE_get_pointer(interp, t_4);; v_5 = t_5; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3, v_4, v_5); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_int_ptr_long_int(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(void *, long, int); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; PMC * t_1; void * v_1; INTVAL t_2; long v_2; INTVAL t_3; int v_3; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PII", &t_1, &t_2, &t_3); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = t_2; v_3 = t_3; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_int_ptr_long_long(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(void *, long, long); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; PMC * t_1; void * v_1; INTVAL t_2; long v_2; INTVAL t_3; long v_3; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PII", &t_1, &t_2, &t_3); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = t_2; v_3 = t_3; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_int_ptr_long_long_long_long_long_long_long_long(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(void *, long, long, long, long, long, long, long, long); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; PMC * t_1; void * v_1; INTVAL t_2; long v_2; INTVAL t_3; long v_3; INTVAL t_4; long v_4; INTVAL t_5; long v_5; INTVAL t_6; long v_6; INTVAL t_7; long v_7; INTVAL t_8; long v_8; INTVAL t_9; long v_9; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PIIIIIIII", &t_1, &t_2, &t_3, &t_4, &t_5, &t_6, &t_7, &t_8, &t_9); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = t_2; v_3 = t_3; v_4 = t_4; v_5 = t_5; v_6 = t_6; v_7 = t_7; v_8 = t_8; v_9 = t_9; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3, v_4, v_5, v_6, v_7, v_8, v_9); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_int_ptr_long_ptr(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(void *, long, void *); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; PMC * t_1; void * v_1; INTVAL t_2; long v_2; PMC * t_3; void * v_3; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PIP", &t_1, &t_2, &t_3); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = t_2; v_3 = PMC_IS_NULL(t_3) ? NULL : VTABLE_get_pointer(interp, t_3);; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_int_ptr_long_short_ptr(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(void *, long, short, void *); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; PMC * t_1; void * v_1; INTVAL t_2; long v_2; INTVAL t_3; short v_3; PMC * t_4; void * v_4; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PIIP", &t_1, &t_2, &t_3, &t_4); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = t_2; v_3 = t_3; v_4 = PMC_IS_NULL(t_4) ? NULL : VTABLE_get_pointer(interp, t_4);; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3, v_4); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_int_ptr_ptr(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(void *, void *); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; PMC * t_1; void * v_1; PMC * t_2; void * v_2; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PP", &t_1, &t_2); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = PMC_IS_NULL(t_2) ? NULL : VTABLE_get_pointer(interp, t_2);; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_int_ptr_ptr_int(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(void *, void *, int); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; PMC * t_1; void * v_1; PMC * t_2; void * v_2; INTVAL t_3; int v_3; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PPI", &t_1, &t_2, &t_3); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = PMC_IS_NULL(t_2) ? NULL : VTABLE_get_pointer(interp, t_2);; v_3 = t_3; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_int_ptr_ptr_int_int_int_int_int_int_int_int(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(void *, void *, int, int, int, int, int, int, int, int); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; PMC * t_1; void * v_1; PMC * t_2; void * v_2; INTVAL t_3; int v_3; INTVAL t_4; int v_4; INTVAL t_5; int v_5; INTVAL t_6; int v_6; INTVAL t_7; int v_7; INTVAL t_8; int v_8; INTVAL t_9; int v_9; INTVAL t_10; int v_10; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PPIIIIIIII", &t_1, &t_2, &t_3, &t_4, &t_5, &t_6, &t_7, &t_8, &t_9, &t_10); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = PMC_IS_NULL(t_2) ? NULL : VTABLE_get_pointer(interp, t_2);; v_3 = t_3; v_4 = t_4; v_5 = t_5; v_6 = t_6; v_7 = t_7; v_8 = t_8; v_9 = t_9; v_10 = t_10; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3, v_4, v_5, v_6, v_7, v_8, v_9, v_10); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_int_ptr_ptr_ptr_ptr(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(void *, void *, void *, void *); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; PMC * t_1; void * v_1; PMC * t_2; void * v_2; PMC * t_3; void * v_3; PMC * t_4; void * v_4; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PPPP", &t_1, &t_2, &t_3, &t_4); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = PMC_IS_NULL(t_2) ? NULL : VTABLE_get_pointer(interp, t_2);; v_3 = PMC_IS_NULL(t_3) ? NULL : VTABLE_get_pointer(interp, t_3);; v_4 = PMC_IS_NULL(t_4) ? NULL : VTABLE_get_pointer(interp, t_4);; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3, v_4); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_int_ptr_short_ptr(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(void *, short, void *); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; PMC * t_1; void * v_1; INTVAL t_2; short v_2; PMC * t_3; void * v_3; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PIP", &t_1, &t_2, &t_3); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = t_2; v_3 = PMC_IS_NULL(t_3) ? NULL : VTABLE_get_pointer(interp, t_3);; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_int_short(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(short); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; INTVAL t_1; short v_1; Parrot_pcc_fill_params_from_c_args(interp, call_object, "I", &t_1); v_1 = t_1; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_int_short_ptr(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(short, void *); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; INTVAL t_1; short v_1; PMC * t_2; void * v_2; Parrot_pcc_fill_params_from_c_args(interp, call_object, "IP", &t_1, &t_2); v_1 = t_1; v_2 = PMC_IS_NULL(t_2) ? NULL : VTABLE_get_pointer(interp, t_2);; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_int_short_short_short(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(short, short, short); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; INTVAL t_1; short v_1; INTVAL t_2; short v_2; INTVAL t_3; short v_3; Parrot_pcc_fill_params_from_c_args(interp, call_object, "III", &t_1, &t_2, &t_3); v_1 = t_1; v_2 = t_2; v_3 = t_3; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_int_short_short_short_short(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(short, short, short, short); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; INTVAL t_1; short v_1; INTVAL t_2; short v_2; INTVAL t_3; short v_3; INTVAL t_4; short v_4; Parrot_pcc_fill_params_from_c_args(interp, call_object, "IIII", &t_1, &t_2, &t_3, &t_4); v_1 = t_1; v_2 = t_2; v_3 = t_3; v_4 = t_4; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3, v_4); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_long_int_int(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef long(* func_t)(int, int); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; long v_0; INTVAL t_1; int v_1; INTVAL t_2; int v_2; Parrot_pcc_fill_params_from_c_args(interp, call_object, "II", &t_1, &t_2); v_1 = t_1; v_2 = t_2; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_long_ptr_int(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef long(* func_t)(void *, int); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; long v_0; PMC * t_1; void * v_1; INTVAL t_2; int v_2; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PI", &t_1, &t_2); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = t_2; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_long_ptr_int_int(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef long(* func_t)(void *, int, int); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; long v_0; PMC * t_1; void * v_1; INTVAL t_2; int v_2; INTVAL t_3; int v_3; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PII", &t_1, &t_2, &t_3); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = t_2; v_3 = t_3; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_ptr(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef void *(* func_t)(void); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); PMC * t_0; void * v_0; Parrot_pcc_fill_params_from_c_args(interp, call_object, ""); ; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(); if (v_0 != NULL) { t_0 = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, t_0, v_0); } else { t_0 = PMCNULL; }; Parrot_pcc_set_call_from_c_args(interp, call_object, "P", t_0); } static void pcf_ptr_int(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef void *(* func_t)(int); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); PMC * t_0; void * v_0; INTVAL t_1; int v_1; Parrot_pcc_fill_params_from_c_args(interp, call_object, "I", &t_1); v_1 = t_1; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1); if (v_0 != NULL) { t_0 = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, t_0, v_0); } else { t_0 = PMCNULL; }; Parrot_pcc_set_call_from_c_args(interp, call_object, "P", t_0); } static void pcf_ptr_int_int(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef void *(* func_t)(int, int); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); PMC * t_0; void * v_0; INTVAL t_1; int v_1; INTVAL t_2; int v_2; Parrot_pcc_fill_params_from_c_args(interp, call_object, "II", &t_1, &t_2); v_1 = t_1; v_2 = t_2; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2); if (v_0 != NULL) { t_0 = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, t_0, v_0); } else { t_0 = PMCNULL; }; Parrot_pcc_set_call_from_c_args(interp, call_object, "P", t_0); } static void pcf_ptr_int_int_int_int(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef void *(* func_t)(int, int, int, int); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); PMC * t_0; void * v_0; INTVAL t_1; int v_1; INTVAL t_2; int v_2; INTVAL t_3; int v_3; INTVAL t_4; int v_4; Parrot_pcc_fill_params_from_c_args(interp, call_object, "IIII", &t_1, &t_2, &t_3, &t_4); v_1 = t_1; v_2 = t_2; v_3 = t_3; v_4 = t_4; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3, v_4); if (v_0 != NULL) { t_0 = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, t_0, v_0); } else { t_0 = PMCNULL; }; Parrot_pcc_set_call_from_c_args(interp, call_object, "P", t_0); } static void pcf_ptr_int_int_int_int_int_int(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef void *(* func_t)(int, int, int, int, int, int); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); PMC * t_0; void * v_0; INTVAL t_1; int v_1; INTVAL t_2; int v_2; INTVAL t_3; int v_3; INTVAL t_4; int v_4; INTVAL t_5; int v_5; INTVAL t_6; int v_6; Parrot_pcc_fill_params_from_c_args(interp, call_object, "IIIIII", &t_1, &t_2, &t_3, &t_4, &t_5, &t_6); v_1 = t_1; v_2 = t_2; v_3 = t_3; v_4 = t_4; v_5 = t_5; v_6 = t_6; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3, v_4, v_5, v_6); if (v_0 != NULL) { t_0 = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, t_0, v_0); } else { t_0 = PMCNULL; }; Parrot_pcc_set_call_from_c_args(interp, call_object, "P", t_0); } static void pcf_ptr_int_int_int_int_int_int_int_int(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef void *(* func_t)(int, int, int, int, int, int, int, int); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); PMC * t_0; void * v_0; INTVAL t_1; int v_1; INTVAL t_2; int v_2; INTVAL t_3; int v_3; INTVAL t_4; int v_4; INTVAL t_5; int v_5; INTVAL t_6; int v_6; INTVAL t_7; int v_7; INTVAL t_8; int v_8; Parrot_pcc_fill_params_from_c_args(interp, call_object, "IIIIIIII", &t_1, &t_2, &t_3, &t_4, &t_5, &t_6, &t_7, &t_8); v_1 = t_1; v_2 = t_2; v_3 = t_3; v_4 = t_4; v_5 = t_5; v_6 = t_6; v_7 = t_7; v_8 = t_8; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3, v_4, v_5, v_6, v_7, v_8); if (v_0 != NULL) { t_0 = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, t_0, v_0); } else { t_0 = PMCNULL; }; Parrot_pcc_set_call_from_c_args(interp, call_object, "P", t_0); } static void pcf_ptr_ptr_int_int(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef void *(* func_t)(void *, int, int); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); PMC * t_0; void * v_0; PMC * t_1; void * v_1; INTVAL t_2; int v_2; INTVAL t_3; int v_3; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PII", &t_1, &t_2, &t_3); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = t_2; v_3 = t_3; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3); if (v_0 != NULL) { t_0 = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, t_0, v_0); } else { t_0 = PMCNULL; }; Parrot_pcc_set_call_from_c_args(interp, call_object, "P", t_0); } static void pcf_ptr_ptr_int_int_int_int(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef void *(* func_t)(void *, int, int, int, int); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); PMC * t_0; void * v_0; PMC * t_1; void * v_1; INTVAL t_2; int v_2; INTVAL t_3; int v_3; INTVAL t_4; int v_4; INTVAL t_5; int v_5; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PIIII", &t_1, &t_2, &t_3, &t_4, &t_5); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = t_2; v_3 = t_3; v_4 = t_4; v_5 = t_5; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3, v_4, v_5); if (v_0 != NULL) { t_0 = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, t_0, v_0); } else { t_0 = PMCNULL; }; Parrot_pcc_set_call_from_c_args(interp, call_object, "P", t_0); } static void pcf_ptr_ptr_ptr_ptr_ptr_ptr_ptr_ptr(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef void *(* func_t)(void *, void *, void *, void *, void *, void *, void *); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); PMC * t_0; void * v_0; PMC * t_1; void * v_1; PMC * t_2; void * v_2; PMC * t_3; void * v_3; PMC * t_4; void * v_4; PMC * t_5; void * v_5; PMC * t_6; void * v_6; PMC * t_7; void * v_7; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PPPPPPP", &t_1, &t_2, &t_3, &t_4, &t_5, &t_6, &t_7); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = PMC_IS_NULL(t_2) ? NULL : VTABLE_get_pointer(interp, t_2);; v_3 = PMC_IS_NULL(t_3) ? NULL : VTABLE_get_pointer(interp, t_3);; v_4 = PMC_IS_NULL(t_4) ? NULL : VTABLE_get_pointer(interp, t_4);; v_5 = PMC_IS_NULL(t_5) ? NULL : VTABLE_get_pointer(interp, t_5);; v_6 = PMC_IS_NULL(t_6) ? NULL : VTABLE_get_pointer(interp, t_6);; v_7 = PMC_IS_NULL(t_7) ? NULL : VTABLE_get_pointer(interp, t_7);; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3, v_4, v_5, v_6, v_7); if (v_0 != NULL) { t_0 = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, t_0, v_0); } else { t_0 = PMCNULL; }; Parrot_pcc_set_call_from_c_args(interp, call_object, "P", t_0); } static void pcf_short(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef short(* func_t)(void); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; short v_0; Parrot_pcc_fill_params_from_c_args(interp, call_object, ""); ; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_int_ptr_PMC(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(void *, PMC *); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; PMC * t_1; void * v_1; PMC * t_2; PMC * v_2; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PP", &t_1, &t_2); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = t_2; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_int_short_char(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(short, char); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; INTVAL t_1; short v_1; INTVAL t_2; char v_2; Parrot_pcc_fill_params_from_c_args(interp, call_object, "II", &t_1, &t_2); v_1 = t_1; v_2 = t_2; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_short_short_char(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef short(* func_t)(short, char); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; short v_0; INTVAL t_1; short v_1; INTVAL t_2; char v_2; Parrot_pcc_fill_params_from_c_args(interp, call_object, "II", &t_1, &t_2); v_1 = t_1; v_2 = t_2; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_char_short_char(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef char(* func_t)(short, char); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; char v_0; INTVAL t_1; short v_1; INTVAL t_2; char v_2; Parrot_pcc_fill_params_from_c_args(interp, call_object, "II", &t_1, &t_2); v_1 = t_1; v_2 = t_2; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_int_int_int_int(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(int, int, int); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; INTVAL t_1; int v_1; INTVAL t_2; int v_2; INTVAL t_3; int v_3; Parrot_pcc_fill_params_from_c_args(interp, call_object, "III", &t_1, &t_2, &t_3); v_1 = t_1; v_2 = t_2; v_3 = t_3; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_void_PMC(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef void(* func_t)(PMC *); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); PMC * t_1; PMC * v_1; Parrot_pcc_fill_params_from_c_args(interp, call_object, "P", &t_1); v_1 = t_1; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); (*fn_pointer)(v_1); Parrot_pcc_set_call_from_c_args(interp, call_object, ""); } static void pcf_void_ptr_PMC(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef void(* func_t)(void *, PMC *); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); PMC * t_1; void * v_1; PMC * t_2; PMC * v_2; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PP", &t_1, &t_2); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = t_2; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); (*fn_pointer)(v_1, v_2); Parrot_pcc_set_call_from_c_args(interp, call_object, ""); } static void pcf_ptr_int_ptr(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef void *(* func_t)(int, void *); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); PMC * t_0; void * v_0; INTVAL t_1; int v_1; PMC * t_2; void * v_2; Parrot_pcc_fill_params_from_c_args(interp, call_object, "IP", &t_1, &t_2); v_1 = t_1; v_2 = PMC_IS_NULL(t_2) ? NULL : VTABLE_get_pointer(interp, t_2);; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2); if (v_0 != NULL) { t_0 = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, t_0, v_0); } else { t_0 = PMCNULL; }; Parrot_pcc_set_call_from_c_args(interp, call_object, "P", t_0); } static void pcf_void_ptr_int_int(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef void(* func_t)(void *, int, int); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); PMC * t_1; void * v_1; INTVAL t_2; int v_2; INTVAL t_3; int v_3; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PII", &t_1, &t_2, &t_3); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = t_2; v_3 = t_3; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); (*fn_pointer)(v_1, v_2, v_3); Parrot_pcc_set_call_from_c_args(interp, call_object, ""); } static void pcf_ptr_ptr_ptr_int_int_int(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef void *(* func_t)(void *, void *, int, int, int); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); PMC * t_0; void * v_0; PMC * t_1; void * v_1; PMC * t_2; void * v_2; INTVAL t_3; int v_3; INTVAL t_4; int v_4; INTVAL t_5; int v_5; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PPIII", &t_1, &t_2, &t_3, &t_4, &t_5); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = PMC_IS_NULL(t_2) ? NULL : VTABLE_get_pointer(interp, t_2);; v_3 = t_3; v_4 = t_4; v_5 = t_5; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3, v_4, v_5); if (v_0 != NULL) { t_0 = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, t_0, v_0); } else { t_0 = PMCNULL; }; Parrot_pcc_set_call_from_c_args(interp, call_object, "P", t_0); } static void pcf_ptr_ptr_ptr_int_int_int_int_int_int_int(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef void *(* func_t)(void *, void *, int, int, int, int, int, int, int); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); PMC * t_0; void * v_0; PMC * t_1; void * v_1; PMC * t_2; void * v_2; INTVAL t_3; int v_3; INTVAL t_4; int v_4; INTVAL t_5; int v_5; INTVAL t_6; int v_6; INTVAL t_7; int v_7; INTVAL t_8; int v_8; INTVAL t_9; int v_9; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PPIIIIIII", &t_1, &t_2, &t_3, &t_4, &t_5, &t_6, &t_7, &t_8, &t_9); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = PMC_IS_NULL(t_2) ? NULL : VTABLE_get_pointer(interp, t_2);; v_3 = t_3; v_4 = t_4; v_5 = t_5; v_6 = t_6; v_7 = t_7; v_8 = t_8; v_9 = t_9; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3, v_4, v_5, v_6, v_7, v_8, v_9); if (v_0 != NULL) { t_0 = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, t_0, v_0); } else { t_0 = PMCNULL; }; Parrot_pcc_set_call_from_c_args(interp, call_object, "P", t_0); } static void pcf_int_ptr_ptr_int_int(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(void *, void *, int, int); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; PMC * t_1; void * v_1; PMC * t_2; void * v_2; INTVAL t_3; int v_3; INTVAL t_4; int v_4; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PPII", &t_1, &t_2, &t_3, &t_4); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = PMC_IS_NULL(t_2) ? NULL : VTABLE_get_pointer(interp, t_2);; v_3 = t_3; v_4 = t_4; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3, v_4); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_int_ptr_ptr_int_int_int(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(void *, void *, int, int, int); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; PMC * t_1; void * v_1; PMC * t_2; void * v_2; INTVAL t_3; int v_3; INTVAL t_4; int v_4; INTVAL t_5; int v_5; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PPIII", &t_1, &t_2, &t_3, &t_4, &t_5); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = PMC_IS_NULL(t_2) ? NULL : VTABLE_get_pointer(interp, t_2);; v_3 = t_3; v_4 = t_4; v_5 = t_5; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3, v_4, v_5); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_int_ptr_ptr_int_int_int_int(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(void *, void *, int, int, int, int); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; PMC * t_1; void * v_1; PMC * t_2; void * v_2; INTVAL t_3; int v_3; INTVAL t_4; int v_4; INTVAL t_5; int v_5; INTVAL t_6; int v_6; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PPIIII", &t_1, &t_2, &t_3, &t_4, &t_5, &t_6); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = PMC_IS_NULL(t_2) ? NULL : VTABLE_get_pointer(interp, t_2);; v_3 = t_3; v_4 = t_4; v_5 = t_5; v_6 = t_6; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3, v_4, v_5, v_6); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_int_ptr_ptr_int_int_int_int_int(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(void *, void *, int, int, int, int, int); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; PMC * t_1; void * v_1; PMC * t_2; void * v_2; INTVAL t_3; int v_3; INTVAL t_4; int v_4; INTVAL t_5; int v_5; INTVAL t_6; int v_6; INTVAL t_7; int v_7; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PPIIIII", &t_1, &t_2, &t_3, &t_4, &t_5, &t_6, &t_7); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = PMC_IS_NULL(t_2) ? NULL : VTABLE_get_pointer(interp, t_2);; v_3 = t_3; v_4 = t_4; v_5 = t_5; v_6 = t_6; v_7 = t_7; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3, v_4, v_5, v_6, v_7); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_int_ptr_ptr_int_int_int_int_int_int(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(void *, void *, int, int, int, int, int, int); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; PMC * t_1; void * v_1; PMC * t_2; void * v_2; INTVAL t_3; int v_3; INTVAL t_4; int v_4; INTVAL t_5; int v_5; INTVAL t_6; int v_6; INTVAL t_7; int v_7; INTVAL t_8; int v_8; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PPIIIIII", &t_1, &t_2, &t_3, &t_4, &t_5, &t_6, &t_7, &t_8); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = PMC_IS_NULL(t_2) ? NULL : VTABLE_get_pointer(interp, t_2);; v_3 = t_3; v_4 = t_4; v_5 = t_5; v_6 = t_6; v_7 = t_7; v_8 = t_8; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3, v_4, v_5, v_6, v_7, v_8); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_int_ptr_ptr_ptr_int(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(void *, void *, void *, int); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; PMC * t_1; void * v_1; PMC * t_2; void * v_2; PMC * t_3; void * v_3; INTVAL t_4; int v_4; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PPPI", &t_1, &t_2, &t_3, &t_4); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = PMC_IS_NULL(t_2) ? NULL : VTABLE_get_pointer(interp, t_2);; v_3 = PMC_IS_NULL(t_3) ? NULL : VTABLE_get_pointer(interp, t_3);; v_4 = t_4; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3, v_4); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_int_ptr_ptr_ptr_int_int(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(void *, void *, void *, int, int); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; PMC * t_1; void * v_1; PMC * t_2; void * v_2; PMC * t_3; void * v_3; INTVAL t_4; int v_4; INTVAL t_5; int v_5; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PPPII", &t_1, &t_2, &t_3, &t_4, &t_5); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = PMC_IS_NULL(t_2) ? NULL : VTABLE_get_pointer(interp, t_2);; v_3 = PMC_IS_NULL(t_3) ? NULL : VTABLE_get_pointer(interp, t_3);; v_4 = t_4; v_5 = t_5; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3, v_4, v_5); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_int_ptr_ptr_ptr_int_int_int_int(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(void *, void *, void *, int, int, int, int); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; PMC * t_1; void * v_1; PMC * t_2; void * v_2; PMC * t_3; void * v_3; INTVAL t_4; int v_4; INTVAL t_5; int v_5; INTVAL t_6; int v_6; INTVAL t_7; int v_7; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PPPIIII", &t_1, &t_2, &t_3, &t_4, &t_5, &t_6, &t_7); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = PMC_IS_NULL(t_2) ? NULL : VTABLE_get_pointer(interp, t_2);; v_3 = PMC_IS_NULL(t_3) ? NULL : VTABLE_get_pointer(interp, t_3);; v_4 = t_4; v_5 = t_5; v_6 = t_6; v_7 = t_7; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3, v_4, v_5, v_6, v_7); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_int_ptr_ptr_ptr_ptr_int_int_int_int_int_int(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(void *, void *, void *, void *, int, int, int, int, int, int); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; PMC * t_1; void * v_1; PMC * t_2; void * v_2; PMC * t_3; void * v_3; PMC * t_4; void * v_4; INTVAL t_5; int v_5; INTVAL t_6; int v_6; INTVAL t_7; int v_7; INTVAL t_8; int v_8; INTVAL t_9; int v_9; INTVAL t_10; int v_10; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PPPPIIIIII", &t_1, &t_2, &t_3, &t_4, &t_5, &t_6, &t_7, &t_8, &t_9, &t_10); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = PMC_IS_NULL(t_2) ? NULL : VTABLE_get_pointer(interp, t_2);; v_3 = PMC_IS_NULL(t_3) ? NULL : VTABLE_get_pointer(interp, t_3);; v_4 = PMC_IS_NULL(t_4) ? NULL : VTABLE_get_pointer(interp, t_4);; v_5 = t_5; v_6 = t_6; v_7 = t_7; v_8 = t_8; v_9 = t_9; v_10 = t_10; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3, v_4, v_5, v_6, v_7, v_8, v_9, v_10); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_void_float_float_float(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef void(* func_t)(float, float, float); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); FLOATVAL t_1; float v_1; FLOATVAL t_2; float v_2; FLOATVAL t_3; float v_3; Parrot_pcc_fill_params_from_c_args(interp, call_object, "NNN", &t_1, &t_2, &t_3); v_1 = t_1; v_2 = t_2; v_3 = t_3; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); (*fn_pointer)(v_1, v_2, v_3); Parrot_pcc_set_call_from_c_args(interp, call_object, ""); } static void pcf_int_ptr_int_double(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(void *, int, double); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; PMC * t_1; void * v_1; INTVAL t_2; int v_2; FLOATVAL t_3; double v_3; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PIN", &t_1, &t_2, &t_3); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = t_2; v_3 = t_3; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_int_ptr_int_ptr_int_int(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(void *, int, void *, int, int); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; PMC * t_1; void * v_1; INTVAL t_2; int v_2; PMC * t_3; void * v_3; INTVAL t_4; int v_4; INTVAL t_5; int v_5; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PIPII", &t_1, &t_2, &t_3, &t_4, &t_5); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = t_2; v_3 = PMC_IS_NULL(t_3) ? NULL : VTABLE_get_pointer(interp, t_3);; v_4 = t_4; v_5 = t_5; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3, v_4, v_5); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_ptr_ptr_STRING(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef void *(* func_t)(void *, STRING *); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); PMC * t_0; void * v_0; PMC * t_1; void * v_1; STRING * t_2; STRING * v_2; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PS", &t_1, &t_2); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = t_2; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2); if (v_0 != NULL) { t_0 = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, t_0, v_0); } else { t_0 = PMCNULL; }; Parrot_pcc_set_call_from_c_args(interp, call_object, "P", t_0); } static void pcf_ptr_ptr_int_ptrref_intref_ptr(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef void *(* func_t)(void *, int, void **, int*, void *); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); PMC * t_0; void * v_0; PMC * t_1; void * v_1; INTVAL t_2; int v_2; PMC * t_3; void * v_3; INTVAL t_4; int v_4; PMC * t_5; void * v_5; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PIPIP", &t_1, &t_2, &t_3, &t_4, &t_5); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = t_2; v_3 = PMC_IS_NULL(t_3) ? NULL : VTABLE_get_pointer(interp, t_3);; v_4 = t_4; v_5 = PMC_IS_NULL(t_5) ? NULL : VTABLE_get_pointer(interp, t_5);; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, &v_3, &v_4, v_5); if (v_0 != NULL) { t_0 = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, t_0, v_0); } else { t_0 = PMCNULL; }; if (v_3 != NULL) { t_3 = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, t_3, v_3); } else { t_3 = PMCNULL; }; t_4 = v_4; Parrot_pcc_set_call_from_c_args(interp, call_object, "PPI", t_0, t_3, t_4); } static void pcf_int_ptr_ptr_ptr_int_int_int_ptr_int(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef int(* func_t)(void *, void *, void *, int, int, int, void *, int); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; int v_0; PMC * t_1; void * v_1; PMC * t_2; void * v_2; PMC * t_3; void * v_3; INTVAL t_4; int v_4; INTVAL t_5; int v_5; INTVAL t_6; int v_6; PMC * t_7; void * v_7; INTVAL t_8; int v_8; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PPPIIIPI", &t_1, &t_2, &t_3, &t_4, &t_5, &t_6, &t_7, &t_8); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = PMC_IS_NULL(t_2) ? NULL : VTABLE_get_pointer(interp, t_2);; v_3 = PMC_IS_NULL(t_3) ? NULL : VTABLE_get_pointer(interp, t_3);; v_4 = t_4; v_5 = t_5; v_6 = t_6; v_7 = PMC_IS_NULL(t_7) ? NULL : VTABLE_get_pointer(interp, t_7);; v_8 = t_8; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3, v_4, v_5, v_6, v_7, v_8); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_PMC_ptr_STRING(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef PMC *(* func_t)(void *, STRING *); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); PMC * t_0; PMC * v_0; PMC * t_1; void * v_1; STRING * t_2; STRING * v_2; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PS", &t_1, &t_2); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = t_2; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "P", t_0); } static void pcf_INTVAL_ptr_STRING(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef INTVAL(* func_t)(void *, STRING *); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); INTVAL t_0; INTVAL v_0; PMC * t_1; void * v_1; STRING * t_2; STRING * v_2; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PS", &t_1, &t_2); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = t_2; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0); } static void pcf_STRING_ptr_INTVAL(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef STRING *(* func_t)(void *, INTVAL); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); STRING * t_0; STRING * v_0; PMC * t_1; void * v_1; INTVAL t_2; INTVAL v_2; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PI", &t_1, &t_2); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = t_2; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "S", t_0); } static void pcf_STRING_ptr_ptr_INTVAL(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef STRING *(* func_t)(void *, void *, INTVAL); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); STRING * t_0; STRING * v_0; PMC * t_1; void * v_1; PMC * t_2; void * v_2; INTVAL t_3; INTVAL v_3; Parrot_pcc_fill_params_from_c_args(interp, call_object, "PPI", &t_1, &t_2, &t_3); v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);; v_2 = PMC_IS_NULL(t_2) ? NULL : VTABLE_get_pointer(interp, t_2);; v_3 = t_3; GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(v_1, v_2, v_3); t_0 = v_0; Parrot_pcc_set_call_from_c_args(interp, call_object, "S", t_0); } static void pcf_ptr_void(PARROT_INTERP, PMC *nci, SHIM(PMC *self)) { typedef void *(* func_t)(void); func_t fn_pointer; void *orig_func; PMC * const ctx = CURRENT_CONTEXT(interp); PMC * const call_object = Parrot_pcc_get_signature(interp, ctx); PMC * t_0; void * v_0; Parrot_pcc_fill_params_from_c_args(interp, call_object, ""); GETATTR_NCI_orig_func(interp, nci, orig_func); fn_pointer = (func_t)D2FPTR(orig_func); v_0 = (*fn_pointer)(); if (v_0 != NULL) { t_0 = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, t_0, v_0); } else { t_0 = PMCNULL; }; Parrot_pcc_set_call_from_c_args(interp, call_object, "P", t_0); } void Parrot_nci_load_extra_thunks(PARROT_INTERP) { PMC * const iglobals = interp->iglobals; PMC *nci_funcs; PMC *temp_pmc; PARROT_ASSERT(!(PMC_IS_NULL(iglobals))); nci_funcs = VTABLE_get_pmc_keyed_int(interp, iglobals, IGLOBALS_NCI_FUNCS); PARROT_ASSERT(!(PMC_IS_NULL(nci_funcs))); { const int n = 3; static const int sig[] = { 7, 7, 29, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_int_ptr); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 2; static const int sig[] = { 7, 29, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_ptr); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 2; static const int sig[] = { 28, 29, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_void_ptr); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 4; static const int sig[] = { 28, 29, 29, 29, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_void_ptr_ptr_ptr); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 1; static const int sig[] = { 28, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_void); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 2; static const int sig[] = { 28, 7, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_void_int); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 3; static const int sig[] = { 28, 7, 7, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_void_int_int); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 10; static const int sig[] = { 28, 7, 8, 8, 8, 8, 8, 8, 8, 8, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_void_int_long_long_long_long_long_long_long_long); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 2; static const int sig[] = { 28, 8, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_void_long); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 3; static const int sig[] = { 28, 29, 7, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_void_ptr_int); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 6; static const int sig[] = { 28, 29, 7, 7, 7, 7, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_void_ptr_int_int_int_int); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 3; static const int sig[] = { 28, 29, 8, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_void_ptr_long); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 3; static const int sig[] = { 28, 29, 29, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_void_ptr_ptr); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 2; static const int sig[] = { 7, 4, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_PMC); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 4; static const int sig[] = { 7, 29, 29, 16, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_ptr_ptr_double); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 5; static const int sig[] = { 7, 29, 7, 29, 7, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_ptr_int_ptr_int); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 4; static const int sig[] = { 29, 29, 29, 7, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_ptr_ptr_ptr_int); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 5; static const int sig[] = { 29, 29, 29, 29, 7, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_ptr_ptr_ptr_ptr_int); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 6; static const int sig[] = { 29, 29, 29, 29, 29, 7, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_ptr_ptr_ptr_ptr_ptr_int); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 1; static const int sig[] = { 7, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 5; static const int sig[] = { 8, 8, 29, 29, 8, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_long_long_ptr_ptr_long); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 4; static const int sig[] = { 7, 29, 7, 29, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_ptr_int_ptr); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 4; static const int sig[] = { 7, 29, 7, 3, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_ptr_int_STRING); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 2; static const int sig[] = { 3, 7, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_STRING_int); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 2; static const int sig[] = { 8, 29, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_long_ptr); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 2; static const int sig[] = { 5, 29, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_char_ptr); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 5; static const int sig[] = { 5, 29, 29, 29, 29, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_char_ptr_ptr_ptr_ptr); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 3; static const int sig[] = { 29, 29, 7, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_ptr_ptr_int); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 2; static const int sig[] = { 29, 29, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_ptr_ptr); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 7; static const int sig[] = { 7, 29, 29, 29, 29, 29, 29, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_ptr_ptr_ptr_ptr_ptr_ptr); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 4; static const int sig[] = { 8, 29, 29, 8, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_long_ptr_ptr_long); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 5; static const int sig[] = { 8, 29, 29, 29, 8, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_long_ptr_ptr_ptr_long); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 3; static const int sig[] = { 7, 29, 7, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_ptr_int); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 3; static const int sig[] = { 7, 29, 8, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_ptr_long); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 1; static const int sig[] = { 8, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_long); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 3; static const int sig[] = { 29, 29, 29, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_ptr_ptr_ptr); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 9; static const int sig[] = { 29, 29, 29, 29, 29, 29, 7, 29, 7, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_ptr_ptr_ptr_ptr_ptr_ptr_int_ptr_int); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 4; static const int sig[] = { 29, 29, 29, 4, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_ptr_ptr_ptr_PMC); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 8; static const int sig[] = { 29, 29, 29, 7, 29, 29, 29, 7, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_ptr_ptr_ptr_int_ptr_ptr_ptr_int); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 9; static const int sig[] = { 29, 29, 29, 7, 29, 29, 29, 29, 7, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_ptr_ptr_ptr_int_ptr_ptr_ptr_ptr_int); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 6; static const int sig[] = { 29, 29, 29, 29, 7, 29, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_ptr_ptr_ptr_ptr_int_ptr); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 5; static const int sig[] = { 29, 7, 7, 7, 8, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_ptr_int_int_int_long); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 4; static const int sig[] = { 7, 29, 29, 8, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_ptr_ptr_long); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 4; static const int sig[] = { 28, 29, 7, 29, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_void_ptr_int_ptr); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 4; static const int sig[] = { 7, 29, 29, 29, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_ptr_ptr_ptr); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 5; static const int sig[] = { 29, 29, 29, 7, 7, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_ptr_ptr_ptr_int_int); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 4; static const int sig[] = { 29, 29, 29, 29, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_ptr_ptr_ptr_ptr); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 7; static const int sig[] = { 7, 29, 29, 7, 7, 29, 7, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_ptr_ptr_int_int_ptr_int); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 1; static const int sig[] = { 5, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_char); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 3; static const int sig[] = { 5, 29, 7, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_char_ptr_int); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 1; static const int sig[] = { 16, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_double); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 2; static const int sig[] = { 16, 16, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_double_double); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 1; static const int sig[] = { 15, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_float); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 3; static const int sig[] = { 15, 15, 15, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_float_float_float); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 3; static const int sig[] = { 15, 7, 6, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_float_int_short); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 2; static const int sig[] = { 7, 16, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_double); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 2; static const int sig[] = { 7, 7, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_int); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 3; static const int sig[] = { 7, 7, 7, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_int_int); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 5; static const int sig[] = { 7, 7, 7, 7, 7, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_int_int_int_int); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 7; static const int sig[] = { 7, 7, 7, 7, 8, 6, 29, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_int_int_int_long_short_ptr); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 4; static const int sig[] = { 7, 7, 7, 8, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_int_int_long); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 5; static const int sig[] = { 7, 7, 7, 8, 7, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_int_int_long_int); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 4; static const int sig[] = { 7, 7, 7, 29, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_int_int_ptr); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 5; static const int sig[] = { 7, 7, 7, 29, 7, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_int_int_ptr_int); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 5; static const int sig[] = { 7, 7, 8, 6, 29, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_int_long_short_ptr); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 2; static const int sig[] = { 7, 8, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_long); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 3; static const int sig[] = { 7, 8, 7, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_long_int); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 3; static const int sig[] = { 7, 8, 29, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_long_ptr); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 4; static const int sig[] = { 7, 8, 6, 29, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_long_short_ptr); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 4; static const int sig[] = { 7, 29, 7, 7, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_ptr_int_int); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 5; static const int sig[] = { 7, 29, 7, 7, 7, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_ptr_int_int_int); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 8; static const int sig[] = { 7, 29, 7, 7, 7, 7, 7, 7, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_ptr_int_int_int_int_int_int); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 8; static const int sig[] = { 7, 29, 7, 7, 7, 8, 6, 29, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_ptr_int_int_int_long_short_ptr); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 5; static const int sig[] = { 7, 29, 7, 7, 8, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_ptr_int_int_long); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 6; static const int sig[] = { 7, 29, 7, 7, 8, 7, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_ptr_int_int_long_int); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 5; static const int sig[] = { 7, 29, 7, 7, 29, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_ptr_int_int_ptr); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 5; static const int sig[] = { 7, 29, 7, 29, 8, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_ptr_int_ptr_long); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 6; static const int sig[] = { 7, 29, 7, 8, 6, 29, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_ptr_int_long_short_ptr); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 6; static const int sig[] = { 7, 29, 7, 7, 29, 7, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_ptr_int_int_ptr_int); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 4; static const int sig[] = { 7, 29, 8, 7, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_ptr_long_int); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 4; static const int sig[] = { 7, 29, 8, 8, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_ptr_long_long); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 10; static const int sig[] = { 7, 29, 8, 8, 8, 8, 8, 8, 8, 8, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_ptr_long_long_long_long_long_long_long_long); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 4; static const int sig[] = { 7, 29, 8, 29, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_ptr_long_ptr); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 5; static const int sig[] = { 7, 29, 8, 6, 29, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_ptr_long_short_ptr); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 3; static const int sig[] = { 7, 29, 29, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_ptr_ptr); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 4; static const int sig[] = { 7, 29, 29, 7, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_ptr_ptr_int); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 11; static const int sig[] = { 7, 29, 29, 7, 7, 7, 7, 7, 7, 7, 7, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_ptr_ptr_int_int_int_int_int_int_int_int); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 5; static const int sig[] = { 7, 29, 29, 29, 29, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_ptr_ptr_ptr_ptr); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 4; static const int sig[] = { 7, 29, 6, 29, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_ptr_short_ptr); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 2; static const int sig[] = { 7, 6, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_short); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 3; static const int sig[] = { 7, 6, 29, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_short_ptr); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 4; static const int sig[] = { 7, 6, 6, 6, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_short_short_short); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 5; static const int sig[] = { 7, 6, 6, 6, 6, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_short_short_short_short); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 3; static const int sig[] = { 8, 7, 7, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_long_int_int); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 3; static const int sig[] = { 8, 29, 7, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_long_ptr_int); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 4; static const int sig[] = { 8, 29, 7, 7, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_long_ptr_int_int); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 1; static const int sig[] = { 29, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_ptr); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 2; static const int sig[] = { 29, 7, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_ptr_int); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 3; static const int sig[] = { 29, 7, 7, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_ptr_int_int); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 5; static const int sig[] = { 29, 7, 7, 7, 7, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_ptr_int_int_int_int); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 7; static const int sig[] = { 29, 7, 7, 7, 7, 7, 7, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_ptr_int_int_int_int_int_int); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 9; static const int sig[] = { 29, 7, 7, 7, 7, 7, 7, 7, 7, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_ptr_int_int_int_int_int_int_int_int); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 4; static const int sig[] = { 29, 29, 7, 7, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_ptr_ptr_int_int); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 6; static const int sig[] = { 29, 29, 7, 7, 7, 7, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_ptr_ptr_int_int_int_int); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 8; static const int sig[] = { 29, 29, 29, 29, 29, 29, 29, 29, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_ptr_ptr_ptr_ptr_ptr_ptr_ptr_ptr); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 1; static const int sig[] = { 6, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_short); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 3; static const int sig[] = { 7, 29, 4, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_ptr_PMC); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 3; static const int sig[] = { 7, 6, 5, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_short_char); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 3; static const int sig[] = { 6, 6, 5, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_short_short_char); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 3; static const int sig[] = { 5, 6, 5, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_char_short_char); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 4; static const int sig[] = { 7, 7, 7, 7, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_int_int_int); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 2; static const int sig[] = { 28, 4, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_void_PMC); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 3; static const int sig[] = { 28, 29, 4, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_void_ptr_PMC); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 3; static const int sig[] = { 29, 7, 29, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_ptr_int_ptr); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 4; static const int sig[] = { 28, 29, 7, 7, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_void_ptr_int_int); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 6; static const int sig[] = { 29, 29, 29, 7, 7, 7, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_ptr_ptr_ptr_int_int_int); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 10; static const int sig[] = { 29, 29, 29, 7, 7, 7, 7, 7, 7, 7, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_ptr_ptr_ptr_int_int_int_int_int_int_int); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 5; static const int sig[] = { 7, 29, 29, 7, 7, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_ptr_ptr_int_int); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 6; static const int sig[] = { 7, 29, 29, 7, 7, 7, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_ptr_ptr_int_int_int); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 7; static const int sig[] = { 7, 29, 29, 7, 7, 7, 7, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_ptr_ptr_int_int_int_int); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 8; static const int sig[] = { 7, 29, 29, 7, 7, 7, 7, 7, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_ptr_ptr_int_int_int_int_int); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 9; static const int sig[] = { 7, 29, 29, 7, 7, 7, 7, 7, 7, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_ptr_ptr_int_int_int_int_int_int); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 5; static const int sig[] = { 7, 29, 29, 29, 7, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_ptr_ptr_ptr_int); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 6; static const int sig[] = { 7, 29, 29, 29, 7, 7, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_ptr_ptr_ptr_int_int); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 8; static const int sig[] = { 7, 29, 29, 29, 7, 7, 7, 7, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_ptr_ptr_ptr_int_int_int_int); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 11; static const int sig[] = { 7, 29, 29, 29, 29, 7, 7, 7, 7, 7, 7, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_ptr_ptr_ptr_ptr_int_int_int_int_int_int); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 4; static const int sig[] = { 28, 15, 15, 15, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_void_float_float_float); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 4; static const int sig[] = { 7, 29, 7, 16, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_ptr_int_double); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 6; static const int sig[] = { 7, 29, 7, 29, 7, 7, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_ptr_int_ptr_int_int); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 3; static const int sig[] = { 29, 29, 3, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_ptr_ptr_STRING); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 6; static const int sig[] = { 29, 29, 7, 93, 71, 29, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_ptr_ptr_int_ptrref_intref_ptr); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 9; static const int sig[] = { 7, 29, 29, 29, 7, 7, 7, 29, 7, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_int_ptr_ptr_ptr_int_int_int_ptr_int); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 3; static const int sig[] = { 4, 29, 3, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_PMC_ptr_STRING); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 3; static const int sig[] = { 1, 29, 3, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_INTVAL_ptr_STRING); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 3; static const int sig[] = { 3, 29, 1, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_STRING_ptr_INTVAL); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 4; static const int sig[] = { 3, 29, 29, 1, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_STRING_ptr_ptr_INTVAL); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } { const int n = 2; static const int sig[] = { 29, 28, }; PMC *sig_pmc = Parrot_pmc_new_init_int(interp, enum_class_FixedIntegerArray, n); int i; for (i = 0; i < n; i++) VTABLE_set_integer_keyed_int(interp, sig_pmc, i, sig[i]); temp_pmc = Parrot_pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, temp_pmc, (void *)pcf_ptr_void); VTABLE_set_pmc_keyed(interp, nci_funcs, sig_pmc, temp_pmc); } } /* * Local variables: * c-file-style: "parrot" * End: * vim: expandtab shiftwidth=4 cinoptions='\:2=2' : */ api.c000644000765000765 24637312233541455 14563 0ustar00bruce000000000000parrot-6.6.0/src/string/* Copyright (C) 2001-2012, Parrot Foundation. =head1 NAME src/string/api.c - Parrot Strings =head1 DESCRIPTION This file implements the non-ICU parts of the Parrot string subsystem. Note that C and C are used by the memory subsystem. The string functions may only use C to determine if there is some space left beyond C. This is the I valid usage of these two data members, beside setting C/C for external strings. =head2 Functions =over 4 =cut */ #include #include "parrot/parrot.h" #include "parrot/events.h" #include "private_cstring.h" #include "api.str" /* for parrot/interpreter.h */ STRING *STRINGNULL; #define nonnull_encoding_name(s) (s) ? (s)->encoding->name : "null string" #define ASSERT_STRING_SANITY(s) \ PARROT_ASSERT((s)->encoding); \ PARROT_ASSERT(!PObj_on_free_list_TEST(s)) /* HEADERIZER HFILE: include/parrot/string_funcs.h */ /* HEADERIZER BEGIN: static */ /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */ PARROT_WARN_UNUSED_RESULT PARROT_PURE_FUNCTION static INTVAL string_max_bytes(PARROT_INTERP, ARGIN(const STRING *s), UINTVAL nchars) __attribute__nonnull__(2); PARROT_INLINE PARROT_IGNORABLE_RESULT PARROT_CAN_RETURN_NULL PARROT_PURE_FUNCTION static const STR_VTABLE * string_rep_compatible( ARGIN(const STRING *a), ARGIN(const STRING *b)) __attribute__nonnull__(1) __attribute__nonnull__(2); PARROT_DOES_NOT_RETURN PARROT_COLD static void throw_illegal_escape(PARROT_INTERP) __attribute__nonnull__(1); #define ASSERT_ARGS_string_max_bytes __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(s)) #define ASSERT_ARGS_string_rep_compatible __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(a) \ , PARROT_ASSERT_ARG(b)) #define ASSERT_ARGS_throw_illegal_escape __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp)) /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */ /* HEADERIZER END: static */ /* Buffer size for hexadecimal conversions: Expected at most 8 characters plus room for some prefixes and suffixes. */ #define HEX_BUF_SIZE 16 /* =item C Tests if the given STRING is STRINGNULL. =cut */ PARROT_EXPORT PARROT_HOT PARROT_PURE_FUNCTION INTVAL Parrot_str_is_null(SHIM_INTERP, ARGIN_NULLOK(const STRING *s)) { ASSERT_ARGS(Parrot_str_is_null) return STRING_IS_NULL(s); } /* =back =head2 Basic String Functions Creation, enlargement, etc. =over 4 =item C Initializes the Parrot string subsystem. =cut */ PARROT_EXPORT void Parrot_str_init(PARROT_INTERP) { ASSERT_ARGS(Parrot_str_init) Hash *const_cstring_hash; size_t i; const size_t n_parrot_cstrings = sizeof (parrot_cstrings) / sizeof (parrot_cstrings[0]); if (interp->parent_interpreter) interp->hash_seed = interp->parent_interpreter->hash_seed; /* interp is initialized from zeroed memory, so this is fine */ else if (interp->hash_seed == 0) { interp->hash_seed = Parrot_get_entropy(interp); } /* initialize the constant string table */ if (interp->parent_interpreter) { interp->const_cstring_table = interp->parent_interpreter->const_cstring_table; interp->const_cstring_hash = interp->parent_interpreter->const_cstring_hash; return; } /* Set up the cstring cache, then load the basic encodings */ const_cstring_hash = Parrot_hash_create_sized(interp, enum_type_PMC, Hash_key_type_cstring, n_parrot_cstrings); interp->const_cstring_hash = const_cstring_hash; Parrot_encodings_init(interp); /* initialize STRINGNULL, but not in the constant table */ STRINGNULL = Parrot_str_new_init(interp, NULL, 0, Parrot_null_encoding_ptr, PObj_constant_FLAG); interp->const_cstring_table = mem_gc_allocate_n_zeroed_typed(interp, n_parrot_cstrings, STRING *); PARROT_ASSERT(interp->const_cstring_table != NULL); for (i = 0; i < n_parrot_cstrings; ++i) { DECL_CONST_CAST; STRING * const s = Parrot_str_new_init(interp, parrot_cstrings[i].string, parrot_cstrings[i].len, Parrot_default_encoding_ptr, PObj_external_FLAG|PObj_constant_FLAG); Parrot_hash_put(interp, const_cstring_hash, PARROT_const_cast(char *, parrot_cstrings[i].string), (void *)s); interp->const_cstring_table[i] = s; } } /* =item C De-Initializes the Parrot string subsystem. =cut */ PARROT_EXPORT void Parrot_str_finish(PARROT_INTERP) { ASSERT_ARGS(Parrot_str_finish) /* all are shared between interpreters */ if (!interp->parent_interpreter) { mem_internal_free(interp->const_cstring_table); interp->const_cstring_table = NULL; Parrot_deinit_encodings(interp); Parrot_hash_destroy(interp, interp->const_cstring_hash); } } /* =item C Creates and returns an empty Parrot string. =cut */ PARROT_EXPORT PARROT_CANNOT_RETURN_NULL STRING * Parrot_str_new_noinit(PARROT_INTERP, UINTVAL capacity) { ASSERT_ARGS(Parrot_str_new_noinit) STRING * const s = Parrot_gc_new_string_header(interp, 0); s->encoding = Parrot_default_encoding_ptr; Parrot_gc_allocate_string_storage(interp, s, (size_t)string_max_bytes(interp, s, capacity)); return s; } /* =item C Find the "lowest" possible encoding for the given string. E.g. ascii utf8 => utf8 => ascii, B C has ascii chars only. Returns NULL, if no compatible string representation can be found. =cut */ PARROT_INLINE PARROT_IGNORABLE_RESULT PARROT_CAN_RETURN_NULL PARROT_PURE_FUNCTION static const STR_VTABLE * string_rep_compatible(ARGIN(const STRING *a), ARGIN(const STRING *b)) { ASSERT_ARGS(string_rep_compatible) PARROT_ASSERT(a->encoding && b->encoding); if (a->encoding == b->encoding) return a->encoding; /* a table could possibly simplify the logic */ if (STRING_max_bytes_per_codepoint(a) == 1 && STRING_max_bytes_per_codepoint(b) == 1) { /* Return the "largest" encoding where ascii < latin1 < binary */ if (b->encoding == Parrot_ascii_encoding_ptr) return a->encoding; if (a->encoding == Parrot_ascii_encoding_ptr) return b->encoding; if (a->encoding == Parrot_binary_encoding_ptr) return a->encoding; if (b->encoding == Parrot_binary_encoding_ptr) return b->encoding; } else { /* UTF-8 strings are ASCII compatible if their byte length equals their codepoint length. This is a nice trick but it can cause many surprises when UTF-8 strings are suddenly "downgraded" to ASCII strings. */ if (a->encoding == Parrot_utf8_encoding_ptr && b->encoding == Parrot_ascii_encoding_ptr) { if (a->strlen == a->bufused) { return b->encoding; } return a->encoding; } if (b->encoding == Parrot_utf8_encoding_ptr && a->encoding == Parrot_ascii_encoding_ptr) { if (b->strlen == b->bufused) { return a->encoding; } return b->encoding; } } return NULL; } /* =item C Find the "lowest" possible encoding for the given string. E.g. ascii utf8 => utf8 => ascii, B C has ascii chars only. Returns NULL, if no compatible string representation can be found. =cut */ PARROT_EXPORT PARROT_IGNORABLE_RESULT PARROT_CAN_RETURN_NULL PARROT_PURE_FUNCTION const STR_VTABLE * Parrot_str_rep_compatible(SHIM_INTERP, ARGIN(const STRING *a), ARGIN(const STRING *b)) { ASSERT_ARGS(Parrot_str_rep_compatible) return string_rep_compatible(a, b); } /* =item C Helper function to clone string. =cut */ PARROT_WARN_UNUSED_RESULT PARROT_CANNOT_RETURN_NULL STRING * Parrot_str_clone(PARROT_INTERP, ARGIN_NULLOK(const STRING *s)) { ASSERT_ARGS(Parrot_str_clone) size_t alloc_size; STRING *result; if (STRING_IS_NULL(s)) return STRINGNULL; result = Parrot_gc_new_string_header(interp, 0); alloc_size = s->bufused; if (alloc_size) { /* Allocate new chunk of memory */ Parrot_gc_allocate_string_storage(interp, result, alloc_size); /* and copy it over */ memcpy(result->strstart, s->strstart, alloc_size); } result->bufused = alloc_size; result->strlen = s->strlen; result->hashval = s->hashval; result->encoding = s->encoding; return result; } /* =item C Creates and returns a shallow copy of the specified Parrot string. =cut */ PARROT_EXPORT PARROT_CANNOT_RETURN_NULL PARROT_WARN_UNUSED_RESULT STRING * Parrot_str_copy(PARROT_INTERP, ARGIN_NULLOK(const STRING *s)) { ASSERT_ARGS(Parrot_str_copy) STRING *d; int is_movable; if (STRING_IS_NULL(s)) return STRINGNULL; d = Parrot_gc_new_string_header(interp, PObj_get_FLAGS(s) & ~PObj_constant_FLAG); /* This might set the constant flag again but it is the right thing * to do */ STRUCT_COPY(d, s); /* * FIXME. It's abstraction leak here from GC. * Basically if we are copying string from older generation * we have to clear flags about it. */ d->flags &= ~PObj_GC_all_generation_FLAGS; /* Clear live flag. It might be set on constant strings */ PObj_live_CLEAR(d); /* Set the string copy flag */ PObj_is_string_copy_SET(d); is_movable = PObj_is_movable_TESTALL(s); /* Now check that buffer allocated from pool and affected by compacting */ if (is_movable && Buffer_bufstart(s)) { /* If so, mark it as shared */ INTVAL * const buffer_flags = Buffer_bufflagsptr(d); *buffer_flags |= Buffer_shared_FLAG; } PARROT_ASSERT(is_movable == PObj_is_movable_TESTALL(d)); return d; } /* =item C Concatenates two Parrot strings. If necessary, converts the second string's encoding and/or type to match those of the first string. If either string is C, then a copy of the non-C string is returned. If both strings are C, return C. =cut */ PARROT_EXPORT PARROT_CANNOT_RETURN_NULL STRING * Parrot_str_concat(PARROT_INTERP, ARGIN_NULLOK(const STRING *a), ARGIN_NULLOK(const STRING *b)) { ASSERT_ARGS(Parrot_str_concat) const STR_VTABLE *enc; STRING *dest; UINTVAL total_length; if (STRING_IS_NULL(a) && STRING_IS_NULL(b)) return STRINGNULL; if (STRING_length(a) == 0) { if (STRING_length(b) == 0) return CONST_STRING(interp, ""); else return Parrot_str_copy(interp, b); } else { if (STRING_length(b) == 0) return Parrot_str_copy(interp, a); } ASSERT_STRING_SANITY(a); ASSERT_STRING_SANITY(b); enc = string_rep_compatible(a, b); if (!enc) { /* upgrade strings for concatenation */ if (a->encoding == Parrot_ucs4_encoding_ptr || b->encoding == Parrot_ucs4_encoding_ptr) enc = Parrot_ucs4_encoding_ptr; else if (a->encoding == Parrot_utf16_encoding_ptr || b->encoding == Parrot_utf16_encoding_ptr || a->encoding == Parrot_ucs2_encoding_ptr || b->encoding == Parrot_ucs2_encoding_ptr) enc = Parrot_utf16_encoding_ptr; else enc = Parrot_utf8_encoding_ptr; a = enc->to_encoding(interp, a); b = enc->to_encoding(interp, b); } /* calc usable and total bytes */ total_length = a->bufused + b->bufused; if (PObj_is_growable_TESTALL(a) && a->strstart + total_length <= (char *)Buffer_bufstart(a) + Buffer_buflen(a)) { /* String a is growable and there's enough space in the buffer */ DECL_CONST_CAST; dest = Parrot_str_copy(interp, a); /* Switch string copy flags */ PObj_is_string_copy_SET(PARROT_const_cast(STRING *, a)); PObj_is_string_copy_CLEAR(dest); /* Append b */ memcpy(dest->strstart + dest->bufused, b->strstart, b->bufused); dest->encoding = enc; dest->hashval = 0; } else { if (4 * b->bufused < a->bufused) { /* Preallocate more memory if we're appending a short string to a long string */ total_length += total_length >> 1; } dest = Parrot_str_new_noinit(interp, total_length); PARROT_ASSERT(enc); dest->encoding = enc; /* Copy A first */ memcpy(dest->strstart, a->strstart, a->bufused); /* Tack B on the end of A */ memcpy(dest->strstart + a->bufused, b->strstart, b->bufused); } dest->bufused = a->bufused + b->bufused; dest->strlen = a->strlen + b->strlen; return dest; } /* =item C Makes a Parrot string from a specified C string. =cut */ PARROT_EXPORT PARROT_WARN_UNUSED_RESULT PARROT_MALLOC PARROT_CANNOT_RETURN_NULL STRING * Parrot_str_new(PARROT_INTERP, ARGIN_NULLOK(const char *buffer), const UINTVAL len) { ASSERT_ARGS(Parrot_str_new) /* Force an 8-bit encoding at some point? */ const UINTVAL buff_length = (len > 0) ? len : buffer ? strlen(buffer) : 0; return Parrot_str_new_init(interp, buffer, buff_length, Parrot_default_encoding_ptr, 0); } /* =item C Makes a Parrot string from a Buffer. The Buffer is nulled afterwards, as only one PObj can point at a given string pool object. =cut */ PARROT_EXPORT PARROT_WARN_UNUSED_RESULT PARROT_MALLOC PARROT_CANNOT_RETURN_NULL STRING * Parrot_str_new_from_buffer(PARROT_INTERP, ARGMOD(Parrot_Buffer *buffer), const UINTVAL len) { ASSERT_ARGS(Parrot_str_new_from_buffer) STRING * const result = Parrot_gc_new_string_header(interp, 0); Buffer_bufstart(result) = Buffer_bufstart(buffer); Buffer_buflen(result) = Buffer_buflen(buffer); result->strstart = (char *)Buffer_bufstart(result); result->bufused = len; result->strlen = len; result->encoding = Parrot_binary_encoding_ptr; Buffer_buflen(buffer) = 0; Buffer_bufstart(buffer) = NULL; return result; } /* =item C Creates and returns a constant Parrot string. =cut */ PARROT_EXPORT PARROT_WARN_UNUSED_RESULT PARROT_CANNOT_RETURN_NULL STRING * Parrot_str_new_constant(PARROT_INTERP, ARGIN(const char *buffer)) { ASSERT_ARGS(Parrot_str_new_constant) DECL_CONST_CAST; Hash * const cstring_cache = interp->const_cstring_hash; STRING *s = (STRING *)Parrot_hash_get(interp, cstring_cache, buffer); if (s) return s; s = Parrot_str_new_init(interp, buffer, strlen(buffer), Parrot_default_encoding_ptr, PObj_external_FLAG|PObj_constant_FLAG); Parrot_hash_put(interp, cstring_cache, PARROT_const_cast(char *, buffer), (void *)s); return s; } /* =item C Given a buffer, its length, an encoding, and STRING flags, creates and returns a new string. If buffer is NULL and len >= 0, allocates len bytes. =cut */ PARROT_EXPORT PARROT_WARN_UNUSED_RESULT PARROT_CANNOT_RETURN_NULL STRING * Parrot_str_new_init(PARROT_INTERP, ARGIN_NULLOK(const char *buffer), UINTVAL len, ARGIN(const STR_VTABLE *encoding), UINTVAL flags) { ASSERT_ARGS(Parrot_str_new_init) DECL_CONST_CAST; STRING * const s = Parrot_gc_new_string_header(interp, flags); s->encoding = encoding; if (flags & PObj_external_FLAG) { /* * fast path for external (constant) strings - don't allocate * and copy data */ /* The following cast discards the 'const'. That raises a warning with gcc, but is ok since the caller indicated it was safe by setting PObj_external_FLAG. (The cast is necessary to pacify TenDRA's tcc.) */ Buffer_bufstart(s) = s->strstart = PARROT_const_cast(char *, buffer); Buffer_buflen(s) = s->bufused = len; STRING_scan(interp, s); return s; } Parrot_gc_allocate_string_storage(interp, s, len); if (buffer && len) { memcpy(s->strstart, buffer, len); s->bufused = len; STRING_scan(interp, s); } else s->strlen = s->bufused = 0; return s; } /* =item C Given a buffer and an encoding, creates and returns a new string. If buffer is NULL the result is a null string. Otherwise, the buffer should be a zero terminated c-style string and its content must be valid for the encoding specified. If encoding is null, assume platform encoding. =cut */ PARROT_WARN_UNUSED_RESULT PARROT_CANNOT_RETURN_NULL STRING * Parrot_str_new_from_cstring(PARROT_INTERP, ARGIN_NULLOK(const char *buffer), ARGIN_NULLOK(STRING *encodingname)) { ASSERT_ARGS(Parrot_str_new_from_cstring) STRING *result = STRINGNULL; if (buffer) { const STR_VTABLE *encoding = STRING_IS_NULL(encodingname) ? Parrot_platform_encoding_ptr : Parrot_find_encoding_by_string(interp, encodingname); if (encoding == NULL) Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_ENCODING, "Invalid encoding"); else { int size = strlen(buffer); result = Parrot_str_new_init(interp, buffer, size, encoding, 0); } } return result; } /* =item C Convert a C string, encoded in the platform's assumed encoding, to a Parrot string. =cut */ PARROT_EXPORT PARROT_CANNOT_RETURN_NULL STRING * Parrot_str_from_platform_cstring(PARROT_INTERP, ARGIN_NULLOK(const char *c)) { ASSERT_ARGS(Parrot_str_from_platform_cstring) if (!c) return STRINGNULL; else { STRING *retv; Parrot_runloop jmp; if (setjmp(jmp.resume)) { /* catch */ Parrot_cx_delete_handler_local(interp); retv = Parrot_str_new_init(interp, c, strlen(c), Parrot_binary_encoding_ptr, 0); } else { /* try */ Parrot_ex_add_c_handler(interp, &jmp); retv = Parrot_str_new_init(interp, c, Parrot_str_platform_strlen(interp, c), Parrot_platform_encoding_ptr, 0); Parrot_cx_delete_handler_local(interp); } return retv; } } /* =item C Obtain a C string, encoded in the platform's assumed encoding, from a Parrot string. =cut */ PARROT_EXPORT PARROT_CAN_RETURN_NULL PARROT_WARN_UNUSED_RESULT char * Parrot_str_to_platform_cstring(PARROT_INTERP, ARGIN(const STRING *s)) { ASSERT_ARGS(Parrot_str_to_platform_cstring) if (STRING_IS_NULL(s)) { return NULL; } else { return Parrot_str_to_encoded_cstring(interp, s, Parrot_platform_encoding_ptr); } } /* =item C Extracts C characters from C containing C bytes. =cut */ PARROT_WARN_UNUSED_RESULT PARROT_CANNOT_RETURN_NULL STRING * Parrot_str_extract_chars(PARROT_INTERP, ARGIN(const char *buffer), UINTVAL len, INTVAL chars, ARGIN(const STR_VTABLE *encoding)) { ASSERT_ARGS(Parrot_str_extract_chars) Parrot_String_Bounds bounds; STRING *result; bounds.bytes = len; bounds.chars = chars; bounds.delim = -1; encoding->partial_scan(interp, buffer, &bounds); if (bounds.chars < chars) Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_OUT_OF_BOUNDS, "extract_chars: index out of bounds"); result = Parrot_str_new_noinit(interp, bounds.bytes); result->encoding = encoding; result->bufused = bounds.bytes; result->strlen = bounds.chars; memcpy(result->strstart, buffer, bounds.bytes); return result; } /* =back =head2 Ordinary user-visible string operations =over 4 =item C Returns the number of characters in the specified Parrot string. =cut */ PARROT_EXPORT PARROT_PURE_FUNCTION UINTVAL Parrot_str_byte_length(SHIM_INTERP, ARGIN_NULLOK(const STRING *s)) { ASSERT_ARGS(Parrot_str_byte_length) return STRING_IS_NULL(s) ? 0 : s->bufused; } /* =item C Returns the codepoint at a given index into a string. Negative indexes are treated as counting from the end of the string. Throws an exception if C is null or C is out of bounds. Identical to the STRING_ord macro. =cut */ PARROT_EXPORT PARROT_WARN_UNUSED_RESULT INTVAL Parrot_str_indexed(PARROT_INTERP, ARGIN(const STRING *s), INTVAL idx) { ASSERT_ARGS(Parrot_str_indexed) if (s == NULL) s = STRINGNULL; return STRING_ord(interp, s, idx); } /* =item C Returns the character position of the second Parrot string in the first at or after C. The return value is a (0 based) offset in characters, not bytes. If the search string is not found in the first string or it is null or empty, returns -1. If C is out of bounds, returns -1. Throws an exception if C is null. Identical to the STRING_index macro. =item C Returns the last character position of the second Parrot string C in C, not after C. Returns the last position found, or -1 if no instances are found. Mostly identical to the STRING_rindex macro. =cut */ PARROT_EXPORT PARROT_WARN_UNUSED_RESULT INTVAL Parrot_str_find_index(PARROT_INTERP, ARGIN(const STRING *src), ARGIN(const STRING *search), INTVAL start) { ASSERT_ARGS(Parrot_str_find_index) if (src == NULL) src = STRINGNULL; return STRING_index(interp, src, search, start); } PARROT_EXPORT PARROT_WARN_UNUSED_RESULT INTVAL Parrot_str_find_reverse_index(PARROT_INTERP, ARGIN(const STRING *src), ARGIN(const STRING *search), INTVAL start) { ASSERT_ARGS(Parrot_str_find_reverse_index) INTVAL len = Parrot_str_length(interp, src); if (start <= 0 || !len || start > len) return -1; if (!Parrot_str_length(interp, search)) return -1; return STRING_rindex(interp, src, search, (UINTVAL)start); } /* =item C Returns a single-character Parrot string. =cut */ PARROT_EXPORT PARROT_CANNOT_RETURN_NULL PARROT_WARN_UNUSED_RESULT STRING * Parrot_str_chr(PARROT_INTERP, UINTVAL character) { ASSERT_ARGS(Parrot_str_chr) if (character > 0xff) return Parrot_utf8_encoding_ptr->chr(interp, character); else if (character > 0x7f) return Parrot_latin1_encoding_ptr->chr(interp, character); else return Parrot_ascii_encoding_ptr->chr(interp, character); } /* =back =head2 Vtable Dispatch Functions =over 4 =item C Returns the number of characters in the specified Parrot string. =cut */ PARROT_EXPORT PARROT_PURE_FUNCTION PARROT_WARN_UNUSED_RESULT INTVAL Parrot_str_length(SHIM_INTERP, ARGIN_NULLOK(const STRING *s)) { ASSERT_ARGS(Parrot_str_length) return STRING_IS_NULL(s) ? 0 : s->strlen; } /* =item C Returns the number of bytes required to safely contain the specified number of characters in the specified Parrot string's representation. =cut */ PARROT_WARN_UNUSED_RESULT PARROT_PURE_FUNCTION static INTVAL string_max_bytes(SHIM_INTERP, ARGIN(const STRING *s), UINTVAL nchars) { ASSERT_ARGS(string_max_bytes) PARROT_ASSERT(s->encoding); return STRING_max_bytes_per_codepoint(s) * nchars; } /* =item C Repeats the specified Parrot string I times and returns the result. =cut */ PARROT_EXPORT PARROT_CANNOT_RETURN_NULL STRING * Parrot_str_repeat(PARROT_INTERP, ARGIN(const STRING *s), UINTVAL num) { ASSERT_ARGS(Parrot_str_repeat) STRING * const dest = Parrot_str_new_init(interp, NULL, s->bufused * num, s->encoding, 0); if (num > 0) { /* copy s into dest num times */ UINTVAL length = s->bufused; UINTVAL i; char * destpos = dest->strstart; const char * const srcpos = s->strstart; for (i = 0; i < num; ++i) { memcpy(destpos, srcpos, length); destpos += length; } dest->strlen = s->strlen * num; dest->bufused = s->bufused * num; } return dest; } /* =item C Returns substring of length C from C from the specified Parrot string. If C is negative, it counts from the end of the string. Returns the empty string if C equals the length of the string. Throws an exception if C is null or C is out of bounds. Truncates C if it extends beyond the end of the string. Identical to the STRING_substr macro. =cut */ PARROT_EXPORT PARROT_CANNOT_RETURN_NULL PARROT_WARN_UNUSED_RESULT STRING * Parrot_str_substr(PARROT_INTERP, ARGIN_NULLOK(const STRING *src), INTVAL offset, INTVAL length) { ASSERT_ARGS(Parrot_str_substr) if (src == NULL) src = STRINGNULL; return STRING_substr(interp, src, offset, length); } /* =item C Returns the substring between iterators C and C. =cut */ PARROT_CANNOT_RETURN_NULL PARROT_WARN_UNUSED_RESULT STRING * Parrot_str_iter_substr(PARROT_INTERP, ARGIN(const STRING *str), ARGIN(const String_iter *l), ARGIN_NULLOK(const String_iter *r)) { ASSERT_ARGS(Parrot_str_iter_substr) STRING * const dest = Parrot_str_copy(interp, str); dest->strstart += l->bytepos; if (r == NULL) { dest->bufused = str->bufused - l->bytepos; dest->strlen = str->strlen - l->charpos; } else { dest->bufused = r->bytepos - l->bytepos; dest->strlen = r->charpos - l->charpos; } dest->hashval = 0; return dest; } /* =item C Find the next occurrence of STRING C in STRING C starting at String_iter C. If C is found C is modified to mark the beginning of C and String_iter C is set to the character after C in C. Returns the character position where C was found or -1 if it wasn't found. =cut */ INTVAL Parrot_str_iter_index(PARROT_INTERP, ARGIN(const STRING *src), ARGMOD(String_iter *start), ARGOUT(String_iter *end), ARGIN(const STRING *search)) { ASSERT_ARGS(Parrot_str_iter_index) String_iter search_iter, search_start, next_start; const UINTVAL len = search->strlen; UINTVAL c0; if (len == 0) { *end = *start; return start->charpos; } STRING_ITER_INIT(interp, &search_iter); c0 = STRING_iter_get_and_advance(interp, search, &search_iter); search_start = search_iter; next_start = *start; while (start->charpos + len <= src->strlen) { UINTVAL c1 = STRING_iter_get_and_advance(interp, src, &next_start); if (c1 == c0) { UINTVAL c2; *end = next_start; do { if (search_iter.charpos >= len) return start->charpos; c1 = STRING_iter_get_and_advance(interp, src, end); c2 = STRING_iter_get_and_advance(interp, search, &search_iter); } while (c1 == c2); search_iter = search_start; } *start = next_start; } return -1; } /* =item C Replaces a sequence of C characters from C in the first Parrot string with the second Parrot string, returning what was replaced. This follows the Perl semantics for: substr EXPR, OFFSET, LENGTH, REPLACEMENT Replacing a sequence of characters with a longer string grows the string; a shorter string shrinks it. Replacing 2 past the end of the string is undefined. However replacing 1 past the end of the string concatenates the two strings. A negative offset is allowed to replace from the end. =cut */ PARROT_EXPORT PARROT_CANNOT_RETURN_NULL PARROT_WARN_UNUSED_RESULT STRING * Parrot_str_replace(PARROT_INTERP, ARGIN(const STRING *src), INTVAL offset, INTVAL length, ARGIN(const STRING *rep)) { ASSERT_ARGS(Parrot_str_replace) String_iter iter; const STR_VTABLE *enc; STRING *dest = NULL; UINTVAL true_offset = (UINTVAL)offset; UINTVAL true_length = (UINTVAL)length; UINTVAL start_byte, end_byte, start_char, end_char; INTVAL buf_size; if (STRING_IS_NULL(src)) { Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_UNEXPECTED_NULL, "Can't replace in NULL string"); } /* abs(-offset) may not be > strlen-1 */ if (offset < 0) true_offset = (UINTVAL)(src->strlen + offset); /* Can replace 1 past end of string which is technically outside the string * but is same as a concat(). * Only give exception if caller trys to replace end of string + 2 */ if (true_offset > src->strlen) Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_SUBSTR_OUT_OF_STRING, "Can only replace inside string or index after end of string"); if (true_length > (src->strlen - true_offset)) true_length = (UINTVAL)(src->strlen - true_offset); if (STRING_IS_NULL(rep)) { enc = src->encoding; } else { /* may have different reps..... */ enc = string_rep_compatible(src, rep); if (!enc) { if (src->encoding != Parrot_utf8_encoding_ptr) src = Parrot_utf8_encoding_ptr->to_encoding(interp, src); if (rep->encoding != Parrot_utf8_encoding_ptr) rep = Parrot_utf8_encoding_ptr->to_encoding(interp, rep); /* Remember selected encoding */ enc = src->encoding; } } /* get byte position of the part that will be replaced */ STRING_ITER_INIT(interp, &iter); STRING_iter_skip(interp, src, &iter, true_offset); start_byte = iter.bytepos; start_char = iter.charpos; STRING_iter_skip(interp, src, &iter, true_length); end_byte = iter.bytepos; end_char = iter.charpos; /* not possible.... */ if (end_byte < start_byte) Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_SUBSTR_OUT_OF_STRING, "replace: subend somehow is less than substart"); /* Now do the replacement */ dest = Parrot_gc_new_string_header(interp, 0); /* Set encoding to compatible */ dest->encoding = enc; /* Clear COW flag. We own buffer */ PObj_get_FLAGS(dest) = PObj_is_string_FLAG | PObj_is_COWable_FLAG; /* size removed bytes added bytes */ buf_size = src->bufused - (end_byte - start_byte) + rep->bufused; /* Alloctate new string size. */ Parrot_gc_allocate_string_storage(interp, dest, buf_size); dest->bufused = buf_size; /* Copy begin of string */ memcpy(dest->strstart, src->strstart, start_byte); /* Copy the replacement in */ memcpy(dest->strstart + start_byte, rep->strstart, rep->bufused); /* Copy the end of old string */ memcpy(dest->strstart + start_byte + rep->bufused, src->strstart + end_byte, src->bufused - end_byte); dest->strlen = src->strlen - (end_char - start_char) + rep->strlen; dest->hashval = 0; return dest; } /* =item C Removes the last C characters of the specified Parrot string and returns the modified string. If C is negative, cuts the string after C<+n> characters. =cut */ PARROT_EXPORT PARROT_CANNOT_RETURN_NULL STRING * Parrot_str_chopn(PARROT_INTERP, ARGIN(const STRING *s), INTVAL n) { ASSERT_ARGS(Parrot_str_chopn) INTVAL end = -n; if (n >= 0) end += STRING_length(s); return STRING_substr(interp, s, 0, end); } /* =item C Compares two strings to each other. If s1 is less than s2, returns -1. If the strings are equal, returns 0. If s1 is greater than s2, returns 2. This comparison uses the character set collation order of the strings for comparison. The null string is considered equal to the empty string. Identical to the STRING_compare macro. =cut */ PARROT_EXPORT PARROT_WARN_UNUSED_RESULT INTVAL Parrot_str_compare(PARROT_INTERP, ARGIN_NULLOK(const STRING *s1), ARGIN_NULLOK(const STRING *s2)) { ASSERT_ARGS(Parrot_str_compare) if (s1 == NULL) s1 = STRINGNULL; return STRING_compare(interp, s1, s2); } /* =item C Compares two Parrot strings, performing type and encoding conversions if necessary. Returns 1 if the strings are not equal, and 0 otherwise. =cut */ PARROT_EXPORT PARROT_WARN_UNUSED_RESULT INTVAL Parrot_str_not_equal(PARROT_INTERP, ARGIN_NULLOK(const STRING *s1), ARGIN_NULLOK(const STRING *s2)) { ASSERT_ARGS(Parrot_str_not_equal) if (s1 == NULL) s1 = STRINGNULL; return !STRING_equal(interp, s1, s2); } /* =item C Compares two Parrot strings, performing type and encoding conversions if necessary. The null string is considered equal to the empty string. Returns 1 if the strings are equal, and 0 otherwise. Identical to the STRING_equal macro. =cut */ PARROT_EXPORT PARROT_WARN_UNUSED_RESULT INTVAL Parrot_str_equal(PARROT_INTERP, ARGIN_NULLOK(const STRING *s1), ARGIN_NULLOK(const STRING *s2)) { ASSERT_ARGS(Parrot_str_equal) if (s1 == NULL) s1 = STRINGNULL; return STRING_equal(interp, s1, s2); } /* =item C Performs a bitwise C on two Parrot strings, performing type and encoding conversions if necessary. Returns the result as a new string. =cut */ PARROT_EXPORT PARROT_CANNOT_RETURN_NULL STRING * Parrot_str_bitwise_and(PARROT_INTERP, ARGIN_NULLOK(const STRING *s1), ARGIN_NULLOK(const STRING *s2)) { ASSERT_ARGS(Parrot_str_bitwise_and) STRING *res; size_t minlen; /* we could also trans_encoding to iso-8859-1 */ if (s1 && STRING_max_bytes_per_codepoint(s1) != 1) Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_ENCODING, "string bitwise_and (%s/%s) unsupported", s1->encoding->name, nonnull_encoding_name(s2)); if (s2 && STRING_max_bytes_per_codepoint(s2) != 1) Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_ENCODING, "string bitwise_and (%s/%s) unsupported", nonnull_encoding_name(s1), s2->encoding->name); /* think about case of dest string is one of the operands */ if (!STRING_IS_NULL(s1) && !STRING_IS_NULL(s2)) minlen = s1->strlen > s2->strlen ? s2->strlen : s1->strlen; else minlen = 0; res = Parrot_str_new_init(interp, NULL, minlen, Parrot_binary_encoding_ptr, 0); if (STRING_IS_NULL(s1) || STRING_IS_NULL(s2)) { res->bufused = 0; res->strlen = 0; return res; } #if ! DISABLE_GC_DEBUG /* trigger GC for debug */ if (interp && GC_DEBUG(interp)) Parrot_gc_mark_and_sweep(interp, GC_trace_stack_FLAG); #endif { /* bitwise AND the strings */ const Parrot_UInt1 *curr1 = (Parrot_UInt1 *)s1->strstart; const Parrot_UInt1 *curr2 = (Parrot_UInt1 *)s2->strstart; Parrot_UInt1 *dp = (Parrot_UInt1 *)res->strstart; size_t len = minlen; while (len--) *dp++ = *curr1++ & *curr2++; } res->bufused = res->strlen = minlen; return res; } #define BITWISE_XOR_STRINGS(type1, type2, restype, s1, s2, res, maxlen) \ do { \ const type1 *curr1 = NULL; \ const type2 *curr2 = NULL; \ size_t length1 = 0; \ size_t length2 = 0; \ restype *dp; \ size_t _index; \ \ if (!STRING_IS_NULL(s1)) { \ curr1 = (type1 *)(s1)->strstart; \ length1 = (s1)->strlen; \ } \ if (!STRING_IS_NULL(s2)) { \ curr2 = (type2 *)(s2)->strstart; \ length2 = (s2)->strlen; \ } \ \ dp = (restype *)(res)->strstart; \ _index = 0; \ \ for (; _index < (maxlen) ; ++curr1, ++curr2, ++dp, ++_index) { \ if (_index < length1) { \ if (_index < length2) \ *dp = *curr1 ^ *curr2; \ else \ *dp = *curr1; \ } \ else if (_index < length2) { \ *dp = *curr2; \ } \ } \ } while (0) #define BITWISE_OR_STRINGS(type1, type2, restype, s1, s2, res, maxlen) \ do { \ const type1 *curr1 = NULL; \ const type2 *curr2 = NULL; \ size_t length1 = 0; \ size_t length2 = 0; \ restype *dp; \ size_t _index; \ \ if (!STRING_IS_NULL(s1)) { \ curr1 = (type1 *)(s1)->strstart; \ length1 = (s1)->strlen; \ } \ if (!STRING_IS_NULL(s2)) { \ curr2 = (type2 *)(s2)->strstart; \ length2 = (s2)->strlen; \ } \ \ dp = (restype *)(res)->strstart; \ _index = 0; \ \ for (; _index < (maxlen) ; ++curr1, ++curr2, ++dp, ++_index) { \ if (_index < length1) { \ if (_index < length2) \ *dp = *curr1 | *curr2; \ else \ *dp = *curr1; \ } \ else if (_index < length2) { \ *dp = *curr2; \ } \ } \ } while (0) /* =item C Performs a bitwise C on two Parrot strings, performing type and encoding conversions if necessary. Returns the result as a new string. =cut */ PARROT_EXPORT PARROT_CANNOT_RETURN_NULL STRING * Parrot_str_bitwise_or(PARROT_INTERP, ARGIN_NULLOK(const STRING *s1), ARGIN_NULLOK(const STRING *s2)) { ASSERT_ARGS(Parrot_str_bitwise_or) STRING *res; size_t maxlen = 0; if (!STRING_IS_NULL(s1)) { if (STRING_max_bytes_per_codepoint(s1) != 1) Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_ENCODING, "string bitwise_or (%s/%s) unsupported", s1->encoding->name, nonnull_encoding_name(s2)); maxlen = s1->bufused; } if (!STRING_IS_NULL(s2)) { if (STRING_max_bytes_per_codepoint(s2) != 1) Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_ENCODING, "string bitwise_or (%s/%s) unsupported", nonnull_encoding_name(s1), s2->encoding->name); if (s2->bufused > maxlen) maxlen = s2->bufused; } res = Parrot_str_new_init(interp, NULL, maxlen, Parrot_binary_encoding_ptr, 0); if (!maxlen) { res->bufused = 0; res->strlen = 0; return res; } #if ! DISABLE_GC_DEBUG /* trigger GC for debug */ if (interp && GC_DEBUG(interp)) Parrot_gc_mark_and_sweep(interp, GC_trace_stack_FLAG); #endif BITWISE_OR_STRINGS(Parrot_UInt1, Parrot_UInt1, Parrot_UInt1, s1, s2, res, maxlen); res->bufused = res->strlen = maxlen; return res; } /* =item C Performs a bitwise C on two Parrot strings, performing type and encoding conversions if necessary. Returns the result as a new string. =cut */ PARROT_EXPORT PARROT_CANNOT_RETURN_NULL STRING * Parrot_str_bitwise_xor(PARROT_INTERP, ARGIN_NULLOK(const STRING *s1), ARGIN_NULLOK(const STRING *s2)) { ASSERT_ARGS(Parrot_str_bitwise_xor) STRING *res; size_t maxlen = 0; if (!STRING_IS_NULL(s1)) { if (STRING_max_bytes_per_codepoint(s1) != 1) Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_ENCODING, "string bitwise_xor (%s/%s) unsupported", s1->encoding->name, nonnull_encoding_name(s2)); maxlen = s1->bufused; } if (!STRING_IS_NULL(s2)) { if (STRING_max_bytes_per_codepoint(s2) != 1) Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_ENCODING, "string bitwise_xor (%s/%s) unsupported", nonnull_encoding_name(s1), s2->encoding->name); if (s2->bufused > maxlen) maxlen = s2->bufused; } res = Parrot_str_new_init(interp, NULL, maxlen, Parrot_binary_encoding_ptr, 0); if (!maxlen) { res->bufused = 0; res->strlen = 0; return res; } #if ! DISABLE_GC_DEBUG /* trigger GC for debug */ if (interp && GC_DEBUG(interp)) Parrot_gc_mark_and_sweep(interp, GC_trace_stack_FLAG); #endif BITWISE_XOR_STRINGS(Parrot_UInt1, Parrot_UInt1, Parrot_UInt1, s1, s2, res, maxlen); res->bufused = res->strlen = maxlen; return res; } #define BITWISE_NOT_STRING(type, s, res) \ do { \ if (!STRING_IS_NULL(s) && !STRING_IS_NULL(res)) { \ const type *curr = (type *)(s)->strstart; \ size_t length = (s)->strlen; \ Parrot_UInt1 *dp = (Parrot_UInt1 *)(res)->strstart; \ \ for (; length ; --length, ++dp, ++curr) \ *dp = 0xFF & ~ *curr; \ } \ } while (0) /* =item C Performs a bitwise C on a Parrot string. Returns the result as a new string. =cut */ PARROT_EXPORT PARROT_CANNOT_RETURN_NULL STRING * Parrot_str_bitwise_not(PARROT_INTERP, ARGIN_NULLOK(const STRING *s)) { ASSERT_ARGS(Parrot_str_bitwise_not) STRING *res; size_t len; if (!STRING_IS_NULL(s)) { if (STRING_max_bytes_per_codepoint(s) != 1) Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_ENCODING, "string bitwise_not (%s) unsupported", s->encoding->name); len = s->bufused; } else len = 0; res = Parrot_str_new_init(interp, NULL, len, Parrot_binary_encoding_ptr, 0); if (!len) { res->bufused = 0; res->strlen = 0; return res; } #if ! DISABLE_GC_DEBUG /* trigger GC for debug */ if (interp && GC_DEBUG(interp)) Parrot_gc_mark_and_sweep(interp, GC_trace_stack_FLAG); #endif res->strlen = res->bufused = len; BITWISE_NOT_STRING(Parrot_UInt1, s, res); return res; } /* =item C Returns whether the specified Parrot string is true. A string is true if it is equal to anything other than C<0>, C<""> or C<"0">. =cut */ PARROT_EXPORT PARROT_WARN_UNUSED_RESULT INTVAL Parrot_str_boolean(PARROT_INTERP, ARGIN_NULLOK(const STRING *s)) { ASSERT_ARGS(Parrot_str_boolean) INTVAL len; if (s == NULL) return 0; len = STRING_length(s); if (len == 0) return 0; if (len == 1) { const UINTVAL c = STRING_ord(interp, s, 0); /* relying on character literals being interpreted as ASCII--may not be correct on EBCDIC systems. use numeric value instead? */ if (c == '0') /* later, accept other chars with digit value 0? or, no */ return 0; } /* it must be true */ return 1; } /* =item C Writes and returns a Parrot string. =cut */ PARROT_EXPORT PARROT_CANNOT_RETURN_NULL STRING * Parrot_str_format_data(PARROT_INTERP, ARGIN(const char *format), ...) { ASSERT_ARGS(Parrot_str_format_data) STRING *output; va_list args; va_start(args, format); output = Parrot_vsprintf_c(interp, format, args); va_end(args); return output; } /* State of FSM during number value parsing. Integer uses only parse_start, parse_before_dot and parse_end. */ typedef enum number_parse_state { parse_start, parse_before_dot, parse_after_dot, parse_after_e, parse_after_e_sign, parse_end } number_parse_state; /* =item C Converts a numeric Parrot string to an integer value. A number is such that: sign = '+' | '-' digit = "Any code point considered a digit by the chartype" indicator = 'e' | 'E' digits = digit [digit]... decimal-part = digits '.' [digits] | ['.'] digits exponent-part = indicator [sign] digits numeric-string = [sign] decimal-part [exponent-part] The integer value is the appropriate integer representation of such a number, rounding towards zero. =cut */ PARROT_EXPORT PARROT_WARN_UNUSED_RESULT INTVAL Parrot_str_to_int(PARROT_INTERP, ARGIN_NULLOK(const STRING *s)) { ASSERT_ARGS(Parrot_str_to_int) if (STRING_IS_NULL(s)) return 0; else { const UINTVAL max_safe = -(UINTVAL)PARROT_INTVAL_MIN / 10; const UINTVAL last_dig = (-(UINTVAL)PARROT_INTVAL_MIN) % 10; int sign = 1; UINTVAL i = 0; String_iter iter; INTVAL count = (INTVAL)s->strlen; UINTVAL c; STRING_ITER_INIT(interp, &iter); c = count-- > 0 ? STRING_iter_get_and_advance(interp, s, &iter) : 0; while (c == ' ') c = count-- > 0 ? STRING_iter_get_and_advance(interp, s, &iter) : 0; switch (c) { case '-': sign = -1; /* Fall through. */ case '+': c = count-- > 0 ? STRING_iter_get_and_advance(interp, s, &iter) : 0; break; default: ; /* nothing */ } while (c) { const UINTVAL nextval = c - (UINTVAL)'0'; if (nextval > 9) break; if (i < max_safe || (i == max_safe && nextval <= last_dig)) i = i * 10 + nextval; else Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_ERR_OVERFLOW, "Integer value of String '%S' too big", s); c = count-- > 0 ? STRING_iter_get_and_advance(interp, s, &iter) : 0; } if (sign == 1 && i > (UINTVAL)PARROT_INTVAL_MAX) Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_ERR_OVERFLOW, "Integer value of String '%S' too big", s); return sign == -1 ? -i : i; } } /* =item C Converts a numeric Parrot STRING to a floating point number. =cut */ PARROT_EXPORT PARROT_WARN_UNUSED_RESULT FLOATVAL Parrot_str_to_num(PARROT_INTERP, ARGIN_NULLOK(const STRING *s)) { ASSERT_ARGS(Parrot_str_to_num) FLOATVAL f = 0.0; FLOATVAL mantissa = 0.0; FLOATVAL sign = 1.0; /* -1 for '-' */ FLOATVAL divider = 0.1; INTVAL e = 0; INTVAL e_sign = 1; /* -1 for '-' */ /* How many digits it's safe to parse */ const INTVAL max_safe = PARROT_INTVAL_MAX / 10; INTVAL m = 0; /* Integer mantissa */ int m_is_safe = 1; /* We can use integer mantissa */ INTVAL d = 0; /* Integer descriminator */ int d_is_safe = 1; /* We can use integer mantissa */ int d_length = 0; int check_nan = 0; /* Check for NaN and Inf after main loop */ String_iter iter; number_parse_state state = parse_start; if (STRING_IS_NULL(s)) return 0.0; STRING_ITER_INIT(interp, &iter); /* Handcrafted FSM to read float value */ while (state != parse_end && iter.charpos < s->strlen) { const UINTVAL c = STRING_iter_get_and_advance(interp, s, &iter); /* Check for overflow */ if (c > 255) break; switch (state) { case parse_start: if (isdigit((unsigned char)c)) { f = c - '0'; m = c - '0'; state = parse_before_dot; } else if (c == '-') { sign = -1.0; state = parse_before_dot; } else if (c == '+') state = parse_before_dot; else if (c == '.') state = parse_after_dot; else if (isspace((unsigned char)c)) ; /* Do nothing */ else { check_nan = 1; state = parse_end; } break; case parse_before_dot: if (isdigit((unsigned char)c)) { f = f*10.0 + (c-'0'); m = m*10 + (c-'0'); /* Integer overflow for mantissa */ if (m >= max_safe) m_is_safe = 0; } else if (c == '.') { state = parse_after_dot; /* * Throw gathered result. Recalculate from integer mantissa * to preserve precision. */ if (m_is_safe) f = m; mantissa = f; } else if (c == 'e' || c == 'E') { state = parse_after_e; /* See comment above */ if (m_is_safe) f = m; mantissa = f; } else { check_nan = 1; state = parse_end; } break; case parse_after_dot: if (isdigit((unsigned char)c)) { f += (c-'0') * divider; divider /= 10.0; d = d*10 + (c-'0'); if (d >= max_safe) d_is_safe = 0; ++d_length; } else if (c == 'e' || c == 'E') state = parse_after_e; else state = parse_end; break; case parse_after_e: if (isdigit((unsigned char)c)) { e = e*10 + (c-'0'); state = parse_after_e_sign; } else if (c == '-') { e_sign = -1; state = parse_after_e_sign; } else if (c == '+') state = parse_after_e_sign; else state = parse_end; break; case parse_after_e_sign: if (isdigit((unsigned char)c)) e = e*10 + (c-'0'); else state = parse_end; break; case parse_end: default: /* Pacify compiler */ break; } } /* Support for non-canonical NaN and Inf */ /* charpos <= 2 because for "-i" iter already advanced to next char */ if (check_nan && (iter.charpos <= 2)) { STRING * const t = Parrot_str_upcase(interp, s); if (STRING_equal(interp, t, CONST_STRING(interp, "NAN"))) return PARROT_FLOATVAL_NAN_QUIET; else if (STRING_equal(interp, t, CONST_STRING(interp, "INF")) || STRING_equal(interp, t, CONST_STRING(interp, "INFINITY"))) return PARROT_FLOATVAL_INF_POSITIVE; else if (STRING_equal(interp, t, CONST_STRING(interp, "-INF")) || STRING_equal(interp, t, CONST_STRING(interp, "-INFINITY"))) return PARROT_FLOATVAL_INF_NEGATIVE; } /* powl() could be used here, but it is an optional POSIX extension that needs to be checked for at Configure-time. See https://github.com/parrot/parrot/issues/451 for more details. */ # define POW pow if (d && d_is_safe) { f = mantissa + (1.0 * d / POW(10.0, d_length)); } if (sign < 0) f = -f; if (e) { if (e_sign == 1) f *= POW(10.0, e); else f /= POW(10.0, e); } #undef POW return f; } /* =item C Returns a Parrot string representation of the specified integer value. =cut */ PARROT_EXPORT PARROT_WARN_UNUSED_RESULT PARROT_CANNOT_RETURN_NULL STRING * Parrot_str_from_int(PARROT_INTERP, INTVAL i) { ASSERT_ARGS(Parrot_str_from_int) char buf[128]; return Parrot_str_from_int_base(interp, buf, (HUGEINTVAL)i, 10); } /* =item C Returns a Parrot string representation of the specified floating-point value. =cut */ PARROT_EXPORT PARROT_WARN_UNUSED_RESULT PARROT_CANNOT_RETURN_NULL STRING * Parrot_str_from_num(PARROT_INTERP, FLOATVAL f) { ASSERT_ARGS(Parrot_str_from_num) /* Too damn hard--hand it off to Parrot_sprintf, which'll probably use the system sprintf anyway, but has gigantic buffers that are awfully hard to overflow. */ return Parrot_sprintf_c(interp, FLOATVAL_FMT, f); } /* =item C Returns a C string for the specified Parrot string in the current representation of the string. Use C to free the string. Failure to do this will result in a memory leak. You usually should use Parrot_str_to_encoded_cstring instead. =cut */ PARROT_EXPORT PARROT_CANNOT_RETURN_NULL char * Parrot_str_to_cstring(PARROT_INTERP, ARGIN(const STRING *s)) { ASSERT_ARGS(Parrot_str_to_cstring) return Parrot_str_to_encoded_cstring(interp, s, s->encoding); } /* =item C Returns a C string in the encoding C for the Parrot string C. Use C to free the string. Failure to do this will result in a memory leak. =cut */ PARROT_EXPORT PARROT_CANNOT_RETURN_NULL char * Parrot_str_to_encoded_cstring(PARROT_INTERP, ARGIN(const STRING *s), ARGIN(const STR_VTABLE *enc)) { ASSERT_ARGS(Parrot_str_to_encoded_cstring) size_t len; size_t trail; char *p; if (STRING_IS_NULL(s)) Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_UNEXPECTED_NULL, "Can't convert NULL string"); if (s->encoding != enc) { /* Check for compatible encodings */ if (s->encoding == Parrot_ascii_encoding_ptr) { if (enc == Parrot_latin1_encoding_ptr || enc == Parrot_utf8_encoding_ptr) goto skip; } else if (s->encoding == Parrot_ucs2_encoding_ptr) { if (enc == Parrot_utf16_encoding_ptr) goto skip; } /* Convert */ s = enc->to_encoding(interp, s); } skip: len = s->bufused; trail = enc->bytes_per_unit; p = (char*)mem_internal_allocate(len + trail); memcpy(p, s->strstart, len); memset(p + len, 0, trail); return p; } /* =item C Free a string created by C. TODO - Hopefully this can go away at some point, as it's got all sorts of leak potential otherwise. =cut */ PARROT_EXPORT void Parrot_str_free_cstring(ARGFREE(char *p)) { ASSERT_ARGS(Parrot_str_free_cstring) mem_internal_free((void *)p); } /* =item C Replaces the specified Parrot string's managed buffer memory by system memory. =cut */ PARROT_EXPORT void Parrot_str_pin(SHIM_INTERP, ARGMOD(STRING *s)) { ASSERT_ARGS(Parrot_str_pin) const size_t size = Buffer_buflen(s); char * const memory = (char *)mem_internal_allocate(size); memcpy(memory, Buffer_bufstart(s), size); Buffer_bufstart(s) = memory; s->strstart = memory; /* Mark the memory as both from the system and immobile */ PObj_sysmem_SET(s); } /* =item C Undoes a C so that the string once again uses managed memory. =cut */ PARROT_EXPORT void Parrot_str_unpin(PARROT_INTERP, ARGMOD(STRING *s)) { ASSERT_ARGS(Parrot_str_unpin) void *memory; size_t size; /* If this string is not marked using system memory, * we just don't do this */ if (!PObj_sysmem_TEST(s)) return; size = Buffer_buflen(s); /* We need a handle on the fixed memory so we can get rid of it later */ memory = Buffer_bufstart(s); /* Reallocate it the same size * NOTE can't use Parrot_gc_reallocate_string_storage because of the LEA * allocator, where this is a noop for the same size * * We have to block GC here, as we have a pointer to bufstart */ Parrot_block_GC_sweep(interp); Parrot_gc_allocate_string_storage(interp, s, size); Parrot_unblock_GC_sweep(interp); memcpy(Buffer_bufstart(s), memory, size); /* Mark the memory as neither immobile nor system allocated */ PObj_sysmem_CLEAR(s); /* Free up the memory */ mem_internal_free(memory); } /* =item C Returns the hash value for the specified Parrot string, caching it in C<< s->hashval >>. Identical to the STRING_hash macro. =cut */ PARROT_EXPORT PARROT_WARN_UNUSED_RESULT size_t Parrot_str_to_hashval(PARROT_INTERP, ARGIN_NULLOK(const STRING *s)) { ASSERT_ARGS(Parrot_str_to_hashval) if (s == NULL) s = STRINGNULL; return STRING_hash(interp, s, interp->hash_seed); } /* =item C Return the reverse of C, even for non-ascii strings. =cut */ PARROT_EXPORT PARROT_CANNOT_RETURN_NULL STRING * Parrot_str_reverse(PARROT_INTERP, ARGIN(const STRING *src)) { ASSERT_ARGS(Parrot_str_reverse) String_iter iter; INTVAL pos; PMC *sb; STRING_ITER_INIT(interp, &iter); sb = Parrot_pmc_new(interp, enum_class_StringBuilder); for (pos = STRING_length(src) - 1; pos >= 0; pos--) { VTABLE_push_string(interp, sb, Parrot_str_chr(interp, STRING_iter_get(interp, src, &iter, pos))); } return VTABLE_get_string(interp, sb); } /* =item C Escapes all non-ASCII chars to backslash sequences. Control chars that C can handle are escaped as I<\x>, as well as a double quote character. Other control chars and codepoints < 0x100 are escaped as I<\xhh>, codepoints up to 0xffff, as I<\uhhhh>, and codepoints greater than this as I<\x{hh...hh}>. =cut */ PARROT_EXPORT PARROT_CANNOT_RETURN_NULL STRING * Parrot_str_escape(PARROT_INTERP, ARGIN_NULLOK(const STRING *src)) { ASSERT_ARGS(Parrot_str_escape) return Parrot_str_escape_truncate(interp, src, (UINTVAL) ~0); } /* =item C Escapes all non-ASCII characters in the given string with backslashed versions, but limits the length of the output (used for trace output of strings). =cut */ PARROT_EXPORT PARROT_CANNOT_RETURN_NULL STRING * Parrot_str_escape_truncate(PARROT_INTERP, ARGIN_NULLOK(const STRING *src), UINTVAL limit) { ASSERT_ARGS(Parrot_str_escape_truncate) STRING *result; UINTVAL i, len, charlen; String_iter iter; char hex_buf[HEX_BUF_SIZE]; char *dp; if (STRING_IS_NULL(src)) return STRINGNULL; len = src->strlen; if (len > limit) len = limit; /* expect around 2x the chars */ charlen = 2 * len; if (charlen < HEX_BUF_SIZE) charlen = HEX_BUF_SIZE; /* create ascii result */ result = Parrot_str_new_init(interp, NULL, charlen, Parrot_ascii_encoding_ptr, 0); /* more work TODO */ STRING_ITER_INIT(interp, &iter); dp = result->strstart; for (i = 0; len > 0; --len) { unsigned c = STRING_iter_get_and_advance(interp, src, &iter); int hex_len; if (c < 0x7f) { /* process ASCII chars */ if (i >= charlen - 2) { /* resize - still len codepoints to go */ charlen += len * 2 + HEX_BUF_SIZE; result->bufused = i; Parrot_gc_reallocate_string_storage(interp, result, charlen); /* start can change */ dp = result->strstart; } switch (c) { case '\\': dp[i++] = '\\'; break; case '\a': dp[i++] = '\\'; c = 'a'; break; case '\b': dp[i++] = '\\'; c = 'b'; break; case '\n': dp[i++] = '\\'; c = 'n'; break; case '\r': dp[i++] = '\\'; c = 'r'; break; case '\t': dp[i++] = '\\'; c = 't'; break; case '\f': dp[i++] = '\\'; c = 'f'; break; case '"': dp[i++] = '\\'; c = '"'; break; case 27: dp[i++] = '\\'; c = 'e'; break; default: break; } if (c >= 0x20) { dp[i++] = c; continue; } } /* escape by appending either \uhhhh or \x{hh...} */ if (c < 0x0100 || c >= 0x10000) hex_len = snprintf(hex_buf, HEX_BUF_SIZE - 1, "\\x{%x}", c); else hex_len = snprintf(hex_buf, HEX_BUF_SIZE - 1, "\\u%04x", c); if (hex_len < 0) hex_len = 0; if (i + hex_len > charlen) { /* resize - still len codepoints to go */ charlen += len * 2 + HEX_BUF_SIZE; result->bufused = i; Parrot_gc_reallocate_string_storage(interp, result, charlen); /* start can change */ dp = result->strstart; } memcpy(dp + i, hex_buf, hex_len); /* adjust our insert idx */ i += hex_len; PARROT_ASSERT(i <= charlen); } result->bufused = result->strlen = i; return result; } /* =item C Helper function to avoid repeated throw calls. =cut */ PARROT_DOES_NOT_RETURN PARROT_COLD static void throw_illegal_escape(PARROT_INTERP) { ASSERT_ARGS(throw_illegal_escape) Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_UNIMPLEMENTED, "Illegal escape sequence"); } /* =item C EXPERIMENTAL, see TT #1628 Unescapes the src string returning a new string with the encoding specified. =cut */ PARROT_EXPORT PARROT_CANNOT_RETURN_NULL STRING * Parrot_str_unescape_string(PARROT_INTERP, ARGIN(const STRING *src), ARGIN(const STR_VTABLE *encoding), UINTVAL flags) { ASSERT_ARGS(Parrot_str_unescape_string) UINTVAL srclen = Parrot_str_byte_length(interp, src); STRING *result = Parrot_gc_new_string_header(interp, flags); String_iter itersrc; String_iter iterdest; UINTVAL reserved; int digcount; char digbuf[9]; int pending; result->encoding = encoding; reserved = string_max_bytes(interp, result, srclen); Parrot_gc_allocate_string_storage(interp, result, reserved); result->bufused = reserved; STRING_ITER_INIT(interp, &itersrc); STRING_ITER_INIT(interp, &iterdest); while (itersrc.bytepos < srclen) { INTVAL c = STRING_iter_get_and_advance(interp, src, &itersrc); INTVAL next; do { pending = 0; next = c; if (c == '\\') { if (itersrc.bytepos >= srclen) break; c = STRING_iter_get_and_advance(interp, src, &itersrc); switch (c) { /* Common one char sequences */ case 'a': next = '\a'; break; case 'b': next = '\b'; break; case 't': next = '\t'; break; case 'n': next = '\n'; break; case 'v': next = '\v'; break; case 'f': next = '\f'; break; case 'r': next = '\r'; break; case 'e': next = '\x1B'; break; /* Escape character */ case 'c': if (itersrc.bytepos >= srclen) break; c = STRING_iter_get_and_advance(interp, src, &itersrc); /* This assumes ascii-alike encoding */ if (c < 'A' || c > 'Z') throw_illegal_escape(interp); next = c - 'A' + 1; break; case 'x': digcount = 0; if (itersrc.bytepos >= srclen) break; c = STRING_iter_get_and_advance(interp, src, &itersrc); if (c == '{') { /* \x{h..h} 1..8 hex digits */ while (itersrc.bytepos < srclen) { c = STRING_iter_get_and_advance(interp, src, &itersrc); if (c == '}') break; if (!isxdigit(c)) throw_illegal_escape(interp); if (digcount == 8) break; digbuf[digcount++] = c; } if (c != '}') throw_illegal_escape(interp); } else { /* \xhh 1..2 hex digits */ pending = 1; for (digcount = 0; digcount < 2;) { if (!isxdigit(c)) break; digbuf[digcount] = c; ++digcount; if (itersrc.bytepos >= srclen) { pending = 0; break; } c = STRING_iter_get_and_advance(interp, src, &itersrc); } } if (digcount == 0) throw_illegal_escape(interp); digbuf[digcount] = '\0'; next = strtol(digbuf, NULL, 16); break; case 'u': /* \uhhhh 4 hex digits */ for (digcount = 0; digcount < 4; ++digcount) { if (itersrc.bytepos >= srclen) break; c = STRING_iter_get_and_advance(interp, src, &itersrc); if (!isxdigit(c)) throw_illegal_escape(interp); digbuf[digcount] = c; } digbuf[digcount] = '\0'; next = strtol(digbuf, NULL, 16); break; case 'U': /* \Uhhhhhhhh 8 hex digits */ for (digcount = 0; digcount < 8; ++digcount) { if (itersrc.bytepos >= srclen) break; c = STRING_iter_get_and_advance(interp, src, &itersrc); if (!isxdigit(c)) throw_illegal_escape(interp); digbuf[digcount] = c; } digbuf[digcount] = '\0'; next = strtol(digbuf, NULL, 16); break; case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': /* \ooo 1..3 oct digits */ digbuf[0] = c; for (digcount = 1; digcount < 3; ++digcount) { if (itersrc.bytepos >= srclen) break; c = STRING_iter_get_and_advance(interp, src, &itersrc); if (c < '0' || c > '7') break; digbuf[digcount] = c; } digbuf[digcount] = '\0'; next = strtol(digbuf, NULL, 8); if (itersrc.bytepos < srclen && digcount < 3) pending = 1; break; default: next = c; } } STRING_iter_set_and_advance(interp, result, &iterdest, next); } while (pending); } result->bufused = iterdest.bytepos; result->strlen = iterdest.charpos; return result; } /* =item C Unescapes the specified C string. These sequences are covered: \xhh 1..2 hex digits \ooo 1..3 oct digits \cX control char X \x{h..h} 1..8 hex digits \uhhhh 4 hex digits \Uhhhhhhhh 8 hex digits \a, \b, \t, \n, \v, \f, \r, \e =cut */ PARROT_EXPORT PARROT_CANNOT_RETURN_NULL STRING * Parrot_str_unescape(PARROT_INTERP, ARGIN(const char *cstring), char delimiter, ARGIN_NULLOK(const char *enc_char)) { ASSERT_ARGS(Parrot_str_unescape) STRING *src; const STR_VTABLE *encoding, *src_encoding; size_t clength = strlen(cstring); if (delimiter && clength) --clength; if (enc_char == NULL) { encoding = Parrot_default_encoding_ptr; } else { encoding = Parrot_find_encoding(interp, enc_char); if (!encoding) Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_UNIMPLEMENTED, "Can't make '%s' encoding strings", enc_char); } if (encoding->max_bytes_per_codepoint == 1) src_encoding = encoding; else src_encoding = Parrot_utf8_encoding_ptr; src = Parrot_str_new_init(interp, cstring, clength, src_encoding, PObj_external_FLAG); return Parrot_str_unescape_string(interp, src, encoding, PObj_constant_FLAG); } /* =item C Returns a copy of the specified Parrot string converted to upper case. Non-caseable characters are left unchanged. =cut */ PARROT_EXPORT PARROT_CANNOT_RETURN_NULL PARROT_MALLOC STRING * Parrot_str_upcase(PARROT_INTERP, ARGIN_NULLOK(const STRING *s)) { ASSERT_ARGS(Parrot_str_upcase) if (STRING_IS_NULL(s)) Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_UNEXPECTED_NULL, "Can't upcase NULL string"); else { STRING * const res = STRING_upcase(interp, s); res->hashval = 0; return res; } } /* =item C Returns a copy of the specified Parrot string converted to lower case. Non-caseable characters are left unchanged. =cut */ PARROT_EXPORT PARROT_CANNOT_RETURN_NULL PARROT_MALLOC STRING * Parrot_str_downcase(PARROT_INTERP, ARGIN_NULLOK(const STRING *s)) { ASSERT_ARGS(Parrot_str_downcase) if (STRING_IS_NULL(s)) Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_UNEXPECTED_NULL, "Can't downcase NULL string"); else { STRING * const res = STRING_downcase(interp, s); res->hashval = 0; return res; } } /* =item C Returns a copy of the specified Parrot string converted to title case. Non-caseable characters are left unchanged. =cut */ PARROT_EXPORT PARROT_CANNOT_RETURN_NULL PARROT_MALLOC STRING * Parrot_str_titlecase(PARROT_INTERP, ARGIN_NULLOK(const STRING *s)) { ASSERT_ARGS(Parrot_str_titlecase) if (STRING_IS_NULL(s)) Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_UNEXPECTED_NULL, "Can't titlecase NULL string"); else { STRING * const res = STRING_titlecase(interp, s); res->hashval = 0; return res; } } /* =item C Returns a C string from a Parrot string. Both sides are treated as constants -- i.e. do not resize the result. =cut */ PARROT_EXPORT PARROT_PURE_FUNCTION PARROT_CANNOT_RETURN_NULL const char * Parrot_str_cstring(SHIM_INTERP, ARGIN(const STRING *str)) { ASSERT_ARGS(Parrot_str_cstring) /* TODO handle NULL and friends */ return str->strstart; } /* =item C Returns 1 if the codepoint of string C at given offset is in the given character class C. See also F for possible character classes. Returns 0 otherwise, or if the string is empty or NULL. =cut */ PARROT_EXPORT PARROT_WARN_UNUSED_RESULT INTVAL Parrot_str_is_cclass(PARROT_INTERP, INTVAL flags, ARGIN(const STRING *s), UINTVAL offset) { ASSERT_ARGS(Parrot_str_is_cclass) if (!Parrot_str_byte_length(interp, s)) return 0; return STRING_is_cclass(interp, flags, s, offset); } /* =item C Finds the first occurrence of the given character class in C in the string, and returns its glyph-wise index. =cut */ PARROT_EXPORT PARROT_WARN_UNUSED_RESULT INTVAL Parrot_str_find_cclass(PARROT_INTERP, INTVAL flags, ARGIN_NULLOK(const STRING *s), UINTVAL offset, UINTVAL count) { ASSERT_ARGS(Parrot_str_find_cclass) if (STRING_IS_NULL(s)) return -1; return STRING_find_cclass(interp, flags, s, offset, count); } /* =item C Finds the first occurrence of the a character I in the given character class in C in the string starting from C and looking at C positions, and returns its glyph-wise index. Returns C, if not found. =cut */ PARROT_EXPORT PARROT_WARN_UNUSED_RESULT INTVAL Parrot_str_find_not_cclass(PARROT_INTERP, INTVAL flags, ARGIN_NULLOK(const STRING *s), UINTVAL offset, UINTVAL count) { ASSERT_ARGS(Parrot_str_find_not_cclass) if (STRING_IS_NULL(s)) return -1; return STRING_find_not_cclass(interp, flags, s, offset, count); } /* =item C Converts C to the given encoding and returns the result as a new string. =cut */ PARROT_EXPORT PARROT_WARN_UNUSED_RESULT PARROT_CAN_RETURN_NULL STRING* Parrot_str_change_encoding(PARROT_INTERP, ARGMOD_NULLOK(STRING *src), INTVAL encoding_nr) { ASSERT_ARGS(Parrot_str_change_encoding) const STR_VTABLE *new_encoding; if (STRING_IS_NULL(src)) return STRINGNULL; new_encoding = Parrot_get_encoding(interp, encoding_nr); if (!new_encoding) Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_ENCODING, "encoding #%d not found", (int) encoding_nr); if (new_encoding == src->encoding) return src; return new_encoding->to_encoding(interp, src); } /* =item C Normalizes the string. =cut */ PARROT_EXPORT PARROT_WARN_UNUSED_RESULT PARROT_CANNOT_RETURN_NULL STRING * Parrot_str_compose(PARROT_INTERP, ARGIN_NULLOK(const STRING *src)) { ASSERT_ARGS(Parrot_str_compose) if (STRING_IS_NULL(src)) return STRINGNULL; if (src->strlen == 0) return CONST_STRING(interp, ""); return STRING_compose(interp, src); } /* =item C Joins the elements of the array C as strings with the string C between them, returning the result. =cut */ PARROT_EXPORT PARROT_WARN_UNUSED_RESULT PARROT_CANNOT_RETURN_NULL STRING* Parrot_str_join(PARROT_INTERP, ARGIN_NULLOK(STRING *j), ARGIN(PMC *ar)) { ASSERT_ARGS(Parrot_str_join) if (STRING_IS_NULL(j)) { PMC *sb = Parrot_pmc_new_init(interp, enum_class_StringBuilder, ar); return VTABLE_get_string(interp, sb); } else { PMC *sb; STRING *first; const int count = VTABLE_elements(interp, ar); INTVAL length, j_length; int i; if (count == 0) return Parrot_str_new_noinit(interp, 0); first = VTABLE_get_string_keyed_int(interp, ar, 0); length = Parrot_str_byte_length(interp, first); j_length = Parrot_str_byte_length(interp, j); /* it's an approximation, but it doesn't hurt */ sb = Parrot_pmc_new_init_int(interp, enum_class_StringBuilder, (length + j_length) * count); VTABLE_push_string(interp, sb, first); for (i = 1; i < count; ++i) { STRING *part = VTABLE_get_string_keyed_int(interp, ar, i); if (j_length) VTABLE_push_string(interp, sb, j); if (part->strlen) VTABLE_push_string(interp, sb, part); } return VTABLE_get_string(interp, sb); } } /* =item C Splits the string C at the delimiter C, returning a C, or his mapped type in the current HLL, of results. Returns PMCNULL if the string or the delimiter is NULL. =cut */ PARROT_EXPORT PARROT_WARN_UNUSED_RESULT PARROT_CANNOT_RETURN_NULL PMC* Parrot_str_split(PARROT_INTERP, ARGIN_NULLOK(const STRING *delim), ARGIN_NULLOK(const STRING *str)) { ASSERT_ARGS(Parrot_str_split) PMC *res; STRING *tstr; UINTVAL slen, dlen; String_iter iter; if (STRING_IS_NULL(delim) || STRING_IS_NULL(str)) return PMCNULL; res = Parrot_pmc_new(interp, Parrot_hll_get_ctx_HLL_type(interp, enum_class_ResizableStringArray)); slen = Parrot_str_length(interp, str); if (!slen) return res; STRING_ITER_INIT(interp, &iter); dlen = Parrot_str_length(interp, delim); if (dlen == 0) { VTABLE_set_integer_native(interp, res, slen); do { const String_iter old_iter = iter; STRING_iter_skip(interp, str, &iter, 1); tstr = Parrot_str_iter_substr(interp, str, &old_iter, &iter); VTABLE_set_string_keyed_int(interp, res, old_iter.charpos, tstr); } while (iter.charpos < slen); return res; } do { String_iter start, end; start = iter; if (Parrot_str_iter_index(interp, str, &start, &end, delim) < 0) break; tstr = Parrot_str_iter_substr(interp, str, &iter, &start); VTABLE_push_string(interp, res, tstr); iter = end; } while (iter.charpos < slen); tstr = Parrot_str_iter_substr(interp, str, &iter, NULL); VTABLE_push_string(interp, res, tstr); return res; } /* =item C Returns C converted to a Parrot C. Note that C must be defined (a default of 10 is not assumed). The caller has to verify that C<< base >= 2 && base <= 36 >> The buffer C must be at least C chars big. If C is true, then C<-> is prepended to the string representation. =cut */ PARROT_WARN_UNUSED_RESULT PARROT_CANNOT_RETURN_NULL STRING* Parrot_str_from_uint(PARROT_INTERP, ARGOUT(char *tc), UHUGEINTVAL num, unsigned int base, int minus) { ASSERT_ARGS(Parrot_str_from_uint) /* the buffer must be at least as long as this */ char *p = tc + sizeof (UHUGEINTVAL)*8 + 1; const char * const tail = p; PARROT_ASSERT(base >= 2 && base <= 36); do { const char cur = (char)(num % base); if (cur < 10) *--p = (char)('0' + cur); else *--p = (char)('a' + cur - 10); } while (num /= base); if (minus) *--p = '-'; return Parrot_str_new_init(interp, p, (UINTVAL)(tail - p), Parrot_default_encoding_ptr, 0); } /* =item C Returns C converted to a Parrot C. Note that C must be defined (a default of 10 is not assumed). If C<< num < 0 >>, then C<-> is prepended to the string representation. =cut */ PARROT_WARN_UNUSED_RESULT PARROT_CANNOT_RETURN_NULL STRING * Parrot_str_from_int_base(PARROT_INTERP, ARGOUT(char *tc), HUGEINTVAL num, unsigned int base) { ASSERT_ARGS(Parrot_str_from_int_base) const int is_neg = (num < 0); if (is_neg) num = -num; return Parrot_str_from_uint(interp, tc, (UHUGEINTVAL)num, base, is_neg); } /* =back =head2 GC registry interface =over 4 =item C Registers the STRING from the interpreter's GC registry to prevent it from being collected. =cut */ PARROT_EXPORT void Parrot_str_gc_register(PARROT_INTERP, ARGIN(STRING *s)) { ASSERT_ARGS(Parrot_str_gc_register) /* Better not trigger a GC run with a potentially unanchored PMC */ Parrot_block_GC_mark(interp); PARROT_ASSERT(interp->gc_registry); VTABLE_set_pmc_keyed_str(interp, interp->gc_registry, s, PMCNULL); Parrot_unblock_GC_mark(interp); } /* =item C Unregisters the STRING from the interpreter's GC registry. =cut */ PARROT_EXPORT void Parrot_str_gc_unregister(PARROT_INTERP, ARGIN(STRING *s)) { ASSERT_ARGS(Parrot_str_gc_unregister) PARROT_ASSERT(interp->gc_registry); VTABLE_delete_keyed_str(interp, interp->gc_registry, s); } /* =back =head1 SEE ALSO =over =item F =item F =item F =back =cut */ /* * Local variables: * c-file-style: "parrot" * End: * vim: expandtab shiftwidth=4 cinoptions='\:2=2' : */ Default.pir000644000765000765 1761211567202623 22364 0ustar00bruce000000000000parrot-6.6.0/runtime/parrot/library/Data/Dumper =head1 TITLE Data::Dumper::Default - The default output module of Data::Dumper. =head1 VERSION version 0.20 =head1 SYNOPSIS TDB =head1 DESCRIPTION This module provides the default output style of C. =cut .sub __library_data_dumper_default_onload :load .local pmc ddb_class ddb_class = get_class ['Data'; 'Dumper'; 'Default'] if null ddb_class goto create_ddb goto END create_ddb: load_bytecode 'Data/Dumper/Base.pbc' get_class $P0, ['Data'; 'Dumper'; 'Base'] subclass $P0, $P0, ['Data'; 'Dumper'; 'Default'] END: .return () .end .namespace ['Data'; 'Dumper'; 'Default'] =head1 METHODS A Data::Dumper::Default object has the following methods: =over 4 =item style."dumpWithName"( shortname, name, dump ) =cut .sub dumpWithName :method .param string shortname .param string name .param pmc dump .local int ret print "\"" print shortname print "\" => " ret = self."dump"( name, dump ) .return ( ret ) .end =item style."dumpCached"( name, dump ) =cut .sub dumpCached :method .param string name .param pmc dump print "\\" print name .return ( 1 ) .end =item style."dumpProperties"( name, dump ) =cut .sub dumpProperties :method .param string paramName .param pmc dump .local string name .local pmc prop .local int ret ret = 1 if_null dump, END prophash prop, dump if_null prop, END print " with-properties: " clone name, paramName name = concat name, ".properties()" ret = self."dump"( name, prop ) END: .return ( ret ) .end =item style.genericHash( name, hash ) Dumps a 'generic' Hash. =cut .sub genericHash :method .param string name .param pmc hash .local string indent .local string subindent .local pmc it .local string key .local pmc val .local pmc keys .local string name2 (subindent, indent) = self."newIndent"() $S0 = typeof hash print $S0 print " {" new keys, "ResizablePMCArray" it = iter hash iter_loop: unless it, iter_end shift key, it push keys, key branch iter_loop iter_end: keys."sort"() dump_loop: unless keys, dump_end print "\n" print subindent shift key, keys new val, "ResizablePMCArray" push val, name push val, key sprintf name2, "%s[\"%s\"]", val set val, hash[key] self."dumpWithName"( key, name2, val ) unless keys, dump_end print "," branch dump_loop dump_end: print "\n" print indent print "}" self."deleteIndent"() .return ( 1 ) .end =item style."dumpStringEscaped"( string, escapeChar ) Escape any characters in a string so we can re-use it as a literal. =cut .sub dumpStringEscaped :method .param pmc var .param string char .local string str str = var str = escape str print str .return ( 1 ) .end =item style."pmcDefault"( name, dump ) =cut .sub pmcDefault :method .param string name .param pmc dump .local pmc class .local string type type = typeof dump print "PMC '" print type print "' " $I0 = can dump, "__dump" if $I0 goto CAN_DUMP print "{ ... }" branch END CAN_DUMP: dump."__dump"( self, name ) END: .return ( 1 ) .end =item style."pmcIntList"( name, array ) Dumps an IntList PMC. =cut .sub pmcIntList :method .param string name .param pmc array .local string indent .local string subindent .local int size .local int pos .local pmc val .local string name2 .local int tmp (subindent, indent) = self."newIndent"() typeof name2, array print name2 print " (size:" $I0 = array print $I0 print ") [" set size, array set pos, 0 unless size, iter_end iter_loop: print "\n" print subindent new val, "ResizablePMCArray" push val, name push val, pos sprintf name2, "%s[%d]", val $I0 = array[pos] print $I0 # next array member inc pos # skip the ',' after the last element if pos >= size goto iter_end print "," # elements left? branch iter_loop iter_end: print "\n" print indent print "]" self."deleteIndent"() .return ( 1 ) .end =item style."genericArray"( name, array ) Dumps any pmc that implements an Array interface. =cut .sub genericArray :method .param string name .param pmc array .local string indent .local string subindent .local int size .local int pos .local pmc val .local string name2 .local int tmp (subindent, indent) = self."newIndent"() typeof name2, array print name2 print " (size:" $I0 = array print $I0 print ") [" size = array pos = 0 unless size, iter_end iter_loop: print "\n" print subindent val = new 'ResizablePMCArray' push val, name push val, pos sprintf name2, "%s[%d]", val set val, array[pos] self."dump"( name2, val ) # next array member inc pos # skip the ',' after the last element if pos >= size goto iter_end print "," # elements left? branch iter_loop iter_end: print "\n" print indent print "]" self."deleteIndent"() .return ( 1 ) .end =item style."genericString"( name, str ) Dumps any string-like PMC. =cut .sub genericString :method .param string name .param pmc str print "\"" self."dumpStringEscaped"( str, "\"" ) print "\"" .return ( 1 ) .end =item style."genericNumber" Dumps a generic numeric PMC. =cut .sub genericNumber :method .param string name .param pmc val print val .return ( 1 ) .end =item style."genericUndef"( name, val ) Dumps any undef PMC. =cut .sub genericUndef :method .param string name .param pmc val print "undef" .return ( 1 ) .end =item style."pmcNull"( name, val ) Dumps a Null PMC. =cut .sub pmcNull :method .param string name .param pmc val print "null" .return ( 1 ) .end =item Capture dumpe Dump a capture object. =cut .namespace ['Capture'] .sub '__dump' :method .param pmc dumper .param string label .local int hasstuff hasstuff = 0 .local string subindent, indent (subindent, indent) = dumper.'newIndent'() # Sort hash keys before dump to preseve order # Use RPA instead of RSA because RSA doesn't have 'sort' method .local pmc hash, it, keys hash = self.'hash'() keys = new ['ResizablePMCArray'] it = iter hash dump_hash_keys_loop: unless it goto dump_hash_keys_end .local string key key = shift it push keys, key goto dump_hash_keys_loop dump_hash_keys_end: keys.'sort'() it = iter keys dump_hash_loop: unless it goto dump_hash_end if hasstuff goto dump_hash_1 print " {" hasstuff = 1 dump_hash_1: print "\n" print subindent .local string key .local pmc val key = shift it val = hash[key] print "<" print key print "> => " dumper.'dump'(label, val) goto dump_hash_loop dump_hash_end: .local pmc array array = self.'list'() if null array goto dump_array_end $I1 = elements array $I0 = 0 dump_array_loop: if $I0 >= $I1 goto dump_array_end if hasstuff goto dump_array_1 print " {" hasstuff = 1 dump_array_1: print "\n" print subindent val = array[$I0] print "[" print $I0 print "] => " dumper.'dump'(label, val) inc $I0 goto dump_array_loop dump_array_end: unless hasstuff goto end print "\n" print indent print '}' end: dumper.'deleteIndent'() .end =back =head1 AUTHOR Jens Rieks Eparrot at jensbeimsurfen dot deE is the author and maintainer. Please send patches and suggestions to the Perl 6 Internals mailing list. =head1 COPYRIGHT Copyright (C) 2004-2008, Parrot Foundation. =cut # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: ack.pir000644000765000765 223311533177635 16455 0ustar00bruce000000000000parrot-6.6.0/examples/shootout#!./parrot # Copyright (C) 2005-2009, Parrot Foundation. # OUTPUT="Ack(3, 9) = 4093\n" # # ./parrot -Oc # RQ (Karl) # Seems to be an old benchmark, now deprecated by the shootout # # ackermann - ack(3, 9) is default # shootout runs ack(3, 11) # time for ack(3,11): 0.8s (AMD X2@2000) # by Leopold Toetsch .sub main :main .param pmc argv .local int argc argc = elements argv .local int x, y, r x = 3 y = 7 if argc == 1 goto go $S0 = argv[1] if argc == 2 goto xdefault x = $S0 $S0 = argv[2] y = $S0 goto go xdefault: y = $S0 go: $P0 = getinterp $P0.'recursion_limit'(100000) r = ack(x, y) .local pmc args args = new 'ResizableIntegerArray' push args, x push args, y push args, r $S0 = sprintf "Ack(%d, %d) = %d\n", args print $S0 .end .sub ack .param int x .param int y if x goto a1 $I0 = y + 1 .return ($I0) a1: if y goto a2 $I0 = x - 1 $I1 = 1 .tailcall ack($I0, $I1) a2: $I2 = y - 1 $I3 = ack(x, $I2) $I4 = x - 1 .tailcall ack($I4, $I3) .end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: data_json.pir000644000765000765 533612234733135 20115 0ustar00bruce000000000000parrot-6.6.0/compilers/data_json# Copyright (C) 2005-2011, Parrot Foundation. =head1 NAME data_json - parse JSON, a lightweight data-interchange format. =head1 DESCRIPTION Given a valid JSON (JavaScript Object Notation) string, the compiler will return a sub that when called will produce the appropriate values. For example: .local pmc json, code, result load_language 'data_json' json = compreg 'data_json' code = json.'compile'('[1,2,3]') result = code() load_bytecode 'dumper.pbc' _dumper( result, 'array' ) will create a PMC that C C containing the values 1, 2, and 3, and store it in the C. For more information about the structure of the JSON representation, see the documentation at L. =cut .HLL 'data_json' .sub '__onload' :load load_bytecode 'PGE.pbc' load_bytecode 'PGE/Util.pbc' load_bytecode 'TGE.pbc' $P1 = newclass ['JSON'; 'Compiler'] $P2 = new $P1 compreg 'data_json', $P2 $P1 = new 'Hash' $P1['\"'] = '"' $P1['\\'] = "\\" $P1['\/'] = '/' $P1['\b'] = "\b" $P1['\f'] = "\f" $P1['\n'] = "\n" $P1['\r'] = "\r" $P1['\t'] = "\t" set_root_global ['parrot'; 'data_json'], '$escapes', $P1 .end .namespace ['JSON';'Compiler'] .sub 'compile' :method .param string json_string .param pmc opts :slurpy :named .local pmc parse, match parse = get_root_global ['parrot'; 'JSON'], 'value' $P0 = get_root_global ['parrot'; 'PGE'], 'Match' match = $P0.'new'(json_string) match.'to'(0) match = parse(match) unless match goto failed .local pmc pirgrammar, pirbuilder, pir pirgrammar = new ['JSON'; 'PIR'] pirbuilder = pirgrammar.'apply'(match) pir = pirbuilder.'get'('result') $I0 = exists opts['target'] unless $I0 goto no_targ $S0 = opts['target'] unless $S0 == 'pir' goto not_pir .return (pir) not_pir: no_targ: .local pmc pirc, result pirc = compreg 'PIR' result = pirc(pir) result = result.'first_sub_in_const_table'() .return (result) failed: $P0 = new 'Exception' $P0[0] = "Invalid JSON value" throw $P0 .end .HLL 'parrot' .sub unique_pmc_reg $P0 = get_root_global ['parrot';'PGE';'Util'], 'unique' $I0 = $P0() $S0 = $I0 $S0 = concat "$P", $S0 .return ($S0) .end .sub appendln .param pmc sb .param string line push sb, line push sb, "\n" .end .sub 'sprintf' .param string fmt .param pmc args :slurpy $S0 = sprintf fmt, args .return ($S0) .end .include 'compilers/data_json/data_json/grammar.pir' .include 'compilers/data_json/data_json/pge2pir.pir' # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: osutils.pir000644000765000765 6350112134026463 20370 0ustar00bruce000000000000parrot-6.6.0/runtime/parrot/library# Copyright (C) 2009-2011, Parrot Foundation. =head1 NAME osutils - operating system utilities for Parrot =head1 SYNOPSIS .sub 'main' :main load_bytecode 'osutils.pbc' # Print current working directory $S0 = cwd() say $S0 # Make a new directory, then enter it $S1 = 'foobar' mkdir($S1) chdir($S1) .end =head1 DESCRIPTION The C library provides a procedural interface to many common shell utilities. Think of it as a watered down version of GNU coreutils for Parrot. =head1 FUNCTIONS =over 4 =cut .loadlib 'math_ops' .sub '' :init :load :anon .end =item B Executes a shell command. The first argument is a string that specifies which command to execute. The C<:verbose()> argument is an optional integer indicating whether or not to be verbose. If given, the name of the command in C will be displayed. The C<:ignore_error()> argument is also an optional integer indicating whether or not errors should be ignored. Returns the exit status of the C command. =cut .sub 'system' .param string cmd .param int verbose :named('verbose') :optional .param int has_verbose :opt_flag .param int ignore_error :named('ignore_error') :optional .param int has_ignore_error :opt_flag unless has_verbose goto L1 unless verbose goto L1 say cmd L1: $I0 = spawnw cmd unless $I0 goto L2 unless has_ignore_error goto L3 if ignore_error goto L2 L3: $S0 = "exit status: " $S1 = $I0 $S0 .= $S1 $S0 .= "\ncommand: " $S0 .= cmd $S0 .= "\n" die $S0 L2: .return ($I0) .end .loadlib 'io_ops' .include 'stat.pasm' =item B Returns an integer value indicating whether or not the file in C exists. A value of 1 means that it does exist while a value of 0 means that it does not. =cut .sub 'file_exists' .param string filename $I0 = stat filename, .STAT_EXISTS .return ($I0) .end =item B =item B =item B Checks whether or not the file in C is newer than the file in C. If either of the arguments are aggregates (i.e. array or hash), then C checks whether or not I the file(s) in C are newer than I the file(s) in C. Returns 1 if C is newer than C and 0 if it's not. If the file in C doesn't exist, then 0 is returned. =cut .sub 'newer' :multi(string, pmc) .param string target .param pmc depend $I0 = does depend, 'array' if $I0 goto L1 $S0 = depend .tailcall newer(target, $S0) L1: $I0 = stat target, .STAT_EXISTS unless $I0 goto L2 $I0 = stat target, .STAT_FILESIZE unless $I0 goto L2 goto L3 L2: .return (0) L3: $I0 = stat target, .STAT_MODIFYTIME $P0 = iter depend L4: unless $P0 goto L5 $S0 = shift $P0 if $S0 == '' goto L4 $I1 = stat $S0, .STAT_MODIFYTIME if $I1 < $I0 goto L4 .return (0) L5: .return (1) .end .sub 'newer' :multi(string, string) .param string target .param string depend $I0 = stat target, .STAT_EXISTS unless $I0 goto L1 $I0 = stat target, .STAT_FILESIZE unless $I0 goto L1 goto L2 L1: .return (0) L2: $I1 = stat target, .STAT_MODIFYTIME $I2 = stat depend, .STAT_MODIFYTIME $I0 = $I1 > $I2 .return ($I0) .end .sub 'newer' :multi(pmc, pmc) .param pmc target .param pmc depend $S0 = target .tailcall newer($S0, depend) .end =item B Creates the file path given in C. The C<:verbose()> argument is an optional integer which indicates whether or not to be verbose. If given, the string I will be displayed along with each directory name as it is created. =cut .sub 'mkpath' .param string pathname .param int verbose :named('verbose') :optional $I1 = 1 L1: $I1 = index pathname, '/', $I1 if $I1 < 0 goto L2 $S0 = substr pathname, 0, $I1 inc $I1 $I0 = stat $S0, .STAT_EXISTS if $I0 goto L1 $I0 = length $S0 if $I0 != 2 goto L3 $I0 = index $S0, ':' if $I0 == 1 goto L1 L3: mkdir($S0, verbose :named('verbose')) goto L1 L2: $I0 = stat pathname, .STAT_EXISTS if $I0 goto L4 mkdir(pathname, verbose :named('verbose')) L4: .end =item B Creates the directory given in C if it does not already exist. The C<:verbose()> argument is an optional integer indicating whether or not to be verbose. If given, the string I> will be displayed. An exception is thrown if C already exists. Note that unlike C, subdirectories cannot be created at the same time. For example, creating C will fail with C but will succeed with C. In this case, C must be created first, then C (in that order), before C can be created. =cut .sub 'mkdir' .param string dirname .param int verbose :named('verbose') :optional .param int has_verbose :opt_flag unless has_verbose goto L1 unless verbose goto L1 print "mkdir " say dirname L1: $P0 = new 'OS' $I1 = 0o775 push_eh _handler $P0.'mkdir'(dirname, $I1) pop_eh .return () _handler: .local pmc e .get_results (e) $S0 = "Can't mkdir '" $S0 .= dirname $S0 .= "' (" $S1 = err $S0 .= $S1 $S0 .= ")\n" e = $S0 rethrow e .end =item B Copies the file given in C to C and sets attributes. The C<:exe()> argument is an optional integer which indicates whether or not to set the executable mode bit for all users for the file given in C. The C<:verbose()> argument is an optional integer which indicates whether or not to be verbose. If given, each step during the installation process will be displayed. =cut .include 'iglobals.pasm' .sub 'install' .param string src .param string dst .param int exe :named('exe') :optional .param int has_exe :opt_flag .param int verbose :named('verbose') :optional $I1 = 1 L1: $I1 = index dst, '/', $I1 if $I1 < 0 goto L2 $S0 = substr dst, 0, $I1 inc $I1 $I0 = stat $S0, .STAT_EXISTS if $I0 goto L1 mkdir($S0, verbose :named('verbose')) goto L1 L2: $I0 = newer(dst, src) if $I0 goto L3 $I0 = stat dst, .STAT_EXISTS unless $I0 goto L4 unlink(dst, verbose :named('verbose')) L4: cp(src, dst, verbose :named('verbose')) unless has_exe goto L3 unless exe goto L3 $P0 = getinterp $P0 = $P0[.IGLOBALS_CONFIG_HASH] $I0 = $P0['win32'] if $I0 goto L3 chmod(dst, 0o755, verbose :named('verbose')) L3: .end =item B Copies the file given in C to C. The copy is completely independent of the original. The C<:verbose()> argument is an optional integer indicating whether or not to be verbose. If given, the string I C> will be displayed. The C file must be readable and the C file must be writable. If not, an exception will be thrown. Note that unlike the C shell command, the second argument I be a directory. For example, to copy C to C, C must be called as C. =cut .sub 'cp' .param string src .param string dst .param int verbose :named('verbose') :optional .param int has_verbose :opt_flag unless has_verbose goto L1 unless verbose goto L1 print "cp " print src print " " say dst L1: $P0 = new 'FileHandle' $P0.'encoding'('binary') push_eh _handler1 $S0 = $P0.'readall'(src) pop_eh push_eh _handler2 $P0.'open'(dst, 'w') pop_eh $P0.'print'($S0) $P0.'close'() .return () _handler1: .local pmc e .get_results (e) $S0 = "Can't open '" $S0 .= src $S0 .= "' (" $S1 = err $S0 .= $S1 $S0 .= ")\n" e = $S0 rethrow e _handler2: .local pmc e .get_results (e) $S0 = "Can't open '" $S0 .= dst $S0 .= "' (" $S1 = err $S0 .= $S1 $S0 .= ")\n" e = $S0 rethrow e .end =item B Changes the file mode bits for C according to C. The second argument, C, is an octal number representing the bit pattern for the new mode bits. The C<:verbose()> argument is an optional integer which indicates whether or not to be verbose. If given, the string I C> will be displayed. A full discussion of file permissions and mode bits is outside the scope of this reference. For a more in-depth explanation, see the L man page. Note that unlike the C shell command, the C argument I alternatively be a symbolic string representation of the changes to make. =cut .sub 'chmod' .param string filename .param int mode .param int verbose :named('verbose') :optional .param int has_verbose :opt_flag unless has_verbose goto L1 unless verbose goto L1 $P0 = new 'ResizablePMCArray' push $P0, mode $S0 = sprintf '%o', $P0 print "chmod " print filename print " 0o" say $S0 L1: $P0 = new 'OS' $P0.'chmod'(filename, mode) .end =item B =item B Removes a link to the file given in C. The C<:verbose()> argument is an optional integer indicating whether or not to be verbose. If given, the string I> will be displayed. If the file's link count becomes 0, its contents will be removed. Note that if one or more processes currently have the file open, it is not actually removed until those processes have been terminated. If C is a symbolic link, then only the link itself is removed and will not affect the file that it points to. =cut .sub 'unlink' :multi(string) .param string filename .param int verbose :named('verbose') :optional .param int has_verbose :opt_flag $I0 = stat filename, .STAT_EXISTS unless $I0 goto L1 $I0 = stat filename, .STAT_ISREG unless $I0 goto L1 unless has_verbose goto L2 unless verbose goto L2 print "unlink " say filename L2: new $P0, 'OS' push_eh _handler $P0.'unlink'(filename) pop_eh L1: .return () _handler: .local pmc e .get_results (e) $S0 = "Can't remove '" $S0 .= filename $S0 .= "' (" $S1 = err $S0 .= $S1 $S0 .= ")\n" e = $S0 rethrow e .end .sub 'unlink' :multi(pmc) .param pmc filename .param int verbose :named('verbose') :optional $I0 = does filename, 'array' if $I0 goto L1 $S0 = filename unlink($S0, verbose :named('verbose')) goto L2 L1: $P0 = iter filename L3: unless $P0 goto L2 $S0 = shift $P0 unlink($S0, verbose :named('verbose')) goto L3 L2: .end =item B Removes the directory path given in C. The C<:verbose()> argument is an optional integer indicating whether or not to be verbose. If given, the string I> will be displayed. =cut .sub 'rmtree' .param string path .param int verbose :named('verbose') :optional .param int has_verbose :opt_flag $I0 = stat path, .STAT_EXISTS unless $I0 goto L1 $I0 = stat path, .STAT_ISDIR unless $I0 goto L1 unless has_verbose goto L2 unless verbose goto L2 print "rmtree " say path L2: new $P0, 'OS' $P1 = $P0.'readdir'(path) push_eh _handler L3: unless $P1 goto L4 $S0 = shift $P1 if $S0 == '.' goto L3 if $S0 == '..' goto L3 $S1 = path . '/' $S1 .= $S0 $I0 = stat $S1, .STAT_ISDIR unless $I0 goto L5 rmtree($S1) goto L3 L5: $P0.'unlink'($S1) goto L3 L4: push_eh _handler $S1 = path $P0.'rmdir'($S1) pop_eh L1: .return () _handler: .local pmc e .get_results (e) $S0 = "Can't remove '" $S0 .= $S1 $S0 .= "' (" $S1 = err $S0 .= $S1 $S0 .= ")\n" e = $S0 rethrow e .end =item B Returns C with all leading directory components removed. Put differently, it returns the filename portion of C. =cut .sub 'basename' .param string path $I0 = 0 L1: $I1 = index path, '/', $I0 if $I1 < 0 goto L2 $I0 = $I1 + 1 goto L1 L2: $S0 = substr path, $I0 .return ($S0) .end =item B Returns C with the trailing component removed. Put differently, it returns the directory portion of C. If C contains no /'s, then "." (the current working directory) is returned. =cut .sub 'dirname' .param string path unless path goto L3 $I0 = 0 L1: $I1 = index path, '/', $I0 if $I1 < 0 goto L2 $I0 = $I1 + 1 goto L1 L2: dec $I0 unless $I0 > 0 goto L3 $S0 = substr path, 0, $I0 .return ($S0) L3: .return ('.') .end =item BB<(>B<)> Returns the pathname of the current working directory. =cut .sub 'cwd' new $P0, 'OS' $S0 = $P0.'cwd'() $P0 = split "\\", $S0 $S0 = join "/", $P0 .return ($S0) .end =item B Changes the current working directory to C. The C<:verbose()> argument is an optional integer indicating whether or not to be verbose. If given, the string I> will be displayed. Note that unlike the C shell command, not specifying a directory I change the working directory to the home directory. =cut .sub 'chdir' .param string dirname .param int verbose :named('verbose') :optional .param int has_verbose :opt_flag unless has_verbose goto L1 unless verbose goto L1 print "chdir " say dirname L1: new $P0, 'OS' push_eh _handler $P0.'chdir'(dirname) pop_eh .return () _handler: .local pmc e .get_results (e) $S0 = "Can't chdir '" $S0 .= dirname $S0 .= "' (" $S1 = err $S0 .= $S1 $S0 .= ")\n" e = $S0 rethrow e .end =item B Behaves similar to the C function in Perl by removing any trailing newline characters from C. Regardless of operating system, trims the last 2 chars if they are \r\n, or trims the last char if it is \n. =cut .include 'cclass.pasm' .sub 'chomp' .param string str .local int len, pos_n, pos_r, pos_char_last, pos_char_next_to_last len = length str if len == 0 goto trim_0 # Return original empty string pos_char_last = len - 1 pos_char_next_to_last = len - 2 pos_n = index str, "\n", pos_char_last if pos_n == -1 goto trim_0 # Does not end in \n; return original. if len == 1 goto trim_1 # str eq "\n"; remove only char. pos_r = index str, "\r", pos_char_next_to_last if pos_r == -1 goto trim_1 # Ends in \n not \r\n; remove last 1 char. goto trim_2 # Ends in \r\n; remove last 2 chars. trim_0: .return (str) trim_1: str = replace str, -1, 1, "" .return (str) trim_2: str = replace str, -2, 2, "" .return (str) .end =item B Searches the current working directory for all the pathnames matching C. For more information about pattern matching and wilcard expansion, see the C man page. Returns a (possibly empty) C of all the matched pathnames. =cut .sub 'glob' .param string patterns $P0 = new 'ResizableStringArray' $P1 = split ' ', patterns L1: unless $P1 goto L2 .local string pattern pattern = shift $P1 $I0 = index pattern, '*' unless $I0 < 0 goto L3 $I0 = index pattern, '?' unless $I0 < 0 goto L3 $I0 = index pattern, '[' unless $I0 < 0 goto L3 $I0 = stat pattern, .STAT_EXISTS unless $I0 goto L1 push $P0, pattern goto L1 L3: .local pmc matcher load_bytecode 'PGE/Glob.pbc' $P2 = compreg 'PGE::Glob' matcher = $P2.'compile'(pattern) $S0 = dirname(pattern) $P3 = glob($S0) $P4 = new 'OS' L4: unless $P3 goto L1 .local string dir dir = shift $P3 $I0 = stat dir, .STAT_ISDIR unless $I0 goto L4 $S0 = basename(dir) $P5 = $P4.'readdir'(dir) L5: unless $P5 goto L4 $S0 = shift $P5 if $S0 == '.' goto L5 if $S0 == '..' goto L5 if dir == '.' goto L6 $S1 = dir . '/' $S0 = $S1 . $S0 L6: $P6 = matcher($S0) unless $P6 goto L5 push $P0, $S0 goto L5 L2: .return ($P0) .end =item B Searches the environment list for the environment variable given in C. Returns a string representing the value of C. If the C environment variable is not defined, an empty string will be returned. =cut .sub 'getenv' .param string name new $P0, 'Env' $S0 = $P0[name] .return ($S0) .end =item B Adds or changes an environment variable. If the C environment variable does not already exist, it will be added. However, if C I already exist, its value is changed to C. The C<:verbose()> argument is an optional integer indicating whether or not to be verbose. If given, the string I = C> will be displayed. =cut .sub 'setenv' .param string name .param string value .param int verbose :named('verbose') :optional .param int has_verbose :opt_flag unless has_verbose goto L1 unless verbose goto L1 print "setenv " print name print " = " say value L1: new $P0, 'Env' $P0[name] = value .end =item B Reads the entire contents of the file given in C. The C<:encoding()> argument is an optional string containing the character encoding used by C. An exception is thrown if C does not exist. The C file must already exist and be readable. If not, an exception will be thrown. Returns the contents of C as a string. =cut .sub 'slurp' .param string filename .param string encoding :named('encoding') :optional .param int has_encoding :opt_flag $P0 = new 'FileHandle' unless has_encoding goto L1 $P0.'encoding'(encoding) L1: push_eh _handler $S0 = $P0.'readall'(filename) pop_eh .return ($S0) _handler: .local pmc e .get_results (e) $S0 = "Can't open '" $S0 .= filename $S0 .= "' (" $S1 = err $S0 .= $S1 $S0 .= ")\n" e = $S0 rethrow e .end =item B Creates a new file called C and writes the contents of C to it. If C already exists, its contents will be truncated to length 0 before writing. The C<:verbose()> argument is an optional integer indicating whether or not to be verbose. If given, the string I> will be displayed. =cut .sub 'spew' .param string filename .param string content .param int verbose :named('verbose') :optional .param int has_verbose :opt_flag unless has_verbose goto L1 unless verbose goto L1 print "spew " say filename L1: $P0 = new 'FileHandle' push_eh _handler $P0.'open'(filename, 'w') pop_eh $P0.'print'(content) $P0.'close'() .return () _handler: .local pmc e .get_results (e) $S0 = "Can't open '" $S0 .= filename $S0 .= "' (" $S1 = err $S0 .= $S1 $S0 .= ")\n" e = $S0 rethrow e .end =item B Appends the contents of C to the file given in C. If C does not exist, it will be created under the same conditions as C. The C<:verbose()> argument is an optional integer indicating whether or not to be verbose. If given, the string I> will be displayed. =cut .sub 'append' .param string filename .param string content .param int verbose :named('verbose') :optional .param int has_verbose :opt_flag unless has_verbose goto L1 unless verbose goto L1 print "append " say filename L1: $P0 = new 'FileHandle' push_eh _handler $P0.'open'(filename, 'a') pop_eh $P0.'print'(content) $P0.'close'() .return () _handler: .local pmc e .get_results (e) $S0 = "Can't open '" $S0 .= filename $S0 .= "' (" $S1 = err $S0 .= $S1 $S0 .= ")\n" e = $S0 rethrow e .end =item B Returns a string representing a unique filename that can be used for creating a temporary file. The format of the filename is C where C represents 3 random characters. Optionally, the C<:SUFFIX()> argument may be given which will append the string to the filename. For example, the call C could create a filename like C. =cut .sub 'tempdir' .param string suffix :named('SUFFIX') :optional .param int has_suffix :opt_flag $S0 = tmpdir() $S0 .= '/TEMPXXX' unless has_suffix goto L1 $S0 .= suffix L1: .tailcall _gettemp($S0) .end .sub '_gettemp' :anon .param string template $P0 = split "/", template $S0 = pop $P0 .const string TEMPCHARS = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" $P1 = split '', TEMPCHARS $I1 = elements $P1 dec $I1 REDO: $S1 = '' $P2 = split '', $S0 L1: unless $P2 goto L2 $S2 = shift $P2 unless $S2 == 'X' goto L3 $I0 = rand $I1 $S2 = $P1[$I0] L3: $S1 .= $S2 goto L1 L2: push $P0, $S1 $S0 = join "/", $P0 $I0 = stat $S0, .STAT_EXISTS if $I0 goto REDO .return ($S0) .end .sub 'tmpdir' .local pmc env, dirlist env = new 'Env' dirlist = new 'ResizableStringArray' $P0 = getinterp $P0 = $P0[.IGLOBALS_CONFIG_HASH] $I0 = $P0['win32'] unless $I0 goto L1 $I0 = exists env['TMPDIR'] unless $I0 goto L2 $S0 = env['TMPDIR'] push dirlist, $S0 L2: $I0 = exists env['TEMP'] unless $I0 goto L3 $S0 = env['TEMP'] push dirlist, $S0 L3: $I0 = exists env['TMP'] unless $I0 goto L4 $S0 = env['TMP'] push dirlist, $S0 L4: push dirlist, 'c:/system/temp' push dirlist, 'c:/temp' push dirlist, '/tmp' push dirlist, '/' goto L5 L1: $I0 = exists env['TMPDIR'] unless $I0 goto L6 $S0 = env['TMPDIR'] push dirlist, $S0 L6: push dirlist, '/tmp' L5: unless dirlist goto L7 $S0 = shift dirlist $I0 = stat $S0, .STAT_EXISTS unless $I0 goto L5 $I0 = stat $S0, .STAT_ISDIR unless $I0 goto L5 $P0 = split "\\", $S0 $S0 = join "/", $P0 .return ($S0) L7: .end =item B Compresses the file given in C using the Lempel-Ziv algorithm. This replaces the file with one with the C<.gz> extension. An exception is thrown if C does not exist. For more information, see the C man page. =cut .sub 'gzip' .param string filename .param int verbose :named('verbose') :optional .param int has_verbose :opt_flag unless has_verbose goto L1 unless verbose goto L1 print "gzip " say filename L1: .local pmc fh, gh fh = new 'FileHandle' fh.'encoding'('binary') push_eh _handler1 $S0 = fh.'readall'(filename) $I0 = length $S0 pop_eh $P0 = loadlib 'gziphandle' push_eh _handler2 gh = new 'GzipHandle' $S1 = filename . '.gz' gh.'open'($S1, 'wb') gh.'print'($S0) gh.'close'() unlink(filename) .return () _handler1: .local pmc e .get_results (e) $S0 = "Can't open '" $S0 .= filename $S0 .= "' (" $S1 = err $S0 .= $S1 $S0 .= ")\n" e = $S0 rethrow e _handler2: .local pmc e .get_results (e) $S0 = "Can't gzip '" $S0 .= filename $S0 .= "'\n" e = $S0 rethrow e .end =item B Concatenates the directory names and filename in C. The C<:native()> argument is an optional integer indicating whether or not to use the native path separator. The default is C. Returns a string representing a complete path ending with a filename. =cut .sub 'catfile' .param pmc args :slurpy .param int native :named('native') :optional .param int has_native :opt_flag .local string slash slash = '/' unless has_native goto L1 unless native goto L1 $P0 = getinterp $P0 = $P0[.IGLOBALS_CONFIG_HASH] slash = $P0['slash'] L1: $S0 = join slash, args .return ($S0) .end =item B Returns a string representing the path given in C split into volume, directory, and filename portions. On systems that don't have the concept of "volumes", returns '' for the volume portion. =cut .sub 'splitpath' .param string path .local string volume, directories, file volume = '' $I0 = index path, ':' unless $I0 == 1 goto L1 volume = substr path, 0, 2 path = substr path, 2 L1: $I0 = 0 L2: $I1 = index path, '/', $I0 if $I1 < 0 goto L3 $I0 = $I1 + 1 goto L2 L3: file = substr path, $I0 directories = '' dec $I0 unless $I0 > 0 goto L4 directories = substr path, 0, $I0 L4: .return (volume, directories, file) .end =back =head1 AUTHOR Francois Perrad =cut # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: parrot.el000644000765000765 151311533177634 14617 0ustar00bruce000000000000parrot-6.6.0/editor;;; Emacs support for working on the source code of the Parrot virtual ;;; machine. ;; ;; Note that the support for editing pasm files is currently in the separate ;; file "pasm.el". This file is for editing the Parrot VM source. ;; ;; To use this file, copy it to a known location and add this statement to ;; your .emacs file: ;; ;; (load-file "/known/location/parrot.el") ;; (c-add-style "parrot" '("stroustrup" (indent-tabs-mode . nil) (fill-column . 100) (c-offsets-alist . ( (label . *) (access-label . *) (case-label . *) (statement-case-intro . *) (inextern-lang . 0) )))) (setq auto-mode-alist (cons '("\\.pmc$" . c-mode) auto-mode-alist)) (setq auto-mode-alist (cons '("\\.ops$" . perl-mode) auto-mode-alist)) 22_string_ops_length.pir000644000765000765 120212101554066 21711 0ustar00bruce000000000000parrot-6.6.0/examples/tutorial# Copyright (C) 2007-2012, Parrot Foundation. =pod =head1 DESCRIPTION A tutorial lesson about Parrot's string operations (continued). =head1 STRING OPERATIONS To find the length of a string in PIR, use the length opcode. It works on any variable containing a basic Parrot string, but not the String PMC. C returns an integer value, and 0 means an empty string. =cut .sub main :main $S0 = "Hello" $I0 = length $S0 say $I0 .local string text text = "longer string" $I1 = length text say $I1 .end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: sockaddr.t000644000765000765 231111567202625 14472 0ustar00bruce000000000000parrot-6.6.0/t/pmc#!./parrot # Copyright (C) 2006-2010, Parrot Foundation. =head1 NAME t/pmc/sockaddr.t - test the Sockaddr PMC =head1 SYNOPSIS % prove t/pmc/sockaddr.t =head1 DESCRIPTION Test the Sockaddr PMC. =cut .sub main :main .include 'test_more.pir' plan(8) test_basic() test_bool() test_string() .end .sub test_basic new $P0, ['Socket'] ok(1, 'Instantiated a Socket PMC') $P1 = $P0."sockaddr"("localhost", 1234) ok(1, 'socket.sockaddr method successful') $I0 = isnull $P0 $I0 = not $I0 ok($I0, 'Sockaddr PMC created') $S0 = typeof $P1 is($S0, 'Sockaddr', 'PMC has correct type') $P2 = clone $P1 $S2 = typeof $P2 is($S2, 'Sockaddr', 'PMC clone has correct type') .end .sub test_bool $P0 = new 'Socket' $P1 = $P0."sockaddr"("localhost", 1234) ok($P1, 'get_bool on a SockAddr') .end .sub test_string $P0 = new 'Socket' $P1 = $P0."sockaddr"("localhost", 1234) is($P1,"127.0.0.1:1234","sockaddr stringification") null $S0 $P1 = $P0."sockaddr"($S0, 56789) is($P1,"127.0.0.1:56789","sockaddr stringification") .end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: foo-03.t000644000765000765 105211606346660 14421 0ustar00bruce000000000000parrot-6.6.0/t/dynpmc#!./parrot # Copyright (C) 2011, Parrot Foundation. .sub main :main .include 'test_more.pir' plan(1) ## load a relative pathname without the extension. loadlib will convert the ## '/' characters to '\\' on windows. $S0 = "runtime/parrot/dynext/foo_group" loadlib $P1, $S0 ## ensure that we can still make Foo instances. $P1 = new "Foo" $I1 = $P1 is($I1, 42, 'test loadlib with relative pathname, no ext') .end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: update_copyright.pl000755000765000765 263011606346603 17324 0ustar00bruce000000000000parrot-6.6.0/tools/dev#! perl # Copyright (C) 2008, Parrot Foundation. use strict; use warnings; use Fatal qw( open close ); =head1 NAME F =head1 DESCRIPTION Given a list of files as command line arguments, update the copyright notice to go from the earliest year noted to the current year. Edits the files in place. You should update the copyright on a modified file before you commit it back to the repository. =cut use lib 'lib'; use Parrot::Test; # Accept a little fuzz in the original copyright notice.. my $copyright_re = qr/ Copyright \s+ \(C\) \s+ (\d\d\d\d)\s*(?:-\s*\d\d\d\d)? \s* ,? \s* The \s+ Perl \s+ Foundation\.? /xi; my $year = (localtime())[5]+1900; # loop over all the files specified on the command line foreach my $file (@ARGV) { my $contents = Parrot::Test::slurp_file( $file ); if ( $contents =~ $copyright_re) { my $old_year = $1; if ($old_year eq $year) { warn "$file already up to date.\n"; next; } else { $contents =~ s/$copyright_re/Copyright (C) $old_year-$year, Parrot Foundation./; open my $ofh, '>', $file; print {$ofh} $contents; close $ofh; } } else { warn "$file doesn't have a valid copyright line.\n"; } } # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: pir.t000644000765000765 2726511567202625 14570 0ustar00bruce000000000000parrot-6.6.0/t/examples#!perl # Copyright (C) 2005-2009, Parrot Foundation. use strict; use warnings; use lib qw( . lib ../lib ../../lib ); use Test::More; use Parrot::Test tests => 18; use Parrot::Config; =head1 NAME t/examples/pir.t - Test examples in F =head1 SYNOPSIS % prove t/examples/pir.t =head1 DESCRIPTION Test the examples in F. =head1 SEE ALSO F =head1 AUTHOR Bernhard Schmalhofer - =cut # Set up expected output for examples my %expected = ( 'circle.pir' => << 'END_EXPECTED', ******************************************************************************************************************************************************************************************************************************************************************************************************************************************************************************************************************** END_EXPECTED 'euclid.pir' => << 'END_EXPECTED', Algorithm E (Euclid's algorithm) The greatest common denominator of 96 and 64 is 32. END_EXPECTED 'hanoi.pir' => << 'END_EXPECTED', Using default size 3 for tower. | | ==== | | ====== | | == | | | | ====== | ==== | == | | | == | ====== | ==== | | | | == | | ==== | ====== | | | | == | ==== | ====== | | | | ==== == | | ====== | | == | | ==== | | ====== END_EXPECTED 'io.pir' => << 'END_EXPECTED', test4 test5 test1 test2 test3 END_EXPECTED 'local_label.pir' => << 'END_EXPECTED', Branching to '$ok' in macro 'TEST1' Branched to '$ok' in macro 'TEST1' After .TEST1 () Branching to '$ok' in macro 'TEST2' Branched to '$ok' in macro 'TEST2' Branched to 'non_local' in sub 'example' END_EXPECTED 'mandel.pir' => << 'END_EXPECTED', ................::::::::::::::::::::::::::::::::::::::::::::............... ...........::::::::::::::::::::::::::::::::::::::::::::::::::::::.......... ........::::::::::::::::::::::::::::::::::,,,,,,,:::::::::::::::::::....... .....:::::::::::::::::::::::::::::,,,,,,,,,,,,,,,,,,,,,,:::::::::::::::.... ...::::::::::::::::::::::::::,,,,,,,,,,,,;;;!:H!!;;;,,,,,,,,:::::::::::::.. :::::::::::::::::::::::::,,,,,,,,,,,,,;;;;!!/>&*|& !;;;,,,,,,,::::::::::::: ::::::::::::::::::::::,,,,,,,,,,,,,;;;;;!!//)|.*#|>/!;;;;;,,,,,,::::::::::: ::::::::::::::::::,,,,,,,,,,,,;;;;;;!!!!//>|: !:|//!!;;;;;,,,,,::::::::: :::::::::::::::,,,,,,,,,,;;;;;;;!!/>>I>>)||I# H&))>////*!;;,,,,:::::::: ::::::::::,,,,,,,,,,;;;;;;;;;!!!!/>H: #| IH&*I#/;;,,,,::::::: ::::::,,,,,,,,,;;;;;!!!!!!!!!!//>|.H: #I>!!;;,,,,:::::: :::,,,,,,,,,;;;;!/||>///>>///>>)|H %|&/;;,,,,,::::: :,,,,,,,,;;;;;!!//)& :;I*,H#&||&/ *)/!;;,,,,,:::: ,,,,,,;;;;;!!!//>)IH:, ## #&!!;;,,,,,:::: ,;;;;!!!!!///>)H%.** * )/!;;;,,,,,:::: &)/!!;;;,,,,,:::: ,;;;;!!!!!///>)H%.** * )/!;;;,,,,,:::: ,,,,,,;;;;;!!!//>)IH:, ## #&!!;;,,,,,:::: :,,,,,,,,;;;;;!!//)& :;I*,H#&||&/ *)/!;;,,,,,:::: :::,,,,,,,,,;;;;!/||>///>>///>>)|H %|&/;;,,,,,::::: ::::::,,,,,,,,,;;;;;!!!!!!!!!!//>|.H: #I>!!;;,,,,:::::: ::::::::::,,,,,,,,,,;;;;;;;;;!!!!/>H: #| IH&*I#/;;,,,,::::::: :::::::::::::::,,,,,,,,,,;;;;;;;!!/>>I>>)||I# H&))>////*!;;,,,,:::::::: ::::::::::::::::::,,,,,,,,,,,,;;;;;;!!!!//>|: !:|//!!;;;;;,,,,,::::::::: ::::::::::::::::::::::,,,,,,,,,,,,,;;;;;!!//)|.*#|>/!;;;;;,,,,,,::::::::::: :::::::::::::::::::::::::,,,,,,,,,,,,,;;;;!!/>&*|& !;;;,,,,,,,::::::::::::: ...::::::::::::::::::::::::::,,,,,,,,,,,,;;;!:H!!;;;,,,,,,,,:::::::::::::.. .....:::::::::::::::::::::::::::::,,,,,,,,,,,,,,,,,,,,,,:::::::::::::::.... ........::::::::::::::::::::::::::::::::::,,,,,,,:::::::::::::::::::....... ...........::::::::::::::::::::::::::::::::::::::::::::::::::::::.......... END_EXPECTED 'substr.pir' => << 'END_EXPECTED', H He Hel Hell Hello Hello Hello W Hello Wo Hello Wor Hello Worl Hello World Hello Worl Hello Wor Hello Wo Hello W Hello Hello Hell Hel He H END_EXPECTED 'sudoku.pir' => << 'END_EXPECTED', +---------+---------+---------+ | 1 . . | . . . | . . . | | . . 2 | 7 4 . | . . . | | . . . | 5 . . | . . 4 | +---------+---------+---------+ | . 3 . | . . . | . . . | | 7 5 . | . . . | . . . | | . . . | . . 9 | 6 . . | +---------+---------+---------+ | . 4 . | . . 6 | . . . | | . . . | . . . | . 7 1 | | . . . | . . 1 | . 3 . | +---------+---------+---------+ init ok +---------+---------+---------+ | 1 8 4 | 9 6 3 | 7 2 5 | | 5 6 2 | 7 4 8 | 3 1 9 | | 3 9 7 | 5 1 2 | 8 6 4 | +---------+---------+---------+ | 2 3 9 | 6 5 7 | 1 4 8 | | 7 5 6 | 1 8 4 | 2 9 3 | | 4 1 8 | 2 3 9 | 6 5 7 | +---------+---------+---------+ | 9 4 1 | 3 7 6 | 5 8 2 | | 6 2 3 | 8 9 5 | 4 7 1 | | 8 7 5 | 4 2 1 | 9 3 6 | +---------+---------+---------+ solved END_EXPECTED 'make_hello_pbc.pir' => << 'END_EXPECTED', Hello, World END_EXPECTED ); # expected output of a quine is the quine itself # TODO currently broken # $expected{'quine_ord.pir'} = Parrot::Test::slurp_file("examples/pir/quine_ord.pir"); my %skips = ( ); while ( my ( $example, $expected ) = each %expected ) { my $skip = $skips{$example}; if ($skip) { my ( $cond, $reason ) = @{$skip}; if ( eval "$cond" ) { Test::More->builder->skip("$example $reason"); next; } } example_output_is( "examples/pir/$example", $expected ); } my $PARROT = ".$PConfig{slash}$PConfig{test_prog}"; # For testing life.pir, the number of generations should be small, # because users should not get bored. { my $life_fn = "examples$PConfig{slash}pir$PConfig{slash}life.pir"; my $sum = `$PARROT $life_fn 4`; like( $sum, qr/4 generations in/, 'life ran for 4 generations' ); } # readline.pir expects something on standard input { my $readline_pir_fn = "examples$PConfig{slash}pir$PConfig{slash}readline.pir"; my $readline_tmp_fn = "test_readline.tmp"; open( my $tmp, '>', $readline_tmp_fn ); print $tmp join( "\n", 'first line', '', 'last line' ); close $tmp; my $out = `$PARROT $readline_pir_fn < $readline_tmp_fn`; is( $out, << 'END_EXPECTED', 'print until first empty line' ); first line END_EXPECTED unlink($readline_tmp_fn); } # uniq.pir expects a file that it can uniquify { my $uniq_pir_fn = "examples$PConfig{slash}pir$PConfig{slash}uniq.pir"; my $uniq_tmp_fn = "test_uniq.tmp"; open( my $tmp, '>', $uniq_tmp_fn ); print $tmp join( "\n", qw( a a a b b c d d d ) ); print $tmp "\n"; close $tmp; my $out = `$PARROT $uniq_pir_fn $uniq_tmp_fn`; is( $out, << 'END_EXPECTED', 'uniq' ); a b c d END_EXPECTED $out = `$PARROT $uniq_pir_fn -c $uniq_tmp_fn`; is( $out, << 'END_EXPECTED', 'uniq -c' ); 3 a 2 b 1 c 3 d END_EXPECTED $out = `$PARROT $uniq_pir_fn -d $uniq_tmp_fn`; is( $out, << 'END_EXPECTED', 'uniq -d' ); a b d END_EXPECTED $out = `$PARROT $uniq_pir_fn -u $uniq_tmp_fn`; is( $out, << 'END_EXPECTED', 'uniq -u' ); c END_EXPECTED unlink($uniq_tmp_fn); } ## Added test this way, so we can have more interesting tests. pir_output_is( <<'CODE', < for a slightly different glob syntax. =head2 Functions =over 4 =item C Return the result of compiling the glob expression given by C. Normally this function is obtained using C instead of calling it directly. Returns the compiled regular expression. If a C named parameter is supplied, then it will return the parse tree (target='parse'), the expression tree (target='exp'), or the resulting PIR code (target='PIR'). =cut .namespace [ 'PGE';'Glob' ] .sub 'compile_glob' .param pmc source .param pmc adverbs :slurpy :named .local string target target = adverbs['target'] target = downcase target .local pmc match null match if source == '' goto analyze $P0 = get_global 'glob' match = $P0(source) if target != 'parse' goto check .return (match) check: unless match goto check_1 $S0 = source $S1 = match if $S0 == $S1 goto analyze check_1: null $P0 .return ($P0) analyze: .local pmc exp, pad exp = new ['PGE';'Exp';'Concat'] $I0 = 1 $P0 = new ['PGE';'Exp';'Anchor'] $P0.'!make'('^') exp[0] = $P0 if null match goto analyze_1 $P0 = match['expr'] exp[$I0] = $P0 inc $I0 analyze_1: $P0 = new ['PGE';'Exp';'Anchor'] $P0.'!make'('$') exp[$I0] = $P0 .tailcall exp.'compile'(adverbs :flat :named) .end .sub 'main' :main .param pmc args load_bytecode 'PGE.pbc' load_bytecode 'PGE/Dumper.pbc' $P0 = compreg 'PGE::Glob' .tailcall $P0.'command_line'(args) .end .sub '__onload' :load :init .local pmc optable load_bytecode 'PGE.pbc' optable = new ['PGE';'OPTable'] set_global '$optable', optable $P0 = get_global 'glob_literal' optable.'newtok'('term:', 'precedence'=>'=', 'nows'=>1, 'parsed'=>$P0) $P0 = get_global 'glob_quest' optable.'newtok'('term:?', 'equiv'=>'term:', 'nows'=>1, 'parsed'=>$P0) $P0 = get_global 'glob_star' optable.'newtok'('term:*', 'equiv'=>'term:', 'nows'=>1, 'parsed'=>$P0) $P0 = get_global 'glob_enum' optable.'newtok'('term:[', 'equiv'=>'term:', 'nows'=>1, 'parsed'=>$P0) $P0 = get_global 'glob_alt' optable.'newtok'('term:{', 'equiv'=>'term:', 'nows'=>1, 'parsed'=>$P0) optable.'newtok'('infix:', 'looser'=>'term:', 'assoc'=>'list', 'nows'=>1, 'match'=>'PGE::Exp::Concat') .local pmc p6meta p6meta = get_hll_global 'P6metaclass' p6meta.'new_class'('PGE::Glob::Compiler', 'attr'=>'$!compsub') $P0 = get_global 'compile_glob' $P1 = new [ 'PGE';'Glob';'Compiler' ] $P1.'register'('PGE::Glob', $P0) .return () .end =item C Parses a glob expression, returning the corresponding parse C object. =cut .const int GLOB_INF = 2147483647 .sub 'glob' .param pmc mob .param pmc adverbs :slurpy :named .local pmc optable, match optable = get_hll_global ['PGE';'Glob'], '$optable' match = optable.'parse'(mob) .return (match) .end .sub 'scan_literal' .param string target .param int pos .param string delim .local int lastpos lastpos = length target .local string literal literal = '' literal_loop: if pos >= lastpos goto literal_end $S0 = substr target, pos, 1 $I0 = index delim, $S0 if $I0 >= 0 goto literal_end if $S0 != '\' goto literal_add inc pos $S0 = substr target, pos, 1 literal_add: literal .= $S0 inc pos goto literal_loop literal_end: .return (literal, pos) .end =item C Scan a literal from a string, stopping at any metacharacters such as C<*> or C<[>. Return the matched portion, with the I set to the decoded literal. =cut .sub 'glob_literal' .param pmc mob .param pmc adverbs :slurpy :named .local string target .local int pos (mob, pos, target) = mob.'new'(mob, 'grammar'=>'PGE::Exp::Literal') ($S0, $I0) = 'scan_literal'(target, pos, '*?[{') if $I0 <= pos goto end mob.'to'($I0) mob.'!make'($S0) end: .return (mob) .end =item C Process a C wildcard character in a glob. For this we just return a CCShortcut that is set to '.' =cut .sub 'glob_quest' .param pmc mob .param pmc adverbs :slurpy :named ## The '?' is already in mob['KEY'], so we don't need to find it here. (mob, $I0) = mob.'new'(mob, 'grammar'=>'PGE::Exp::CCShortcut') mob.'to'($I0) mob.'!make'('.') .return (mob) .end =item C Process a C<*> wildcard character in a glob. This is a little bit more complex, as we have to return a quantified '.'. =cut .sub 'glob_star' .param pmc mob .param pmc adverbs :slurpy :named .local int pos ## The '*' is already in mob['KEY'], so we don't need to find it here. ## We create a Quant object, then a CCShortcut inside of it. (mob, pos) = mob.'new'(mob, 'grammar'=>'PGE::Exp::Quant') mob.'to'(pos) mob['min'] = 0 mob['max'] = GLOB_INF $P0 = mob.'new'(mob, 'grammar'=>'PGE::Exp::CCShortcut') $P0.'to'(pos) $P0.'!make'('.') mob[0] = $P0 .return (mob) .end =item C Parse an enumerated character list, such as [abcd], [!abcd], and [^0-9]. =cut .sub glob_enum .param pmc mob .param pmc adverbs :slurpy :named .local string target .local int pos, lastpos (mob, pos, target) = mob.'new'(mob, 'grammar'=>'PGE::Exp::EnumCharList') lastpos = length target $S0 = substr target, pos, 1 if $S0 == '!' goto negate if $S0 == '^' goto negate mob['isnegated'] = 0 goto firstchar negate: mob['isnegated'] = 1 inc pos firstchar: .local string charlist charlist = '' $S0 = substr target, pos, 1 if $S0 == '-' goto addfirst if $S0 == ']' goto addfirst goto scan_loop addfirst: charlist .= $S0 inc pos scan_loop: ($S0, pos) = 'scan_literal'(target, pos, '-]') if pos >= lastpos goto err_noclose charlist .= $S0 $S0 = substr target, pos, 1 if $S0 == ']' goto scan_end inc pos $S0 = substr target, pos, 1 if $S0 == ']' goto scan_endhyphen inc pos $I1 = ord $S0 $I0 = ord charlist, -1 add_range: if $I0 > $I1 goto scan_loop $S1 = chr $I0 charlist .= $S1 inc $I0 goto add_range scan_endhyphen: charlist .= '-' scan_end: inc pos mob.'to'(pos) mob.'!make'(charlist) .return (mob) err_noclose: mob.'to'(-1) .return (mob) .end =item C Parse an enumerated character list, such as [abcd], [!abcd], and [^0-9]. =cut .sub glob_alt .param pmc mob .param pmc adverbs :slurpy :named .local string target .local int pos, lastpos (mob, pos, target) = mob.'new'(mob, 'grammar'=>'PGE::Exp::Literal') lastpos = length target ($S0, pos) = 'scan_literal'(target, pos, ',}') mob.'to'(pos) mob.'!make'($S0) alt_loop: if pos >= lastpos goto err_noclose $S0 = substr target, pos, 1 if $S0 == '}' goto end $P0 = mob.'new'(mob, 'grammar'=>'PGE::Exp::Alt') inc pos mob.'to'(pos) $P0[0] = mob mob = $P0 $P0 = mob.'new'(mob, 'grammar'=>'PGE::Exp::Literal') ($S0, pos) = 'scan_literal'(target, pos, ',}') mob.'to'(pos) $P0.'!make'($S0) mob[1] = $P0 goto alt_loop end: inc pos mob.'to'(pos) .return (mob) err_noclose: mob.'to'(-1) .return (mob) .end .namespace [ 'PGE';'Glob';'Compiler' ] =item register(string name, pmc compsub) Registers this compiler object as C and using C as the subroutine to call for performing compilation. =cut .sub 'register' :method .param string name .param pmc compsub setattribute self, '$!compsub', compsub compreg name, self .return () .end =item compile(pmc code [, "option" => value, ... ]) Compile C (possibly modified by any provided options). =cut .sub 'compile' :method .param pmc source .param pmc adverbs :slurpy :named .local pmc compsub # $!compsub is deprecated compsub = getattribute self, '$!compsub' .tailcall compsub(source, adverbs :flat :named) .end =back =head1 AUTHOR PGE::Glob was originally authored by Jonathan Scott Duff (duff@pobox.com), It has been updated for later versions of PGE by Patrick R. Michaud (pmichaud@pobox.com). =cut # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: schedulermessage.t000644000765000765 357411533177645 16245 0ustar00bruce000000000000parrot-6.6.0/t/pmc#!./parrot # Copyright (C) 2008-2010, Parrot Foundation. =head1 NAME t/pmc/schedulermessage - test the SchedulerMessage PMC =head1 SYNOPSIS % prove t/pmc/schedulermessage.t =head1 DESCRIPTION Tests the SchedulerMessage PMC. =cut .include 'except_types.pasm' .sub main :main .include 'test_more.pir' plan(8) init_check() type_and_id_tests() freeze_thaw_tests() hash_tests() .end .sub init_check new $P0, ['SchedulerMessage'] ok(1, 'Instantiated SchedulerMessage PMC') .local pmc eh eh = new ['ExceptionHandler'] eh.'handle_types'(.EXCEPTION_INVALID_OPERATION) set_label eh, catch push_eh eh $I0 = 1 $P1 = new ['Integer'] $P0 = new ['SchedulerMessage'], $P1 $I0 = 0 goto check catch: finalize eh check: pop_eh ok($I0, 'initializing with invalid type throws') .end .sub type_and_id_tests $P0 = new ['SchedulerMessage'] $P0 = 2345 $P0 = "some kinda message" $S0 = $P0 is($S0 , "some kinda message", "scheduler message type stored/retrieved successfully") $I0 = $P0 is($I0, 2345, "scheduler id type stored/retrieved successfully") .end .sub freeze_thaw_tests $P0 = new ['SchedulerMessage'] $P0 = 86 $P0 = "Smart message" $S0 = freeze $P0 $P1 = thaw $S0 $S0 = $P1 is($S0, "Smart message", "frozen message has correct type") $I0 = $P1 is($I0, 86, "frozen message has correct id") .end .sub hash_tests $P0 = new ['Hash'] $P0['id'] = 9 $P0['type'] = 'nine' $P1 = new ['SchedulerMessage'], $P0 # Make sure the mark vtable function is exercised. null $P0 sweep 1 $S0 = $P1 is($S0, "nine", "hash-initialized message has correct type") $I0 = $P1 is($I0, 9, "hash-initialized message has correct id") .end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: post.t000644000765000765 566711567202625 15712 0ustar00bruce000000000000parrot-6.6.0/t/compilers/pct#! perl # Copyright (C) 2006-2009, Parrot Foundation. use strict; use warnings; use lib qw(t . lib ../lib ../../lib ../../../lib); use Parrot::Test tests => 8; foreach my $name (qw(Op Ops Sub Label)) { my $module = "'POST';'$name'"; my $code = <<'CODE' .sub _main :main load_bytecode 'PCT.pbc' load_bytecode 'dumper.pbc' .local pmc node .local pmc node2 CODE ; $code .= " node = new [$module]\n"; $code .= " node2 = new [$module]\n"; $code .= <<'CODE' node.'init'('name' => 'foo') node2.'init'('name' => 'bar') node.'push'(node2) $P1 = node.'name'() say $P1 "_dumper"(node, "ost") .return () .end CODE ; $module =~ s/'//g; pir_output_is( $code, <<"OUT", "set attributes for $module via method" ); foo "ost" => PMC '$module' { => "foo" [0] => PMC '$module' { => "bar" } } OUT } pir_output_is( <<'CODE', <<'OUT', 'dump POST::Op node in visual format' ); .sub _main :main load_bytecode 'PCT.pbc' load_bytecode 'dumper.pbc' .local pmc node node = new ['POST';'Op'] node.'pirop'('add') node.'result'('$P1') node.'inline'('%r=1') "_dumper"(node, "ost") .return () .end CODE "ost" => PMC 'POST;Op' { => "%r=1" => "add" => "$P1" } OUT pir_output_is( <<'CODE', <<'OUT', 'dump POST::Label node in visual format' ); .sub _main :main load_bytecode 'PCT.pbc' load_bytecode 'dumper.pbc' .local pmc node node = new ['POST';'Label'] node.'name'('labeler') "_dumper"(node, "ost") .return () .end CODE "ost" => PMC 'POST;Label' { => "labeler" } OUT pir_output_is( <<'CODE', <<'OUT', 'Generate :multi' ); .sub _main :main load_bytecode 'PCT.pbc' load_bytecode 'dumper.pbc' .local pmc node node = new ['POST';'Sub'] node.'name'('foo') $P0 = new ['ResizablePMCArray'] push $P0, "_" push $P0, "Foo" $P1 = new ['ResizableStringArray'] push $P1, "Bar" push $P1, "Baz" push $P0, $P1 node.'multi'($P0) .local pmc compiler compiler = new ['POST';'Compiler'] $S0 = compiler.'to_pir'(node) say $S0 .return () .end CODE .namespace [] .sub "foo" :subid("post10") :multi(_,["Foo"],["Bar";"Baz"]) .end OUT pir_output_is( <<'CODE', <<'OUT', 'Generate directives' ); .sub _main :main load_bytecode 'PCT.pbc' load_bytecode 'dumper.pbc' .local pmc node node = new ['POST';'Sub'] node.'name'('foo') node.'add_directive'('.include "cclass.pasm"') node.'add_directive'('.include "exception_types.pasm"') .local pmc compiler compiler = new ['POST';'Compiler'] $S0 = compiler.'to_pir'(node) say $S0 .return () .end CODE .namespace [] .include "cclass.pasm" .include "exception_types.pasm" .sub "foo" :subid("post10") .end OUT # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: hints-01.t000644000765000765 1120111533177646 15612 0ustar00bruce000000000000parrot-6.6.0/t/steps/init#! perl # Copyright (C) 2007, Parrot Foundation. # init/hints-01.t use strict; use warnings; use Test::More tests => 21; use Carp; use Cwd; use File::Path (); use File::Spec::Functions qw/catfile/; use File::Temp qw(tempdir); use lib qw( lib t/configure/testlib ); use_ok('config::init::hints'); use Parrot::Configure::Options qw( process_options ); use Parrot::Configure::Step::Test; use Parrot::Configure::Test qw( test_step_constructor_and_description ); use IO::CaptureOutput qw | capture |; ########## --verbose ########## my ($args, $step_list_ref) = process_options( { argv => [q{--verbose}], mode => q{configure}, } ); my $conf = Parrot::Configure::Step::Test->new; $conf->include_config_results( $args ); my $pkg = q{init::hints}; $conf->add_steps($pkg); my $serialized = $conf->pcfreeze(); $conf->options->set( %{$args} ); my $step = test_step_constructor_and_description($conf); # need to capture the --verbose output, because the fact that it does not end # in a newline confuses Test::Harness { my $rv; my $stdout; capture ( sub {$rv = $step->runstep($conf)}, \$stdout); ok( $stdout, "verbose output: hints were captured" ); ok( defined $rv, "runstep() returned defined value" ); } $conf->replenish($serialized); ########## --verbose; local hints directory ########## ($args, $step_list_ref) = process_options( { argv => [q{--verbose}], mode => q{configure}, } ); $conf->options->set( %{$args} ); $step = test_step_constructor_and_description($conf); my $cwd = cwd(); { my $tdir = tempdir( CLEANUP => 1 ); File::Path::mkpath(qq{$tdir/init/hints}) or croak "Unable to create directory for local hints"; my $localhints = qq{$tdir/init/hints/local.pm}; open my $FH, '>', $localhints or croak "Unable to open temp file for writing"; print $FH <runstep($conf)}, \$stdout); ok( $stdout, "verbose output: hints were captured" ); ok( defined $rv, "runstep() returned defined value" ); } unlink $localhints or croak "Unable to delete $localhints"; } $conf->replenish($serialized); ########## --verbose; local hints directory; no runstep() in local hints ########## ($args, $step_list_ref) = process_options( { argv => [q{--verbose}], mode => q{configure}, } ); $conf->options->set( %{$args} ); $step = test_step_constructor_and_description($conf); $cwd = cwd(); { my $tdir = tempdir( CLEANUP => 1 ); File::Path::mkpath(qq{$tdir/init/hints}) or croak "Unable to create directory for local hints"; my $localhints = qq{$tdir/init/hints/local.pm}; open my $FH, '>', $localhints or croak "Unable to open temp file for writing"; print $FH <runstep($conf)}, \$stdout); ok( $stdout, "verbose output: hints were captured" ); ok( defined $rv, "runstep() returned defined value" ); } unlink $localhints or croak "Unable to delete $localhints"; } $conf->replenish($serialized); ########## --verbose; imaginary OS ########## ($args, $step_list_ref) = process_options( { argv => [ q{--verbose} ], mode => q{configure}, } ); $conf->options->set( %{$args} ); $step = test_step_constructor_and_description($conf); { my ($stdout, $stderr, $ret); $conf->data->set( OSNAME_provisional => q{imaginaryOS} ); my $osname = lc( $conf->data->get( 'OSNAME_provisional' ) ); my $hints_file = catfile('config', 'init', 'hints', "$osname.pm"); capture ( sub { $ret = $step->runstep($conf); }, \$stdout, \$stderr, ); like( $stdout, qr/No \Q$hints_file\E found/s, "Got expected verbose output when no hints file found" ); } pass("Completed all tests in $0"); ################### DOCUMENTATION ################### =head1 NAME init/hints-01.t - test init::hints =head1 SYNOPSIS % prove t/steps/init/hints-01.t =head1 DESCRIPTION The files in this directory test functionality used by F. The tests in this file test init::hints. =head1 AUTHOR James E Keenan =head1 SEE ALSO config::init::hints, F. =cut # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: parrotinterpreter.pmc000644000765000765 5327712356767111 17377 0ustar00bruce000000000000parrot-6.6.0/src/pmc/* Copyright (C) 2001-2014, Parrot Foundation. =head1 NAME src/pmc/parrotinterpreter.pmc - ParrotInterpreter PMC =head1 DESCRIPTION These are the vtable functions for the ParrotInterpreter base class getinterp P0 set P1, P0[.IGLOBALS_*] # access interpreter globals set I0, P0[x] # interpinfo I0, x set I0, P0[-1] # get interpreter flags set P0[-1], x # set flags on interpreter # NOTE: this doesn't restart =head2 Functions =over 4 =cut */ #include "parrot/dynext.h" #include "parrot/io.h" #include "parrot/runcore_api.h" #include "parrot/thread.h" #include "pmc/pmc_class.h" #include "pmc/pmc_sub.h" #include "pmc/pmc_proxy.h" #include "pmc/pmc_task.h" #define PMC_interp(x) ((Parrot_ParrotInterpreter_attributes *)PMC_data(x))->interp #define PMC_args(x) ((Parrot_ParrotInterpreter_attributes *)PMC_data(x))->args #define PMC_sub(x) ((Parrot_ParrotInterpreter_attributes *)PMC_data(x))->sub /* HEADERIZER HFILE: none */ /* HEADERIZER BEGIN: static */ /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */ static void create_interp( ARGIN(PMC *self), ARGIN_NULLOK(Parrot_Interp parent)) __attribute__nonnull__(1); #define ASSERT_ARGS_create_interp __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(self)) /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */ /* HEADERIZER END: static */ /* =item C Clones the interpreter as specified by the flags. TODO: Move this logic into src/interp/api.c or src/threads.c, as appropriate =cut */ PARROT_CANNOT_RETURN_NULL PMC * clone_interpreter(Parrot_Interp s, INTVAL flags) { /* have to pass a parent to allocate_interpreter to prevent PMCNULL from being set to NULL */ Parrot_Interp d = Parrot_interp_allocate_interpreter(s, flags); int stacktop; Parrot_GC_Init_Args args; PMC * interp_pmc; PMC * const s_config_hash = VTABLE_get_pmc_keyed_int(s, s->iglobals, IGLOBALS_CONFIG_HASH); memset(&args, 0, sizeof (args)); args.stacktop = &stacktop; /* Set up the memory allocation system */ Parrot_gc_initialize(d, &args); Parrot_block_GC_mark(d); Parrot_block_GC_sweep(d); d->ctx = PMCNULL; d->resume_flag = RESUME_INITIAL; d->recursion_limit = RECURSION_LIMIT; /* PANIC will fail until this is done */ d->piodata = NULL; Parrot_io_init(d); /* * Set up the string subsystem * This also generates the constant string tables * Do this before unsetting parent_interpreter to copy its hash_seed and constant string table */ Parrot_str_init(d); /* create caches structure */ init_object_cache(d); d->n_vtable_max = s->n_vtable_max; d->vtables = s->vtables; d->class_hash = Parrot_thread_create_proxy(s, d, s->class_hash); Parrot_cx_init_scheduler(d); d->parent_interpreter = NULL; /* create the root set registry */ d->gc_registry = Parrot_pmc_new(d, enum_class_AddrRegistry); interp_pmc = Parrot_pmc_new_noinit(d, enum_class_ParrotInterpreter); VTABLE_set_pointer(d, interp_pmc, d); /* init the interpreter globals array */ d->iglobals = Parrot_pmc_new_init_int(d, enum_class_FixedPMCArray, (INTVAL)IGLOBALS_SIZE); VTABLE_set_pmc_keyed_int(d, d->iglobals, (INTVAL) IGLOBALS_INTERPRETER, interp_pmc); /* initialize built-in runcores */ Parrot_runcore_init(d); /* create a proxy for the config_hash */ VTABLE_set_pmc_keyed_int(d, d->iglobals, (INTVAL) IGLOBALS_CONFIG_HASH, Parrot_thread_create_proxy(s, d, s_config_hash)); /* can't copy directly, unless you want double-frees */ if (flags & PARROT_CLONE_RUNOPS) Parrot_runcore_switch(d, s->run_core->name); if (flags & PARROT_CLONE_INTERP_FLAGS) { /* XXX setting of IS_THREAD? */ d->flags = s->flags; d->debug_flags = s->debug_flags; } d->root_namespace = Parrot_thread_create_proxy(s, d, s->root_namespace); if (flags & PARROT_CLONE_HLL) { /* we'd like to share the HLL data. Give it a PMC_sync structure if it doesn't have one already */ /* This used to be proxied: d->HLL_info = Parrot_thread_create_proxy(s, d, s->HLL_info); But src/hll.c:Parrot_hll_get_HLL_type() pokes directly into the PMC attributes which is a problem if we're using a Proxy. Instead, clone the structure so direct accesses continue working. */ d->HLL_info = VTABLE_clone(d, s->HLL_info); d->HLL_namespace = Parrot_thread_create_proxy(s, d, s->HLL_namespace); d->HLL_entries = Parrot_thread_create_proxy(s, d, s->HLL_entries); } if (flags & (PARROT_CLONE_LIBRARIES | PARROT_CLONE_CLASSES)) { } if (flags & PARROT_CLONE_LIBRARIES) { PMC * const s_pbc_libs = VTABLE_get_pmc_keyed_int(s, s->iglobals, IGLOBALS_PBC_LIBS); VTABLE_set_pmc_keyed_int(d, d->iglobals, (INTVAL) IGLOBALS_PBC_LIBS, Parrot_thread_create_proxy(s, d, s_pbc_libs)); } create_initial_context(d); if (flags & PARROT_CLONE_CODE) Parrot_clone_code(d, s); /* setup stdio PMCs */ Parrot_io_init(d); Parrot_unblock_GC_sweep(d); Parrot_unblock_GC_mark(d); return interp_pmc; } /* =item C Creates a new child interpreter of C. =cut */ static void create_interp(ARGIN(PMC *self), ARGIN_NULLOK(Parrot_Interp parent)) { ASSERT_ARGS(create_interp) Interp_flags flag = PARROT_NO_FLAGS; Parrot_Interp new_interp; new_interp = Parrot_interp_make_interpreter(parent, (INTVAL)flag); PMC_interp(self) = new_interp; VTABLE_set_pmc_keyed_int(new_interp, new_interp->iglobals, (INTVAL) IGLOBALS_INTERPRETER, self); } pmclass ParrotInterpreter no_ro manual_attrs provides invokable { ATTR struct parrot_interp_t *interp; /* this PMC's interpreter */ ATTR INTVAL tid; /* thread id. Unused, see get_integer() */ ATTR PMC *args; /* args passed to this thread */ ATTR PMC *sub; /* this thread's sub */ /* =back =head2 Methods =over 4 =item C Yield the current thread =item C Gets the recursion limit of the interpreter, optionally setting it to something new. =cut */ METHOD recursion_limit(INTVAL l :optional, INTVAL has_l :opt_flag) :no_wb { const INTVAL ret = INTERP->recursion_limit; UNUSED(SELF) if (has_l) INTERP->recursion_limit = l; RETURN(INTVAL ret); } /* =item C Initializes the interpreter. =cut */ VTABLE void init() { if (!PMC_data(SELF)) { Parrot_ParrotInterpreter_attributes * const attrs = mem_gc_allocate_zeroed_typed(INTERP, Parrot_ParrotInterpreter_attributes); PMC_data(SELF) = attrs; } if (!PMC_interp(SELF)) create_interp(SELF, INTERP); PObj_custom_destroy_SET(SELF); } /* =item C Initializes a child interpreter with C<*parent> if C is a ParrotInterpreter instance. Otherwise takes the thread ID from C and uses that thread. =cut */ VTABLE void init_pmc(PMC *parent) { if (!PMC_data(SELF)) { Parrot_ParrotInterpreter_attributes * const attrs = mem_gc_allocate_zeroed_typed(INTERP, Parrot_ParrotInterpreter_attributes); PMC_data(SELF) = attrs; } if (!PMC_interp(SELF)) create_interp(SELF, PMC_interp(parent)); PObj_custom_destroy_SET(SELF); } /* =item C Destroys the PMC. =cut */ VTABLE void destroy() :no_wb { if (PMC_data(SELF)) { mem_gc_free(INTERP, PMC_data(SELF)); PMC_data(SELF) = NULL; } } /* =item C Sets C to C<*value>. =cut */ VTABLE void set_pointer(void *value) { /* XXX: init_world in src/global_setup.c needs to create a * ParrotInterpreter through Parrot_pmc_new_noinit. If this PMC hasn't been * initialized, cheat by initializing instead. */ if (!PMC_data(SELF)) { Parrot_ParrotInterpreter_attributes * const attrs = mem_gc_allocate_zeroed_typed(INTERP, Parrot_ParrotInterpreter_attributes); PMC_data(SELF) = attrs; PObj_custom_destroy_SET(SELF); } PMC_interp(SELF) = (struct parrot_interp_t *)value; } /* =item C Returns C. =cut */ VTABLE void *get_pointer() :no_wb { UNUSED(INTERP) return PMC_interp(SELF); } /* =item C Returns the thread id of the interpreter. =cut */ VTABLE INTVAL get_integer() :no_wb { UNUSED(INTERP) const Parrot_Interp i = PMC_interp(SELF); if (i->thread_data) return (INTVAL)i->thread_data->tid; return 0; } /* =item C Runs the interpreter's byte code. =cut */ VTABLE opcode_t *invoke(void *next) :no_wb { Interp * const new_interp = PMC_interp(SELF); /* TODO pass arguments from parent (interp) to child (new_interp) by * possibly clone of share the arguments r/o args can be passed as is */ /* calculate offset and run */ runops(new_interp, (size_t)((opcode_t *)PMC_sub(SELF) - (opcode_t *)INTERP->code->base.data)); return (opcode_t *)next; } /* =item C Return this Thread's args. =cut */ VTABLE PMC *get_pmc() :no_wb { UNUSED(INTERP) return PMC_args(SELF); } /* =item C Set this Thread's args. =cut */ VTABLE void set_pmc(PMC *args) { PMC_args(SELF) = args; } /* =item C Returns the PMC global value for C. =cut */ VTABLE PMC *get_pmc_keyed_int(INTVAL key) :no_wb { Interp * const new_interp = PMC_interp(SELF); UNUSED(INTERP) if (key >= 0 && key < IGLOBALS_SIZE) { PMC * const val = VTABLE_get_pmc_keyed_int(new_interp, new_interp->iglobals, key); return val == NULL ? PMCNULL : val; } /* quick hack to get the global stash */ if (key == -1) return new_interp->root_namespace; return PMCNULL; } /* =item C Introspection interface. C can be: "context" ... return Context PMC "sub" ... return Sub object of this subroutine "continuation" ... return Continuation PMC "lexpad" ... return lexpad PMC for this sub "namespace" ... return namespace PMC for this sub "outer" ... return outer sub of this closure ""; level ... same for caller "annotations"; level > 0 ... annotations at point of call s down "outer"; "" ... same for outer level 1 "outer"; ""; level ... same for outer "globals" ... return global stash =cut */ VTABLE PMC *get_pmc_keyed(PMC *key) :no_wb { PMC *nextkey; STRING *outer = NULL; STRING *item = Parrot_key_string(INTERP, key); int level = 0; PMC *ctx; UNUSED(SELF) if (STRING_equal(INTERP, item, CONST_STRING(INTERP, "globals"))) return INTERP->root_namespace; if (STRING_equal(INTERP, item, CONST_STRING(INTERP, "packfile"))) return Parrot_pf_get_current_packfile(INTERP); if (STRING_equal(INTERP, item, CONST_STRING(INTERP, "outer"))) { outer = item; nextkey = Parrot_key_next(INTERP, key); if (nextkey && (PObj_get_FLAGS(nextkey) & KEY_string_FLAG)) { key = nextkey; item = VTABLE_get_string(INTERP, key); } } nextkey = Parrot_key_next(INTERP, key); if (nextkey) level = VTABLE_get_integer(INTERP, nextkey); else if (outer) level = 1; if (level < 0) Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_INVALID_OPERATION, "No such caller depth"); ctx = CURRENT_CONTEXT(INTERP); if (outer) { for (; level; --level) { ctx = Parrot_pcc_get_outer_ctx(INTERP, ctx); if (PMC_IS_NULL(ctx)) Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_INVALID_OPERATION, "No such outer depth"); } } else { for (; level; --level) { PMC * const cont = Parrot_pcc_get_continuation(INTERP, ctx); if (PMC_IS_NULL(cont) || !PARROT_CONTINUATION(cont)->seg) Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_INVALID_OPERATION, "No such caller depth"); ctx = PARROT_CONTINUATION(cont)->to_ctx; if (PMC_IS_NULL(Parrot_pcc_get_sub(INTERP, ctx))) Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_INVALID_OPERATION, "No such caller depth"); } } if (item == outer) return Parrot_pcc_get_sub(INTERP, ctx); if (STRING_equal(INTERP, item, CONST_STRING(INTERP, "context"))) return ctx; if (STRING_equal(INTERP, item, CONST_STRING(INTERP, "sub"))) return Parrot_pcc_get_sub(INTERP, ctx); if (STRING_equal(INTERP, item, CONST_STRING(INTERP, "lexpad"))) return Parrot_pcc_get_lex_pad(INTERP, ctx); if (STRING_equal(INTERP, item, CONST_STRING(INTERP, "namespace"))) return Parrot_pcc_get_namespace(INTERP, ctx); if (STRING_equal(INTERP, item, CONST_STRING(INTERP, "continuation"))) return VTABLE_clone(INTERP, Parrot_pcc_get_continuation(INTERP, ctx)); if (STRING_equal(INTERP, item, CONST_STRING(INTERP, "annotations"))) { PMC * const sub_pmc = Parrot_pcc_get_sub(INTERP, ctx); if (ctx == CURRENT_CONTEXT(INTERP)) { /* We can't know the current program counter for the currently * executing sub, so can't return annotations for that. */ Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_INVALID_OPERATION, "Cannot get annotations at depth 0; use annotations op instead."); } if (!PMC_IS_NULL(sub_pmc) && sub_pmc->vtable->base_type == enum_class_Sub) { Parrot_Sub_attributes *sub; PackFile_ByteCode *seg; opcode_t * const pc = Parrot_pcc_get_pc(INTERP, ctx); PMC_get_sub(INTERP, sub_pmc, sub); seg = sub->seg; if (sub->seg->annotations) return PackFile_Annotations_lookup(INTERP, seg->annotations, pc - seg->base.data, NULL); } return Parrot_pmc_new(INTERP, enum_class_Hash); } Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_ATTRIB_NOT_FOUND, "No such item %Ss", item); } /* =item C Returns the interpreter info for C. =cut */ VTABLE INTVAL get_integer_keyed_int(INTVAL key) :no_wb { UNUSED(INTERP) Interp * const new_interp = PMC_interp(SELF); if (key == -1) return (INTVAL)new_interp->flags; return Parrot_interp_info(new_interp, key); } /* =item C Sets the interpreter info for C to C. =cut */ VTABLE void set_integer_keyed_int(INTVAL key, INTVAL val) { Interp * const new_interp = PMC_interp(SELF); /* set interpreter flags */ if (key == -1) { const INTVAL allowed = PARROT_BOUNDS_FLAG | PARROT_PROFILE_FLAG | PARROT_GC_DEBUG_FLAG; Parrot_interp_clear_flag(new_interp, allowed); Parrot_interp_set_flag(new_interp, val & allowed); } } /* =item C First attempt to make things running, and to see, where problems may arise. Only minimal items are done yet. XXX this should of course call C and use freeze/thaw. =cut */ VTABLE PMC *clone() :no_wb { PMC * const dest = clone_interpreter(PMC_interp(SELF), PARROT_CLONE_DEFAULT); UNUSED(INTERP) return dest; } /* =item C Returns whether the interpreter is equal to C<*val>. Two interpreters (threads) are equal if both are non-threaded or they have the same thread id. =cut */ MULTI INTVAL is_equal(ParrotInterpreter val) :no_wb { UNUSED(INTERP) Parrot_Interp self = PMC_interp(SELF); Parrot_Interp other = PMC_interp(val); return self == other; } MULTI INTVAL is_equal(DEFAULT value) :no_wb { UNUSED(SELF) Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_INTERNAL_NOT_IMPLEMENTED, "ParrotInterpreter: no multiple dispatch variant 'is_equal' for %Ss", VTABLE_name(INTERP, value)); } /* =item C This is used by freeze/thaw to visit the contents of the interpreter. C<*info> is the visit info, (see F). =item C Used to archive the interpreter. Actually not the whole interpreter is frozen but the state of the interpreter, which includes everything that has changes since creating an empty interpreter. =item C Used to unarchive the interpreter. This merges the changes into this interpreter instance. =item C Finish thawing. =cut */ VTABLE void freeze(PMC *info) :no_wb { UNUSED(SELF) UNUSED(info) Parrot_ex_throw_from_c_args(INTERP, NULL, 0, "Attempt to freeze interpreter"); } METHOD run_gc() { Parrot_gc_mark_and_sweep(PMC_interp(SELF), 0); } /* =item METHOD hll_map(PMC core_type,PMC hll_type) Map core_type to hll_type. =cut */ METHOD hll_map(PMC *core_type, PMC *hll_type) :no_wb { const INTVAL core_type_id = VTABLE_type(INTERP, core_type); const INTVAL hll_type_id = VTABLE_type(INTERP, hll_type); const INTVAL hll_id = Parrot_pcc_get_HLL(INTERP, CURRENT_CONTEXT(INTERP)); UNUSED(SELF) Parrot_hll_register_HLL_type(INTERP, hll_id, core_type_id, hll_type_id); } /* =item METHOD stdin_handle(PMC *newhandle :optional) If a PMC object is provided, the standard input handle for this interpreter is set to that PMC, and the new PMC handle is returned. If no PMC object is provided, the current standard input handle is returned. =cut */ METHOD stdin_handle(PMC *newhandle :optional) :no_wb { PMC * const handle = Parrot_io_stdhandle(INTERP, PIO_STDIN_FILENO, newhandle); UNUSED(SELF) RETURN(PMC *handle); } /* =item METHOD stdout_handle(PMC *newhandle :optional) If a PMC object is provided, the standard output handle for this interpreter is set to that PMC, and the new PMC handle is returned. If no PMC object is provided, the current standard output handle is returned. =cut */ METHOD stdout_handle(PMC *newhandle :optional) :no_wb { PMC * const handle = Parrot_io_stdhandle(INTERP, PIO_STDOUT_FILENO, newhandle); RETURN(PMC *handle); } /* =item METHOD stderr_handle(PMC *newhandle :optional) If a PMC object is provided, the standard error handle for this interpreter is set to that PMC, and the new PMC handle is returned. If no PMC object is provided, the current standard error handle is returned. =cut */ METHOD stderr_handle(PMC *newhandle :optional) :no_wb { PMC * const handle = Parrot_io_stdhandle(INTERP, PIO_STDERR_FILENO, newhandle); RETURN(PMC *handle); } /* =item METHOD getpid() Returns the pid of the current process, 0 in platforms that doesn't support it. =cut */ METHOD getpid() :no_wb { const INTVAL id = Parrot_getpid(); RETURN(INTVAL id); } /* =item METHOD current_task() Returns the task currently executed by this interpreter. =cut */ METHOD current_task() :no_wb { Interp * const this_interp = PMC_interp(SELF); PMC * const current_task = this_interp->cur_task; RETURN(PMC *current_task); } /* =item METHOD schedule(PMC *task) Schedules the given task on this interpreter. =cut */ METHOD schedule(PMC *task) :no_wb { Interp * const this_interp = PMC_interp(SELF); Parrot_cx_schedule_immediate(this_interp, task); } /* =item METHOD schedule_proxied(PMC *task, PMC *proxy) Schedules the given task on the proxy's interpreter. =cut */ METHOD schedule_proxied(PMC *task, PMC *proxy) :no_wb { Parrot_Proxy_attributes * const core_struct = PARROT_PROXY(proxy); Interp * const proxied_interp = core_struct->interp; UNUSED(SELF) #ifdef PARROT_HAS_THREADS /* don't run GC from the wrong thread since GC involves stack walking and we * don't want the foreign GC to find our objects */ Parrot_block_GC_mark_locked(proxied_interp); Parrot_cx_schedule_immediate(proxied_interp, Parrot_thread_create_local_task(INTERP, proxied_interp, task)); Parrot_unblock_GC_mark_locked(proxied_interp); #else Parrot_cx_schedule_immediate(interp, task); #endif } } /* =back =cut */ /* * Local variables: * c-file-style: "parrot" * End: * vim: expandtab shiftwidth=4 cinoptions='\:2=2' : */ va_ptr-01.t000644000765000765 235511533177646 15757 0ustar00bruce000000000000parrot-6.6.0/t/steps/auto#! perl # Copyright (C) 2007, Parrot Foundation. # auto/va_ptr-01.t use strict; use warnings; use Test::More tests => 5; use Carp; use lib qw( lib t/configure/testlib ); use_ok('config::auto::va_ptr'); use Parrot::Configure::Options qw( process_options ); use Parrot::Configure::Step::Test; use Parrot::Configure::Test qw( test_step_constructor_and_description ); my ($args, $step_list_ref) = process_options( { argv => [ ], mode => q{configure}, } ); my $conf = Parrot::Configure::Step::Test->new; $conf->include_config_results( $args ); my $pkg = q{auto::va_ptr}; $conf->add_steps($pkg); $conf->options->set( %{$args} ); my $step = test_step_constructor_and_description($conf); pass("Completed all tests in $0"); ################### DOCUMENTATION ################### =head1 NAME auto/va_ptr-01.t - test auto::va_ptr =head1 SYNOPSIS % prove t/steps/auto/va_ptr-01.t =head1 DESCRIPTION The files in this directory test functionality used by F. The tests in this file test auto::va_ptr. =head1 AUTHOR James E Keenan =head1 SEE ALSO config::auto::va_ptr, F. =cut # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: parrotbench.pl000755000765000765 1665611606346603 16316 0ustar00bruce000000000000parrot-6.6.0/tools/dev#! perl # Copyright (C) 2004-2007, Parrot Foundation. use strict; use warnings; use Config::IniFiles; use File::Basename; use File::Find; use File::Spec; use FindBin; use Getopt::Long; use Pod::Usage; require POSIX; =head1 NAME tools/dev/parrotbench.pl - Parrot benchmark =head1 SYNOPSIS parrotbench.pl [options] Options: -b -benchmarks use benchmarks matching regexes (multiple) -c -conf path to configuration file -d -directory path to benchmarks directory -h -? -help display this help and exits -list list available benchmarks and exits -m -method method of time from times() 1 $cuser + $csystem from times() (default) 2 Real time using POSIX::times() -n -nobench skip benchmarks matching regexes (multiple) -time show times instead of percentage =head1 DESCRIPTION Benchmark Parrot against other interpreters. =head1 CONFIGURATION You must specify paths to executables in a configuration file. That file may be placed as parrotbench.conf in the same directory as parrotbench.pl or otherwise explicitly specified with the -conf option. You may set any command line option in the file with the exception of the configuration file name itself. In the event you have specified an option both in the configuration file and the command line, the command line takes precedence. Here is an example parrotbench.conf: [global] directory = ../../examples/benchmarks list = 0 help = 0 method = 2 time = 1 [regexes] include = ^gc include = ^oo exclude = header exclude = waves [benchmark parrotj] exe = ../../parrot -R jit type = .pasm type = .pir [benchmark perl_585_th] exe = /usr/bin/perl585-th type = .pl [benchmark python] exe = /usr/local/bin/python type = .py [benchmark ruby] exe = /usr/bin/ruby type = .rb =head1 BUGS While every effort was made to ensure this script is portable, it is likely that it will break somewhere. If a benchmark has multiple extensions associated with the same executable, the last one will be used. For instance, with the configuration file above, foo.pir would be selected over foo.pasm =head1 AUTHOR Joshua Gatcomb, C Originally written by: Sebastian Riedel, C =cut # Create Default Configuration my %cfg = ( config_file => File::Spec->catdir( $FindBin::Bin, 'parrotbench.conf' ), bench_path => undef, list_only => undef, use_times => undef, display_help => undef, method => undef, run_bench => [], skip_bench => [], ); # Read Command Line Options GetOptions( 'conf=s' => \$cfg{config_file}, 'directory=s' => \$cfg{bench_path}, 'list' => \$cfg{list_only}, 'time' => \$cfg{use_times}, 'help|?' => \$cfg{display_help}, 'method=s' => \$cfg{method}, 'benchmarks=s' => $cfg{run_bench}, 'nobench=s' => $cfg{skip_bench}, ); # Read Configuration File die 'Unable to access configuration file ', $cfg{config_file} unless -r $cfg{config_file}; my $ini = Config::IniFiles->new( -file => $cfg{config_file} ); # Merge Configuration if ( !defined $cfg{bench_path} ) { $cfg{bench_path} = $ini->val( global => 'directory' ); } if ( !defined $cfg{list_only} ) { $cfg{list_only} = $ini->val( global => 'list' ); } if ( !defined $cfg{use_times} ) { $cfg{use_times} = $ini->val( global => 'time' ); } if ( !defined $cfg{display_help} ) { $cfg{display_help} = $ini->val( global => 'help' ); } pod2usage 1 if $cfg{display_help}; if ( !defined $cfg{method} ) { $cfg{method} = $ini->val( global => 'method', 1 ); } if ( !@{ $cfg{run_bench} } ) { my @regexes = grep defined, $ini->val( regexes => 'include' ); @{ $cfg{run_bench} } = @regexes ? @regexes : '[\d\D]'; } if ( !@{ $cfg{skip_bench} } ) { my @regexes = grep defined, $ini->val( regexes => 'exclude' ); @{ $cfg{skip_bench} } = @regexes ? @regexes : '[^\d\D]'; } # Frequently Used Variables my %bench; my @section = sort $ini->GroupMembers('benchmark'); my @program = map { /^benchmark\s+(.*)$/ } @section; my %suffix; $suffix{$_} = [ map quotemeta, $ini->val( $_, 'type' ) ] for @section; my $ticks = POSIX::sysconf(&POSIX::_SC_CLK_TCK); my %Get_Time = ( 1 => sub { my @times = times(); return $times[2] + $times[3] }, 2 => sub { return ( POSIX::times() )[0] / $ticks }, ); # Find And Build Benchmarks find sub { my $pass; for my $regex ( @{ $cfg{run_bench} } ) { $pass++ and last if /$regex/; } return if !$pass; my $fail; for my $regex ( @{ $cfg{skip_bench} } ) { $fail++ and last if /$regex/; } return if $fail; for my $index ( 0 .. $#section ) { my ( $name, $p, $ext ) = fileparse( $_, @{ $suffix{ $section[$index] } } ); next if !$ext; $bench{$name}{ $program[$index] } = $ext; } }, $cfg{bench_path}; die "No benchmarks found" if !keys %bench; # List Names Of Benchmarks With Pretty Output if ( $cfg{list_only} ) { my @rows; push @rows, [ 'Benchmark', @program ]; for my $name ( sort keys %bench ) { push @rows, [ $name, map { $bench{$name}{$_} || '-' } @program ]; } my @max; for ( 0 .. @program ) { for my $row (@rows) { Longest( $max[$_], length $row->[$_] ); } } for my $col (@rows) { print map { sprintf( "%-$max[$_]s ", $col->[$_] ) } 0 .. $#$col; print "\n"; } exit; } # Run The Benchmarks With Pretty Output if ( !$cfg{use_times} && @program < 2 ) { print "WARNING: Switching percentage to time - not enough executables\n"; $cfg{use_times} = 1; } if ( $cfg{use_times} ) { my $type = $cfg{method} == 1 ? 'CPU' : 'wall-clock'; print "Times are in $type seconds. (lower is better)\n"; } else { print "Numbers are relative to the first one. (lower is better)\n"; } print "\n"; open( my $COPYOUT, ">&STDOUT" ) or die "Unable to copy STDOUT"; open( STDOUT, '>', File::Spec->devnull ) or die "Unable to redirect STDOUT"; select $COPYOUT; $| = 1; my @max = $cfg{method} == 1 ? (5) x @program : (6) x @program; Longest( $max[0], length $_ ) for 'Benchmark', keys %bench; Longest( $max[ $_ + 1 ], length $program[$_] ) for 0 .. $#program; printf( "%-$max[0]s ", 'Benchmark' ); printf( "%-$max[$_ + 1]s ", $program[$_] ) for 0 .. $#program; for my $name ( sort keys %bench ) { my $base = 0; printf( "\n%-$max[0]s ", $name ); for ( 0 .. $#section ) { my ( $prog, $sect ) = ( $program[$_], $section[$_] ); if ( $bench{$name}{$prog} ) { my $start = $Get_Time{ $cfg{method} }->(); system( $ini->val( $sect, 'exe' ) . " " . File::Spec->catdir( $cfg{bench_path}, $name . $bench{$name}{$prog} ) ); my $stop = $Get_Time{ $cfg{method} }->(); my $used = $stop - $start; $base ||= $used; printf( "%-$max[$_ + 1]s ", $cfg{use_times} ? sprintf( "%.3f", $used ) : sprintf( "%d%%", $used / ( $base / 100 ) ) ); } else { printf( "%-$max[$_ + 1]s ", '-' ); } } } sub Longest { $_[0] = $_[1] and return if !defined $_[0]; $_[0] = $_[1] if $_[1] > $_[0]; } # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: uniq.pir000644000765000765 506311533177635 15605 0ustar00bruce000000000000parrot-6.6.0/examples/pir# Copyright (C) 2001-2008, Parrot Foundation. =head1 NAME examples/pir/uniq.pir - Remove duplicate lines from a sorted file =head1 SYNOPSIS % ./parrot examples/pir/uniq.pir -o uniq.pbc =head1 DESCRIPTION Parrot implementation of C. Removes duplicate lines from a sorted file. You'll have to create a suitable file to "de-dup". =head2 Command-line Options =over 4 =item C<-c> Precede each output line with the count of the number of times the line occurred in the input, followed by a single space =item C<-d> Don't output lines that are not repeated in the input =item C<-u> Don't output lines that are repeated in the input =back =head1 HISTORY By Leon Brocard . Converted to PIR by Bernhard Schmalhofer. =cut .loadlib 'io_ops' # convenient I/O dynamic opcodes .sub "uniq" :main .param pmc argv .local string program program = shift argv .local int num_args num_args = argv if num_args > 0 goto SOURCE print "usage: parrot " print program print " [-c] [-d] [-u] filename\n" goto END SOURCE: # set up flag registers $I10 = 0 $I11 = 0 $I12 = 0 # do some simple option parsing .local string option option = shift argv ne option, "-c", NOTC $I10 = 1 # count mode option = shift argv NOTC: ne option, "-d", NOTD $I11 = 1 # duplicate mode option = shift argv NOTD: ne option, "-u", GO $I12 = 1 # unique mode option = shift argv GO: .local string file_name file_name = option $I1 = 1 # count .local pmc in_fh in_fh = open file_name, 'r' unless in_fh, ERR .local string prev_line, curr_line prev_line = readline in_fh SOURCE_LOOP: unless in_fh, END curr_line = readline in_fh if curr_line == prev_line goto MATCH # different line unless $I10, NOTC2 # count mode # we go to some lengths to make the count pretty set $S3, $I1 length $I2, $S3 sub $I2, 7, $I2 set $S3, " " repeat $S3, $S3, $I2 print $S3 print $I1 print " " print prev_line branch RESET NOTC2: unless $I11, NOTD2 # show duplicates mode eq 1, $I1, RESET print prev_line branch RESET ERR: print "Couldn't read " print $S0 exit 1 NOTD2: unless $I12, NOTU2 # don't show lines that are duplicated mode ne 1, $I1, RESET print prev_line branch RESET NOTU2: # default mode print prev_line branch RESET RESET: set $I1, 1 branch LOOP MATCH: inc $I1 # fall through LOOP: set prev_line, curr_line if curr_line, SOURCE_LOOP close in_fh END: .end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: QueryHash.pir000644000765000765 1133612101554067 21200 0ustar00bruce000000000000parrot-6.6.0/runtime/parrot/library/CGI# Copyright (C) 2006-2012, Parrot Foundation. .namespace ['CGI'; 'QueryHash'] =head1 NAME CGI;QueryHash - A helper for classic CGI =head1 SYNOPSIS load_bytecode 'CGI/QueryHash.pbc' parse_get_sub = get_global [ 'CGI'; 'QueryHash' ], 'parse_get' .local pmc params_from_get params_from_get = parse_get_sub() parse_post_sub = get_global [ 'CGI'; 'QueryHash' ], 'parse_post' .local pmc params_from_post params_from_post = parse_post_sub() =head1 DESCRIPTION This PIR module is a helper for classic CGI. =head1 FUNCTIONS =over =item parse_get Get parameters for GET method. =cut .sub 'parse_get' .local pmc my_env, query_hash .local int does_exist query_hash = new 'Hash' my_env = new 'Env' does_exist = exists my_env['QUERY_STRING'] unless does_exist goto end_parse_get .local string query query = my_env['QUERY_STRING'] #_dumper( query, 'queryGET:' ) query_hash = parse( query ) end_parse_get: .return (query_hash) .end =item parse_post Get parameters for POST method. =cut .sub 'parse_post' .local pmc my_env, query_hash .local int does_exist query_hash = new 'Hash' my_env = new 'Env' does_exist = exists my_env['CONTENT_LENGTH'] unless does_exist goto end_parse_post .local pmc in .local string content_length, query .local int len content_length = my_env['CONTENT_LENGTH'] len = content_length $P0 = getinterp in = $P0.'stdin_handle'() query = in.'read'(len) in.'close'() #_dumper( query, 'queryPOST:' ) query_hash = parse( query ) end_parse_post: .return (query_hash) .end =item parse Split into a hash. '[]' indicates that the value should be put into an array. =cut .sub 'parse' .param string query unless query goto END .local pmc query_hash, items, items_tmp_1, items_tmp_2 .local string kv, k, v, item_tmp_1, item_tmp_2, last_chars_of_k .local int i, j, n, o, len_of_k query_hash = new 'Hash' items = new 'ResizableStringArray' # split by '&' and ';' items_tmp_1 = split ';', query i = 0 n = elements items_tmp_1 next_loop_1: if i >= n goto end_loop_1 item_tmp_1 = items_tmp_1[i] inc i items_tmp_2 = split '&', item_tmp_1 j = 0 o = elements items_tmp_2 next_loop_2: if j >= o goto next_loop_1 item_tmp_2 = items_tmp_2[j] push items, item_tmp_2 inc j goto next_loop_2 end_loop_1: i = 0 n = elements items lp_items: kv = items[i] $I0 = index kv, "=" if $I0 == -1 goto no_val k = substr kv, 0, $I0 k = urldecode(k) inc $I0 v = substr kv, $I0 goto set_val no_val: k = kv v = 1 set_val: v = urldecode(v) # a special case: [] indicates an array len_of_k = length k if len_of_k <= 2 goto v_isnt_array last_chars_of_k = substr k, -2 ne last_chars_of_k, '[]', v_isnt_array .local pmc v_array # TODO: This should be an array v_array = new 'Hash' v_array[0] = v k = replace k, -2, 2, '' query_hash[k] = v_array branch next_item v_isnt_array: query_hash[k] = v next_item: inc i if i < n goto lp_items END: .return (query_hash) .end =item urldecode convert %xx to char =cut .sub urldecode .param string in .local string out, char_in, char_out .local int c_out, pos_in, len .local string hex len = length in pos_in = 0 out = "" START: if pos_in >= len goto END substr char_in, in, pos_in, 1 char_out = char_in if char_in != "+" goto NOT_A_PLUS char_out = ' ' goto INC_IN NOT_A_PLUS: if char_in != "%" goto INC_IN # OK this was a escape character, next two are hexadecimal inc pos_in substr hex, in, pos_in, 2 c_out = hex_to_int (hex) chr char_out, c_out inc pos_in goto INC_IN INC_IN: out = concat out, char_out inc pos_in goto START END: .return( out ) .end .sub hex_to_int .param pmc hex .tailcall hex.'to_int'(16) .end =back =head1 HISTORY Splitting of query string is taken from HTTP/Daemon.pir. =head1 TODO Better method names. Add stuff that Pipp needs. Find or write a test suite for CGI. =head1 SEE ALSO F, F, F, L =head1 AUTHOR Bernhard Schmalhofer - =cut # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: 18-associative.t000644000765000765 77712101554066 17474 0ustar00bruce000000000000parrot-6.6.0/ext/nqp-rx/t/nqp#!./parrot-nqp # check hash access methods plan(7); my %h; %h := 1; say("ok 1 # hash assignment with numeric value works"); say('ok ', %h + 1, ' # hash access to numeric value'); %h := 'ok 3'; say(%h, ' # hash access to string value'); %h{1} := '4'; say('ok ', %h{1}, ' # numeric hash access'); say('ok ', %h<1> + 1, ' # numbers stringify'); %h{'b'} := 'ok 6 # curly braces and single quotes work'; say(%h{'b'}); %h{"foo"} := "ok 7 # curly braces and double quotes work"; say(%h{"foo"}); PCT_Tutorial.pm000644000765000765 417211533177636 20666 0ustar00bruce000000000000parrot-6.6.0/lib/Parrot/Docs/Section# Copyright (C) 2010, Parrot Foundation. =head1 NAME Parrot::Docs::Section::PCT_Tutorial - Tutorial of Parrot Comiler Tools =head1 SYNOPSIS use Parrot::Docs::Section::PCT_Tutorial; =head1 DESCRIPTION A tutorial series on building a compiler with the Parrot Compiler Tools. =head2 Class Methods =over =cut package Parrot::Docs::Section::PCT_Tutorial; use strict; use warnings; use base qw( Parrot::Docs::Section ); use Parrot::Docs::Item; use Parrot::Docs::Group; =item C Returns a new section. =cut sub new { my $self = shift; return $self->SUPER::new( 'PCT Tutorial', 'PCT_Tutorial.html', '', $self->new_group( 'Tutorial of Parrot Compiler Tools', '', $self->new_item( 'Episode 1: Introduction', 'examples/languages/squaak/doc/tutorial_episode_1.pod'), $self->new_item( 'Episode 2: Poking in Compiler Guts', 'examples/languages/squaak/doc/tutorial_episode_2.pod'), $self->new_item( 'Episode 3: Squaak Details and First Steps', 'examples/languages/squaak/doc/tutorial_episode_3.pod'), $self->new_item( 'Episode 4: PAST Nodes and More Statements', 'examples/languages/squaak/doc/tutorial_episode_4.pod'), $self->new_item( 'Episode 5: Variable Declaration and Scope', 'examples/languages/squaak/doc/tutorial_episode_5.pod'), $self->new_item( 'Episode 6: Scope and Subroutines', 'examples/languages/squaak/doc/tutorial_episode_6.pod'), $self->new_item( 'Episode 7: Operators and Precedence', 'examples/languages/squaak/doc/tutorial_episode_7.pod'), $self->new_item( 'Episode 8: Hashtables and Arrays', 'examples/languages/squaak/doc/tutorial_episode_8.pod'), $self->new_item( 'Episode 9: Wrap up and Conclusion', 'examples/languages/squaak/doc/tutorial_episode_9.pod'), ), ); } =back =cut 1; # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: hamming.pir000644000765000765 323011533177634 17565 0ustar00bruce000000000000parrot-6.6.0/examples/benchmarks# Copyright (C) 2009, Parrot Foundation. =head1 NAME examples/benchmarks/hamming.pir - calculate hamming distance between two strings =head1 SYNOPSIS ./parrot examples/benchmarks/hamming.pir foobar foozibar =head1 DESCRIPTION Calculate the number of characters that are different between two strings. Strings need not be the same length. This benchmark should be useful for looking into the performance of String PMC -> string conversion and function calls. =cut .sub main .param pmc argv .local pmc s1, s2 .local int argc $S0 = shift argv # get rid of filename argc = argv s1 = new 'String' s2 = new 'String' if argc == 2 goto get_args s1 = "bbbcdebbbcdebbcdebcdbcdebbcdebebbcdebcdebbcdebbbcdebbcdebbcdebbcdebcdef" s2 = "acdbcdeabcdeaeaabcdeabbcdeadeaeabcdebcdeabcdeaabcdeabcdeabcdeabcdebcdef" goto get_distance get_args: s1 = argv[0] s2 = argv[1] get_distance: $I0 = distance(s1,s2) print $I0 print "\n" .end .sub distance .param string s1 .param string s2 .local int dist .local int min, max dist = 0 $I0 = length s1 $I1 = length s2 min = $I0 max = $I1 if $I0 < $I1 goto calc_dist min = $I1 max = $I0 calc_dist: dist = max - min .local int k k = 0 loop: $S1 = get_char(s1,k) $S2 = get_char(s2,k) $I4 = $S1 != $S2 dist += $I4 inc k if k >= min goto done goto loop done: .return (dist) .end .sub get_char .param string s .param int k $S0 = substr s, k, 1 .return ($S0) .end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: configverbose000644000765000765 156111715102032 20241 0ustar00bruce000000000000parrot-6.6.0/examples/config/file =variables =general verbose =steps init::manifest nomanicheck init::defaults init::install init::hints inter::progs inter::make inter::lex inter::yacc auto::gcc auto::glibc auto::backtrace auto::fink auto::macports auto::msvc auto::attributes auto::warnings init::optimize inter::shlibs inter::libparrot inter::charset inter::encoding inter::types auto::ops auto::pmc auto::alignptrs auto::headers auto::sizes auto::byteorder auto::va_ptr auto::format auto::isreg auto::arch auto::jit auto::cpu auto::funcptr auto::inline auto::gc auto::memalign auto::signal auto::socklen_t auto::env auto::gmp auto::readline auto::gdbm auto::pcre auto::opengl auto::crypto auto::gettext auto::snprintf # auto::perldoc auto::ctags auto::revision auto::icu auto::platform gen::config_h gen::core_pmcs gen::crypto gen::opengl gen::call_list gen::languages gen::makefiles gen::config_pm =cut oo1.rb000644000765000765 26711466337261 16442 0ustar00bruce000000000000parrot-6.6.0/examples/benchmarks#! ruby # # does the perl variant count as oo? # class Foo attr_reader :i, :j def initialize() @i = 10 @j = 20 end end (1..100000).each{ o = Foo.new } o = Foo.new puts o.i freeze.pl000644000765000765 202111533177634 17243 0ustar00bruce000000000000parrot-6.6.0/examples/benchmarks#! perl # Copyright (C) 2001-2006, Parrot Foundation. =head1 NAME examples/benchmarks/freeze.pl - Freeze/Thaw Benchmarks =head1 SYNOPSIS % time perl examples/benchmarks/freeze.pl =head1 DESCRIPTION Freeze/thaw a C. Uses C to archive the array. =cut use strict; use warnings; use Storable qw( freeze thaw dclone ); use Time::HiRes qw( time ); my @a; my $s = time(); for my $i ( 0 .. 99999 ) { push @a, $i; } my $e = time(); printf "constr.time %.6f\n", $e - $s; $s = time(); my $image = freeze( \@a ); $e = time(); printf "freeze time %.6f\n", $e - $s; $s = time(); my @b = @{ thaw $image }; $e = time(); printf " thaw time %.6f\n", $e - $s; #$s = time(); #my $c = dclone \@a; #$e = time(); #printf " clone time %.6f\n", $e-$s; print "Image len ", length($image), "\n"; print "array size ", scalar(@b), "\n"; =head1 SEE ALSO F. =cut # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: Makefile000644000765000765 233411533177634 16034 0ustar00bruce000000000000parrot-6.6.0/examples/embed# Copyright (C) 2009, Parrot Foundation. # # To build this example with an installed parrot: # # PATH=/parrot_install_directory/bin:$PATH # make # This assumes a posix environment with sh style shell. # May need changes with other shells or other make tools. # For MSVC use see nmake -f Makefile.msvc (may not be up-to-date) CC = $(shell parrot_config cc) CCFLAGS = $(shell parrot_config ccflags) CCWARN = $(shell parrot_config ccwarn) LD = $(shell parrot_config ld) LD_OUT = $(shell parrot_config ld_out) LINKFLAGS = $(shell parrot_config inst_libparrot_linkflags) $(shell parrot_config rpath_lib) O = $(shell parrot_config o) EXE = $(shell parrot_config exe) VERSIONDIR = $(shell parrot_config versiondir) INCLUDEDIR = $(shell parrot_config includedir)$(VERSIONDIR) LIBDIR = $(shell parrot_config libdir)$(VERSIONDIR) CONFIG = $(LIBDIR)/parrot_config all: cotorra$(EXE) #----------------------------------------------------------------------- cotorra$(O): cotorra.c $(CC) $(CCFLAGS) $(CCWARN) -c -I $(INCLUDEDIR) cotorra.c cotorra$(EXE): cotorra$(O) $(LD) $(LD_OUT)cotorra$(EXE) cotorra$(O) $(CONFIG)$(O) $(LINKFLAGS) #----------------------------------------------------------------------- clean: rm -f cotorra$(EXE) cotorra$(O) asm.s000644000765000765 214011656271051 15627 0ustar00bruce000000000000parrot-6.6.0/src/platform/aix# POWER/AIX asm helper functions for preserving cache synchronization and # respecting AIX calling conventions # Commented instructions are the important bits; supporting boilerplate # generated by xlc .machine "pwr" .set SP,1; .set RTOC,2; .set BO_ALWAYS,20; .set CR0_LT,0 .globl .aix_get_toc .globl .ppc_sync .globl .ppc_flush_line .globl .Parrot_ppc_jit_restore_nonvolatile_registers # Flushes the cache line whose address is passed in .ppc_flush_line: .function .ppc_flush_line,.ppc_flush_line,2,0 stm 30,-8(1) stu 1,-48(1) mr 30,1 st 3,72(30) l 0,72(30) clf 0,0 # "Cache Line Flush", analog of "dcbf" instruction on PPC l 1,0(1) lmw 30,-8(1) bcr BO_ALWAYS,CR0_LT # Synchronizes the cache .ppc_sync: .function .ppc_sync,.ppc_sync,2,0 dcs # "Data Cache Synchronize", analog of "sync" instruction on PPC bcr BO_ALWAYS,CR0_LT # Returns the value from the TOC register r2 .aix_get_toc: .function .aix_get_toc,.aix_get_toc,2,0 stu SP,-80(SP) mr 3, RTOC # Copy r2 (TOC) into r3 (return value) st 3,68(SP) cal SP,80(SP) bcr BO_ALWAYS,CR0_LT tutorial_episode_5.pod000644000765000765 3576112101554066 23643 0ustar00bruce000000000000parrot-6.6.0/examples/languages/squaak/doc# Copyright (C) 2008-2012, Parrot Foundation. =pod =head1 DESCRIPTION This is the fifth episode in a tutorial series on building a compiler with the Parrot Compiler Tools. =head1 Episode 5: Variable Declaration and Scope Episode 4 discussed the implementation of some statement types, such as the if-statement. In this episode we'll talk about variable declarations and scope handling. It's going to be a long story, so take your time to read this episode. =head2 Globals, locals and default values Squaak variables have one of two scopes: either they're global, or they're local. In order to create a global variable, you just assign some expression to an identifier (which hasn't been declared as a local). Local variables, on the other hand, must be declared using the "var" keyword. In other words, at any given point during the parsing phase, we have a list of variables that are known to be local variables. When an identifier is parsed, it is looked up and if found, its scope is set to local. If not, its scope is assumed to be global. When using an uninitialized variable, its value is set to an object called C<"Undef">. Some examples are shown below. x = 42 # x was not declared, so it is global var k = 10 # k is local and initialized to 10 a + b # neither a nor b was declared; # both default to the value "Undef" =head2 Scoping and Symbol Tables Earlier we mentioned the need to store declared local variables. In compiler jargon, such a data structure to store declarations is called a I. For each individual scope, there's a separate symbol table. Squaak has a so-called do-block statement, that is defined below. rule statement:sym { 'end' } Each do-block defines a new scope; local variables declared between the C and C keywords are local to that block. An example to clarify this is shown below: do var x = 1 print(x) # prints 1 do var x = 2 print(x) # prints 2 end print(x) # prints 1 end So, each do/end pair defines a new scope, in which any declared variables hide variables with the same name in outer scopes. This behavior is common in many programming languages. The PCT has built-in support for symbol tables; a C object has a method symbol that can be used to enter new symbols and query the table for existing ones. In PCT, a C object represents a scope. There are two blocktypes: C and C. An "immediate" block can be used to represent the blocks of statements in an do-block statement, for instance: do end When executing this statement, block is executed immediately. A "declaration" block, on the other hand, represents a block of statements that can be invoked at a later point, typically these are subroutines. So, in this example: sub foo(x) print(x) end a C object is created for the subroutine "foo". The blocktype is set to "declaration", as the subroutine is defined, not executed (immediately). For now you can forget about the blocktype, but now that I've told you, you'll recognize it when you see it. We'll come back to it in a later episode. =head2 Implementing Scope So, we know how to use global variables, declare local variables, and about C objects representing scopes. How do we make our compiler to generate the right PIR instructions? After all, when handling a global variable, Parrot must handle this differently from handling a local variable. When creating C nodes to represent the variables, we must know whether the variable is a local or a global variable. So, when handling variable declarations (of local variables; globals are not declared), we need to register the identifier as a local in the current block's symbol table. First, we'll take a look at the implementation of variable declarations. =head2 Variable declaration The following is the grammar rule for variable declarations. This is a type of statement, so I assume you know how to extend the statement rule to allow for variable declarations. rule statement:sym { ['=' ]? } A local variable is declared using the C keyword, and has an optional initialization expression. If the latter is missing, the variable's value defaults to the undefined value called "Undef". Let's see what the parse action looks like: method statement:sym($/) { # get the PAST for the identifier my $past := $.ast; # this is a local (it's being defined) $past.scope('lexical'); # set a declaration flag $past.isdecl(1); # check for the initialization expression if $ { # use the viviself clause to add a # an initialization expression $past.viviself($[0].ast); } else { # no initialization, default to "Undef" $past.viviself('Undef'); } make $past; } Well, that wasn't too hard, was it? Let's analyze what we just did. First we retrieved the PAST node for the identifier, which we then decorated by setting its scope to "lexical" (a local variable is said to be lexically scoped, hence "lexical"), and setting a flag indicating this node represents a declaration (C). So, besides representing variables in other statements (for instance, assignments), a C node is also used as a declaration statement. Earlier in this episode we mentioned the need to register local variables in the current scope block when they are declared. So, when executing the parse action for variable-declaration, there should already be a C node around, that can be used to register the symbol being declared. As we learned in Episode 4, PAST nodes are created in a depth-first fashion; the leafs are created first, and then the nodes "higher" in the parse tree. This implies that a C node is created after the statement nodes (which C is) that will be the children of the block. In the next section we'll see how to solve this problem. =head2 Implementing a scope stack In order to make sure that a PAST::Block node is created before any statements are parsed (and their parse actions are executed -- these might need to enter symbols in the block's symbol table), we add a few extra parse actions. Let's take a look at them. Add this token to the grammar: token begin_TOP { } It uses something we haven't seen before, . The null pattern always returns true without consuming any text. Tokens consisting of only are frequently used to invoke additional action methods. Add this method to Actions.pm: method begin_TOP ($/) { our $?BLOCK := PAST::Block.new(:blocktype, :node($/), :hll); our @?BLOCK; @?BLOCK.unshift($?BLOCK); } We create a new C node and assign it to a strange-looking (if you don't know Perl, like me. Oh wait, this is Perl. Never mind..) variable called C<$?BLOCK>. This variable is declared as "our", which means that it is a package variable. This means that the variable is shared by all methods in the same package (or class), and, equally important, the variable is still around after the parse action is done. Please refer to the Perl 6 specification for more semantics on "our". The variable C<$?BLOCK> holds the current block. After that, this block is unshifted onto another funny-looking variable, called C<@?BLOCK>. This variable has a "@" sigil, meaning this is an array. The unshift method puts its argument on the front of the list. In a sense, you could think of the front of this list as the top of a stack. Later we'll see why this stack is necessary. This C<@?BLOCK> variable is also declared with "our", meaning it's also package-scoped. Since it's an array variable, it is automatically initialized with an empty ResizablePMCArray. Now we need to modify our TOP rule to call begin_TOP. rule TOP { <.begin_TOP> [ $ || <.panic: "Syntax error"> ] } "<.begin_TOP>" is just like , calling the subrule begin_TOP, with one difference: The <.subrule> form does not capture. Normally, when match a subrule , $ on the match object is bound to the subrule's match result. With <.foo>, $ is not bound. The parse action for begin_TOP is executed before any input is parsed, which is particularly suitable for any initialization actions you might need. The action for TOP is executed after the whole input string is parsed. Now we can create a C node before any statements are parsed, so that when we need the current block, it's there (somewhere, later we'll see where exactly). Let's take a look at the parse action for TOP. method TOP($/, $key) { our @?BLOCK; my $past := @?BLOCK.shift(); $past.push($.ast); make $past; } Let's take a quick look at the updated parse action for TOP, which is executed after the whole input string is parsed. The C node is retrieved from C<@?BLOCK>, which makes sense, as it was created in the first part of the method and unshifted on C<@?BLOCK>. Now this node can be used as the final result object of TOP. So, now we've seen how to use the scope stack, let's have a look at its implementation. =head2 Storing Symbols Now, we set up the necessary infrastructure to store the current scope block, and we created a datastructure that acts as a scope stack, which we will need later. We'll now go back to the parse action for statement:sym, because we didn't enter the declared variable into the current block's symbol table yet. We'll see how to do that now. First, we need to make the current block accessible from the method statement:sym. We've already seen how to do that, using the "our" keyword. It doesn't really matter where in the action method we enter the symbol's name into the symbol table, but let's do it at the end, after the initialization stuff. Naturally, we're only going to enter the symbol if it's not there already; duplicate variable declarations (in the same scope) should result in an error message (using the panic method of the match object). The code to be added to the method statement:sym looks then like this: method statement:sym($/) { our $?BLOCK; # get the PAST node for identifier # set the scope and declaration flag # do the initialization stuff # cache the name into a local variable my $name := $past.name(); if $?BLOCK.symbol( $name ) { # symbol is already present $/.CURSOR.panic("Error: symbol " ~ $name ~ " was already defined.\n"); } else { $?BLOCK.symbol( $name, :scope('lexical') ); } make $past; } =head2 What's Next? With this code in place, variable declarations are handled correctly. However, we didn't update the parse action for identifier, which creates the C node and sets its scope; currently all identifiers' scope is set to C (which means it's a global variable). As we already covered a lot of material in this episode, we'll leave this for the next episode. In the next episode, we'll also cover subroutines, which is another important aspect of any programming language. Hope to catch you later! =head2 Exercises =over 4 =item * In this episode, we changed the action method for the C rule; it is now invokes the new begin_TOP action at the beginning of the parse. The block rule, which defines a block to be a series of statements, represents a new scope. This rule is used in for instance if-statement (the then-part and else-part), while-statement (the loop body) and others. Add a new begin_block rule consisting of ; in the action for it, create a new PAST::Block and store it onto the scope stack. Update the rule for block so that it calls begin_block before parsing the statements. Update the parse action for block after parsing the statements, during which this PAST node is set as the result object. Make sure C<$?BLOCK> is always pointing to the current block. In order to do this exercise correctly, you should understand well what the shift and unshift methods do, and why we didn't implement methods to push and pop, which are more appropriate words in the context of a (scope) stack. =back =head2 Solution to the exercise =head3 Keeping the Current block up to date Sometimes we need to access the current block's symbol table. In order to be able to do so, we need a reference to the "current block". We do this by declaring a package variable called C<$?BLOCK>, declared with "our" (as opposed with "my"). This variable will always point to the "current" block. As blocks can nest, we use a "stack", on which newly created blocks are stored. Whenever a new block is created, we assign this to C<$?BLOCK>, and store it onto the stack, so that the next time a new block is created, the "old" current block isn't lost. Whenever a scope is closed, we pop off the current block from the stack, and restore the previous "current" block. =head3 Why unshift/shift and not push/pop? When we're talking about stacks, it would seem logical to talk about stack operations such as "push" and "pop". Instead, we use the operations "unshift" and "shift". If you're not a Perl programmer (such as myself), these names might not make sense. However, it's pretty easy. Instead of pushing a new object onto the "top" of the stack, you unshift objects onto this stack. Just see it as an old school bus, with only one entrance (at the front of the bus). Pushing a new person means taking the first free seat when entering, while unshifting a new person means everybody moves (shifts) one place to the back, so the new person can sit in the front seat. You might think this is not as efficient (more stuff is moved around), but that's not really true (actually: I guess (and certainly hope) the shift and unshift operations are implemented more effectively than the bus metaphor; I don't know how it is implemented). So why unshift/shift, and not push/pop? When restoring the previous "current block", we need to know exactly where it is (what position). It would be nice to be able to always refer to the "first passenger on the bus", instead of the last person. We know how to reference the first passenger (it's on seat no. 0 (it was designed by an IT guy)); we don't really know what is the seat no. of the last person: s/he might sit in the middle, or at the back. I hope it's clear what I mean here... otherwise, have a look at the code, and try to figure out what's happening: # In src/Squaak/Grammar.pm token begin_block { } rule block { <.begin_block> * } # In src/Squaak/Actions.pm method begin_block { our $?BLOCK; our @?BLOCK; $?BLOCK := PAST::Block.new(:blocktype('immediate'), :node($/)); @?BLOCK.unshift($?BLOCK); } method block($/, $key) { our $?BLOCK; our @?BLOCK; my $past := @?BLOCK.shift(); $?BLOCK := @?BLOCK[0]; for $ { $past.push($_.ast); } make $past; } =cut 046-inter.t000644000765000765 460712312075407 15537 0ustar00bruce000000000000parrot-6.6.0/t/configure#! perl # Copyright (C) 2007, Parrot Foundation. # 046-inter.t use strict; use warnings; use Test::More tests => 12; use Carp; use lib qw( lib t/configure/testlib ); use Parrot::Configure; use Parrot::Configure::Options qw( process_options ); use IO::CaptureOutput qw | capture |; use Tie::Filehandle::Preempt::Stdin; $| = 1; is( $|, 1, "output autoflush is set" ); my ($args, $step_list_ref) = process_options( { argv => [], mode => q{configure}, } ); ok( defined $args, "process_options returned successfully" ); my %args = %$args; my $conf = Parrot::Configure->new; ok( defined $conf, "Parrot::Configure->new() returned okay" ); my $step = q{inter::theta}; my $description = 'Determining if your computer does theta'; $conf->add_steps($step); my @confsteps = @{ $conf->steps }; isnt( scalar @confsteps, 0, "Parrot::Configure object 'steps' key holds non-empty array reference" ); is( scalar @confsteps, 1, "Parrot::Configure object 'steps' key holds ref to 1-element array" ); my $nontaskcount = 0; foreach my $k (@confsteps) { $nontaskcount++ unless $k->isa("Parrot::Configure::Task"); } is( $nontaskcount, 0, "Each step is a Parrot::Configure::Task object" ); is( $confsteps[0]->step, $step, "'step' element of Parrot::Configure::Task struct identified" ); ok( !ref( $confsteps[0]->object ), "'object' element of Parrot::Configure::Task struct is not yet a ref" ); $conf->options->set(%args); is( $conf->options->{c}->{debugging}, 1, "command-line option '--debugging' has been stored in object" ); { my $rv; my $stdout; capture ( sub {$rv = $conf->runsteps}, \$stdout ); ok($rv, "runsteps() returned true value"); like( $stdout, qr/$description\.\.\./s, "Got STDOUT message expected upon running $step"); } pass("Completed all tests in $0"); ################### DOCUMENTATION ################### =head1 NAME 046-inter.t - test Parrot::Configure::_run_this_step() =head1 SYNOPSIS % prove t/configure/046-inter.t =head1 DESCRIPTION The files in this directory test functionality used by F. This file tests Parrot::Configure::_run_this_step() with regard to configuration steps that prompt for user input. =head1 AUTHOR James E Keenan =head1 SEE ALSO Parrot::Configure, F. =cut # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: arrayiterator.pmc000644000765000765 3222612356767111 16463 0ustar00bruce000000000000parrot-6.6.0/src/pmc/* Copyright (C) 2001-2014, Parrot Foundation. =head1 NAME src/pmc/arrayiterator.pmc - ArrayIterator PMC =head1 DESCRIPTION Generic iterator for traversing arrays. =head1 SYNOPSIS =head2 default usage .local pmc iterator, array, entry iterator = iter array iter_loop: unless iterator, iter_end # while (more values) entry = shift iterator # get an entry ... goto iter_loop iter_end: =head2 iterate from the end, for arrays .local pmc iterator, array, entry iterator = iter array iterator = .ITERATE_FROM_END iter_loop: unless iterator, iter_end # while (more values) entry = pop iterator # get an entry ... goto iter_loop iter_end: =head2 Warning! NB: for different direction you have to use different ops! TODO: Discuss idea of having separate get_iter/get_reverse_iter VTABLEs to avoid this caveat. =head1 Vtable functions =over 4 =cut */ /* HEADERIZER HFILE: none */ /* HEADERIZER BEGIN: static */ /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */ PARROT_DOES_NOT_RETURN static void out_of_bounds(PARROT_INTERP) __attribute__nonnull__(1); #define ASSERT_ARGS_out_of_bounds __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp)) /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */ /* HEADERIZER END: static */ pmclass ArrayIterator extends Iterator provides iterator no_ro auto_attrs { ATTR PMC *array; /* the array which this Iterator iterates */ ATTR INTVAL pos; /* Current position of iterator for forward iterator */ /* Previous position of iterator for reverse iterator */ ATTR INTVAL length; /* Length of C */ ATTR INTVAL reverse; /* Direction of iteration. 1 - for reverse iteration */ /* =item C Raises an exception. Use C. =cut */ VTABLE void init() :no_wb { UNUSED(SELF) Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_INVALID_OPERATION, "ArrayIterator init without aggregate"); } /* =item C Initializes the iterator with an aggregate PMC. Defaults iteration mode to iterate from start. =cut */ VTABLE void init_pmc(PMC *array) :manual_wb { SET_ATTR_array(INTERP, SELF, array); PObj_custom_mark_SET(SELF); /* by default, iterate from start */ STATICSELF.set_integer_native(ITERATE_FROM_START); } /* =item C Marks the current idx/key and the aggregate as live. =cut */ VTABLE void mark() :no_wb { PMC *array; GET_ATTR_array(INTERP, SELF, array); Parrot_gc_mark_PMC_alive(INTERP, array); } /* =item C =cut */ VTABLE PMC* clone() :no_wb { INTVAL pos, reverse; PMC *array; PMC *clone; GET_ATTR_array(INTERP, SELF, array); GET_ATTR_pos(INTERP, SELF, pos); GET_ATTR_reverse(INTERP, SELF, reverse); clone = Parrot_pmc_new_init(INTERP, enum_class_ArrayIterator, array); PARROT_GC_WRITE_BARRIER(INTERP, SELF); SET_ATTR_pos(INTERP, clone, pos); SET_ATTR_reverse(INTERP, clone, reverse); return clone; } /* =item C Returns true if there is more elements to iterate over. =cut */ VTABLE INTVAL get_bool() :no_wb { return STATICSELF.elements() > 0; } /* =item C Returns the number of remaining elements in the array. =cut */ VTABLE INTVAL elements() :no_wb { INTVAL reverse; GET_ATTR_reverse(INTERP, SELF, reverse); if (reverse) { INTVAL pos; GET_ATTR_pos(INTERP, SELF, pos); return pos; } else { INTVAL pos, length; GET_ATTR_length(INTERP, SELF, length); GET_ATTR_pos(INTERP, SELF, pos); return length - pos; } } VTABLE INTVAL get_integer() :no_wb { return STATICSELF.elements(); } /* =item C Reset the Iterator. C must be one of ITERATE_FROM_START ... Iterate from start ITERATE_FROM_END ... Iterate from end =cut */ VTABLE void set_integer_native(INTVAL value) { PMC *array; INTVAL element; GET_ATTR_array(INTERP, SELF, array); element = VTABLE_elements(INTERP, array); switch (value) { case ITERATE_FROM_START: SET_ATTR_reverse(INTERP, SELF, 0); SET_ATTR_pos(INTERP, SELF, 0); SET_ATTR_length(INTERP, SELF, element); break; case ITERATE_FROM_END: SET_ATTR_reverse(INTERP, SELF, 1); SET_ATTR_length(INTERP, SELF, element); SET_ATTR_pos(INTERP, SELF, element); break; default: Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_INVALID_OPERATION, "Wrong direction for ArrayIterator"); } } /* =item C Returns this Iterator's array. =cut */ VTABLE PMC *get_pmc() :no_wb { PMC *array; GET_ATTR_array(INTERP, SELF, array); return array ? array : PMCNULL; } /* =item C Returns the element for the current idx and sets the idx to the next one. =cut */ VTABLE INTVAL shift_integer() :manual_wb { INTVAL pos, length; PMC *array; GET_ATTR_pos(INTERP, SELF, pos); GET_ATTR_length(INTERP, SELF, length); if (pos >= length) out_of_bounds(INTERP); GET_ATTR_array(INTERP, SELF, array); SET_ATTR_pos(INTERP, SELF, pos+1); PARROT_GC_WRITE_BARRIER(INTERP, SELF); return VTABLE_get_integer_keyed_int(INTERP, array, pos); } /* =item C =cut */ VTABLE FLOATVAL shift_float() :manual_wb { INTVAL pos; PMC *array; GET_ATTR_pos(INTERP, SELF, pos); if (!STATICSELF.get_bool()) out_of_bounds(INTERP); GET_ATTR_array(INTERP, SELF, array); SET_ATTR_pos(INTERP, SELF, pos+1); PARROT_GC_WRITE_BARRIER(INTERP, SELF); return VTABLE_get_number_keyed_int(INTERP, array, pos); } /* =item C =cut */ VTABLE STRING *shift_string() :manual_wb { INTVAL pos; PMC *array; GET_ATTR_pos(INTERP, SELF, pos); if (!STATICSELF.get_bool()) out_of_bounds(INTERP); GET_ATTR_array(INTERP, SELF, array); SET_ATTR_pos(INTERP, SELF, pos+1); PARROT_GC_WRITE_BARRIER(INTERP, SELF); return VTABLE_get_string_keyed_int(INTERP, array, pos); } /* =item C Returns the element for the current idx/key and sets the idx/key to the next one. =cut */ VTABLE PMC *shift_pmc() :manual_wb { INTVAL pos; PMC *array; GET_ATTR_pos(INTERP, SELF, pos); if (!STATICSELF.get_bool()) out_of_bounds(INTERP); GET_ATTR_array(INTERP, SELF, array); SET_ATTR_pos(INTERP, SELF, pos+1); PARROT_GC_WRITE_BARRIER(INTERP, SELF); return VTABLE_get_pmc_keyed_int(INTERP, array, pos); } /* =item C Returns the element for the current idx and sets the idx to the next one. =cut */ VTABLE INTVAL pop_integer() :manual_wb { INTVAL pos; PMC *array; GET_ATTR_pos(INTERP, SELF, pos); if (!STATICSELF.get_bool()) out_of_bounds(INTERP); GET_ATTR_array(INTERP, SELF, array); SET_ATTR_pos(INTERP, SELF, --pos); PARROT_GC_WRITE_BARRIER(INTERP, SELF); return VTABLE_get_integer_keyed_int(INTERP, array, pos); } /* =item C =cut */ VTABLE FLOATVAL pop_float() :manual_wb { INTVAL pos; PMC *array; GET_ATTR_pos(INTERP, SELF, pos); if (!STATICSELF.get_bool()) out_of_bounds(INTERP); GET_ATTR_array(INTERP, SELF, array); SET_ATTR_pos(INTERP, SELF, --pos); PARROT_GC_WRITE_BARRIER(INTERP, SELF); return VTABLE_get_number_keyed_int(INTERP, array, pos); } /* =item C =cut */ VTABLE STRING *pop_string() :manual_wb { INTVAL pos; PMC *array; GET_ATTR_pos(INTERP, SELF, pos); if (!STATICSELF.get_bool()) out_of_bounds(INTERP); GET_ATTR_array(INTERP, SELF, array); SET_ATTR_pos(INTERP, SELF, --pos); PARROT_GC_WRITE_BARRIER(INTERP, SELF); return VTABLE_get_string_keyed_int(INTERP, array, pos); } /* =item C Returns the element for the current idx/key and sets the idx/key to the next one. =cut */ VTABLE PMC *pop_pmc() :manual_wb { INTVAL pos; PMC *array; GET_ATTR_pos(INTERP, SELF, pos); if (!STATICSELF.get_bool()) out_of_bounds(INTERP); GET_ATTR_array(INTERP, SELF, array); SET_ATTR_pos(INTERP, SELF, --pos); PARROT_GC_WRITE_BARRIER(INTERP, SELF); return VTABLE_get_pmc_keyed_int(INTERP, array, pos); } /* =item C Returns the element for C<*key>. =cut */ VTABLE PMC *get_pmc_keyed(PMC *key) :no_wb { return STATICSELF.get_pmc_keyed_int(VTABLE_get_integer(INTERP, key)); } /* =item C Returns the element for C. =cut */ VTABLE PMC *get_pmc_keyed_int(INTVAL idx) :no_wb { INTVAL pos; GET_ATTR_pos(INTERP, SELF, pos); return VTABLE_get_pmc_keyed_int(INTERP, STATICSELF.get_pmc(), pos + idx); } /* =item C =cut */ VTABLE INTVAL get_integer_keyed(PMC *key) :no_wb { return STATICSELF.get_integer_keyed_int(VTABLE_get_integer(INTERP, key)); } /* =item C Get integer value of current position plus idx. =cut */ VTABLE INTVAL get_integer_keyed_int(INTVAL idx) :no_wb { INTVAL pos; GET_ATTR_pos(INTERP, SELF, pos); return VTABLE_get_integer_keyed_int(INTERP, STATICSELF.get_pmc(), pos + idx); } /* =item C =cut */ VTABLE FLOATVAL get_number_keyed(PMC *key) :no_wb { return STATICSELF.get_number_keyed_int(VTABLE_get_integer(INTERP, key)); } /* =item C Get number value of current position plus idx. =cut */ VTABLE FLOATVAL get_number_keyed_int(INTVAL idx) :no_wb { INTVAL pos; GET_ATTR_pos(INTERP, SELF, pos); return VTABLE_get_number_keyed_int(INTERP, STATICSELF.get_pmc(), pos + idx); } /* =item C =cut */ VTABLE STRING *get_string_keyed(PMC *key) :no_wb { return STATICSELF.get_string_keyed_int(VTABLE_get_integer(INTERP, key)); } /* =item C Get string value of current position plus idx. =cut */ VTABLE STRING *get_string_keyed_int(INTVAL idx) :no_wb { INTVAL pos; GET_ATTR_pos(INTERP, SELF, pos); return VTABLE_get_string_keyed_int(INTERP, STATICSELF.get_pmc(), pos + idx); } /* =item C Returns whether an element for C<*key> exists in the array. =cut */ VTABLE INTVAL exists_keyed(PMC *key) :no_wb { return STATICSELF.exists_keyed_int(VTABLE_get_integer(INTERP, key)); } /* =item C Returns whether an element for C exists in the aggregate. =cut */ VTABLE INTVAL exists_keyed_int(INTVAL idx) :no_wb { INTVAL pos, reverse, final_pos; PMC *array; GET_ATTR_pos(INTERP, SELF, pos); GET_ATTR_reverse(INTERP, SELF, reverse); GET_ATTR_array(INTERP, SELF, array); /* Cheat! */ final_pos = pos + idx - reverse; return VTABLE_exists_keyed_int(INTERP, array, final_pos); } /* =item C =cut */ VTABLE INTVAL defined_keyed(PMC *key) :no_wb { return STATICSELF.defined_keyed_int(VTABLE_get_integer(INTERP, key)); } /* =item C Returns the result of calling C on the aggregate. =cut */ VTABLE INTVAL defined_keyed_int(INTVAL idx) :no_wb { INTVAL pos, reverse, final_pos; PMC *array; GET_ATTR_pos(INTERP, SELF, pos); GET_ATTR_reverse(INTERP, SELF, reverse); GET_ATTR_array(INTERP, SELF, array); /* Cheat! */ final_pos = pos + idx - reverse; return VTABLE_defined_keyed_int(INTERP, array, final_pos); } } /* =back =head1 Auxiliar functions =over 4 =item C Throw out-of-bounds exception. =cut */ PARROT_DOES_NOT_RETURN static void out_of_bounds(PARROT_INTERP) { ASSERT_ARGS(out_of_bounds) Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_OUT_OF_BOUNDS, "StopIteration"); } /* =back =cut */ /* * Local variables: * c-file-style: "parrot" * End: * vim: expandtab shiftwidth=4 cinoptions='\:2=2' : */ oo1.pir000644000765000765 324212101554066 16634 0ustar00bruce000000000000parrot-6.6.0/examples/benchmarks# Copyright (C) 2004-2009, Parrot Foundation. # all timings Athlon 800, gcc 2.95.2 # parrot SVN-HEAD # perl 5.8.0 # python 2.3.3 # perl oo1.pl 0.8 # python oo1.py 1.2 (first time) # python oo1.py 0.51 # original list fixed 4.9 (leaks mem ~ 110 M used) # don't clone vtable 4.4 # Dan's vtable cache 4.3 3.8 # list MIN_ITEMS 4->16 2.25 # find_global hack 2.16 1.6 # reuse exception 2.00 1.37 # reuse regsave mem 1.25 # anchor P1 1.36 # Dan's new object layout 1.05 # parrot -R jit oo1.pasm # find_global hack 1.51 # reuse exception 1.30 # reuse regsave mem 1.23 # anchor P1 1.32 # Dan's new object layout 1.00 # parrot -R jit oo1-prop.pasm 0.54 .namespace [ "Foo" ] .sub 'main' :main newclass $P1, "Foo" addattribute $P1, ".i" addattribute $P1, ".j" set $I10, 0 set $I11, 100000 loop: new $P3, "Foo" inc $I10 #sleep 0.0001 if $I10 < $I11 goto loop new $P3, "Foo" getattribute $P2, $P3, ".i" print $P2 print "\n" .end .sub 'init' :vtable .include "interpinfo.pasm" .param pmc self new $P10, 'Integer' set $P10, 10 setattribute self, ".i", $P10 $P10 = new 'Integer' $P10 = 20 setattribute self, ".j", $P10 .return () .end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: gc_ms.c000644000765000765 16132512312075407 14153 0ustar00bruce000000000000parrot-6.6.0/src/gc/* Copyright (C) 2001-2011, Parrot Foundation. =head1 NAME src/gc/gc_ms.c - Implementation of the basic mark & sweep collector =head1 DESCRIPTION This code implements the default mark and sweep garbage collector. =cut */ #include "parrot/parrot.h" #include "gc_private.h" #include "parrot/list.h" #define DEBUG_FREE_LIST 0 #define PANIC_OUT_OF_MEM(size) failed_allocation(__LINE__, (size)) /* HEADERIZER HFILE: src/gc/gc_private.h */ /* HEADERIZER BEGIN: static */ /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */ PARROT_WARN_UNUSED_RESULT static INTVAL contained_in_attr_pool( ARGIN(const PMC_Attribute_Pool *pool), ARGIN(const void *ptr)) __attribute__nonnull__(1) __attribute__nonnull__(2); PARROT_DOES_NOT_RETURN static void failed_allocation(unsigned int line, unsigned long size); static int gc_ms_active_sized_buffers(ARGIN(const Memory_Pools *mem_pools)) __attribute__nonnull__(1); static void gc_ms_add_free_object(PARROT_INTERP, Memory_Pools *mem_pools, ARGMOD(Fixed_Size_Pool *pool), ARGIN(void *to_add)) __attribute__nonnull__(1) __attribute__nonnull__(3) __attribute__nonnull__(4) FUNC_MODIFIES(*pool); static void gc_ms_alloc_objects(PARROT_INTERP, ARGMOD(Memory_Pools *mem_pools), ARGMOD(Fixed_Size_Pool *pool)) __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__nonnull__(3) FUNC_MODIFIES(*mem_pools) FUNC_MODIFIES(*pool); PARROT_CANNOT_RETURN_NULL PARROT_WARN_UNUSED_RESULT static Parrot_Buffer * gc_ms_allocate_bufferlike_header(PARROT_INTERP, size_t size) __attribute__nonnull__(1); PARROT_MALLOC PARROT_CAN_RETURN_NULL static void * gc_ms_allocate_memory_chunk(PARROT_INTERP, size_t size); PARROT_MALLOC PARROT_CAN_RETURN_NULL static void * gc_ms_allocate_memory_chunk_zeroed(PARROT_INTERP, size_t size); PARROT_CANNOT_RETURN_NULL static void * gc_ms_allocate_pmc_attributes(PARROT_INTERP, ARGMOD(PMC *pmc)) __attribute__nonnull__(1) __attribute__nonnull__(2) FUNC_MODIFIES(*pmc); PARROT_CAN_RETURN_NULL static PMC* gc_ms_allocate_pmc_header(PARROT_INTERP, UINTVAL flags) __attribute__nonnull__(1); PARROT_WARN_UNUSED_RESULT PARROT_CAN_RETURN_NULL static STRING* gc_ms_allocate_string_header(PARROT_INTERP, UINTVAL flags) __attribute__nonnull__(1); static void gc_ms_block_GC_mark(PARROT_INTERP) __attribute__nonnull__(1); static void gc_ms_block_GC_sweep(PARROT_INTERP) __attribute__nonnull__(1); static void gc_ms_destroy_child_interp( ARGMOD(Interp *dest_interp), ARGIN(Interp *source_interp)) __attribute__nonnull__(1) __attribute__nonnull__(2) FUNC_MODIFIES(*dest_interp); static void gc_ms_finalize(PARROT_INTERP) __attribute__nonnull__(1); static void gc_ms_finalize_memory_pools(PARROT_INTERP, ARGIN(Memory_Pools * const mem_pools)) __attribute__nonnull__(1) __attribute__nonnull__(2); static void gc_ms_free_attributes_from_pool( ARGMOD(PMC_Attribute_Pool *pool), ARGMOD(void *data)) __attribute__nonnull__(1) __attribute__nonnull__(2) FUNC_MODIFIES(*pool) FUNC_MODIFIES(*data); static void gc_ms_free_bufferlike_header(PARROT_INTERP, ARGMOD(Parrot_Buffer *obj), size_t size) __attribute__nonnull__(1) __attribute__nonnull__(2) FUNC_MODIFIES(*obj); static void gc_ms_free_memory_chunk(PARROT_INTERP, ARGFREE(void *data)); static void gc_ms_free_pmc_header(PARROT_INTERP, ARGMOD(PMC *pmc)) __attribute__nonnull__(1) __attribute__nonnull__(2) FUNC_MODIFIES(*pmc); static void gc_ms_free_string_header(PARROT_INTERP, ARGMOD(STRING *s)) __attribute__nonnull__(1) __attribute__nonnull__(2) FUNC_MODIFIES(*s); PARROT_CANNOT_RETURN_NULL PARROT_WARN_UNUSED_RESULT static void * gc_ms_get_free_object(PARROT_INTERP, ARGMOD(Memory_Pools *mem_pools), ARGMOD(Fixed_Size_Pool *pool)) __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__nonnull__(3) FUNC_MODIFIES(*mem_pools) FUNC_MODIFIES(*pool); static size_t gc_ms_get_gc_info(PARROT_INTERP, Interpinfo_enum which) __attribute__nonnull__(1); static unsigned int gc_ms_is_blocked_GC_mark(PARROT_INTERP) __attribute__nonnull__(1); static unsigned int gc_ms_is_blocked_GC_sweep(PARROT_INTERP) __attribute__nonnull__(1); PARROT_WARN_UNUSED_RESULT static int gc_ms_is_pmc_ptr(PARROT_INTERP, ARGIN_NULLOK(void *ptr)) __attribute__nonnull__(1); PARROT_WARN_UNUSED_RESULT static int gc_ms_is_string_ptr(PARROT_INTERP, ARGIN_NULLOK(void *ptr)) __attribute__nonnull__(1); static void gc_ms_iterate_live_strings(PARROT_INTERP, string_iterator_callback callback, ARGIN_NULLOK(void *data)) __attribute__nonnull__(1); static void gc_ms_mark_and_sweep(PARROT_INTERP, UINTVAL flags) __attribute__nonnull__(1); static void gc_ms_mark_special(PARROT_INTERP, ARGIN(PMC *pmc)) __attribute__nonnull__(1) __attribute__nonnull__(2); static void gc_ms_mark_str_header(PARROT_INTERP, ARGMOD_NULLOK(STRING *obj)) FUNC_MODIFIES(*obj); static void gc_ms_more_traceable_objects(PARROT_INTERP, Memory_Pools *mem_pools, ARGMOD(Fixed_Size_Pool *pool)) __attribute__nonnull__(1) __attribute__nonnull__(3) FUNC_MODIFIES(*pool); static void gc_ms_pool_init(PARROT_INTERP, ARGMOD(Fixed_Size_Pool *pool)) __attribute__nonnull__(2) FUNC_MODIFIES(*pool); PARROT_MALLOC PARROT_CAN_RETURN_NULL static void * gc_ms_reallocate_memory_chunk(PARROT_INTERP, ARGFREE(void *from), size_t size); PARROT_MALLOC PARROT_CANNOT_RETURN_NULL static void * gc_ms_reallocate_memory_chunk_zeroed(PARROT_INTERP, ARGFREE(void *data), size_t newsize, size_t oldsize); static int gc_ms_sweep_cb(PARROT_INTERP, ARGIN(Memory_Pools *mem_pools), ARGMOD(Fixed_Size_Pool *pool), int flag, ARGMOD(void *arg)) __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__nonnull__(3) __attribute__nonnull__(5) FUNC_MODIFIES(*pool) FUNC_MODIFIES(*arg); static int gc_ms_total_sized_buffers(ARGIN(const Memory_Pools *mem_pools)) __attribute__nonnull__(1); static int gc_ms_trace_active_PMCs(PARROT_INTERP, Parrot_gc_trace_type trace) __attribute__nonnull__(1); static void gc_ms_unblock_GC_mark(PARROT_INTERP) __attribute__nonnull__(1); static void gc_ms_unblock_GC_sweep(PARROT_INTERP) __attribute__nonnull__(1); static void Parrot_gc_allocate_new_attributes_arena( ARGMOD(PMC_Attribute_Pool *pool)) __attribute__nonnull__(1) FUNC_MODIFIES(*pool); PARROT_CANNOT_RETURN_NULL PARROT_MALLOC static PMC_Attribute_Pool * Parrot_gc_create_attrib_pool(size_t attrib_idx); PARROT_CANNOT_RETURN_NULL static PMC_Attribute_Pool * Parrot_gc_get_attribute_pool(PARROT_INTERP, ARGMOD(Memory_Pools *mem_pools), size_t attrib_size) __attribute__nonnull__(2) FUNC_MODIFIES(*mem_pools); PARROT_CANNOT_RETURN_NULL static void * Parrot_gc_get_attributes_from_pool(PARROT_INTERP, ARGMOD(PMC_Attribute_Pool * pool)) __attribute__nonnull__(1) __attribute__nonnull__(2) FUNC_MODIFIES(* pool); static void Parrot_gc_initialize_fixed_size_pools(PARROT_INTERP, ARGMOD(Memory_Pools *mem_pools), size_t init_num_pools) __attribute__nonnull__(2) FUNC_MODIFIES(*mem_pools); #define ASSERT_ARGS_contained_in_attr_pool __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(pool) \ , PARROT_ASSERT_ARG(ptr)) #define ASSERT_ARGS_failed_allocation __attribute__unused__ int _ASSERT_ARGS_CHECK = (0) #define ASSERT_ARGS_gc_ms_active_sized_buffers __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(mem_pools)) #define ASSERT_ARGS_gc_ms_add_free_object __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(pool) \ , PARROT_ASSERT_ARG(to_add)) #define ASSERT_ARGS_gc_ms_alloc_objects __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(mem_pools) \ , PARROT_ASSERT_ARG(pool)) #define ASSERT_ARGS_gc_ms_allocate_bufferlike_header \ __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp)) #define ASSERT_ARGS_gc_ms_allocate_memory_chunk __attribute__unused__ int _ASSERT_ARGS_CHECK = (0) #define ASSERT_ARGS_gc_ms_allocate_memory_chunk_zeroed \ __attribute__unused__ int _ASSERT_ARGS_CHECK = (0) #define ASSERT_ARGS_gc_ms_allocate_pmc_attributes __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(pmc)) #define ASSERT_ARGS_gc_ms_allocate_pmc_header __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp)) #define ASSERT_ARGS_gc_ms_allocate_string_header __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp)) #define ASSERT_ARGS_gc_ms_block_GC_mark __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp)) #define ASSERT_ARGS_gc_ms_block_GC_sweep __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp)) #define ASSERT_ARGS_gc_ms_destroy_child_interp __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(dest_interp) \ , PARROT_ASSERT_ARG(source_interp)) #define ASSERT_ARGS_gc_ms_finalize __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp)) #define ASSERT_ARGS_gc_ms_finalize_memory_pools __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(mem_pools)) #define ASSERT_ARGS_gc_ms_free_attributes_from_pool \ __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(pool) \ , PARROT_ASSERT_ARG(data)) #define ASSERT_ARGS_gc_ms_free_bufferlike_header __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(obj)) #define ASSERT_ARGS_gc_ms_free_memory_chunk __attribute__unused__ int _ASSERT_ARGS_CHECK = (0) #define ASSERT_ARGS_gc_ms_free_pmc_header __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(pmc)) #define ASSERT_ARGS_gc_ms_free_string_header __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(s)) #define ASSERT_ARGS_gc_ms_get_free_object __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(mem_pools) \ , PARROT_ASSERT_ARG(pool)) #define ASSERT_ARGS_gc_ms_get_gc_info __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp)) #define ASSERT_ARGS_gc_ms_is_blocked_GC_mark __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp)) #define ASSERT_ARGS_gc_ms_is_blocked_GC_sweep __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp)) #define ASSERT_ARGS_gc_ms_is_pmc_ptr __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp)) #define ASSERT_ARGS_gc_ms_is_string_ptr __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp)) #define ASSERT_ARGS_gc_ms_iterate_live_strings __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp)) #define ASSERT_ARGS_gc_ms_mark_and_sweep __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp)) #define ASSERT_ARGS_gc_ms_mark_special __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(pmc)) #define ASSERT_ARGS_gc_ms_mark_str_header __attribute__unused__ int _ASSERT_ARGS_CHECK = (0) #define ASSERT_ARGS_gc_ms_more_traceable_objects __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(pool)) #define ASSERT_ARGS_gc_ms_pool_init __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(pool)) #define ASSERT_ARGS_gc_ms_reallocate_memory_chunk __attribute__unused__ int _ASSERT_ARGS_CHECK = (0) #define ASSERT_ARGS_gc_ms_reallocate_memory_chunk_zeroed \ __attribute__unused__ int _ASSERT_ARGS_CHECK = (0) #define ASSERT_ARGS_gc_ms_sweep_cb __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(mem_pools) \ , PARROT_ASSERT_ARG(pool) \ , PARROT_ASSERT_ARG(arg)) #define ASSERT_ARGS_gc_ms_total_sized_buffers __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(mem_pools)) #define ASSERT_ARGS_gc_ms_trace_active_PMCs __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp)) #define ASSERT_ARGS_gc_ms_unblock_GC_mark __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp)) #define ASSERT_ARGS_gc_ms_unblock_GC_sweep __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp)) #define ASSERT_ARGS_Parrot_gc_allocate_new_attributes_arena \ __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(pool)) #define ASSERT_ARGS_Parrot_gc_create_attrib_pool __attribute__unused__ int _ASSERT_ARGS_CHECK = (0) #define ASSERT_ARGS_Parrot_gc_get_attribute_pool __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(mem_pools)) #define ASSERT_ARGS_Parrot_gc_get_attributes_from_pool \ __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(pool)) #define ASSERT_ARGS_Parrot_gc_initialize_fixed_size_pools \ __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(mem_pools)) /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */ /* HEADERIZER END: static */ /* =over 4 =item C Report error if allocation failed =back =cut */ PARROT_DOES_NOT_RETURN static void failed_allocation(unsigned int line, unsigned long size) { fprintf(stderr, "Failed allocation of %lu bytes\n", size); Parrot_x_panic_and_exit(NULL, "Out of mem", __FILE__, line); } /* =head2 Primary MS Functions =over 4 =item C Initialize the state structures of the gc system. Called immediately before creation of memory pools. This function must set the function pointers for C, C, C, and C. =cut */ void Parrot_gc_ms_init(PARROT_INTERP, SHIM(Parrot_GC_Init_Args *args)) { ASSERT_ARGS(Parrot_gc_ms_init) Memory_Pools *mem_pools = mem_internal_allocate_zeroed_typed(Memory_Pools); mem_pools->num_sized = 0; mem_pools->num_attribs = 0; mem_pools->attrib_pools = NULL; mem_pools->sized_header_pools = NULL; interp->gc_sys->finalize_gc_system = gc_ms_finalize; interp->gc_sys->destroy_child_interp = gc_ms_destroy_child_interp; interp->gc_sys->init_pool = gc_ms_pool_init; interp->gc_sys->do_gc_mark = gc_ms_mark_and_sweep; interp->gc_sys->compact_string_pool = gc_ms_compact_memory_pool; interp->gc_sys->mark_special = gc_ms_mark_special; interp->gc_sys->pmc_needs_early_collection = gc_ms_pmc_needs_early_collection; interp->gc_sys->allocate_pmc_header = gc_ms_allocate_pmc_header; interp->gc_sys->free_pmc_header = gc_ms_free_pmc_header; interp->gc_sys->allocate_string_header = gc_ms_allocate_string_header; interp->gc_sys->free_string_header = gc_ms_free_string_header; interp->gc_sys->allocate_bufferlike_header = gc_ms_allocate_bufferlike_header; interp->gc_sys->free_bufferlike_header = gc_ms_free_bufferlike_header; interp->gc_sys->is_pmc_ptr = gc_ms_is_pmc_ptr; interp->gc_sys->is_string_ptr = gc_ms_is_string_ptr; interp->gc_sys->mark_pmc_header = gc_ms_mark_pmc_header; interp->gc_sys->mark_str_header = gc_ms_mark_str_header; interp->gc_sys->allocate_pmc_attributes = gc_ms_allocate_pmc_attributes; interp->gc_sys->free_pmc_attributes = gc_ms_free_pmc_attributes; interp->gc_sys->allocate_string_storage = gc_ms_allocate_string_storage; interp->gc_sys->reallocate_string_storage = gc_ms_reallocate_string_storage; interp->gc_sys->allocate_buffer_storage = gc_ms_allocate_buffer_storage; interp->gc_sys->reallocate_buffer_storage = gc_ms_reallocate_buffer_storage; interp->gc_sys->allocate_fixed_size_storage = gc_ms_allocate_fixed_size_storage; interp->gc_sys->free_fixed_size_storage = gc_ms_free_fixed_size_storage; /* We don't distinguish between chunk and chunk_with_pointers */ interp->gc_sys->allocate_memory_chunk = gc_ms_allocate_memory_chunk; interp->gc_sys->reallocate_memory_chunk = gc_ms_reallocate_memory_chunk; interp->gc_sys->allocate_memory_chunk_with_interior_pointers = gc_ms_allocate_memory_chunk_zeroed; interp->gc_sys->reallocate_memory_chunk_with_interior_pointers = gc_ms_reallocate_memory_chunk_zeroed; interp->gc_sys->free_memory_chunk = gc_ms_free_memory_chunk; interp->gc_sys->block_mark = gc_ms_block_GC_mark; interp->gc_sys->unblock_mark = gc_ms_unblock_GC_mark; interp->gc_sys->is_blocked_mark = gc_ms_is_blocked_GC_mark; interp->gc_sys->block_sweep = gc_ms_block_GC_sweep; interp->gc_sys->unblock_sweep = gc_ms_unblock_GC_sweep; interp->gc_sys->is_blocked_sweep = gc_ms_is_blocked_GC_sweep; interp->gc_sys->get_gc_info = gc_ms_get_gc_info; interp->gc_sys->iterate_live_strings = gc_ms_iterate_live_strings; /* gc_private is Memory_Pools */ interp->gc_sys->gc_private = mem_pools; Parrot_gc_str_initialize(interp, &mem_pools->string_gc); initialize_fixed_size_pools(interp, mem_pools); Parrot_gc_initialize_fixed_size_pools(interp, mem_pools, GC_NUM_INITIAL_FIXED_SIZE_POOLS); } /* =item C Finalyze MS GC subsystem. Destroy everything. =cut */ static void gc_ms_finalize(PARROT_INTERP) { ASSERT_ARGS(gc_ms_finalize) Memory_Pools *mem_pools = (Memory_Pools*)interp->gc_sys->gc_private; /* buffer headers, PMCs */ Parrot_gc_destroy_header_pools(interp, mem_pools); /* memory pools in resources */ Parrot_gc_str_finalize(interp, &mem_pools->string_gc); /* mem subsystem is dead now */ mem_internal_free(mem_pools); interp->gc_sys->gc_private = NULL; } /* =item C Merges the header pools of C into those of C. (Used to deal with shared objects left after interpreter destruction.) =cut */ static void gc_ms_destroy_child_interp(ARGMOD(Interp *dest_interp), ARGIN(Interp *source_interp)) { ASSERT_ARGS(gc_ms_destroy_child_interp) Memory_Pools * const dest_arena = (Memory_Pools*)dest_interp->gc_sys->gc_private; Memory_Pools * const source_arena = (Memory_Pools*)source_interp->gc_sys->gc_private; Parrot_gc_merge_memory_pools(dest_interp, dest_arena, source_arena); } /* =item C Determines whether a GC run is needed. The decision is based on the amount of memory used since the last GC run. This amount is compared to a static and a dynamic threshold. The dynamic threshold roughly limits the memory wasted by objects that could be freed but are not yet collected to a percentage of total memory that is actually needed. Increasing the dynamic threshold results in fewer GC runs and more memory consumption. =cut */ PARROT_WARN_UNUSED_RESULT PARROT_PURE_FUNCTION int Parrot_gc_ms_needed(PARROT_INTERP) { ASSERT_ARGS(Parrot_gc_ms_needed) size_t dynamic_threshold; /* new_mem is the additional amount of memory used since the last GC */ const size_t new_mem = interp->gc_sys->stats.memory_used - interp->gc_sys->stats.mem_used_last_collect; /* Never run a GC if new_mem is below static GC_SIZE_THRESHOLD */ if (new_mem <= GC_SIZE_THRESHOLD) return 0; /* The dynamic threshold is a configurable percentage of the amount of memory used after the last GC */ dynamic_threshold = (size_t)(interp->gc_sys->stats.mem_used_last_collect * 0.25); return new_mem > dynamic_threshold; } /* =item C Runs the stop-the-world mark & sweep (MS) collector. =cut */ static void gc_ms_mark_and_sweep(PARROT_INTERP, UINTVAL flags) { ASSERT_ARGS(gc_ms_mark_and_sweep) Memory_Pools * const mem_pools = (Memory_Pools *)interp->gc_sys->gc_private; int total_free = 0; if (mem_pools->gc_mark_block_level) return; if (interp->pdb && interp->pdb->debugger) { /* The debugger could have performed a mark. Make sure everything is marked dead here, so that when we sweep it all gets collected */ Parrot_gc_clear_live_bits(interp, mem_pools->pmc_pool); } if (flags & GC_finish_FLAG) { gc_ms_finalize_memory_pools(interp, mem_pools); return; } ++mem_pools->gc_mark_block_level; mem_pools->lazy_gc = flags & GC_lazy_FLAG; /* tell the threading system that we're doing GC mark */ Parrot_gc_run_init(interp, mem_pools); /* Now go trace the PMCs. returning true means we did a complete trace. false means it was a lazy trace. */ if (gc_ms_trace_active_PMCs(interp, (flags & GC_trace_stack_FLAG) ? GC_TRACE_FULL : GC_TRACE_ROOT_ONLY)) { mem_pools->gc_trace_ptr = NULL; mem_pools->gc_mark_ptr = NULL; /* We've done the mark, now do the sweep. Pass the sweep callback function to the PMC pool and all the sized pools. */ header_pools_iterate_callback(interp, mem_pools, POOL_BUFFER | POOL_PMC, (void *)&total_free, gc_ms_sweep_cb); } else { ++interp->gc_sys->stats.gc_lazy_mark_runs; Parrot_gc_clear_live_bits(interp, mem_pools->pmc_pool); } /* compact STRING pools to collect free headers and allocated buffers */ Parrot_gc_compact_memory_pool(interp); /* Note it */ ++interp->gc_sys->stats.gc_mark_runs; --mem_pools->gc_mark_block_level; interp->gc_sys->stats.mem_used_last_collect = interp->gc_sys->stats.memory_used; return; } /* =item C Scan the string pools and compact them. This does not perform a GC mark or sweep run, and does not check whether string buffers are still alive. Redirects to C. =cut */ void gc_ms_compact_memory_pool(PARROT_INTERP) { ASSERT_ARGS(gc_ms_compact_memory_pool) Memory_Pools * const mem_pools = (Memory_Pools *)interp->gc_sys->gc_private; Parrot_gc_str_compact_pool(interp, &mem_pools->string_gc); } /* =item C =item C =item C =item C Functions for allocating strings/buffers storage. =cut */ void gc_ms_allocate_string_storage(PARROT_INTERP, ARGIN(STRING *str), size_t size) { ASSERT_ARGS(gc_ms_allocate_string_storage) Memory_Pools * const mem_pools = (Memory_Pools *)interp->gc_sys->gc_private; Parrot_gc_str_allocate_string_storage(interp, &mem_pools->string_gc, str, size); } void gc_ms_reallocate_string_storage(PARROT_INTERP, ARGIN(STRING *str), size_t size) { ASSERT_ARGS(gc_ms_reallocate_string_storage) Memory_Pools * const mem_pools = (Memory_Pools *)interp->gc_sys->gc_private; Parrot_gc_str_reallocate_string_storage(interp, &mem_pools->string_gc, str, size); } void gc_ms_allocate_buffer_storage(PARROT_INTERP, ARGIN(Parrot_Buffer *str), size_t size) { ASSERT_ARGS(gc_ms_allocate_buffer_storage) Memory_Pools * const mem_pools = (Memory_Pools *)interp->gc_sys->gc_private; Parrot_gc_str_allocate_buffer_storage(interp, &mem_pools->string_gc, str, size); } void gc_ms_reallocate_buffer_storage(PARROT_INTERP, ARGIN(Parrot_Buffer *str), size_t size) { ASSERT_ARGS(gc_ms_reallocate_buffer_storage) Memory_Pools * const mem_pools = (Memory_Pools *)interp->gc_sys->gc_private; Parrot_gc_str_reallocate_buffer_storage(interp, &mem_pools->string_gc, str, size); } /* =item C Mark PMC special. =cut */ static void gc_ms_mark_special(PARROT_INTERP, ARGIN(PMC *pmc)) { ASSERT_ARGS(gc_ms_mark_special) Memory_Pools * const mem_pools = (Memory_Pools *)interp->gc_sys->gc_private; mark_special(interp, mem_pools, pmc); } /* =item C Mark a PMC as needing timely destruction =cut */ void gc_ms_pmc_needs_early_collection(PARROT_INTERP, ARGMOD(PMC *pmc)) { ASSERT_ARGS(gc_ms_pmc_needs_early_collection) Memory_Pools * const mem_pools = (Memory_Pools *)interp->gc_sys->gc_private; PObj_needs_early_gc_SET(pmc); ++mem_pools->num_early_gc_PMCs; } /* =item C Perform the finalization run, freeing all PMCs in Memory_Pools. =cut */ static void gc_ms_finalize_memory_pools(PARROT_INTERP, ARGIN(Memory_Pools * const mem_pools)) { ASSERT_ARGS(gc_ms_finalize_memory_pools) Parrot_gc_clear_live_bits(interp, mem_pools->pmc_pool); Parrot_gc_clear_live_bits(interp, mem_pools->constant_pmc_pool); /* keep the scheduler and its kids alive for Task-like PMCs to destroy * themselves; run a sweep to collect them */ if (interp->scheduler) { Parrot_gc_mark_PMC_alive(interp, interp->scheduler); VTABLE_mark(interp, interp->scheduler); Parrot_gc_sweep_pool(interp, mem_pools, mem_pools->pmc_pool); } /* now sweep everything that's left */ Parrot_gc_sweep_pool(interp, mem_pools, mem_pools->pmc_pool); Parrot_gc_sweep_pool(interp, mem_pools, mem_pools->constant_pmc_pool); } /* =item C Allocate new PMC header from pool. =cut */ PARROT_CAN_RETURN_NULL static PMC* gc_ms_allocate_pmc_header(PARROT_INTERP, UINTVAL flags) { ASSERT_ARGS(gc_ms_allocate_pmc_header) Memory_Pools * const mem_pools = (Memory_Pools *)interp->gc_sys->gc_private; Fixed_Size_Pool * const pool = flags & PObj_constant_FLAG ? mem_pools->constant_pmc_pool : mem_pools->pmc_pool; return (PMC *)pool->get_free_object(interp, mem_pools, pool); } /* =item C Return PMC header into pool. =cut */ static void gc_ms_free_pmc_header(PARROT_INTERP, ARGMOD(PMC *pmc)) { ASSERT_ARGS(gc_ms_free_pmc_header) Memory_Pools * const mem_pools = (Memory_Pools *)interp->gc_sys->gc_private; Fixed_Size_Pool * const pool = (PObj_constant_TEST(pmc)) ? mem_pools->constant_pmc_pool : mem_pools->pmc_pool; Parrot_pmc_destroy(interp, pmc); PObj_flags_SETTO((PObj *)pmc, PObj_on_free_list_FLAG); pool->add_free_object(interp, mem_pools, pool, (PObj *)pmc); ++pool->num_free_objects; } /* =item C Mark the PMC *obj as live and attach PMCs and/or buffers =cut */ void gc_ms_mark_pmc_header(PARROT_INTERP, ARGMOD_NULLOK(PMC *obj)) { ASSERT_ARGS(gc_ms_mark_pmc_header) if (!PMC_IS_NULL(obj)) { PARROT_ASSERT(PObj_is_PMC_TEST(obj)); if (PObj_is_live_or_free_TESTALL(obj)) return; /* mark it live */ PObj_live_SET(obj); /* if object is a PMC and contains buffers or PMCs, then attach the PMC * to the chained mark list. */ if (PObj_custom_mark_TEST(obj)) VTABLE_mark(interp, obj); if (PMC_metadata(obj)) Parrot_gc_mark_PMC_alive(interp, PMC_metadata(obj)); } } /* =item C return True if *ptr is contained in the pool =cut */ PARROT_WARN_UNUSED_RESULT static int gc_ms_is_pmc_ptr(PARROT_INTERP, ARGIN_NULLOK(void *ptr)) { ASSERT_ARGS(gc_ms_is_pmc_ptr) Memory_Pools * const mem_pools = (Memory_Pools *)interp->gc_sys->gc_private; return contained_in_pool(mem_pools->pmc_pool, ptr); } /* =item C establish if string *ptr is owned =cut */ PARROT_WARN_UNUSED_RESULT static int gc_ms_is_string_ptr(PARROT_INTERP, ARGIN_NULLOK(void *ptr)) { ASSERT_ARGS(gc_ms_is_string_ptr) Memory_Pools * const mem_pools = (Memory_Pools *)interp->gc_sys->gc_private; UINTVAL i; for (i = 0; i < mem_pools->num_sized; ++i) { if (mem_pools->sized_header_pools[i] && contained_in_pool(mem_pools->sized_header_pools[i], ptr)) return 1; } return 0; } /* =item C Allocate new STRING header from pool. =cut */ PARROT_WARN_UNUSED_RESULT PARROT_CAN_RETURN_NULL static STRING* gc_ms_allocate_string_header(PARROT_INTERP, UINTVAL flags) { ASSERT_ARGS(gc_ms_allocate_string_header) Memory_Pools * const mem_pools = (Memory_Pools *)interp->gc_sys->gc_private; Fixed_Size_Pool * const pool = flags & PObj_constant_FLAG ? mem_pools->constant_string_header_pool : mem_pools->string_header_pool; STRING * const s = (STRING *)pool->get_free_object(interp, mem_pools, pool); memset(s, 0, sizeof (STRING)); return s; } /* =item C Return STRING header into pool. =cut */ static void gc_ms_free_string_header(PARROT_INTERP, ARGMOD(STRING *s)) { ASSERT_ARGS(gc_ms_free_string_header) Memory_Pools * const mem_pools = (Memory_Pools *)interp->gc_sys->gc_private; if (!PObj_constant_TEST(s)) { Fixed_Size_Pool * const pool = mem_pools->string_header_pool; PObj_flags_SETTO((PObj *)s, PObj_on_free_list_FLAG); pool->add_free_object(interp, mem_pools, pool, s); ++pool->num_free_objects; } } /* =item C mark *obj as live =cut */ static void gc_ms_mark_str_header(SHIM_INTERP, ARGMOD_NULLOK(STRING *obj)) { ASSERT_ARGS(gc_ms_mark_str_header) if (obj) { /* mark it live */ PObj_live_SET(obj); } } /* =item C Returns a new buffer-like header from the appropriate sized pool. A "bufferlike object" is an object that is considered to be isomorphic to the PObj, so it will participate in normal GC. At the moment these are only used to create ListChunk objects in src/list.c. =cut */ PARROT_CANNOT_RETURN_NULL PARROT_WARN_UNUSED_RESULT static Parrot_Buffer * gc_ms_allocate_bufferlike_header(PARROT_INTERP, size_t size) { ASSERT_ARGS(gc_ms_allocate_bufferlike_header) Memory_Pools * const mem_pools = (Memory_Pools *)interp->gc_sys->gc_private; Fixed_Size_Pool * const pool = get_bufferlike_pool(interp, mem_pools, size); return (Parrot_Buffer *)pool->get_free_object(interp, mem_pools, pool); } /* =item C Free a bufferlike header that is not being used, so that Parrot can recycle it and use it again. =cut */ static void gc_ms_free_bufferlike_header(PARROT_INTERP, ARGMOD(Parrot_Buffer *obj), size_t size) { ASSERT_ARGS(gc_ms_free_bufferlike_header) Memory_Pools * const mem_pools = (Memory_Pools *)interp->gc_sys->gc_private; Fixed_Size_Pool * const pool = get_bufferlike_pool(interp, mem_pools, size); pool->add_free_object(interp, mem_pools, pool, obj); } /* =over 4 =item C Get a new fixed-size storage space from the given pool. The pool contains information on the size of the item to allocate already. =item C Allocate a new arena of fixed-sized data structures for the given pool. =item C Initialize the pools (zeroize) =item C Find a fixed-sized data structure pool given the size of the object to allocate. If the pool does not exist, create it. =item C Create a new pool for fixed-sized data items with the given C. =back =cut */ PARROT_CANNOT_RETURN_NULL static void * Parrot_gc_get_attributes_from_pool(PARROT_INTERP, ARGMOD(PMC_Attribute_Pool * pool)) { ASSERT_ARGS(Parrot_gc_get_attributes_from_pool) PMC_Attribute_Free_List *item; if (pool->free_list) { item = pool->free_list; pool->free_list = item->next; } else if (pool->newfree) { item = pool->newfree; pool->newfree = (PMC_Attribute_Free_List *) ((char *)(pool->newfree) + pool->attr_size); if (pool->newfree >= pool->newlast) pool->newfree = NULL; } else { Parrot_gc_allocate_new_attributes_arena(pool); return Parrot_gc_get_attributes_from_pool(interp, pool); } --pool->num_free_objects; return (void *)item; } static void Parrot_gc_allocate_new_attributes_arena(ARGMOD(PMC_Attribute_Pool *pool)) { ASSERT_ARGS(Parrot_gc_allocate_new_attributes_arena) PMC_Attribute_Free_List *next; const size_t num_items = pool->objects_per_alloc; const size_t item_size = pool->attr_size; const size_t item_space = item_size * num_items; const size_t total_size = sizeof (PMC_Attribute_Arena) + item_space; PMC_Attribute_Arena * const new_arena = (PMC_Attribute_Arena *)mem_internal_allocate( total_size); new_arena->prev = NULL; new_arena->next = pool->top_arena; pool->top_arena = new_arena; next = (PMC_Attribute_Free_List *)(new_arena + 1); pool->newfree = next; pool->newlast = (PMC_Attribute_Free_List *)((char *)next + item_space); pool->num_free_objects += num_items; pool->total_objects += num_items; } static void Parrot_gc_initialize_fixed_size_pools(SHIM_INTERP, ARGMOD(Memory_Pools *mem_pools), size_t init_num_pools) { ASSERT_ARGS(Parrot_gc_initialize_fixed_size_pools) PMC_Attribute_Pool **pools; const size_t total_size = (init_num_pools + 1) * sizeof (void *); pools = (PMC_Attribute_Pool **)mem_internal_allocate(total_size); memset(pools, 0, total_size); mem_pools->attrib_pools = pools; mem_pools->num_attribs = init_num_pools; } PARROT_CANNOT_RETURN_NULL static PMC_Attribute_Pool * Parrot_gc_get_attribute_pool(SHIM_INTERP, ARGMOD(Memory_Pools *mem_pools), size_t attrib_size) { ASSERT_ARGS(Parrot_gc_get_attribute_pool) PMC_Attribute_Pool **pools = mem_pools->attrib_pools; const size_t idx = (attrib_size < sizeof (void *)) ? 0 : attrib_size - sizeof (void *); if (mem_pools->num_attribs <= idx) { const size_t total_length = idx + GC_ATTRIB_POOLS_HEADROOM; const size_t total_size = total_length * sizeof (void *); const size_t current_size = mem_pools->num_attribs; const size_t diff = total_length - current_size; pools = (PMC_Attribute_Pool **)mem_internal_realloc(pools, total_size); memset(pools + current_size, 0, diff * sizeof (void *)); mem_pools->attrib_pools = pools; mem_pools->num_attribs = total_length; } if (!pools[idx]) { PMC_Attribute_Pool * const pool = Parrot_gc_create_attrib_pool(idx); /* Create the first arena now, so we don't have to check for it later */ Parrot_gc_allocate_new_attributes_arena(pool); pools[idx] = pool; } return pools[idx]; } PARROT_CANNOT_RETURN_NULL PARROT_MALLOC static PMC_Attribute_Pool * Parrot_gc_create_attrib_pool(size_t attrib_idx) { ASSERT_ARGS(Parrot_gc_create_attrib_pool) const size_t attrib_size = attrib_idx + sizeof (void *); const size_t num_objs_raw = (GC_FIXED_SIZE_POOL_SIZE - sizeof (PMC_Attribute_Arena)) / attrib_size; const size_t num_objs = (num_objs_raw == 0)?(1):(num_objs_raw); PMC_Attribute_Pool * const newpool = mem_internal_allocate_typed(PMC_Attribute_Pool); newpool->attr_size = attrib_size; newpool->total_objects = 0; newpool->objects_per_alloc = num_objs; newpool->num_free_objects = 0; newpool->free_list = NULL; newpool->top_arena = NULL; return newpool; } /* =item C Allocates a new attribute structure for a PMC if it has the auto_attrs flag set. =cut */ PARROT_CANNOT_RETURN_NULL static void * gc_ms_allocate_pmc_attributes(PARROT_INTERP, ARGMOD(PMC *pmc)) { ASSERT_ARGS(gc_ms_allocate_pmc_attributes) Memory_Pools * const mem_pools = (Memory_Pools *)interp->gc_sys->gc_private; const size_t attr_size = pmc->vtable->attr_size; PMC_Attribute_Pool * const pool = Parrot_gc_get_attribute_pool(interp, mem_pools, attr_size); void * const attrs = Parrot_gc_get_attributes_from_pool(interp, pool); memset(attrs, 0, attr_size); PMC_data(pmc) = attrs; return attrs; } #if DEBUG_FREE_LIST /* =item C Returns whether the given C<*ptr> points to a location in C. =cut */ PARROT_WARN_UNUSED_RESULT static INTVAL contained_in_attr_pool(ARGIN(const PMC_Attribute_Pool *pool), ARGIN(const void *ptr)) { ASSERT_ARGS(contained_in_attr_pool) const PMC_Attribute_Arena *arena; const ptrdiff_t item_space = pool->objects_per_alloc * pool->attr_size; for (arena = pool->top_arena; arena; arena = arena->next) { const ptrdiff_t ptr_diff = (const char *)ptr - (const char *)(arena + 1); if (ptr_diff >= 0 && ptr_diff < item_space && ptr_diff % pool->attr_size == 0) return 1; } return 0; } #endif /* =item C Deallocates an attributes structure from a PMC if it has the auto_attrs flag set. */ void gc_ms_free_pmc_attributes(PARROT_INTERP, ARGMOD(PMC *pmc)) { ASSERT_ARGS(gc_ms_free_pmc_attributes) Memory_Pools * const mem_pools = (Memory_Pools *)interp->gc_sys->gc_private; void * const data = PMC_data(pmc); if (data) { const size_t attr_size = pmc->vtable->attr_size; const size_t item_size = attr_size < sizeof (void *) ? sizeof (void *) : attr_size; PMC_Attribute_Pool ** const pools = mem_pools->attrib_pools; const size_t idx = item_size - sizeof (void *); gc_ms_free_attributes_from_pool(pools[idx], data); } } /* =item C Frees a fixed-size data item back to the pool for later reallocation. Private to this file. */ static void gc_ms_free_attributes_from_pool(ARGMOD(PMC_Attribute_Pool *pool), ARGMOD(void *data)) { ASSERT_ARGS(gc_ms_free_attributes_from_pool) PMC_Attribute_Free_List * const item = (PMC_Attribute_Free_List *)data; #if DEBUG_FREE_LIST PARROT_ASSERT(contained_in_attr_pool(pool, data)); #endif item->next = pool->free_list; pool->free_list = item; ++pool->num_free_objects; } /* =item C Allocates a fixed-size chunk of memory for use. This memory is not manually managed and needs to be freed with C */ PARROT_CANNOT_RETURN_NULL void * gc_ms_allocate_fixed_size_storage(PARROT_INTERP, size_t size) { ASSERT_ARGS(gc_ms_allocate_fixed_size_storage) Memory_Pools * const mem_pools = (Memory_Pools *)interp->gc_sys->gc_private; PMC_Attribute_Pool *pool = NULL; const size_t idx = (size < sizeof (void *)) ? 0 : (size - sizeof (void *)); /* get the pool directly, if possible, for great speed */ if (mem_pools->num_attribs > idx) pool = mem_pools->attrib_pools[idx]; /* otherwise create it */ if (!pool) pool = Parrot_gc_get_attribute_pool(interp, mem_pools, size); return Parrot_gc_get_attributes_from_pool(interp, pool); } /* =item C Manually deallocates fixed size storage allocated with C */ void gc_ms_free_fixed_size_storage(PARROT_INTERP, size_t size, ARGFREE_NOTNULL(void *data)) { ASSERT_ARGS(gc_ms_free_fixed_size_storage) Memory_Pools * const mem_pools = (Memory_Pools *)interp->gc_sys->gc_private; const size_t idx = size - sizeof (void *); PMC_Attribute_Pool ** const pools = mem_pools->attrib_pools; gc_ms_free_attributes_from_pool(pools[idx], data); } /* =item C =item C =item C =item C =item C TODO Write docu. */ PARROT_MALLOC PARROT_CAN_RETURN_NULL static void * gc_ms_allocate_memory_chunk(SHIM_INTERP, size_t size) { ASSERT_ARGS(gc_ms_allocate_memory_chunk) void * const ptr = malloc(size); #ifdef DETAIL_MEMORY_DEBUG fprintf(stderr, "Allocated %i at %p\n", size, ptr); #endif if (!ptr && size) PANIC_OUT_OF_MEM(size); return ptr; } PARROT_MALLOC PARROT_CAN_RETURN_NULL static void * gc_ms_reallocate_memory_chunk(SHIM_INTERP, ARGFREE(void *from), size_t size) { ASSERT_ARGS(gc_ms_reallocate_memory_chunk) void *ptr; #ifdef DETAIL_MEMORY_DEBUG fprintf(stderr, "Freed %p (realloc -- %i bytes)\n", from, size); #endif if (from) ptr = realloc(from, size); else ptr = calloc(1, size); #ifdef DETAIL_MEMORY_DEBUG fprintf(stderr, "Allocated %i at %p\n", size, ptr); #endif if (!ptr && size) PANIC_OUT_OF_MEM(size); return ptr; } PARROT_MALLOC PARROT_CAN_RETURN_NULL static void * gc_ms_allocate_memory_chunk_zeroed(SHIM_INTERP, size_t size) { ASSERT_ARGS(gc_ms_allocate_memory_chunk_zeroed) void * const ptr = calloc(1, size); #ifdef DETAIL_MEMORY_DEBUG fprintf(stderr, "Allocated %i at %p\n", size, ptr); #endif if (!ptr && size) PANIC_OUT_OF_MEM(size); return ptr; } PARROT_MALLOC PARROT_CANNOT_RETURN_NULL static void * gc_ms_reallocate_memory_chunk_zeroed(SHIM_INTERP, ARGFREE(void *data), size_t newsize, size_t oldsize) { ASSERT_ARGS(gc_ms_reallocate_memory_chunk_zeroed) void * const ptr = realloc(data, newsize); if (newsize > oldsize) memset((char*)ptr + oldsize, 0, newsize - oldsize); return ptr; } static void gc_ms_free_memory_chunk(SHIM_INTERP, ARGFREE(void *data)) { ASSERT_ARGS(gc_ms_free_memory_chunk) #ifdef DETAIL_MEMORY_DEBUG fprintf(stderr, "Freed %p\n", data); #endif if (data) free(data); } /* =item C Performs a full trace run and marks all the PMCs as active if they are. Returns whether the run completed, that is, whether it's safe to proceed with GC. =cut */ static int gc_ms_trace_active_PMCs(PARROT_INTERP, Parrot_gc_trace_type trace) { ASSERT_ARGS(gc_ms_trace_active_PMCs) Memory_Pools * const mem_pools = (Memory_Pools *)interp->gc_sys->gc_private; if (!Parrot_gc_trace_root(interp, mem_pools, trace)) return 0; mem_pools->gc_trace_ptr = NULL; return 1; } /* =item C Sweeps the given pool for the MS collector. This function also ends the profiling timer, if profiling is enabled. Returns the total number of objects freed. =cut */ static int gc_ms_sweep_cb(PARROT_INTERP, ARGIN(Memory_Pools *mem_pools), ARGMOD(Fixed_Size_Pool *pool), SHIM(int flag), ARGMOD(void *arg)) { ASSERT_ARGS(gc_ms_sweep_cb) int * const total_free = (int *) arg; Parrot_gc_sweep_pool(interp, mem_pools, pool); *total_free += pool->num_free_objects; return 0; } /* =back =head2 MS Pool Functions =over 4 =item C Initialize a memory pool for the MS garbage collector system. Sets the function pointers necessary to perform basic operations on a pool, such as object allocation. =cut */ static void gc_ms_pool_init(SHIM_INTERP, ARGMOD(Fixed_Size_Pool *pool)) { ASSERT_ARGS(gc_ms_pool_init) pool->add_free_object = gc_ms_add_free_object; pool->get_free_object = gc_ms_get_free_object; pool->alloc_objects = gc_ms_alloc_objects; pool->more_objects = gc_ms_more_traceable_objects; } /* =item C We're out of traceable objects. First we try a GC run to free some up. If that doesn't work, allocate a new arena. =cut */ static void gc_ms_more_traceable_objects(PARROT_INTERP, SHIM(Memory_Pools *mem_pools), ARGMOD(Fixed_Size_Pool *pool)) { ASSERT_ARGS(gc_ms_more_traceable_objects) Memory_Pools * const mem_pools = (Memory_Pools *)interp->gc_sys->gc_private; if (pool->skip == GC_ONE_SKIP) pool->skip = GC_NO_SKIP; else if (pool->skip == GC_NEVER_SKIP || (pool->skip == GC_NO_SKIP && Parrot_gc_ms_needed(interp))) Parrot_gc_mark_and_sweep(interp, GC_trace_stack_FLAG); /* requires that num_free_objects be updated in Parrot_gc_mark_and_sweep. If gc is disabled, then we must check the free list directly. */ if ((!pool->free_list || pool->num_free_objects < pool->replenish_level) && !pool->newfree) (*pool->alloc_objects) (interp, mem_pools, pool); } /* =item C Add an unused object back to the pool's free list for later reuse. Set the PObj flags to indicate that the item is free. =cut */ static void gc_ms_add_free_object(PARROT_INTERP, SHIM(Memory_Pools *mem_pools), ARGMOD(Fixed_Size_Pool *pool), ARGIN(void *to_add)) { ASSERT_ARGS(gc_ms_add_free_object) GC_MS_PObj_Wrapper *object = (GC_MS_PObj_Wrapper *)to_add; #if DEBUG_FREE_LIST PARROT_ASSERT(contained_in_pool(pool, to_add)); #endif PObj_flags_SETTO(object, PObj_on_free_list_FLAG); object->next_ptr = pool->free_list; pool->free_list = object; interp->gc_sys->stats.memory_used -= pool->object_size; } /* =item C Free object allocator for the MS garbage collector system. If there are no free objects, call C to either free them up with a GC run, or allocate new objects. If there are objects available on the free list, pop it off and return it. =cut */ PARROT_CANNOT_RETURN_NULL PARROT_WARN_UNUSED_RESULT static void * gc_ms_get_free_object(PARROT_INTERP, ARGMOD(Memory_Pools *mem_pools), ARGMOD(Fixed_Size_Pool *pool)) { ASSERT_ARGS(gc_ms_get_free_object) PObj *ptr; PObj *free_list = (PObj *)pool->free_list; HAVE_FREE: if (free_list) { ptr = free_list; pool->free_list = ((GC_MS_PObj_Wrapper *)ptr)->next_ptr; } else if (pool->newfree) { Fixed_Size_Arena * const arena = pool->last_Arena; ptr = (PObj *)pool->newfree; pool->newfree = (void *)((char *)pool->newfree + pool->object_size); ++arena->used; if (pool->newfree >= pool->newlast) pool->newfree = NULL; PARROT_ASSERT(ptr < (PObj *)pool->newlast); } else { (*pool->more_objects)(interp, mem_pools, pool); free_list = (PObj *)pool->free_list; goto HAVE_FREE; } --pool->num_free_objects; interp->gc_sys->stats.memory_used += pool->object_size; return ptr; } /* =item C New arena allocator function for the MS garbage collector system. Allocates and initializes a new memory arena in the given pool. Adds all the new objects to the pool's free list for later allocation. =cut */ static void gc_ms_alloc_objects(PARROT_INTERP, ARGMOD(Memory_Pools *mem_pools), ARGMOD(Fixed_Size_Pool *pool)) { ASSERT_ARGS(gc_ms_alloc_objects) /* Setup memory for the new objects */ Fixed_Size_Arena * const new_arena = mem_internal_allocate_typed(Fixed_Size_Arena); const size_t size = pool->object_size * pool->objects_per_alloc; size_t alloc_size; /* could be mem_internal_allocate too, but calloc is fast */ new_arena->start_objects = mem_internal_allocate_zeroed(size); Parrot_append_arena_in_pool(interp, mem_pools, pool, new_arena, size); PARROT_ASSERT(pool->last_Arena); Parrot_add_to_free_list(interp, pool, new_arena); /* Allocate more next time */ pool->objects_per_alloc *= GC_DEBUG_UNITS_PER_ALLOC_GROWTH_FACTOR; pool->replenish_level = (size_t)(pool->total_objects * GC_DEBUG_REPLENISH_LEVEL_FACTOR); /* check alloc size against maximum */ alloc_size = pool->object_size * pool->objects_per_alloc; if (alloc_size > POOL_MAX_BYTES) pool->objects_per_alloc = POOL_MAX_BYTES / pool->object_size; } /* =item C Blocks the GC from performing its mark phase. =item C Unblocks the GC mark. =item C Blocks the GC from performing its sweep phase. =item C Unblocks GC sweep. =item C Determines if the GC mark is currently blocked. =item C Determines if the GC sweep is currently blocked. =cut */ static void gc_ms_block_GC_mark(PARROT_INTERP) { ASSERT_ARGS(gc_ms_block_GC_mark) Memory_Pools * const mem_pools = (Memory_Pools *)interp->gc_sys->gc_private; ++mem_pools->gc_mark_block_level; } static void gc_ms_unblock_GC_mark(PARROT_INTERP) { ASSERT_ARGS(gc_ms_unblock_GC_mark) Memory_Pools * const mem_pools = (Memory_Pools *)interp->gc_sys->gc_private; if (mem_pools->gc_mark_block_level) --mem_pools->gc_mark_block_level; } static void gc_ms_block_GC_sweep(PARROT_INTERP) { ASSERT_ARGS(gc_ms_block_GC_sweep) Memory_Pools * const mem_pools = (Memory_Pools *)interp->gc_sys->gc_private; ++mem_pools->gc_sweep_block_level; } static void gc_ms_unblock_GC_sweep(PARROT_INTERP) { ASSERT_ARGS(gc_ms_unblock_GC_sweep) Memory_Pools * const mem_pools = (Memory_Pools *)interp->gc_sys->gc_private; if (mem_pools->gc_sweep_block_level) --mem_pools->gc_sweep_block_level; } static unsigned int gc_ms_is_blocked_GC_mark(PARROT_INTERP) { ASSERT_ARGS(gc_ms_is_blocked_GC_mark) Memory_Pools * const mem_pools = (Memory_Pools *)interp->gc_sys->gc_private; return mem_pools->gc_mark_block_level; } static unsigned int gc_ms_is_blocked_GC_sweep(PARROT_INTERP) { ASSERT_ARGS(gc_ms_is_blocked_GC_sweep) Memory_Pools * const mem_pools = (Memory_Pools *)interp->gc_sys->gc_private; return mem_pools->gc_sweep_block_level; } /* =item C Get information about MS GC. =cut */ static size_t gc_ms_get_gc_info(PARROT_INTERP, Interpinfo_enum which) { ASSERT_ARGS(gc_ms_get_gc_info) Memory_Pools * const mem_pools = (Memory_Pools *)interp->gc_sys->gc_private; switch (which) { case ACTIVE_PMCS: return mem_pools->pmc_pool->total_objects - mem_pools->pmc_pool->num_free_objects; case ACTIVE_BUFFERS: return gc_ms_active_sized_buffers(mem_pools); case TOTAL_PMCS: return mem_pools->pmc_pool->total_objects; case TOTAL_BUFFERS: return gc_ms_total_sized_buffers(mem_pools); case IMPATIENT_PMCS: return mem_pools->num_early_gc_PMCs; default: return Parrot_gc_get_info(interp, which, &interp->gc_sys->stats); break; } return 0; } /* TODO Move it somewhere. */ /* =item C returns stats as required by enum which =cut */ PARROT_WARN_UNUSED_RESULT PARROT_PURE_FUNCTION size_t Parrot_gc_get_info(SHIM_INTERP, Interpinfo_enum which, ARGIN(GC_Statistics *stats)) { ASSERT_ARGS(Parrot_gc_get_info) switch (which) { case TOTAL_MEM_ALLOC: return stats->memory_allocated; case TOTAL_MEM_USED: return stats->memory_used; case GC_MARK_RUNS: return stats->gc_mark_runs; case GC_COLLECT_RUNS: return stats->gc_collect_runs; case HEADER_ALLOCS_SINCE_COLLECT: return stats->header_allocs_since_last_collect; case MEM_ALLOCS_SINCE_COLLECT: return stats->mem_allocs_since_last_collect; case TOTAL_COPIED: return stats->memory_collected; case GC_LAZY_MARK_RUNS: return stats->gc_lazy_mark_runs; default: break; } return 0; } /* =item C Returns the number of actively used sized buffers. =cut */ static int gc_ms_active_sized_buffers(ARGIN(const Memory_Pools *mem_pools)) { ASSERT_ARGS(gc_ms_active_sized_buffers) int j, ret = 0; for (j = 0; j < (INTVAL)mem_pools->num_sized; ++j) { Fixed_Size_Pool * const header_pool = mem_pools->sized_header_pools[j]; if (header_pool) ret += header_pool->total_objects - header_pool->num_free_objects; } return ret; } /* =item C Returns the total number of sized buffers that we are managing. =cut */ static int gc_ms_total_sized_buffers(ARGIN(const Memory_Pools *mem_pools)) { ASSERT_ARGS(gc_ms_total_sized_buffers) int j, ret = 0; for (j = 0; j < (INTVAL)mem_pools->num_sized; ++j) { Fixed_Size_Pool * const header_pool = mem_pools->sized_header_pools[j]; if (header_pool) ret += header_pool->total_objects; } return ret; } /* =item C Iterate over live string invoking callback for each of them. Used during compacting of string pool. =cut */ static void gc_ms_iterate_live_strings(PARROT_INTERP, string_iterator_callback callback, ARGIN_NULLOK(void *data)) { ASSERT_ARGS(gc_ms_iterate_live_strings) Memory_Pools * const mem_pools = (Memory_Pools *)interp->gc_sys->gc_private; INTVAL j; /* Run through all the Parrot_Buffer header pools and invoke callback */ for (j = (INTVAL)mem_pools->num_sized - 1; j >= 0; --j) { Fixed_Size_Pool * const header_pool = mem_pools->sized_header_pools[j]; Fixed_Size_Arena * cur_buffer_arena; UINTVAL object_size; if (!header_pool) continue; object_size = header_pool->object_size; for (cur_buffer_arena = header_pool->last_Arena; cur_buffer_arena; cur_buffer_arena = cur_buffer_arena->prev) { Parrot_Buffer *b = (Parrot_Buffer *) cur_buffer_arena->start_objects; UINTVAL i; const size_t objects_end = cur_buffer_arena->used; for (i = objects_end; i; --i) { if (Buffer_buflen(b) && PObj_is_movable_TESTALL(b)) { Memory_Block *old_block = Buffer_pool(b); if (5 * (old_block->free + old_block->freed) >= old_block->size) callback(interp, b, data); } b = (Parrot_Buffer *)((char *)b + object_size); } } } } /* =back =cut */ /* * Local variables: * c-file-style: "parrot" * End: * vim: expandtab shiftwidth=4 cinoptions='\:2=2' : */ lack_directive.in000644000765000765 11411567202625 22721 0ustar00bruce000000000000parrot-6.6.0/t/tools/dev/headerizer/testlibThis file lacks a HEADERIZER HFILE directive embedded in a C-style comment. Grammar.pm000644000765000765 1042311667265570 22536 0ustar00bruce000000000000parrot-6.6.0/examples/languages/squaak/src/Squaak#! nqp # Copyright (C) 2010, Parrot Foundation. =begin overview This is the grammar for Squaak in Perl 6 rules. =end overview grammar Squaak::Grammar is HLL::Grammar; token begin_TOP { } token TOP { <.begin_TOP> [ $ || <.panic: "Syntax error"> ] } ## Lexer items # This rule treats # as "comment to eol". token ws { [ '#' \N* \n? | \s+ ]* } ## Statements rule statementlist { * } rule stat_or_def { | | } rule sub_definition { 'sub' * 'end' } rule parameters { '(' [ ** ',']? ')' } proto rule statement { <...> } rule statement:sym { '=' } rule statement:sym { 'end' } rule statement:sym { ',' ? 'do' * 'end' } rule step { ',' } rule for_init { 'var' '=' } rule statement:sym { 'then' $= ['else' $= ]? 'end' } rule statement:sym { } rule arguments { '(' [ ** ',']? ')' } rule statement:sym { } rule statement:sym { $= 'catch' $= 'end' } rule exception { } rule statement:sym { ['=' ]? } rule statement:sym { 'do' 'end' } rule statement:sym { } token begin_block { } rule block { <.begin_block> * } ## Terms rule primary { * } proto rule postfix_expression { <...> } rule postfix_expression:sym { '[' ']' } rule postfix_expression:sym { '{' '}' } rule postfix_expression:sym { '.' } rule postfix_expression:sym { } token identifier { } token keyword { ['and'|'catch' |'do' |'else' |'end'|'for'|'if' |'not' |'or' |'return'|'sub'|'throw'|'try'|'var'|'while']>> } token term:sym { } token term:sym { } token string_constant { } token term:sym { # longer to work-around lack of LTM [ | \d+ '.' \d* | \d* '.' \d+ ] } token term:sym { } proto token quote { <...> } token quote:sym<'> { } token quote:sym<"> { } ## Operators INIT { Squaak::Grammar.O(':prec, :assoc', '%unary-negate'); Squaak::Grammar.O(':prec, :assoc', '%unary-not'); Squaak::Grammar.O(':prec, :assoc', '%multiplicative'); Squaak::Grammar.O(':prec, :assoc', '%additive'); Squaak::Grammar.O(':prec, :assoc', '%relational'); Squaak::Grammar.O(':prec, :assoc', '%conjunction'); Squaak::Grammar.O(':prec, :assoc', '%disjunction'); } token circumfix:sym<( )> { '(' <.ws> ')' } rule circumfix:sym<[ ]> { '[' [ ** ',']? ']' } rule circumfix:sym<{ }> { '{' [ ** ',']? '}' } rule named_field { '=>' } token prefix:sym<-> { ')> } token prefix:sym { ')> } token infix:sym<*> { ')> } token infix:sym<%> { ')> } token infix:sym { ')> } token infix:sym<+> { ')> } token infix:sym<-> { ')> } token infix:sym<..> { ')> } token infix:sym«<» { ')> } token infix:sym«<=» { ')> } token infix:sym«>» { ')> } token infix:sym«>=» { ')> } token infix:sym«==» { ')> } token infix:sym«!=» { ')> } token infix:sym { ')> } token infix:sym { ')> } indent_pir.vim000644000765000765 305711533177634 15643 0ustar00bruce000000000000parrot-6.6.0/editor" Description: PIR indenter " Author: Andrew Rodland " Maintainer: Jimmy Zhuo " Last Change: 2009 Jan 16 " As usual, we want to be alone if exists("b:did_indent") finish endif let b:did_indent=1 setlocal indentexpr=PIRIndent() setlocal indentkeys=o,O,*,,:,=.end,0# fun! InPOD(lnum) return synIDattr(synID(a:lnum, 1, 1), "name") =~? '^myPod$\|^pod[A-Z]' endfun fun! PIRIndent() let thisline = getline(v:lnum) let POD_START = '^=[a-z]' if thisline =~? POD_START return 0 endif if InPOD(v:lnum) return -1 endif let COMMENT = '^#' if thisline =~? COMMENT return 0 endif let lnum=v:lnum while lnum > 0 let lnum = prevnonblank(lnum-1) let prevline = getline(lnum) if prevline !~? COMMENT if !InPOD(lnum) break endif endif endwhile if lnum < 1 return 0 endif let ind = indent(lnum) let SUB = '^\s*\.pcc_sub\s\+\|^\s*\.sub\s\+\|^\s*\.macro\s\+' let RETURNBLOCK = '\s*\.begin_return\s*$' let END = '^\s*\.end\s*$\|^\s*\.end_return\s*\|^\s*\.endm$' let LABEL = '^\s*\k\+:' if prevline =~? SUB let ind = ind + &sw endif if prevline =~? RETURNBLOCK let ind = ind + &sw endif if prevline =~? LABEL let ind = ind + 2 endif if thisline =~? END let ind = ind - &sw endif if thisline =~? LABEL let ind = ind - 2 endif return ind endfun complex.pmc000644000765000765 14637512356767111 15275 0ustar00bruce000000000000parrot-6.6.0/src/pmc/* Copyright (C) 2004-2014, Parrot Foundation. =head1 NAME src/pmc/complex.pmc - Complex PMC =head1 DESCRIPTION C provides a representation of complex numbers. It handles string parsing/generating and basic mathematical operations. =head2 Functions Equations used are sometimes listed. At times, multiple equations are given, but those starting with => are the ones used. =over 4 =cut */ /* HEADERIZER HFILE: none */ /* HEADERIZER BEGIN: static */ /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */ static void complex_check_divide_zero(PARROT_INTERP, ARGIN(PMC *value)) __attribute__nonnull__(1) __attribute__nonnull__(2); static void complex_parse_string(PARROT_INTERP, ARGOUT(FLOATVAL *re), ARGOUT(FLOATVAL *im), ARGIN(STRING *value)) __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__nonnull__(3) __attribute__nonnull__(4) FUNC_MODIFIES(*re) FUNC_MODIFIES(*im); static void float_check_divide_zero(PARROT_INTERP, FLOATVAL value) __attribute__nonnull__(1); static void int_check_divide_zero(PARROT_INTERP, INTVAL value) __attribute__nonnull__(1); #define ASSERT_ARGS_complex_check_divide_zero __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(value)) #define ASSERT_ARGS_complex_parse_string __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(re) \ , PARROT_ASSERT_ARG(im) \ , PARROT_ASSERT_ARG(value)) #define ASSERT_ARGS_float_check_divide_zero __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp)) #define ASSERT_ARGS_int_check_divide_zero __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp)) /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */ /* HEADERIZER END: static */ /* =item C Parses the string in C to produce a complex number, represented by the real (C<*re>) and imaginary (C<*im>) parts. Raises an exception if it cannot understand the string. The string should be of the form C with optional spaces around C<+> and before C. You can also use C instead of C. =cut We have a conflict among our coding standards here. Our 100-character line limit meant that the following function declaration had to be split over two lines. However, that leads to t/codingstd/pmc_docs.t reporting that this function lacks documentation -- reporting due to differences in whitespacing between '=item' and function declaration. */ static void complex_parse_string(PARROT_INTERP, ARGOUT(FLOATVAL *re), ARGOUT(FLOATVAL *im), ARGIN(STRING *value)) { ASSERT_ARGS(complex_parse_string) char * const str = Parrot_str_to_cstring(interp, value); char *t = str; char *first_num_offset = str; char *second_num_offset = NULL; STRING *S; INTVAL i = 0; INTVAL first_num_minus = 0; INTVAL second_num_minus = 0; UINTVAL first_num_length, second_num_length; /* walk the string and identify the real and imaginary parts */ if (*t == '-') { /* first number is negative */ ++t; first_num_minus = 1; /* allow for an optional space */ if (*t == ' ') ++t; first_num_offset = t; } /* skip digits */ while (*t >= '0' && *t <= '9') ++t; if (*t == '.') { /* this number has a decimal point */ ++t; /* skip digits */ while (*t >= '0' && *t <= '9') ++t; } /* save the length of the real part */ first_num_length = t - first_num_offset; /* end of string; we only have a real part */ if (*t == 0) { second_num_length = 0; } else if ((*t == 'i' || *t == 'j') && *(t+1) == 0) { /* there is only an imaginary part, so the first number was actually the imaginary part */ second_num_length = first_num_length; first_num_length = 0; second_num_offset = first_num_offset; second_num_minus = first_num_minus; first_num_minus = 0; /* this is useful if there is no number for the imaginary part, like in "-i" */ i = 1; } else { /* skip an optional space */ if (*t == ' ') ++t; /* expect "+" or "-" and the imaginary part */ if (*t == '+' || *t == '-') { /* save the sign */ second_num_minus = (*t == '-'); ++t; /* skip another optional space */ if (*t == ' ') ++t; /* save the beginning of the imaginary part */ second_num_offset = t; /* skip digits */ while (*t >= '0' && *t <= '9') ++t; if (*t == '.') { /* this number has a decimal point */ ++t; /* skip digits */ while (*t >= '0' && *t <= '9') ++t; } /* save the length of the imaginary part */ second_num_length = t - second_num_offset; /* allow for one more optional space */ if (*t == ' ') ++t; /* verify that the string ends properly */ if ((*t != 'i' && *t != 'j') || (*(t+1) != 0)) { /* imaginary part does not end in 'i' or 'j' */ Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_STRING_REPRESENTATION, "Complex: malformed string"); } /* this is useful if there is no number for the imaginary part, like in "2+i" */ i = 1; /* all is OK, save the number */ } else { /* "+" or "-" not found: error */ Parrot_str_free_cstring(str); Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_STRING_REPRESENTATION, "Complex: malformed string"); } } /* now we have the offsets and the lengths we turn them into float values */ if (first_num_length) { /* there is a real part, interpret it */ S = Parrot_str_new(interp, first_num_offset, first_num_length); *re = Parrot_str_to_num(interp, S); } else { /* consider the real part 0.0 */ *re = 0.0; } if (second_num_length) { /* there is an imaginary part, interpret it */ S = Parrot_str_new(interp, second_num_offset, second_num_length); *im = Parrot_str_to_num(interp, S); } else { /* consider the imaginary part 0.0 */ if (i) /* the string was something like "1+i" */ *im = 1.0; else *im = 0.0; } if (first_num_minus) *re = -*re; if (second_num_minus) *im = -*im; Parrot_str_free_cstring(str); } /* =item C If C is 0, throw a divide by zero exception. =cut */ static void int_check_divide_zero(PARROT_INTERP, INTVAL value) { ASSERT_ARGS(int_check_divide_zero) if (value == 0) Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_DIV_BY_ZERO, "Divide by zero"); } /* =item C If C is 0.0, throw a divide by zero exception. =cut */ static void float_check_divide_zero(PARROT_INTERP, FLOATVAL value) { ASSERT_ARGS(float_check_divide_zero) if (FLOAT_IS_ZERO(value)) Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_DIV_BY_ZERO, "Divide by zero"); } /* =item C If C is a Complex PMC with a value of 0, throw a divide by zero exception. =cut */ static void complex_check_divide_zero(PARROT_INTERP, ARGIN(PMC *value)) { ASSERT_ARGS(complex_check_divide_zero) /* Throw an exception if we are dividing by zero. Check both the real part * and the imaginary part.*/ if (FLOAT_IS_ZERO(VTABLE_get_number_keyed_int(interp, value, 0)) && FLOAT_IS_ZERO(VTABLE_get_number_keyed_int(interp, value, 1))) Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_DIV_BY_ZERO, "Divide by zero"); } pmclass Complex provides complex provides scalar auto_attrs { ATTR FLOATVAL re; /* real part */ ATTR FLOATVAL im; /* imaginary part */ /* =back =head2 Methods =over 4 =item C Initializes the complex number with the value 0+0i. =item C Initializes the complex number with the specified initializer. The initializer can be a string PMC or a numeric array with (real, imag) =item C Creates an identical copy of the complex number. =cut */ VTABLE void init() { SET_ATTR_re(INTERP, SELF, 0.0); SET_ATTR_im(INTERP, SELF, 0.0); } VTABLE void init_pmc(PMC *initializer) :manual_wb { const INTVAL arg_type = VTABLE_type(INTERP, initializer); SELF.init(); switch (arg_type) { case enum_class_String: SELF.set_string_native(VTABLE_get_string(INTERP, initializer)); break; case enum_class_FixedFloatArray: case enum_class_ResizableFloatArray: case enum_class_FixedIntegerArray: case enum_class_ResizableIntegerArray: if (VTABLE_get_integer(INTERP, initializer) == 2) { const FLOATVAL re = VTABLE_get_number_keyed_int(INTERP, initializer, 0); const FLOATVAL im = VTABLE_get_number_keyed_int(INTERP, initializer, 1); SET_ATTR_re(INTERP, SELF, re); SET_ATTR_im(INTERP, SELF, im); PARROT_GC_WRITE_BARRIER(INTERP, SELF); break; } /* else let it fall to default */ default: if (VTABLE_isa(INTERP, initializer, CONST_STRING(INTERP, "String"))) { STRING * const s = VTABLE_get_string(INTERP, initializer); SELF.set_string_native(s); } else { Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_INVALID_OPERATION, "Invalid Complex initializer"); } } } VTABLE PMC *clone() :no_wb { PMC * const dest = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); FLOATVAL re, im; GET_ATTR_re(INTERP, SELF, re); GET_ATTR_im(INTERP, SELF, im); SET_ATTR_re(INTERP, dest, re); SET_ATTR_im(INTERP, dest, im); return dest; } /* =item C =item C Serialize/deserialize this object for bytecode. =cut */ VTABLE void freeze(PMC *visit) :no_wb { FLOATVAL re, im; SUPER(visit); GET_ATTR_re(INTERP, SELF, re); VTABLE_push_float(INTERP, visit, re); GET_ATTR_im(INTERP, SELF, im); VTABLE_push_float(INTERP, visit, im); } VTABLE void thaw(PMC *visit) { FLOATVAL re, im; SUPER(visit); re = VTABLE_shift_float(INTERP, visit); SET_ATTR_re(INTERP, SELF, re); im = VTABLE_shift_float(INTERP, visit); SET_ATTR_im(INTERP, SELF, im); } /* =item C Returns the modulus of the complex number as an integer. =item C Returns the modulus of the complex number. =item C Returns the complex number as a string in the form C. =item C Returns true if the complex number is non-zero. =cut */ VTABLE INTVAL get_integer() :no_wb { const FLOATVAL f = SELF.get_number(); return (INTVAL)f; } VTABLE FLOATVAL get_number() :no_wb { FLOATVAL re, im; GET_ATTR_re(INTERP, SELF, re); GET_ATTR_im(INTERP, SELF, im); return sqrt(re * re + im * im); } VTABLE STRING *get_string() :no_wb { FLOATVAL re, im; GET_ATTR_re(INTERP, SELF, re); GET_ATTR_im(INTERP, SELF, im); return Parrot_sprintf_c(INTERP, "%vg%+vgi", re, im); } VTABLE INTVAL get_bool() :no_wb { FLOATVAL re, im; GET_ATTR_re(INTERP, SELF, re); GET_ATTR_im(INTERP, SELF, im); return !(FLOAT_IS_ZERO(re) && FLOAT_IS_ZERO(im)); } /* =item C =item C =item C =item C =item C =item C Returns the requested number (real part for C and imaginary for C). =cut */ VTABLE INTVAL get_integer_keyed(PMC *key) :no_wb { STRING * const s = VTABLE_get_string(INTERP, key); return SELF.get_integer_keyed_str(s); } VTABLE INTVAL get_integer_keyed_str(STRING *key) :no_wb { const FLOATVAL f = SELF.get_number_keyed_str(key); return (INTVAL)f; } VTABLE FLOATVAL get_number_keyed(PMC *key) :no_wb { STRING * const s = VTABLE_get_string(INTERP, key); return SELF.get_number_keyed_str(s); } VTABLE FLOATVAL get_number_keyed_str(STRING *key) :no_wb { FLOATVAL value; if (STRING_equal(INTERP, key, CONST_STRING(INTERP, "real"))) { GET_ATTR_re(INTERP, SELF, value); } else if (STRING_equal(INTERP, key, CONST_STRING(INTERP, "imag"))) { GET_ATTR_im(INTERP, SELF, value); } else Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_INVALID_OPERATION, "Complex: key is neither 'real' or 'imag'"); return value; } VTABLE PMC *get_pmc_keyed(PMC *key) :no_wb { if (VTABLE_isa(INTERP, key, CONST_STRING(INTERP, "Integer"))) { const INTVAL i = VTABLE_get_integer(INTERP, key); return SELF.get_pmc_keyed_int(i); } else { STRING * const s = VTABLE_get_string(INTERP, key); return SELF.get_pmc_keyed_str(s); } } VTABLE PMC *get_pmc_keyed_str(STRING *key) :no_wb { PMC * const ret = Parrot_pmc_new(INTERP, enum_class_Float); const FLOATVAL val = SELF.get_number_keyed_str(key); VTABLE_set_number_native(INTERP, ret, val); return ret; } /* =item C Returns the requested number (real part for C<0> and imaginary for C<1>). =cut */ VTABLE PMC *get_pmc_keyed_int(INTVAL key) :no_wb { PMC * const ret = Parrot_pmc_new(INTERP, enum_class_Float); const FLOATVAL val = SELF.get_number_keyed_int(key); VTABLE_set_number_native(INTERP, ret, val); return ret; } /* =item C Quick hack to emulate get_real() and get_imag(): key = 0 ... get real part key = 1 ... get imag part =item C Set real or imag depending on key =cut */ VTABLE FLOATVAL get_number_keyed_int(INTVAL key) :no_wb { FLOATVAL f; switch (key) { case 0: GET_ATTR_re(INTERP, SELF, f); break; case 1: GET_ATTR_im(INTERP, SELF, f); break; default: Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_INVALID_OPERATION, "Complex: key must be 0 or 1"); } return f; } VTABLE void set_number_keyed_int(INTVAL key, FLOATVAL v) { switch (key) { case 0: SET_ATTR_re(INTERP, SELF, v); break; case 1: SET_ATTR_im(INTERP, SELF, v); break; default: Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_INVALID_OPERATION, "Complex: key must be 0 or 1"); } } /* =item C Parses the string C into a complex number; raises an exception on failure. =item C if C is a Complex PMC then the complex number is set to its value; otherwise C's string representation is parsed with C. =item C =item C Sets the real part of the complex number to C and the imaginary part to C<0.0> =cut */ VTABLE void set_string_native(STRING *value) { FLOATVAL re, im; complex_parse_string(INTERP, &re, &im, value); SET_ATTR_re(INTERP, SELF, re); SET_ATTR_im(INTERP, SELF, im); } VTABLE void set_pmc(PMC *value) :manual_wb { if (VTABLE_isa(INTERP, value, CONST_STRING(INTERP, "Complex"))) { FLOATVAL re, im; GET_ATTR_re(INTERP, value, re); GET_ATTR_im(INTERP, value, im); SET_ATTR_re(INTERP, SELF, re); SET_ATTR_im(INTERP, SELF, im); PARROT_GC_WRITE_BARRIER(INTERP, SELF); } else VTABLE_set_string_native(INTERP, SELF, VTABLE_get_string(INTERP, value)); } VTABLE void set_integer_native(INTVAL value) :manual_wb { SELF.set_number_native((FLOATVAL)value); } VTABLE void set_number_native(FLOATVAL value) { SET_ATTR_re(INTERP, SELF, value); SET_ATTR_im(INTERP, SELF, 0.0); } /* =item C =item C =item C =item C =item C =item C Sets the requested number (real part for C and imaginary for C) to C. =cut */ VTABLE void set_integer_keyed(PMC *key, INTVAL value) :manual_wb { SELF.set_number_keyed(key, (FLOATVAL)value); } VTABLE void set_integer_keyed_str(STRING *key, INTVAL value) :manual_wb { SELF.set_number_keyed_str(key, (FLOATVAL)value); } VTABLE void set_number_keyed(PMC *key, FLOATVAL value) :manual_wb { if (VTABLE_isa(INTERP, key, CONST_STRING(INTERP, "Integer"))) { const INTVAL i = VTABLE_get_integer(INTERP, key); SELF.set_number_keyed_int(i, value); } else { STRING *s = VTABLE_get_string(INTERP, key); SELF.set_number_keyed_str(s, value); } } VTABLE void set_number_keyed_str(STRING *key, FLOATVAL value) :manual_wb { if (STRING_equal(INTERP, key, CONST_STRING(INTERP, "real"))) { SET_ATTR_re(INTERP, SELF, value); PARROT_GC_WRITE_BARRIER(INTERP, SELF); } else if (STRING_equal(INTERP, key, CONST_STRING(INTERP, "imag"))) { SET_ATTR_im(INTERP, SELF, value); PARROT_GC_WRITE_BARRIER(INTERP, SELF); } else Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_INVALID_OPERATION, "Complex: key is neither 'real' or 'imag'"); } VTABLE void set_pmc_keyed(PMC *key, PMC *value) :manual_wb { const FLOATVAL f = VTABLE_get_number(INTERP, value); SELF.set_number_keyed(key, f); } VTABLE void set_pmc_keyed_str(STRING *key, PMC *value) :manual_wb { const FLOATVAL f = VTABLE_get_number(INTERP, value); SELF.set_number_keyed_str(key, f); } /* =item C =item C =item C Adds C to the complex number, placing the result in C. =cut */ MULTI PMC *add(Complex value, PMC *dest) :no_wb { FLOATVAL self_re, self_im, val_re, val_im; dest = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); GET_ATTR_re(INTERP, SELF, self_re); GET_ATTR_im(INTERP, SELF, self_im); GET_ATTR_re(INTERP, value, val_re); GET_ATTR_im(INTERP, value, val_im); SET_ATTR_re(INTERP, dest, self_re + val_re); SET_ATTR_im(INTERP, dest, self_im + val_im); return dest; } MULTI PMC *add(DEFAULT value, PMC *dest) :no_wb { FLOATVAL re, im; dest = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); GET_ATTR_re(INTERP, SELF, re); GET_ATTR_im(INTERP, SELF, im); SET_ATTR_re(INTERP, dest, re + VTABLE_get_number(INTERP, value)); SET_ATTR_im(INTERP, dest, im); return dest; } VTABLE PMC *add_int(INTVAL value, PMC *dest) :no_wb { return SELF.add_float((FLOATVAL)value, dest); } VTABLE PMC *add_float(FLOATVAL value, PMC *dest) :no_wb { FLOATVAL re, im; dest = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); GET_ATTR_re(INTERP, SELF, re); GET_ATTR_im(INTERP, SELF, im); SET_ATTR_re(INTERP, dest, re + value); SET_ATTR_im(INTERP, dest, im); return dest; } MULTI void i_add(Complex value) { FLOATVAL self_re, self_im, val_re, val_im; GET_ATTR_re(INTERP, SELF, self_re); GET_ATTR_im(INTERP, SELF, self_im); GET_ATTR_re(INTERP, value, val_re); GET_ATTR_im(INTERP, value, val_im); SET_ATTR_re(INTERP, SELF, self_re + val_re); SET_ATTR_im(INTERP, SELF, self_im + val_im); } MULTI void i_add(DEFAULT value) { FLOATVAL re; GET_ATTR_re(INTERP, SELF, re); SET_ATTR_re(INTERP, SELF, re + VTABLE_get_number(INTERP, value)); } VTABLE void i_add_int(INTVAL value) :manual_wb { SELF.i_add_float((FLOATVAL)value); } VTABLE void i_add_float(FLOATVAL value) { FLOATVAL re; GET_ATTR_re(INTERP, SELF, re); SET_ATTR_re(INTERP, SELF, re + value); } /* =item C =item C =item C Subtracts C from the complex number, placing the result in C. =cut */ MULTI PMC *subtract(Complex value, PMC *dest) :no_wb { FLOATVAL self_re, self_im, val_re, val_im; dest = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); GET_ATTR_re(INTERP, SELF, self_re); GET_ATTR_im(INTERP, SELF, self_im); GET_ATTR_re(INTERP, value, val_re); GET_ATTR_im(INTERP, value, val_im); SET_ATTR_re(INTERP, dest, self_re - val_re); SET_ATTR_im(INTERP, dest, self_im - val_im); return dest; } MULTI PMC *subtract(DEFAULT value, PMC *dest) :no_wb { FLOATVAL re, im; dest = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); GET_ATTR_re(INTERP, SELF, re); GET_ATTR_im(INTERP, SELF, im); SET_ATTR_re(INTERP, dest, re - VTABLE_get_number(INTERP, value)); SET_ATTR_im(INTERP, dest, im); return dest; } VTABLE PMC *subtract_int(INTVAL value, PMC *dest) :no_wb { return SELF.subtract_float((FLOATVAL)value, dest); } VTABLE PMC *subtract_float(FLOATVAL value, PMC *dest) :no_wb { FLOATVAL re, im; dest = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); GET_ATTR_re(INTERP, SELF, re); GET_ATTR_im(INTERP, SELF, im); SET_ATTR_re(INTERP, dest, re - value); SET_ATTR_im(INTERP, dest, im); return dest; } MULTI void i_subtract(Complex value) { FLOATVAL self_re, self_im, val_re, val_im; GET_ATTR_re(INTERP, SELF, self_re); GET_ATTR_im(INTERP, SELF, self_im); GET_ATTR_re(INTERP, value, val_re); GET_ATTR_im(INTERP, value, val_im); SET_ATTR_re(INTERP, SELF, self_re - val_re); SET_ATTR_im(INTERP, SELF, self_im - val_im); } MULTI void i_subtract(DEFAULT value) { FLOATVAL re; GET_ATTR_re(INTERP, SELF, re); SET_ATTR_re(INTERP, SELF, re - VTABLE_get_number(INTERP, value)); } VTABLE void i_subtract_int(INTVAL value) :manual_wb { SELF.i_subtract_float((FLOATVAL) value); } VTABLE void i_subtract_float(FLOATVAL value) { FLOATVAL re; GET_ATTR_re(INTERP, SELF, re); SET_ATTR_re(INTERP, SELF, re - value); } /* =item C =item C =item C Multiplies the complex number with C, placing the result in C. =item C =item C =item C Multiplies the complex number SELF inplace with C. =cut */ /* (a+ib)(c+id)=(ac-bd)+i((a+b)(c+d)-ac-bd). (a+bi)(c+di)=(ac-bd)+i(ad+bc) */ MULTI PMC *multiply(Complex value, PMC *dest) :no_wb { FLOATVAL a, b, c, d; dest = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); GET_ATTR_re(INTERP, SELF, a); GET_ATTR_im(INTERP, SELF, b); GET_ATTR_re(INTERP, value, c); GET_ATTR_im(INTERP, value, d); SET_ATTR_re(INTERP, dest, a * c - b * d); SET_ATTR_im(INTERP, dest, a * d + b * c); return dest; } MULTI PMC *multiply(DEFAULT value, PMC *dest) :no_wb { FLOATVAL re, im; dest = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); GET_ATTR_re(INTERP, SELF, re); GET_ATTR_im(INTERP, SELF, im); SET_ATTR_re(INTERP, dest, re * VTABLE_get_number(INTERP, value)); SET_ATTR_im(INTERP, dest, im * VTABLE_get_number(INTERP, value)); return dest; } VTABLE PMC *multiply_int(INTVAL value, PMC *dest) :no_wb { return SELF.multiply_float((FLOATVAL) value, dest); } VTABLE PMC *multiply_float(FLOATVAL value, PMC *dest) :no_wb { FLOATVAL re, im; dest = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); GET_ATTR_re(INTERP, SELF, re); GET_ATTR_im(INTERP, SELF, im); SET_ATTR_re(INTERP, dest, re * value); SET_ATTR_im(INTERP, dest, im * value); return dest; } MULTI void i_multiply(Complex value) { FLOATVAL a, b, c, d; GET_ATTR_re(INTERP, SELF, a); GET_ATTR_im(INTERP, SELF, b); GET_ATTR_re(INTERP, value, c); GET_ATTR_im(INTERP, value, d); SET_ATTR_re(INTERP, SELF, a * c - b * d); SET_ATTR_im(INTERP, SELF, a * d + b * c); } MULTI void i_multiply(DEFAULT value) { FLOATVAL re, im; GET_ATTR_re(INTERP, SELF, re); GET_ATTR_im(INTERP, SELF, im); SET_ATTR_re(INTERP, SELF, re * VTABLE_get_number(INTERP, value)); SET_ATTR_im(INTERP, SELF, im * VTABLE_get_number(INTERP, value)); } VTABLE void i_multiply_int(INTVAL value) { FLOATVAL re, im; GET_ATTR_re(INTERP, SELF, re); GET_ATTR_im(INTERP, SELF, im); SET_ATTR_re(INTERP, SELF, re * value); SET_ATTR_im(INTERP, SELF, im * value); } VTABLE void i_multiply_float(FLOATVAL value) { FLOATVAL re, im; GET_ATTR_re(INTERP, SELF, re); GET_ATTR_im(INTERP, SELF, im); SET_ATTR_re(INTERP, SELF, re * value); SET_ATTR_im(INTERP, SELF, im * value); } /* =item C =item C =item C Divide the complex number by C, placing the result in C. =item C =item C =item C Divide the complex number C by C inplace. Throws divide by zero exception if divisor is zero. =cut TODO: for better fp precision http://docs.sun.com/source/806-3568/ncg_goldberg.html (a+ib)/(c+id) = (a + b(d/c)) / (c + d(d/c)) + i(b - a(d/c)) / (c + d(d/c)) if |d|<|c| (b + a(c/d)) / (d + c(c/d)) + i(-a + b(c/d)) / (d + c(c/d)) if |d|>=|c| */ MULTI PMC *divide(Complex value, PMC *dest) :no_wb { FLOATVAL mod, re, im; FLOATVAL self_re, self_im, val_re, val_im; complex_check_divide_zero(INTERP, value); dest = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); GET_ATTR_re(INTERP, SELF, self_re); GET_ATTR_im(INTERP, SELF, self_im); GET_ATTR_re(INTERP, value, val_re); GET_ATTR_im(INTERP, value, val_im); /* a little speed optimisation: cache an intermediate number; I'm not sure the compiler does this */ if (self_im == 0.0 && val_im == 0.0) { re = self_re / val_re; im = 0.0; } else { mod = (val_re * val_re + val_im * val_im); re = (self_re * val_re + self_im * val_im) / mod; im = (self_im * val_re - self_re * val_im) / mod; } SET_ATTR_re(INTERP, dest, re); SET_ATTR_im(INTERP, dest, im); return dest; } MULTI PMC *divide(DEFAULT value, PMC *dest) :no_wb { FLOATVAL re, im; const FLOATVAL d = VTABLE_get_number(INTERP, value); float_check_divide_zero(INTERP, d); dest = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); GET_ATTR_re(INTERP, SELF, re); GET_ATTR_im(INTERP, SELF, im); SET_ATTR_re(INTERP, dest, re / d); SET_ATTR_im(INTERP, dest, im / d); return dest; } VTABLE PMC *divide_int(INTVAL value, PMC *dest) :no_wb { FLOATVAL re, im; int_check_divide_zero(INTERP, value); dest = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); GET_ATTR_re(INTERP, SELF, re); GET_ATTR_im(INTERP, SELF, im); SET_ATTR_re(INTERP, dest, re / value); SET_ATTR_im(INTERP, dest, im / value); return dest; } VTABLE PMC *divide_float(FLOATVAL value, PMC *dest) :no_wb { FLOATVAL re, im; float_check_divide_zero(INTERP, value); dest = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); GET_ATTR_re(INTERP, SELF, re); GET_ATTR_im(INTERP, SELF, im); SET_ATTR_re(INTERP, dest, re / value); SET_ATTR_im(INTERP, dest, im / value); return dest; } MULTI void i_divide(Complex value) { FLOATVAL re, im; FLOATVAL self_re, self_im, val_re, val_im; complex_check_divide_zero(INTERP, value); GET_ATTR_re(INTERP, SELF, self_re); GET_ATTR_im(INTERP, SELF, self_im); GET_ATTR_re(INTERP, value, val_re); GET_ATTR_im(INTERP, value, val_im); if (self_im == 0.0 && val_im == 0.0) { re = self_re / val_re; im = 0.0; } else { /* a little speed optimisation: cache an intermediate number; I'm not sure the compiler does this */ const FLOATVAL mod = (val_re * val_re + val_im * val_im); re = (self_re * val_re + self_im * val_im) / mod; im = (self_im * val_re - self_re * val_im) / mod; } SET_ATTR_re(INTERP, SELF, re); SET_ATTR_im(INTERP, SELF, im); } MULTI void i_divide(DEFAULT value) { FLOATVAL re, im; const FLOATVAL d = VTABLE_get_number(INTERP, value); float_check_divide_zero(INTERP, d); GET_ATTR_re(INTERP, SELF, re); GET_ATTR_im(INTERP, SELF, im); SET_ATTR_re(INTERP, SELF, re / d); SET_ATTR_im(INTERP, SELF, im / d); } VTABLE void i_divide_int(INTVAL value) { FLOATVAL re, im; int_check_divide_zero(INTERP, value); GET_ATTR_re(INTERP, SELF, re); GET_ATTR_im(INTERP, SELF, im); SET_ATTR_re(INTERP, SELF, re / value); SET_ATTR_im(INTERP, SELF, im / value); } VTABLE void i_divide_float(FLOATVAL value) { FLOATVAL re, im; float_check_divide_zero(INTERP, value); GET_ATTR_re(INTERP, SELF, re); GET_ATTR_im(INTERP, SELF, im); SET_ATTR_re(INTERP, SELF, re / value); SET_ATTR_im(INTERP, SELF, im / value); } /* =item C =item C Set C to the negated value of C. =cut */ VTABLE PMC *neg(PMC *dest) :no_wb { FLOATVAL re, im; dest = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); GET_ATTR_re(INTERP, SELF, re); GET_ATTR_im(INTERP, SELF, im); SET_ATTR_re(INTERP, dest, -re); SET_ATTR_im(INTERP, dest, -im); return dest; } VTABLE void i_neg() { FLOATVAL re, im; GET_ATTR_re(INTERP, SELF, re); GET_ATTR_im(INTERP, SELF, im); SET_ATTR_re(INTERP, SELF, -re); SET_ATTR_im(INTERP, SELF, -im); } /* =item C Compares the complex number with C and returns true if they are equal. =cut */ MULTI INTVAL is_equal(Complex value) :no_wb { FLOATVAL self_re, self_im, val_re, val_im; GET_ATTR_re(INTERP, SELF, self_re); GET_ATTR_im(INTERP, SELF, self_im); GET_ATTR_re(INTERP, value, val_re); GET_ATTR_im(INTERP, value, val_im); return (INTVAL)(self_re == val_re && self_im == val_im); } MULTI INTVAL is_equal(DEFAULT value) :no_wb { FLOATVAL re, im; GET_ATTR_re(INTERP, SELF, re); GET_ATTR_im(INTERP, SELF, im); if (im != 0.0) return (INTVAL)0; return (re == VTABLE_get_number(INTERP, value)); } /* =item C =item C Sets C to the absolute value of SELF that is the distance from (0.0). =cut */ /* TODO for better precision: hinted by vaxman according to "Numerical Recipes in Fortran 77", 2nd edition, Press, Vetterling, Teukolsky, Flannery, Cambridge University Press, 2001, pp. 171ff: |a+ib|=|a|*sqrt(1+(b/a)**2), if |a|>=|b|, |b|*sqrt(1+(a/b)**2) else. */ VTABLE PMC *absolute(PMC *dest) :no_wb { FLOATVAL re, im, d; GET_ATTR_re(INTERP, SELF, re); GET_ATTR_im(INTERP, SELF, im); d = sqrt(re*re + im*im); dest = Parrot_pmc_new(INTERP, Parrot_hll_get_ctx_HLL_type(INTERP, enum_class_Float)); VTABLE_set_number_native(INTERP, dest, d); return dest; } VTABLE void i_absolute() :manual_wb { FLOATVAL re, im, d; GET_ATTR_re(INTERP, SELF, re); GET_ATTR_im(INTERP, SELF, im); d = sqrt(re*re + im*im); Parrot_pmc_reuse(INTERP, SELF, enum_class_Float, 0); VTABLE_set_number_native(INTERP, SELF, d); } /* =item C Returns the natural logarithm of SELF as a PMC. =cut ln z = ln |z| + i arg(z) |x + iy| = sqrt(x^2 + y^2) arg(x + iy) = atan2(y, x) Some special cases ln(-1) = pi i ln(0) = -inf ln(1) = 0 ln(e) = 1 ln(+-i) = +- (pi i)/2 */ METHOD ln() :no_wb { PMC * const d = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); FLOATVAL re, im, result_re, result_im; GET_ATTR_re(INTERP, SELF, re); GET_ATTR_im(INTERP, SELF, im); /* This is necessary for atan2 to behave */ if (im == -0.0) im = 0.0; result_re = log(sqrt(re*re + im*im)); if (re == 0.0 && im == 0.0) /* atan2(0, 0) not portable */ result_im = 0.0; else result_im = atan2(im, re); SET_ATTR_re(INTERP, d, result_re); SET_ATTR_im(INTERP, d, result_im); RETURN(PMC *d); } /* =item C Returns e ^ SELF as a PMC. =cut exp(a + bi) = exp(a) * (cos(b) + i * sin(b)) */ METHOD exp() :no_wb { PMC * const d = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); FLOATVAL re, im, f; GET_ATTR_re(INTERP, SELF, re); GET_ATTR_im(INTERP, SELF, im); f = exp(re); SET_ATTR_re(INTERP, d, f * cos(im)); /* If only sin(pi) worked. */ if (im == 4.0 * atan(1.0)) { SET_ATTR_im(INTERP, d, 0.0); } else { SET_ATTR_im(INTERP, d, f * sin(im)); } RETURN(PMC *d); } /* =item C =item C =item C =item C =item C =item C Returns C(SELF). =cut => sin(a + bi) = sin(a)cosh(b)+i*cos(a)sinh(b) sin(z) = ((e ^ zi) - (e ^ -zi)) / (2i) => cos(a + bi) = cos(a) * cosh(b) - i * sin(a) * sinh(b) cos(z) = ((e ^ zi) + (e ^ -zi)) / 2 sin(iz) = i sinh(z) cos(iz) = cosh(z) sinh(iz) = i sin(z) cosh(iz) = cos z sinh(a + bi) = sinh(a) * cos(b) + i * cosh(a) * sin(b) cosh(a + bi) = cosh(a) * cos(b) + i * sinh(a) * sin(b) */ METHOD sin() :no_wb { PMC * const d = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); FLOATVAL re, im, result_re, result_im; GET_ATTR_re(INTERP, SELF, re); GET_ATTR_im(INTERP, SELF, im); if (FLOAT_IS_ZERO(im)) { result_re = sin(re); result_im = 0.0; } else if (FLOAT_IS_ZERO(re)) { result_re = 0.0; result_im = sinh(im); } else { result_re = sin(re) * cosh(im); if (im == -0.0) result_im = 0.0; else result_im = cos(re) * sinh(im); } SET_ATTR_re(INTERP, d, result_re); SET_ATTR_im(INTERP, d, result_im); RETURN(PMC *d); } METHOD cos() :no_wb { PMC * const d = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); FLOATVAL re, im, result_re, result_im; GET_ATTR_re(INTERP, SELF, re); GET_ATTR_im(INTERP, SELF, im); if (FLOAT_IS_ZERO(re)) { result_re = cosh(im); result_im = 0.0; } else if (FLOAT_IS_ZERO(im)) { result_re = cos(re); result_im = 0.0; } else { result_re = cos(re) * cosh(im); result_im = -1.0 * sin(re) * sinh(im); } SET_ATTR_re(INTERP, d, result_re); SET_ATTR_im(INTERP, d, result_im); RETURN(PMC *d); } METHOD tan() :no_wb { PMC * const d = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); PMC * const e = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); (PMC *d) = PCCINVOKE(INTERP, SELF, "sin"); (PMC *e) = PCCINVOKE(INTERP, SELF, "cos"); Parrot_Complex_multi_i_divide_Complex(INTERP, d, e); RETURN(PMC *d); } METHOD cot() :no_wb { PMC * const d = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); PMC * const e = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); (PMC *d) = PCCINVOKE(INTERP, SELF, "cos"); (PMC *e) = PCCINVOKE(INTERP, SELF, "sin"); Parrot_Complex_multi_i_divide_Complex(INTERP, d, e); RETURN(PMC *d); } METHOD sec() :no_wb { PMC * const d = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); PMC * const e = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); SET_ATTR_re(INTERP, d, 1.0); SET_ATTR_im(INTERP, d, 0.0); (PMC *e) = PCCINVOKE(INTERP, SELF, "cos"); Parrot_Complex_multi_i_divide_Complex(INTERP, d, e); RETURN(PMC *d); } METHOD csc() :no_wb { PMC * const d = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); PMC * const e = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); SET_ATTR_re(INTERP, d, 1.0); SET_ATTR_im(INTERP, d, 0.0); (PMC *e) = PCCINVOKE(INTERP, SELF, "sin"); Parrot_Complex_multi_i_divide_Complex(INTERP, d, e); RETURN(PMC *d); } /* =item C =item C =item C =item C =item C =item C Returns the inverse function of SELF. =cut => arcsin z = -i ln(iz + sqrt(1-z*z)) => arccos z = pi/2 + i * ln(iz + sqrt(1 - z*z)) arccos z = -i ln(z + sqrt(z*z-1)) => arctan z = i/2 ln((i+z) / (i-z)) arctan z = 1/2 i (ln(1-iz) - ln(1 + iz)) => acot(z) = atan(1 / z) acot(z) = i/2 (ln((z - i) / z) - ln((z + i) / z)) => asec(z) = acos(1 / z) asec(z) = 1/2 pi + i ln(sqrt(1 - 1/zz) + i/z) => acsc(z) = asin(1 / z) acsc(z) = -i ln(sqrt(1 - 1/zz + i/z)) */ METHOD asin() :no_wb { FLOATVAL d_re, d_im, e_re, e_im, self_re, self_im; PMC * const d = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); PMC * e = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); GET_ATTR_re(INTERP, SELF, self_re); GET_ATTR_im(INTERP, SELF, self_im); e = Parrot_Complex_multi_multiply_Complex_PMC(INTERP, SELF, SELF, e); GET_ATTR_re(INTERP, e, e_re); GET_ATTR_im(INTERP, e, e_im); SET_ATTR_re(INTERP, e, 1.0 - e_re); SET_ATTR_im(INTERP, e, -e_im); (PMC *d) = PCCINVOKE(INTERP, e, "sqrt"); GET_ATTR_re(INTERP, d, d_re); GET_ATTR_im(INTERP, d, d_im); SET_ATTR_re(INTERP, d, d_re - self_im); SET_ATTR_im(INTERP, d, d_im + self_re); (PMC *d) = PCCINVOKE(INTERP, d, "ln"); GET_ATTR_re(INTERP, d, d_re); GET_ATTR_im(INTERP, d, d_im); SET_ATTR_re(INTERP, e, d_im); SET_ATTR_im(INTERP, e, d_re ? -d_re : 0.0); RETURN(PMC *e); } METHOD acos() :no_wb { FLOATVAL d_re, d_im, e_re, e_im, self_re, self_im; PMC * const d = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); PMC * e = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); GET_ATTR_re(INTERP, SELF, self_re); GET_ATTR_im(INTERP, SELF, self_im); e = Parrot_Complex_multi_multiply_Complex_PMC(INTERP, SELF, SELF, e); GET_ATTR_re(INTERP, e, e_re); GET_ATTR_im(INTERP, e, e_im); SET_ATTR_re(INTERP, e, 1.0 - e_re); SET_ATTR_im(INTERP, e, -e_im); (PMC *d) = PCCINVOKE(INTERP, e, "sqrt"); GET_ATTR_re(INTERP, d, d_re); GET_ATTR_im(INTERP, d, d_im); SET_ATTR_re(INTERP, d, d_re + self_im); SET_ATTR_im(INTERP, d, d_im - self_re); (PMC *e) = PCCINVOKE(INTERP, d, "ln"); GET_ATTR_re(INTERP, e, e_re); GET_ATTR_im(INTERP, e, e_im); SET_ATTR_re(INTERP, d, e_im + 2.0 * atan(1.0)); SET_ATTR_im(INTERP, d, e_re ? -e_re : 0.0); RETURN(PMC *d); } METHOD atan() :no_wb { PMC * const d = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); PMC * const e = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); FLOATVAL re, im, d_re, d_im; GET_ATTR_re(INTERP, SELF, re); GET_ATTR_im(INTERP, SELF, im); SET_ATTR_re(INTERP, d, re); SET_ATTR_im(INTERP, d, 1 + im); SET_ATTR_re(INTERP, e, -re); SET_ATTR_im(INTERP, e, 1 - im); Parrot_Complex_multi_i_divide_Complex(INTERP, d, e); (PMC *d) = PCCINVOKE(INTERP, d, "ln"); GET_ATTR_re(INTERP, d, d_re); GET_ATTR_im(INTERP, d, d_im); SET_ATTR_re(INTERP, e, (d_im ? d_im : -0.0) / -2.0); SET_ATTR_im(INTERP, e, d_re / 2.0); RETURN(PMC *e); } METHOD acot() :no_wb { PMC * const d = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); PMC *e; FLOATVAL re, im; GET_ATTR_re(INTERP, SELF, re); GET_ATTR_im(INTERP, SELF, im); SET_ATTR_re(INTERP, d, re / (re * re + im * im)); SET_ATTR_im(INTERP, d, -im / (re * re + im * im)); (PMC *e) = PCCINVOKE(INTERP, d, "atan"); RETURN(PMC *e); } METHOD acsc() :no_wb { PMC * const d = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); PMC *e; FLOATVAL re, im; GET_ATTR_re(INTERP, SELF, re); GET_ATTR_im(INTERP, SELF, im); SET_ATTR_re(INTERP, d, re / (re * re + im * im)); SET_ATTR_im(INTERP, d, -im / (re * re + im * im)); (PMC *e) = PCCINVOKE(INTERP, d, "asin"); RETURN(PMC *e); } METHOD asec() :no_wb { PMC * const d = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); PMC *e; FLOATVAL re, im; GET_ATTR_re(INTERP, SELF, re); GET_ATTR_im(INTERP, SELF, im); SET_ATTR_re(INTERP, d, re / (re * re + im * im)); SET_ATTR_im(INTERP, d, -im / (re * re + im * im)); (PMC *e) = PCCINVOKE(INTERP, d, "acos"); RETURN(PMC *e); } /* =item C Returns the arctangent of SELF. =item C Returns the arcsine of SELF. =item C Returns the arccosine of SELF. =cut tanh(z) = sinh(z) / cosh(z) */ METHOD sinh() :no_wb { PMC * const d = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); FLOATVAL re, im; GET_ATTR_re(INTERP, SELF, re); GET_ATTR_im(INTERP, SELF, im); SET_ATTR_re(INTERP, d, sinh(re) * cos(im)); SET_ATTR_im(INTERP, d, im ? cosh(re) * sin(im) : 0.0); RETURN(PMC *d); } METHOD cosh() :no_wb { PMC * const d = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); FLOATVAL re, im; GET_ATTR_re(INTERP, SELF, re); GET_ATTR_im(INTERP, SELF, im); SET_ATTR_re(INTERP, d, cosh(re) * cos(im)); if (re == 0.0 || im == 0.0) { SET_ATTR_im(INTERP, d, 0.0); } else { SET_ATTR_im(INTERP, d, sinh(re) * sin(im)); } RETURN(PMC *d); } METHOD tanh() :no_wb { PMC * const d = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); PMC * const e = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); (PMC *d) = PCCINVOKE(INTERP, SELF, "sinh"); (PMC *e) = PCCINVOKE(INTERP, SELF, "cosh"); Parrot_Complex_multi_i_divide_Complex(INTERP, d, e); RETURN(PMC *d); } METHOD coth() :no_wb { FLOATVAL re, im; PMC * const d = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); (PMC *d) = PCCINVOKE(INTERP, SELF, "tanh"); GET_ATTR_re(INTERP, d, re); GET_ATTR_im(INTERP, d, im); SET_ATTR_re(INTERP, d, re ? re / (re * re + im * im) : 0.0); SET_ATTR_im(INTERP, d, im ? -im / (re * re + im * im) : 0.0); RETURN(PMC *d); } METHOD csch() :no_wb { FLOATVAL re, im; PMC * const d = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); (PMC *d) = PCCINVOKE(INTERP, SELF, "sinh"); GET_ATTR_re(INTERP, d, re); GET_ATTR_im(INTERP, d, im); SET_ATTR_re(INTERP, d, re ? re / (re * re + im * im) : 0.0); SET_ATTR_im(INTERP, d, im ? -im / (re * re + im * im) : 0.0); RETURN(PMC *d); } METHOD sech() :no_wb { FLOATVAL re, im; PMC * const d = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); (PMC *d) = PCCINVOKE(INTERP, SELF, "cosh"); GET_ATTR_re(INTERP, d, re); GET_ATTR_im(INTERP, d, im); SET_ATTR_re(INTERP, d, re ? re / (re * re + im * im) : 0.0); SET_ATTR_im(INTERP, d, im ? -im / (re * re + im * im) : 0.0); RETURN(PMC *d); } /* =item C =item C =item C =item C =item C =item C The inverse hyperbolic functions. Currently all broken, but for C, C<|c|> and C<|d|> will be correct, confusingly enough. =cut asinh z = -ln(sqrt(1+zz) - z) asinh z = ln(sqrt(zz + 1) + z) asinh = i asin(-ix) acosh = i acos(x) atanh = i atan(-ix) */ METHOD asinh() :no_wb { FLOATVAL re, im; PMC * const d = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); PMC * const e = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); GET_ATTR_re(INTERP, SELF, re); GET_ATTR_im(INTERP, SELF, im); SET_ATTR_re(INTERP, d, im); SET_ATTR_im(INTERP, d, -re); (PMC *d) = PCCINVOKE(INTERP, d, "asin"); GET_ATTR_re(INTERP, d, re); GET_ATTR_im(INTERP, d, im); SET_ATTR_re(INTERP, e, -im); SET_ATTR_im(INTERP, e, re); RETURN(PMC *e); } METHOD acosh() :no_wb { FLOATVAL re, im; PMC * const d = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); PMC * const e = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); (PMC *d) = PCCINVOKE(INTERP, SELF, "acos"); GET_ATTR_re(INTERP, d, re); GET_ATTR_im(INTERP, d, im); SET_ATTR_re(INTERP, e, -im); SET_ATTR_im(INTERP, e, re); RETURN(PMC *e); } METHOD atanh() :no_wb { FLOATVAL re, im; PMC * const d = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); PMC * const e = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); GET_ATTR_re(INTERP, SELF, re); GET_ATTR_im(INTERP, SELF, im); SET_ATTR_re(INTERP, d, im); SET_ATTR_im(INTERP, d, -re); (PMC *d) = PCCINVOKE(INTERP, d, "atan"); GET_ATTR_re(INTERP, d, re); GET_ATTR_im(INTERP, d, im); SET_ATTR_re(INTERP, e, -im); SET_ATTR_im(INTERP, e, re); RETURN(PMC *e); } METHOD acoth() :no_wb { PMC * const d = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); PMC *e; FLOATVAL re, im; GET_ATTR_re(INTERP, SELF, re); GET_ATTR_im(INTERP, SELF, im); SET_ATTR_re(INTERP, d, re / (re * re + im * im)); SET_ATTR_im(INTERP, d, -im / (re * re + im * im)); (PMC *e) = PCCINVOKE(INTERP, d, "atanh"); RETURN(PMC *e); } METHOD acsch() :no_wb { PMC * const d = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); PMC *e; FLOATVAL re, im; GET_ATTR_re(INTERP, SELF, re); GET_ATTR_im(INTERP, SELF, im); SET_ATTR_re(INTERP, d, re / (re * re + im * im)); SET_ATTR_im(INTERP, d, -im / (re * re + im * im)); (PMC *e) = PCCINVOKE(INTERP, d, "asinh"); RETURN(PMC *e); } METHOD asech() :no_wb { PMC * const d = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); PMC *e; FLOATVAL re, im; GET_ATTR_re(INTERP, SELF, re); GET_ATTR_im(INTERP, SELF, im); SET_ATTR_re(INTERP, d, re / (re * re + im * im)); SET_ATTR_im(INTERP, d, -im / (re * re + im * im)); (PMC *e) = PCCINVOKE(INTERP, d, "acosh"); RETURN(PMC *e); } /* =item C Raise SELF to the power of value. Replacement for the old pow() vtable, which was deleted. TODO: Requires testing =item C Return the square root of SELF. =cut TODO: mmd in other pmc's to allow .Integer ^ .Complex, etc. and i_pow, and pow_(float|int), etc x ^ y = exp(y * ln x)) */ METHOD pow(PMC * value) :no_wb { PMC *l = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); PMC *log; PMC * const dest = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); Parrot_pcc_invoke_method_from_c_args(INTERP, SELF, CONST_STRING(INTERP, "ln"), "->P", &log); l = VTABLE_multiply(INTERP, log, value, l); Parrot_pcc_invoke_method_from_c_args(INTERP, l, CONST_STRING(INTERP, "exp"), "->P", &dest); RETURN(PMC *dest); } METHOD sqrt() :no_wb { PMC * const result = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF)); const FLOATVAL absval = SELF.get_number(); FLOATVAL sx, sy, rx, ry; GET_ATTR_re(INTERP, SELF, sx); GET_ATTR_im(INTERP, SELF, sy); rx = sqrt((absval + sx) / 2); ry = sqrt((absval - sx) / 2); if (sy < 0) ry = -ry; SET_ATTR_re(INTERP, result, rx); SET_ATTR_im(INTERP, result, ry); RETURN(PMC *result); } } /* =back =cut */ /* * Local variables: * c-file-style: "parrot" * End: * vim: expandtab shiftwidth=4 cinoptions='\:2=2' : */ xlibtest.rb000644000765000765 461311466337261 16255 0ustar00bruce000000000000parrot-6.6.0/examples/nci# xlibtest.rb - A test of Xlib.pir usage from cardinal # # To run this file, execute the following command from the # current directory: # # ../../parrot ../../languages/cardinal/cardinal.pbc xlibtest.rb # # (You must have the cardinal pbc already builded). # # Press Esc key to exit the program. # # Parsing is very slow. Give it a minute to start up. require 'Xlib' puts 'Hello' puts 'Display: ' + Xlib::DisplayName() display = Xlib::OpenDisplay('') puts 'Default screen: ' + display.DefaultScreen() display.hello() white = display.WhitePixel(0) root = display.RootWindow() window = display.CreateSimpleWindow(root, 0, 0, 600, 400, 0, 0, white) window.StoreName("Hello, ruby") window.SelectInput(163919) window.Map() # Get Escape keycode keysym = Xlib::StringToKeysym('Escape') code_escape = display.KeysymToKeycode(keysym) event = Xlib::newEvent() type = 0 lastx = 0 lasty = 0 pressed = 0 listline = Array.new() line = Array.new() while type != 17 display.NextEvent(event) type = event.type() if type == 4 x = event.x() y = event.y() window.DrawPoint(x, y) lastx = x lasty = y pressed = 1 end if type == 5 newline = line listline.push(newline) line = Array.new() pressed = 0 end if type == 6 && pressed x = event.x() y = event.y() if x != lastx || y != lasty window.DrawLine(lastx, lasty, x, y) lastx = x lasty = y line.push(x, y) end end if type == 12 #puts 'Exposed. Lines: ', +@listline listline.each do |l| #puts 'Points ', l.elems if l.elems > 0 lx = l[0] ly = l[1] #puts lx, ' ', ly window.DrawPoint(lx, ly) i = 2 while i < l.elems x = l[i] y = l[i+1] window.DrawLine(lx, ly, x, y) lx = x ly = y #puts lx, ' ', ly i += 2 end end end end if type == 2 code = event.keycode() if code == code_escape window.Unmap() window.Destroy() end end if type == 33 window.Unmap() window.Destroy() end end display.Close() puts 'Bye' DONORS.pod000644000765000765 134712101554066 13203 0ustar00bruce000000000000parrot-6.6.0# Parrot is Copyright (C) 2001-2008, Parrot Foundation. =head1 NAME DONORS =head1 DESCRIPTION We want to thank the following people and institutions, whose financial contributions help to support the development of Parrot. =over 4 =item * The Perl Foundation L =item * NLnet Foundation L =item * The Mozilla Foundation L =item * Best Practical L =item * ActiveState L =item * BBC L =back =head1 ERRATA Information will be added to this file as it becomes available. For errors and omissions, please contact the directors of the Parrot Foundation =cut integer.pmc000644000765000765 10361112356767111 15245 0ustar00bruce000000000000parrot-6.6.0/src/pmc/* Copyright (C) 2003-2014, Parrot Foundation. =head1 NAME src/pmc/integer.pmc - Integer PMC =head1 DESCRIPTION C provides an integer for languages that want a value-restricted integer type without going to an I register. =head2 Functions =over 4 =cut */ #include "pmc/pmc_bigint.h" /* HEADERIZER HFILE: none */ /* HEADERIZER BEGIN: static */ /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */ static void maybe_throw_overflow_error(PARROT_INTERP) __attribute__nonnull__(1); PARROT_IGNORABLE_RESULT PARROT_CANNOT_RETURN_NULL static PMC* upgrade_self_to_bignum(PARROT_INTERP, ARGMOD(PMC *self)) __attribute__nonnull__(1) __attribute__nonnull__(2) FUNC_MODIFIES(*self); #define ASSERT_ARGS_maybe_throw_overflow_error __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp)) #define ASSERT_ARGS_upgrade_self_to_bignum __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(self)) /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */ /* HEADERIZER END: static */ /* =item C Checks to see if the interpreter is set to throw an exception on overflow. If so, throw the exception, otherwise ignore. =cut */ static void maybe_throw_overflow_error(PARROT_INTERP) { ASSERT_ARGS(maybe_throw_overflow_error) /* check to see what the behavior is. If the interpreter is set to throw an exception on overflow. If so, throw the exception, otherwise, chill out it's no big deal. */ if (PARROT_ERRORS_test(interp, PARROT_ERRORS_OVERFLOW_FLAG)) Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_ERR_OVERFLOW, "Integer overflow"); } /* =item C Returns a pointer of *self upgraded to a bignum =cut */ PARROT_IGNORABLE_RESULT PARROT_CANNOT_RETURN_NULL static PMC* upgrade_self_to_bignum(PARROT_INTERP, ARGMOD(PMC *self)) { ASSERT_ARGS(upgrade_self_to_bignum) /* Do an in-place upgrade to a Bignum of SELF and return a pointer to it (which is probably redundant, but whatever). */ const INTVAL a = VTABLE_get_integer(interp, self); Parrot_pmc_reuse(interp, self, enum_class_BigInt, 0); VTABLE_set_integer_native(interp, self, a); return self; } pmclass Integer extends scalar provides integer provides scalar auto_attrs { ATTR INTVAL iv; /* the value of this Integer */ /* =item C Create a new Integer with arguments passed according to pdd03. =item C Initializes the integer with a default value of C<0>. =cut */ VTABLE void init() { Parrot_Integer_attributes * const attrs = (Parrot_Integer_attributes *)PMC_data(SELF); attrs->iv = 0; } VTABLE void init_pmc(PMC *init) { Parrot_Integer_attributes * const attrs = (Parrot_Integer_attributes *)PMC_data(SELF); attrs->iv = VTABLE_get_integer(INTERP, init); } VTABLE void init_int(INTVAL init) { Parrot_Integer_attributes * const attrs = (Parrot_Integer_attributes *)PMC_data(SELF); attrs->iv = init; } /* =item C Creates an exact duplicate of this PMC. =cut */ VTABLE PMC *clone() :no_wb { PMC * ret = Parrot_pmc_new_init_int(INTERP, SELF->vtable->base_type, SELF.get_integer()); return ret; } /* =item C Return the memory address of an Integer PMC. This is needed for certain NCI applications and may be disabled in certain security contexts. =cut */ VTABLE void *get_pointer() :no_wb { UNUSED(INTERP) return &(PARROT_INTEGER(SELF)->iv); } /* =item C Sets the value of the integer to the value in C<*value>. =cut */ VTABLE void set_pmc(PMC *value) :manual_wb { SELF.set_integer_native(VTABLE_get_integer(INTERP, value)); } /* =item C Sets this PMC as shared and read-only. =cut */ VTABLE void share() :no_wb { /* * assume that the access to a long is atomic. * integers are most often (1) equal to C longs, * not C ints, and this makes a difference in 64-bit * platforms where longs are 64-bit but ints are 32-bit. * (1) Not equal when integers have been configured * to be software-emulated long longs. */ if (sizeof (INTVAL) != sizeof (long)) SUPER(); } /* =item C Returns the integer value of the Integer. =cut */ VTABLE INTVAL get_integer() :no_wb { INTVAL iv; GET_ATTR_iv(INTERP, SELF, iv); return iv; } /* =item C Returns the boolean value of the Integer. =cut */ VTABLE INTVAL get_bool() :no_wb { INTVAL iv; GET_ATTR_iv(INTERP, SELF, iv); return iv ? 1 : 0; } /* =item C Returns the floating-point value of the integer. =cut */ VTABLE FLOATVAL get_number() :no_wb { INTVAL iv; GET_ATTR_iv(INTERP, SELF, iv); return (FLOATVAL)iv; } /* =item C =item C Returns the string value of the integer. =cut */ VTABLE STRING *get_string() :no_wb { return Parrot_str_from_int(INTERP, SELF.get_integer()); } VTABLE STRING *get_repr() :no_wb { return Parrot_str_from_int(INTERP, SELF.get_integer()); } /* =item C Sets the value of the integer to the value of the native integer C<*value>. =cut */ VTABLE void set_integer_native(INTVAL value) { SET_ATTR_iv(INTERP, SELF, value); } /* =item C Morphs the integer to a C and sets the value from C. =item C Morphs the integer to a C and sets the value from C. =item C Morphs the integer to a C and sets the value from C. =cut */ VTABLE void set_number_native(FLOATVAL value) :manual_wb { Parrot_pmc_reuse(INTERP, SELF, Parrot_hll_get_ctx_HLL_type(INTERP, enum_class_Float), 0); SELF.set_number_native(value); } VTABLE void set_bool(INTVAL value) :manual_wb { Parrot_pmc_reuse(INTERP, SELF, Parrot_hll_get_ctx_HLL_type(INTERP, enum_class_Boolean), 0); SELF.set_bool(value); } VTABLE void set_string_native(STRING *value) :manual_wb { Parrot_pmc_reuse(INTERP, SELF, Parrot_hll_get_ctx_HLL_type(INTERP, enum_class_String), 0); SELF.set_string_native(value); } /* =item C =item C Adds C to the integer and returns the result in C<*dest>. =cut */ MULTI PMC *add(Integer value, PMC *dest) :no_wb { const INTVAL a = SELF.get_integer(); const INTVAL b = VTABLE_get_integer(INTERP, value); const INTVAL c = a + b; if ((c^a) >= 0 || (c^b) >= 0) return Parrot_pmc_new_init_int(INTERP, VTABLE_type(INTERP, SELF), c); else { PMC *temp; maybe_throw_overflow_error(INTERP); temp = Parrot_pmc_new_init_int(INTERP, enum_class_BigInt, a); return VTABLE_add(INTERP, temp, value, dest); } } MULTI PMC *add(Complex value, PMC *dest) :no_wb { const INTVAL a = SELF.get_integer(); dest = Parrot_pmc_new_init_int(INTERP, VTABLE_type(INTERP, value), a + VTABLE_get_number_keyed_int(INTERP, value, 0)); VTABLE_set_number_keyed_int(INTERP, dest, 1, VTABLE_get_number_keyed_int(INTERP, value, 1)); return dest; } MULTI PMC *add(BigInt value, PMC *dest) :no_wb { PMC *temp; maybe_throw_overflow_error(INTERP); temp = Parrot_pmc_new_init_int(INTERP, enum_class_BigInt, SELF.get_integer()); return VTABLE_add(INTERP, temp, value, dest); } MULTI PMC *add(DEFAULT value, PMC *dest) :no_wb { dest = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, value)); VTABLE_set_number_native(INTERP, dest, SELF.get_integer() + VTABLE_get_number(interp, value)); return dest; } VTABLE PMC *add_int(INTVAL b, PMC *dest) :no_wb { const INTVAL a = VTABLE_get_integer(INTERP, SELF); const INTVAL c = a + b; if ((c^a) >= 0 || (c^b) >= 0) return Parrot_pmc_new_init_int(INTERP, VTABLE_type(INTERP, SELF), c); else { PMC *temp; maybe_throw_overflow_error(INTERP); temp = Parrot_pmc_new_init_int(INTERP, enum_class_BigInt, a); return VTABLE_add_int(INTERP, temp, b, dest); } } /* =item C =item C =item C Adds C to C inplace. =cut */ MULTI void i_add(Integer value) :manual_wb { STATICSELF.i_add_int(VTABLE_get_integer(INTERP, value)); } MULTI void i_add(Complex value) :manual_wb { Parrot_pmc_reuse(INTERP, SELF, enum_class_Complex, 0); VTABLE_set_number_native(INTERP, SELF, SELF.get_integer() + VTABLE_get_number(INTERP, value)); } MULTI void i_add(DEFAULT value) :manual_wb { VTABLE_set_number_native(INTERP, SELF, SELF.get_integer() + VTABLE_get_number(INTERP, value)); } VTABLE void i_add_int(INTVAL b) :manual_wb { const INTVAL a = SELF.get_integer(); const INTVAL c = a + b; if ((c^a) >= 0 || (c^b) >= 0) VTABLE_set_integer_native(INTERP, SELF, c); else { maybe_throw_overflow_error(INTERP); SELF = upgrade_self_to_bignum(INTERP, SELF); VTABLE_i_add_int(INTERP, SELF, b); } } VTABLE void i_add_float(FLOATVAL value) :manual_wb { const INTVAL a = SELF.get_integer(); VTABLE_set_number_native(INTERP, SELF, a + value); } /* =item C Subtracts C<*value> from the integer and returns the result in C<*dest>. If C is NULL, a PMC of this type. Please note: as C or C maybe be subclassed, we have to call C and C always. =cut */ MULTI PMC *subtract(Integer value, PMC *dest) :no_wb { const INTVAL a = SELF.get_integer(); const INTVAL b = VTABLE_get_integer(INTERP, value); const INTVAL c = a - b; if ((c^a) >= 0 || (c^~b) >= 0) return Parrot_pmc_new_init_int(INTERP, VTABLE_type(INTERP, SELF), c); else { PMC *temp; maybe_throw_overflow_error(INTERP); temp = Parrot_pmc_new_init_int(INTERP, enum_class_BigInt, a); return VTABLE_subtract(INTERP, temp, value, dest); } } MULTI PMC *subtract(Complex value, PMC *dest) :no_wb { const INTVAL a = SELF.get_integer(); dest = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, value)); VTABLE_set_number_native(INTERP, dest, a - VTABLE_get_number_keyed_int(INTERP, value, 0)); VTABLE_set_number_keyed_int(INTERP, dest, 1, -VTABLE_get_number_keyed_int(INTERP, value, 1)); return dest; } MULTI PMC *subtract(BigInt value, PMC *dest) :no_wb { PMC *temp; maybe_throw_overflow_error(INTERP); temp = Parrot_pmc_new_init_int(INTERP, enum_class_BigInt, SELF.get_integer()); return VTABLE_subtract(INTERP, temp, value, dest); } MULTI PMC *subtract(DEFAULT value, PMC *dest) :no_wb { dest = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, value)); VTABLE_set_number_native(INTERP, dest, SELF.get_integer() - VTABLE_get_number(INTERP, value)); return dest; } /* =item C Subtracts C from the integer and returns the result in C<*dest>. =cut */ VTABLE PMC *subtract_int(INTVAL b, PMC *dest) :no_wb { const INTVAL a = SELF.get_integer(); const INTVAL c = a - b; if ((c^a) >= 0 || (c^~b) >= 0) return Parrot_pmc_new_init_int(INTERP, VTABLE_type(INTERP, SELF), c); else { PMC *temp; maybe_throw_overflow_error(INTERP); temp = Parrot_pmc_new_init_int(INTERP, enum_class_BigInt, a); return VTABLE_subtract_int(INTERP, temp, b, dest); } } /* =item C =item C =item C Subtracts C from C inplace. =cut */ MULTI void i_subtract(Integer value) :manual_wb { const INTVAL a = SELF.get_integer(); const INTVAL b = VTABLE_get_integer(INTERP, value); const INTVAL c = a - b; if ((c^a) >= 0 || (c^~b) >= 0) VTABLE_set_integer_native(INTERP, SELF, c); else { maybe_throw_overflow_error(INTERP); SELF = upgrade_self_to_bignum(INTERP, SELF); VTABLE_i_subtract(INTERP, SELF, value); } } MULTI void i_subtract(Complex value) :manual_wb { const INTVAL a = SELF.get_integer(); Parrot_pmc_reuse(INTERP, SELF, enum_class_Complex, 0); VTABLE_set_number_native(INTERP, SELF, (FLOATVAL)a - VTABLE_get_number_keyed_int(INTERP, value, 0)); VTABLE_set_number_keyed_int(INTERP, SELF, 1, -VTABLE_get_number_keyed_int(INTERP, value, 1)); } MULTI void i_subtract(DEFAULT value) :manual_wb { VTABLE_set_number_native(INTERP, SELF, SELF.get_integer() - VTABLE_get_number(INTERP, value)); } VTABLE void i_subtract_int(INTVAL b) :manual_wb { const INTVAL a = SELF.get_integer(); const INTVAL c = a - b; if ((c^a) >= 0 || (c^~b) >= 0) VTABLE_set_integer_native(INTERP, SELF, c); else { maybe_throw_overflow_error(INTERP); SELF = upgrade_self_to_bignum(INTERP, SELF); VTABLE_i_subtract_int(INTERP, SELF, b); } } VTABLE void i_subtract_float(FLOATVAL value) :manual_wb { const INTVAL a = SELF.get_integer(); VTABLE_set_number_native(INTERP, SELF, a - value); } /* =item C =item C Multiplies the integer by C<*value> and returns the result in C<*dest>. =cut */ MULTI PMC *multiply(Integer value, PMC *dest) :no_wb { const INTVAL a = VTABLE_get_integer(INTERP, SELF); const INTVAL b = VTABLE_get_integer(INTERP, value); const INTVAL c = a * b; const double cf = (double)a * (double)b; if ((double) c == cf) return Parrot_pmc_new_init_int(INTERP, VTABLE_type(INTERP, SELF), c); else { PMC *temp; maybe_throw_overflow_error(INTERP); temp = Parrot_pmc_new_init_int(INTERP, enum_class_BigInt, a); return VTABLE_multiply(INTERP, temp, value, dest); } } MULTI PMC *multiply(Complex value, PMC *dest) :no_wb { return VTABLE_multiply(INTERP, value, SELF, dest); } MULTI PMC *multiply(BigInt value, PMC *dest) :no_wb { return VTABLE_multiply_int(INTERP, value, SELF.get_integer(), dest); } MULTI PMC *multiply(String value, PMC *dest) :no_wb { return Parrot_Integer_multi_multiply_Integer_PMC(INTERP, SELF, value, dest); } MULTI PMC *multiply(DEFAULT value, PMC *dest) :no_wb { const FLOATVAL valf = VTABLE_get_number(INTERP, value); UNUSED(dest) return Parrot_pmc_new_init_int(INTERP, VTABLE_type(INTERP, SELF), SELF.get_number() * valf); } VTABLE PMC *multiply_int(INTVAL b, PMC *dest) :no_wb { const INTVAL a = SELF.get_integer(); const INTVAL c = a * b; const double cf = (double)a * (double)b; if ((double) c == cf) return Parrot_pmc_new_init_int(INTERP, VTABLE_type(INTERP, SELF), c); else { PMC *temp; maybe_throw_overflow_error(INTERP); temp = Parrot_pmc_new_init_int(INTERP, enum_class_BigInt, a); return VTABLE_multiply_int(INTERP, temp, b, dest); } } /* =item C =item C =item C Multiply C with C inplace. =cut */ VTABLE void i_multiply(PMC * value) :manual_wb { /* VTABLE_i_multiply_int(INTERP, SELF, VTABLE_get_integer(INTERP, value)); */ VTABLE_set_number_native(INTERP, SELF, SELF.get_integer() * VTABLE_get_number(INTERP, value)); } VTABLE void i_multiply_int(INTVAL b) :manual_wb { const INTVAL a = SELF.get_integer(); const INTVAL c = a * b; const double cf = (double)a * (double)b; if ((double) c == cf) SELF.set_integer_native(c); else { maybe_throw_overflow_error(INTERP); upgrade_self_to_bignum(INTERP, SELF); VTABLE_i_multiply_int(INTERP, SELF, b); } } VTABLE void i_multiply_float(FLOATVAL value) :manual_wb { const INTVAL a = SELF.get_integer(); VTABLE_set_number_native(INTERP, SELF, a * value); } /* =item C =item C =item C Divides the number by C and returns the result in C<*dest>. =item C =item C =item C Divides C by C inplace. =cut */ MULTI PMC *divide(BigInt value, PMC *dest) :no_wb { PMC *temp; maybe_throw_overflow_error(INTERP); temp = Parrot_pmc_new_init_int(INTERP, enum_class_BigInt, SELF.get_integer()); return VTABLE_divide(INTERP, temp, value, dest); } MULTI PMC *divide(DEFAULT value, PMC *dest) :no_wb { const FLOATVAL d = VTABLE_get_number(INTERP, value); UNUSED(dest) if (FLOAT_IS_ZERO(d)) Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_DIV_BY_ZERO, "float division by zero"); return Parrot_pmc_new_init_int(INTERP, VTABLE_type(INTERP, SELF), SELF.get_number() / d); } MULTI void i_divide(BigInt value) :manual_wb { maybe_throw_overflow_error(INTERP); SELF = upgrade_self_to_bignum(INTERP, SELF); VTABLE_i_divide(INTERP, SELF, value); } MULTI void i_divide(DEFAULT value) :manual_wb { const FLOATVAL d = VTABLE_get_number(INTERP, value); if (FLOAT_IS_ZERO(d)) Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_DIV_BY_ZERO, "float division by zero"); VTABLE_set_number_native(INTERP, SELF, SELF.get_number() / d); } /* =item C =item C =item C Divides the number by C and returns the result in C<*dest>. =item C =item C =item C Divides C by C inplace. =cut */ MULTI PMC *floor_divide(BigInt value, PMC *dest) :no_wb { PMC *temp; maybe_throw_overflow_error(INTERP); temp = Parrot_pmc_new_init_int(INTERP, enum_class_BigInt, SELF.get_integer()); return VTABLE_floor_divide(INTERP, temp, value, dest); } MULTI PMC *floor_divide(DEFAULT value, PMC *dest) :no_wb { const FLOATVAL d = VTABLE_get_number(INTERP, value); FLOATVAL f; UNUSED(dest) if (FLOAT_IS_ZERO(d)) Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_DIV_BY_ZERO, "float division by zero"); f = floor(SELF.get_number() / d); return Parrot_pmc_new_init_int(INTERP, VTABLE_type(INTERP, SELF), (INTVAL)f); } VTABLE PMC *floor_divide_int(INTVAL value, PMC *dest) :no_wb { UNUSED(dest) FLOATVAL f; if (value == 0) Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_DIV_BY_ZERO, "float division by zero"); f = floor(SELF.get_number() / value); return Parrot_pmc_new_init_int(INTERP, VTABLE_type(INTERP, SELF), (INTVAL)f); } VTABLE PMC *floor_divide_float(FLOATVAL value, PMC *dest) :no_wb { UNUSED(dest) FLOATVAL f; if (FLOAT_IS_ZERO(value)) Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_DIV_BY_ZERO, "float division by zero"); f = floor(SELF.get_number() / value); return Parrot_pmc_new_init_int(INTERP, VTABLE_type(INTERP, SELF), (INTVAL)f); } MULTI void i_floor_divide(BigInt value) :manual_wb { maybe_throw_overflow_error(INTERP); SELF = upgrade_self_to_bignum(INTERP, SELF); VTABLE_i_floor_divide(INTERP, SELF, value); } MULTI void i_floor_divide(DEFAULT value) :manual_wb { const FLOATVAL d = VTABLE_get_number(INTERP, value); FLOATVAL f; if (FLOAT_IS_ZERO(d)) Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_DIV_BY_ZERO, "float division by zero"); f = floor(SELF.get_number() / d); VTABLE_set_integer_native(INTERP, SELF, (INTVAL)f); } VTABLE void i_floor_divide_int(INTVAL value) :manual_wb { FLOATVAL f; if (value == 0) Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_DIV_BY_ZERO, "float division by zero"); f = floor(SELF.get_number() / value); VTABLE_set_integer_native(INTERP, SELF, (INTVAL)f); } VTABLE void i_floor_divide_float(FLOATVAL value) :manual_wb { FLOATVAL f; if (FLOAT_IS_ZERO(value)) Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_DIV_BY_ZERO, "float division by zero"); f = floor(SELF.get_number() / value); VTABLE_set_integer_native(INTERP, SELF, (INTVAL)f); } /* =item C =item C =item C Calculates the value of corrected C C and returns the result in C. See also ops/math.ops. =item C =item C =item C Calculates modulus in place. =cut */ MULTI PMC *modulus(BigInt value, PMC *dest) :no_wb { PMC *temp; maybe_throw_overflow_error(INTERP); temp = Parrot_pmc_new_init_int(INTERP, enum_class_BigInt, SELF.get_integer()); return VTABLE_modulus(INTERP, temp, value, dest); } MULTI PMC *modulus(DEFAULT value, PMC *dest) :no_wb { UNUSED(dest) const INTVAL d = VTABLE_get_integer(INTERP, value); if (d == 0) Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_DIV_BY_ZERO, "int modulus by zero"); return Parrot_pmc_new_init_int(INTERP, VTABLE_type(INTERP, SELF), Parrot_util_intval_mod(SELF.get_integer(), d)); } VTABLE PMC *modulus_int(INTVAL value, PMC *dest) :no_wb { UNUSED(dest) if (value == 0) Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_DIV_BY_ZERO, "int modulus by zero"); return Parrot_pmc_new_init_int(INTERP, VTABLE_type(INTERP, SELF), Parrot_util_intval_mod(SELF.get_integer(), value)); } VTABLE PMC *modulus_float(FLOATVAL value, PMC *dest) :no_wb { UNUSED(dest) if (FLOAT_IS_ZERO(value)) Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_DIV_BY_ZERO, "int modulus by zero"); return Parrot_pmc_new_init_int(INTERP, VTABLE_type(INTERP, SELF), Parrot_util_intval_mod(SELF.get_integer(), (INTVAL)value)); } MULTI void i_modulus(BigInt value) :manual_wb { maybe_throw_overflow_error(INTERP); SELF = upgrade_self_to_bignum(INTERP, SELF); VTABLE_i_modulus(INTERP, SELF, value); } MULTI void i_modulus(DEFAULT value) :manual_wb { const INTVAL d = VTABLE_get_integer(INTERP, value); if (d == 0) Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_DIV_BY_ZERO, "int modulus by zero"); VTABLE_set_integer_native(INTERP, SELF, Parrot_util_intval_mod(SELF.get_integer(), d)); } VTABLE void i_modulus_int(INTVAL value) :manual_wb { if (value == 0) Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_DIV_BY_ZERO, "int modulus by zero"); VTABLE_set_integer_native(INTERP, SELF, Parrot_util_intval_mod(SELF.get_integer(), value)); } VTABLE void i_modulus_float(FLOATVAL value) :manual_wb { if (FLOAT_IS_ZERO(value)) Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_DIV_BY_ZERO, "int modulus by zero"); VTABLE_set_integer_native(INTERP, SELF, Parrot_util_intval_mod(SELF.get_integer(), (INTVAL)value)); } /* =item C =item C Set C to the negated value of C. If the value of C is the minimum integer, a BigInt is created. =cut */ VTABLE PMC *neg(PMC *dest) :no_wb { UNUSED(dest) const INTVAL a = SELF.get_integer(); if (a != PARROT_INTVAL_MIN) return Parrot_pmc_new_init_int(INTERP, VTABLE_type(INTERP, SELF), -a); else { PMC *promoted; maybe_throw_overflow_error(INTERP); promoted = Parrot_pmc_new_init_int(INTERP, enum_class_BigInt, 0); return VTABLE_subtract_int(INTERP, promoted, a, promoted); } } VTABLE void i_neg() :manual_wb { const INTVAL a = SELF.get_integer(); if (a != PARROT_INTVAL_MIN) VTABLE_set_integer_native(INTERP, SELF, -a); else { maybe_throw_overflow_error(INTERP); SELF = upgrade_self_to_bignum(INTERP, SELF); VTABLE_set_integer_native(INTERP, SELF, 0); VTABLE_i_subtract_int(INTERP, SELF, a); } } /* =item C The C<==> operation. =cut */ VTABLE INTVAL is_equal(PMC *value) :no_wb { INTVAL retval; switch (value->vtable->base_type) { case enum_class_BigInt: { PMC const *temp = Parrot_pmc_new_init_int(INTERP, enum_class_BigInt, SELF.get_integer()); Parrot_mmd_multi_dispatch_from_c_args(INTERP, "is_equal", "PP->I", temp, value, &retval); return retval; } break; default: return (VTABLE_get_integer(INTERP, SELF) == VTABLE_get_integer(INTERP, value)); break; } } /* =item C Returns the result of comparing the integer with C<*value>. =cut */ MULTI INTVAL cmp(String value) :no_wb { INTVAL iv; GET_ATTR_iv(INTERP, SELF, iv); { const FLOATVAL fdiff = (FLOATVAL)iv - VTABLE_get_number(INTERP, value); if (FLOAT_IS_ZERO(fdiff)) { const INTVAL idiff = SELF.get_integer() - VTABLE_get_integer(INTERP, value); return idiff > 0 ? 1 : idiff < 0 ? -1 : 0; } return fdiff > 0 ? 1 : -1; } } MULTI INTVAL cmp(Float value) :no_wb { INTVAL iv; GET_ATTR_iv(INTERP, SELF, iv); { const FLOATVAL diff = (FLOATVAL)iv - VTABLE_get_number(INTERP, value); return diff > 0 ? 1 : diff < 0 ? -1 : 0; } } MULTI INTVAL cmp(DEFAULT value) :no_wb { /* int or undef */ INTVAL selfint; GET_ATTR_iv(INTERP, SELF, selfint); { const INTVAL valueint = VTABLE_get_integer(INTERP, value); return selfint > valueint ? 1 : selfint < valueint ? -1 : 0; } } /* =item C Returns the result of numerically comparing the integer with C<*value>. =cut */ MULTI INTVAL cmp_num(String value) :no_wb { const FLOATVAL fdiff = SELF.get_number() - VTABLE_get_number(INTERP, value); if (FLOAT_IS_ZERO(fdiff)) { const INTVAL idiff = SELF.get_integer() - VTABLE_get_integer(INTERP, value); return idiff > 0 ? 1 : idiff < 0 ? -1 : 0; } return fdiff > 0 ? 1 : -1; } MULTI INTVAL cmp_num(Float value) :no_wb { const FLOATVAL diff = SELF.get_number() - VTABLE_get_number(INTERP, value); return diff > 0 ? 1 : diff < 0 ? -1 : 0; } MULTI INTVAL cmp_num(DEFAULT value) :no_wb { /* int or undef */ const INTVAL diff = SELF.get_integer() - VTABLE_get_integer(INTERP, value); return diff > 0 ? 1 : diff < 0 ? -1 : 0; } /* =item C Increments the integer. =cut */ VTABLE void increment() :manual_wb { INTVAL volatile a; /* clang -O3 was too aggressive here [GH #774] */ INTVAL volatile c; GET_ATTR_iv(INTERP, SELF, a); c = a + 1; /* did not overflow */ if ((c^a) >= 0 || (c^1) >= 0) { SET_ATTR_iv(INTERP, SELF, c); PARROT_GC_WRITE_BARRIER(INTERP, SELF); } else { Parrot_pmc_reuse(INTERP, SELF, enum_class_BigInt, 0); VTABLE_set_integer_native(INTERP, SELF, a); VTABLE_increment(INTERP, SELF); } } /* =item C Decrements the integer. =cut */ VTABLE void decrement() :manual_wb { const INTVAL a = SELF.get_integer(); const INTVAL c = a - 1; if ((c^a) >= 0 || (c^~1) >= 0) { VTABLE_set_integer_native(INTERP, SELF, c); } else { Parrot_pmc_reuse(INTERP, SELF, enum_class_BigInt, 0); VTABLE_set_integer_native(INTERP, SELF, a); VTABLE_decrement(INTERP, SELF); } } /* =item C =item C Sets C to the absolute value of C. If the value of C is the minimum integer, a BigInt is created. =cut */ VTABLE PMC *absolute(PMC *dest) :no_wb { const INTVAL a = SELF.get_integer(); if (a != PARROT_INTVAL_MIN) return Parrot_pmc_new_init_int(INTERP, VTABLE_type(INTERP, SELF), abs(a)); else { PMC *promoted; maybe_throw_overflow_error(INTERP); promoted = Parrot_pmc_new_init_int(INTERP, enum_class_BigInt, a); return VTABLE_neg(INTERP, promoted, dest); } } VTABLE void i_absolute() :manual_wb { const INTVAL a = SELF.get_integer(); if (a != PARROT_INTVAL_MIN) VTABLE_set_integer_native(INTERP, SELF, abs(a)); else { maybe_throw_overflow_error(INTERP); SELF = upgrade_self_to_bignum(INTERP, SELF); VTABLE_i_neg(INTERP, SELF); } } /* =item C Converts and returns the integer in base C. C must be between 2 and 36, inclusive. =cut */ METHOD get_as_base(INTVAL base) :no_wb { char buf[128]; STRING *result; if ((base < 2) || (base > 36)) Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_OUT_OF_BOUNDS, "get_as_base: base out of bounds"); result = Parrot_str_from_int_base(INTERP, buf, (HUGEINTVAL)VTABLE_get_integer(INTERP, SELF), (unsigned int)base); RETURN(STRING *result); } /* =item C Used to archive the integer. =cut */ VTABLE void freeze(PMC *info) :no_wb { SUPER(info); VTABLE_push_integer(INTERP, info, SELF.get_integer()); } /* =item C Used to unarchive the integer. =cut */ VTABLE void thaw(PMC *info) :manual_wb { SUPER(info); SELF.set_integer_native(VTABLE_shift_integer(INTERP, info)); } /* =item C Set to a random value. SELF.set_random() # value from [INTVAL_MIN..INTVAL_MAX] SELF.set_random(0) # same SELF.set_random(a) # value from [0..a] or [a..0] if a is negative SELF.set_random(a, b) # value from [a..b] (b > a) =cut */ METHOD set_random(INTVAL a :optional, INTVAL has_a :opt_flag, INTVAL b :optional, INTVAL has_b :opt_flag) :manual_wb { INTVAL r; if (has_a && a != 0) { if (!has_b) { if (a < 0) b = 0; if (a > 0) { b = a; a = 0; } } if (a == b || a > b) { Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_OUT_OF_BOUNDS, "set_random: range start must be less than range end (%d, %d)", a, b); } { const double spread = (double)(b - a + 1); const double randpart = Parrot_util_float_rand(0); r = a + (INTVAL)(spread * randpart); } } else r = Parrot_util_int_rand(0); SELF.set_integer_native(r); } } /* =back =cut */ /* * Local variables: * c-file-style: "parrot" * End: * vim: expandtab shiftwidth=4 cinoptions='\:2=2' : */ nci_thunk_gen.t000644000765000765 213212101554067 16646 0ustar00bruce000000000000parrot-6.6.0/t/tools/dev#! perl # Copyright (C) 2013, Parrot Foundation. use strict; use warnings; use lib qw(lib); use Test::More tests => 2; use Parrot::Config; my ($cc, $cc_inc, $ccflags, $cc_warn, $cc_o_out, $cc_shared, $cc_debug, $clock_best) = @PConfig{qw(cc cc_inc ccflags ccwarn cc_o_out cc_shared cc_debug clock_best)}; my $cflags = "$cc_inc $ccflags $cc_debug $clock_best $cc_shared"; my $cmd = q(echo "p v"|./parrot tools/dev/nci_thunk_gen.pir --output=test_nci.c); system ($cmd); ok (-f "test_nci.c", "test_nci.c created") or diag $cmd; $cmd = qq($cc $cflags $cc_warn -I. -Isrc ${cc_o_out}test_nci.o -c test_nci.c); system ($cmd); ok (-f "test_nci.o", "test_nci.o created") or diag $cmd; unlink ("test_nci.*"); __END__ =head1 NAME t/tools/dev/nci_thunk_gen.t - test bugs in tools/dev/nci_thunk_gen.pir =head1 SYNOPSIS % prove t/tools/dev/nci_thunk_gen.t =head1 DESCRIPTION Test basic F usage. Test that the sig "p v" compiles to valid C code [GH #904]. =cut # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: 64bit.t000644000765000765 344011533177644 13500 0ustar00bruce000000000000parrot-6.6.0/t/op#!./parrot # Copyright (C) 2001-2010, Parrot Foundation. =head1 NAME t/op/64bit.t - Testing integer ops on 64-bit platforms =head1 SYNOPSIS % prove t/op/64bit.t =head1 DESCRIPTION Test integer operations on platforms with 64-bit integers. Tests are skipped on other platforms. =cut .sub main :main .include "iglobals.pasm" .include 'test_more.pir' # Check to see if this is 64 bit .local pmc interp # a handle to our interpreter object. interp = getinterp .local pmc config config = interp[.IGLOBALS_CONFIG_HASH] .local int intvalsize intvalsize = config['intvalsize'] plan(5) if intvalsize == 8 goto is_64_bit skip(5, "this is not a 64 bit platform") goto end is_64_bit: # setup TODO for platform 'MSWin32' .local string osname osname = config['osname'] .local int todo_1 todo_1 = 0 unless osname == "MSWin32" goto do_test todo_1 = 1 do_test: bitops64(todo_1) end: .end .sub bitops64 # check bitops for 8-byte ints .param int todo_1 set $I0, 0xffffffffffffffff if todo_1 goto do_todo is( $I0, -1, 'bitops64' ) goto test_2 do_todo: if $I0 == -1 goto todo_pass todo ( 0, 'bitops64', 'not working on MSWin32, amd64' ) goto test_2 todo_pass: todo ( 1, 'bitops64', 'not working on MSWin32, amd64' ) test_2: set $I1, 0x00000000ffffffff is( $I1, 4294967295, 'bitops64' ) set $I0, $I1 shl $I0, $I0, 32 is( $I0, -4294967296, 'bitops64' ) band $I2, $I0, $I1 is( $I2, 0, 'bitops64' ) bor $I2, $I0, $I1 is( $I2, -1, 'bitops64' ) .end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: opengl.pm000644000765000765 11427512346145241 15402 0ustar00bruce000000000000parrot-6.6.0/config/gen# Copyright (C) 2008-2014, Parrot Foundation. =head1 NAME config/gen/opengl.pm - OpenGL binding generated files =head1 DESCRIPTION Generates several files used by the OpenGL binding. These include: =over 4 =item F =item F =item F =item F =back For information about Parrot's OpenGL support on different platforms, and system libraries/headers that must be installed to enable OpenGL support, see F, where this support is detected. For information on how to I Parrot's OpenGL support, see F for an overview, or the OpenGL examples starting with F for more detail. =begin ignored =cut package gen::opengl; use strict; use warnings; use File::Basename; use File::Glob; use File::Which; use base qw(Parrot::Configure::Step); use Parrot::Configure::Utils ':gen'; # taken from List::MoreUtils sub any { my $f = shift; return if ! @_; for (@_) { return 1 if $f->(); } return 0; } my @GLUT_1_CALLBACKS = ( [ 'Display', 'void' ], [ 'Idle', 'void' ], [ 'Entry', 'int state' ], [ 'Menu State', 'int status' ], [ 'Visibility', 'int state' ], [ 'Motion', 'int x, int y' ], [ 'Passive Motion', 'int x, int y' ], [ 'Reshape', 'int width, int height' ], [ 'Keyboard', 'unsigned char key, int x, int y' ], [ 'Mouse', 'int button, int state, int x, int y' ], # NOTE: Hardcoded because of special arguments # [ 'Timer', 'int data' ], ); my @GLUT_2_CALLBACKS = ( [ 'Button Box', 'int button, int state' ], [ 'Dials', 'int dial, int value' ], [ 'Spaceball Button', 'int button, int state' ], [ 'Tablet Motion', 'int x, int y' ], [ 'Spaceball Motion', 'int x, int y, int z' ], [ 'Spaceball Rotate', 'int x, int y, int z' ], [ 'Special', 'int key, int x, int y' ], [ 'Tablet Button', 'int button, int state, int x, int y' ], ); my @GLUT_3_CALLBACKS = ( [ 'Overlay Display', 'void' ], [ 'Menu Status', 'int status, int x, int y' ], ); my @GLUT_4_CALLBACKS = ( [ 'Window Status', 'int state' ], [ 'Keyboard Up', 'unsigned char key, int x, int y' ], [ 'Special Up', 'int key, int x, int y' ], # NOTE: Hardcoded because of special arguments # [ 'Joystick', 'int buttons, int xaxis, int yaxis, int zaxis' ], ); my @MACOSXGLUT_CALLBACKS = ( # Also works in freeglut [ 'WM Close', 'void' ], ); my @FREEGLUT_CALLBACKS = ( [ 'Close', 'void' ], [ 'Menu Destroy', 'void' ], [ 'Mouse Wheel', 'int wheel, int direction, int x, int y' ], ); # These typemaps try to be both portable and accurate. However, there is # at least one OS release known to get some of these wrong: Mac OS X 10.4 # headers typedef some of the 'int' types as 'long' instead. This disagrees # with all other headers I can find, and was fixed in Mac OS X 10.5 -- those # typedefs now match accepted standards. I am told that Mac OS X 10.4 has # a 32-bit core, making the difference immaterial, so I don't bother to # alter the typemaps to fit this bug. my %C_TYPE = ( VOID => 'void', GLvoid => 'void', GLUnurbs => 'void', GLUquadric => 'void', GLUtesselator => 'void', gleGC => 'void', muiObject => 'void', SphereMap => 'void', Display => 'void', XVisualInfo => 'void', GLEWContext => 'void', GLXEWContext => 'void', WGLEWContext => 'void', _CGLContextObject => 'void', CGDirectDisplayID => 'void', GLXHyperpipeConfigSGIX => 'void', GLXHyperpipeNetworkSGIX => 'void', PIXELFORMATDESCRIPTOR => 'void', COLORREF => 'void', wchar_t => 'void', GLCchar => 'void', GLMfunctions => 'void*', GLXContext => 'void*', GLXFBConfig => 'void*', GLXFBConfigSGIX => 'void*', CGLContextObj => 'void*', CGLPixelFormatObj => 'void*', CGLRendererInfoObj => 'void*', CGLPBufferObj => 'void*', AGLContext => 'void*', AGLDevice => 'void*', AGLDrawable => 'void*', AGLPixelFormat => 'void*', AGLRendererInfo => 'void*', AGLPbuffer => 'void*', GDHandle => 'void*', IOSurfaceRef => 'void*', WindowRef => 'void*', HIViewRef => 'void*', Style => 'void*', HANDLE => 'void*', HPBUFFERARB => 'void*', HPBUFFEREXT => 'void*', HVIDEOINPUTDEVICENV => 'void*', HVIDEOOUTPUTDEVICENV => 'void*', HPVIDEODEV => 'void*', HPGPUNV => 'void*', HGPUNV => 'void*', HDC => 'void*', HGLRC => 'void*', LPGLYPHMETRICSFLOAT => 'void*', LPLAYERPLANEDESCRIPTOR => 'void*', LPPIXELFORMATDESCRIPTOR => 'void*', LPVOID => 'void*', PGPU_DEVICE => 'void*', GLsync => 'void*', GLchar => 'char', GLcharARB => 'char', GLbyte => 'signed char', GLubyte => 'unsigned char', GLboolean => 'unsigned char', GLshort => 'short', USHORT => 'unsigned short', GLushort => 'unsigned short', GLhalfARB => 'unsigned short', GLhalfNV => 'unsigned short', BOOL => 'int', Bool => 'int', Status => 'int', GLint => 'int', GLsizei => 'int', GLfixed => 'int', GLclampx => 'int', int32_t => 'int', INT32 => 'int', INT => 'int', GLenum => 'unsigned int', GLCenum => 'unsigned int', CGLPixelFormatAttribute => 'unsigned int', CGLRendererProperty => 'unsigned int', CGLContextEnable => 'unsigned int', CGLContextParameter => 'unsigned int', CGLGlobalOption => 'unsigned int', CGLError => 'unsigned int', SphereMapFlags => 'unsigned int', UINT => 'unsigned int', GLuint => 'unsigned int', GLbitfield => 'unsigned int', GLhandleARB => 'unsigned int', GLXVideoDeviceNV => 'unsigned int', DWORD => 'unsigned long', GLulong => 'unsigned long', XID => 'unsigned long', Window => 'unsigned long', Drawable => 'unsigned long', Font => 'unsigned long', Pixmap => 'unsigned long', Cursor => 'unsigned long', Colormap => 'unsigned long', GContext => 'unsigned long', KeySym => 'unsigned long', GLXContextID => 'unsigned long', GLXPixmap => 'unsigned long', GLXDrawable => 'unsigned long', GLXPbuffer => 'unsigned long', GLXWindow => 'unsigned long', GLXFBConfigID => 'unsigned long', GLXPbufferSGIX => 'unsigned long', GLXFBConfigIDSGIX => 'unsigned long', GLXVideoSourceSGIX => 'unsigned long', GLXVideoCaptureDeviceNV => 'unsigned long', int64_t => 'long long', INT64 => 'long long', GLint64 => 'signed long long', GLint64EXT => 'signed long long', GLuint64 => 'unsigned long long', GLuint64EXT => 'unsigned long long', FLOAT => 'float', GLfloat => 'float', GLclampf => 'float', GLdouble => 'double', GLclampd => 'double', gleDouble => 'double', GLintptr => 'ptrdiff_t', GLsizeiptr => 'ptrdiff_t', GLintptrARB => 'ptrdiff_t', GLsizeiptrARB => 'ptrdiff_t', GLvdpauSurfaceNV => 'ptrdiff_t', ); my %NCI_TYPE = ( ( map {( $_ => $_ )} qw[ void char short int long longlong float double longdouble ] ), size_t => 'long', ptrdiff_t => 'long', ( map {( "$_*" => 'ptr', "$_**" => 'ptr' )} qw[ void char short int long ptrdiff_t longlong float double ] ), 'double***' => 'ptr', ); my %PCC_TYPE = ( char => 'I', short => 'I', int => 'I', long => 'I', float => 'N', double => 'N', ptr => 'P', ); my %PCC_CAST = ( I => '(INTVAL) ', N => '(FLOATVAL) ', S => '', P => '', ); my %OVERRIDE = ( glutInit => [[qw[ void int& ptr ]], [0, 0, 0]], ); my @IGNORE = ( # Most of these are limitations of this module or Parrot NCI # Don't handle GetProcAddress type functions yet 'glutGetProcAddress', 'glXGetProcAddress', 'glXGetProcAddressARB', 'wglGetProcAddress', # Don't handle this odd create/callback register function yet 'glutCreateMenu', # Don't handle Mesa, GLC, GLU, or MUI callbacks yet 'glProgramCallbackMESA', 'glcCallbackFunc', 'glcGetCallbackFunc', 'gluNurbsCallback', 'gluQuadricCallback', 'gluTessCallback', 'muiSetCallback', 'muiSetNonMUIcallback', 'handler', 'callback', # Don't handle functions without "namespace" prefixes matching library 'rot_axis', 'rot_about_axis', 'rot_omega', 'rot_prince', 'urot_axis', 'urot_about_axis', 'urot_omega', 'urot_prince', 'uview_direction', 'uviewpoint', # Some versions of GLUT declare these both with and without prefixes; # ignore the non-prefixed versions 'SwapBuffers', 'ChoosePixelFormat', 'DescribePixelFormat', 'GetPixelFormat', 'SetPixelFormat', # Can't handle weird data types specified only in proprietary headers 'glXCreateGLXVideoSourceSGIX', 'glXAssociateDMPbufferSGIX', # Ignore internal GLUT Win32 compatibility hackage 'exit', ); my @SKIP = ( # Can't properly support these yet; some (such as the internal headers) # may never be supported. # Mesa non-standard driver headers 'amesa.h', 'dmesa.h', 'foomesa.h', 'fxmesa.h', 'ggimesa.h', 'mesa_wgl.h', 'mglmesa.h', 'osmesa.h', 'svgamesa.h', 'uglmesa.h', 'wmesa.h', 'xmesa.h', 'xmesa_xf86.h', 'xmesa_x.h', # Mesa API-mangling headers (to load vendor GL and Mesa simultaneously) 'gl_mangle.h', 'glu_mangle.h', 'glx_mangle.h', # OpenVMS API-mangling header 'vms_x_fix.h', # Internal headers for DRI 'dri_interface.h', 'glcore.h', # Apple CGL OpenGL API conversion macros 'CGLMacro.h', # Internal headers for GLE (OpenGL Extrusions) library 'extrude.h', 'segment.h', # Rotation math utility functions from GLE 'gutil.h', # Plane math utility functions/macros from GLE 'intersect.h', # MUI (internal?) headers lacking "namespace" identifier prefixes 'browser.h', 'gizmo.h', 'hslider.h', 'vslider.h', # SGI GLw Drawing Area headers 'GLwDrawA.h', 'GLwDrawAP.h', 'GLwMDrawA.h', 'GLwMDrawAP.h', # GLFW, a replacement for GLUT 'glfw.h', ); my $MACRO_FILE = 'runtime/parrot/include/opengl_defines.pasm'; my $FUNCS_FILE = 'runtime/parrot/library/OpenGL_funcs.pir'; my $SIGS_FILE = 'src/glut_nci_thunks.nci'; my $C_FILE = 'src/glut_callbacks.c'; sub _init { my $self = shift; return { description => q{Generating OpenGL bindings}, result => q{}, }; } sub runstep { my ($self, $conf) = @_; unless ($conf->data->get('has_opengl')) { $self->set_result('skipped'); return 1; } my @include_paths_win32 = grep /\S/ => split /;/ => ($ENV{INCLUDE} || ''); my $osname = $conf->data->get('osname'); if (scalar @include_paths_win32 == 0 && $osname =~ /mswin32/i) { my $cc = $conf->data->get('cc'); my $path = dirname(dirname(which($cc))) . '\include'; @include_paths_win32 = ( $path ); } s{\\}{/}g foreach @include_paths_win32; my @header_globs = ( # Default locations for most UNIX-like platforms '/usr/include/GL/*.h', '/usr/local/include/GL/*.h', # Mac OS X '/System/Library/Frameworks/OpenGL.framework/Headers/*.h', '/System/Library/Frameworks/GLUT.framework/Headers/*.h', # Cygwin '/usr/include/w32api/GL/*.h', # Windows/MSVC (map "$_/gl/*.h" => @include_paths_win32), # # Portability testing headers # "$ENV{HOME}/src/gentoo3/*.h", # "$ENV{HOME}/src/gentoo4/usr/include/GL/*.h", # "$ENV{HOME}/src/osx/headers/GLUT/*.h", # "$ENV{HOME}/src/osx/headers/OpenGL/*.h", # "$ENV{HOME}/src/osx-10.4/GLUT/*.h", # "$ENV{HOME}/src/osx-10.4/OpenGL/*.h", # "$ENV{HOME}/src/cygwin/opengl-1.1.0/GLUI_v2_1_beta/*.h", # "$ENV{HOME}/src/cygwin/opengl-1.1.0/glut-3.7.3/include/GL/*.h", # "$ENV{HOME}/src/cygwin/opengl-1.1.0/glut-3.7.3/include/mui/*.h", # "$ENV{HOME}/src/glut-3.7.6/include/GL/*.h", # "$ENV{HOME}/src/glut-3.7.6/include/mui/*.h", # "$ENV{HOME}/src/freebsd-gl/usr/local/include/GL/*.h", # "$ENV{HOME}/src/osx-insane/Developer/Platforms/Aspen.platform/Developer/SDKs/Aspen1.2.sdk/System/Library/Frameworks/OpenGLES.framework/Headers/ES1/*.h", # "$ENV{HOME}/src/osx-insane/Developer/SDKs/MacOSX10.4u.sdk/System/Library/Frameworks/AGL.framework/Versions/A/Headers/*.h", # "$ENV{HOME}/src/osx-insane/Developer/SDKs/MacOSX10.4u.sdk/System/Library/Frameworks/OpenGL.framework/Versions/A/Headers/*.h", # "$ENV{HOME}/src/osx-insane/Developer/SDKs/MacOSX10.4u.sdk/System/Library/Frameworks/GLUT.framework/Versions/A/Headers/*.h", # "$ENV{HOME}/src/osx-insane/Developer/SDKs/MacOSX10.4u.sdk/usr/X11R6/include/GL/*.h", # "$ENV{HOME}/src/osx-insane/Developer/SDKs/MacOSX10.5.sdk/System/Library/Frameworks/AGL.framework/Versions/A/Headers/*.h", # "$ENV{HOME}/src/osx-insane/Developer/SDKs/MacOSX10.5.sdk/System/Library/Frameworks/OpenGL.framework/Versions/A/Headers/*.h", # "$ENV{HOME}/src/osx-insane/Developer/SDKs/MacOSX10.5.sdk/System/Library/Frameworks/GLUT.framework/Versions/A/Headers/*.h", # "$ENV{HOME}/src/osx-insane/Developer/SDKs/MacOSX10.5.sdk/usr/X11/include/GL/*.h", # "$ENV{HOME}/src/osx-insane/Developer/SDKs/MacOSX10.5.sdk/usr/X11/include/GL/internal/*.h", # "$ENV{HOME}/src/osx-insane/System/Library/Frameworks/AGL.framework/Versions/A/Headers/*.h", # "$ENV{HOME}/src/osx-insane/System/Library/Frameworks/OpenGL.framework/Versions/A/Headers/*.h", # "$ENV{HOME}/src/osx-insane/System/Library/Frameworks/GLUT.framework/Versions/A/Headers/*.h", # "$ENV{HOME}/src/osx-insane/usr/include/GL/*.h", # "$ENV{HOME}/src/osx-insane/usr/X11/include/GL/*.h", # "$ENV{HOME}/src/osx-insane/usr/X11/include/GL/internal/*.h", # "$ENV{HOME}/src/osx-insane/usr/X11R6 1/include/GL/*.h", # "$ENV{HOME}/src/osx-10.6.3/Headers/*.h", ); # X freeglut only if DISPLAY is set, otherwise use native w32api GLUT shift @header_globs if $^O eq 'cygwin' and !$ENV{DISPLAY}; my $globs_str = join("\n\t", @header_globs) . "\n"; $conf->debug( "\n", "Checking for OpenGL headers using the following globs:\n", "\t$globs_str" ); my @header_files = sort map {File::Glob::bsd_glob($_)} @header_globs; my %skip = map {($_ => 1)} @SKIP; @header_files = grep {my ($file) = m{([^/]+)$}; !$skip{$file}} @header_files; if (!@header_files) { my $err = "OpenGL enabled and detected, but no OpenGL headers found!"; if ( $^O eq 'darwin' ) { $err .= "\nIf you are on OS X 10.9 (Mavericks) with XCode 5.0.1," . " see: https://github.com/parrot/parrot/issues/1016"; } die $err; } my $files_str = join("\n\t", @header_files) . "\n"; $conf->debug( "\n", "Found the following OpenGL headers:\n", "\t$files_str\n", ); my $autogen_header = <<'HEADER'; # DO NOT EDIT THIS FILE. # # Any changes made here will be lost. # # This file is generated automatically by config/gen/opengl.pm # using the following files: # HEADER $autogen_header .= "# $_\n" foreach @header_files; $self->gen_opengl_defines ($conf, \@header_files, $autogen_header); $self->gen_opengl_wrappers($conf, \@header_files, $autogen_header); $self->gen_glut_callbacks ($conf); return 1; } sub gen_opengl_defines { my ($self, $conf, $header_files, $autogen_header) = @_; my (%defs, @macros, %non_numeric); my $max_len = 0; foreach my $file (@$header_files) { open my $header, '<', $file or die "Could not open header '$file': $!"; while (<$header>) { s/^\s*#\s*define\b/#define/; my (@F) = split; next unless @F > 2 and $F[0] eq '#define'; next unless $F[1] =~ /^(AGL|CGL|WGL|GLX|MUI|SMAP|TUBE|GL[A-Z]*)_/; next if $F[1] =~ /\(/; $max_len = length $F[1] if $max_len < length $F[1]; my $api = $1; if ($F[2] =~ /^(?:[ACW])?GL[A-Z]*_\w+$/) { push @macros, [$api, $F[1], $F[2]]; } if ($F[2] =~ /^\(?((?:[ACW])?GL[A-Z]*_\w+)([+-]\d+(?:\.\d*)?(?:e\d+)?)\)?$/) { push @macros, [$api, $F[1], $1, $2]; } elsif ( $F[2] =~ /^0x[0-9a-fA-F]+$/ || $F[2] =~ /^\d+(?:\.\d*)?(?:e\d+)?$/) { $defs{$api}{$F[1]} = $F[2]; } else { $non_numeric{$F[1]}++; $conf->debug("Non-numeric value for '$F[1]': '$F[2]'\n"); } } } foreach my $macro (@macros) { my ($api, $define, $value, $offset) = @$macro; my ($val_api) = $value =~ /^((?:[ACW])?GL[A-Z]*)_/; unless (defined $defs{$val_api}{$value}) { next if $non_numeric{$define}; die "'$define' is defined using '$value', but no '$value' has been defined"; } $defs{$api}{$define} = $defs{$val_api}{$value}; $defs{$api}{$define} += $offset if defined $offset; } open my $macros, '>', $MACRO_FILE or die "Could not open macro file '$MACRO_FILE' for write: $!"; print $macros $autogen_header; print $macros "\n\n"; foreach my $api (sort keys %defs) { my $api_defs = $defs{$api}; foreach my $define (sort keys %$api_defs) { printf $macros ".macro_const %-${max_len}s %s\n", $define, $api_defs->{$define}; } } add_to_generated($MACRO_FILE, "[main]"); return 1; } sub gen_opengl_wrappers { my ($self, $conf, $header_files, $autogen_header) = @_; my $verbose = $conf->options->get('verbose') || 0; my %IGNORE = map {($_ => 1)} @IGNORE; my (%pass, %fail, %ignore, %sigs, %funcs); # PHASE 1: Parse Headers foreach my $file (@$header_files) { open my $header, '<', $file or die "Could not open header '$file': $!"; PROTO: while (<$header>) { # Get rid of C comments s{/\*.*?\*/}{}g; if (m{/\*}) { chomp; $_ .= <$header>; redo; } # Make sure the entire parameter list is on a single line next unless /\(/; unless (/\)/) { chomp; $_ .= <$header>; redo; } # We only care about regular function prototypes next unless /API/ or /\bextern\b/ or /\bmui[A-Z]/; next if /^#/; next if /\btypedef\b/; next if /extern gleGC \*_gle_gc /; # Work around bug in Mac OS X headers (glext.h as of 10.6.3, at least) next if /^\s*extern\s+\w+\s+\(\*\s+/; # Skip where we are explicitly told to do so next if /\bFGUNUSED\b/; # Save a (space compressed) copy of the source line # for later error reporting my $orig = $_; $orig =~ s/\s+/ /g; $orig =~ s/ $/\n/; # Get rid of junk needed for C, but not for Parrot NCI; # also do general cleanup to make parsing easier s/\b(?:AVAILABLE|DEPRECATED_(?:IN|FOR))_MAC_OS_X_VERSION_\d+_\d+_AND_LATER\b\s*//; s/\bAVAILABLE_MAC_OS_X_VERSION_\d+_\d+_AND_LATER_BUT_DEPRECATED_IN_MAC_OS_X_VERSION_\d+_\d+\b\s*//; s/\bOPENGL_DEPRECATED\(10_\d+, 10_\d+\)\s*//; s/\bOPENGL_DEPRECATED_MSG\(10_\d+, 10_\d+, "[^")]+"\)\s*//; s/\bOPENGL_AVAILABLE\(10_\d+\)\s*//; s/\b__cdecl\b\s*//; s/\b__stdcall\b\s*//; s/\b_CRTIMP\b\s*//; s/\bextern\b\s*//; s/\bstatic\b\s*//; s/\bconst\b\s*//g; s/\benum\b\s*//g; s/\bstruct\b\s*//g; s/\b[_A-Z]*API[_A-Z]*\s*//g; s/\s*\*\s*/* /g; s/\* \*/**/g; s/\s*,\s*/, /g; s/\s*\(\s*/(/g; s/\s*\)\s*/)/g; s/\s+/ /g; s/\s+$//; s/^\s+//; # Canonicalize types s/\b(\w+)\b/$C_TYPE{$1} || $1/eg; s/\b(?:un)?signed (char|short|int|long)\b/$1/g; s/\b(?:un)?signed /int /g; s/\blong long\b/longlong/g; # Parse the function prototype, trying hard to capture name my ($return, $name, $params) = /^(\w+\**) (\w+)\(([^)]*)\);$/; ($name) = /^\w+\(?\** (\w+)\)?/ unless defined $name; # Is this a function we're ignoring for now or handling elsewhere? if (defined $name) { # Callback reg functions handled by gen_*_callbacks() $pass {$file}++, next if /\bglut[A-Z][a-zA-Z]+Func\b/; $ignore{$file}++, next if /\bsmap[A-Z][a-zA-Z]+Func\b/; # Ignore all library-internal functions $ignore{$file}++, next if $name =~ /^__/; $ignore{$file}++, next if $name =~ /_ATEXIT_HACK$/; # Miscellaneous ignores $ignore{$file}++, next if $IGNORE{$name}; } # Successful parse? unless (defined $return and defined $name and defined $params) { $fail{$file}++; $name ||= ''; warn "In OpenGL header '$file', can't parse canonicalized prototype for '$name':\n $_\nOriginal prototype:\n $orig\n"; next; } # Figure out what group/library this function belongs to my ($group) = $name =~ /^(agl|CGL|wgl|glX|mui|smap|gl[a-z]*)/; unless ($group) { $fail{$file}++; warn "In OpenGL header '$file', found a non-OpenGL function: '$name'\n"; next; } $group = lc $group; # Convert return and param types to NCI signature my @nci_sig = @{${$OVERRIDE{$name} or []}[0] or []}; my @cstr_trans = @{${$OVERRIDE{$name} or []}[1] or []}; unless (@nci_sig) { $params = '' if $params eq 'void'; my @params = split /, / => $params; unshift @params, $return; foreach my $param (@params) { 1 while $param =~ s/(\w+\**) (\w+)\s*\[\d*\]/$1* $2/; $param =~ s/ \w+$// unless $NCI_TYPE{$param}; unless ($NCI_TYPE{$param}) { $fail{$file}++; warn "In OpenGL header '$file', prototype '$name', can't handle type '$param'; original prototype:\n $orig\n" if $verbose; next PROTO; } push @nci_sig, $NCI_TYPE{$param}; push @cstr_trans, $param eq 'char*'; } if (any sub { $_ eq 'void' }, @nci_sig[1..$#nci_sig]) { $fail{$file}++; warn "In OpenGL header '$file', prototype '$name', there is a void parameter; original prototype:\n $orig\n" if $verbose; next PROTO; } } # Success! Save results. $pass{$file}++; $sigs{join ',', @nci_sig} = [@nci_sig]; push @{$funcs{$group}}, [$name, [@nci_sig], [@cstr_trans]]; my $nci_sig = '[' . (join ',', @nci_sig) . ']'; print "$group\t$nci_sig\t$return $name($params);\n" if $verbose >= 3; } } # PHASE 2: Write unique signatures to NCI signatures file my @sigs = values %sigs; open my $sigs, '>', $SIGS_FILE or die "Could not open NCI signatures file '$SIGS_FILE' for write: $!"; print $sigs <<"HEADER"; # Used by OpenGL (including GLU and GLUT) # $autogen_header # GLUT callbacks v pP v pPi v pPii # Generated signatures HEADER foreach my $nci_sig (@sigs) { my ($return, @params) = ($$nci_sig[0], @$nci_sig[1..$#$nci_sig]); print $sigs "$return (", (join ',', @params), ")\n"; } close $sigs; add_to_generated($SIGS_FILE, "[]"); # [devel]src ? # PHASE 3: Write function lists for each OpenGL-related library open my $funcs, '>', $FUNCS_FILE or die "Could not open function list file '$FUNCS_FILE' for write: $!"; print $funcs $autogen_header; print $funcs <<'GLUTCB_FUNCS'; .sub _glutcb_func_list .local pmc glutcb_funcs glutcb_funcs = new 'ResizableStringArray' push glutcb_funcs, 'Parrot_glut_nci_loader' push glutcb_funcs, 'void,ptr' push glutcb_funcs, '' push glutcb_funcs, 'glutcbCloseFunc' push glutcb_funcs, 'void,ptr,PMC' push glutcb_funcs, '' push glutcb_funcs, 'glutcbDisplayFunc' push glutcb_funcs, 'void,ptr,PMC' push glutcb_funcs, '' push glutcb_funcs, 'glutcbIdleFunc' push glutcb_funcs, 'void,ptr,PMC' push glutcb_funcs, '' push glutcb_funcs, 'glutcbMenuDestroyFunc' push glutcb_funcs, 'void,ptr,PMC' push glutcb_funcs, '' push glutcb_funcs, 'glutcbOverlayDisplayFunc' push glutcb_funcs, 'void,ptr,PMC' push glutcb_funcs, '' push glutcb_funcs, 'glutcbWMCloseFunc' push glutcb_funcs, 'void,ptr,PMC' push glutcb_funcs, '' push glutcb_funcs, 'glutcbEntryFunc' push glutcb_funcs, 'void,ptr,PMC' push glutcb_funcs, '' push glutcb_funcs, 'glutcbMenuStateFunc' push glutcb_funcs, 'void,ptr,PMC' push glutcb_funcs, '' push glutcb_funcs, 'glutcbVisibilityFunc' push glutcb_funcs, 'void,ptr,PMC' push glutcb_funcs, '' push glutcb_funcs, 'glutcbWindowStatusFunc' push glutcb_funcs, 'void,ptr,PMC' push glutcb_funcs, '' push glutcb_funcs, 'glutcbButtonBoxFunc' push glutcb_funcs, 'void,ptr,PMC' push glutcb_funcs, '' push glutcb_funcs, 'glutcbDialsFunc' push glutcb_funcs, 'void,ptr,PMC' push glutcb_funcs, '' push glutcb_funcs, 'glutcbMotionFunc' push glutcb_funcs, 'void,ptr,PMC' push glutcb_funcs, '' push glutcb_funcs, 'glutcbPassiveMotionFunc' push glutcb_funcs, 'void,ptr,PMC' push glutcb_funcs, '' push glutcb_funcs, 'glutcbReshapeFunc' push glutcb_funcs, 'void,ptr,PMC' push glutcb_funcs, '' push glutcb_funcs, 'glutcbSpaceballButtonFunc' push glutcb_funcs, 'void,ptr,PMC' push glutcb_funcs, '' push glutcb_funcs, 'glutcbTabletMotionFunc' push glutcb_funcs, 'void,ptr,PMC' push glutcb_funcs, '' push glutcb_funcs, 'glutcbKeyboardFunc' push glutcb_funcs, 'void,ptr,PMC' push glutcb_funcs, '' push glutcb_funcs, 'glutcbKeyboardUpFunc' push glutcb_funcs, 'void,ptr,PMC' push glutcb_funcs, '' push glutcb_funcs, 'glutcbMenuStatusFunc' push glutcb_funcs, 'void,ptr,PMC' push glutcb_funcs, '' push glutcb_funcs, 'glutcbSpaceballMotionFunc' push glutcb_funcs, 'void,ptr,PMC' push glutcb_funcs, '' push glutcb_funcs, 'glutcbSpaceballRotateFunc' push glutcb_funcs, 'void,ptr,PMC' push glutcb_funcs, '' push glutcb_funcs, 'glutcbSpecialFunc' push glutcb_funcs, 'void,ptr,PMC' push glutcb_funcs, '' push glutcb_funcs, 'glutcbSpecialUpFunc' push glutcb_funcs, 'void,ptr,PMC' push glutcb_funcs, '' push glutcb_funcs, 'glutcbMouseFunc' push glutcb_funcs, 'void,ptr,PMC' push glutcb_funcs, '' push glutcb_funcs, 'glutcbMouseWheelFunc' push glutcb_funcs, 'void,ptr,PMC' push glutcb_funcs, '' push glutcb_funcs, 'glutcbTabletButtonFunc' push glutcb_funcs, 'void,ptr,PMC' push glutcb_funcs, '' push glutcb_funcs, 'glutcbTimerFunc' push glutcb_funcs, 'void,ptr,PMC,int,int' push glutcb_funcs, '' push glutcb_funcs, 'glutcbJoystickFunc' push glutcb_funcs, 'void,ptr,PMC,int' push glutcb_funcs, '' .return (glutcb_funcs) .end GLUTCB_FUNCS foreach my $group (sort keys %funcs) { my $sub_name = "_${group}_func_list"; my $list_name = "${group}_funcs"; print $funcs <<"SUB_HEADER"; .sub $sub_name .local pmc $list_name $list_name = new 'ResizableStringArray' SUB_HEADER my @funcs = sort {$a->[0] cmp $b->[0]} @{$funcs{$group}}; foreach my $func (@funcs) { my ($name, $sig, $cstr) = @$func; my $sig_str = join ',', @$sig; my $cstr_str = do { my $i = -1; join ',', map $_->[1], grep $_->[0], map [$_, $i++], @$cstr; }; print $funcs <<"FUNCTION" push $list_name, '$name' push $list_name, '$sig_str' push $list_name, '$cstr_str' FUNCTION } print $funcs <<"SUB_FOOTER"; .return ($list_name) .end SUB_FOOTER } close $funcs; add_to_generated($FUNCS_FILE, "[main]"); # PHASE 4: Print statistical info on parse results if verbose if ($verbose) { print "\nPASS FAIL IGNORE HEADER\n"; foreach my $file (@$header_files, 'TOTAL') { my $pass = $pass {$file} || 0; my $fail = $fail {$file} || 0; my $ignore = $ignore{$file} || 0; printf "%4d %4d %4d %s\n", $pass, $fail, $ignore, $file; $pass {TOTAL} += $pass; $fail {TOTAL} += $fail; $ignore{TOTAL} += $ignore; } print "\nCOUNT NCI SIGNATURE\n" if $verbose >= 2; foreach my $nci_sig (@sigs, 'TOTAL') { printf "%5d %s\n", $sigs{$nci_sig}, $nci_sig if $verbose >= 2; $sigs{TOTAL} += $sigs{$nci_sig}; } printf "\n===> %d unique signatures successfully translated.\n", scalar @sigs; } return 1; } sub gen_glut_callbacks { my ( $self, $conf ) = @_; my $glut_api = $conf->data->get('has_glut'); my $glut_brand = $conf->data->get('glut_brand'); my @glut_callbacks = @GLUT_1_CALLBACKS; push @glut_callbacks, @GLUT_2_CALLBACKS if $glut_api >= 2; push @glut_callbacks, @GLUT_3_CALLBACKS if $glut_api >= 3; push @glut_callbacks, @GLUT_4_CALLBACKS if $glut_api >= 4; push @glut_callbacks, @FREEGLUT_CALLBACKS if $glut_brand eq 'freeglut'; push @glut_callbacks, @MACOSXGLUT_CALLBACKS if $glut_brand eq 'freeglut' or $glut_brand eq 'MacOSX_GLUT'; my $glut_header = $glut_brand eq 'MacOSX_GLUT' ? 'GLUT/glut.h' : $glut_brand eq 'OpenGLUT' ? 'GL/openglut.h' : $glut_brand eq 'freeglut' ? 'GL/freeglut.h' : 'GL/glut.h' ; my @callbacks; foreach my $raw (@glut_callbacks) { my ($friendly, $params) = @$raw; my $args = $params; $args =~ s/void//; $args =~ s/unsigned //; $args =~ s/(^|, )((?:\w+ )+)/$1$PCC_CAST{$PCC_TYPE{$NCI_TYPE{(split ' ', $2)[0]}}}/g; $args = ", $args" if $args; my $proto = $params; $proto =~ s/ \w+(,|$)/$1/g; my $sig = $proto; $sig =~ s/void//; $sig =~ s/unsigned //; $sig =~ s/(\w+)\W*/$PCC_TYPE{$NCI_TYPE{$1}}/g; $sig = "$sig->"; my $glutcb = "glutcb${friendly}Func"; $glutcb =~ s/ //g; my $glut = $glutcb; $glut =~ s/glutcb/glut/; my $thunk = 'glut_' . lc($friendly) . '_func'; $thunk =~ s/ /_/g; my $enum = 'GLUT_CB_' . uc($friendly); $enum =~ s/ /_/g; push @callbacks, { friendly => $friendly, params => $params, proto => $proto, args => $args, sig => $sig, glutcb => $glutcb, glut => $glut, thunk => $thunk, enum => $enum, }; } my $enums = ''; my $thunks = ''; my $reg_funcs = ''; my $std_cbs = ''; foreach (@callbacks) { $enums .= " $_->{enum},\n"; $thunks .= " void $_->{thunk}($_->{proto});\n"; $reg_funcs .= "PARROT_DYNEXT_EXPORT void $_->{glutcb}(Parrot_Interp, PMC *);\n"; } my $header = <<"HEADER"; /* # DO NOT EDIT THIS FILE. # # Any changes made here will be lost. # # This file is generated automatically by config/gen/opengl.pm Copyright (C) 2008, 2014, Parrot Foundation. =head1 NAME $C_FILE - GLUT Callback Function Handling =head1 DESCRIPTION GLUT callbacks are always synchronous and have void return type. None of them accept user data parameters, so normal Parrot callback handling cannot be used. =head2 Functions =over 4 =cut */ #define PARROT_IN_EXTENSION #include "parrot/parrot.h" #include "parrot/extend.h" /* workaround freeglut problem from 2.0 to at least 2.8, see [GH #1070] */ #ifndef __APPLE__ # define __APPLE__ 0 #endif #include <$glut_header> typedef enum { $enums GLUT_CB_TIMER, #if GLUT_API_VERSION >= 4 GLUT_CB_JOYSTICK, #endif GLUT_NUM_CALLBACKS } GLUT_CALLBACKS; typedef struct GLUT_CB_data { Parrot_Interp interp; PMC *sub; } GLUT_CB_data; GLUT_CB_data callback_data[GLUT_NUM_CALLBACKS]; int is_safe(Parrot_Interp, PMC *); void glut_timer_func(int); PARROT_DYNEXT_EXPORT void glutcbTimerFunc(Parrot_Interp, PMC *, unsigned int, int); #if GLUT_API_VERSION >= 4 void glut_joystick_func(unsigned int, int, int, int); PARROT_DYNEXT_EXPORT void glutcbJoystickFunc(Parrot_Interp, PMC *, int); #endif $thunks $reg_funcs /* Make sure that interp and sub are sane before running callback sub */ /* XXXX: Should this do the moral equivalent of PANIC? */ int is_safe(SHIM_INTERP, PMC *sub) { /* XXXX: Verify that interp still exists */ /* XXXX: Verify that sub exists in interp */ return PMC_IS_NULL(sub) ? 0 : 1; } /* # glutTimerFunc and glutJoystickFunc must be hardcoded because they have # special timer-related arguments that do not follow the template of all # of the other GLUT callbacks =item C Register a Sub PMC to handle GLUT Timer callbacks. =cut */ void glut_timer_func(int data) { Parrot_Interp interp = callback_data[GLUT_CB_TIMER].interp; PMC *sub = callback_data[GLUT_CB_TIMER].sub; if (is_safe(interp, sub)) Parrot_ext_call(interp, sub, "I->", (INTVAL) data); } PARROT_DYNEXT_EXPORT void glutcbTimerFunc(PARROT_INTERP, PMC *sub, unsigned int milliseconds, int data) { callback_data[GLUT_CB_TIMER].interp = interp; callback_data[GLUT_CB_TIMER].sub = sub; if (PMC_IS_NULL(sub)) glutTimerFunc(0, NULL, 0); else glutTimerFunc(milliseconds, glut_timer_func, data); } #if GLUT_API_VERSION >= 4 /* =item C Register a Sub PMC to handle GLUT Joystick callbacks. =cut */ void glut_joystick_func(unsigned int buttons, int xaxis, int yaxis, int zaxis) { Parrot_Interp interp = callback_data[GLUT_CB_JOYSTICK].interp; PMC *sub = callback_data[GLUT_CB_JOYSTICK].sub; if (is_safe(interp, sub)) Parrot_ext_call(interp, sub, "IIII->", (INTVAL) buttons, (INTVAL) xaxis, (INTVAL) yaxis, (INTVAL) zaxis); } PARROT_DYNEXT_EXPORT void glutcbJoystickFunc(PARROT_INTERP, PMC *sub, int pollinterval) { callback_data[GLUT_CB_JOYSTICK].interp = interp; callback_data[GLUT_CB_JOYSTICK].sub = sub; if (PMC_IS_NULL(sub)) glutJoystickFunc(NULL, 0); else glutJoystickFunc(glut_joystick_func, pollinterval); } #endif HEADER foreach (@callbacks) { $std_cbs .= <<"IMPLEMENTATION" /* =item C{glutcb}(PARROT_INTERP, sub)> Register a Sub PMC to handle GLUT $_->{friendly} callbacks. =cut */ void $_->{thunk}($_->{params}) { Parrot_Interp interp = callback_data[$_->{enum}].interp; PMC *sub = callback_data[$_->{enum}].sub; if (is_safe(interp, sub)) Parrot_ext_call(interp, sub, "$_->{sig}"$_->{args}); } PARROT_DYNEXT_EXPORT void $_->{glutcb}(PARROT_INTERP, PMC *sub) { callback_data[$_->{enum}].interp = interp; callback_data[$_->{enum}].sub = sub; if (PMC_IS_NULL(sub)) $_->{glut}(NULL); else $_->{glut}($_->{thunk}); } IMPLEMENTATION } my $footer = <<'FOOTER'; /* =back =cut */ FOOTER ### ### ACTUALLY WRITE FILE ### open my $c_file, '>', $C_FILE or die "Could not open '$C_FILE' for write: $!"; print $c_file $header; print $c_file $std_cbs; print $c_file $footer; add_to_generated($C_FILE, "[devel]", 'src'); return 1; } 1; # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: abc_special_variables000644000765000765 15611533177634 22436 0ustar00bruce000000000000parrot-6.6.0/examples/languages/abc/t# last special variale last 0\n empty last 1; last 1\n1\n not empty last # todo: # ibase, obase, and last. key.pmc000644000765000765 3231512346145241 14353 0ustar00bruce000000000000parrot-6.6.0/src/pmc/* Copyright (C) 2001-2014, Parrot Foundation. =head1 NAME src/pmc/key.pmc - Key PMC =head1 DESCRIPTION These are the vtable functions for the Key PMC class. =head2 Methods =over 4 =cut */ /* HEADERIZER HFILE: none */ /* HEADERIZER BEGIN: static */ /* HEADERIZER END: static */ pmclass Key auto_attrs { ATTR PMC *next_key; /* Sometimes it's the next key, sometimes it's not. The Key code is like that. */ ATTR INTVAL int_key; /* int value of this key, or something magical if it's a hash iterator key */ ATTR STRING *str_key; /* STRING value of this key, if any */ /* Theoretically there'd also be a pmc_key here, * but that code looks broken and unneeded. */ /* =item C Initializes the key. =cut */ VTABLE void init() { PObj_custom_mark_SET(SELF); } /* =item C Creates and returns a clone of the key. =cut */ VTABLE PMC *clone() :no_wb { PMC * const dest = Parrot_pmc_new(INTERP, SELF->vtable->base_type); PMC *dkey = dest; PMC *key = SELF; for (; key ;) { switch (KEY_get_FLAGS(key)) { case KEY_integer_FLAG: case KEY_integer_FLAG | KEY_register_FLAG: Parrot_key_set_integer(INTERP, dkey, Parrot_key_integer(INTERP, key)); break; case KEY_string_FLAG: case KEY_string_FLAG | KEY_register_FLAG: Parrot_key_set_string(INTERP, dkey, VTABLE_get_string(INTERP, key)); break; case KEY_pmc_FLAG: case KEY_pmc_FLAG | KEY_register_FLAG: Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_UNIMPLEMENTED, "Key.clone of pmc is broken - see TT #1683"); default: Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_INVALID_OPERATION, "Key: Unknown Key type %d", KEY_get_FLAGS(SELF)); break; } key = Parrot_key_next(INTERP, key); if (key) { PMC * const p = Parrot_key_new(INTERP); Parrot_key_append(INTERP, dkey, p); dkey = p; } } return dest; } /* =item C Marks the key as live. =cut */ VTABLE void mark() :no_wb { Parrot_key_mark(INTERP, SELF); } /* =item C Returns the integer value of the key. =cut */ VTABLE INTVAL get_integer() :no_wb { return Parrot_key_integer(INTERP, SELF); } /* =item C Returns the Parrot string value of the key. =cut */ VTABLE STRING *get_string() :no_wb { /* Parrot_key_string() is only useful if this PMC has a key type */ if (KEY_get_FLAGS(SELF)) { return Parrot_key_string(INTERP, SELF); } return CONST_STRING(INTERP, ""); } /* =item C Returns the PMC value of the key. =cut */ VTABLE PMC *get_pmc() :no_wb { return Parrot_key_pmc(INTERP, SELF); } /* =item C =cut */ VTABLE void set_integer_native(INTVAL value) { Parrot_key_set_integer(INTERP, SELF, value); } /* =item C =cut */ VTABLE void set_string_native(STRING *value) { Parrot_key_set_string(INTERP, SELF, value); } /* =item C Sets the value of the key to C<*value>. =cut */ VTABLE void set_pmc(PMC *value) :no_wb { UNUSED(SELF) UNUSED(value) Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_UNIMPLEMENTED, "Key.set_pmc is broken - see GH #499"); } /* =item C Appends C<*value> to the key. =cut */ void push_pmc(PMC *value) { if (value->vtable->base_type != enum_class_Key) Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_INVALID_OPERATION, "Can only push another Key onto a Key PMC."); Parrot_key_append(INTERP, SELF, value); } /* =item C Returns the next key. Actually doesn't remove the entry but might be useful to traverse a key chain. =cut */ VTABLE PMC *shift_pmc() :no_wb { PMC *next_key; GET_ATTR_next_key(INTERP, SELF, next_key); return next_key; } /* =back =head2 Iterator Interface =over 4 =item C Returns the key itself. =cut */ VTABLE PMC *get_pmc_keyed(PMC *key) :no_wb { UNUSED(INTERP) UNUSED(SELF) return key; } /* =item C Archives the Key. =item C Unarchives the Key. =item C Called after the Key has been thawed: convert last PMC_NULL key to NULL. =cut */ void freeze(PMC *info) :no_wb { int size; PMC *k; for (size = 0, k = SELF; k; size++) GET_ATTR_next_key(interp, k, k); VTABLE_push_integer(INTERP, info, size); for (k = SELF; k;) { const INTVAL flags = KEY_get_FLAGS(k); VTABLE_push_integer(INTERP, info, flags); switch (flags) { case KEY_integer_FLAG | KEY_register_FLAG: case KEY_string_FLAG | KEY_register_FLAG: case KEY_pmc_FLAG | KEY_register_FLAG: case KEY_integer_FLAG: { INTVAL i; GET_ATTR_int_key(INTERP, k, i); VTABLE_push_integer(INTERP, info, i); } break; case KEY_string_FLAG: { STRING *s; GET_ATTR_str_key(INTERP, k, s); VTABLE_push_string(INTERP, info, s); } break; default: Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_KEY_NOT_FOUND, "Unsupported key type in Key.freeze"); break; } GET_ATTR_next_key(interp, k, k); } } void thaw(PMC *info) { int size; PMC *k = SELF; PObj_custom_mark_SET(SELF); for (size = VTABLE_shift_integer(INTERP, info); size; size--) { const INTVAL flags = VTABLE_shift_integer(INTERP, info) & KEY_type_FLAGS; PObj_get_FLAGS(k) |= flags; /* get contents */ switch (flags) { case KEY_integer_FLAG | KEY_register_FLAG: case KEY_string_FLAG | KEY_register_FLAG: case KEY_pmc_FLAG | KEY_register_FLAG: case KEY_integer_FLAG: SET_ATTR_int_key(INTERP, k, VTABLE_shift_integer(INTERP, info)); break; case KEY_string_FLAG: VTABLE_set_string_native(INTERP, k, VTABLE_shift_string(INTERP, info)); break; default: Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_KEY_NOT_FOUND, "Unsupported key type in Key.thaw"); break; } if (size == 1) { SET_ATTR_next_key(INTERP, k, NULL); } else { SET_ATTR_next_key(INTERP, k, Parrot_pmc_new(INTERP, enum_class_Key)); GET_ATTR_next_key(INTERP, k, k); } } } VTABLE void thawfinish(PMC *info) { UNUSED(info) PMC *key = SELF; while (1) { PMC *next; GET_ATTR_next_key(INTERP, key, next); if (PMC_IS_NULL(next)) { SET_ATTR_next_key(INTERP, key, NULL); break; } key = next; } } VTABLE STRING* get_repr() :no_wb { return Parrot_key_set_to_string(INTERP, SELF); } /* =item C Set key to hold particular register. =cut */ METHOD set_register(INTVAL reg_no, INTVAL reg_type) { Parrot_key_set_register(INTERP, SELF, reg_no, reg_type); } /* =item C =item C =item C =item C Aggregate interface. =cut */ VTABLE INTVAL elements() :no_wb { INTVAL n = 0; UNUSED(INTERP) for (; SELF; SELF = PARROT_KEY(SELF)->next_key) n++; return n; } VTABLE INTVAL get_integer_keyed_int(INTVAL n) :no_wb { for (; SELF && n; SELF = PARROT_KEY(SELF)->next_key, n--); if (n) Parrot_ex_throw_from_c_args(INTERP, NULL, 0, "Key access out of bounds"); return Parrot_key_integer(INTERP, SELF); } VTABLE STRING *get_string_keyed_int(INTVAL n) :no_wb { for (; SELF && n; SELF = PARROT_KEY(SELF)->next_key, n--); if (n) Parrot_ex_throw_from_c_args(INTERP, NULL, 0, "Key access out of bounds"); return Parrot_key_string(INTERP, SELF); } VTABLE PMC *get_pmc_keyed_int(INTVAL n) :no_wb { for (; SELF && n; SELF = PARROT_KEY(SELF)->next_key, n--); if (n) Parrot_ex_throw_from_c_args(INTERP, NULL, 0, "Key access out of bounds"); return Parrot_key_pmc(INTERP, SELF); } METHOD make_register_key(STRING * set, INTVAL idx) { INTVAL first_char = Parrot_str_indexed(INTERP, set, 0); KEY_flags key_type; switch (first_char) { case 'S': key_type = KEY_string_FLAG; break; case 'I': key_type = KEY_integer_FLAG; break; case 'P': key_type = KEY_pmc_FLAG; break; default: Parrot_ex_throw_from_c_args(INTERP, NULL, 0, "Key: Unknown register set %Ss", set); } Parrot_key_set_register(INTERP, SELF, idx, (INTVAL)key_type); } METHOD is_register_reference() :no_wb { INTVAL is_reg_ref = KEY_register_TEST(SELF) ? 1 : 0; RETURN(INTVAL is_reg_ref); } METHOD get_register_idx() :no_wb { if (!KEY_register_TEST(SELF)) Parrot_ex_throw_from_c_args(INTERP, NULL, 0, "Key: Key is not a register reference"); else { const INTVAL idx = Parrot_key_integer(INTERP, SELF); RETURN(INTVAL idx); } } METHOD get_register_contents(PMC *ctx :optional, INTVAL has_ctx :opt_flag) :no_wb { INTVAL int_key; if (!KEY_register_TEST(SELF)) Parrot_ex_throw_from_c_args(INTERP, NULL, 0, "Key: Key is not a register reference"); GETATTR_Key_int_key(interp, SELF, int_key); if (!has_ctx || PMC_IS_NULL(ctx)) { switch (KEY_get_FLAGS(SELF)) { case KEY_string_FLAG | KEY_register_FLAG: { STRING * const str_val = REG_STR(interp, int_key); RETURN(STRING *str_val); } case KEY_pmc_FLAG | KEY_register_FLAG: { PMC * const pmc_val = REG_PMC(interp, int_key); RETURN(PMC *pmc_val); } case KEY_integer_FLAG | KEY_register_FLAG: { const INTVAL int_val = REG_INT(interp, int_key); RETURN(INTVAL int_val); } default: Parrot_ex_throw_from_c_args(INTERP, NULL, 0, "Key: Unknown Key type %d", KEY_get_FLAGS(SELF)); } } else { switch (KEY_get_FLAGS(SELF)) { case KEY_string_FLAG | KEY_register_FLAG: { STRING * const str_val = *Parrot_pcc_get_STRING_reg(INTERP, ctx, int_key); RETURN(STRING *str_val); } case KEY_pmc_FLAG | KEY_register_FLAG: { PMC * const pmc_val = *Parrot_pcc_get_PMC_reg(INTERP, ctx, int_key); RETURN(PMC *pmc_val); } case KEY_integer_FLAG | KEY_register_FLAG: { const INTVAL int_val = *Parrot_pcc_get_INTVAL_reg(INTERP, ctx, int_key); RETURN(INTVAL int_val); } default: Parrot_ex_throw_from_c_args(INTERP, NULL, 0, "Key: Unknown Key type %d", KEY_get_FLAGS(SELF)); } } } /* returns integer, values taken from PCC */ METHOD get_type() :no_wb { INTVAL ret = 0; switch (KEY_get_FLAGS(SELF)) { #if 0 case KEY_integer_FLAG: case KEY_integer_FLAG | KEY_register_FLAG: ret = 0; break; #endif case KEY_string_FLAG: case KEY_string_FLAG | KEY_register_FLAG: ret = 1; break; case KEY_pmc_FLAG: case KEY_pmc_FLAG | KEY_register_FLAG: ret = 2; break; default: break; } RETURN(INTVAL ret); } } /* =back =cut */ /* * Local variables: * c-file-style: "parrot" * End: * vim: expandtab shiftwidth=4 cinoptions='\:2=2' : */ pcre.t000644000765000765 1062712356767112 14553 0ustar00bruce000000000000parrot-6.6.0/t/library#!perl # Copyright (C) 2001-2014, Parrot Foundation. use strict; use warnings; use lib qw( t . lib ../lib ../../lib ); use Test::More; use Parrot::Test tests => 2; use Parrot::Config qw( %PConfig ); =head1 NAME t/library/pcre.t - testing library/pcre.pir =head1 SYNOPSIS % prove t/library/pcre.t =head1 DESCRIPTION This program tests whether the 'pcre.pir' library accesses the installed PCRE library, and matches patterns successfully. =cut # test if compiled with pcre and if the run-time component of pcre still works my $had_pcre = $PConfig{HAS_PCRE}; my ($has_pcre, $pcre_libpath); if ($had_pcre) { my $cmd = ( $^O =~ /MSWin32/ ) ? "pcregrep --version" : "pcre-config --version"; $has_pcre = !Parrot::Test::run_command( $cmd, STDOUT => File::Spec->devnull ,STDERR => File::Spec->devnull, ); $pcre_libpath = ''; } # It's possible that libpcre is installed in some non-standard path... if ($had_pcre && $has_pcre && ($^O !~ /MSWin32/)) { # Extract the library path for non-windows platforms (in case it isn't in # the normal lookup locations) my $outfile = 'pcre-config.out'; Parrot::Test::run_command('pcre-config --prefix', STDOUT => $outfile); my $out = Parrot::Test::slurp_file($outfile); unlink $outfile; chomp $out; $pcre_libpath = "$out/lib"; } SKIP: { skip( 'no pcre', Test::Builder->new()->expected_tests() ) unless $had_pcre; skip( ($^O eq 'MSWin32' ? 'no pcregrep' : 'no pcre-config'), Test::Builder->new()->expected_tests() ) unless $has_pcre; skip( 'Parrot built without libffi or extra NCI thunks', Test::Builder->new()->expected_tests() ) unless ($PConfig{HAS_EXTRA_NCI_THUNKS} || $PConfig{HAS_LIBFFI}); ## 1 ## Check that the library can be loaded and initialized, ## diganose the failure otherwise. pir_output_is(<<"CODE", <<'OUT', 'libpcre loading'); .include 'iglobals.pasm' .include 'libpaths.pasm' .sub main :main .local pmc interp getinterp interp .local pmc lib_paths lib_paths = interp[.IGLOBALS_LIB_PATHS] .local pmc dynext_path dynext_path = lib_paths[.PARROT_LIB_PATH_DYNEXT] unshift dynext_path, '$pcre_libpath' load_bytecode 'pcre.pbc' .local pmc pcre_init .local pmc pcre_lib get_global pcre_init, ['PCRE'], 'init' if null pcre_init goto NOINIT push_eh CATCH pcre_lib = pcre_init() pop_eh if null pcre_lib goto NULLINIT unless pcre_lib goto FALSEINIT say 'Loaded' .return() CATCH: .local pmc exception .get_results(exception) .local string message message = exception['message'] pop_eh say message .return() NOINIT: say 'No init function' .return() NULLINIT: say 'init returned null value' .return() FALSEINIT: say 'init returned false value' .return() .end CODE Loaded OUT ## 2 my @todo; @todo = ( todo => '3..5 fail on Win32' ) if $^O =~ /MSWin32/; pir_output_is( <<"CODE", <<'OUT', 'soup to nuts', @todo ); .include 'iglobals.pasm' .include 'libpaths.pasm' .sub main :main .local pmc interp getinterp interp .local pmc lib_paths lib_paths = interp[.IGLOBALS_LIB_PATHS] .local pmc dynext_path dynext_path = lib_paths[.PARROT_LIB_PATH_DYNEXT] unshift dynext_path, '$pcre_libpath' load_bytecode 'pcre.pbc' .local pmc func .local pmc lib get_global func, ['PCRE'], 'init' if_null func, NOK1 branch OK1 NOK1: print 'not ' OK1: say 'ok 1' lib = func() if_null lib, NOK2 branch OK2 NOK2: print 'not ' OK2: say 'ok 2' .local string s .local string pat s= '--a--' pat= 'a' .local pmc code .local string error .local int errptr func= get_global ['PCRE'], 'compile' ( code, error, errptr )= func( pat, 0 ) .local int is_code_defined is_code_defined= defined code if is_code_defined goto OK3 print 'not ' OK3: say 'ok 3' .local int ok .local pmc result func= get_global ['PCRE'], 'match' ( ok, result )= func( code, s, 0, 0 ) unless ok < 0 goto OK4 print 'not ' OK4: say 'ok 4' .local int i i = 0 .local string match func = get_global ['PCRE'], 'dollar' match = func( s, ok, result, i ) if 'a' == match goto OK5 print 'not ' OK5: say 'ok 5' .end CODE ok 1 ok 2 ok 3 ok 4 ok 5 OUT } # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: PCCMETHOD.pm000644000765000765 5157712356767111 16363 0ustar00bruce000000000000parrot-6.6.0/lib/Parrot/Pmc2c# Copyright (C) 2004-2014, Parrot Foundation. package Parrot::Pmc2c::PCCMETHOD; use strict; use warnings; use Carp qw(longmess croak); use Parrot::Pmc2c::PCCMETHOD_BITS; use Parrot::Pmc2c::UtilFunctions qw( trim ); =head1 NAME Parrot::Pmc2c::PCCMETHOD - Parses and preps PMC PCCMETHOD called from F =head1 SYNOPSIS use Parrot::Pmc2c::PCCMETHOD; =head1 DESCRIPTION Parrot::Pmc2c::PCCMETHOD - Parses and preps PMC PCCMETHOD called from F =cut =head1 FUNCTIONS =head2 Publicly Available Methods =head3 C B Parse and Build PMC PCCMETHODS. B =over 4 =item * C =item * C Current Method Object =item * C Current Method Body =back =head3 C B Parse and Build a PCCINVOKE Call. B =over 4 =item * C =item * C Current Method Object =item * C Current Method Body =back =cut use constant REGNO_INT => 0; use constant REGNO_NUM => 1; use constant REGNO_STR => 2; use constant REGNO_PMC => 3; =head3 regtype to argtype conversion hash =cut our $reg_type_info = { # s is string, ss is short string, at is arg type +(REGNO_INT) => { s => "INTVAL", ss => "INT", pcc => 'I', at => PARROT_ARG_INTVAL}, +(REGNO_NUM) => { s => "FLOATVAL", ss => "NUM", pcc => "N", at => PARROT_ARG_FLOATVAL, }, +(REGNO_STR) => { s => "STRING*", ss => "STR", pcc => "S", at => PARROT_ARG_STRING, }, +(REGNO_PMC) => { s => "PMC*", ss => "PMC", pcc => "P", at => PARROT_ARG_PMC, }, }; =head3 C builds and returs an adverb hash from an adverb string such as ":optional :opt_flag :slurpy" { optional =>1, opt_flag =>1, slurpy =>1, } =cut sub parse_adverb_attributes { my $adverb_string = shift; my %result; if ( defined $adverb_string ) { ++$result{$1} while $adverb_string =~ /:(\S+)/g; } $result{manual_wb}++ if $result{no_wb}; return \%result; } sub convert_type_string_to_reg_type { local ($_) = @_; return REGNO_INT if /INTVAL|int/i; return REGNO_NUM if /FLOATVAL|double/i; return REGNO_STR if /STRING/i; return REGNO_PMC if /PMC/i; croak "$_ not recognized as INTVAL, FLOATVAL, STRING, or PMC"; } sub convert_pcc_sigtype { my %sigtype = ('P' => 'pmc', 'S' => 'string', 'I' => 'integer', 'N' => 'number'); return $sigtype{$_[0]}; } sub gen_arg_pcc_sig { my ($param) = @_; return 'Ip' if exists $param->{attrs}{opt_flag}; my $sig = $reg_type_info->{ $param->{type} }->{pcc}; $sig .= 'c' if exists $param->{attrs}{constant}; $sig .= 'f' if exists $param->{attrs}{flatten}; $sig .= 'i' if exists $param->{attrs}{invocant}; $sig .= 'l' if exists $param->{attrs}{lookahead}; $sig .= 'n' if (exists $param->{attrs}{name} || exists $param->{attrs}{named}); $sig .= 'o' if exists $param->{attrs}{optional}; $sig .= 'p' if exists $param->{attrs}{opt_flag}; $sig .= 's' if exists $param->{attrs}{slurpy}; return $sig; } =head3 C Rewrites the method body performing the various macro substitutions for RETURNs. =cut sub rewrite_RETURNs { my ( $method, $pmc ) = @_; my $method_name = $method->name; my $body = $method->body; my $wb = $method->attrs->{manual_wb} ? '' : 'PARROT_GC_WRITE_BARRIER(interp, _self);'; my $result; my $signature_re = qr/ (RETURN #method name \s* #optional whitespace \( ([^\(]*) \) #returns ( type... var) ;?) #optional semicolon /sx; croak "return not allowed in pccmethods, use RETURN instead $body" if !$method->is_vtable and $wb and $body and $body =~ m/\breturn\b.*?;\z/s; while ($body) { my $matched; if ($body) { $matched = $body->find($signature_re); last unless $matched; } $matched =~ /$signature_re/; my ( $match, $returns ) = ( $1, $2 ); my $e = Parrot::Pmc2c::Emitter->new( $pmc->filename(".c") ); if ($returns eq 'void') { if ($wb) { $e->emit( <<"END" ); { $wb return; } END } else { $e->emit( <<"END" ); return; END } $matched->replace( $match, $e ); $result = 1; next; } my $goto_string = "goto ${method_name}_returns;"; my ( $returns_signature, $returns_varargs ) = process_pccmethod_args( parse_p_args_string($returns), 'return' ); my $rettype; if ($returns_signature and !$method->is_vtable) { my $type = convert_pcc_sigtype($returns_signature); unless ($type) { # Fallback to slow arg filling. Currently only "II" with FileHandle.tell $e->emit( <<"END" ); { /*BEGIN RETURN $returns */ Parrot_pcc_set_call_from_c_args(interp, _call_object, "$returns_signature", $returns_varargs); $wb return; } /*END RETURN $returns */ END $matched->replace( $match, $e ); $result = 1; next; } $e->emit( <<"END" ); { VTABLE_set_${type}_keyed_int(interp, _call_object, 0, $returns_varargs); $wb return; } END } elsif ($wb) { # if ($returns_signature) block needed $e->emit( <<"END" ); { $wb return $returns_varargs; } END } else { # no block needed $e->emit( <<"END" ); return $returns_varargs; END } $matched->replace( $match, $e ); $result = 1; } return $result; } # This doesn't handle "const PMC *var", but "PMC *const var" sub parse_p_args_string { my ($parameters) = @_; my $linear_args = []; for my $x ( split /,/, $parameters ) { #change 'PMC * foo' to 'PMC *foo' $x =~ s/\*\s+/\*/ if ($x =~ /\s\*+\s/); #change 'PMC* foo' to 'PMC *foo' $x =~ s/(\*+)\s+/ $1/ if ($x =~ /^\w+\*/); my ( $type, $name, $rest ) = split /\s+/, trim($x), 3; # 'PMC *const ret' if ($rest and $rest !~ /^:/) { # handle const volatile or such $type .= " ".$name; ($name, $rest) = split /\s+/, trim($rest), 2; } die "invalid PCC arg '$x': did you forget to specify a type?\n" unless defined $name; $name =~ s/^\*//g; my $arg = { type => convert_type_string_to_reg_type($type), name => $name, attrs => parse_adverb_attributes($rest) }; push @$linear_args, $arg; } $linear_args; } sub is_named { my ($arg) = @_; while ( my ( $k, $v ) = each( %{ $arg->{attrs} } ) ) { return ( 1, $1 ) if $k =~ /named\((.*)\)/; } return ( 0, '' ); } sub process_pccmethod_args { my ( $linear_args, $arg_type ) = @_; my $args = [ [], [], [], [] ]; # actual INT, FLOAT, STRING, PMC my $signature = ""; my @vararg_list = (); my $varargs = ""; my $declarations = ""; for my $arg (@$linear_args) { my ( $named, $named_name ) = is_named($arg); my $type = $arg->{type}; my $name = $arg->{name}; if ($named) { my $tis = $reg_type_info->{+(REGNO_STR)}{s}; #reg_type_info string my $dummy_name = "_param_name_str_". $named_name; $dummy_name =~ s/"//g; my $argn = { type => +(REGNO_STR), name => $named_name, }; $arg->{named_arg} = $argn; $arg->{named_name} = $named_name; push @{ $args->[ +(REGNO_STR) ] }, $argn; $signature .= 'Sn'; $declarations .= "$tis $dummy_name = CONST_STRING_GEN(interp, $named_name);\n"; push @vararg_list, "&$dummy_name"; } push @{ $args->[ $type ] }, $arg; $signature .= gen_arg_pcc_sig($arg); if ( $arg_type eq 'arg' ) { my $tis = $reg_type_info->{$type}{"s"}; #reg_type_info string $declarations .= "$tis $name;\n" unless $arg->{already_declared}; push @vararg_list, "&$name"; } elsif ( $arg_type eq 'return' ) { my $typenamestr = $reg_type_info->{$type}{s}; push @vararg_list, "($typenamestr)$name"; } } $varargs = join ", ", @vararg_list; return ( $signature, $varargs, $declarations ); } =head3 C rewrite_pccmethod($method, $pmc); =cut sub rewrite_pccmethod { my ( $method, $pmc ) = @_; my $e = Parrot::Pmc2c::Emitter->new( $pmc->filename(".c") ); my $e_post = Parrot::Pmc2c::Emitter->new( $pmc->filename(".c") ); # parse pccmethod parameters, then unshift the PMC arg for the invocant my $linear_args = parse_p_args_string( $method->parameters ); unshift @$linear_args, { type => convert_type_string_to_reg_type('PMC'), name => '_self', attrs => parse_adverb_attributes(':invocant'), already_declared => 1, }; # The invocant is already passed in the C signature, why pass it again? my ( $params_signature, $params_varargs, $params_declarations ) = process_pccmethod_args( $linear_args, 'arg' ); my $wb = $method->attrs->{manual_wb} ? '' : 'PARROT_GC_WRITE_BARRIER(interp, _self);'; rewrite_RETURNs( $method, $pmc ); rewrite_pccinvoke( $method, $pmc ); $e->emit( <<"END"); PMC * const _ctx = CURRENT_CONTEXT(interp); PMC * const _call_object = Parrot_pcc_get_signature(interp, _ctx); /* BEGIN PARAMS SCOPE */ END $params_declarations =~ s/\n/\n /g; $e->emit(<<"END"); $params_declarations END # SKIP fast code for c,f,l,n,s arg adverbs if ($params_signature and $params_signature !~ /[cflns]/) { # new fast branch my @params_vararg_list = split(/, &/, substr($params_varargs, 1)); my ($arg_index, $list_index, $i) = (0, 0, 0); # run-time arity-check: error if too many or too less args given. # cost of the 2 if's: 4.4% in parrot-bench my ($arity, $arity_opt) = (0, 0); $params_signature =~ s/([PSIN])/$arity++; $1/ge; $arity_opt = $params_signature =~ tr/o/o/; $arity -= $arity_opt; $arity -= $params_signature =~ tr/p/p/; if ($arity_opt) { # slow checks $e->emit( <<"END"); const INTVAL arity = $arity; /* \"$params_signature\" */ const INTVAL arity_opt = $arity_opt; INTVAL param_count = VTABLE_elements(interp, _call_object); if (param_count < arity) Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, "too few arguments: %d passed, %d expected", param_count, arity); if (param_count > arity + arity_opt) Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, "too many arguments: %d passed, %d expected", param_count, arity + arity_opt); END } else { # only one check $e->emit( <<"END"); const INTVAL arity = $arity; /* \"$params_signature\" */ INTVAL param_count = VTABLE_elements(interp, _call_object); if (param_count != arity) Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, "wrong number of arguments: %d passed, %d expected", param_count, arity); END } # TODO: handle c for constant while ($i < length($params_signature)) { my $sig = substr($params_signature, $i, 1); my $sig2 = substr($params_signature, $i+1, 1); my $type = convert_pcc_sigtype($sig); $i++; if ($type) { if ($sig2 eq "o") { # for :optional $e->emit( " if (param_count > $list_index) {\n " ); } $e->emit( <<"END"); $params_vararg_list[$arg_index] = VTABLE_get_${type}_keyed_int(interp, _call_object, $list_index); END if ($sig2 eq "o") { # for :optional my $opt_arg = $params_vararg_list[$arg_index]; my $null_def = { 'P' => 'PMCNULL', 'S' => 'STRINGNULL', 'I' => '0', 'N' => '0.0' }; my $def = $null_def->{$sig}; if (substr($params_signature, $i, 3) eq "oIp") { # and set :opt_flag my $opt_flag = $params_vararg_list[$arg_index + 1]; $arg_index++; $list_index++; $i += 2; $e->emit( <<"END"); $opt_flag = 1; } else { $opt_arg = $def; $opt_flag = 0; } END } else { # no :opt_flag, only :optional $e->emit( <<"END"); } else { $opt_arg = $def; } END } $i++; } $arg_index++; $list_index++ unless $sig2 eq "o"; } elsif ($sig eq 'i' # for invocant and $params_vararg_list[$arg_index - 1] eq '_self' and substr($params_signature, $i-2, 1) eq 'P') { } else { warn "Warning: ".$pmc->name.".".$method->name."(\"$params_signature\"): unhandled arg adverb $sig for $params_vararg_list[$arg_index - 1]"; $e->emit( <<"END"); /* unhandled $sig for $params_vararg_list[$arg_index - 1] */ END } } } elsif ($params_signature) { # the old slow branch $e->emit( <<"END"); Parrot_pcc_fill_params_from_c_args(interp, _call_object, "$params_signature", $params_varargs); END } $e->emit( <<'END' ); { /* BEGIN PMETHOD BODY */ END $e_post->emit( <<"END"); } /* END PMETHOD BODY */ $wb /* END PARAMS SCOPE */ return; END $method->return_type('void'); $method->parameters(''); my $e_body = Parrot::Pmc2c::Emitter->new( $pmc->filename ); $e_body->emit($e); $e_body->emit( $method->body ); $e_body->emit($e_post); $method->body($e_body); $method->{PCCMETHOD} = 1; return 1; } sub rewrite_pccinvoke { my ( $method, $pmc ) = @_; my $body = $method->body; my $signature_re = qr{ ( ( \( ([^\(]*) \) # results \s* # optional whitespace = # results equals PCCINVOKE invocation \s* # optional whitespace )? # results are optional \b # exclude Parrot_pcc_invoke_method_from_c_args when lacking optional capture PCCINVOKE # method name \s* # optional whitespace \( ([^\(]*) \) # parameters ;? # optional semicolon ) }sx; while ($body) { my $matched; if ($body) { $matched = $body->find($signature_re); last unless $matched; } $matched =~ /$signature_re/; my ( $match, $result_clause, $results, $parameters ) = ( $1, $2, $3, $4 ); my ($out_vars, $out_types) = process_pccmethod_results( $results ); my ($fixed_params, $in_types, $in_vars) = process_pccmethod_parameters( $parameters ); my $signature = $in_types . '->' . $out_types; # I know this is ugly.... my $vars = ''; if ($in_vars) { $vars .= $in_vars; $vars .= ', ' if $out_vars; } $vars .= $out_vars; my $e = Parrot::Pmc2c::Emitter->new( $pmc->filename ); $e->emit(qq|Parrot_pcc_invoke_method_from_c_args($fixed_params, "$signature", $vars);\n|); $matched->replace( $match, $e ); } return 1; } sub process_pccmethod_results { my $results = shift; return ('', '') unless $results; my @params = split /,\s*/, $results; my (@out_vars, @out_types); for my $param (@params) { my ($type, @names) = process_parameter($param); push @out_types, $type; push @out_vars, map { "&$_" } @names; } my $out_types = join '', @out_types; my $out_vars = join ', ', @out_vars; return ($out_vars, $out_types); } sub process_pccmethod_parameters { my $parameters = shift; my ($interp, $pmc, $method, @params) = split /,\s*/, $parameters; $method = 'CONST_STRING_GEN(interp, ' . $method . ')'; my $fixed_params = join ', ', $interp, $pmc, $method; my (@in_types, @in_vars); for my $param (@params) { # @var is an array because named parameters are two variables my ($type, @var) = process_parameter($param); push @in_types, $type; push @in_vars, @var; } my $in_types = join '', @in_types; my $in_vars = join ', ', @in_vars; return ($fixed_params, $in_types, $in_vars); } sub process_parameter { my $param = shift; my $param_re = qr{ (STRING\s\*|INTVAL|FLOATVAL|PMC\s\*) # type \s* # optional whitespace (\w+) # name \s* # optional whitespace (.*)? # adverbs }sx; my ($type, $name, $adverbs) = $param =~ /$param_re/; # the first letter of the type is the type in the signature $type = substr $type, 0, 1; my $adverb_re = qr{ : # leading colon (\w+) # name (?: # optional argument \(" (\w+) "\) ) \s* }sx; my %allowed_adverbs = ( named => 'n', flatten => 'f', slurpy => 's', optional => 'o', opt_flag => 'p', ); my @arg_names = ($name); while (my ($name, $argument) = $adverbs =~ /$adverb_re/g) { next unless my $type_mod = $allowed_adverbs{$name}; $type .= $type_mod; next unless $type eq 'named'; push @arg_names, qq|CONST_STRING_GEN(interp, "$argument")|; } return ($type, @arg_names); } =head3 C B Parse and Build PMC multiple dispatch subs. B =over 4 =item * C =item * C Current Method Object =item * C Current Method Body =back =cut sub rewrite_multi_sub { my ( $method, $pmc ) = @_; my @param_types = (); my @new_params = (); # Fixup the parameters, standardizing PMC types and extracting type names # for the multi name. for my $param ( split /,/, $method->parameters ) { my ( $type, $name, $rest ) = split /\s+/, &Parrot::Pmc2c::PCCMETHOD::trim($param), 3; die "Invalid MULTI parameter '$param': missing type or name\n" unless defined $name; die "Invalid MULTI parameter '$param': attributes not allowed on multis\n" if defined $rest; # Clean any '*' out of the name or type. if ($name =~ /[\**]?(\"?\w+\"?)/) { $name = $1; } $type =~ s/\*+//; # Capture the actual type for the sub name push @param_types, $type; # Pass standard parameter types unmodified. # All other param types are rewritten as PMCs. if ($type eq 'STRING' or $type eq 'PMC' or $type eq 'INTVAL') { push @new_params, $param; } elsif ($type eq 'FLOATVAL') { push @new_params, $param; } else { push @new_params, "PMC *$name"; } } $method->parameters(join (",", @new_params)); $method->{MULTI_sig} = [@param_types]; $method->{MULTI_full_sig} = join(',', @param_types); $method->{MULTI} = 1; return 1; } sub mangle_name { my ( $method ) = @_; $method->symbol( $method->name ); $method->name( $method->type eq Parrot::Pmc2c::Method::MULTI() ? (join '_', 'multi', $method->name, @{ $method->{MULTI_sig} }) : "nci_@{[$method->name]}" ); } 1; # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: time.t000644000765000765 674112101554067 15070 0ustar00bruce000000000000parrot-6.6.0/t/dynoplibs#!./parrot # Copyright (C) 2010, Parrot Foundation. =head1 NAME t/dynoplibs/time.t - Time Dynops =head1 DESCRIPTION This PIR code implements time dynops. =cut .loadlib 'sys_ops' .sub main :main .include 'test_more.pir' plan(19) test_gmtime_s_i() test_decodetime_p_i() test_localtime_s_i() test_decodelocaltime_p_i() test_gmtime_s_ic() test_time_n_vs_time_ic() test_decodetime_p_ic() test_localtime_s_ic() test_decodelocaltime_p_ic() .end .sub test_gmtime_s_i $I1 = 0 $S0 = gmtime $I1 $I0 = isnull $S0 is($I0, 0, "gmtime string is not null") is($S0, "Thu Jan 1 00:00:00 1970\n", "correct epoch") $I1 = length $S0 is($I1, 25, "string is the correct length") .end .sub test_decodetime_p_i $I1 = 0 $P0 = decodetime $I1 $I0 = $P0 is($I0, 9, "decodetime result has 9 values") $S0 = typeof $P0 # TODO: Actually, this should return whatever HLL type replaces # FixedIntegerArray. We should test this behavior with a new HLL is($S0, "FixedIntegerArray", "decodetime returns the correct PMC type") .end .sub test_localtime_s_i $I1 = 0 $S0 = localtime $I1 $I0 = isnull $S0 is($I0, 0, "localtime string is not a null string") $I0 = length $S0 is($I0, 25, "localtime string is the correct length") .end .sub test_decodelocaltime_p_i $I1 = 0 $P0 = decodelocaltime $I1 $I0 = $P0 is($I0, 9, "decodelocaltime result has 9 values") $S0 = typeof $P0 # TODO: Actually, this should return whatever HLL type replaces # FixedIntegerArray. We should test this behavior with a new HLL is($S0, "FixedIntegerArray", "decodelocaltime returns the correct PMC type") .end .sub test_gmtime_s_ic $S0 = gmtime 0 $I0 = isnull $S0 is($I0, 0, "gmtime string is not null") is($S0, "Thu Jan 1 00:00:00 1970\n", "correct epoch") $I1 = length $S0 is($I1, 25, "string is the correct length") .end .sub test_time_n_vs_time_ic .local int time_int time_int = time .local num time_float time_float = time # check if time_float is within [time_int - 5;time_int + 5] .local int time_int_lower time_int_lower = time_int - 5 if time_float < time_int_lower goto FAIL .local int time_int_upper time_int_upper = time_int + 5 if time_float > time_int_upper goto FAIL ok(1, "time_n value corresponds to time_i value") .return() FAIL: ok(0, "time_n value does not correspond to time_t value") .return() .end .sub test_decodetime_p_ic $P0 = decodetime 0 $I0 = $P0 is($I0, 9, "decodetime result has 9 values") $S0 = typeof $P0 # TODO: Actually, this should return whatever HLL type replaces # FixedIntegerArray. We should test this behavior with a new HLL is($S0, "FixedIntegerArray", "decodetime returns the correct PMC type") .end .sub test_localtime_s_ic $S0 = localtime 0 $I0 = isnull $S0 is($I0, 0, "localtime string is not a null string") $I0 = length $S0 is($I0, 25, "localtime string is the correct length") .end .sub test_decodelocaltime_p_ic $P0 = decodelocaltime 0 $I0 = $P0 is($I0, 9, "decodelocaltime result has 9 values") $S0 = typeof $P0 # TODO: Actually, this should return whatever HLL type replaces # FixedIntegerArray. We should test this behavior with a new HLL is($S0, "FixedIntegerArray", "decodelocaltime returns the correct PMC type") .end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: Headerizer.pm000644000765000765 5706712101554067 16163 0ustar00bruce000000000000parrot-6.6.0/lib/Parrot# Copyright (C) 2004-2012, Parrot Foundation. package Parrot::Headerizer; =head1 NAME Parrot::Headerizer - Parrot header generation functionality =head1 SYNOPSIS use Parrot::Headerizer; $headerizer = Parrot::Headerizer->new( { macro_match => $macro_match, # optional } ); $headerizer->get_sources(@ofiles); $headerizer->process_sources(); $headerizer->print_final_message(); $headerizer->print_warnings(); @function_decls = $headerizer->extract_function_declarations($buf); $escaped_decl = $headerizer->generate_documentation_signature($function_decl); =head1 DESCRIPTION C knows how to extract all kinds of information out of C-language files. Its methods are used in F and F. =head1 METHODS =cut use strict; use warnings; use Data::Dumper;$Data::Dumper::Indent=1; use Scalar::Util qw( reftype ); use lib qw( lib ); use Parrot::Config; use Parrot::Headerizer::Functions qw( read_file write_file qualify_sourcefile replace_pod_item no_both_PARROT_EXPORT_and_PARROT_INLINE validate_prototype_args no_both_static_and_PARROT_EXPORT handle_split_declaration clean_args_for_declarations handle_modified_args add_newline_if_multiline add_asserts_to_declarations func_modifies add_headerizer_markers ); =head2 C =over 4 =item * Purpose Constructor of headerizer object. The object is initialized with a list of valid C macros. =item * Arguments $headerizer = Parrot::Headerizer->new(); No mandatory arguments, but one special use-case takes a hash reference. $headerizer = Parrot::Headerizer->new( { macro_match => $macro_match, # optional } ); Currently, the only meaningful element in that hash reference is C. See C below for discussion of how that is used. =item * Return Value Parrot::Headerizer object. =back =cut sub new { my ($class, $args) = @_; if (defined $args) { die 'Argument to Parrot::Headerizer must be hashref' unless reftype($args) eq 'HASH'; } else { $args = {}; } $args->{macro_match} = undef unless defined $args->{macro_match}; $args->{warnings} = {}; $args->{message} = ''; $args->{valid_macros} = { map { ( $_, 1 ) } qw( PARROT_EXPORT PARROT_INLINE PARROT_NOINLINE PARROT_CAN_RETURN_NULL PARROT_CANNOT_RETURN_NULL PARROT_IGNORABLE_RESULT PARROT_WARN_UNUSED_RESULT PARROT_PURE_FUNCTION PARROT_CONST_FUNCTION PARROT_DOES_NOT_RETURN PARROT_DOES_NOT_RETURN_WHEN_FALSE PARROT_MALLOC PARROT_OBSERVER PARROT_HOT PARROT_COLD PARROT_API PARROT_NO_ADDRESS_SAFETY_ANALYSIS ) }; return bless $args, $class; } =head2 C =over 4 =item * Purpose Identify the source code files which need to have header information extracted. The header information is extracted and stored inside the headerizer object in appropriate ways. =item * Arguments $headerizer->get_sources(@ofiles); List of names of C object (C<.o>) files. =item * Return Value No defined return value. =back =cut sub get_sources { my $self = shift; my @ofiles = @_; my %sourcefiles; my %sourcefiles_with_statics; my %api; # Walk the object files and find corresponding source (either .c or .pmc) for my $ofile (@ofiles) { # Skip files in the src/ops/ subdirectory. next if $ofile =~ m/^\Qsrc$PConfig{slash}ops\E/ || # if run by hand... $ofile =~ m{^src/ops}; # ... or by makefile $ofile =~ s{\\}{/}g; # Normalize path separators my $is_yacc = ($ofile =~ /\.y$/); if ( !$is_yacc ) { my $sfile = $ofile; $sfile =~ s/\Q$PConfig{o}\E$/.s/; next if -f $sfile; } my ($sourcefile, $source_code, $hfile) = qualify_sourcefile( { ofile => $ofile, PConfig => \%PConfig, is_yacc => $is_yacc, } ); my @decls; if ( $self->{macro_match} ) { @decls = $self->extract_function_declarations( $source_code ); } else { @decls = $self->extract_function_declarations_and_update_source( $sourcefile ); } for my $decl (@decls) { my $components = $self->function_components_from_declaration( $sourcefile, $decl ); push( @{ $sourcefiles{$hfile}->{$sourcefile} }, $components ) unless $hfile eq 'none'; push( @{ $sourcefiles_with_statics{$sourcefile} }, $components ) if $components->{is_static}; if ( $self->{macro_match} ) { if ( grep { $_ eq $self->{macro_match} } @{$components->{macros}} ) { push( @{ $api{$sourcefile} }, $components ); } } } } # for @cfiles $self->{sourcefiles} = \%sourcefiles; $self->{sourcefiles_with_statics} = \%sourcefiles_with_statics; $self->{api} = \%api; } =head2 C =over 4 =item * Purpose Extracts the function declarations from the text argument, and returns an array of strings containing the function declarations. =item * Arguments @function_decls = $headerizer->extract_function_declarations($text) String holding the slurped-in content of a source code file. =item * Return Value List of strings holding function declarations. =item * Comment Called within C, but also called on its own within F. =back =cut sub extract_function_declarations { my $self = shift; my $text = shift; # Only check the YACC C code if we find what looks like YACC file $text =~ s/%\{(.*)%\}.*/$1/sm; # Drop all text after HEADERIZER STOP $text =~ s{/\*\s*HEADERIZER STOP.+}{}s; # Drop begin/end PMC HEADER sections $text =~ s{BEGIN_PMC_HEADER_PREAMBLE}{}sx; $text =~ s{END_PMC_HEADER_PREAMBLE}{}sx; # Strip blocks of comments $text =~ s{^/\*.*?\*/}{}mxsg; # Strip # compiler directives $text =~ s{^#(\\\n|.)*}{}mg; # Strip code blocks $text =~ s/^{.+?^}//msg; # Split on paragraphs my @funcs = split /\n{2,}/, $text; # If it doesn't start in the left column, it's not a func @funcs = grep { /^\S/ } @funcs; # Typedefs, enums and externs are no good @funcs = grep { !/^(?:typedef|enum|extern)\b/ } @funcs; # Structs are OK if they're not alone on the line @funcs = grep { !/^struct.+;\n/ } @funcs; # Structs are OK if they're not being defined @funcs = grep { !/^(?:static\s+)?struct.+{\n/ } @funcs; # Ignore magic function name YY_DECL @funcs = grep { !/YY_DECL/ } @funcs; # Ignore anything with magic words HEADERIZER SKIP @funcs = grep { !m{/\*\s*HEADERIZER SKIP\s*\*/} } @funcs; # pmclass declarations in PMC files are no good @funcs = grep { !m{^pmclass } } @funcs; # Variables are of no use to us @funcs = grep { !/=/ } @funcs; # Get rid of any blocks at the end s/\s*{.*//s for @funcs; # Toast anything non-whitespace @funcs = grep { /\S/ } @funcs; # If it's got a semicolon, it's not a function header @funcs = grep { !/;/ } @funcs; # remove any remaining }'s @funcs = grep {! /^}/} @funcs; chomp @funcs; return @funcs; } =head2 C =over 4 =item * Purpose Extract all the function declarations from a source code file and update the comment blocks within it. =item * Arguments @function_declarations = $headerizer->extract_function_declaration_and_update_source($cfile_name); String holding source code filename. =item * Return Value List of strings holding function declarations. =item * Comment Called within C. Wraps around C but differs from that method by generating signatures, correcting POD, etc. =back =cut sub extract_function_declarations_and_update_source { my $self = shift; my $cfile_name = shift; open( my $fhin, '<', $cfile_name ) or die "Can't open $cfile_name: $!"; my $text = join( '', <$fhin> ); close $fhin; my @func_declarations = $self->extract_function_declarations( $text ); for my $decl ( @func_declarations ) { my $specs = $self->function_components_from_declaration( $cfile_name, $decl ); my $name = $specs->{name}; my $heading = $self->generate_documentation_signature($decl); $text = replace_pod_item( { text => $text, name => $name, heading => $heading, cfile_name => $cfile_name, } ); } open( my $fhout, '>', $cfile_name ) or die "Can't create $cfile_name: $!"; print {$fhout} $text; close $fhout; return @func_declarations; } =head2 C =over 4 =item * Purpose Creates a data structure in which information about a particular function can be looked up. =item * Arguments List of two strings, the filename and the function declaration. =item * Return Value Returns a reference to a hash of these function components: file name args macros is_static is_inline is_api is_ignorable return_type =item * Comment Currently called within both C and C. =back =cut sub function_components_from_declaration { my $self = shift; my $file = shift; my $proto = shift; my @lines = split( /\n/, $proto ); chomp @lines; my @macros; my $parrot_api; my $parrot_inline; while ( @lines && ( $lines[0] =~ /^PARROT_/ ) ) { my $macro = shift @lines; if ( $macro eq 'PARROT_EXPORT' ) { $parrot_api = 1; } elsif ( $macro eq 'PARROT_INLINE' ) { $parrot_inline = 1; } push( @macros, $macro ); } my $return_type = shift @lines; my $args = join( ' ', @lines ); $args =~ s/\s+/ /g; $args =~ s{([^(]+)\s*\((.+)\);?}{$2} or die qq{Couldn't handle "$proto" in $file\n}; my $name = $1; $args = $2; no_both_PARROT_EXPORT_and_PARROT_INLINE( { file => $file, name => $name, parrot_inline => $parrot_inline, parrot_api => $parrot_api, } ); my @args = validate_prototype_args( $args, $proto ); my $is_static; ($return_type, $is_static) = no_both_static_and_PARROT_EXPORT( { file => $file, name => $name, return_type => $return_type, parrot_api => $parrot_api, } ); my $is_ignorable = 0; my %macros; for my $macro (@macros) { $macros{$macro} = 1; if (not $self->valid_macro($macro)) { $self->squawk( $file, $name, "Invalid macro $macro" ); } if ( $macro eq 'PARROT_IGNORABLE_RESULT' ) { $is_ignorable = 1; } } $self->check_pointer_return_type( { return_type => $return_type, macros => \%macros, name => $name, file => $file, } ); return { file => $file, name => $name, args => \@args, macros => \@macros, is_static => $is_static, is_inline => $parrot_inline, is_api => $parrot_api, is_ignorable => $is_ignorable, return_type => $return_type, }; } =head2 C =over 4 =item * Purpose Performs some validation in the case where a function's return value is a pointer. =item * Arguments $headerizer->check_pointer_return_type( { return_type => $return_type, macros => \%macros, name => $name, file => $file, } ); Reference to a hash with the four elements listed above. =item * Return Value No defined return value. =back =cut sub check_pointer_return_type { my ($self, $args) = @_; if ( $args->{return_type} =~ /\*/ ) { if ( !$args->{macros}->{PARROT_CAN_RETURN_NULL} && !$args->{macros}->{PARROT_CANNOT_RETURN_NULL} ) { if ( $args->{name} !~ /^yy/ ) { # Don't complain about lexer-created functions $self->squawk( $args->{file}, $args->{name}, 'Returns a pointer, but no PARROT_CAN(NOT)_RETURN_NULL macro found.' ); } } elsif ( $args->{macros}->{PARROT_CAN_RETURN_NULL} && $args->{macros}->{PARROT_CANNOT_RETURN_NULL} ) { $self->squawk( $args->{file}, $args->{name}, q{Can't have both PARROT_CAN_RETURN_NULL and PARROT_CANNOT_RETURN_NULL together.} ); } } } =head2 C =over 4 =item * Purpose Given an extracted function signature, return a modified version suitable for inclusion in POD documentation. =item * Arguments $heading = $headerizer->generate_documentation_signature($decl); String holding a function declaration. =item * Return Value String holding a function header, split over multiple lines as needed. =back =cut sub generate_documentation_signature { my $self = shift; my $function_decl = shift; # strip out any PARROT_* function modifiers foreach my $key ($self->valid_macros) { $function_decl =~ s/^$key$//m; } $function_decl =~ s/^\s+//g; $function_decl =~ s/\s+/ /g; # strip out any ARG* modifiers $function_decl =~ s/ARG(?:IN|IN_NULLOK|OUT|OUT_NULLOK|MOD|MOD_NULLOK|FREE|FREE_NOTNULL)\((.*?)\)/$1/g; # strip out the SHIM modifier $function_decl =~ s/SHIM\((.*?)\)/$1/g; # strip out the NULL modifiers $function_decl =~ s/(?:NULLOK|NOTNULL)\((.*?)\)/$1/g; # SHIM_INTERP is still a PARROT_INTERP $function_decl =~ s/SHIM_INTERP/PARROT_INTERP/g; # wrap with POD $function_decl = "=item C<$function_decl>"; # Wrap long lines. my $line_len = 80; if (length($function_decl)<= $line_len) { return $function_decl; } else { return handle_split_declaration( $function_decl, $line_len, ); } } =head2 C =over 4 =item * Purpose Tests the validity of a given macro. =item * Arguments $headerizer->valid_macro( $macro ) String holding a macro. =item * Return Value Boolean: true value for valid macro; false value for invalid macro. =back =cut sub valid_macro { my $self = shift; my $macro = shift; return exists $self->{valid_macros}{$macro}; } =head2 C =over 4 =item * Purpose Identify all valid macros whose names are of the form C. =item * Arguments @marcros = $headerizer->valid_macros(); None. =item * Return Value List of all the valid C macros. =back =cut sub valid_macros { my $self = shift; my @macros = sort keys %{$self->{valid_macros}}; return @macros; } =head2 C =over 4 =item * Purpose Builds a data structure with headerizer-specific ways of complaining if something went wrong. =item * Arguments $headerizer->squawk($file, $func, $error); List of 3 arguments: the file containing the error; the function containing the error; the text of the error message. =item * Return Value Undefined value. =item * Comment C does not print any warnings or errors itself. Use C to report those. =back =cut sub squawk { my $self = shift; my $file = shift; my $func = shift; my $error = shift; push( @{ $self->{warnings}{$file}{$func} }, $error ); return; } =head2 C =over 4 =item * Purpose Once the source files needing headerization have been identified, this method serves as a wrapper around that headerization. Both C<.h> and C<.c> files are handled. =item * Arguments None. =item * Return Value None. =item * Comment If a hash reference with an element named C was passed to C, C merely prints to C a list of files and functions using the macro named as the value of that element. No headerization or revision of headers is performed. =back =cut sub process_sources { my ($self) = @_; my %sourcefiles = %{$self->{sourcefiles}}; my %sourcefiles_with_statics = %{$self->{sourcefiles_with_statics}}; my %api = %{$self->{api}}; if ( $self->{macro_match} ) { my $nfuncs = 0; for my $cfile ( sort keys %api ) { my @funcs = sort { $a->{name} cmp $b->{name} } @{$api{$cfile}}; print "$cfile\n"; for my $func ( @funcs ) { print " $func->{name}\n"; ++$nfuncs; } } my $s = $nfuncs == 1 ? '' : 's'; $self->{message} = "$nfuncs $self->{macro_match} function$s"; } # Normal headerization and updating else { # Update all the .h files for my $hfile ( sort keys %sourcefiles ) { my $sourcefiles = $sourcefiles{$hfile}; my $header = read_file($hfile); for my $cfile ( sort keys %{$sourcefiles} ) { my @funcs = @{ $sourcefiles->{$cfile} }; @funcs = grep { not $_->{is_static} } @funcs; # skip statics $header = $self->replace_headerized_declarations( $header, $cfile, $hfile, @funcs ); } write_file( $hfile, $header ); } # Update all the .c files in place for my $cfile ( sort keys %sourcefiles_with_statics ) { my @funcs = @{ $sourcefiles_with_statics{$cfile} }; @funcs = grep { $_->{is_static} } @funcs; my $source = read_file($cfile); $source = $self->replace_headerized_declarations( $source, 'static', $cfile, @funcs ); write_file( $cfile, $source ); } $self->{message} = "Headerization complete."; } } =head2 C =over 4 =item * Purpose =item * Arguments =item * Return Value =back =cut sub replace_headerized_declarations { my $self = shift; my $source_code = shift; my $sourcefile = shift; my $hfile = shift; my @funcs = @_; # Allow a way to not headerize statics if ( $source_code =~ m{/\*\s*HEADERIZER NONE:\s*$sourcefile\s*\*/} ) { return $source_code; } @funcs = sort { ( ( $b->{is_api} || 0 ) <=> ( $a->{is_api} || 0 ) ) || ( ( lc($a->{name}) || '') cmp ( lc($b->{name}) || '') ) } @funcs; my @function_decls = $self->make_function_decls(@funcs); my $markers_args = { function_decls => \@function_decls, sourcefile => $sourcefile, hfile => $hfile, code => $source_code, }; return add_headerizer_markers( $markers_args ); } =head2 C =over 4 =item * Purpose Composes proper function declarations. =item * Arguments @function_decls = $self->make_function_decls(@funcs); List of functions. =item * Return Value List of function declarations. =item * Comment Called within C. =back =cut sub make_function_decls { my $self = shift; my @funcs = @_; my @decls; foreach my $func (@funcs) { my $alt_void = ' '; # Splint can't handle /*@alt void@*/ on pointers, although this page # http://www.mail-archive.com/lclint-interest@virginia.edu/msg00139.html # seems to say that we can. if ( $func->{is_ignorable} && ($func->{return_type} !~ /\*/) ) { $alt_void = " /*\@alt void@*/\n"; } my $decl = sprintf( "%s%s%s(" => ( $func->{return_type}, $alt_void, $func->{name} ) ); $decl = "static $decl" if $func->{is_static}; my @args = @{ $func->{args} }; my @attrs = $self->attrs_from_args( $func, @args ); my @modified_args = clean_args_for_declarations($func, \@args); my $multiline; ($decl, $multiline) = handle_modified_args($decl, \@modified_args); my $attrs = join( "", map { "\n\t\t$_" } @attrs ); if ($attrs) { $decl .= $attrs; $multiline = 1; } my @macros = @{ $func->{macros} }; $multiline = 1 if @macros; $decl = add_newline_if_multiline($decl, $multiline); $decl = join( "\n", @macros, $decl ); $decl =~ s/\t/ /g; push( @decls, $decl ); } @decls = add_asserts_to_declarations( \@funcs, \@decls ); return @decls; } =head2 C =over 4 =item * Purpose Adds to headers strings of the form C<__attribute__nonnull__(1)>. =item * Arguments @attrs = $headerizer->attrs_from_args( $func, @args ); List whose first element is a hash reference holding characteristics about a given function, followed by list of arguments. =item * Return Value List. =item * Comment Called within C. =back =cut sub attrs_from_args { my $self = shift; my $func = shift; my @args = @_; my @attrs = (); my @mods = (); my $name = $func->{name}; my $file = $func->{file}; my $n = 0; for my $arg (@args) { ++$n; @mods = func_modifies($arg, \@mods); if ( $arg =~ m{(ARGIN|ARGOUT|ARGMOD|ARGFREE_NOTNULL|NOTNULL)\(} || $arg eq 'PARROT_INTERP' ) { push( @attrs, "__attribute__nonnull__($n)" ); } if ( ( $arg =~ m{\*} ) && ( $arg !~ /\b(SHIM|((ARGIN|ARGOUT|ARGMOD)(_NULLOK)?)|ARGFREE(_NOTNULL)?)\b/ ) ) { if ( $name !~ /^yy/ ) { # Don't complain about the lexer auto-generated funcs $self->squawk( $file, $name, qq{"$arg" isn't protected with an ARGIN, ARGOUT or ARGMOD (or a _NULLOK variant), or ARGFREE} ); } } if ( ($arg =~ /\bconst\b/) && ($arg =~ /\*/) && ($arg !~ /\*\*/) && ($arg =~ /\b(ARG(MOD|OUT))\b/) ) { $self->squawk( $file, $name, qq{"$arg" is const, but that $1 conflicts with const} ); } } return (@attrs,@mods); } =head2 C =over 4 =item * Purpose Prints a concluding message whose content reflects either normal headerization or macro matching. =item * Arguments None. =item * Return Value Implicitly returns true value upon success. =back =cut sub print_final_message { my $self = shift; if ($self->{message} ne '') { print "$self->{message}\n"; } } =head2 C =over 4 =item * Purpose Print all warnings accumulated in the course of the headerization process. =item * Arguments None. =item * Return Value Implicitly returns true value upon success. =back =cut sub print_warnings { my $self = shift; my %warnings = %{$self->{warnings}}; if ( keys %warnings ) { my $nwarnings = 0; my $nwarningfuncs = 0; my $nwarningfiles = 0; for my $file ( sort keys %warnings ) { ++$nwarningfiles; print "$file\n"; my $funcs = $warnings{$file}; for my $func ( sort keys %{$funcs} ) { ++$nwarningfuncs; for my $error ( @{ $funcs->{$func} } ) { print " $func: $error\n"; ++$nwarnings; } } } print "$nwarnings warnings in $nwarningfuncs funcs in $nwarningfiles C files\n"; } } 1; # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: nci_pmc.in000644000765000765 3046512356767112 21441 0ustar00bruce000000000000parrot-6.6.0/t/tools/dev/headerizer/testlib/* Copyright (C) 2001-2014, Parrot Foundation. =head1 NAME src/pmc/nci.pmc - Native Call Interface =head1 DESCRIPTION The vtable functions for the native C call functions. =head2 Methods =over 4 =cut */ /* HEADERIZER HFILE: none */ /* HEADERIZER BEGIN: static */ /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */ PARROT_IGNORABLE_RESULT static nci_thunk_t /*@alt void@*/ build_func(PARROT_INTERP, ARGMOD(Parrot_NCI_attributes *nci_info)) __attribute__nonnull__(1) __attribute__nonnull__(2) FUNC_MODIFIES(*nci_info); static void pcc_params(PARROT_INTERP, ARGIN(STRING *sig), ARGMOD(Parrot_NCI_attributes *nci_info), size_t sig_length) __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__nonnull__(3) FUNC_MODIFIES(*nci_info); #define ASSERT_ARGS_build_func __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(nci_info)) #define ASSERT_ARGS_pcc_params __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(sig) \ , PARROT_ASSERT_ARG(nci_info)) /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */ /* HEADERIZER END: static */ /* =item C Check and validate parameter signatures =cut */ static void pcc_params(PARROT_INTERP, ARGIN(STRING *sig), ARGMOD(Parrot_NCI_attributes *nci_info), size_t sig_length) { ASSERT_ARGS(pcc_params) /* NCI and PCC have a 1 to 1 mapping except an extra char in PCC for invocant and slurpy */ size_t buf_length = sig_length + 2 + 1; /* avoid malloc churn on common signatures */ char static_buf[16]; char * const sig_buf = sig_length <= sizeof static_buf ? static_buf : (char *)mem_sys_allocate(buf_length); size_t j = 0; size_t i; for (i = 0; i < sig_length; ++i) { const INTVAL c = STRING_ord(interp, sig, i); PARROT_ASSERT(j < buf_length - 1); switch (c) { case (INTVAL)'0': /* null ptr or such - doesn't consume a reg */ break; case (INTVAL)'f': case (INTVAL)'N': case (INTVAL)'d': sig_buf[j++] = 'N'; break; case (INTVAL)'I': /* INTVAL */ case (INTVAL)'l': /* long */ case (INTVAL)'i': /* int */ case (INTVAL)'s': /* short */ case (INTVAL)'c': /* char */ sig_buf[j++] = 'I'; break; case (INTVAL)'S': case (INTVAL)'t': /* string, pass a cstring */ sig_buf[j++] = 'S'; break; case (INTVAL)'J': /* interpreter */ break; case (INTVAL)'p': /* push pmc->data */ case (INTVAL)'P': /* push PMC * */ case (INTVAL)'V': /* push PMC * */ case (INTVAL)'2': case (INTVAL)'3': case (INTVAL)'4': sig_buf[j++] = 'P'; break; case (INTVAL)'v': /* null return */ if (j == 0) sig_buf[j++] = '\0'; break; case (INTVAL)'O': /* push PMC * invocant */ sig_buf[j++] = 'P'; sig_buf[j++] = 'i'; break; case (INTVAL)'@': /* push PMC * slurpy */ sig_buf[j++] = 'P'; sig_buf[j++] = 's'; break; case (INTVAL)'b': /* buffer (void*) pass Buffer_bufstart(SReg) */ case (INTVAL)'B': /* buffer (void**) pass &Buffer_bufstart(SReg) */ sig_buf[j++] = 'S'; break; default: Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_JIT_ERROR, "Unknown param Signature %c\n", (char)c); break; } } PARROT_ASSERT(j < buf_length); sig_buf[j++] = '\0'; nci_info->pcc_return_signature = Parrot_str_new(interp, sig_buf, 1); nci_info->pcc_params_signature = j > 1 ? Parrot_str_new(interp, sig_buf + 1, j - 1) : CONST_STRING(interp, ""); if (sig_buf != static_buf) mem_sys_free(sig_buf); } /* =item C Actually build the NCI thunk. =cut */ PARROT_IGNORABLE_RESULT static nci_thunk_t build_func(PARROT_INTERP, ARGMOD(Parrot_NCI_attributes *nci_info)) { ASSERT_ARGS(build_func) STRING * const key = nci_info->signature; const size_t key_length = Parrot_str_byte_length(interp, key); pcc_params(interp, key, nci_info, key_length); /* Arity is length of that string minus one (the return type). */ nci_info->arity = key_length - 1; /* Build call function. */ nci_info->fb_info = build_call_func(interp, key); nci_info->func = F2DPTR(VTABLE_get_pointer(interp, nci_info->fb_info)); return (nci_thunk_t)nci_info->func; } pmclass NCI auto_attrs provides invokable { /* NCI thunk handling attributes */ /* NCI thunk handling attributes */ ATTR STRING *signature; /* The signature. */ ATTR void *func; /* Function pointer to call. */ ATTR PMC *fb_info; /* Frame-builder info */ ATTR void *orig_func; /* Function pointer * used to create func */ /* Parrot Sub-ish attributes */ ATTR STRING *pcc_params_signature; ATTR STRING *pcc_return_signature; ATTR INTVAL arity; /* Cached arity of the NCI. */ /* MMD fields */ ATTR STRING *long_signature; /* The full signature. */ ATTR PMC *multi_sig; /* type tuple array (?) */ /* =item C Return the MMD signature PMC, if any or a Null PMC. =cut */ METHOD get_multisig() :no_wb { PMC *sig; GET_ATTR_multi_sig(INTERP, SELF, sig); if (PMC_IS_NULL(sig)) sig = PMCNULL; RETURN(PMC *sig); } /* =item C Initializes the NCI with a C function pointer. =cut */ VTABLE void init() { PObj_custom_mark_SET(SELF); } VTABLE void *get_pointer() :no_wb { return PARROT_NCI(SELF)->orig_func; } /* =item C Sets the specified function pointer and signature (C<*key>). =cut */ VTABLE void set_pointer_keyed_str(STRING *key, void *func) { Parrot_NCI_attributes * const nci_info = PARROT_NCI(SELF); /* Store the original function and signature. */ SET_ATTR_orig_func(INTERP, SELF, func); /* ensure that the STRING signature is constant */ if (!PObj_constant_TEST(key)) { char * const key_c = Parrot_str_to_cstring(INTERP, key); const size_t key_length = Parrot_str_byte_length(interp, key); key = Parrot_str_new_init(interp, key_c, key_length, Parrot_default_encoding_ptr, PObj_constant_FLAG); Parrot_str_free_cstring(key_c); } nci_info->signature = key; } /* =item C Mark any referenced strings and PMCs. =cut */ VTABLE void mark() :no_wb { if (PARROT_NCI(SELF)) { Parrot_NCI_attributes * const nci_info = PARROT_NCI(SELF); Parrot_gc_mark_PMC_alive(interp, nci_info->fb_info); Parrot_gc_mark_PMC_alive(interp, nci_info->multi_sig); Parrot_gc_mark_STRING_alive(interp, nci_info->signature); Parrot_gc_mark_STRING_alive(interp, nci_info->long_signature); Parrot_gc_mark_STRING_alive(interp, nci_info->pcc_params_signature); Parrot_gc_mark_STRING_alive(interp, nci_info->pcc_return_signature); } } /* =item C Creates and returns a clone of the NCI. =cut */ VTABLE PMC *clone() :no_wb { Parrot_NCI_attributes * const nci_info_self = PARROT_NCI(SELF); Parrot_NCI_attributes *nci_info_ret; void *orig_func; PMC * const ret = Parrot_pmc_new(INTERP, SELF->vtable->base_type); nci_info_ret = PARROT_NCI(ret); /* FIXME if data is malloced (JIT/i386!) then we need * the length of data here, to memcpy it * ManagedStruct or Buffer? */ nci_info_ret->func = nci_info_self->func; nci_info_ret->fb_info = nci_info_self->fb_info; nci_info_ret->orig_func = nci_info_self->orig_func; nci_info_ret->signature = nci_info_self->signature; nci_info_ret->pcc_params_signature = nci_info_self->pcc_params_signature; nci_info_ret->pcc_return_signature = nci_info_self->pcc_params_signature; nci_info_ret->arity = nci_info_self->arity; PObj_get_FLAGS(ret) = PObj_get_FLAGS(SELF); return ret; } /* =item C Returns whether the NCI is defined. =cut */ VTABLE INTVAL defined() :no_wb { Parrot_NCI_attributes * const nci_info = PARROT_NCI(SELF); return nci_info->orig_func != NULL; } /* =item C Calls the associated C function, returning C<*next>. If the invocant is a class, the PMC arguments are shifted down. =cut */ VTABLE opcode_t *invoke(void *next) { Parrot_NCI_attributes * const nci_info = PARROT_NCI(SELF); nci_thunk_t func; PMC *fb_info; char *sig_str; void *orig_func; PMC *cont; GET_ATTR_orig_func(INTERP, SELF, orig_func); func = (nci_thunk_t)D2FPTR(nci_info->func); GET_ATTR_fb_info(INTERP, SELF, fb_info); if (!func) { /* build the thunk only when necessary */ func = build_func(interp, nci_info); if (!func) Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_INVALID_OPERATION, "attempt to call NULL function"); } func(INTERP, SELF, fb_info); cont = INTERP->current_cont; /* * If the NCI function was tailcalled, the return result * is already passed back to the caller of this frame * - see Parrot_init_ret_nci(). We therefore invoke the * return continuation here, which gets rid of this frame * and returns the real return address */ if (cont && cont != NEED_CONTINUATION && (PObj_get_FLAGS(cont) & SUB_FLAG_TAILCALL)) { cont = Parrot_pcc_get_continuation(interp, CURRENT_CONTEXT(interp)); next = VTABLE_invoke(INTERP, cont, next); } return (opcode_t *)next; } /* =item C Returns the function pointer as an integer. =cut */ VTABLE INTVAL get_integer() :no_wb { Parrot_NCI_attributes * const nci_info = PARROT_NCI(SELF); if (!nci_info->func) build_func(INTERP, nci_info); return (INTVAL)nci_info->func; } /* =item C Returns the boolean value of the pointer. =cut */ VTABLE INTVAL get_bool() :no_wb { Parrot_NCI_attributes * const nci_info = PARROT_NCI(SELF); return (0 != (INTVAL)nci_info->orig_func); } /* =item C Return the arity of the NCI (the number of arguments). =cut */ METHOD arity() :no_wb { Parrot_NCI_attributes * const nci_info = PARROT_NCI(SELF); INTVAL arity = 0; if (nci_info) { if (!nci_info->func) build_func(INTERP, nci_info); if (nci_info->func) { arity = nci_info->arity; RETURN(INTVAL arity); } } Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_INVALID_OPERATION, "You cannot get the arity of an undefined NCI."); } } /* =back =head1 SEE ALSO F. =head1 HISTORY Initial revision by sean 2002/08/04. =cut */ /* * Local variables: * c-file-style: "parrot" * End: * vim: expandtab shiftwidth=4: */ md5sum.pir000644000765000765 323012101554066 16674 0ustar00bruce000000000000parrot-6.6.0/examples/library# Copyright (C) 2005-2009, Parrot Foundation. =head1 NAME examples/library/md5sum.pir - calculate MD5 checksums =head1 SYNOPSIS % ./parrot examples/library/md5sum.pir filename [filename ...] =head1 DESCRIPTION The main purpose of this script is testing the Digest/MD5.pir library. It should behave very much like md5sum(1). Running parrot with C<-R jit> will give a significant performance boost (often about ten-fold). =head1 AUTHOR Nick Glencross - Leopold Toetsch - =cut .sub _main :main .param pmc args .local int size load_bytecode "Digest/MD5.pbc" # Argument count $I0 = args $I0 = $I0 - 1 if $I0 > 0 goto has_args $S0 = args[0] print "(parrot) " print $S0 print " filename [filename ...]\n" exit 1 has_args: $I1 = 1 next_iter: if $I1 > $I0 goto iter_done .local string file file = args[$I1] .include "stat.pasm" # Get size of file .local pmc os, stat_buf os = new ['OS'] stat_buf = os.'stat'(file) size = stat_buf[7] .local pmc pio, cl cl = new 'FileHandle' # slurp the file into memory .local string contents contents = cl.'readall'(file) $I2 = length contents if $I2 == size goto size_ok print file print ": size mismatch (" print size print " vs " print $I2 print ")\n" goto iter_cont size_ok: $P0 = _md5sum (contents) _md5_print ($P0) print "\t" print file print "\n" iter_cont: $I1 = $I1 + 1 goto next_iter iter_done: .end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: 020-version.t000644000765000765 313711533177643 16101 0ustar00bruce000000000000parrot-6.6.0/t/configure#! perl # Copyright (C) 2007, Parrot Foundation. # 020-version.t use strict; use warnings; use Test::More tests => 6; use Carp; use Cwd; use File::Copy; use File::Temp qw| tempdir |; use lib qw( lib t/configure/testlib ); use Parrot::BuildUtil; use Make_VERSION_File qw| make_VERSION_file |; my $cwd = cwd(); { my $tdir = tempdir( CLEANUP => 1 ); ok( chdir $tdir, "Changed to temporary directory for testing" ); ok( ( mkdir "lib" ), "Able to make directory lib" ); ok( ( mkdir "lib/Parrot" ), "Able to make directory lib/Parrot" ); # Case 2: VERSION file with <3-element version number make_VERSION_file(q{0.4}); eval { my $pv = Parrot::BuildUtil::parrot_version(); }; like( $@, qr/Too few components to VERSION file contents/, "Correctly detected too few components in version number" ); unlink q{VERSION} or croak "Unable to delete file from tempdir after testing"; ok( chdir $cwd, "Able to change back to directory after testing" ); } pass("Completed all tests in $0"); ################### DOCUMENTATION ################### =head1 NAME 020-version.t - test C =head1 SYNOPSIS % prove t/configure/020-version.t =head1 DESCRIPTION The files in this directory test functionality used by F. The tests in this file test Parrot::BuildUtil (F). =head1 AUTHOR James E Keenan =head1 SEE ALSO Parrot::BuildUtil, F. =cut # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: sysinfo.t000644000765000765 1312712135343346 15643 0ustar00bruce000000000000parrot-6.6.0/t/dynoplibs#!perl # Copyright (C) 2008-2010, Parrot Foundation. # initial work by Brad Gilbert b2gills gmail com use strict; use warnings; use lib qw( . lib ../lib ../../lib ); use Test::More; use Config; use Parrot::Test tests => 17; use Parrot::Config; =head1 NAME t/op/sysinfo.t - System Info =head1 SYNOPSIS % prove t/op/sysinfo.t =head1 DESCRIPTION Tests for basic system information. =over 4 =item 1 The size of a platform integer =item 2 The size of a platform float =item 3 The size of a platform pointer. (Largest possible data pointer) =item 4 The OS name =item 5 The OS version string =item 6 The OS version number string =item 7 The CPU architecture =item 8 The CPU model =item 9, 10 The min and max INTVAL values =back =cut #define PARROT_INTSIZE 16 #define PARROT_FLOATSIZE 17 #define PARROT_POINTERSIZE 18 #define PARROT_OS 30 #define PARROT_OS_VERSION 31 #define PARROT_OS_VERSION_NUMBER 32 #define CPU_ARCH 33 #define CPU_TYPE 34 #define PARROT_INTMAX 19 #define PARROT_INTMIN 20 my @setup = ( { pconfig_key => 'intvalsize', pasm_key => 16, pir_key => 'SYSINFO_PARROT_INTSIZE', desc => 'integer size', reg_type => 'I', }, { pconfig_key => 'doublesize', pasm_key => 17, pir_key => 'SYSINFO_PARROT_FLOATSIZE', desc => 'float size', reg_type => 'I', }, { pconfig_key => 'ptrsize', pasm_key => 18, pir_key => 'SYSINFO_PARROT_POINTERSIZE', desc => 'pointer size', reg_type => 'I', }, { pconfig_key => 'osname', pasm_key => 30, pir_key => 'SYSINFO_PARROT_OS', desc => 'osname', reg_type => 'S', }, { pconfig_key => 'cpuarch', pasm_key => 33, pir_key => 'SYSINFO_CPU_ARCH', desc => 'CPU Arch Family', reg_type => 'S', }, { pconfig_key => 'cputype', pasm_key => 34, pir_key => 'SYSINFO_CPU_TYPE', desc => 'CPU Model', reg_type => 'S', }, ); foreach ( @setup ) { if ( $_->{reg_type} eq 'I' ) { pasm_output_is( <<"CODE", "$PConfig{$_->{pconfig_key}}$PConfig{$_->{pconfig_key}}", "PASM sysinfo $_->{desc}" ); .pcc_sub :main main: .loadlib 'sys_ops' sysinfo_i_ic I1, $_->{pasm_key} print I1 set I3, $_->{pasm_key} sysinfo_i_i I2, I3 print I2 end CODE pir_output_is( <<"CODE", "$PConfig{$_->{pconfig_key}}$PConfig{$_->{pconfig_key}}", "PIR sysinfo $_->{desc}" ); .loadlib 'sys_ops' .include 'sysinfo.pasm' .sub main :main \$I0 = sysinfo .$_->{pir_key} print \$I0 \$I3 = .$_->{pir_key} \$I2 = sysinfo \$I3 print \$I2 .end CODE } else { pasm_output_is( <<"CODE", "$PConfig{$_->{pconfig_key}}$PConfig{$_->{pconfig_key}}", "PASM sysinfo $_->{desc}" ); .pcc_sub :main main: .loadlib 'sys_ops' sysinfo_s_ic S1, $_->{pasm_key} print S1 set I1, $_->{pasm_key} sysinfo_s_i S2, I1 print S2 end CODE pir_output_is( <<"CODE", "$PConfig{$_->{pconfig_key}}$PConfig{$_->{pconfig_key}}", "PIR sysinfo $_->{desc}" ); .loadlib 'sys_ops' .include 'sysinfo.pasm' .sub main :main \$S0 = sysinfo .$_->{pir_key} print \$S0 \$I1 = .$_->{pir_key} \$S1 = sysinfo \$I1 print \$S1 .end CODE } } SKIP: { $PConfig{osname} eq 'MSWin32' or skip "Tests only meaningful on Win32", 2; SKIP: { eval { require Win32; } or skip "requires package Win32 for these tests", 2; my $osname = Win32::GetOSName(); $osname = 'WinXP' if $osname =~ m/^WinXP/; TODO: { local $TODO = "Not Currently Implemented"; pasm_output_is( <<'CODE', "$osname$osname", "sysinfo OS version string" ); .pcc_sub :main main: .loadlib 'sys_ops' sysinfo_s_ic S1, 5 print S1 set I0, 5 sysinfo_s_i S2, 5 print S2 end CODE my ( $osvername, $major, $minor, $id ) = Win32::GetOSVersion(); pasm_output_is( <<'CODE', "$major.$minor$major.$minor", "sysinfo OS version number string" ); .pcc_sub :main main: .loadlib 'sys_ops' sysinfo_s_ic S1, 6 print S1 set I0, 6 sysinfo_s_i S2, 6 print S2 end CODE } # END todo block } # END inner SKIP block } # END outer SKIP block # 9, 10 SKIP: { skip 'Testing only in some known platforms', 1 unless $PConfig{osname} eq 'linux'; pir_output_like( <<'CODE', '/^-[1-9][0-9]*\n[1-9][0-9]*\n-[1-9][0-9]*\n[1-9][0-9]*\n$/', 'INTVAL min and max values'); .loadlib 'sys_ops' .include 'sysinfo.pasm' .sub main :main $I0 = sysinfo .SYSINFO_PARROT_INTMIN say $I0 $I0 = sysinfo .SYSINFO_PARROT_INTMAX say $I0 $I1 = .SYSINFO_PARROT_INTMIN $I0 = sysinfo $I1 say $I0 $I1 = .SYSINFO_PARROT_INTMAX $I0 = sysinfo $I1 say $I0 .end CODE } pir_output_is(<<'CODE', < or, alternatively, email a query to the C mailing list. If there are goals for the release, please announce them on C. As well, please ensure everyone understands what they've committed to accomplish in time for the release. =item 2 Shortly after the release preceding to your release, it is a good idea to start tracking Parrot news in F. A good resource is the individual reports posted in the weekly IRC meeting on C<#parrotsketch>. You may obtain a complete log of these meetings at L. =item 3 A couple of weeks in advance of the release, ask people to run C and report (and hopefully fix!) any problems they discover. Check-in with language project leaders (I Rakudo) for any potential release blockers. This will, hopefully, afford them sufficient time apply any fixes. Also, please ask people to review any issues targeted for the upcoming release at L. =item 4 During the course of the release process, you will need to be able to log in and operate on two different servers. To oversimplify a bit, you will need to be able to execute these two commands and their C equivalents. =over 4 =item * C In order to do this, please ensure your public SSH key(s) have been added to the FTP server L. You can open a support ticket for this by sending an email to C with your public SSH keys as attachments. Without them, you will not be able to ship the release. =item * CusernameE@parrot.org> Also, set up your account on L. Any previous release manager should be able to help you, but you may also need to open a support ticket at C in order to be added to the C group. The C group has permissions to create the new directories necessary to contain documentation for new releases. =back =item 5 A couple of days in advance, announce the new release to C and to the IRC channel C<#parrot>. Ask whether there are any showstopping bugs. Check-in again with the language project leads. It's also good to ask for updates to L, L, L. L, L, and L. =item 6 On the Saturday before the release, you should notify other developers to stop committing non-release related code to the master branch. This will help to avoid complications. They are, of course, free to commit to branches as much as they want. You may also set the topic in C<#parrot>, announcing the time you plan to start the release procedure. This will aid the committers. =item 7 You may also select a name (and optionally a quote) for your release. For example, you could select a name from L. =item 8 B You must have a recent version of Parrot already built for some of the subsequent steps. =back =head2 II. Get the Most Recent Changes The day of the release has arrived. Please ensure you have checked out the most recent version of the master branch: git checkout master git pull --rebase Also, ensure you do not have any local commits which have not yet been pushed and thoroughly tested. You can do so with the following command: git log origin/master.. If this produces no output, then your local master and the remote master are in sync. =head2 III. Update the Release Version First, ensure you have configured Parrot (C) and ran C and C with the old version of Parrot. Second, save a copy of the entire F directory to some temporary location; you will need them later in I
below. Next, update files with the following version-specific information. =over 4 =item 1. =over 4 =item a. Use C to update the version string in several files. For example, perl tools/release/update_version.pl A.B.C The version change you just made by running F did not invalidate existing generated bytecode. Only if you had to update F. Assuming you ran it in a directory with an existing build, you must now run C to update the version in your config files. =item b. Update the version number, the date, and your name in L. =item c. Update this file (L) to remove the pending release you're currently building. =back =item 2 Run perl tools/dev/new_changelog_skeleton.pl to update F with the new version number and a skeleton announcement. Add any other changes which have occurred since the last release. Hopefully, the committers are updating these files as they work. But, if not, then it's probably a good idea to gather the updates weekly rather than wait until the day of the release. All commits since the last release can be see via: git log RELEASE_A_B_C.. --date=short --pretty=%h%x09%ad%x09%an%x09%B =item 3 Update release-related information in F. You will use this later for the release announcements. There are a few, essential fields which must be updated at each release: =over 4 =item C The date of the next release (I L). =item C Enter the date of the Saturday before the next release. =item C Enter the date part of the link to the wiki page for the next bugday. =item C The URL of the FTP directory where the Parrot tarball can be found. =item C Either "devel" for a regular development release, or "supported" for a long-term-support release. =back =item 4 Make sure F is still accurate. =item 5 Give yourself credit for the release in F. =item 6 Configure Parrot and run C. Then either fix what those tests complain about or fix the tests so they don't complain. =item 7 B You may skip the following step if this is a developer release or if there have been no new entries to F. If this is a supported release and new entries to F have been added since the last supported release, add a new entry with a new major version number for this release at the top of the list. For example, 3.0 2007.10.17 coke released 0.4.17 Delete all minor version numbers since the last major bytecode version number, as these are used only in development and are not relevant to the bytecode support policy. Those changes are all included within the major version number increase for the supported release. Once you've updated F run C to update the PBC files used in the native PBC tests. Note: You must already have built Parrot for this to work, and this script will reconfigure and rebuild Parrot with various primitive size options. You will need 64-bit multilib or 64-bit and 32-bit, little-endian and big-endian Parrot versions to generate all native_pbc files. If F was not updated and you got no updated native_pbc files, you need to update the native pbc headers with C, so that the native_pbc tests will not be TODO'd, but skip unreadable old PBC files for big endian 8 bit platforms F<*_8_be.pbc>. =item 8 Verify that the build process runs smoothly: make realclean perl Configure.pl --test ... make world installable html 2>&1 | tee make_world_html.log make fulltest 2>&1 | tee make_fulltest.log Note that running C takes a while and that separate harnesses are being run. =back =head2 IV. Push Changes to the GitHub Repository When all is well, commit your changes: git diff git add file1 file2 ... git commit -m "awesome and informative commit message" Instead of adding files individually, you can also tell C that you want all modified and deleted files to be in your next commit via the C<-a> switch: git commit -a -m "awesome and informative commit message" Be careful with C as it could add files you do not mean to include. Verify the contents of your most recent commit look sane with: git show If you want, you can note the SHA-1 digest from this commit by running, git rev-parse master > SHA1_TO_REMEMBER Update the repository on GitHub with, git push origin master =head2 V. Prepare the Release Tarballs There are two possible approaches to preparing and testing the release tarball: using C or using C. =over 4 =item 1. Using C =over 4 =item a. Begin by running: make release VERSION=a.b.c where a.b.c is the version number (I C<3.8.0>). This will create the tarball named F. The F file is automatically excluded from the release tarball. =item b. Extract F into another directory: cp parrot-a.b.c.tar.gz ~/another/directory cd ~/another/directory tar -xvzf parrot-a.b.c.tar.gz cd parrot-a.b.c =item c. Verify that the build process runs smoothly: perl Configure.pl make world installable html 2>&1 | tee make_world_html.log make fulltest 2>&1 | tee make_fulltest.log =back =item 2. Using C As an alternative, you can package the release by running: perl Configure.pl make release_check This target (or, for short, C), will prepare the tarball, copy it into a temporary directory, and then reconfigure, rebuild, re-test (with C) and re-release. =back Whichever of these two approaches you use, verify the version is correct and B contain the suffix C: ./parrot -V =head2 VI. Tag the Release Commit Tag the release as "RELEASE_a_b_c", where a.b.c is the version number: git tag RELEASE_a_b_c git push --tags =head2 VII. Push Tarballs to the FTP Server Log in to L: ssh parrot@ftp-osl.osuosl.org As mentioned previously, your public SSH key must be added to the list of authorized keys before you can log in. If this is a development release, create a new directory under F<~/ftp/releases/devel>: mkdir ~/ftp/releases/devel/a.b.c If this is a supported release (I L), create the new directory in F<~/ftp/releases/supported> instead: mkdir ~/ftp/releases/supported/a.b.c For both supported and developer releases, add a symlink from to so that scripts that want to download a Parrot release don't need to guess the location: cd ftp/releases/all ln -s ../supported/9.9.0 . Copy all the tarballs and their respective digest files from your machine into the new directory: scp parrot-a.b.c.tar.gz \ parrot-a.b.c.tar.bz2 \ parrot-a.b.c.tar.gz.sha256 \ parrot-a.b.c.tar.bz2.sha256 \ parrot@ftp-osl.osuosl.org:~/ftp/releases/devel/a.b.c/ You don't necessarily have to use C for this step. You can use whichever tool you prefer. When you're finished making changes, run the trigger script to push the changes out to the FTP mirrors: ~/trigger-parrot Verify your changes at F. It should only take a few minutes for the mirrors to sync. =head2 VIII. Release Announcement Compose the release announcement. Use F to make this part easier. You can specify the format of your announcements like so, ./parrot tools/release/crow.pir --type=text ./parrot tools/release/crow.pir --type=html Copy the output and paste it into the application you need. HTML works well for Perl and PerlMonks and text works well for the rest. It's a good idea (although not necessary) to add a "highlights" section to draw attention to major new features. If you do, be sure to say the same thing in both the text and the HTML versions. Please ensure you include the SHA256 sums of the tarballs in the release announcement which are automatically generated by C. =head2 IX. Update the Website Update the website. You will need an account with editor rights on L. =over 4 =item 1 Create a new page for the release announcement by navigating to going to L. There's some additional stuff needed at the top of the page; use one of the old announcements as a guide. The "" line marks the end of the text that will appear on the front page. =item 2 For the "News" category, select both "Releases" and "News". Add tags to the page for significant changes in this release (e.g. "rakudo" for significant Rakudo language updates or "gc" for significant garbage collection subsystem updates). =item 3 Under I, uncheck I and set the path to I. =item 4 Under I, make sure I and I are both checked. =item 5 Under I -> I -> I, change the URL for C to the FTP file for the new release (e.g. F). Also update the URL for C or C depending on which type of release this is. =item 6 Update L. Run C in a release copy of Parrot, and save the F and F directories created in F. Use SSH to login to C<< @parrot.org >> and expand these into a release directory (e.g. 3.8.0) in the webroot (I F) for L. In C<< /parrot >>, there are symbolic links for C, C, and C. Update the C symlink to point to your new directory. If this is a supported release, also update the C symlink. Do not delete any old copies of the docs and don't update the other symlinks. =item 7 Preview the new page, and submit it. =back The old release announcement may be edited to uncheck I to keep the main page fresh. =head2 X. Update parrot.github.com and the Relevant parrot-docsx Repository To update both the C and the relevant C repositories, execute the following command: perl tools/release/parrot_github_release.pl --docs=[/path/to/old/docs/] Please note: To review the available options, use the C<-h | --help> option. In addition, you may also want to review the pod with, C. For more information about the update process, I L. =head2 XI. Publicity Publicize the release by publishing the announcement through the following channels (and any others you can think of): =over 4 =item 1 Send a text email to C, C, C, C, etc. You should also include L in this mailing; email to C at that domain. Also, notify Perl Weekly at C . =item 2 Submit the announcement story to use Perl, Perl Monks, Slashdot, Newsforge, etc. Don't forget to set a C or C header, if your mail client lets you. =item 3 If you are an IRC op, modify the topic on C<#parrot>, for example, /topic #parrot Parrot 4.0.0 "[Name of Parrot Release]" | http://parrot.org/ | Log: http://irclog.perlgeek.de/parrot | #parrotsketch meeting Tuesday 19:30 UTC If not, ask someone to do this. =item 4 Update the wiki frontpage at L =item 5 Update the Wikipedia entry at L. =item 6 Update the C2 wiki entry at L. =back =head2 XII. Finish You're done! Help yourself to a beer, cola, or other delicious celebratory drink. =head1 SEE ALSO L, L. =head1 APPENDIX 1 - UPCOMING RELEASES To make a monthly release schedule possible, we spread the burden of releases across multiple release managers. Releases are scheduled for the 3rd Tuesday of each month. To learn more about our support policy, see L. The calendar of releases is available at the C Google calendar, visible at L. Make sure that at least the next two releases are covered - Aug 19, 2014 - 6.7.0 - rurban - Sep 16, 2014 - 6.8.0 - Util - Oct 21, 2014 - 6.9.0 - ?? =cut __END__ Local Variables: fill-column:78 End: dl.c000644000765000765 304211567202624 15602 0ustar00bruce000000000000parrot-6.6.0/src/platform/ansi/* * Copyright (C) 2007-2010, Parrot Foundation. */ /* =head1 NAME src/platform/ansi/dl.c =head1 DESCRIPTION Parrot functions -- B -- which wrap around standard library functions for handling dynamic libraries. =head2 Functions =over 4 =cut */ #include "parrot/parrot.h" /* HEADERIZER HFILE: none */ /* =item C Parrot wrapper around C. B =cut */ void * Parrot_dlopen(const char *filename, SHIM(Parrot_dlopen_flags flags)) { Parrot_warn(NULL, PARROT_WARNINGS_PLATFORM_FLAG, "Parrot_dlopen not implemented"); return NULL; } /* =item C Parrot wrapper around C. B =cut */ const char * Parrot_dlerror(void) { return "Parrot_dlerror not implemented"; } /* =item C Parrot wrapper around C. B =cut */ void * Parrot_dlsym(void *handle, const char *symbol) { Parrot_warn(NULL, PARROT_WARNINGS_PLATFORM_FLAG, "Parrot_dlsym not implemented"); return NULL; } /* =item C Parrot wrapper around C. B =cut */ int Parrot_dlclose(void *handle) { Parrot_warn(NULL, PARROT_WARNINGS_PLATFORM_FLAG, "Parrot_dlclose not implemented"); return 0; } /* =back =cut */ /* * Local variables: * c-file-style: "parrot" * End: * vim: expandtab shiftwidth=4 cinoptions='\:2=2' : */ README.pod000644000765000765 664611644422075 13413 0ustar00bruce000000000000parrot-6.6.0/t=head1 NAME t/ - The Parrot Virtual Machine Test Suite =head1 DESCRIPTION This directory contains the official Parrot Virtual Machine test suite. For details on how tests are written see the documentation in docs/tests.pod L. For status of the testing effort, see t/TESTS_STATUS.pod L. The script 'harness' actually runs the test suite. To run the normal Parrot test suite tests: make test To run only the core test suite (intented to be used after C): make coretest The run the full test suite, which is equivalent to "make test" under various runcores as well as coding standard tests: make fulltest To run just the coding standard tests: make codingstd_tests To create code coverage reports from the Parrot test suite: make cover which requires the Devel::Cover Perl 5 module. To submit "smoke" reports, you will need to install the TAP::Harness::Archive and LWP::UserAgent CPAN modules, and then type: make smoke The report will then be visible on Smolder: L If you only want to submit results of the core test suite to Smolder: make smolder_coretest Below is a list of subdirs along with a short description of what is tested in there. =over 4 =item all_hll_test Run all the tests for all HLLs and libraries. Useful before and after merges to detect regressions in projects using Parrot. =item benchmark Benchmark tests. =item codingstd Tests the coding conventions for Parrot source code. =item compilers Tests for compilers in Parrot. =item configure Tests for the Perl modules in our configuration subsystem. =item distro Tests that run before a distribution is released. Can be run with: make distro_tests =item doc Tests for the completeness and sanity of the documentation. =item dynoplibs Tests for dynamic (loadable at run-time) opcode libraries. =item dynpmc Tests for dynamic PMCs. =item examples Tests to check whether the examples are still working. Can be run with: make examples_tests =item library Test Parrot modules that ship with core. Can be run with: make library_tests =item manifest Tests for the functionality supporting the creation of MANIFEST and related files. Can be run with: make manifest_tests =item native_pbc Tests Parrot Byte Code. =item oo Tests for object oriented features of Parrot. Can be run with make oo_tests =item op Tests for Parrot opcodes. Can be run with make op_tests =item perl Tests for the Perl 5 modules used for configuration, building and testing of Parrot. Can be run with: make perl_tests =item pharness Tests for the functionality supporting Parrot's test harnesses. =item pmc Tests for Parrot PMCs. Can be run with make pmc_tests =item postconfigure Tests of configuration system run after configuration has completed. =item run Tests for the command line options of the 'parrot' executable. Can be run with: make run_tests =item src Tests written in C, mostly for the Embed/Extend subsystems. Can be run with make src_tests =item steps Tests for the steps in the Parrot configuration process. =item stress Stress testing. Make Parrot sweat. =item tools Tests for tools useful to Parrot core and HLL developers =back =head1 COPYRIGHT Copyright (C) 2005-2011, Parrot Foundation. =cut validheader.in000644000765000765 17511567202625 22230 0ustar00bruce000000000000parrot-6.6.0/t/tools/dev/headerizer/testlibThis file has a valid HEADERIZER HFILE directive and has a corresponding header file. /* HEADERIZER HFILE: validheader.h */ env.pm000644000765000765 352511533177633 15047 0ustar00bruce000000000000parrot-6.6.0/config/auto# Copyright (C) 2001-2009, Parrot Foundation. =head1 NAME config/auto/env.pm - System Environment =head1 DESCRIPTION Determining if the C library has C and C. More information about these functions can be found at L, among other locations. =cut package auto::env; use strict; use warnings; use base qw(Parrot::Configure::Step); use Parrot::Configure::Utils ':auto'; sub _init { my $self = shift; my %data; $data{description} = q{Does your C library have setenv / unsetenv}; $data{result} = q{}; return \%data; } sub runstep { my ( $self, $conf ) = ( shift, shift ); my ( $setenv, $unsetenv ) = ( 0, 0 ); $conf->cc_gen('config/auto/env/test_setenv_c.in'); eval { $conf->cc_build(); }; unless ( $@ || $conf->cc_run() !~ /ok/ ) { $setenv = 1; } $conf->cc_clean(); $conf->cc_gen('config/auto/env/test_unsetenv_c.in'); eval { $conf->cc_build(); }; unless ( $@ || $conf->cc_run() !~ /ok/ ) { $unsetenv = 1; } $conf->cc_clean(); $self->_evaluate_env($conf, $setenv, $unsetenv); return 1; } sub _evaluate_env { my ($self, $conf, $setenv, $unsetenv) = @_; $conf->data->set( setenv => $setenv, unsetenv => $unsetenv ); if ( $setenv && $unsetenv ) { $conf->debug(" (both) "); $self->set_result('both'); } elsif ($setenv) { $conf->debug(" (setenv) "); $self->set_result('setenv'); } elsif ($unsetenv) { $conf->debug(" (unsetenv) "); $self->set_result('unsetenv'); } else { $conf->debug(" (no) "); $self->set_result('no'); } } 1; # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: ptr.pmc000644000765000765 1046212356767111 14376 0ustar00bruce000000000000parrot-6.6.0/src/pmc/* Copyright (C) 2011-2014, Parrot Foundation. =head1 NAME src/pmc/ptr.pmc - Ptr PMC =head1 DESCRIPTION C is a bare bones PMC for representing the base type for pointers. It is intended that additional functionality be added via subclassing. Any functionality added to this PMC not critical to its operation as a pointer representation is deprecated in advance and subject to removal without notice. =head2 Fat versus Thin C can be implemented with two separate representations - C, which makes use of the conventional PMC attributes structure and C which is more efficient and stores the pointer directly, avoiding memory allocation and pointer dereference costs at the expense of extensibility. The distinction is managed via a set of macros - C, C, and C. Internally, these use the C flag, and this flag is therefore unavailable for subclass use. =cut */ BEGIN_PMC_HEADER_PREAMBLE #define PTR_FAT_TEST(i, s) PObj_flag_TEST(private1, (s)) #define PTR_FAT_SET(i, s) PObj_flag_SET(private1, (s)) #define PTR_FAT_CLEAR(i, s) PObj_flag_CLEAR(private1, (s)) END_PMC_HEADER_PREAMBLE #include "parrot/string_funcs.h" /* HEADERIZER HFILE: none */ /* HEADERIZER BEGIN: static */ /* HEADERIZER END: static */ /* =head2 Vtable Functions =over 4 =cut */ pmclass Ptr manual_attrs { ATTR void *ptr; /* =item C If C and attributes have not yet been otherwise allocated, will allocate room for the representation. Unless otherwise initialized, Parrot will have zeroed this and the pointer value will be C. =item C C with a value from an C. =item C C with a value from an existing pointer-ish PMC. =cut */ VTABLE void init() :manual_wb { if (PTR_FAT_TEST(INTERP, SELF) && !PMC_data(SELF)) { PMC_data(SELF) = (void *)mem_gc_allocate_zeroed_typed(INTERP, Parrot_Ptr_attributes); PObj_custom_destroy_SET(SELF); PARROT_GC_WRITE_BARRIER(INTERP, SELF); } } VTABLE void init_int(INTVAL i) :manual_wb { void *ptr = (void *)i; SELF.init(); STATICSELF.set_pointer(ptr); } VTABLE void init_pmc(PMC *p) :manual_wb { void *ptr = VTABLE_get_pointer(INTERP, p); SELF.init(); STATICSELF.set_pointer(ptr); } /* =item C =item C Get and set the pointer value. =cut */ VTABLE void *get_pointer() :manual_wb { void *ptr; if (PTR_FAT_TEST(INTERP, SELF)) GET_ATTR_ptr(INTERP, SELF, ptr); else ptr = PMC_data(SELF); /* We are returning raw pointer. Someone can write into it */ PARROT_GC_WRITE_BARRIER(INTERP, SELF); return ptr; } VTABLE void set_pointer(void *ptr) { if (PTR_FAT_TEST(INTERP, SELF)) SET_ATTR_ptr(INTERP, SELF, ptr); else PMC_data(SELF) = ptr; } /* =item C Boolean value of the pointer. Non-C is true, following in the C tradition. =cut */ VTABLE INTVAL get_bool() :no_wb { return STATICSELF.get_pointer() != NULL; } /* =item C Manage attribute deallocation for C representation. =cut */ VTABLE void destroy() :no_wb { if (PTR_FAT_TEST(INTERP, SELF) && PMC_data(SELF)) mem_gc_free(INTERP, PMC_data(SELF)); } /* =item C Implement C interface. Specifies length of the buffer. In this case, always returns C<0>, indicating undetermined length. =cut */ VTABLE INTVAL get_integer() :no_wb { UNUSED(INTERP) UNUSED(SELF) return 0; } /* =back =head2 Methods =over 4 =item C Create a string from the buffer, assumed to be a C string, with the encoding specified. If the encoding is omitted or null, use platform encoding. =cut */ METHOD as_string(STRING *encodingname :optional) :no_wb { const char * content = (const char *)SELF.get_pointer(); STRING *result = Parrot_str_new_from_cstring(INTERP, content, encodingname); RETURN(STRING result); } } /* =back =cut */ /* * Local variables: * c-file-style: "parrot" * End: * vim: expandtab shiftwidth=4 cinoptions='\:2=2' : */ test_c.in000644000765000765 60511567202622 17271 0ustar00bruce000000000000parrot-6.6.0/config/auto/memalign/* Copyright (C) 2003-2009, Parrot Foundation. test for memalign function */ #include <@malloc_header@> #include int main(int argc, char **argv) { void *ptr = memalign(256, 17); puts(ptr && ((@ptrcast@)ptr & 0xff) == 0 ? "ok" : "nix"); return 0; } /* * Local variables: * c-file-style: "parrot" * End: * vim: expandtab shiftwidth=4 cinoptions='\:2=2' : */ shlibs.pm000644000765000765 256311533177634 15716 0ustar00bruce000000000000parrot-6.6.0/config/inter# Copyright (C) 2005-2007, Parrot Foundation. =head1 NAME config/inter/shlibs.pm - Flags for shared libraries. =head1 DESCRIPTION Asks the user which flags are needed for compiling position-independent code for use in shared libraries. Eventually, other shared-library-related prompts may end up here. This is a separate unit from config/inter/progs.pm because the answers depend on which compiler is in use. Thus it should come after the gccversion test. =cut package inter::shlibs; use strict; use warnings; use base qw(Parrot::Configure::Step); use Parrot::Configure::Utils ':inter'; sub _init { my $self = shift; my %data; $data{description} = q{Determine flags for building shared libraries}; $data{result} = q{}; return \%data; } sub runstep { my ( $self, $conf ) = @_; my $cc_shared = $conf->options->get('cc_shared'); $cc_shared = integrate( $conf->data->get('cc_shared'), $cc_shared ); $cc_shared = prompt( "\nWhat flags instruct your compiler to compile code suitable for use in a shared library?", $cc_shared ) if $conf->options->get('ask'); $conf->data->set( cc_shared => $cc_shared ); $self->set_result( ( $cc_shared =~ m/^ ?$/ ) ? 'done' : $cc_shared ); return 1; } 1; # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: pod.t000644000765000765 1006712227307455 14551 0ustar00bruce000000000000parrot-6.6.0/t/examples#! perl # Copyright (C) 2009-2010, Parrot Foundation. use strict; use warnings; use lib qw( . lib ../lib ../../lib ); use File::Temp qw(tempfile); use Test::More qw(no_plan); use Parrot::Test; use Parrot::Test::Pod; use Parrot::Config qw(%PConfig); my @files = @ARGV; if (!@files) { my $podTester = Parrot::Test::Pod->new( { argv => [ @ARGV ], } ); @files = @{$podTester->identify_files_for_POD_testing()}; } foreach my $file ( @files ) { foreach my $snippet (get_samples($file)) { compile_ok($snippet); } } #################### SUBROUTINES #################### sub compile_ok { my $snippet = shift; # If it's a PIR fragment, wrap it in a sub. if ($snippet->{type} eq "PIR" && $snippet->{modifier} =~ /FRAGMENT/) { $snippet->{code} = ".sub 'testing'\n" . $snippet->{code} . "\n.end"; } # Generate a temp file for the source. my ($fh,$tempfile) = tempfile( SUFFIX => '.' . lc $snippet->{type}, UNLINK => 1 ); print {$fh} $snippet->{code}; close $fh; # Generate a temp file for stderr my ($err_fh,$err_tempfile) = tempfile( SUFFIX => '.err', UNLINK => 1 ); close $err_fh; # Send the output to /dev/null; similar to perl5's -c my $cmd = File::Spec->curdir() . $PConfig{slash} . $PConfig{test_prog} . " -o " . File::Spec->devnull() . " " . $tempfile . ' 2> ' . $err_tempfile; my $description = join (':', map {$snippet->{$_}} qw(file line type modifier)); my $rc = system($cmd); open my $errout_fh, '<', $err_tempfile; my $error_output; { undef local $/; $error_output = <$errout_fh>; } my $todo = 0; $todo = 1 if ($snippet->{modifier} =~ /TODO|INVALID/); TODO: { # conditionally todo the file. local $TODO = 'invalid code' if $todo; is ($error_output,'',$description); } } sub get_samples { my $file = shift; open my $fh, '<', $file; my @snippets; my $snippet = {}; my $code = ''; my $target; my $in_code = 0; while (my $line = <$fh>) { if ( $in_code ) { if ($line =~ /^=end $target$/) { $snippet->{code} = $code; push @snippets, $snippet; $code = ''; $snippet = {}; $in_code = 0; } else { $code .= $line; } } elsif ( $line =~ /^=begin ((PIR|PASM)(_(.*))?)$/ ) { $in_code = 1; $snippet->{file} = $file; $snippet->{line} = $.; $snippet->{type} = $2; $snippet->{modifier} = defined($4) ? $4 : ''; $target = $1; } } # We don't check for an example in progress here because no file # should end with =end. return @snippets; } __END__ =head1 NAME t/examples/pod.t - Compile examples found in POD =head1 SYNOPSIS # test all files % prove t/examples/pod.t # test specific files % perl t/examples/pod.t docs/compiler_faq.pod =head1 DESCRIPTION Tests the syntax for any embedded PIR in POD, for all files in the repository that contain POD. Any invalid examples are reported in the test output. To test a snippet of parrot code, wrap it in C<=begin> and C<=end> blocks like: =begin PASM set I0, 0 =end PASM C and C are both valid target languages. Additionally, you can add the following modifiers (prepending with an underscore). =over 4 =item * FRAGMENT For PIR, wraps the code in a C<.sub> block. =item * TODO =item * INVALID Either of these will force the test to be marked TODO. =back For example, this PIR fragment uses an old, invalid opcode and needs to be updated: =begin PIR_FRAGMENT_INVALID find_type $I1, 'Integer' =end PIR_FRAGMENT_INVALID As shown, you can "stack" the modifiers. Take care to make the begin and and end POD targets identical. Always begin with the target language. =cut # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: scope.t000644000765000765 62511533177643 16745 0ustar00bruce000000000000parrot-6.6.0/t/compilers/imcc/syn#!./parrot # Copyright (C) 2001-2010, Parrot Foundation. .sub main :main .include 'test_more.pir' plan(2) test_global_const() .end .sub test_global_const .globalconst string ok1 = "ok\n" ok(1, 'global const') _global_const_sub() .end .sub _global_const_sub ok(1, 'global const') .end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: static-triangle.pir000644000765000765 377511533177634 20424 0ustar00bruce000000000000parrot-6.6.0/examples/opengl# Copyright (C) 2006-2008, Parrot Foundation. =head1 TITLE static-triangle.pir - Minimal OpenGL/GLUT setup and render for NCI tests =head1 SYNOPSIS $ cd parrot-home $ ./parrot examples/opengl/static-triangle.pir =head1 DESCRIPTION This is a simplified version of F, attempting to remove everything not absolutely necessary. This should make it easier to debug problems with the Parrot NCI system. To quit the example, close the window using your window manager (using the X in the corner of the window title bar, for example), since all keyboard handling has been removed. =cut .include 'opengl_defines.pasm' .sub main :main .param pmc argv # Load OpenGL library and a helper library for calling glutInit load_bytecode 'OpenGL.pbc' load_bytecode 'NCI/Utils.pbc' # Import all OpenGL/GLU/GLUT functions .local pmc import_gl import_gl = get_global ['OpenGL'], '_export_all_functions' import_gl() # Initialize GLUT .local pmc call_toolkit_init call_toolkit_init = get_global ['NCI'; 'Utils'], 'call_toolkit_init' .const 'Sub' glutInit = 'glutInit' argv = call_toolkit_init(glutInit, argv) # Set display mode, create GLUT window, save window handle .local int mode mode = .GLUT_DOUBLE | .GLUT_RGBA glutInitDisplayMode(mode) .local pmc window window = new 'Integer' window = glutCreateWindow('Static Triangle NCI Test') set_global 'glut_window', window # Set up GLUT callbacks .const 'Sub' draw = 'draw' glutDisplayFunc (draw) # Enter the GLUT main loop glutMainLoop() .end .sub draw .local int buffers buffers = .GL_COLOR_BUFFER_BIT | .GL_DEPTH_BUFFER_BIT glClear(buffers) glBegin(.GL_TRIANGLES) glColor3d(1,0,0) glVertex3f(-1, -1, 0) glColor3d(0, 1, 0) glVertex3f(1, -1, 0) glColor3d(0, 0, 1) glVertex3f(0, 1, 0) glEnd() glutSwapBuffers() .end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: test_c.in000644000765000765 43012307662657 16477 0ustar00bruce000000000000parrot-6.6.0/config/auto/neg_0/* Copyright (C) 2009-2014, Parrot Foundation. */ #include int main(int argc, char* argv[]) { printf("%.0f", -0.0); return 0; } /* * Local variables: * mode: c * c-file-style: "parrot" * End: * vim: expandtab shiftwidth=4 cinoptions='\:2=2' : */ check_isxxx.t000644000765000765 316111533177643 16427 0ustar00bruce000000000000parrot-6.6.0/t/codingstd#! perl # Copyright (C) 2006-2009, Parrot Foundation. use strict; use warnings; use lib qw( . lib ../lib ../../lib ); use Test::More tests => 1; use Parrot::Distribution; use Parrot::Test::Util::Runloop; =head1 NAME t/codingstd/check_isxxx.t - checks that the isxxx() functions are passed unsigned char =head1 SYNOPSIS # test all files % prove t/codingstd/check_isxxx.t # test specific files % perl t/codingstd/check_isxxx.t src/foo.c include/parrot/bar.h =head1 DESCRIPTION Checks all C language files to make sure that arguments to the isxxx() functions are explicitly cast to unsigned char. =head1 SEE ALSO L =cut my $DIST = Parrot::Distribution->new; my @files = @ARGV ? <@ARGV> : $DIST->get_c_language_files(); my @no_explicit_cast; my @isxxx_functions_list = qw( isalnum isalpha isblank iscntrl isdigit isgraph islower isprint ispunct isspace isupper ); my $isxxx_functions = join '|', @isxxx_functions_list; sub check_isxxx { my $line = shift; # does the line contain an isxxx call? return 1 unless $line =~ /[^_]($isxxx_functions)\([^)]+/; # is the line missing a cast? return 1 unless $line !~ /[^_]($isxxx_functions)\(\(unsigned char\)/; # yes! fail. return 0; } Parrot::Test::Util::Runloop->testloop( name => 'isxxx() functions cast correctly', files => [@files], per_line => \&check_isxxx, diag_prefix => 'isxxx() function not cast to unsigned char' ); # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: regexdna.pir_output000644000765000765 41311466337261 21110 0ustar00bruce000000000000parrot-6.6.0/examples/shootoutagggtaaa|tttaccct 0 [cgt]gggtaaa|tttaccc[acg] 3 a[act]ggtaaa|tttacc[agt]t 9 ag[act]gtaaa|tttac[agt]ct 8 agg[act]taaa|ttta[agt]cct 10 aggg[acg]aaa|ttt[cgt]ccct 3 agggt[cgt]aa|tt[acg]accct 4 agggta[cgt]a|t[acg]taccct 3 agggtaa[cgt]|[acg]ttaccct 5 101745 100000 133640 pcc.c000644000765000765 2306112307662657 14141 0ustar00bruce000000000000parrot-6.6.0/src/call/* Copyright (C) 2001-2011, Parrot Foundation. =head1 NAME src/call/pcc.c =head1 DESCRIPTION B: Functions in this file handle argument/return value passing to and from subroutines. =head1 FUNCTIONS =over 4 =cut */ #include "parrot/parrot.h" #include "parrot/runcore_api.h" #include "parrot/oplib/ops.h" #include "pcc.str" #include "pmc/pmc_key.h" #include "pmc/pmc_continuation.h" /* HEADERIZER HFILE: include/parrot/call.h */ /* HEADERIZER BEGIN: static */ /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */ static int do_run_ops(PARROT_INTERP, ARGIN(PMC *sub_obj)) __attribute__nonnull__(1) __attribute__nonnull__(2); PARROT_INLINE PARROT_WARN_UNUSED_RESULT static int is_invokable(PARROT_INTERP, ARGIN(PMC *sub_obj)) __attribute__nonnull__(1) __attribute__nonnull__(2); static void Parrot_pcc_add_invocant(PARROT_INTERP, ARGIN(PMC *call_obj), ARGIN(PMC *pmc)) __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__nonnull__(3); #define ASSERT_ARGS_do_run_ops __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(sub_obj)) #define ASSERT_ARGS_is_invokable __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(sub_obj)) #define ASSERT_ARGS_Parrot_pcc_add_invocant __attribute__unused__ int _ASSERT_ARGS_CHECK = (\ PARROT_ASSERT_ARG(interp) \ , PARROT_ASSERT_ARG(call_obj) \ , PARROT_ASSERT_ARG(pmc)) /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */ /* HEADERIZER END: static */ /* =item C C is the invocant. C is the sub to invoke. C is the signature. Variable args contains the IN arguments followed by the OUT results variables. You must pass the address_of(&) the OUT results, of course. Signatures: uppercase letters represent each arg and denote its types I INTVAL N FLOATVAL S STRING * P PMC * lowercase letters are adverb modifiers to the preceding uppercase arg identifier f flatten n named s slurpy o optional p opt flag l lookahead parameter (next positional, or next named if no positionals) i invocant -> is the separator between args and results, similar to type theory notation. Named args require two arg slots. The first is the name, the second the arg. Example signature: "SnIPf->INPs" The args to the method invocation are a named INTVAL: SnI a flattened PMC: Pf The results of the method invocation are a INTVAL: I a FLOATVAL: N a slurpy PMC: Ps =cut */ PARROT_EXPORT void Parrot_pcc_invoke_sub_from_c_args(PARROT_INTERP, ARGIN(PMC *sub_obj), ARGIN(const char *sig), ...) { ASSERT_ARGS(Parrot_pcc_invoke_sub_from_c_args) PMC *call_obj; va_list args; const char *arg_sig, *ret_sig; PMC * const old_call_obj = Parrot_pcc_get_signature(interp, CURRENT_CONTEXT(interp)); Parrot_pcc_split_signature_string(sig, &arg_sig, &ret_sig); va_start(args, sig); call_obj = Parrot_pcc_build_call_from_varargs(interp, PMCNULL, arg_sig, &args); Parrot_pcc_set_signature(interp, CURRENT_CONTEXT(interp), call_obj); Parrot_pcc_invoke_from_sig_object(interp, sub_obj, call_obj); call_obj = Parrot_pcc_get_signature(interp, CURRENT_CONTEXT(interp)); Parrot_pcc_fill_params_from_varargs(interp, call_obj, ret_sig, &args, PARROT_ERRORS_RESULT_COUNT_FLAG); va_end(args); Parrot_pcc_set_signature(interp, CURRENT_CONTEXT(interp), old_call_obj); } /* =item C Adds the given PMC as an invocant to the given CallContext PMC. You should never have to use this, and it should go away with interp->current_object. =cut */ static void Parrot_pcc_add_invocant(PARROT_INTERP, ARGIN(PMC *call_obj), ARGIN(PMC *pmc)) { ASSERT_ARGS(Parrot_pcc_add_invocant) PMC *arg_flags; GETATTR_CallContext_arg_flags(interp, call_obj, arg_flags); VTABLE_unshift_integer(interp, arg_flags, PARROT_ARG_PMC | PARROT_ARG_INVOCANT); VTABLE_unshift_pmc(interp, call_obj, pmc); } /* =item C Makes a method call given the name of the method and the arguments as a C variadic argument list. C is the invocant, C is the string name of the method, C is a C string describing the signature of the invocation, according to the Parrot calling conventions. The variadic argument list contains the input arguments followed by the output results in the same order that they appear in the function signature. =cut */ PARROT_EXPORT void Parrot_pcc_invoke_method_from_c_args(PARROT_INTERP, ARGIN(PMC* pmc), ARGMOD(STRING *method_name), ARGIN(const char *signature), ...) { ASSERT_ARGS(Parrot_pcc_invoke_method_from_c_args) PMC *call_obj; PMC *sub_obj; va_list args; const char *arg_sig, *ret_sig; PMC * const old_call_obj = Parrot_pcc_get_signature(interp, CURRENT_CONTEXT(interp)); Parrot_pcc_split_signature_string(signature, &arg_sig, &ret_sig); va_start(args, signature); call_obj = Parrot_pcc_build_call_from_varargs(interp, PMCNULL, arg_sig, &args); Parrot_pcc_add_invocant(interp, call_obj, pmc); Parrot_pcc_set_signature(interp, CURRENT_CONTEXT(interp), call_obj); /* Find the subroutine object as a named method on pmc */ sub_obj = VTABLE_find_method(interp, pmc, method_name); if (UNLIKELY(PMC_IS_NULL(sub_obj))) Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_METHOD_NOT_FOUND, "Method '%Ss' not found", method_name); /* Invoke the subroutine object with the given CallContext object */ Parrot_pcc_invoke_from_sig_object(interp, sub_obj, call_obj); call_obj = Parrot_pcc_get_signature(interp, CURRENT_CONTEXT(interp)); Parrot_pcc_fill_params_from_varargs(interp, call_obj, ret_sig, &args, PARROT_ERRORS_RESULT_COUNT_FLAG); va_end(args); Parrot_pcc_set_signature(interp, CURRENT_CONTEXT(interp), old_call_obj); } /* =item C Check if the PMC is a Sub or does invokable. Helper for do_run_ops. =cut */ PARROT_INLINE PARROT_WARN_UNUSED_RESULT static int is_invokable(PARROT_INTERP, ARGIN(PMC *sub_obj)) { ASSERT_ARGS(is_invokable) if (VTABLE_isa(interp, sub_obj, CONST_STRING(interp, "Sub"))) return 1; else return VTABLE_does(interp, sub_obj, CONST_STRING(interp, "invokable")); } /* =item C Check should we run ops. PIR Subs need runops to run their opcodes. Methods and NCI subs don't. =cut */ static int do_run_ops(PARROT_INTERP, ARGIN(PMC *sub_obj)) { ASSERT_ARGS(do_run_ops) if (sub_obj->vtable->base_type < enum_class_core_max) { switch (sub_obj->vtable->base_type) { case enum_class_Sub: case enum_class_MultiSub: case enum_class_Continuation: return 1; case enum_class_Object: break; default: return 0; } } return is_invokable(interp, sub_obj); } /* =item C Check if current object require running ops. =cut */ PARROT_EXPORT INTVAL Parrot_pcc_do_run_ops(PARROT_INTERP, ARGIN(PMC *sub_obj)) { ASSERT_ARGS(Parrot_pcc_do_run_ops) return do_run_ops(interp, sub_obj); } /* =item C Follows the same conventions as C, but the signature string and call arguments are passed in a CallSignature PMC. =cut */ PARROT_EXPORT void Parrot_pcc_invoke_from_sig_object(PARROT_INTERP, ARGIN(PMC *sub_obj), ARGIN(PMC *call_object)) { ASSERT_ARGS(Parrot_pcc_invoke_from_sig_object) opcode_t *dest; PMC * const ret_cont = Parrot_pmc_new(interp, enum_class_Continuation); if (UNLIKELY(PMC_IS_NULL(call_object))) call_object = Parrot_pmc_new(interp, enum_class_CallContext); Parrot_pcc_set_signature(interp, CURRENT_CONTEXT(interp), call_object); PARROT_CONTINUATION(ret_cont)->from_ctx = call_object; Parrot_pcc_set_continuation(interp, call_object, ret_cont); interp->current_cont = ret_cont; /* Invoke the function */ dest = VTABLE_invoke(interp, sub_obj, NULL); /* PIR Subs need runops to run their opcodes. Methods and NCI subs * don't. */ if (dest && do_run_ops(interp, sub_obj)) { Parrot_runcore_t * const old_core = interp->run_core; const opcode_t offset = dest - interp->code->base.data; runops(interp, offset); Interp_core_SET(interp, old_core); } } /* =item C Returns a new CallContext object, suitable for making a Sub call. =cut */ PARROT_EXPORT PARROT_CANNOT_RETURN_NULL PARROT_WARN_UNUSED_RESULT PMC * Parrot_pcc_new_call_object(PARROT_INTERP) { ASSERT_ARGS(Parrot_pcc_new_call_object) return Parrot_pmc_new(interp, enum_class_CallContext); } /* =back =head1 SEE ALSO F, F, F. =cut */ /* * Local variables: * c-file-style: "parrot" * End: * vim: expandtab shiftwidth=4 cinoptions='\:2=2' : */ IGNOREME000644000765000765 011533177633 20077 0ustar00bruce000000000000parrot-6.6.0/compilers/opsc/gen/Ops/Trans050-fatal.t000644000765000765 344711533177644 15513 0ustar00bruce000000000000parrot-6.6.0/t/configure#! perl # Copyright (C) 2007, Parrot Foundation. # 050-fatal.t use strict; use warnings; use Test::More tests => 6; use Carp; use lib qw( lib t/configure/testlib ); use Parrot::Configure; use Parrot::Configure::Options qw( process_options ); use Parrot::Configure::Step::List qw( get_steps_list ); use IO::CaptureOutput qw | capture |; $| = 1; is($|, 1, "output autoflush is set"); my ($args, $step_list_ref) = process_options( { argv => [ q{--fatal} ], mode => q{configure}, } ); ok(defined $args, "process_options returned successfully"); my %args = %$args; my $conf = Parrot::Configure->new; ok(defined $conf, "Parrot::Configure->new() returned okay"); my $first_step = q{init::zeta}; my $description = 'Determining if your computer does zeta'; $conf->add_steps( $first_step, get_steps_list() ); $conf->options->set(%args); is($conf->options->{c}->{debugging}, 1, "command-line option '--debugging' has been stored in object"); { my $rv; my ($stdout, $stderr); capture ( sub {$rv = $conf->runsteps}, \$stdout, \$stderr ); ok(! defined $rv, "runsteps returned undefined value as expected"); } pass("Completed all tests in $0"); ################### DOCUMENTATION ################### =head1 NAME 050-fatal.t - see what happens when C<--fatal-step> is set for all configuration steps =head1 SYNOPSIS % prove t/configure/050-fatal.t =head1 DESCRIPTION The files in this directory test functionality used by F. The tests in this file examine what happens when you require the failure of any configuration step to cause all configuration to cease. =head1 AUTHOR James E Keenan =head1 SEE ALSO Parrot::Configure, F. =cut # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: 022-version.t000644000765000765 316111533177643 16100 0ustar00bruce000000000000parrot-6.6.0/t/configure#! perl # Copyright (C) 2007, Parrot Foundation. # 022-version.t use strict; use warnings; use Test::More tests => 6; use Carp; use Cwd; use File::Copy; use File::Temp qw| tempdir |; use lib qw( lib t/configure/testlib ); use Parrot::BuildUtil; use Make_VERSION_File qw| make_VERSION_file |; my $cwd = cwd(); { my $tdir = tempdir( CLEANUP => 1 ); ok( chdir $tdir, "Changed to temporary directory for testing" ); ok( ( mkdir "lib" ), "Able to make directory lib" ); ok( ( mkdir "lib/Parrot" ), "Able to make directory lib/Parrot" ); # Case 4: VERSION file with non-numeric component in version number make_VERSION_file(q{0.tomboy.11}); eval { my $pv = Parrot::BuildUtil::parrot_version(); }; like( $@, qr/Illegal version component: 'tomboy'/, "Correctly detected non-numeric component in version number" ); unlink q{VERSION} or croak "Unable to delete file from tempdir after testing"; ok( chdir $cwd, "Able to change back to directory after testing" ); } pass("Completed all tests in $0"); ################### DOCUMENTATION ################### =head1 NAME 022-version.t - test C =head1 SYNOPSIS % prove t/configure/022-version.t =head1 DESCRIPTION The files in this directory test functionality used by F. The tests in this file test Parrot::BuildUtil (F). =head1 AUTHOR James E Keenan =head1 SEE ALSO Parrot::BuildUtil, F. =cut # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: lib_deps.pl000755000765000765 3556712101554067 15566 0ustar00bruce000000000000parrot-6.6.0/tools/dev#! perl ################################################################################ # Copyright (C) 2001-2003, Parrot Foundation. ################################################################################ =head1 NAME tools/dev/lib_deps.pl - List libc dependencies =head1 SYNOPSIS % perl tools/dev/lib_deps.pl [object | source] file1 [file2 ...] =head1 DESCRIPTION This script is intended to give us an idea of what C functions this build depends upon. =head2 Options =over 4 =item C In C mode, it expects a list of all parrot's object files. It runs C on each and determines what external functions are being called. Note that it assumes a gnu-ish C. =item C In C mode, it uses a the C program (L) to extract information from the program source about what functions are being called, what includes are used, etc. This mode is potentially more thorough, but a bit more magical and therefore less conclusive. =back =cut ################################################################################ use strict; use warnings; use File::Find; use File::Spec; my %defined_in; my %referenced_in; my %ansi_c89_symbol; my %ansi_c89_header; my ( $mode, @files ) = @ARGV; if ( $mode !~ /^(source|object)$/ || !@files ) { die "Usage: $0 object \n" . " $0 source \n"; } while () { next if /^\s*#/; chomp; next unless $_; my ( $symbol, $file ) = /(\S+)\s+(\S+)/; $ansi_c89_symbol{$symbol} = $file unless ( $symbol eq "UNDEF" ); push @{ $ansi_c89_header{$file} }, $symbol; } if ( $mode eq "object" ) { do_object(); } else { do_source(); } exit(0); ############################################################################## sub do_source { if ( $files[0] eq "all_source" ) { # do a little "find" action for now. @files = (); File::Find::find( { wanted => sub { /^.*\.[ch]\z/s && push @files, $File::Find::name; } }, '.' ); } # note: need to run this a second time so the database is built. # should just use the build process to do it the first time. my $devnull = File::Spec->devnull; my $cmd = "cxref -raw -Iinclude -Iinclude/pmc -xref @files"; print "Running cxref (pass 1)\n"; system("$cmd > $devnull 2>$devnull"); print "Running cxref (pass 2)\n"; open( my $F, '-|', "$cmd 2>$devnull|" ) || die "Can't run $cmd.\n"; my %external_calls; my %internal_calls; my %variable_visible; my %system_include; my ( $file, $function, $variable ); while (<$F>) { if (/----------------------------------------/) { undef $file if defined($file); next; } if (/^INCLUDES : '(.*)' \[System file\]/) { next if ( $1 =~ /^include\// ); $system_include{$1}{$file}++; next; } if ( !$file && /^FILE : '(.*)'$/ ) { $file = $1; next; } # skip anything between files. next unless $file; # beginning of function block if (/FUNCTION : (.*) \[(.*)\]/) { $function = $1; my $function_scope = $2; next; } # end of function block if ( $function && /^\s*$/ ) { undef $function; next; } # beginning of variable block if (/VARIABLE : (.*) \[(.*)\]/) { $variable = $1; my $variable_scope = $2; if ( $variable_scope eq "Local" ) { $variable_visible{$file}{$1}++; } else { $variable_visible{"ALL"}{$1}++; } next; } # end of variable block if ( $variable && /^\s*$/ ) { undef $variable; next; } if ($function) { if (/Calls (.*) : (.*)/) { # calling another function within parrot. $internal_calls{$1}{"$file:$function"}++ unless ( $variable_visible{$file}{$1} || $variable_visible{ALL}{$1} ); } elsif (/Calls (.*)/) { # calling a function outside of parrot! $external_calls{$1}{"$file:$function"}++ unless ( $variable_visible{$file}{$1} || $variable_visible{ALL}{$1} ); } } } close($F); # filter out things that start with _. Probably internal libc stuff. my @external_calls = grep { !/^_/ } sort keys %external_calls; my @internal_calls = grep { !/^_/ } sort keys %internal_calls; my @non_ansi_external_calls = grep { !exists( $ansi_c89_symbol{$_} ) } @external_calls; printf( "Found %d functions which are defined and called within the %d supplied source files.\n", scalar(@internal_calls), scalar(@files) ); printf( "Found %d external functions which were called.\n", scalar(@external_calls) ); printf( "Of these, %d are not defined by ANSI C89:\n", scalar(@non_ansi_external_calls) ); foreach (@non_ansi_external_calls) { print " $_:\n"; foreach ( sort keys %{ $external_calls{$_} } ) { print " $_\n"; } } print "\nThe following non-ansi system includes are used:\n"; foreach my $include ( sort keys %system_include ) { if ( !exists( $ansi_c89_header{$include} ) ) { print " $include, included by:\n"; foreach my $file ( sort keys %{ $system_include{$include} } ) { print " $file\n"; } } } } sub do_object { foreach my $obj (@files) { open( my $F, '-|', "nm -a $obj" ) || die "Can't run nm -a $obj\n"; while (<$F>) { chomp; my ( $type, $symbol ) = /^.+ (\S) (.*)/; if ( $type eq 'U' ) { $defined_in{$symbol} ||= undef; push @{ $referenced_in{$symbol} }, $obj; } else { $defined_in{$symbol} .= "$obj "; } } close($F); } # omit symbols which begin with _. These are likely to be internal # variables used by libc macros. my @symbols = grep { !/^_/ } sort keys %defined_in; my @external_symbols = sort grep { !defined( $defined_in{$_} ) } @symbols; my @internal_symbols = sort grep { defined( $defined_in{$_} ) } @symbols; my @non_ansi_external_symbols = grep { !exists( $ansi_c89_symbol{$_} ) } @external_symbols; printf( "Found %d symbols defined within the %d supplied object files.\n", scalar(@internal_symbols), scalar(@files) ); printf( "Found %d external symbols\n", scalar(@external_symbols) ); printf( "Of these, %d are not defined by ANSI C89:\n", scalar(@non_ansi_external_symbols) ); print " $_ (in " . ( join ',', @{ $referenced_in{$_} } ) . ")\n" foreach (@non_ansi_external_symbols); } __END__ # The following symbols are available in a C89 Hosted Implementation # (not sure if I got this right- it came from a C99 reference, so some 99isms # might have slipped in) abort stdlib.h abs stdlib.h acos math.h acosf math.h acosh math.h acoshf math.h acoshl math.h acosl math.h arg complex.h asctime time.h asin math.h asinf math.h asinh math.h asinhf math.h asinhl math.h asinl math.h atan math.h atan2 math.h atan2f math.h atan2l math.h atanf math.h atanh math.h atanhf math.h atanhl math.h atanl math.h atexit stdlib.h atof stdlib.h atoi stdlib.h atol stdlib.h atoll stdlib.h bsearch stdlib.h cabs complex.h cabsf complex.h cabsl complex.h cacos complex.h cacosf complex.h cacosh complex.h cacoshf complex.h cacoshl complex.h cacosl complex.h calloc stdlib.h carg complex.h cargf complex.h cargl complex.h casin complex.h casinf complex.h casinh complex.h casinhf complex.h casinhl complex.h casinl complex.h catan complex.h catanf complex.h catanh complex.h catanhf complex.h catanhl complex.h catanl complex.h cbrt math.h cbrtf math.h cbrtl math.h ccos complex.h ccosf complex.h ccosh complex.h ccoshf complex.h ccoshl complex.h ccosl complex.h ceil math.h ceilf math.h ceill math.h cexp complex.h cexpf complex.h cexpl complex.h cimag complex.h cimagf complex.h cimagl complex.h clearerr stdio.h clock time.h clog complex.h clogf complex.h clogl complex.h conj complex.h conjf complex.h conjl complex.h copysign math.h copysignf math.h copysignl math.h cos math.h cosf math.h cosh math.h coshf math.h coshl math.h cosl math.h cpow complex.h cpowf complex.h cpowl complex.h cproj complex.h cprojf complex.h cprojl complex.h creal complex.h crealf complex.h creall complex.h csin complex.h csinf complex.h csinh complex.h csinhf complex.h csinhl complex.h csinl complex.h csqrt complex.h csqrtf complex.h csqrtl complex.h ctan complex.h ctanf complex.h ctanh complex.h ctanhf complex.h ctanhl complex.h ctanl complex.h ctime time.h difftime time.h div stdlib.h erf math.h erfc math.h erfcf math.h erfcl math.h erff math.h erfl math.h errno errno.h exit stdlib.h exp math.h exp2 math.h exp2f math.h exp2l math.h expf math.h expl math.h expm1 math.h expm1f math.h expm1l math.h fabs math.h fabsf math.h fabsl math.h fclose stdio.h fdim math.h fdimf math.h fdiml math.h feof stdio.h ferror stdio.h fflush stdio.h fgetc stdio.h fgetpos stdio.h fgets stdio.h floor math.h floorf math.h floorl math.h fma math.h fmaf math.h fmal math.h fmax math.h fmaxf math.h fmaxl math.h fmin math.h fminf math.h fminl math.h fmod math.h fmodf math.h fmodl math.h fopen stdio.h fpclassify math.h fprintf stdio.h fputc stdio.h fputs stdio.h fread stdio.h free stdlib.h freopen stdio.h frexp math.h frexpf math.h frexpl math.h fscanf stdio.h fseek stdio.h fsetpos stdio.h ftell stdio.h fwrite stdio.h getc stdio.h getchar stdio.h getenv stdlib.h gets stdio.h gmtime time.h hypot math.h hypotf math.h hypotl math.h ilogb math.h ilogbf math.h ilogbl math.h imag complex.h isalnum ctype.h isalpha ctype.h isblank ctype.h iscntrl ctype.h isdigit ctype.h isfinite math.h isgraph ctype.h isgreater math.h isgreatereq math.h isinf math.h isless math.h islessequal math.h islessgreat math.h islower ctype.h isnan math.h isnormal math.h isprint ctype.h ispunct ctype.h isspace ctype.h isunordered math.h isupper ctype.h isxdigit ctype.h labs stdlib.h ldexp math.h ldexpf math.h ldexpl math.h ldiv stdlib.h lgamma math.h lgammaf math.h lgammal math.h llabs stdlib.h llrint math.h llrintf math.h llrintl math.h llround math.h llroundf math.h llroundl math.h localeconv locale.h localtime time.h log math.h log10 math.h log10f math.h log10l math.h log1p math.h log1pf math.h log1pl math.h log2 math.h log2f math.h log2l math.h logb math.h logbf math.h logbl math.h logf math.h logl math.h longjmp setjmp.h lrint math.h lrintf math.h lrintl math.h lround math.h lroundf math.h lroundl math.h malloc stdlib.h mblen stdlib.h mbstowcs stdlib.h mbtowc stdlib.h memchr string.h memcmp string.h memcpy string.h memmove string.h memset string.h mktime time.h modf math.h modff math.h modfl math.h nan math.h nanf math.h nanl math.h nearbyint math.h nearbyintf math.h nearbyintl math.h nextafter math.h nextafterf math.h nextafterl math.h nexttoward math.h nexttowardf math.h nexttowardl math.h perror stdio.h pow math.h printf stdio.h putc stdio.h putchar stdio.h puts stdio.h qsort stdlib.h raise signal.h rand stdlib.h real complex.h realloc stdlib.h remainder math.h remainderf math.h remainderl math.h remove stdio.h remquo math.h remquof math.h remquol math.h rename stdio.h rewind stdio.h rint math.h rintf math.h rintl math.h round math.h roundf math.h roundl math.h scalbln math.h scalblnf math.h scalblnl math.h scalbn math.h scalbnf math.h scalbnl math.h scanf stdio.h setbuf stdio.h setlocale locale.h setvbuf stdio.h signal signal.h signbit math.h sin math.h sinf math.h sinh math.h sinhf math.h sinhl math.h sinl math.h sprintf stdio.h sqrt math.h sqrtf math.h sqrtl math.h srand stdlib.h sscanf stdio.h stderr stdio.h stdin stdio.h stdout stdio.h strcat string.h strchr string.h strcmp string.h strcoll string.h strcpy string.h strcspn string.h strerror string.h strftime time.h strlen string.h strncat string.h strncmp string.h strncpy string.h strpbrk string.h strrchr string.h strspn string.h strstr string.h strtod stdlib.h strtof stdlib.h strtok string.h strtol stdlib.h strtold stdlib.h strtoll stdlib.h strtoul stdlib.h strtoull stdlib.h strxfrm string.h system stdlib.h tan math.h tanf math.h tanh math.h tanhf math.h tanhl math.h tanl math.h tgamma math.h tgammaf math.h tgammal math.h time time.h tmpfile stdio.h tmpnam stdio.h tolower ctype.h toupper ctype.h trunc math.h truncf math.h truncl math.h ungetc stdio.h vfprintf stdio.h vfscanf stdio.h vprintf stdio.h vscanf stdio.h vsprintf stdio.h vsscanf stdio.h UNDEF assert.h UNDEF stdarg.h # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: tutorial_episode_4.pod000644000765000765 3553112101554066 23635 0ustar00bruce000000000000parrot-6.6.0/examples/languages/squaak/doc# Copyright (C) 2008-2012, Parrot Foundation. =pod =head1 DESCRIPTION This is the fourth episode in a tutorial series on building a compiler with the Parrot Compiler Tools. =head1 Episode 4: PAST Nodes and More Statements =head2 Introduction The previous episode introduced the full grammar specification of Squaak, and we finally started working on the implementation. If you're doing the exercises, you currently have basic assignments working; strings and integers can be assigned to (global) variables. This episode will focus on implementation of some statement types and explain a few bits about the different PAST node types. =head2 Parrot Abstract Syntax Tree A Parrot Abstract Syntax Tree (PAST) represents a program written in Squaak (or any other Parrot-ported language), and consists of nodes. In the previous episode, we already saw nodes to represent string and integer literals, identifiers and "operator" nodes (PAST::Op), in our case assignment. Other operators represent other high-level language constructs such as conditional statements, loops, and subroutine invocation. Depending on the node type, a PAST node can take child nodes. For instance, a PAST node to represent an if-statement can have up to three child nodes. The first child node represents the condition; if true, the second child node is evaluated. If the condition evaluates to false, and there's a third child node, this third child node is evaluated (the else part). If the PAST represents a subroutine invocation, the child nodes are evaluated in a different way. In that case, the first child node represents the subroutine that is to be invoked (unless the :name attribute was set on this node, but more on that in a later episode), and all other child nodes are passed to that subroutine as arguments. It generally doesn't matter of which PAST node type the children are. For instance, consider a language in which a simple expression is a statement: 42 You might wonder what kind of code is generated for this. Well, it's really very simple: a new C node is created (of a certain type, for this example that would be C), and the value is assigned to this node. It might seem a bit confusing to write something like this, as it doesn't really do anything (note that this is not valid Squaak input): if 42 then "hi" else "bye" end But again, this works out correctly; the "then" and "else" blocks are compiled to instructions that load that particular literal into a C node and leave it there. That's fine, if your language allows such statements. The point I'm trying to make is, that all PAST nodes are equal. You don't need to think about the node types if you set a node as a child of some other parent node. Each PAST node is compiled into a number of PIR instructions. =head2 Go with the control-flow Now you know a bit more on PAST nodes, let's get our hands dirty and implement some more statement types. In the rest of this episode, we'll handle if-statements and throw-statements. =head2 If-then-else The first statement we're going to implement now is the if-statement. An if-statement has typically three parts (but this of course depends on the programming language): a conditional expression, a "then" part and an "else" part. Implementing this in Perl 6 rules and PAST is almost trivial, but first, let's add a little infrastructure to simplify adding new statement types. Replace the statement rule with the following: proto rule statement { <...> } Delete the statement method from Action.pm, and rename the assignment rule in both Grammar.pm and Actions.pm to statement:sym. The new statement rule is a "proto" rule. A proto rule is equivalent to a normal rule whose body contains each specialization of the rule separated by the | operator. The name of a particular specialization of a proto rule is placed between the angle brackets. Within the body of the rule, it can be matched literally with . rule statement:sym { 'then' $= ['else' $= ]? 'end' } rule block { * } Note that the optional else block is stored in the match object's "else" field, and the then block is stored in the match object's "then" field. If we hadn't written this $= part, then would have been an array, with block[0] the "then" part, and block[1] the optional else part. Assigning the optional else block to a different field, makes the action method slightly easier to read. Note that the proto declaration for statement means that the result object for $ in any rule which calls statement as a subrule will be result object for whichever statement type matched. Because of this, we can delete the statement action method. The relevant action methods are shown below: method block($/) { # create a new block, set its type to 'immediate', # meaning it is potentially executed immediately # (as opposed to a declaration, such as a # subroutine definition). my $past := PAST::Block.new( :blocktype('immediate'), :node($/) ); # for each statement, add the result # object to the block for $ { $past.push($_.ast); } make $past; } method statement:sym($/) { my $cond := $.ast; my $past := PAST::Op.new( $cond, $.ast, :pasttype('if'), :node($/) ); if $ { $past.push($[0].ast); } make $past; } That's, easy, huh? First, we get the result objects for the conditional expression and the then part. Then, a new C node is created, and the C<:pasttype> is set to C, meaning this node represents an if-statement. Then, if there is an "else" block, this block's result object is retrieved and added as the third child of the PAST node. Finally, the result object is set with the make function. =head2 Result objects At this point it's wise to spend a few words on the make function, the parse actions and how the whole PAST is created by the individual parse actions. Have another look at the action method statement:sym. In the first two lines, we request the result objects for the conditional expression and the "then" block. When were these result objects created? How can we be sure they're there? The answer lies in the order in which the parse actions are executed. The parse action invocation usually occurs at the end of the rule. For this input string: "if 42 then x = 1 end" this implies the following order: =over 4 =item 1. parse TOP =item 2. parse statement =item 3. parse statement:sym =item 4. parse EXPR =item 5. parse integer =item 6. create PAST::Val( :value(42) ) =item 7. parse block =item 8. parse statement =item 9. parse statement:sym =item 10. parse identifier =item 11. create PAST::Var( :name('x')) =item 12. parse integer =item 13. create PAST::Val( :value(1) ) =item 14. create PAST::Op( :pasttype('bind') ) =item 15. create PAST::Block (in action method block) =item 16. create PAST::Op( :pasttype('if') ) =item 17. create PAST::Block (in action method TOP) =back As you can see, PAST nodes are created in the leaves of the parse tree first, so that later, action methods higher in the parse tree can retrieve them. =head2 Throwing Exceptions The grammar rule for the "throw" statement is really quite easy, but it's useful to discuss the parse action, as it shows the use of generating custom PIR instructions. First the grammar rule: rule statement:sym { } The throw statement will compile down to Parrot's "throw" instruction, which takes one argument. In order to generate a custom Parrot instruction, the instruction can be specified in the C<:pirop> attribute when creating a C node. Any child nodes are passed as arguments to this instruction, so we need to pass the result object of the expression being thrown as a child of the C node representing the "throw" instruction. method statement:sym($/) { make PAST::Op.new( $.ast, :pirop('die'), :node($/) ); } =head2 What's Next? In this episode we implemented two more Squaak statement types. You should get a general idea of how and when PAST nodes are created, and how they can be retrieved as sub (parse) trees. In the next episode we'll take a closer look at variable scope and subroutines. In the mean time, I can imagine some things are not too clear. In case you're lost, don't hesitate to leave comment, and I'll try to answer (as far as my knowledge goes). =head2 Exercises =over 4 =item 1. We showed how the if-statement was implemented. The while-statement and try-statement are very similar. Implement these. Check out pdd26 to see what C nodes you should create. =item 2. Start Squaak in interactive mode, and specify the target option to show the generated PIR instructions. Check out what instructions and labels are generated, and see if you can recognize which instructions make up the conditional expression, which represent the "then" block, and which represent the "else" block (if any). =back =head2 References =over 4 =item * PDD26: AST =item * docs/art/*.pod for good introductions to PIR =back =head2 Solutions to the exercises These are the solutions to the exercises in Episode 4 of the Parrot Compiler Tools tutorial. =over 4 =item 1 We showed how the if-statement was implemented. The while-statement and try-statement are very similar. Implement these. Check out pdd26 to see what C nodes you should create. The while-statement is straightforward: method statement:sym($/) { my $cond := $.ast; my $body := $.ast; make PAST::Op.new( $cond, $body, :pasttype('while'), :node($/) ); } The try-statement is a bit more complex. Here are the grammar rules and action methods. rule statement:sym { $= 'catch' $= 'end' } rule exception { } method statement:sym($/) { ## get the try block my $try := $.ast; ## create a new PAST::Stmts node for ## the catch block; note that no ## PAST::Block is created, as this ## currently has problems with the ## exception object. For now this will ## do. my $catch := PAST::Stmts.new( :node($/) ); $catch.push($.ast); ## get the exception identifier; ## set a declaration flag, the scope, ## and clear the viviself attribute. my $exc := $.ast; $exc.isdecl(1); $exc.scope('lexical'); $exc.viviself(0); ## generate instruction to retrieve the exception object (and the ## exception message, that is passed automatically in PIR, this is stored ## into $S0 (but not used). my $pir := ' .get_results (%r, $S0)\n' ~ "\n store_lex '" ~ $exc.name() ~ "', %r"; $catch.unshift( PAST::Op.new( :inline($pir), :node($/) ) ); ## do the declaration of the exception object as a lexical here: $catch.unshift( $exc ); make PAST::Op.new( $try, $catch, :pasttype('try'), :node($/) ); } method exception($/) { my $past := $.ast; make $past; } First the PAST node for the try block is retrieved. Then, the catch block is retrieved, and stored into a C node. This is needed, so that we can make sure that the instructions that retrieve the exception object come first in the exception handler. Then, we retrieve the PAST node for the exception identifier. We're setting its scope, a flag telling the PAST compiler this is a declaration, and we clear the viviself attribute. The viviself attribute is discussed in a later episode; if you didn't read that yet, just keep in mind the viviself attribute (if set) will make sure all declared variables are initialized. We must clear this attribute here, to make sure that this exception object is not initialized, because that will be done by the instruction that retrieves the thrown exception object, discussed next. In PIR, we can use the C<.get_results> directive to retrieve a thrown exception. You could also generate the C instruction (note the missing dot), but this is much easier. Currently, in PIR, when retrieving the exception object, you must always specify both a variable (or register) for the exception object, and a string variable (or register) to store the exception message. The exception message is actually stored within the exception object. We use C<$S0> to store the exception message, and we'll ignore it after that. Just remember for now that if you want to retrieve the exception object, you must also specify a place to store the exception message. There is no special PAST node to generate these instructions, so we use a so-called inline C node. We store the instructions to be generated into a string and store that in the inline attribute of a C node. Once created, this node is unshifted onto the C node representing the exception handler. After that, the declaration is stored in that C node, so that this declaration comes first. Finally, we have the block representing the try block, and a C node representing the exception handler. Both are used to create a C node whose pasttype is set to the built-in "try" type. =item 2 Start Squaak in interactive mode, and specify the target option to show the generated PIR instructions. Check out what instructions and labels are generated, and see if you can recognize which instructions make up the conditional expression, which represent the "then" block, and which represent the "else" block (if any). Note that this may not be the exact result produced when you try it. Sub ids, block numbers, and register numbers may differ, but it should be analogous. > if 1 then else end .HLL "squaak" .namespace [] .sub "_block11" :anon :subid("10_1279319328.02043") .annotate 'line', 0 .const 'Sub' $P20 = "12_1279319328.02043" capture_lex $P20 .const 'Sub' $P17 = "11_1279319328.02043" capture_lex $P17 .annotate 'line', 1 set $I15, 1 if $I15, if_14 .const 'Sub' $P20 = "12_1279319328.02043" capture_lex $P20 $P21 = $P20() set $P13, $P21 goto if_14_end if_14: .const 'Sub' $P17 = "11_1279319328.02043" capture_lex $P17 $P18 = $P17() set $P13, $P18 if_14_end: .return ($P13) .end .HLL "squaak" .namespace [] .sub "_block19" :anon :subid("12_1279319328.02043") :outer("10_1279319328.02043") .annotate 'line', 1 .return () .end .HLL "squaak" .namespace [] .sub "_block16" :anon :subid("11_1279319328.02043") :outer("10_1279319328.02043") .annotate 'line', 1 .return () .end =back =cut pbc_to_exe.winxed000644000765000765 4557012101554067 16767 0ustar00bruce000000000000parrot-6.6.0/tools/dev#! winxed # Copyright (C) 2009-2012 Parrot Foundation. /* =head1 NAME pbc_to_exe - Generate executables from Parrot bytecode =head1 DESCRIPTION Compile bytecode to executable. =head2 SYNOPSIS pbc_to_exe my.pbc => my.exe pbc_to_exe my.pbc --install => installable_my.exe =cut */ $include_const "interpcores.pasm"; $load "Getopt/Obj.pbc"; $load "config.pbc"; #------------------------------------------------------- # Blocks of C code const string C_HEADER = <<:HEADER #include #include #include "parrot/api.h" int Parrot_set_config_hash(Parrot_PMC interp_pmc); static void show_last_error_and_exit(Parrot_PMC interp); static void print_parrot_string(Parrot_PMC interp, FILE *vector, Parrot_String str, int newline); static void setup_pir_compregs(Parrot_PMC interp); static PMC * get_class_pmc(Parrot_PMC interp, const char *name); static void get_imcc_compiler_pmc(Parrot_PMC interp, Parrot_PMC class_pmc, Parrot_Int is_pasm); #define TRACE 0 HEADER:>> ; #------------------------------------------------------- const string C_MAIN = <<:MAIN int main(int argc, const char *argv[]) { PMC *interp; PMC *pbc; PMC *argsarray; const unsigned char *program_code_addr; Parrot_Init_Args *initargs; GET_INIT_STRUCT(initargs); initargs->gc_system = GCCORE; program_code_addr = get_program_code(); if (!program_code_addr) exit(EXIT_FAILURE); if (!(Parrot_api_make_interpreter(NULL, 0, initargs, &interp) && Parrot_set_config_hash(interp) && Parrot_api_set_executable_name(interp, argv[0]) && Parrot_api_set_runcore(interp, RUNCORE, TRACE))) { fprintf(stderr, "PARROT VM: Could not initialize new interpreter\n"); show_last_error_and_exit(interp); } setup_pir_compregs(interp); if (!Parrot_api_pmc_wrap_string_array(interp, argc, argv, &argsarray)) { fprintf(stderr, "PARROT VM: Could not build args array"); show_last_error_and_exit(interp); } if (!Parrot_api_load_bytecode_bytes(interp, program_code_addr, (Parrot_Int) bytecode_size, &pbc)) { fprintf(stderr, "PARROT VM: Could not load bytecode\n"); show_last_error_and_exit(interp); } if (!Parrot_api_run_bytecode(interp, pbc, argsarray)) { show_last_error_and_exit(interp); } if (!Parrot_api_destroy_interpreter(interp)) { fprintf(stderr, "PARROT VM: Could not destroy interpreter\n"); show_last_error_and_exit(interp); } exit(EXIT_SUCCESS); } static void show_last_error_and_exit(Parrot_PMC interp) { Parrot_String errmsg, backtrace; Parrot_Int exit_code, is_error; Parrot_PMC exception; if (!Parrot_api_get_result(interp, &is_error, &exception, &exit_code, &errmsg)) exit(EXIT_FAILURE); if (is_error) { if (!Parrot_api_get_exception_backtrace(interp, exception, &backtrace)) exit(EXIT_FAILURE); print_parrot_string(interp, stderr, errmsg, 1); print_parrot_string(interp, stderr, backtrace, 0); } exit(exit_code); } static void print_parrot_string(Parrot_PMC interp, FILE *vector, Parrot_String str, int newline) { char *msg_raw; if (!str) return; if (!Parrot_api_string_export_ascii(interp, str, &msg_raw)) show_last_error_and_exit(interp); if (msg_raw) { fprintf(vector, "%s%s", msg_raw, newline ? "\n" : ""); if (!Parrot_api_string_free_exported_ascii(interp, msg_raw)) show_last_error_and_exit(interp); } } static void setup_pir_compregs(Parrot_PMC interp) { Parrot_PMC class_pmc = get_class_pmc(interp, "IMCCompiler"); get_imcc_compiler_pmc(interp, class_pmc, 0); get_imcc_compiler_pmc(interp, class_pmc, 1); } PARROT_CANNOT_RETURN_NULL static PMC * get_class_pmc(Parrot_PMC interp, ARGIN(const char *name)) { Parrot_String name_s = NULL; Parrot_PMC name_pmc = NULL; Parrot_PMC class_pmc = NULL; if (!(Parrot_api_string_import_ascii(interp, name, &name_s) && Parrot_api_pmc_box_string(interp, name_s, &name_pmc) && Parrot_api_pmc_get_class(interp, name_pmc, &class_pmc))) show_last_error_and_exit(interp); return class_pmc; } PARROT_CANNOT_RETURN_NULL static void get_imcc_compiler_pmc(Parrot_PMC interp, Parrot_PMC class_pmc, Parrot_Int is_pasm) { Parrot_PMC is_pasm_pmc = NULL; Parrot_PMC compiler_pmc = NULL; const char * const name = is_pasm ? "PASM" : "PIR"; Parrot_String name_s = NULL; if (!Parrot_api_pmc_box_integer(interp, is_pasm, &is_pasm_pmc)) show_last_error_and_exit(interp); if (!Parrot_api_pmc_new_from_class(interp, class_pmc, is_pasm_pmc, &compiler_pmc)) show_last_error_and_exit(interp); if (!(Parrot_api_string_import_ascii(interp, name, &name_s) && Parrot_api_set_compiler(interp, name_s, compiler_pmc))) show_last_error_and_exit(interp); } MAIN:>> ; #------------------------------------------------------- function main [main] (var argv) { :(string infile, string cfile, string objfile, string exefile, string runcore, string gccore, int install) = handle_args(argv) if (infile == "") throw "cannot read infile"; var outfh = open(cfile, 'w'); if (! outfh) throw "cannot write outfile"; outfh.print(C_HEADER); string code_type = determine_code_type(); switch (code_type) { case "gcc": generate_code_gcc(infile, outfh); break; case "msvc": generate_code_msvc(infile, outfh); break; default: generate_code(infile, outfh); } print_define(outfh, "RUNCORE", runcore); print_define(outfh, "GCCORE", gccore); outfh.print(C_MAIN); # The close opcode does not return a result code, # use the method instead. int closeresult = outfh.close(); if (closeresult != 0) throw "cannot close outfile"; string extra_obj = code_type != 'msvc' ? '' : replace_pbc_extension(infile, '.RES'); compile_file(cfile, objfile, install); link_file(objfile, exefile, extra_obj, install); } function print_define(var outfh, var args[slurpy]) { string name = args[1]; if (name == null) name = sprintf("#define %s NULL\n", args); else name = sprintf("#define %s \"%s\"\n", args); outfh.print(name); } function handle_args(var argv) { var config = _config(); string obj = config['o']; string exe = config['exe']; var getopt = new ['Getopt','Obj']; push(getopt, 'install|i'); push(getopt, 'runcore|R:s'); push(getopt, 'output|o:s'); push(getopt, 'help|h'); push(getopt, 'gc:s'); argv.shift(); # ignore program name var opts = getopt.get_options(argv); int help = opts['help']; int install = opts['install']; string runcore = opts['runcore']; string outfile = opts['output']; string gccore = opts['gc']; if (gccore == "") gccore = null; if (help) { getstderr().print(<<:HELP pbc_to_exe [options] Options: -h --help -i --install -R --runcore=slow|fast -o --output=FILE --gc=ms2|gms HELP:>> ); exit(0); } string infile = argv.shift(); string ext = downcase(substr(infile, -4, 4)); if (ext != '.pbc') throw "input pbc file name does not end in '.pbc'"; string cfile, objfile, exefile; if (outfile != '') { int l = length(exe); string $S0 = downcase(substr(outfile, -l, l)); string $S1 = downcase(exe); if ($S0 != $S1) throw "output executable name does not end in '" + exe + "'"; outfile = replace(outfile, -l, l, ''); cfile = outfile + '.c'; objfile = outfile + obj; exefile = outfile + exe; } else { # substitute .c for .pbc # remove .c for executable outfile = replace(infile, -4, 4, ''); # remove .pbc extension cfile = outfile + '.c'; objfile = outfile + obj; exefile = outfile + exe; if (install) exefile = prepend_installable(exefile); } string runcore_code; switch (runcore) { case 'slow': runcore_code = 'slow'; break; case 'fast': case '': runcore_code = 'fast'; break; default: # invalid runcore name throw "Unsupported runcore: '" + runcore + "'"; } return infile, cfile, objfile, exefile, runcore_code, gccore, install; } function determine_code_type() { var config = _config(); string gcc_ver = config['gccversion']; if (gcc_ver != '') return ('gcc'); string cc = config['cc']; string os_name = config['osname']; if (os_name == 'MSWin32' && cc == 'cl') return 'msvc'; return 'default'; } # Winxed has no builtin for spawnw with string argument. # This function provides it. function spawnw_cmd(string cmd) { int status; ${ spawnw status, cmd }; return status; } const int READBUFFER_SIZE = 16384; function generate_code(string infile, var outfh) { var ifh = open(infile, 'rb'); if (!ifh) throw "cannot open infile"; outfh.print("const Parrot_UInt1 program_code[] = {"); int size = 0; for (;;) { string pbcstring = ifh.read(READBUFFER_SIZE); int pbclength = length(pbcstring); if (pbclength <= 0) break; for (int pos = 0; pos < pbclength; ++pos) { outfh.print(string(ord(pbcstring, pos))); outfh.print(','); ++size; if ((size % 32) == 0) outfh.print("\n"); } } ifh.close(); outfh.print("\n};\n\nconst size_t bytecode_size = "); outfh.print(size); outfh.print(";\n"); outfh.print(<<:END_OF_FUNCTION const unsigned char * get_program_code(void) { return program_code; } END_OF_FUNCTION:>> ); } # The PBC will be represented as a C string, so this sub builds a table # of the C representation of each ASCII character, for lookup by ordinal value. function generate_encoding_table() { # Use '\%o' for speed, or '\x%02x' for readability const string encoding_format = '\%o'; # The 'sprintf' op requires the arglist to be in an array, even when # there is only one arg. int one_number[1]; string coded_strings[256]; for (int index = 0; index < 256; ++index) { one_number[0] = index; coded_strings[index] = sprintf(encoding_format, one_number); } return coded_strings; } function generate_code_gcc(string infile, var outfh) { var ifh = open(infile, 'rb'); if (!ifh) throw "cannot open infile"; var encoding_table = generate_encoding_table(); outfh.print("const unsigned char program_code[] =\n\""); int size = 0; for (;;) { string pbcstring = ifh.read(READBUFFER_SIZE); int pbclength = length(pbcstring); if (pbclength <= 0) break; for(int pos = 0; pos < pbclength; ++pos) { outfh.print(string(encoding_table[ord(pbcstring, pos)])); ++size; if ((size % 32) == 0) outfh.print("\"\n\""); } } ifh.close(); outfh.print("\"\n;\n\nconst size_t bytecode_size = "); outfh.print(size); outfh.print(";\n"); outfh.print(<<:END_OF_FUNCTION const unsigned char * get_program_code(void) { return program_code; } END_OF_FUNCTION:>> ); } # Transforms the .pbc path into one with a different extension. # Passing '' means no extension. # Extensions without leading dots will have a dot pre-pended. function replace_pbc_extension(string pbc_path, string new_extension) { string ext = downcase(substr(pbc_path, -4)); if (ext != '.pbc') throw "input pbc file name does not end in '.pbc'"; string base_path = replace(pbc_path, -4, 4, ''); string new_path = substr(base_path, 0); if (new_extension != '') { if (substr(new_extension, 0, 1) != '.') new_path += '.'; new_path += new_extension; } return new_path; } # In addition to generating the code for inclusion in the C file, # this sub creates supplemental .rc and .RES files. function generate_code_msvc(string pbc_path, var outfh) { string rc_path = replace_pbc_extension(pbc_path, '.rc' ); string res_path = replace_pbc_extension(pbc_path, '.res'); # The exact numbers are not relevant; # they are used to identify the resource within the final executable. string rc_constant_defines = <<:END_OF_DEFINES #define RESOURCE_NAME_ID_WHOLE_PBC 333 #define RESOURCE_TYPE_ID_WHOLE_PBC 444 END_OF_DEFINES:>> ; string rc_contents = rc_constant_defines + 'RESOURCE_NAME_ID_WHOLE_PBC RESOURCE_TYPE_ID_WHOLE_PBC "' + pbc_path + "\"\n"; var rc_fh = open(rc_path, 'w'); if (! rc_fh) throw "cannot open .rc file"; rc_fh.print(rc_contents); if (rc_fh.close() != 0) throw "cannot close .rc file"; var $P0 = new ['OS']; var $P1 = $P0.stat(pbc_path); int pbc_size = $P1[7]; outfh.print("#include \n"); outfh.print(rc_constant_defines); outfh.print("const unsigned int bytecode_size = "); outfh.print(pbc_size); outfh.print(";\n"); outfh.print(<<:END_OF_FUNCTION const unsigned char * get_program_code(void) { HRSRC hResource; DWORD size; HGLOBAL hPBC; LPVOID actual_pointer_to_pbc_in_memory; hResource = FindResource( NULL, MAKEINTRESOURCE(RESOURCE_NAME_ID_WHOLE_PBC), MAKEINTRESOURCE(RESOURCE_TYPE_ID_WHOLE_PBC) ); if (!hResource) return NULL; size = SizeofResource( NULL, hResource ); if (size != bytecode_size) return NULL; hPBC = LoadResource( NULL, hResource ); if (!hPBC) return NULL; actual_pointer_to_pbc_in_memory = LockResource( hPBC ); if (!actual_pointer_to_pbc_in_memory) return NULL; return actual_pointer_to_pbc_in_memory; } END_OF_FUNCTION:>> ); string rc_cmd = 'rc ' + rc_path; say(rc_cmd); int status = spawnw_cmd(rc_cmd); if (status != 0) throw "RC command failed"; } # util functions function compile_file(string cfile, string objfile, int install) { var $P0 = '_config'(); string cc = $P0['cc']; string ccflags = $P0['ccflags']; string optimize = $P0['optimize']; string cc_o_out = $P0['cc_o_out']; string osname = $P0['osname']; string build_dir = $P0['build_dir']; string slash = $P0['slash']; string installed = $P0['installed']; string includepath = $P0['includedir']; string versiondir = $P0['versiondir']; string includedir = installed != "1" ? build_dir + slash + 'include' : includepath + versiondir; string pathquote = '"'; string compile = cc + ' ' + cc_o_out + objfile + ' -I' + pathquote + includedir + pathquote + ' ' + ccflags + ' ' + optimize + ' -c ' + cfile; say(compile); int status = spawnw_cmd(compile); if (status != 0) throw "compilation failed"; say("Compiled: ", objfile); return; } function link_file(string objfile, string exefile, string extra_obj, int install) { var $P0 = _config(); string cc = $P0['cc']; string link = $P0['link']; string link_dynamic = $P0['link_dynamic']; string linkflags = $P0['linkflags']; string ld_out = $P0['ld_out']; string libparrot = $P0['libparrot_linkflags']; string libs = $P0['libs']; string o = $P0['o']; string rpath = $P0['rpath_blib']; string osname = $P0['osname']; string build_dir = $P0['build_dir']; string slash = $P0['slash']; string icushared = $P0['icu_shared']; string installed = $P0['installed']; string libdir = $P0['libdir']; string versiondir = $P0['versiondir']; string optimize = $P0['optimize']; string pathquote = '"'; string config = pathquote; if (installed != '1') { config += build_dir + slash + 'src' + slash; if (! install) config += 'parrot_config'; else { config += 'install_config'; rpath = $P0['rpath_lib']; } } else { rpath = $P0['rpath_lib']; libparrot = $P0['inst_libparrot_linkflags']; config += libdir + versiondir + slash + 'parrot_config'; } config += o; config += pathquote; #if (osname == 'cygwin' || install || optimize == '') # link += ' -s'; link += ' ' + ld_out + exefile + ' ' + pathquote + objfile + pathquote; if (extra_obj != '') link += ' ' + pathquote + extra_obj + pathquote; link += ' ' + config + ' ' + rpath + ' ' + libparrot + ' ' + link_dynamic + ' ' + linkflags + ' ' + libs + ' ' + icushared; say(link); int status = spawnw_cmd(link); if (status != 0) throw "linking failed"; # Check if there is a MSVC app manifest $P0 = loadlib('file'); var file = new [ 'File' ]; string manifest_file_name = exefile + '.manifest'; var manifest_exists = file.exists(manifest_file_name); if (manifest_exists != 0) { # MSVC app manifest exists, embed it string embed_manifest_str = 'mt.exe -nologo -manifest ' + manifest_file_name + ' -outputresource:' + exefile + ';1'; say(embed_manifest_str); int embed_manifest_status = spawnw_cmd(embed_manifest_str); if (embed_manifest_status != 0) throw 'manifest embedding failed'; } say("Linked: ", exefile); return; } # handle any directory components function prepend_installable(string file) { var path = split('/', file); file = path[-1]; file = 'installable_' + file; path[-1] = file; file = join('/', path); return file; } // End 044-slurp_file.t000644000765000765 432511533177644 16567 0ustar00bruce000000000000parrot-6.6.0/t/configure#! perl # Copyright (C) 2007, Parrot Foundation. # 044-slurp_file.t use strict; use warnings; use Test::More tests => 9; use Carp; use File::Temp qw| tempfile |; use lib qw( lib ); use Parrot::BuildUtil; { my ( $fh, $tempfile ) = tempfile( UNLINK => 1 ); open $fh, ">", $tempfile or croak "Unable to open tempfile for writing"; print $fh "Testing Parrot::BuildUtil::slurp_file()\n"; close $fh or croak "Unable to close tempfile after writing"; ok( -f $tempfile, "tempfile created for testing" ); my $str = Parrot::BuildUtil::slurp_file($tempfile); ok( $str, "slurpfile() returned true value" ); like( $str, qr/Testing Parrot::BuildUtil::slurp_file/, "Main content of tempfile correctly slurped" ); } { my ( $fh, $tempfile ) = tempfile( UNLINK => 1 ); open $fh, ">", $tempfile or croak "Unable to open tempfile for writing"; print $fh "Testing Parrot::BuildUtil::slurp_file()\cM\cJ\n"; close $fh or croak "Unable to close tempfile after writing"; ok( -f $tempfile, "tempfile created for testing" ); my $str = Parrot::BuildUtil::slurp_file($tempfile); ok( $str, "slurpfile() returned true value" ); like( $str, qr/Testing Parrot::BuildUtil::slurp_file/, "Main content of tempfile correctly slurped" ); like( $str, qr/\n{2}/m, "DOS line endings correctly converted during slurp_file" ); } { my $phony = $$; my $str; eval { $str = Parrot::BuildUtil::slurp_file($phony); }; like( $@, qr/open '$phony'/, "Got error message expected upon attempting to slurp non-existent file" ); } pass("Completed all tests in $0"); ################### DOCUMENTATION ################### =head1 NAME 044-slurp_file.t - test C =head1 SYNOPSIS % prove t/configure/044-slurp_file.t =head1 DESCRIPTION The files in this directory test functionality used by F. The tests in this file test C. =head1 AUTHOR James E Keenan =head1 SEE ALSO Parrot::BuildUtil, F. =cut # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: 44-try-catch.t000644000765000765 242312135343346 17071 0ustar00bruce000000000000parrot-6.6.0/ext/nqp-rx/t/nqp#!./parrot-nqp # Tests for try and catch plan(8); sub oops($msg = "oops!") { # throw an exception my $ex := Q:PIR { %r = new ['Exception'] }; $ex := $msg; pir::throw($ex); } my $ok := 1; try { oops(); $ok := 0; } ok($ok, "exceptions exit a try block"); sub foo() { try { return 1; } return 0; } ok(foo(), "control exceptions are not caught by a try block"); ok(try oops(), "statement prefix form of try works"); { CATCH { ok(1, "CATCH blocks are invoked when an exception occurs"); } oops(); } $ok := 1; sub bar() { CATCH { $ok := 0; } return; } bar(); ok($ok, "CATCH blocks ignore control exceptions"); $ok := 1; { { { oops(); CATCH { $ok := $ok * 2; pir::rethrow($!); } } CATCH { $ok := $ok * 2; pir::rethrow($!); } } CATCH { $ok := $ok * 2; pir::rethrow($!); } CATCH { ok($ok == 8, "rethrow and multiple exception handlers work") } } $ok := 1; { for 1, 2, 3, 4 { $ok := $ok * 2; oops(); } CATCH { my &c := $!; &c(); } } ok($ok == 16, "resuming from resumable exceptions works"); $ok := 0; { CATCH { $ok := -1; } CONTROL { $ok := 1; } return 5; } ok($ok == 1, "CONTROL blocks catch control exceptions"); Compilers.pm000644000765000765 244311533177636 20311 0ustar00bruce000000000000parrot-6.6.0/lib/Parrot/Docs/Section# Copyright (C) 2006-2007, Parrot Foundation. =head1 NAME Parrot::Docs::Section::Compilers - Compilers documentation section =head1 SYNOPSIS use Parrot::Docs::Section::Compilers; =head1 DESCRIPTION A documentation section describing all compilers in Parrot. =head2 Class Methods =over =cut package Parrot::Docs::Section::Compilers; use strict; use warnings; use base qw( Parrot::Docs::Section ); use Parrot::Distribution; =item C Returns a new section. =cut sub new { my $self = shift; return $self->SUPER::new( 'Compilers', 'compilers.html', '', $self->new_group( 'IMCC', 'the Intermediate Code Compiler for Parrot', 'compilers/imcc' ), $self->new_group( 'PGE', 'the Parrot Grammar Engine', 'compilers/pge' ), $self->new_group( 'TGE', 'the Tree Grammar Engine', 'compilers/tge' ), $self->new_group( 'PCT', 'Parrot Compiler Toolkit', 'compilers/pct' ), $self->new_group( 'JSON', 'JavaScript Object Notation', 'compilers/data_json' ), $self->new_group( 'NCIGEN', 'Native Call Interface Generator', 'compilers/ncigen' ), ); } =back =cut 1; # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: cage_cleaners_guide.pod000644000765000765 3164012307662657 20562 0ustar00bruce000000000000parrot-6.6.0/docs/project# Copyright (C) 2007-2012, Parrot Foundation. =pod =head1 NAME docs/project/cage_cleaners_guide.pod - Cage Cleaner Guide. =head1 DESCRIPTION From F: Fixes failing tests, makes sure coding standards are implemented, reviews documentation and examples. A class of tickets in the tracking system (Trac) has been created for use by this group. This is an entry level position, and viewed as a good way to get familiar with parrot internals. =head1 TESTING PARROT AFTER MAKING A CODE CLEANING CHANGE To be really I sure you're not breaking anything after doing code cleaning or attending to the newspaper at the bottom of our Parrot's cage here are is the process I (ptc) go through before committing a new change: make realclean > make_realclean.out 2>&1 perl Configure.pl > perl_configure.out 2>&1 make buildtools_tests > buildtools_tests.out 2>&1 make test > make_test.out 2>&1 Then I diff the C<*.out> files with copies of the C<*.out> files I made on a previous test run. If the diffs show nothing nasty is happening, you can be more sure that you've not broken anything and can commit the change. Then rename the C<*.out> files to something like C<*.out.old> so that you maintain reasonably up to date references for the diffs. This process should be put into a script and stored somewhere... =head1 PARROT CAGE CLEANERS' HIGH-LEVEL GOALS =head2 Smoke testing on many platforms with many compilers The more platforms we have, the more likely we are to find portability problems. Parrot has to be the most portable thing we've created. More platforms also means more compilers. Maybe your DEC compiler is more picky than gcc, and spews more warnings. Good! More opportunities for cleaning! =head3 icc C is the Intel C/C++ Compiler and is available for free for non-commercial use. To use C to build parrot, use the following arguments to C: perl Configure.pl --cc=icc --ld=icc (courtesy of Steve Peters, C). =head2 Compiler pickiness Use as many compiler warnings as we possibly can. The more warnings we enable, the less likely something will pass the watchful eye of the compiler. Note that warnings may not just be -W flags. Some warnings in gcc only show up when optimization is enabled. Use the C<--cage> option to C to enable extra warnings which are useful in keeping the cage clean. =head3 gcc fortify source macro In gcc it is possible to use the C<-D_FORTIFY_SOURCE=x> macro to provide "a lightweight buffer overflow protection to some memory and string functions" (C). Checks are implemented at compile- and run-time, thus it is also a good idea to run the test suite in combination with this compiler option. There are two levels to this macro usage: =over 4 =item C<-D_FORTIFY_SOURCE=1> This option is only available in combination with at least the C<-O1> optimisation option and performs security checks that shouldn't change the behaviour of conforming programs. Add this option to the C<--ccflags> configure option to enable it, e.g.: perl Configure.pl --ccflags="-D_FORTIFY_SOURCE=1 -O1" =item C<-D_FORTIFY_SOURCE=2> This option is only available in combination with at least the C<-O2> optimisation option and performs more checking which might cause conforming programs to fail. It can be added to the C<--ccflags> configure option and used in combination with the C<--optimize> configure option like so: perl Configure.pl --optimize --ccflags="-D_FORTIFY_SOURCE=2" =back =head2 splint Splint (L) is a very very picky lint tool, and setup and configuration is a pain. Andy has tried to get Perl 5 running under it nicely, but has met with limited success. Maybe the Parrot will be nicer. =head2 Solaris lint Sun has made its dev tools freely available at L. Its lint is the best one out there, except from Gimpel's FlexeLint (L) which costs many dollars. =head2 Enforcing coding standards, naming conventions, etc =over 4 =item * Automatic standards checking The docs in F explains what our code should look like. Write something that automatically validates it in a .t file. =item * C checking Declaring variables as C wherever possible lets the compiler do lots of checking that wouldn't normally be possible. Walk the source code adding the C qualifier wherever possible. The biggest bang is always in passing pointers into functions. =back =head2 Why consting is good In Perl, we have the C pragma to define unchanging values. The L module extends this to allow arrays and hashes to be non-modifiable as well. In C, we have C numbers and pointers, and using them wherever possible lets us put safety checks in our code, and the compiler will watch over our shoulders. =head3 C numbers The easiest way to use the C qualifier is by flagging numbers that are set at the top of a block. For example: int max_elements; max_elements = nusers * ELEMENTS_PER_USER; ... array[max_elements++] = n; /* but you really meant array[max_elements] = n++; */ Adding a C qualifier means you can't accidentally modify C. const int max_elements = nusers * ELEMENTS_PER_USER; =head3 C pointers If a pointer is qualified as const, then its contents cannot be modified. This lets the compiler protect you from doing naughty things to yourself. Here are two examples for functions you're familiar with: int strlen( const char *str ); void memset( char *ptr, char value, int length ); In the case of C, the caller is guaranteed that any string passed in won't be modified. How terrible it would be if it was possible for C to modify what gets passed in! The const on C's parameter also lets the compiler know that C can't be initializing what's passed in. For example: char buffer[ MAX_LEN ]; int n = strlen( buffer ); The compiler knows that C hasn't been initialized, and that C can't be initializing it, so the call to C is on an uninitialized value. Without the const, the compiler assumes that the contents of any pointer are getting initialized or modified. =head3 C arrays Consting arrays makes all the values in the array non-modifiable. const int days_per_month[] = { 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 }; You don't want to be able to do C, right? (We'll ignore that about 25% of the time you want C to be 29.) =head3 Mixing C Combining Cs on a pointer and its contents can get confusing. It's important to know on which side of the asterisk that the C lies. To the left of the asterisk, the characters are constant. To the right of the asterisk, the pointer is constant. Note the difference between a pointer to constant characters: /* Pointer to constant characters */ const char *str = "Don't change me."; str++; /* legal, now points at "o" */ *str = "x"; /* not legal */ and a constant pointer to characters: /* Constant pointer to characters */ char * const str = buffer; str++; /* not legal */ *str = 'x'; /* buffer[0] is now 'x' */ Note the difference between which side of the asterisk that the C is on. You can also combine the two, with a constant pointer to constant characters: const char * const str = "Don't change me"; or even an array of constant pointers to constant characters: const char * const days[] = { "Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat" }; If you see a declaration you don't understand, use C. It's standard in many C compiler suites, and is freely available around the net. $ cdecl Type `help' or `?' for help cdecl> explain const char * str; declare str as pointer to const char cdecl> explain char * const str; declare str as const pointer to char =head2 Decreasing the amount of repeated code PMD (L) has been used on C code, even though it's a Java tool. It looks for repeated strings of tokens that are candidates for either functions or macros. =head3 PMD usage General usage: pmd [directory] [report format] [ruleset file] To generate html output of unused code within parrot use: pmd . html rulesets/unusedcode.xml > unused_code.html Also distributed with PMD is the CPD (Copy/Paste Detector) which finds duplicate code. An easy way to get started with this tool is to use the gui (cpdgui). Set the root source directory to your parrot working directory, and choose the C option of the C menu. Then put C<.c> in the C box and click C. =head2 Automated source macros Perl5 has a lot of good source management techniques that we can use. =over 4 =item * Macro for interp argument A macro for declaring the interpreter argument, and maybe a macro for passing it BTW, our Perl experience teaches us that somebody is going to want to make the interpreter a C++ object for Windows environments, and it wouldn't hurt to make that possible, or at least work in that direction, as long as clarity doesn't suffer. =item * Parrot_xxx macros Automated processing that would make a macro to let us write somefunc(interp,a,b,c) while the linkage is Parrot_somefunc(interp,a,b,c) for namespace cleanup. This is straight out of F and F in Perl5. =back =head2 Automated generation of C headers This has started significantly with the F program. Right now, it extracts the function headers correctly, but now I have to have it create the F<.h> files. =head2 Creating automated code checking tools =head2 Documenting function behavior and structure members =head2 Developing coverage tools =head2 Automatically running the coverage tools =head2 Run on many different C compilers Most of Andy's work right now is with GCC 4.2 on Linux. We need many more. =head2 Run under valgrind Valgrind (L) is a profiler/debugger most notable for the way it magically monitors memory accesses and management. To run parrot under Valgrind, the following argument set should be helpful: valgrind --num-callers=500 \ --leak-check=full --leak-resolution=high --show-reachable=yes \ parrot --leak-test (adapted from a post to C by chromatic). See also the F and F files. C is a wrapper around running parrot with valgrind and uses a custom set of "valgrind suppressions". =head2 IMCC cleanup From #parrot: vsoni: there seems to be some dead code/feature....I had a chat with leo and I am going to send and email to p6i for deprecation of certain old features =head2 Help other contributors hack their patches into Parrot-style industrial-strength C code. From chip's comment at L We've just had contributed an improved register allocation implementation, but since the contributor is new to Parrot, there are some style and coding standards issues that need to be worked out. It'd be great if a Cage Cleaner could step up and help our new contributor bang the code into Parrotish form. =head2 Remove usage of deprecated features The F file lists features that are deprecated but not yet removed, as well as experimental features. A Trac ticket will document how this deprecated feature is to be replaced. Help prepare for the actual removal of the feature by replacing its usage. =head2 Clean up skipped tests Parrot has too many skipped tests. Pick a test file with a skipped test, disable the skip() line, then make it pass. The Parrot code may not compile, or you may have to modify it to bring it up to date. The test may not even be useful anymore; we won't know until you try. If you can make it pass, great! If you can make it run, great! Make it a TODO test instead. If neither, please report your findings so that everyone can decide what to do. =head1 HANDY CONFIGURATION TIPS =head2 Displaying trailing whitespace in vim and emacs =head3 Vim Add this to your C<.vimrc>: set list set listchars=trail:-,tab:\.\ B: there is a space character after the last backslash. It is very important! Contributed by Jerry Gay . =head3 Emacs Add this to your C<.emacs>: (setq-default show-trailing-whitespace t) Emacs 22 users can highlight tabs like this: (global-hi-lock-mode 1) (highlight-regexp "\t") Contributed by Eric Hanchrow . =head1 AUTHOR Paul Cochrane a.k.a. ptc; original document by Andy Lester =head1 SEE ALSO F, F and the list of Cage items in github L. =cut expect.pm000644000765000765 244512307662657 15554 0ustar00bruce000000000000parrot-6.6.0/config/auto# Copyright (C) 2014, Parrot Foundation. =head1 NAME config/auto/expect.pm - HAS_BUILTIN_EXPECT =head1 DESCRIPTION Check if the compiler understands __builtin_expect =cut package auto::expect; use strict; use warnings; use base qw(Parrot::Configure::Step); use Parrot::Configure::Utils ':auto'; sub _init { my $self = shift; my %data; $data{description} = q{Does your compiler support __builtin_expect}; $data{result} = q{}; return \%data; } sub runstep { my ( $self, $conf ) = @_; # gcc and clang should have it if (_test($conf)) { $conf->data->set( 'HAS_BUILTIN_EXPECT' => 1 ); $conf->debug("DEBUG: __builtin_expect detected\n"); $self->set_result('yes'); } else { $conf->data->set( 'HAS_BUILTIN_EXPECT' => 0 ); $conf->debug("DEBUG: __builtin_expect not detected\n"); $self->set_result('no'); } return 1; } #################### INTERNAL SUBROUTINES #################### sub _test { my ($conf) = @_; $conf->cc_gen('config/auto/expect/test_c.in'); eval { $conf->cc_build() }; my $ret = $@ ? 0 : eval $conf->cc_run(); $conf->cc_clean(); return $ret; } 1; # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: debian_packaging_guide.pod000644000765000765 1200712101554066 21213 0ustar00bruce000000000000parrot-6.6.0/docs/project# Copyright (C) 2007-2012, Parrot Foundation. =pod =head1 NAME docs/project/debian_packaging_guide.pod - Debian Packaging Guide. =head1 DESCRIPTION This is a quick set of instructions for packaging Parrot for Debian. =head1 DEBIAN PACKAGING GUIDE See the Debian New Maintainer's Guide (http://www.debian.org/doc/maint-guide) for more information. The Ubuntu Packaging Guide is also a good resource (http://doc.ubuntu.com/ubuntu/packagingguide/C/). This guide assumes that you're running in a chroot environment set up as in: L. For other configurations, see that page for a list of Debian packages you will need to install before building the Parrot packages. To package Parrot for Debian: =over 4 =item 0. Download the latest tarball. =item 1. Compile it and run the tests, just to be sure the tarball is sound (especially useful if you're running in a chroot environment different than your usual dev environment). =item 2. Create a new directory. (The name is irrelevant, but we'll use ~/deb/parrot for the sake of illustration.) Create a fresh extract of the tarball in the ~/deb/parrot directory. The directory should be named "parrot-" (it will be by default). Copy the debian/ directory from the Parrot source tree into the fresh tarball extract. cp -r /ports/debian ~/deb/parrot/parrot-/. Copy the original tarball into ~/deb/parrot, naming it "parrot_.orig.tar.gz" (note the "_" in place of dash). =item 3. Update the debian/changelog file in ~/deb/parrot/parrot-/. The format of the changelog file is strict (automatically parsed). The first line of the log entry gives the package version and categorization. For a new version upload, the version number is the Parrot version number followed by -1. For example: parrot (0.5.1-1) unstable; urgency=low The next few lines are the changelog record entries. These record changes in the Debian packaging of Parrot, not changes in Parrot itself. New package versions should include the line: * New upstream release. Please note any closed bugs related to the Parrot packages with an entry that includes the text "(Closes: #)". The final line gives the maintainer's name, email address, and the date. The date must be in RFC822 format, and can be generated by running C. (Note that two spaces are required between the email and the date.) -- Your Name Sun, 30 Dec 2007 17:21:45 +0000 =item 4. Update the debian/control.in file in ~/deb/parrot/parrot-/. Make sure you are listed in "Uploaders". The "Maintainer" will always be "Debian Parrot Maintainers ". =item 5. Update the debian/copyright file in ~/deb/parrot/parrot-/. Check for any removed files that no longer need copyright notices. Update the years in the Parrot Foundation copyright line if needed. =item 6. Make sure you have C installed. Run: $ aptitude install quilt =item 7. Regenerate the debian/control file. From the ~/deb/parrot/parrot-/ directory, run: $ debian/rules debian-control-stamp =item 8. Install all dependencies: $ sudo /usr/lib/pbuilder/pbuilder-satisfydepends =item 9. Build the packages. From ~/deb/parrot/parrot_/, run: $ export DEBSIGN_KEYID="" $ debuild =item 10. Check the package for errors. From ~/deb/parrot, run: $ lintian -i parrot_.changes =item 11. Commit all changes made to the files in the debian/ directory to the Parrot repository. =item 12. Upload the packages to http://alioth.debian.org. (If you don't have admin privileges, ask someone who does.) From any of the project pages, click on the "Admin" tab, then the "FRS Admin" link on the bottom of the page, then the link to "quick-release a file". Select the appropriate "Package ID" for the file (the same as the filename without the version). For the "Release Name" use the current version number (e.g. 0.6.1). For the "Release Date" use the date and time you listed in the debian changelog file (the date and time the debian package was created, not Parrot's release date for that version). For the "Release Notes" use the standard release text (the email/website/press announcement) without the change list. For the "Change Log" use the change list from the standard release text. Also check "Preserve my pre-formatted text". =back =head1 SEE ALSO F, F. =head1 APPENDIX 1 Parrot Debian Release Managers - Allison Randal - Nuno Carvalho - Patrick Michaud Parrot Debian Sponsors - Colin Watson - Jeff Bailey - Benjamin Mako Hill =head1 APPENDIX 2 Set up instructions for new Debian Parrot release managers. =over 4 =item 0. Create an account on http://alioth.debian.org and request to join the group pkg-parrot. =item 1. If you will be uploading through a sponsor, create an account on http://mentors.debian.net. =item 2. Set up a chroot environment for building packages. See . =back =cut foo-05.t000644000765000765 117011606346660 14424 0ustar00bruce000000000000parrot-6.6.0/t/dynpmc#!./parrot # Copyright (C) 2011, Parrot Foundation. .sub main :main .include 'test_more.pir' plan(1) ## get load_ext in $S0. .include "iglobals.pasm" $P11 = getinterp $P12 = $P11[.IGLOBALS_CONFIG_HASH] $S0 = $P12["load_ext"] ## load a relative pathname with an extension. $S0 = concat "runtime/parrot/dynext/foo_group", $S0 loadlib $P1, $S0 ## ensure that we can still make Foo instances. $P1 = new "Foo" $I1 = $P1 is($I1, 42, 'loadlib with relative pathname & ext') .end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: threads.t000644000765000765 517412101554067 15103 0ustar00bruce000000000000parrot-6.6.0/t/stress#! perl # Copyright (C) 2012-2013, Parrot Foundation. =head1 NAME t/stress/threads.t - Threads with Garbage Collection =head1 SYNOPSIS % prove -v t/stress/threads.t =head1 DESCRIPTION Tests threads stability under garbage collection. Also IO stress: Large -t trace pir output segfaults in GC =cut use strict; use warnings; use lib qw(lib . ../lib ../../lib); use Test::More; use Parrot::Test tests => 2; use Parrot::Config; # Task stress with GC # Segfault #880 { $ENV{TEST_PROG_ARGS} ||= ''; if ($^O eq 'darwin') { my $cwd = `pwd`; chomp($cwd); $ENV{DYLD_LIBRARY_PATH} = $cwd."/blib/lib"; } my $parrot = File::Spec->join( File::Spec->curdir(), 'parrot' . $PConfig{exe} ); my $src = 'examples/threads/chameneos.pir'; my $pbc = 'examples/threads/chameneos.pbc'; system($parrot, '-o', $pbc, $src); my $todo = $PConfig{ccflags} =~ /-DTHREAD_DEBUG/; pbc_exit_code_is( $pbc, 0, 'chameneos', $todo ? (todo => 'GH880 GC walks into thread interp') : ()); unlink $pbc; } # IO stress: trace pir output segfaults # ASSERT src/gc/gc_gms.c:1189: failed assertion '(pmc) == NULL || (pmc)->orig_interp == (interp)' { local $ENV{TEST_PROG_ARGS} .= '-t1'; pir_exit_code_is( << 'CODE', 0, "IO Stress with -t", todo => 'GH875 threads and -t1: gc_gms_mark_pmc_header: self->work_list might be empty' ); .sub test :main load_bytecode "dumper.pbc" load_bytecode 'Test/More.pbc' load_bytecode 'MIME/Base64.pbc' load_bytecode 'PGE.pbc' load_bytecode 'PGE/Util.pbc' load_language 'data_json' .local pmc json json = compreg 'data_json' .local pmc encode_decode_tests, decode_tests encode_decode_tests = json.'compile'( <<'END_JSON' ) [ ["Hello, World!\n","SGVsbG8sIFdvcmxkIQo="], ["aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", "YWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFh\nYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYQ=="] ] END_JSON .local pmc enc_sub enc_sub = get_global [ "MIME"; "Base64" ], 'encode_base64' .local pmc is is = get_hll_global [ 'Test'; 'More' ], 'is' .local pmc test_iterator, test_case encode_decode_tests = encode_decode_tests() test_iterator = iter encode_decode_tests .local string plain, base64, result test_case = shift test_iterator plain = shift test_case base64 = shift test_case result = enc_sub( plain ) is( result, base64 ) .end CODE } 1; # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: 24-module.t000644000765000765 37412101554066 16435 0ustar00bruce000000000000parrot-6.6.0/ext/nqp-rx/t/nqp#!./parrot-nqp # check module plan(3); XYZ::foo('ok 1'); XYZ::sayfoo(); module XYZ { our $value := 'ok 2'; our sub foo($x) { $value := $x; } our sub sayfoo() { say($value // 'ok 1'); } sayfoo(); } XYZ::foo('ok 3'); XYZ::sayfoo(); platform_interface.h000644000765000765 2626112307662657 20502 0ustar00bruce000000000000parrot-6.6.0/include/parrot/* * Copyright (C) 2003-2012, Parrot Foundation. */ #ifndef PARROT_PLATFORM_INTERFACE_H_GUARD #define PARROT_PLATFORM_INTERFACE_H_GUARD /* ** platform_interface.h */ #include "parrot/config.h" #include "parrot/interpreter.h" #include #if PARROT_HAS_HEADER_LIMITS # include #endif #ifndef PARROT_HAS_TIMESPEC struct timespec { time_t tv_sec; long tv_nsec; }; #endif /* PARROT_HAS_TIMESPEC */ #ifdef _MSC_VER # ifndef LLONG_MAX # define LLONG_MAX _I64_MAX # endif # ifndef LLONG_MIN # define LLONG_MIN _I64_MIN # endif # if _MSC_VER >= 1400 # define strdup _strdup # endif /* These disable certain Level 4 Warnings */ # pragma warning(disable: 4100) /* disables 'unreferenced formal parameter' * warnings */ # pragma warning(disable: 4115) /* disables 'named type definition in * parentheses' warnings triggered in VC98 * include files */ # pragma warning(disable: 4505) /* disables 'unreferenced local function has * been removed' warnings in header files */ #endif /* _MSC_VER */ /* * init */ void Parrot_platform_init_code(void); /* * Errors */ STRING *Parrot_platform_strerror(PARROT_INTERP, INTVAL error); /* ** I/O: */ #ifdef _WIN32 # define PIO_INVALID_HANDLE ((void *)-1) typedef void *PIOHANDLE; typedef HUGEINTVAL PIOOFF_T; #else # define PIO_INVALID_HANDLE -1 typedef INTVAL PIOHANDLE; typedef off_t PIOOFF_T; #endif PIOHANDLE Parrot_io_internal_std_os_handle(PARROT_INTERP, INTVAL fileno); PIOHANDLE Parrot_io_internal_open(PARROT_INTERP, ARGIN(STRING *path), INTVAL flags); PIOHANDLE Parrot_io_internal_dup(PARROT_INTERP, PIOHANDLE handle); INTVAL Parrot_io_internal_close(PARROT_INTERP, PIOHANDLE handle); INTVAL Parrot_io_internal_is_tty(PARROT_INTERP, PIOHANDLE fd); PARROT_CONST_FUNCTION INTVAL Parrot_io_internal_getblksize(PIOHANDLE fd); INTVAL Parrot_io_internal_flush(PARROT_INTERP, PIOHANDLE os_handle); size_t Parrot_io_internal_read(PARROT_INTERP, PIOHANDLE os_handle, ARGOUT(char *buf), size_t len); size_t Parrot_io_internal_write(PARROT_INTERP, PIOHANDLE os_handle, ARGIN(const char *buf), size_t len); PIOOFF_T Parrot_io_internal_seek(PARROT_INTERP, PIOHANDLE os_handle, PIOOFF_T offset, INTVAL whence); PIOOFF_T Parrot_io_internal_tell(PARROT_INTERP, PIOHANDLE os_handle); PIOHANDLE Parrot_io_internal_open_pipe(PARROT_INTERP, ARGIN(STRING *command), INTVAL flags, ARGOUT(INTVAL *pid_out)); INTVAL Parrot_io_internal_pipe(PARROT_INTERP, ARGMOD(PIOHANDLE *reader), ARGMOD(PIOHANDLE *writer)); PARROT_EXPORT INTVAL Parrot_io_internal_async(PARROT_INTERP, ARGMOD(PMC *pmc), INTVAL async); /* * Socket */ PMC *Parrot_io_internal_getaddrinfo(PARROT_INTERP, ARGIN(STRING *addr), INTVAL port, INTVAL protocol, INTVAL family, INTVAL passive); INTVAL Parrot_io_internal_addr_match(PARROT_INTERP, ARGIN(PMC *sa), INTVAL family, INTVAL type, INTVAL protocol); STRING *Parrot_io_internal_getnameinfo(PARROT_INTERP, ARGIN(const void *addr), INTVAL addr_len); INTVAL Parrot_io_internal_getprotobyname(PARROT_INTERP, ARGIN(STRING *name)); PIOHANDLE Parrot_io_internal_socket(PARROT_INTERP, int fam, int type, int proto); void Parrot_io_internal_connect(PARROT_INTERP, PIOHANDLE handle, ARGIN(void *addr), INTVAL addr_len); void Parrot_io_internal_bind(PARROT_INTERP, PIOHANDLE handle, ARGIN(void *addr), INTVAL addr_len); void Parrot_io_internal_listen(PARROT_INTERP, PIOHANDLE handle, INTVAL sec); PIOHANDLE Parrot_io_internal_accept(PARROT_INTERP, PIOHANDLE handle, ARGOUT(PMC * remote_addr)); INTVAL Parrot_io_internal_send(PARROT_INTERP, PIOHANDLE handle, ARGIN(const char *buf), size_t len); INTVAL Parrot_io_internal_recv(PARROT_INTERP, PIOHANDLE handle, ARGOUT(char *buf), size_t len); INTVAL Parrot_io_internal_poll(PARROT_INTERP, PIOHANDLE handle, int which, int sec, int usec); INTVAL Parrot_io_internal_close_socket(PARROT_INTERP, PIOHANDLE handle); /* * Files and directories */ /* &gen_from_def(stat.pasm) */ #define STAT_EXISTS 0 #define STAT_FILESIZE 1 #define STAT_ISDIR 2 #define STAT_ISREG 3 #define STAT_ISDEV 4 #define STAT_CREATETIME 5 #define STAT_ACCESSTIME 6 #define STAT_MODIFYTIME 7 #define STAT_CHANGETIME 8 #define STAT_BACKUPTIME 9 #define STAT_UID 10 #define STAT_GID 11 #define STAT_ISLNK 12 #define STAT_PLATFORM_DEV -1 #define STAT_PLATFORM_INODE -2 #define STAT_PLATFORM_MODE -3 #define STAT_PLATFORM_NLINKS -4 #define STAT_PLATFORM_DEVTYPE -5 #define STAT_PLATFORM_BLOCKSIZE -6 #define STAT_PLATFORM_BLOCKS -7 #define STAT_TYPE_UNKNOWN 0 #define STAT_TYPE_FILE 1 #define STAT_TYPE_DIRECTORY 2 #define STAT_TYPE_PIPE 3 #define STAT_TYPE_LINK 4 #define STAT_TYPE_DEVICE 5 /* &end_gen */ typedef struct _Parrot_Stat_Buf { INTVAL type; HUGEINTVAL size; INTVAL uid; INTVAL gid; INTVAL dev; HUGEINTVAL inode; INTVAL mode; INTVAL n_links; INTVAL block_size; INTVAL blocks; struct timespec create_time; struct timespec access_time; struct timespec modify_time; struct timespec change_time; } Parrot_Stat_Buf; PARROT_EXPORT STRING *Parrot_file_getcwd(PARROT_INTERP); PARROT_EXPORT void Parrot_file_mkdir(PARROT_INTERP, ARGIN(STRING *path), INTVAL mode); PARROT_EXPORT void Parrot_file_chdir(PARROT_INTERP, ARGIN(STRING *path)); PARROT_EXPORT void Parrot_file_rmdir(PARROT_INTERP, ARGIN(STRING *path)); PARROT_EXPORT void Parrot_file_unlink(PARROT_INTERP, ARGIN(STRING *path)); PARROT_EXPORT void Parrot_file_stat(PARROT_INTERP, ARGIN(STRING *path), ARGOUT(Parrot_Stat_Buf *buf)); PARROT_EXPORT void Parrot_file_lstat(PARROT_INTERP, ARGIN(STRING *path), ARGOUT(Parrot_Stat_Buf *buf)); PARROT_EXPORT void Parrot_file_fstat(PARROT_INTERP, PIOHANDLE handle, ARGOUT(Parrot_Stat_Buf *buf)); PARROT_EXPORT INTVAL Parrot_file_stat_intval(PARROT_INTERP, ARGIN(STRING *path), INTVAL thing); PARROT_EXPORT INTVAL Parrot_file_lstat_intval(PARROT_INTERP, ARGIN(STRING * path), INTVAL thing); PARROT_EXPORT INTVAL Parrot_file_fstat_intval(PARROT_INTERP, PIOHANDLE os_handle, INTVAL thing); PARROT_EXPORT void Parrot_file_symlink(PARROT_INTERP, ARGIN(STRING *from), ARGIN(STRING *to)); PARROT_EXPORT STRING *Parrot_file_readlink(PARROT_INTERP, ARGIN(STRING *path)); PARROT_EXPORT void Parrot_file_link(PARROT_INTERP, ARGIN(STRING *from), ARGIN(STRING *to)); PARROT_EXPORT INTVAL Parrot_file_umask(PARROT_INTERP, INTVAL mask); PARROT_EXPORT void Parrot_file_chroot(PARROT_INTERP, ARGIN(STRING *path)); PARROT_EXPORT PMC *Parrot_file_readdir(PARROT_INTERP, ARGIN(STRING *path)); PARROT_EXPORT void Parrot_file_rename(PARROT_INTERP, ARGIN(STRING *from), ARGIN(STRING *to)); PARROT_EXPORT void Parrot_file_chmod(PARROT_INTERP, ARGIN(STRING *path), INTVAL mode); PARROT_EXPORT INTVAL Parrot_file_can_read(PARROT_INTERP, ARGIN(STRING *path)); PARROT_EXPORT INTVAL Parrot_file_can_write(PARROT_INTERP, ARGIN(STRING *path)); PARROT_EXPORT INTVAL Parrot_file_can_execute(PARROT_INTERP, ARGIN(STRING *path)); /* ** Math: */ extern int Parrot_signbit(double x); #if NUMVAL_SIZE == 12 int Parrot_signbit_l(long double x); #endif #ifndef signbit # if NUMVAL_SIZE == 8 # define signbit(x) Parrot_signbit(x) # else # define signbit(x) Parrot_signbit_l(x) # endif #endif #define Parrot_is_nzero(x) ((x) == 0.0 && signbit(x)) /* ** Memory: */ void *Parrot_memalign(size_t align, size_t size); void *Parrot_memalign_if_possible(size_t align, size_t size); void Parrot_free_memalign(void *); #if !defined(PARROT_HAS_SOME_MEMALIGN) # define Parrot_memalign_if_possible(a, s) malloc(s) #else # define Parrot_memalign_if_possible(a, s) Parrot_memalign((a), (s)) #endif /* ** Processes */ typedef enum Parrot_proc_exec_enum { /* * Activates RTLD_GLOBAL on *NIX systems, making symbols from the newly * loaded library visible to other libraries; this is usually needed if * it will load libraries itself. */ PARROT_EXEC_STDIN = 0x01, PARROT_EXEC_STDOUT = 0x02, PARROT_EXEC_STDERR = 0x04 } Parrot_proc_exec_flags; PARROT_EXPORT INTVAL Parrot_Run_OS_Command(Interp*, STRING *); PARROT_EXPORT INTVAL Parrot_Run_OS_Command_Argv(Interp*, PMC *); PARROT_EXPORT UINTVAL Parrot_getpid(void); INTVAL Parrot_proc_exec(Interp *, STRING *command, INTVAL flags, PIOHANDLE *handles); INTVAL Parrot_proc_waitpid(Interp *, INTVAL pid); /* ** Time */ PARROT_EXPORT void Parrot_sleep(unsigned int seconds); PARROT_EXPORT void Parrot_usleep(unsigned int microseconds); void Parrot_floatval_sleep(FLOATVAL time); PARROT_EXPORT INTVAL Parrot_intval_time(void); PARROT_EXPORT FLOATVAL Parrot_floatval_time(void); PARROT_EXPORT struct tm * Parrot_gmtime_r(const time_t *, struct tm *); PARROT_EXPORT struct tm * Parrot_localtime_r(const time_t *, struct tm *); PARROT_EXPORT char* Parrot_asctime_r(const struct tm*, char *); /* * Env */ PARROT_EXPORT void Parrot_setenv(PARROT_INTERP, STRING *name, STRING *value); PARROT_EXPORT void Parrot_unsetenv(PARROT_INTERP, STRING *name); PARROT_EXPORT STRING * Parrot_getenv(PARROT_INTERP, STRING *name); /* ** Dynamic Loading: */ /* * The second argument to Parrot_dlopen below provides portable access to * non-default behavior of dynamic linkers. * * All flags will be ignored on platforms for which they are inapplicable. */ /* &gen_from_enum(dlopenflags.pasm) */ typedef enum Parrot_dlopen_enum { /* * Activates RTLD_GLOBAL on *NIX systems, making symbols from the newly * loaded library visible to other libraries; this is usually needed if * it will load libraries itself. */ Parrot_dlopen_global_FLAG = 0x01 } Parrot_dlopen_flags; /* &end_gen */ void *Parrot_dlopen(const char *filename, Parrot_dlopen_flags flags); const char *Parrot_dlerror(void); void *Parrot_dlsym(void *handle, const char *symbol); int Parrot_dlclose(void *handle); /* * encoding */ void Parrot_init_platform_encoding(PARROT_INTERP); size_t Parrot_str_platform_strlen(PARROT_INTERP, const char *s); /* * system timer */ #ifdef PARROT_HAS_SOME_SYS_TIMER void * new_sys_timer_ms(void); void start_sys_timer_ms(void *handle, int ms); void stop_sys_timer_ms(void *handle); int get_sys_timer_ms(void *handle); #else # define new_sys_timer_ms() NULL # define start_sys_timer_ms(h, m) # define stop_sys_timer_ms(h) # define get_sys_timer_ms(h) 0 #endif /* * high-resolution timer support */ PARROT_EXPORT UHUGEINTVAL Parrot_hires_get_time(void); PARROT_EXPORT PARROT_CONST_FUNCTION UINTVAL Parrot_hires_get_tick_duration(void); /* * user information */ PARROT_EXPORT UINTVAL Parrot_get_user_id(void); /* * system memory */ PARROT_EXPORT size_t Parrot_sysmem_amount(Interp*); /* * Entropy */ PARROT_EXPORT INTVAL Parrot_get_entropy(PARROT_INTERP); /* * CPU */ PARROT_EXPORT STRING *Parrot_get_cpu_type(PARROT_INTERP); PARROT_EXPORT INTVAL Parrot_get_num_cpus(PARROT_INTERP); #endif /* PARROT_PLATFORM_INTERFACE_H_GUARD */ /* * Local variables: * c-file-style: "parrot" * End: * vim: expandtab shiftwidth=4 cinoptions='\:2=2' : */ 08-blocks.t000644000765000765 103212101554066 16437 0ustar00bruce000000000000parrot-6.6.0/ext/nqp-rx/t/nqp#!./parrot-nqp # check blocks and statement enders say('1..7'); { say("ok 1 # blocks are okay"); } { print("ok "); say("2 # last statement in a block does not need a semi-colon") } { say("ok 3 # statements can precede blocks"); { say("ok 4 # blocks can nest"); } say("ok 5 # statements can follow blocks"); } { print("ok ") }; { say("6 # multiple blocks on one line need a semi-colon") } { print("ok ") }; { say("7 # blocks following an end brace must be separated by a semicolon") } README.BGR000644000765000765 1655511715102032 16454 0ustar00bruce000000000000parrot-6.6.0/docs/translationsТова е Parrot, версия 3.4.0 ----------------------------- Parrot is Copyright (C) 2001-2010, Parrot Foundation. ЛИЦЕНЗНА ИНФОРМАЦИЯ ------------------- Този код се разпространява под условията на Artistic License 2.0. За повече детайли, вижте пълния текст на лиценза във файла LICENSE. ПРЕГЛЕД -------- Parrot е виртуално машина, разработена за ефикасно компилиране и изпълнение на bytecode за динамични езици. ПРЕДПОСТАВКИ ------------- Трябва ви компилатор за С, линкер и, разбира се, make програма. Ако ще линквате с ICU библиотеката, трябва да я свалите и инсталирате преди да конфигурирате Parrot. Свалете я от http://site.icu-project.org/download Също така ви трябва Perl 5.8.4 или по-нов, и Storable 2.12 или по-нов за пускане на различни скриптове за конфигуриране и билдване. For most of the platforms that we are supporting initially, Parrot should build out of the box. docs/parrot.pod lists the core platforms. PLATFORMS provides reports on the platforms on which Parrot has been built and tested. КАК ДА ВЗЕМЕТЕ PARROT ОТ GITHUB ----------------------------- I. Инсталирайте Git. Linux: Методът зависи от дистрибуцията ви. За да инсталирате трябва да изпълните (като root или sudo ): На Ubuntu/Debian (apt-базирани): apt-get install git-core На Red Hat, Fedora (rpm-базирани): yum install git На Gentoo (portage): emerge -av dev-vcs/git Windows: Има 2 Git порта за Windows: msysgit http://code.google.com/p/msysgit/downloads/list TortoiseGit http://code.google.com/p/tortoisegit/downloads/list Macintosh OS X: Търсене в интернет ще намери разнообразни git инсталатори за Mac OS X, включително: http://help.github.com/mac-git-installation/ II. Получаване на Parrot от github.com За да вземете копие Parrot Git хранилището: git clone git://github.com/parrot/parrot.git Това по подразбиране ще провери главния клон по подразбиране. За да създадете локален клон който следи клона "some_branch": git checkout -b --track some_branch origin/some_branch Горните URL са само за четене. Ако сте разработчик на Parrot използвайте URL за четене и запис: git clone git@github.com:parrot/parrot.git Можете да видите списъкът от клони на http://github.com/parrot/parrot ИНСТРУКЦИИ ------------ За сега, разархивирайте Parrot tarball-а, (ако четете това, вече сигурно сте го направили) и напишете perl Configure.pl за да пуснете Конфигурационния скрипт. Скриптът Configure.pl извлича конфигурацията от работещата perl5 програма. Може да се наложи изрично да кажете на Configure.pl кой компилатор и линкер да използва. Например, за компилиране на C файлове с 'cc', C++ файлове с 'CC', и линкване на всичко с 'CC', трябва да напишете perl Configure.pl --cc=cc --link=CC --ld=CC Вижте "perl Configure.pl --help" за повече опции и docs/configuration.pod за повече детайли. За системи като HPUX които нямат inet_pton моля изпълнете perl Configure.pl --define=inet_aton Пускането на Configure.pl ще генерира config.h хедър, Parrot::Config модул, платформени файлове и много Make файлове. Файлът "myconfig" съдържа преглед на настройките. След това изпълнете make. (Configure.pl ще ви каже коя версия на make се препоръчва за системата ви.) Сега трябва да се билдне интерпретаторът. Ако билдвате ICU библиотеката (това е по подразбиране на повечето системи), трябва да използвате GNU make (или нещо съвместимо с него). Можете да тествате Parrot като изпълните "make test". Можете да изпълнявате тестовете паралелно с "make TEST_JOBS=3 test". Можете да изпълните целия тестов пакет с make fulltest Бележка: PLATFORMS съдържа бележки дали тестови провали се очакват на системата ви. Можете да инсталирате Parrot с: make install По подразбиране се инсталира в /usr/local, с Parrot executable в /usr/local/bin. Ако искате да инсталирате Parrot на друго място използвайте: perl Configure.pl --prefix=/home/joe/bird make install Но динамичните библиотеки няма да бъдат намерени за нестандартни местоположения освен ако не настроите LD_LIBRARY_PATH или подобно. Вижте docs/parrot.pod и docs/intro.pod за да разберете на къде да вървите от тук. Ако имате проблеми, вижте секцията "How To Submit A Bug Report" в docs/submissions.pod. Тези документи са в POD формат. Можете да ги видите с командата: perldoc -F docs/intro.pod ПРОМЕНИ ------- За документация относно юзър-видимите промени между тази версия и предишните версии, вижте NEWS. ПОЩЕНСКИ СПИСЪЦИ ------------- Списъкът за юзърски писма на Parrot е parrot-users@lists.parrot.org. Абонирайте се като попълните бланката на http://lists.parrot.org/mailman/listinfo/parrot-users . Списъкът е архивиран на http://lists.parrot.org/pipermail/parrot-users/ . За дискусии по разработването вижте информацията в docs/gettingstarted.pod. ОБРАТНА ВРЪЗКА, ПАТЧОВЕ И Т.Н. ----------------------- Вижте docs/submissions.pod за повече информациия за докладване на бъгове и събмитване на патчове. УЕБ САЙТОВЕ --------- Тези сайтове съдържат всичките нужна информация за Parrot: http://www.parrot.org/ http://docs.parrot.org/ https://github.com/parrot/parrot/ Забавлявайте се, Екипът на Parrot. test2_c.in000644000765000765 63411567202622 17041 0ustar00bruce000000000000parrot-6.6.0/config/auto/signal/* Copyright (C) 2003-2009, Parrot Foundation. test for sigaction function */ #include #include int main(int argc, char **argv) { struct sigaction old_sa, new_sa; sigemptyset(&new_sa.sa_mask); sigaction(SIGFPE, NULL, &old_sa); puts("ok"); return 0; } /* * Local variables: * c-file-style: "parrot" * End: * vim: expandtab shiftwidth=4 cinoptions='\:2=2' : */ ddefectivefoobar000644000765000765 156712133326621 20606 0ustar00bruce000000000000parrot-6.6.0/t/configure/testlib =variables =general =steps init::manifest nomanicheck init::defaults init::install init::hints verbose-step fatal-step foobar inter::progs inter::make inter::lex inter::yacc auto::gcc auto::glibc auto::backtrace auto::fink auto::macports auto::msvc auto::attributes auto::warnings init::optimize inter::shlibs inter::libparrot inter::charset inter::encoding inter::types auto::ops auto::pmc auto::alignptrs auto::headers auto::sizes auto::byteorder auto::va_ptr auto::format auto::isreg auto::arch auto::jit auto::cpu auto::funcptr auto::inline auto::gc auto::memalign auto::signal auto::socklen_t auto::env auto::gmp auto::readline auto::gdbm auto::pcre auto::opengl auto::crypto auto::gettext auto::snprintf # auto::perldoc auto::ctags auto::icu auto::platform gen::config_h gen::core_pmcs gen::crypto gen::opengl gen::call_list gen::languages gen::makefiles gen::config_pm =cut 041-return_undef.t000644000765000765 502511533177644 17116 0ustar00bruce000000000000parrot-6.6.0/t/configure#! perl # Copyright (C) 2007, Parrot Foundation. # 041-return_undef.t use strict; use warnings; use Test::More tests => 13; use Carp; use lib qw( lib t/configure/testlib ); use Parrot::Configure; use Parrot::Configure::Options qw( process_options ); use IO::CaptureOutput qw | capture |; $| = 1; is($|, 1, "output autoflush is set"); my ($args, $step_list_ref) = process_options( { argv => [ ], mode => q{configure}, } ); ok(defined $args, "process_options returned successfully"); my %args = %$args; my $conf = Parrot::Configure->new; ok(defined $conf, "Parrot::Configure->new() returned okay"); my $step = q{init::zeta}; my $description = 'Determining if your computer does zeta'; $conf->add_steps( $step ); my @confsteps = @{$conf->steps}; isnt(scalar @confsteps, 0, "Parrot::Configure object 'steps' key holds non-empty array reference"); is(scalar @confsteps, 1, "Parrot::Configure object 'steps' key holds ref to 1-element array"); my $nontaskcount = 0; foreach my $k (@confsteps) { $nontaskcount++ unless $k->isa("Parrot::Configure::Task"); } is($nontaskcount, 0, "Each step is a Parrot::Configure::Task object"); is($confsteps[0]->step, $step, "'step' element of Parrot::Configure::Task struct identified"); ok(! ref($confsteps[0]->object), "'object' element of Parrot::Configure::Task struct is not yet a ref"); $conf->options->set(%args); is($conf->options->{c}->{debugging}, 1, "command-line option '--debugging' has been stored in object"); { my $rv; my ($stdout, $stderr); capture ( sub {$rv = $conf->runsteps}, \$stdout, \$stderr ); ok($rv, "runsteps successfully ran $step"); like($stdout, qr/$description/s, "Got correct description for $step"); like($stderr, qr/step $step failed:/, "Got error message expected upon running $step"); } pass("Completed all tests in $0"); ################### DOCUMENTATION ################### =head1 NAME 041-return_undef.t - see what happens when configuration step returns an undefined value =head1 SYNOPSIS % prove t/configure/041-return_undef.t =head1 DESCRIPTION The files in this directory test functionality used by F. The tests in this file examine what happens when your configuration step module returns something other than the object but has some other defined result method. =head1 AUTHOR James E Keenan =head1 SEE ALSO Parrot::Configure, F. =cut # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: 03-regenerate_skip.t000644000765000765 717011533177644 17333 0ustar00bruce000000000000parrot-6.6.0/t/manifest#! perl # Copyright (C) 2007-2010, Parrot Foundation. # 03-regenerate_skip.t use strict; use warnings; use Test::More tests => 10; use Carp; use Cwd; use File::Copy; use File::Temp qw( tempdir ); use Tie::File; use lib (qw| lib |); SKIP: { skip q{Relevant only when working in checkout from repository}, 9 unless (-e 'DEVELOPING'); use_ok('Parrot::Manifest'); my $script = $0; my $mani = Parrot::Manifest->new( { script => $script, } ); isa_ok( $mani, 'Parrot::Manifest' ); my $cwd = cwd(); my $sk = q{MANIFEST.SKIP}; my $print_str = $mani->prepare_manifest_skip(); ok( $print_str, "prepare_manifest_skip() returned" ); # 1: Copy the real MANIFEST.SKIP unaltered to the tempdir. # Assuming the real MANIFEST.SKIP was correct going in to this test, the # absence of any change in it will mean that there will be no need to # regenerate it. { my $tdir = tempdir( CLEANUP => 1 ); chdir $tdir or croak "Unable to change to temporary directory for testing"; copy( qq{$cwd/$sk}, qq{$tdir/$sk} ) or croak "Unable to copy $sk to tempdir"; ok( -f $sk, "$sk found in tempdir" ); my $need_for_skip = $mani->determine_need_for_manifest_skip($print_str); ok( !$need_for_skip, "No need to regenerate $sk" ); unlink qq{$tdir/$sk} or croak "Unable to delete file from tempdir"; chdir $cwd or croak "Unable to change back from temporary directory after testing"; } # 2: Copy the real MANIFEST.SKIP to the tempdir but mangle it there. # The alteration in the copied MANIFEST.SKIP will be sufficient to require # regeneration of MANIFEST.SKIP. { my $tdir = tempdir( CLEANUP => 1 ); chdir $tdir or croak "Unable to change to temporary directory for testing"; copy( qq{$cwd/$sk}, qq{$tdir/$sk} ) or croak "Unable to copy $sk to tempdir"; ok( -f $sk, "$sk found in tempdir" ); my @lines; tie @lines, 'Tie::File', qq{$tdir/$sk} or croak "Unable to tie to $sk in tempdir"; for ( 1 .. 10 ) { if ( defined( $lines[-1] ) ) { pop @lines; } } untie @lines or croak "Unable to untie from $sk"; my $need_for_skip = $mani->determine_need_for_manifest_skip($print_str); ok( $need_for_skip, "Need to regenerate $sk" ); ok( $mani->print_manifest_skip($print_str), "print_manifest_skip() returned true" ); ok( -f $sk, "$sk has been created in tempdir" ); unlink qq{$tdir/$sk} or croak "Unable to delete file from tempdir"; chdir $cwd or croak "Unable to change back from temporary directory after testing"; } } pass("Completed all tests in $0"); ################### DOCUMENTATION ################### =head1 NAME 03-regenerate_skip.t - test C MANIFEST.SKIP-related methods =head1 SYNOPSIS % prove t/manifest/03-regenerate_skip.t =head1 DESCRIPTION The files in this directory test the publicly callable methods of F and packages which inherit from that package. F<03-regenerate_skip.t> tests whether Parrot::Manifest correctly determines whether MANIFEST.SKIP needs to be regenerated or not. =head1 AUTHOR James E Keenan (jkeenan@cpan.org) =head1 SEE ALSO Parrot::Manifest, Parrot::Manifest::Files, Parrot::Manifest::Skip, F. =cut # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: pod.t000644000765000765 264611533177643 16443 0ustar00bruce000000000000parrot-6.6.0/t/compilers/imcc/syn#!perl # Copyright (C) 2001-2005, Parrot Foundation. use strict; use warnings; use lib qw( . lib ../lib ../../lib ); use Test::More; use Parrot::Config; use Parrot::Test tests => 4; =head1 NAME t/compilers/imcc/syn/pod.t =head1 SYNOPSIS % prove t/compilers/imcc/syn/pod.t =head1 DESCRIPTION Tests PIR's handling of Plain Old Documentation (POD) format. =cut pir_output_is( <<'CODE', <<'OUT', "simple pod" ); .sub test :main print "pass\n" end .end =head1 Some POD This should be ignored, incl. digit 1 CODE pass OUT pir_output_is( <<'CODE', <<'OUT', "pod with decimal digits" ); .sub test :main print "pass\n" end .end =head1 Some POD This should be ignored, incl. number 1.0 =cut CODE pass OUT pir_output_is( <<'CODE', <<'OUT', "pod inside sub" ); .sub test :main print "pass\n" _x() end .end .sub _x =head1 Some POD This should be ignored, incl. digit 1.0 =cut print "ok\n" .end CODE pass ok OUT open my $FOO, ">", "include.tempfile"; print $FOO <<'ENDF'; =head1 Foobar we don't cut out!!! ENDF close $FOO; SKIP: { skip( "Closing out of pod from included files", 1 ); pir_output_is( <<'CODE', <<'OUT', "simple pod" ); .include "include.tempfile" .sub test :main print "pass\n" end .end CODE pass OUT } unlink( 'macro.tempfile', 'include.tempfile' ); # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: orderedhashiterator.t000644000765000765 515711567202625 16755 0ustar00bruce000000000000parrot-6.6.0/t/pmc#!./parrot # Copyright (C) 2001-2010, Parrot Foundation. =head1 NAME t/pmc/orderedhashiterator.t - Ordered Hash Iterator =head1 SYNOPSIS % prove t/pmc/orderedhashiterator.t =head1 DESCRIPTION Do almost nothing test. Main purpose of OrderedHashIterator covered by t/pmc/orderedhash.t. =cut .include 'iterator.pasm' .include 'except_types.pasm' .sub 'main' :main .include 'test_more.pir' plan(7) 'test_init'() 'test_bad_type'() 'test_shift'() 'test_pop'() 'test_clone'() .end .sub 'test_init' .local pmc oh, it .local int i, i2 # We can't create OrderedHashIterator directly i = 1 push_eh fail oh = new ['OrderedHashIterator'] i = 0 fail: pop_eh ok(i, "Can't create OrderedHashIterator directly") oh = new ['OrderedHash'] it = iter oh sweep 1 # Make sure the mark vtable is covered i = isa it, 'Iterator' i2 = isa it, 'OrderedHashIterator' add i, i2 is(i, 2, 'OrderedHashIterator has proper type') # elements and get_integer should both return 0 i = elements it i2 = it add i, i2 is(i, 0, 'iterator for empty OrderedHash has size 0') .end .sub 'test_bad_type' .local pmc oh, it, eh .local int i oh = new ['OrderedHash'] it = iter oh i = 1 eh = new ['ExceptionHandler'] eh.'handle_types'(.EXCEPTION_INVALID_OPERATION) set_label eh, catch push_eh eh it = 9999 # Let's hope it will never be a valid iteration type i = 0 catch: finalize eh pop_eh ok(i, 'invalid iteration type throws') .end .sub 'test_shift' .local pmc oh, it, eh, p .local int i oh = new ['OrderedHash'] it = iter oh i = 1 eh = new ['ExceptionHandler'] eh.'handle_types'(.EXCEPTION_OUT_OF_BOUNDS) set_label eh, catch push_eh eh p = shift it i = 0 catch: finalize eh pop_eh ok(i, 'shift_pmc in empty OH throws') .end .sub 'test_pop' .local pmc oh, it, eh, p .local int i oh = new ['OrderedHash'] it = iter oh it = .ITERATE_FROM_END i = 1 eh = new ['ExceptionHandler'] eh.'handle_types'(.EXCEPTION_OUT_OF_BOUNDS) set_label eh, catch push_eh eh p = pop it i = 0 catch: finalize eh pop_eh ok(i, 'pop_pmc in empty OH throws') .end .sub 'test_clone' .local pmc oh, it, cl .local int result oh = new ['OrderedHash'] it = iter oh # This chekcs the de facto behavior for code coverage purposes. cl = clone it result = isnull cl ok(result, 'clone of OHI gives null') .end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: env.t000644000765000765 1000611533177645 13516 0ustar00bruce000000000000parrot-6.6.0/t/pmc#!./parrot # Copyright (C) 2001-2010, Parrot Foundation. =head1 NAME t/pmc/env.t - System Environment =head1 SYNOPSIS % prove t/pmc/env.t =head1 DESCRIPTION Tests the C PMC. =cut .sub main :main .include 'test_more.pir' plan(16) all_envs_are_identical() setenv_getenv() all_envs_are_the_same() gone_delete() iterate() exists_delete() is_interface_done() get_integer() oob_query() .end .sub all_envs_are_identical $P0 = new ['Env'] $P1 = new ['Env'] eq_addr $P0, $P1, ok ok(0, "all Envs aren't identical") goto end ok: ok(1, "all Envs are identical") end: .end .sub setenv_getenv $P0 = new ['Env'] set $P0['PARROT_TMP'], 'hello polly' set $S0, $P0['PARROT_TMP'] is($S0, 'hello polly', 'getenv and setenv work with string keys') delete $P0['PARROT_TMP'] $P1 = new ['Key'] set $P1, "PARROT_TMP" $P2 = new ['String'] set $P2, "Foobar" $P3 = new ['String'] set $P0[$P1], $P2 set $P3, $P0[$P1] is($P3, "Foobar", "getenv and setenv work with PMC keys") delete $P0['PARROT_TMP'] set $S0, $P0[""] is($S0, '', 'getenv works with a null key') .end .sub all_envs_are_the_same $P0 = new ['Env'] set $P0['PARROT_TMP'], 'hello polly' set $S0, $P0['PARROT_TMP'] $P1 = new ['Env'] set $S1, $P1['PARROT_TMP'] is($S0, $S1, 'all envs are the same') delete $P0['PARROT_TMP'] .end .sub gone_delete $P0 = new ['Env'] set $P0['PARROT_TMP'], 'hello polly' exists $I0, $P0['PARROT_TMP'] if $I0, ok1 ok(0, "expected element doesn't exist") ok1: ok(1, 'expected element exists') delete $P0['PARROT_TMP'] set $S0, $P0['PARROT_TMP'] unless $S0, ok2 ok(0, 'deleted element exists') ok2: ok(1, 'deleted element is deleted') .end .sub iterate $P0 = new ['Env'] set $P0["PARROT_1"], "hello" set $P0["PARROT_2"], "polly" iter $P1, $P0 set $I0, 0 loop: unless $P1, loopend shift $S2, $P1 eq $S2, "PARROT_1", gotit eq $S2, "PARROT_2", gotit branch notit gotit: inc $I0 notit: branch loop loopend: is($I0, 2, 'assigned env vars showed up in the iterator') .end # This will not work on our unsetenv implementation #skip( "no native unsetenv", 1 ) unless $PConfig{"unsetenv"}; .sub exists_delete .include "iglobals.pasm" .local pmc config_hash, interp interp = getinterp config_hash = interp[.IGLOBALS_CONFIG_HASH] $I0 = config_hash["unsetenv"] unless $I0 goto no_unsetenv $P0 = new ['Env'] set $P0['PARROT_TMP'], 'hello polly' exists $I0, $P0['PARROT_TMP'] ok( $I0, "set env var stays set") delete $P0["PARROT_TMP"] exists $I0, $P0["PARROT_TMP"] is($I0, 0, "deleted env var stays deleted") goto end no_unsetenv: skip(1, "no native unsetenv") skip(1, "no native unsetenv") end: .end .sub is_interface_done .local pmc pmc1 pmc1 = new ['Env'] .local int bool1 does bool1, pmc1, 'hash' ok(bool1, 'does Hash') does bool1, pmc1, 'scalar' is(bool1, 0, "doesn't do Scalar") does bool1, pmc1, 'no_interface' is(bool1, 0, "doesn't do no_interface") .end .sub get_integer .local pmc env .local int int_before, int_after, int_diff .local num num_before, num_after, num_diff # add three more keys in env env = new ['Env'] num_before = env int_before = env env["PARROT_TMP_ADD_1"] = "tmp_add_1" env["PARROT_TMP_ADD_2"] = "tmp_add_2" env["PARROT_TMP_ADD_3"] = "tmp_add_3" num_after = env int_after = env num_diff = num_after - num_before int_diff = int_after - int_before is(int_diff, 3, "get_integer seems sane") is(num_diff, 3, "get_number seems sane") #clean up the environment delete env['PARROT_TMP_ADD_1'] delete env['PARROT_TMP_ADD_2'] delete env['PARROT_TMP_ADD_3'] .end .sub oob_query $P0 = new ['Env'] set $S0, $P0[999] is($S0, '', 'no segfault') .end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: get.pir000644000765000765 141611567202623 15214 0ustar00bruce000000000000parrot-6.6.0/examples/io# Copyright (C) 2010, Parrot Foundation. =head1 NAME examples/io/get.pir - LWP client =head1 SYNOPSIS % ./parrot examples/io/get.pir http://www.parrot.org/ > parrot_home.html =head1 DESCRIPTION LWP client, grabs an URL. Supported protocols : file, http The HTTP redirection is supported (for example http://fperrad.googlepages.com/home). =cut .sub 'main' :main .param pmc args load_bytecode 'LWP/UserAgent.pir' $S0 = shift args .local string url url = shift args .local pmc ua, response ua = new ['LWP';'UserAgent'] ua.'env_proxy'() ua.'show_progress'(1) response = ua.'get'(url) $S0 = response.'content'() say $S0 .end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: ncurses.pir000644000765000765 5621611533177637 20371 0ustar00bruce000000000000parrot-6.6.0/runtime/parrot/library# Copyright (C) 2004-2009, Parrot Foundation. .sub __ncurses_init :load loadlib $P1, 'libform' if $P1 goto has_lib loadlib $P1, 'cygform-8' has_lib: dlfunc $P2, $P1, 'new_field', 'piiiiii' set_global 'ncurses::new_field', $P2 dlfunc $P2, $P1, 'dup_field', 'ppii' set_global 'ncurses::dup_field', $P2 dlfunc $P2, $P1, 'link_field', 'ppii' set_global 'ncurses::link_field', $P2 dlfunc $P2, $P1, 'free_field', 'ip' set_global 'ncurses::free_field', $P2 dlfunc $P2, $P1, 'field_info', 'ip333333' set_global 'ncurses::field_info', $P2 dlfunc $P2, $P1, 'dynamic_field_info', 'ip333' set_global 'ncurses::dynamic_field_info', $P2 dlfunc $P2, $P1, 'set_max_field', 'ipi' set_global 'ncurses::set_max_field', $P2 dlfunc $P2, $P1, 'move_field', 'ipii' set_global 'ncurses::move_field', $P2 dlfunc $P2, $P1, 'set_new_page', 'ipl' set_global 'ncurses::set_new_page', $P2 dlfunc $P2, $P1, 'set_field_just', 'ipi' set_global 'ncurses::set_field_just', $P2 dlfunc $P2, $P1, 'field_just', 'ip' set_global 'ncurses::field_just', $P2 dlfunc $P2, $P1, 'set_field_fore', 'ipl' set_global 'ncurses::set_field_fore', $P2 dlfunc $P2, $P1, 'set_field_back', 'ipl' set_global 'ncurses::set_field_back', $P2 dlfunc $P2, $P1, 'set_field_pad', 'ipi' set_global 'ncurses::set_field_pad', $P2 dlfunc $P2, $P1, 'field_pad', 'ip' set_global 'ncurses::field_pad', $P2 dlfunc $P2, $P1, 'set_field_buffer', 'ipit' set_global 'ncurses::set_field_buffer', $P2 dlfunc $P2, $P1, 'set_field_status', 'ipl' set_global 'ncurses::set_field_status', $P2 dlfunc $P2, $P1, 'set_field_userptr', 'ipp' set_global 'ncurses::set_field_userptr', $P2 dlfunc $P2, $P1, 'set_field_opts', 'ipi' set_global 'ncurses::set_field_opts', $P2 dlfunc $P2, $P1, 'field_opts_on', 'ipi' set_global 'ncurses::field_opts_on', $P2 dlfunc $P2, $P1, 'field_opts_off', 'ipi' set_global 'ncurses::field_opts_off', $P2 dlfunc $P2, $P1, 'field_fore', 'lp' set_global 'ncurses::field_fore', $P2 dlfunc $P2, $P1, 'field_back', 'ip' set_global 'ncurses::field_back', $P2 dlfunc $P2, $P1, 'new_page', 'lp' set_global 'ncurses::new_page', $P2 dlfunc $P2, $P1, 'field_status', 'lp' set_global 'ncurses::field_status', $P2 dlfunc $P2, $P1, 'field_arg', 'pp' set_global 'ncurses::field_arg', $P2 dlfunc $P2, $P1, 'field_userptr', 'pp' set_global 'ncurses::field_userptr', $P2 dlfunc $P2, $P1, 'field_type', 'pp' set_global 'ncurses::field_type', $P2 dlfunc $P2, $P1, 'field_buffer', 'tpi' set_global 'ncurses::field_buffer', $P2 dlfunc $P2, $P1, 'field_opts', 'lp' set_global 'ncurses::field_opts', $P2 dlfunc $P2, $P1, 'new_form', 'pb' set_global 'ncurses::new_form', $P2 dlfunc $P2, $P1, 'current_field', 'pp' set_global 'ncurses::current_field', $P2 dlfunc $P2, $P1, 'form_win', 'pp' set_global 'ncurses::form_win', $P2 dlfunc $P2, $P1, 'form_sub', 'pp' set_global 'ncurses::form_sub', $P2 dlfunc $P2, $P1, 'free_form', 'ip' set_global 'ncurses::free_form', $P2 dlfunc $P2, $P1, 'set_form_fields', 'ipb' set_global 'ncurses::set_form_fields', $P2 dlfunc $P2, $P1, 'field_count', 'ip' set_global 'ncurses::field_count', $P2 dlfunc $P2, $P1, 'set_form_win', 'ipp' set_global 'ncurses::set_form_win', $P2 dlfunc $P2, $P1, 'set_form_sub', 'ipp' set_global 'ncurses::set_form_sub', $P2 dlfunc $P2, $P1, 'set_current_field', 'ipp' set_global 'ncurses::set_current_field', $P2 dlfunc $P2, $P1, 'field_index', 'ip' set_global 'ncurses::field_index', $P2 dlfunc $P2, $P1, 'set_form_page', 'ipi' set_global 'ncurses::set_form_page', $P2 dlfunc $P2, $P1, 'form_page', 'ip' set_global 'ncurses::form_page', $P2 dlfunc $P2, $P1, 'scale_form', 'ip33' set_global 'ncurses::scale_form', $P2 dlfunc $P2, $P1, 'post_form', 'ip' set_global 'ncurses::post_form', $P2 dlfunc $P2, $P1, 'unpost_form', 'ip' set_global 'ncurses::unpost_form', $P2 dlfunc $P2, $P1, 'pos_form_cursor', 'ip' set_global 'ncurses::pos_form_cursor', $P2 dlfunc $P2, $P1, 'form_driver', 'ipi' set_global 'ncurses::form_driver', $P2 dlfunc $P2, $P1, 'set_form_userptr', 'ipp' set_global 'ncurses::set_form_userptr', $P2 dlfunc $P2, $P1, 'set_form_opts', 'ipi' set_global 'ncurses::set_form_opts', $P2 dlfunc $P2, $P1, 'form_opts_on', 'ipi' set_global 'ncurses::form_opts_on', $P2 dlfunc $P2, $P1, 'form_opts_off', 'ipi' set_global 'ncurses::form_opts_off', $P2 dlfunc $P2, $P1, 'form_request_by_name', 'it' set_global 'ncurses::form_request_by_name', $P2 dlfunc $P2, $P1, 'form_request_name', 'ti' set_global 'ncurses::form_request_name', $P2 dlfunc $P2, $P1, 'form_userptr', 'pp' set_global 'ncurses::form_userptr', $P2 dlfunc $P2, $P1, 'form_opts', 'ip' set_global 'ncurses::form_opts', $P2 dlfunc $P2, $P1, 'data_ahead', 'lp' set_global 'ncurses::data_ahead', $P2 dlfunc $P2, $P1, 'data_behind', 'lp' set_global 'ncurses::data_behind', $P2 loadlib $P1, 'libncurses' if $P1 goto has_lib1 loadlib $P1, 'cygncurses-8' has_lib1: dlfunc $P2, $P1, 'keybound', 'tii' set_global 'ncurses::keybound', $P2 dlfunc $P2, $P1, 'curses_version', 't' set_global 'ncurses::curses_version', $P2 dlfunc $P2, $P1, 'assume_default_colors', 'iii' set_global 'ncurses::assume_default_colors', $P2 dlfunc $P2, $P1, 'define_key', 'iti' set_global 'ncurses::define_key', $P2 dlfunc $P2, $P1, 'keyok', 'iii' set_global 'ncurses::keyok', $P2 dlfunc $P2, $P1, 'resizeterm', 'iii' set_global 'ncurses::resizeterm', $P2 dlfunc $P2, $P1, 'use_default_colors', 'i' set_global 'ncurses::use_default_colors', $P2 dlfunc $P2, $P1, 'use_extended_names', 'ii' set_global 'ncurses::use_extended_names', $P2 dlfunc $P2, $P1, 'wresize', 'ipii' set_global 'ncurses::wresize', $P2 dlfunc $P2, $P1, 'addch', 'il' set_global 'ncurses::addch', $P2 dlfunc $P2, $P1, 'addchnstr', 'i4i' set_global 'ncurses::addchnstr', $P2 dlfunc $P2, $P1, 'addchstr', 'i4' set_global 'ncurses::addchstr', $P2 dlfunc $P2, $P1, 'addnstr', 'iti' set_global 'ncurses::addnstr', $P2 dlfunc $P2, $P1, 'addstr', 'it' set_global 'ncurses::addstr', $P2 dlfunc $P2, $P1, 'attroff', 'il' set_global 'ncurses::attroff', $P2 dlfunc $P2, $P1, 'attron', 'il' set_global 'ncurses::attron', $P2 dlfunc $P2, $P1, 'attrset', 'il' set_global 'ncurses::attrset', $P2 dlfunc $P2, $P1, 'attr_get', 'i42p' set_global 'ncurses::attr_get', $P2 dlfunc $P2, $P1, 'attr_off', 'ilp' set_global 'ncurses::attr_off', $P2 dlfunc $P2, $P1, 'attr_on', 'ilp' set_global 'ncurses::attr_on', $P2 dlfunc $P2, $P1, 'attr_set', 'ilsp' set_global 'ncurses::attr_set', $P2 dlfunc $P2, $P1, 'baudrate', 'i' set_global 'ncurses::baudrate', $P2 dlfunc $P2, $P1, 'beep', 'i' set_global 'ncurses::beep', $P2 dlfunc $P2, $P1, 'bkgd', 'il' set_global 'ncurses::bkgd', $P2 dlfunc $P2, $P1, 'bkgdset', 'vl' set_global 'ncurses::bkgdset', $P2 dlfunc $P2, $P1, 'border', 'villllllll' set_global 'ncurses::border', $P2 dlfunc $P2, $P1, 'box', 'ipll' set_global 'ncurses::box', $P2 dlfunc $P2, $P1, 'can_change_color', 'l' set_global 'ncurses::can_change_color', $P2 dlfunc $P2, $P1, 'cbreak', 'i' set_global 'ncurses::cbreak', $P2 dlfunc $P2, $P1, 'chgat', 'iilsp' set_global 'ncurses::chgat', $P2 dlfunc $P2, $P1, 'clear', 'i' set_global 'ncurses::clear', $P2 dlfunc $P2, $P1, 'clearok', 'ipl' set_global 'ncurses::clearok', $P2 dlfunc $P2, $P1, 'clrtobot', 'i' set_global 'ncurses::clrtobot', $P2 dlfunc $P2, $P1, 'clrtoeol', 'i' set_global 'ncurses::clrtoeol', $P2 dlfunc $P2, $P1, 'color_content', 'is222' set_global 'ncurses::color_content', $P2 dlfunc $P2, $P1, 'color_set', 'isp' set_global 'ncurses::color_set', $P2 dlfunc $P2, $P1, 'COLOR_PAIR', 'ii' set_global 'ncurses::COLOR_PAIR', $P2 dlfunc $P2, $P1, 'copywin', 'ippiiiiiiii' set_global 'ncurses::copywin', $P2 dlfunc $P2, $P1, 'curs_set', 'ii' set_global 'ncurses::curs_set', $P2 dlfunc $P2, $P1, 'def_prog_mode', 'i' set_global 'ncurses::def_prog_mode', $P2 dlfunc $P2, $P1, 'def_shell_mode', 'i' set_global 'ncurses::def_shell_mode', $P2 dlfunc $P2, $P1, 'delay_output', 'ii' set_global 'ncurses::delay_output', $P2 dlfunc $P2, $P1, 'delch', 'i' set_global 'ncurses::delch', $P2 dlfunc $P2, $P1, 'delscreen', 'vp' set_global 'ncurses::delscreen', $P2 dlfunc $P2, $P1, 'delwin', 'ip' set_global 'ncurses::delwin', $P2 dlfunc $P2, $P1, 'deleteln', 'i' set_global 'ncurses::deleteln', $P2 dlfunc $P2, $P1, 'derwin', 'ppiiii' set_global 'ncurses::derwin', $P2 dlfunc $P2, $P1, 'doupdate', 'i' set_global 'ncurses::doupdate', $P2 dlfunc $P2, $P1, 'dupwin', 'pp' set_global 'ncurses::dupwin', $P2 dlfunc $P2, $P1, 'echo', 'i' set_global 'ncurses::echo', $P2 dlfunc $P2, $P1, 'echochar', 'il' set_global 'ncurses::echochar', $P2 dlfunc $P2, $P1, 'erase', 'i' set_global 'ncurses::erase', $P2 dlfunc $P2, $P1, 'endwin', 'i' set_global 'ncurses::endwin', $P2 dlfunc $P2, $P1, 'erasechar', 'c' set_global 'ncurses::erasechar', $P2 dlfunc $P2, $P1, 'filter', 'v' set_global 'ncurses::filter', $P2 dlfunc $P2, $P1, 'flash', 'i' set_global 'ncurses::flash', $P2 dlfunc $P2, $P1, 'flushinp', 'i' set_global 'ncurses::flushinp', $P2 dlfunc $P2, $P1, 'getbkgd', 'lp' set_global 'ncurses::getbkgd', $P2 dlfunc $P2, $P1, 'getch', 'i' set_global 'ncurses::getch', $P2 dlfunc $P2, $P1, 'getnstr', 'iti' set_global 'ncurses::getnstr', $P2 dlfunc $P2, $P1, 'getstr', 'it' set_global 'ncurses::getstr', $P2 dlfunc $P2, $P1, 'getwin', 'pp' set_global 'ncurses::getwin', $P2 dlfunc $P2, $P1, 'halfdelay', 'ii' set_global 'ncurses::halfdelay', $P2 dlfunc $P2, $P1, 'has_colors', 'i' set_global 'ncurses::has_colors', $P2 dlfunc $P2, $P1, 'has_ic', 'i' set_global 'ncurses::has_ic', $P2 dlfunc $P2, $P1, 'has_il', 'i' set_global 'ncurses::has_il', $P2 dlfunc $P2, $P1, 'hline', 'ili' set_global 'ncurses::hline', $P2 dlfunc $P2, $P1, 'idcok', 'vpl' set_global 'ncurses::idcok', $P2 dlfunc $P2, $P1, 'idlok', 'ipl' set_global 'ncurses::idlok', $P2 dlfunc $P2, $P1, 'immedok', 'vpl' set_global 'ncurses::immedok', $P2 dlfunc $P2, $P1, 'inch', 'l' set_global 'ncurses::inch', $P2 dlfunc $P2, $P1, 'inchnstr', 'i4i' set_global 'ncurses::inchnstr', $P2 dlfunc $P2, $P1, 'inchstr', 'i4' set_global 'ncurses::inchstr', $P2 dlfunc $P2, $P1, 'initscr', 'p' set_global 'ncurses::initscr', $P2 dlfunc $P2, $P1, 'init_color', 'issss' set_global 'ncurses::init_color', $P2 dlfunc $P2, $P1, 'init_pair', 'isss' set_global 'ncurses::init_pair', $P2 dlfunc $P2, $P1, 'innstr', 'iti' set_global 'ncurses::innstr', $P2 dlfunc $P2, $P1, 'insstr', 'it' set_global 'ncurses::insstr', $P2 dlfunc $P2, $P1, 'instr', 'it' set_global 'ncurses::instr', $P2 dlfunc $P2, $P1, 'intrflush', 'ipl' set_global 'ncurses::intrflush', $P2 dlfunc $P2, $P1, 'isendwin', 'l' set_global 'ncurses::isendwin', $P2 dlfunc $P2, $P1, 'is_linetouched', 'lpi' set_global 'ncurses::is_linetouched', $P2 dlfunc $P2, $P1, 'is_wintouched', 'lp' set_global 'ncurses::is_wintouched', $P2 dlfunc $P2, $P1, 'keyname', 'ti' set_global 'ncurses::keyname', $P2 dlfunc $P2, $P1, 'keypad', 'ipl' set_global 'ncurses::keypad', $P2 dlfunc $P2, $P1, 'killchar', 'c' set_global 'ncurses::killchar', $P2 dlfunc $P2, $P1, 'leaveok', 'ipl' set_global 'ncurses::leaveok', $P2 dlfunc $P2, $P1, 'longname', 't' set_global 'ncurses::longname', $P2 dlfunc $P2, $P1, 'meta', 'ipl' set_global 'ncurses::meta', $P2 dlfunc $P2, $P1, 'move', 'iii' set_global 'ncurses::move', $P2 dlfunc $P2, $P1, 'mvaddch', 'iiil' set_global 'ncurses::mvaddch', $P2 dlfunc $P2, $P1, 'mvaddchnstr', 'iii4i' set_global 'ncurses::mvaddchnstr', $P2 dlfunc $P2, $P1, 'mvaddchstr', 'iii4' set_global 'ncurses::mvaddchstr', $P2 dlfunc $P2, $P1, 'mvaddnstr', 'iiiti' set_global 'ncurses::mvaddnstr', $P2 dlfunc $P2, $P1, 'mvaddstr', 'iiit' set_global 'ncurses::mvaddstr', $P2 dlfunc $P2, $P1, 'mvchgat', 'iiiilsp' set_global 'ncurses::mvchgat', $P2 #dlfunc $P2, $P1, 'mvcur', 'iiiii' #set_global 'ncurses::mvcur', $P2 dlfunc $P2, $P1, 'mvdelch', 'iii' set_global 'ncurses::mvdelch', $P2 dlfunc $P2, $P1, 'mvderwin', 'ipii' set_global 'ncurses::mvderwin', $P2 dlfunc $P2, $P1, 'mvgetch', 'iii' set_global 'ncurses::mvgetch', $P2 dlfunc $P2, $P1, 'mvgetnstr', 'iiiti' set_global 'ncurses::mvgetnstr', $P2 dlfunc $P2, $P1, 'mvgetstr', 'iiit' set_global 'ncurses::mvgetstr', $P2 dlfunc $P2, $P1, 'mvhline', 'iiili' set_global 'ncurses::mvhline', $P2 dlfunc $P2, $P1, 'mvinch', 'lii' set_global 'ncurses::mvinch', $P2 dlfunc $P2, $P1, 'mvinchnstr', 'iiiti' set_global 'ncurses::mvinchnstr', $P2 dlfunc $P2, $P1, 'mvinchstr', 'iii4' set_global 'ncurses::mvinchstr', $P2 dlfunc $P2, $P1, 'mvinnstr', 'iiiti' set_global 'ncurses::mvinnstr', $P2 dlfunc $P2, $P1, 'mvinsch', 'iiil' set_global 'ncurses::mvinsch', $P2 dlfunc $P2, $P1, 'mvinsnstr', 'iiiti' set_global 'ncurses::mvinsnstr', $P2 dlfunc $P2, $P1, 'mvinsstr', 'iiit' set_global 'ncurses::mvinsstr', $P2 dlfunc $P2, $P1, 'mvvline', 'iiili' set_global 'ncurses::mvvline', $P2 dlfunc $P2, $P1, 'mvwaddch', 'ipiil' set_global 'ncurses::mvwaddch', $P2 dlfunc $P2, $P1, 'mvwaddchnstr', 'ipii4i' set_global 'ncurses::mvwaddchnstr', $P2 dlfunc $P2, $P1, 'mvwaddchstr', 'ipii4' set_global 'ncurses::mvwaddchstr', $P2 dlfunc $P2, $P1, 'mvwaddnstr', 'ipiiti' set_global 'ncurses::mvwaddnstr', $P2 dlfunc $P2, $P1, 'mvwaddstr', 'ipiit' set_global 'ncurses::mvwaddstr', $P2 dlfunc $P2, $P1, 'mvwchgat', 'ipiiilsp' set_global 'ncurses::mvwchgat', $P2 dlfunc $P2, $P1, 'mvwdelch', 'ipii' set_global 'ncurses::mvwdelch', $P2 dlfunc $P2, $P1, 'mvwgetch', 'ipii' set_global 'ncurses::mvwgetch', $P2 dlfunc $P2, $P1, 'mvwgetnstr', 'ipiiti' set_global 'ncurses::mvwgetnstr', $P2 dlfunc $P2, $P1, 'mvwgetstr', 'ipiit' set_global 'ncurses::mvwgetstr', $P2 dlfunc $P2, $P1, 'mvwhline', 'ipiili' set_global 'ncurses::mvwhline', $P2 dlfunc $P2, $P1, 'mvwin', 'ipii' set_global 'ncurses::mvwin', $P2 dlfunc $P2, $P1, 'mvwinch', 'lpii' set_global 'ncurses::mvwinch', $P2 dlfunc $P2, $P1, 'mvwinchnstr', 'ipii4i' set_global 'ncurses::mvwinchnstr', $P2 dlfunc $P2, $P1, 'mvwinchstr', 'ipii4' set_global 'ncurses::mvwinchstr', $P2 dlfunc $P2, $P1, 'mvwinnstr', 'ipiiti' set_global 'ncurses::mvwinnstr', $P2 dlfunc $P2, $P1, 'mvwinsch', 'ipiil' set_global 'ncurses::mvwinsch', $P2 dlfunc $P2, $P1, 'mvwinsnstr', 'ipiiti' set_global 'ncurses::mvwinsnstr', $P2 dlfunc $P2, $P1, 'mvwinsstr', 'ipiit' set_global 'ncurses::mvwinsstr', $P2 dlfunc $P2, $P1, 'mvwinstr', 'ipiit' set_global 'ncurses::mvwinstr', $P2 dlfunc $P2, $P1, 'mvwvline', 'ipiili' set_global 'ncurses::mvwvline', $P2 dlfunc $P2, $P1, 'napms', 'ii' set_global 'ncurses::napms', $P2 dlfunc $P2, $P1, 'newpad', 'pii' set_global 'ncurses::newpad', $P2 dlfunc $P2, $P1, 'newterm', 'ptpp' set_global 'ncurses::newterm', $P2 dlfunc $P2, $P1, 'newwin', 'piiii' set_global 'ncurses::newwin', $P2 dlfunc $P2, $P1, 'nl', 'i' set_global 'ncurses::nl', $P2 dlfunc $P2, $P1, 'nocbreak', 'i' set_global 'ncurses::nocbreak', $P2 dlfunc $P2, $P1, 'nodelay', 'ipl' set_global 'ncurses::nodelay', $P2 dlfunc $P2, $P1, 'noecho', 'i' set_global 'ncurses::noecho', $P2 dlfunc $P2, $P1, 'nonl', 'i' set_global 'ncurses::nonl', $P2 dlfunc $P2, $P1, 'noqiflush', 'v' set_global 'ncurses::noqiflush', $P2 dlfunc $P2, $P1, 'noraw', 'i' set_global 'ncurses::noraw', $P2 dlfunc $P2, $P1, 'notimeout', 'ipl' set_global 'ncurses::notimeout', $P2 dlfunc $P2, $P1, 'overlay', 'ipp' set_global 'ncurses::overlay', $P2 dlfunc $P2, $P1, 'overwrite', 'ipp' set_global 'ncurses::overwrite', $P2 dlfunc $P2, $P1, 'pair_content', 'is22' set_global 'ncurses::pair_content', $P2 dlfunc $P2, $P1, 'PAIR_NUMBER', 'ii' set_global 'ncurses::PAIR_NUMBER', $P2 dlfunc $P2, $P1, 'pechochar', 'ipl' set_global 'ncurses::pechochar', $P2 dlfunc $P2, $P1, 'pnoutrefresh', 'ipiiiiii' set_global 'ncurses::pnoutrefresh', $P2 dlfunc $P2, $P1, 'prefresh', 'ipiiiiii' set_global 'ncurses::prefresh', $P2 dlfunc $P2, $P1, 'putp', 'it' set_global 'ncurses::putp', $P2 dlfunc $P2, $P1, 'putwin', 'ipp' set_global 'ncurses::putwin', $P2 dlfunc $P2, $P1, 'qiflush', 'v' set_global 'ncurses::qiflush', $P2 dlfunc $P2, $P1, 'raw', 'i' set_global 'ncurses::raw', $P2 dlfunc $P2, $P1, 'redrawwin', 'ip' set_global 'ncurses::redrawwin', $P2 dlfunc $P2, $P1, 'refresh', 'i' set_global 'ncurses::refresh', $P2 dlfunc $P2, $P1, 'resetty', 'i' set_global 'ncurses::resetty', $P2 dlfunc $P2, $P1, 'reset_prog_mode', 'i' set_global 'ncurses::reset_prog_mode', $P2 dlfunc $P2, $P1, 'reset_shell_mode', 'i' set_global 'ncurses::reset_shell_mode', $P2 dlfunc $P2, $P1, 'ripoffline', 'iiip' set_global 'ncurses::ripoffline', $P2 dlfunc $P2, $P1, 'savetty', 'i' set_global 'ncurses::savetty', $P2 dlfunc $P2, $P1, 'scr_dump', 'it' set_global 'ncurses::scr_dump', $P2 dlfunc $P2, $P1, 'scr_init', 'it' set_global 'ncurses::scr_init', $P2 dlfunc $P2, $P1, 'scrl', 'ii' set_global 'ncurses::scrl', $P2 dlfunc $P2, $P1, 'scroll', 'ip' set_global 'ncurses::scroll', $P2 dlfunc $P2, $P1, 'scrollok', 'ipl' set_global 'ncurses::scrollok', $P2 dlfunc $P2, $P1, 'scr_restore', 'it' set_global 'ncurses::scr_restore', $P2 dlfunc $P2, $P1, 'scr_set', 'it' set_global 'ncurses::scr_set', $P2 dlfunc $P2, $P1, 'setscrreg', 'iii' set_global 'ncurses::setscrreg', $P2 dlfunc $P2, $P1, 'set_term', 'pp' set_global 'ncurses::set_term', $P2 dlfunc $P2, $P1, 'slk_attroff', 'il' set_global 'ncurses::slk_attroff', $P2 dlfunc $P2, $P1, 'slk_attron', 'il' set_global 'ncurses::slk_attron', $P2 dlfunc $P2, $P1, 'slk_attrset', 'il' set_global 'ncurses::slk_attrset', $P2 dlfunc $P2, $P1, 'slk_attr', 'l' set_global 'ncurses::slk_attr', $P2 dlfunc $P2, $P1, 'slk_attr_set', 'ilsp' set_global 'ncurses::slk_attr_set', $P2 dlfunc $P2, $P1, 'slk_clear', 'i' set_global 'ncurses::slk_clear', $P2 dlfunc $P2, $P1, 'slk_color', 'is' set_global 'ncurses::slk_color', $P2 dlfunc $P2, $P1, 'slk_init', 'ii' set_global 'ncurses::slk_init', $P2 dlfunc $P2, $P1, 'slk_label', 'ti' set_global 'ncurses::slk_label', $P2 dlfunc $P2, $P1, 'slk_noutrefresh', 'i' set_global 'ncurses::slk_noutrefresh', $P2 dlfunc $P2, $P1, 'slk_refresh', 'i' set_global 'ncurses::slk_refresh', $P2 dlfunc $P2, $P1, 'slk_restore', 'i' set_global 'ncurses::slk_restore', $P2 dlfunc $P2, $P1, 'slk_set', 'iiti' set_global 'ncurses::slk_set', $P2 dlfunc $P2, $P1, 'slk_touch', 'i' set_global 'ncurses::slk_touch', $P2 dlfunc $P2, $P1, 'standout', 'i' set_global 'ncurses::standout', $P2 dlfunc $P2, $P1, 'standend', 'i' set_global 'ncurses::standend', $P2 dlfunc $P2, $P1, 'start_color', 'i' set_global 'ncurses::start_color', $P2 dlfunc $P2, $P1, 'subpad', 'ppiiii' set_global 'ncurses::subpad', $P2 dlfunc $P2, $P1, 'subwin', 'ppiiii' set_global 'ncurses::subwin', $P2 dlfunc $P2, $P1, 'syncok', 'ipl' set_global 'ncurses::syncok', $P2 dlfunc $P2, $P1, 'termattrs', 'l' set_global 'ncurses::termattrs', $P2 dlfunc $P2, $P1, 'termname', 't' set_global 'ncurses::termname', $P2 dlfunc $P2, $P1, 'tigetflag', 'it' set_global 'ncurses::tigetflag', $P2 dlfunc $P2, $P1, 'tigetnum', 'it' set_global 'ncurses::tigetnum', $P2 dlfunc $P2, $P1, 'tigetstr', 'tt' set_global 'ncurses::tigetstr', $P2 dlfunc $P2, $P1, 'timeout', 'vi' set_global 'ncurses::timeout', $P2 dlfunc $P2, $P1, 'typeahead', 'ii' set_global 'ncurses::typeahead', $P2 dlfunc $P2, $P1, 'ungetch', 'ii' set_global 'ncurses::ungetch', $P2 dlfunc $P2, $P1, 'untouchwin', 'ip' set_global 'ncurses::untouchwin', $P2 dlfunc $P2, $P1, 'use_env', 'vl' set_global 'ncurses::use_env', $P2 dlfunc $P2, $P1, 'vidattr', 'il' set_global 'ncurses::vidattr', $P2 dlfunc $P2, $P1, 'vidputs', 'ilp' set_global 'ncurses::vidputs', $P2 dlfunc $P2, $P1, 'vline', 'ili' set_global 'ncurses::vline', $P2 dlfunc $P2, $P1, 'waddch', 'ipl' set_global 'ncurses::waddch', $P2 dlfunc $P2, $P1, 'waddchnstr', 'ip4i' set_global 'ncurses::waddchnstr', $P2 dlfunc $P2, $P1, 'waddchstr', 'ip4' set_global 'ncurses::waddchstr', $P2 dlfunc $P2, $P1, 'waddnstr', 'ipti' set_global 'ncurses::waddnstr', $P2 dlfunc $P2, $P1, 'waddstr', 'ipt' set_global 'ncurses::waddstr', $P2 dlfunc $P2, $P1, 'wattron', 'ipi' set_global 'ncurses::wattron', $P2 dlfunc $P2, $P1, 'wattroff', 'ipi' set_global 'ncurses::wattroff', $P2 dlfunc $P2, $P1, 'wattrset', 'ipi' set_global 'ncurses::wattrset', $P2 dlfunc $P2, $P1, 'wattr_get', 'ip42p' set_global 'ncurses::wattr_get', $P2 dlfunc $P2, $P1, 'wattr_on', 'iplp' set_global 'ncurses::wattr_on', $P2 dlfunc $P2, $P1, 'wattr_off', 'iplp' set_global 'ncurses::wattr_off', $P2 dlfunc $P2, $P1, 'wattr_set', 'iplsp' set_global 'ncurses::wattr_set', $P2 dlfunc $P2, $P1, 'wbkgd', 'ipl' set_global 'ncurses::wbkgd', $P2 dlfunc $P2, $P1, 'wbkgdset', 'vpl' set_global 'ncurses::wbkgdset', $P2 dlfunc $P2, $P1, 'wborder', 'ipllllllll' set_global 'ncurses::wborder', $P2 dlfunc $P2, $P1, 'wchgat', 'ipilsp' set_global 'ncurses::wchgat', $P2 dlfunc $P2, $P1, 'wclear', 'ip' set_global 'ncurses::wclear', $P2 dlfunc $P2, $P1, 'wclrtobot', 'ip' set_global 'ncurses::wclrtobot', $P2 dlfunc $P2, $P1, 'wclrtoeol', 'ip' set_global 'ncurses::wclrtoeol', $P2 dlfunc $P2, $P1, 'wcolor_set', 'ipsp' set_global 'ncurses::wcolor_set', $P2 dlfunc $P2, $P1, 'wcursyncup', 'vp' set_global 'ncurses::wcursyncup', $P2 dlfunc $P2, $P1, 'wdelch', 'ip' set_global 'ncurses::wdelch', $P2 dlfunc $P2, $P1, 'wdeleteln', 'ip' set_global 'ncurses::wdeleteln', $P2 dlfunc $P2, $P1, 'wechochar', 'ipl' set_global 'ncurses::wechochar', $P2 dlfunc $P2, $P1, 'werase', 'ip' set_global 'ncurses::werase', $P2 dlfunc $P2, $P1, 'wgetch', 'ip' set_global 'ncurses::wgetch', $P2 dlfunc $P2, $P1, 'wgetnstr', 'ipti' set_global 'ncurses::wgetnstr', $P2 dlfunc $P2, $P1, 'wgetstr', 'ipt' set_global 'ncurses::wgetstr', $P2 dlfunc $P2, $P1, 'whline', 'ipli' set_global 'ncurses::whline', $P2 dlfunc $P2, $P1, 'winch', 'lp' set_global 'ncurses::winch', $P2 dlfunc $P2, $P1, 'winchnstr', 'ip4i' set_global 'ncurses::winchnstr', $P2 dlfunc $P2, $P1, 'winnstr', 'ipti' set_global 'ncurses::winnstr', $P2 dlfunc $P2, $P1, 'winsch', 'ipl' set_global 'ncurses::winsch', $P2 dlfunc $P2, $P1, 'winsdelln', 'ipi' set_global 'ncurses::winsdelln', $P2 dlfunc $P2, $P1, 'winsertln', 'ip' set_global 'ncurses::winsertln', $P2 dlfunc $P2, $P1, 'winsnstr', 'ipti' set_global 'ncurses::winsnstr', $P2 dlfunc $P2, $P1, 'winsstr', 'ipt' set_global 'ncurses::winsstr', $P2 dlfunc $P2, $P1, 'winstr', 'ipt' set_global 'ncurses::winstr', $P2 dlfunc $P2, $P1, 'wmove', 'ipii' set_global 'ncurses::wmove', $P2 dlfunc $P2, $P1, 'wnoutrefresh', 'ip' set_global 'ncurses::wnoutrefresh', $P2 dlfunc $P2, $P1, 'wredrawln', 'ipii' set_global 'ncurses::wredrawln', $P2 dlfunc $P2, $P1, 'wrefresh', 'ip' set_global 'ncurses::wrefresh', $P2 dlfunc $P2, $P1, 'wscrl', 'ipi' set_global 'ncurses::wscrl', $P2 dlfunc $P2, $P1, 'wsetscrreg', 'ipii' set_global 'ncurses::wsetscrreg', $P2 dlfunc $P2, $P1, 'wstandout', 'ip' set_global 'ncurses::wstandout', $P2 dlfunc $P2, $P1, 'wstandend', 'ip' set_global 'ncurses::wstandend', $P2 dlfunc $P2, $P1, 'wsyncdown', 'vp' set_global 'ncurses::wsyncdown', $P2 dlfunc $P2, $P1, 'wsyncup', 'vp' set_global 'ncurses::wsyncup', $P2 dlfunc $P2, $P1, 'wtimeout', 'vpi' set_global 'ncurses::wtimeout', $P2 dlfunc $P2, $P1, 'wtouchln', 'ipiii' set_global 'ncurses::wtouchln', $P2 dlfunc $P2, $P1, 'wvline', 'ipli' set_global 'ncurses::wvline', $P2 dlfunc $P2, $P1, 'getmouse', 'ip' set_global 'ncurses::getmouse', $P2 dlfunc $P2, $P1, 'ungetmouse', 'ip' set_global 'ncurses::ungetmouse', $P2 dlfunc $P2, $P1, 'mousemask', 'll4' set_global 'ncurses::mousemask', $P2 dlfunc $P2, $P1, 'wenclose', 'lpii' set_global 'ncurses::wenclose', $P2 dlfunc $P2, $P1, 'mouseinterval', 'ii' set_global 'ncurses::mouseinterval', $P2 dlfunc $P2, $P1, 'wmouse_trafo', 'lp33l' set_global 'ncurses::wmouse_trafo', $P2 dlfunc $P2, $P1, 'mouse_trafo', 'l33l' set_global 'ncurses::mouse_trafo', $P2 dlfunc $P2, $P1, 'mcprint', 'iti' set_global 'ncurses::mcprint', $P2 dlfunc $P2, $P1, 'has_key', 'ii' set_global 'ncurses::has_key', $P2 .begin_return .end_return .end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: vpm.pir000644000765000765 140311567202623 16741 0ustar00bruce000000000000parrot-6.6.0/examples/benchmarks# Copyright (C) 2004-2009, Parrot Foundation. # beginn #use strict; # #use warnings; .sub main :main .local string _string _string = "just another perl hacker" $I0 = 0 loop0: .local pmc _str .local pmc _f split _str, "", _string # you can't shift from the type of array that split returns. Do a # two step. _f = _str[0] delete _str[0] # you can't push onto the type of array that split returns. Do a # two step. $I1 = _str $I2 = $I1 + 1 _str = $I2 _str[$I1] = _f _string = join "", _str inc $I0 if $I0 <= 99999 goto loop0 print $I0 print ";\n" print _string print "\n" end .end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: DumpAsText.pm000644000765000765 760511644422074 16617 0ustar00bruce000000000000parrot-6.6.0/lib/Pod/Simple require 5; package Pod::Simple::DumpAsText; $VERSION = '3.19'; use Pod::Simple (); BEGIN {@ISA = ('Pod::Simple')} use strict; use Carp (); BEGIN { *DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG } sub new { my $self = shift; my $new = $self->SUPER::new(@_); $new->{'output_fh'} ||= *STDOUT{IO}; $new->accept_codes('VerbatimFormatted'); return $new; } #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ sub _handle_element_start { # ($self, $element_name, $attr_hash_r) my $fh = $_[0]{'output_fh'}; my($key, $value); DEBUG and print "++ $_[1]\n"; print $fh ' ' x ($_[0]{'indent'} || 0), "++", $_[1], "\n"; $_[0]{'indent'}++; while(($key,$value) = each %{$_[2]}) { unless($key =~ m/^~/s) { next if $key eq 'start_line' and $_[0]{'hide_line_numbers'}; _perly_escape($key); _perly_escape($value); printf $fh qq{%s \\ "%s" => "%s"\n}, ' ' x ($_[0]{'indent'} || 0), $key, $value; } } return; } sub _handle_text { DEBUG and print "== \"$_[1]\"\n"; if(length $_[1]) { my $indent = ' ' x $_[0]{'indent'}; my $text = $_[1]; _perly_escape($text); $text =~ # A not-totally-brilliant wrapping algorithm: s/( [^\n]{55} # Snare some characters from a line [^\n\ ]{0,50} # and finish any current word ) \x20{1,10}(?!\n) # capture some spaces not at line-end /$1"\n$indent . "/gx # => line-break here ; print {$_[0]{'output_fh'}} $indent, '* "', $text, "\"\n"; } return; } sub _handle_element_end { DEBUG and print "-- $_[1]\n"; print {$_[0]{'output_fh'}} ' ' x --$_[0]{'indent'}, "--", $_[1], "\n"; return; } # . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . sub _perly_escape { foreach my $x (@_) { $x =~ s/([^\x00-\xFF])/sprintf'\x{%X}',ord($1)/eg; # Escape things very cautiously: $x =~ s/([^-\n\t \&\<\>\'!\#\%\(\)\*\+,\.\/\:\;=\?\~\[\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/sprintf'\x%02X',ord($1)/eg; } return; } #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ 1; __END__ =head1 NAME Pod::Simple::DumpAsText -- dump Pod-parsing events as text =head1 SYNOPSIS perl -MPod::Simple::DumpAsText -e \ "exit Pod::Simple::DumpAsText->filter(shift)->any_errata_seen" \ thingy.pod =head1 DESCRIPTION This class is for dumping, as text, the events gotten from parsing a Pod document. This class is of interest to people writing Pod formatters based on Pod::Simple. It is useful for seeing exactly what events you get out of some Pod that you feed in. This is a subclass of L and inherits all its methods. =head1 SEE ALSO L L =head1 SUPPORT Questions or discussion about POD and Pod::Simple should be sent to the pod-people@perl.org mail list. Send an empty email to pod-people-subscribe@perl.org to subscribe. This module is managed in an open GitHub repository, L. Feel free to fork and contribute, or to clone L and send patches! Patches against Pod::Simple are welcome. Please send bug reports to . =head1 COPYRIGHT AND DISCLAIMERS Copyright (c) 2002 Sean M. Burke. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. This program is distributed in the hope that it will be useful, but without any warranty; without even the implied warranty of merchantability or fitness for a particular purpose. =head1 AUTHOR Pod::Simple was created by Sean M. Burke . But don't bother him, he's retired. Pod::Simple is maintained by: =over =item * Allison Randal C =item * Hans Dieter Pearcey C =item * David E. Wheeler C =back =cut dev_generated_pseudo000644000765000765 54611533177646 22305 0ustar00bruce000000000000parrot-6.6.0/t/tools/install/testlib# See tools/dev/install_files.pl for documentation on the # format of this file. # Please re-sort this file after *EVERY* modification runtime/parrot/library/TGE.pbc [tge] src/pmc/pmc_object.h [devel]include vtable.dump [devel]src # Local variables: # mode: text # End: arrayiterator.t000644000765000765 1124711533177645 15626 0ustar00bruce000000000000parrot-6.6.0/t/pmc#!./parrot # Copyright (C) 2001-2010, Parrot Foundation. =head1 NAME t/pmc/arrayiterator.t - ArrayIterator PMC =head1 SYNOPSIS % prove t/pmc/arrayiterator.t =head1 DESCRIPTION Tests C PMC. Navigate in both directions, check bounds. =cut .namespace [] .include 'iterator.pasm' .include 'except_types.pasm' .sub main :main .include 'test_more.pir' plan(28) iterate_forward() # 8 tests iterate_backward() # 6 tests iterate_backward_string() # 6 test iterate_wrong() # 1 test iterator_init() # 1 test .end .sub 'iterate_forward' .local pmc foo, it foo = new ['ResizablePMCArray'] it = iter foo nok(it, "Iterator for empty array is empty") $I0 = isa it, 'Iterator' ok($I0, "Have proper type") push foo, 1 push foo, 42 it = iter foo ok(it, "Iterator for 2-elem list is not empty") $P0 = shift it ok(it, "Can shift 1st element") is($P0, 1, "With expected value") $P1 = new ['Integer'], 0 $I0 = exists it[$P1] is($I0, 1, "exists_keyed gives expected value") $I0 = defined it[$P1] is($I0, 1, "defined_keyed gives expected value") $P2 = it[$P1] is($P2, 42, "get_pmc_keyed gives expected value") $I0 = it[$P1] is($I0, 42, "get_integer_keyed gives expected value") $N0 = it[$P1] is($N0, 42.0, "get_number_keyed gives expected value") $S0 = it[$P1] is($S0, '42', "get_string_keyed gives expected value") $P0 = shift it nok(it, "Iterator is finished after second shift") is($P0, 42, "2nd element has correct value") .local int result .local pmc ehandler result = 0 ehandler = new ['ExceptionHandler'] ehandler.'handle_types'(.EXCEPTION_OUT_OF_BOUNDS) push_eh ehandler set_label ehandler, handlep $P0 = shift it goto fail handlep: finalize ehandler set_label ehandler, handlei $I0 = shift it goto fail handlei: finalize ehandler set_label ehandler, handlen $N0 = shift it goto fail handlen: finalize ehandler set_label ehandler, handles $S0 = shift it goto fail handles: finalize ehandler result = 1 fail: pop_eh ok(result, "Shifting from finished iterator throws out of bounds exception") .end .sub 'iterate_backward' .local pmc foo, it foo = new ['ResizablePMCArray'] push foo, 1 push foo, 42 it = iter foo it = .ITERATE_FROM_END ok(it, "Iterator reset to backward iteration") $P0 = pop it ok(it, "Can shift 1st element") is($P0, 42, "With expected value") $P0 = pop it nok(it, "Iterator is finished after second shift") is($P0, 1, "2nd element has correct value") .local int result .local pmc ehandler result = 0 ehandler = new ['ExceptionHandler'] ehandler.'handle_types'(.EXCEPTION_OUT_OF_BOUNDS) push_eh ehandler set_label ehandler, handlep $P0 = pop it goto fail handlep: finalize ehandler set_label ehandler, handlei $I0 = pop it goto fail handlei: finalize ehandler set_label ehandler, handlen $N0 = pop it goto fail handlen: finalize ehandler set_label ehandler, handles $S0 = pop it goto fail handles: finalize ehandler result = 1 fail: pop_eh ok(result, "pop from finished iterator throws out of bounds exception") .end .sub 'iterate_backward_string' .local pmc foo, it foo = new ['ResizableStringArray'] push foo, 'First' push foo, 'Other' it = iter foo it = .ITERATE_FROM_END ok(it, "Iterator reset to backward iteration - string") $S0 = pop it ok(it, "Can shift 1st element - string") is($S0, 'Other', "With expected value- string") $S0 = pop it nok(it, "Iterator is finished after second shift - string") is($S0, 'First', "2nd element has correct value - string") $I0 = 1 push_eh fail $S0 = shift it $I0 = 0 fail: pop_eh ok($I0, "Shifting from finished iterator throws exception - string") .end .sub 'iterate_wrong' .local pmc foo, it, ex .local int r foo = new ['FixedIntegerArray'], 1 it = iter foo push_eh catch_wrong it = 42 # Let's hope we'll never have such direction r = 0 goto dotest catch_wrong: .get_results(ex) finalize ex r = 1 dotest: pop_eh ok(r, "Caught wrong direction") .end .sub 'iterator_init' .local pmc it, e .local string msg msg = "ArrayIterator can't be directly instantiated, init must throw" push_eh CATCH it = new 'ArrayIterator' pop_eh ok(0, msg) goto DONE CATCH: .get_results(e) pop_eh ok(1, msg) DONE: .end # Local Variables: # mode: pir # fill-column: 100 # End: # vim: expandtab shiftwidth=4 ft=pir: time_old.t000644000765000765 142711567202625 15727 0ustar00bruce000000000000parrot-6.6.0/t/dynoplibs#!perl # Copyright (C) 2001-2009, Parrot Foundation. use strict; use warnings; use lib qw( . lib ../lib ../../lib ); use Test::More; use Parrot::Test tests => 1; =head1 NAME t/op/time.t - Time and Sleep =head1 SYNOPSIS % prove t/op/time.t =head1 DESCRIPTION Tests the C