https://perl5.git.perl.org / perl5.git / blame
| Commit | Line | Data |
|---|---|---|
| 4ceeac64 AB |
1 | APTR T_PTR |
| 2 | intArray * T_ARRAY | |
| 3 | UWORD T_UV | |
| 4 | ULONG T_UV | |
| 5 | WORD T_IV | |
| 6 | LONG T_IV | |
| 7 | BOOL T_IV | |
| 8 | TagList * T_TAGLIST | |
| 9 | TAGRET T_TAGRET | |
| 10 | STRPTR T_PV | |
| 11 | int32 T_IV | |
| 12 | uint32 T_UV | |
| 13 | ||
| 14 | ############################################################################# | |
| 15 | INPUT | |
| 16 | T_TAGLIST | |
| 17 | U32 ix_$var = $argoff; | |
| 18 | U32 _tag_type; | |
| 19 | /* allocate taglist struct, +2 as tags lists end in a TAG_DONE by tradition */ | |
| 20 | /* if by some chance someone adds something after the TAG_DONE it will just*/ | |
| 21 | /* result in harmless empty space */ | |
| 22 | $var = $ntype((items -= $argoff) +2); | |
| 23 | while(items > 0) | |
| 24 | { | |
| 25 | int __index = (ix_$var - $argoff)/3; | |
| 26 | $var\[__index\].ti_Tag = (ULONG)SvUV(ST(ix_$var)); | |
| 27 | ix_$var++; | |
| 28 | items--; | |
| 29 | /* the last is a tag_done and usualy has no followers so check for > 1 */ | |
| 30 | if(items > 1 && ($var\[__index\].ti_Tag != TAG_DONE)) | |
| 31 | { | |
| 32 | _tag_type = (ULONG)SvUV(ST(ix_$var)); | |
| 33 | ix_$var++; | |
| 34 | switch(_tag_type) | |
| 35 | { | |
| 36 | case TT_APTR: | |
| 37 | $var\[__index\].ti_Data = (ULONG)INT2PTR(APTR,SvIV(ST(ix_$var))); | |
| 38 | break; | |
| 39 | case TT_WORD: | |
| 40 | $var\[__index\].ti_Data = (WORD)SvIV(ST(ix_$var)); | |
| 41 | break; | |
| 42 | case TT_LONG: | |
| 43 | $var\[__index\].ti_Data = (LONG)SvIV(ST(ix_$var)); | |
| 44 | break; | |
| 45 | case TT_UWORD: | |
| 46 | $var\[__index\].ti_Data = (UWORD)SvUV(ST(ix_$var)); | |
| 47 | break; | |
| 48 | case TT_ULONG: | |
| 49 | $var\[__index\].ti_Data = (ULONG)SvUV(ST(ix_$var)); | |
| 50 | break; | |
| 51 | case TT_STRPTR: | |
| 52 | case TT_UBYTE: | |
| 53 | $var\[__index\].ti_Data = (ULONG)(STRPTR)SvPV_nolen(ST(ix_$var)); | |
| 54 | break; | |
| 55 | default: | |
| 56 | Perl_croak(aTHX_ \"Unknown TAGTYPE \%d\",_tag_type); | |
| 57 | } | |
| 58 | ix_$var++; | |
| 59 | items -=2; | |
| 60 | } | |
| 61 | } | |
| 62 | ||
| 63 | T_TAGRET | |
| 64 | /* Allocate variable type according to preceding var tagtype */ | |
| 65 | switch(tagtype) | |
| 66 | { | |
| 67 | case TT_APTR: | |
| 68 | $var.tr_aptr = INT2PTR(APTR,SvIV($arg)); | |
| 69 | break; | |
| 70 | case TT_WORD: | |
| 71 | $var.tr_word = (WORD)SvIV($arg); | |
| 72 | break; | |
| 73 | case TT_LONG: | |
| 74 | $var.tr_long = (LONG)SvIV($arg); | |
| 75 | case TT_UWORD: | |
| 76 | $var.tr_uword = (UWORD)SvUV($arg); | |
| 77 | break; | |
| 78 | case TT_ULONG: | |
| 79 | $var.tr_ulong = (ULONG)SvUV($arg); | |
| 80 | break; | |
| 81 | case TT_STRPTR: | |
| 82 | case TT_UBYTE: | |
| 83 | $var.tr_strptr = (STRPTR)SvPV_nolen($arg); | |
| 84 | break; | |
| 85 | default: | |
| 86 | Perl_croak(aTHX_ \"Unknown TAGTYPE \%d\",tagtype); | |
| 87 | } | |
| 88 | ||
| 89 | #################################################################################### | |
| 90 | OUTPUT | |
| 91 | T_TAGRET | |
| 92 | /* Allocate variable type according to preceding var tagtype */ | |
| 93 | switch(tagtype) | |
| 94 | { | |
| 95 | case TT_APTR: | |
| 96 | sv_setiv($arg, PTR2IV($var.tr_aptr)); | |
| 97 | break; | |
| 98 | case TT_WORD: | |
| 99 | sv_setiv($arg, (IV)$var.tr_word); | |
| 100 | break; | |
| 101 | case TT_LONG: | |
| 102 | sv_setiv($arg, (IV)$var.tr_long); | |
| 103 | break; | |
| 104 | case TT_UWORD: | |
| 105 | sv_setuv($arg, (UV)$var.tr_uword); | |
| 106 | break; | |
| 107 | case TT_ULONG: | |
| 108 | sv_setuv($arg, (UV)$var.tr_ulong); | |
| 109 | break; | |
| 110 | case TT_STRPTR: | |
| 111 | case TT_UBYTE: | |
| 112 | sv_setpv((SV*)$arg, $var.tr_strptr); | |
| 113 | break; | |
| 114 | default: | |
| 115 | Perl_croak(aTHX_ \"Unknown TAGTYPE \%d\",tagtype); | |
| 116 | } | |
| 117 | ||
| 118 |