Changeset 87e95d3 in tol for toltcl/generic/tolaccess.cpp


Ignore:
Timestamp:
Aug 4, 2009, 12:51:31 PM (17 years ago)
Author:
Jorge Pérez <josp.jorge@…>
Branches:
1941-docker-image-to-test, devel, master
Children:
41d0e3c
Parents:
10e4c70
Message:

New command tol::foreach in order to makes it clear the way a Set is iterated from Tcl.

As an example:

set it 1
tol::foreach memb { Set LinRegMet } {

array set it_info $memb
puts "Informacion para el item $it"
parray it_info
incr it

}

git-svn-id: ​https://www.tol-project.org/svn/tolp/trunk@1204 be4846ae-f051-483a-831f-b64e7d08527f

File:
1 edited

Legend:

Unmodified
Added
Removed

  • toltcl/generic/tolaccess.cpp

    r10e4c70 r87e95d3  
    541541    tcl_code = Tcl_GetIntFromObj(interp,indexes[i],&idx);
    542542    if (tcl_code != TCL_OK) {
    543       Tcl_AppendObjToObj(obj_result,Tcl_GetObjResult(interp));
     543      Tcl_AppendObjToObj( obj_result, Tcl_GetObjResult(interp));
    544544      break;
    545545    }
    … …  
    796796}
    797797
     798inline void SAVE_SET_STRING( Tcl_Obj **obj, Tcl_DString* dstr )
     799{
     800  if (Tcl_IsShared( *obj ) ) {
     801    Tcl_DecrRefCount( *obj );
     802    *obj = Tcl_NewStringObj( Tcl_DStringValue( dstr ), -1 );
     803    Tcl_IncrRefCount( *obj );
     804  } else
     805    Tcl_SetStringObj( *obj, Tcl_DStringValue( dstr ),-1 );
     806}
     807
     808/*! Implement a foreach proc similar to the one provided in Tcl except
     809 *  that instead of iterating over the list's items it iterates over
     810 *  the Set's items. The set could be tolset if the indexes is empty
     811 *  or tolset[i1][i2]...[ik] for the given indexes {i1,i2,...,ik}
     812 */
     813int Tol_ForEach (Tcl_Interp * interp,
     814                 int objc,
     815                 Tcl_Obj *CONST objv[],
     816                 Tcl_Obj * obj_result)
     817{
     818  const BSyntaxObject* container;
     819  Tcl_DString dstr;
     820  Tcl_Obj * ArgIndexes;
     821  int tcl_code = TCL_OK;
     822  int i, card ;
     823  int n, index_length;
     824  Tcl_Obj ** items;
     825
     826  int length = 0;
     827
     828  if ( Tcl_GetCharLength( objv[ 0 ] ) == 0 ) {
     829    Tcl_AppendStringsToObj( obj_result, "empty loop variable name", NULL );
     830    return TCL_ERROR;
     831  }
     832 
     833  if ( Tcl_ListObjLength( interp, objv[ 1 ], &length) != TCL_OK ) {
     834    Tcl_AppendObjToObj( obj_result, Tcl_GetObjResult( interp ) );
     835    return TCL_ERROR;
     836  }
     837  if ( length < 2 ) {
     838    Tcl_AppendStringsToObj( obj_result,
     839                            "invalid object reference '",
     840                            Tcl_GetString(objv[0]),
     841                            "must be {TYPE ?name? i1 i2 ... ik}",
     842                            NULL );
     843    return TCL_ERROR;
     844  }
     845
     846  int OBJ_GRAMMAR    = 0;
     847  int OBJ_GRAMMARV   = OBJ_GRAMMAR + 1;
     848  int OBJ_NAME       = OBJ_GRAMMARV + 1;
     849  int OBJ_NAMEV      = OBJ_NAME + 1;
     850  int OBJ_CONTENT    = OBJ_NAMEV + 1;
     851  int OBJ_CONTENTV   = OBJ_CONTENT + 1;
     852  int OBJ_PATH       = OBJ_CONTENTV + 1;
     853  int OBJ_PATHV      = OBJ_PATH + 1;
     854  int OBJ_DESC       = OBJ_PATHV + 1;
     855  int OBJ_DESCV      = OBJ_DESC + 1;
     856  int OBJ_INDEXES    =  OBJ_DESCV + 1;
     857  int OBJ_INDEXESV   =  OBJ_INDEXES + 1;
     858  int OBJ_ISFILE     = OBJ_INDEXESV + 1;
     859  int OBJ_ISFILEV    = OBJ_ISFILE + 1;
     860  int OBJ_HASSUBSET  = OBJ_ISFILEV + 1;
     861  int OBJ_HASSUBSETV = OBJ_HASSUBSET + 1;
     862  int OBJ_SUBTYPE    = OBJ_HASSUBSETV + 1;
     863  int OBJ_SUBTYPEV   = OBJ_SUBTYPE + 1;
     864  int OBJ_STRUCT     = OBJ_SUBTYPEV + 1;
     865  int OBJ_STRUCTV    = OBJ_STRUCT + 1;
     866  int NUM_OBJS      = OBJ_STRUCTV + 1;
     867
     868  int datac;
     869  Tcl_Obj *datav[ NUM_OBJS ];
     870
     871 
     872  if ( !( container = Tol_ResolveObject( interp, objv[ 1 ], obj_result ) ) ) {
     873    return TCL_ERROR;
     874  }
     875  BSet *set = ContainerGetSet( container );
     876  if (!set) {
     877    Tcl_AppendStringsToObj(obj_result,
     878                           "object '",
     879                           Tcl_GetString(objv[0]),
     880                           "' is not a valid container ",
     881                           NULL);
     882      return TCL_ERROR;
     883  }
     884 
     885  card = set->Card();
     886 
     887  // is ok to ask for a list
     888  Tcl_ListObjGetElements( interp, objv[ 0 ], &n, &items );
     889
     890  // initialize the list of indexes (the common part) for every item
     891  // in the Set
     892  if (strcmp(Tcl_GetString( items[ 0 ] ),"Console")) {
     893    if (n>2)
     894      ArgIndexes = Tcl_NewListObj( n - 2, items + 2 );
     895    else
     896      ArgIndexes = Tcl_NewListObj( 0, NULL );
     897  } else {
     898    if ( n > 1 )
     899      ArgIndexes = Tcl_NewListObj( n - 1, items + 1 );
     900    else
     901      ArgIndexes = Tcl_NewListObj( 0, NULL );
     902  }
     903
     904  datav[ OBJ_GRAMMAR ]  = Tcl_NewStringObj( "grammar", -1 );
     905  datav[ OBJ_GRAMMARV ] = Tcl_NewObj( );
     906  datav[ OBJ_NAME ]     = Tcl_NewStringObj( "name", -1 );
     907  datav[ OBJ_NAMEV ]    = Tcl_NewObj( );
     908  datav[ OBJ_CONTENT ]  = Tcl_NewStringObj( "content", -1 );
     909  datav[ OBJ_CONTENTV ] = Tcl_NewObj( );
     910  datav[ OBJ_PATH ]     = Tcl_NewStringObj( "path", -1 );
     911  datav[ OBJ_PATHV ]    = Tcl_NewObj( );
     912  datav[ OBJ_DESC ]     = Tcl_NewStringObj( "description", -1 );
     913  datav[ OBJ_DESCV ]    = Tcl_NewObj( );
     914  Tcl_Obj * last_index  = Tcl_NewIntObj( 0 );
     915  Tcl_ListObjAppendElement( NULL, ArgIndexes, last_index );
     916  datav[ OBJ_INDEXES ]  = Tcl_NewStringObj( "indexes", -1 );
     917  datav[ OBJ_INDEXESV ] = ArgIndexes;
     918  Tcl_ListObjLength( NULL, datav[ OBJ_INDEXES ], &index_length );
     919  datav[ OBJ_ISFILE ]     = Tcl_NewStringObj( "isfile", -1 );
     920  datav[ OBJ_ISFILEV ]    = Tcl_NewObj( );
     921  datav[ OBJ_HASSUBSET ]  = Tcl_NewStringObj( "hassubset", -1 );
     922  datav[ OBJ_HASSUBSETV ] = Tcl_NewObj( );
     923  datav[ OBJ_SUBTYPE ]    = Tcl_NewStringObj( "subtype", -1 );
     924  datav[ OBJ_SUBTYPEV ]   = Tcl_NewObj( );
     925  datav[ OBJ_STRUCT ]     = Tcl_NewStringObj( "struct", -1 );
     926  datav[ OBJ_STRUCTV ]    = Tcl_NewObj( );
     927
     928  // the just created objects have refcount = 0
     929  for ( i = 0; i < NUM_OBJS; ++i ) {
     930    Tcl_IncrRefCount( datav[ i ] );
     931  }
     932 
     933  BSyntaxObject *syn_i;
     934  BSet          *set_i; /* just in case syn_i be a container */
     935
     936  /* now iter over its children */
     937 
     938  Tcl_DStringInit( &dstr );
     939  BText btxt;
     940 
     941  for ( i = 1; i <= card; ++i ) {
     942    syn_i = ( *set )[ i ];
     943   
     944    /* read the grammar */
     945    btxt = syn_i->Grammar( )->Name( );
     946    Tcl_ExternalToUtfDString( NULL, btxt, -1, &dstr );
     947    SAVE_SET_STRING( datav + OBJ_GRAMMARV, &dstr );
     948    Tcl_DStringFree(&dstr);
     949   
     950    /* read the name */
     951    //btxt = syn_i->Identify();
     952    GetName( syn_i, btxt );
     953    Tcl_ExternalToUtfDString(NULL,btxt,-1,&dstr);
     954    SAVE_SET_STRING( datav + OBJ_NAMEV, &dstr );
     955    Tcl_DStringFree(&dstr);
     956   
     957    /* read the content */
     958    btxt = syn_i->Info();
     959    Tcl_ExternalToUtfDString(NULL,btxt,-1,&dstr);
     960    SAVE_SET_STRING( datav + OBJ_CONTENTV, &dstr );
     961    Tcl_DStringFree(&dstr);
     962   
     963    /* read the path */
     964    btxt = syn_i->SourcePath();
     965    Tcl_ExternalToUtfDString(NULL,btxt,-1,&dstr);
     966    SAVE_SET_STRING( datav + OBJ_PATHV, &dstr );
     967    Tcl_DStringFree(&dstr);
     968   
     969    /* read the description */   
     970    btxt = syn_i->Description();
     971    Tcl_ExternalToUtfDString(NULL,btxt,-1,&dstr);
     972    SAVE_SET_STRING( datav + OBJ_PATHV, &dstr );
     973    Tcl_DStringFree(&dstr);
     974
     975    // Este if es para incluir en los items que son Set informacion
     976    // que solo ellos llevan como: Subtype, IsFile, etc ...
     977    if ( ( set_i = ContainerGetSet( syn_i ) ) ) {
     978      /* update last index */
     979      if ( Tcl_IsShared( last_index ) ) {
     980        last_index = Tcl_NewIntObj( i );
     981        Tcl_ListObjReplace( NULL, datav[ OBJ_INDEXESV ], index_length-1,
     982                           1, 1, &last_index );
     983      }
     984      /* set the last value index */
     985      Tcl_SetIntObj( last_index, i );
     986      /* to refresh the string */
     987      Tcl_InvalidateStringRep( datav[ OBJ_INDEXESV ] );
     988      if ( Tcl_IsShared( datav[ OBJ_ISFILEV ] ) ) {
     989        Tcl_DecrRefCount( datav[ OBJ_ISFILEV ] );
     990#ifdef ISFILE_IMPLEMENTED
     991        datav[ OBJ_ISFILEV ] = Tcl_NewIntObj( syn_i->IsFile( ) );
     992#else
     993        datav[OBJ_ISFILEV] = Tcl_NewIntObj( 0 );
     994#endif
     995        Tcl_IncrRefCount( datav[ OBJ_ISFILEV ] );
     996      } else
     997#ifdef ISFILE_IMPLEMENTED
     998        Tcl_SetIntObj( datav[ OBJ_ISFILEV ], syn_i->IsFile( ) );
     999#else
     1000      Tcl_SetIntObj( datav[ OBJ_ISFILEV ], 0 );
     1001#endif
     1002      /* verify if has subset */
     1003      int tmpCard = set_i->Card( );
     1004      int j;
     1005      for ( j = 1; j <= tmpCard; ++j )
     1006        if ( ContainerGetSet( ( *set_i )[ j ] ) )
     1007          break;
     1008      if ( Tcl_IsShared( datav[ OBJ_HASSUBSETV ] ) ) {
     1009        Tcl_DecrRefCount( datav[ OBJ_HASSUBSETV ] );
     1010        datav[ OBJ_HASSUBSETV ] = Tcl_NewIntObj( j <= tmpCard );
     1011        Tcl_IncrRefCount( datav[ OBJ_HASSUBSETV ] );
     1012      } else
     1013        Tcl_SetIntObj( datav[ OBJ_HASSUBSETV ], j <= tmpCard );
     1014       
     1015      /* subtype info */
     1016      if ( Tcl_IsShared( datav[ OBJ_SUBTYPEV ] ) ) {
     1017        Tcl_DecrRefCount( datav[ OBJ_SUBTYPEV ] );
     1018        datav[ OBJ_SUBTYPEV ] = Tcl_NewIntObj( set_i->SubType( ) );
     1019        Tcl_IncrRefCount( datav[ OBJ_SUBTYPEV ] );
     1020      } else
     1021        Tcl_SetIntObj( datav[ OBJ_SUBTYPEV ],set_i->SubType( ) );
     1022       
     1023      /* STRUCT INFO */
     1024      // asume que dstr esta a longitud 0
     1025      if ( set_i->Struct( ) ) {
     1026        btxt = set_i->Struct( )->Name( );
     1027        Tcl_ExternalToUtfDString( NULL, btxt, -1, &dstr );
     1028      }
     1029      SAVE_SET_STRING( datav + OBJ_PATHV, &dstr );
     1030      Tcl_DStringFree( &dstr );
     1031      datac = NUM_OBJS;
     1032    } else
     1033      datac = OBJ_INDEXESV + 1;
     1034    // set the loop variable
     1035    Tcl_Obj *varValuePtr = Tcl_ObjSetVar2( interp, objv[ 0 ], NULL,
     1036                                           Tcl_NewListObj( datac, datav ),
     1037                                           TCL_LEAVE_ERR_MSG );
     1038    if (varValuePtr == NULL) {
     1039      Tcl_AppendObjToObj( obj_result, Tcl_GetObjResult( interp ) );
     1040      Tcl_AppendStringsToObj( obj_result,
     1041                              "\n    (setting foreach loop variable \"",
     1042                              Tcl_GetString( objv[ 0 ] ), "\")",
     1043                              NULL );
     1044      tcl_code = TCL_ERROR;
     1045      break;
     1046    }
     1047    tcl_code = Tcl_EvalObjEx( interp, objv[ 2 ], 0 );
     1048    if ( tcl_code != TCL_OK) {
     1049      if ( tcl_code == TCL_CONTINUE) {
     1050        tcl_code = TCL_OK;
     1051      } else if ( tcl_code == TCL_BREAK) {
     1052        tcl_code = TCL_OK;
     1053        break;
     1054      } else if ( tcl_code == TCL_ERROR) {
     1055        Tcl_AppendObjToObj( obj_result, Tcl_GetObjResult( interp ) );
     1056        break;
     1057      } else {
     1058        break;
     1059      }
     1060    }
     1061  }
     1062 
     1063  /* liberar los objetos tcl */
     1064  for ( i = 0; i < NUM_OBJS; ++i ) {
     1065    Tcl_DecrRefCount( datav[ i ] );
     1066  }
     1067  return tcl_code;
     1068}
     1069
    7981070
    7991071/*
    … …  
    8151087  Tcl_DString dstr;
    8161088  Tcl_Obj * ArgIndexes;
    817   int tcl_code, cont_loop;
     1089  int tcl_code;
    8181090  int i, card ;
    8191091  int n, index_length;
Note: See TracChangeset for help on using the changeset viewer.