PLplot  5.12.0
 All Classes Namespaces Files Functions Variables Typedefs Enumerations Enumerator Macros
tclMatrix.c
Go to the documentation of this file.
1 // Copyright 1994, 1995
2 // Maurice LeBrun mjl@dino.ph.utexas.edu
3 // Institute for Fusion Studies University of Texas at Austin
4 //
5 // Copyright (C) 2004 Joao Cardoso
6 // Copyright (C) 2016 Alan W. Irwin
7 //
8 // This file is part of PLplot.
9 //
10 // PLplot is free software; you can redistribute it and/or modify
11 // it under the terms of the GNU Library General Public License as published
12 // by the Free Software Foundation; either version 2 of the License, or
13 // (at your option) any later version.
14 //
15 // PLplot is distributed in the hope that it will be useful,
16 // but WITHOUT ANY WARRANTY; without even the implied warranty of
17 // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 // GNU Library General Public License for more details.
19 //
20 // You should have received a copy of the GNU Library General Public License
21 // along with PLplot; if not, write to the Free Software
22 // Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
23 //
24 //--------------------------------------------------------------------------
25 //
26 // This file contains routines that implement Tcl matrices.
27 // These are operators that are used to store, return, and modify
28 // numeric data stored in binary array format. The emphasis is
29 // on high performance and low overhead, something that Tcl lists
30 // or associative arrays aren't so good at.
31 //
32 
33 //
34 //#define DEBUG
35 //
36 
37 #include <stdio.h>
38 #include <stdlib.h>
39 #include <string.h>
40 #include "pldll.h"
41 #include "tclMatrix.h"
42 
43 // Cool math macros
44 
45 #ifndef MAX
46 #define MAX( a, b ) ( ( ( a ) > ( b ) ) ? ( a ) : ( b ) )
47 #endif
48 #ifndef MIN
49 #define MIN( a, b ) ( ( ( a ) < ( b ) ) ? ( a ) : ( b ) )
50 #endif
51 
52 // For the truly desperate debugging task
53 
54 #ifdef DEBUG_ENTER
55 #define dbug_enter( a ) \
56  fprintf( stderr, "%s: Entered %s\n", __FILE__, a );
57 
58 #else
59 #define dbug_enter( a )
60 #endif
61 
62 // Internal data
63 
64 static int matTable_initted = 0; // Hash table initialization flag
65 static Tcl_HashTable matTable; // Hash table for external access to data
66 
67 // Function prototypes
68 
69 // Handles matrix initialization lists
70 
71 static int
72 MatrixAssign( Tcl_Interp* interp, tclMatrix* m,
73  int level, int *offset, int nargs, const char** args );
74 
75 // Invoked to process the "matrix" Tcl command.
76 
77 static int
78 MatrixCmd( ClientData clientData, Tcl_Interp *interp, int argc, const char **argv );
79 
80 // Causes matrix command to be deleted.
81 
82 static char *
83 DeleteMatrixVar( ClientData clientData,
84  Tcl_Interp *interp, char *name1, char *name2, int flags );
85 
86 // Releases all the resources allocated to the matrix command.
87 
88 static void
89 DeleteMatrixCmd( ClientData clientData );
90 
91 // These do the put/get operations for each supported type
92 
93 static void
94 MatrixPut_f( ClientData clientData, Tcl_Interp* interp, int index, const char *string );
95 
96 static void
97 MatrixGet_f( ClientData clientData, Tcl_Interp* interp, int index, char *string );
98 
99 static void
100 MatrixPut_i( ClientData clientData, Tcl_Interp* interp, int index, const char *string );
101 
102 static void
103 MatrixGet_i( ClientData clientData, Tcl_Interp* interp, int index, char *string );
104 
105 //--------------------------------------------------------------------------
106 //
107 // Tcl_MatCmd --
108 //
109 // Invoked to process the "matrix" Tcl command. Creates a multiply
110 // dimensioned array (matrix) of floats or ints. The number of
111 // arguments determines the dimensionality.
112 //
113 // Results:
114 // Returns the name of the new matrix.
115 //
116 // Side effects:
117 // A new matrix (operator) gets created.
118 //
119 //--------------------------------------------------------------------------
120 
121 int
122 Tcl_MatrixCmd( ClientData PL_UNUSED( clientData ), Tcl_Interp *interp,
123  int argc, const char **argv )
124 {
125  register tclMatrix *matPtr;
126  int i, j, new, index, persist = 0, initializer = 0;
127  Tcl_HashEntry *hPtr;
128  Tcl_CmdInfo infoPtr;
129  char c;
130  size_t argv0_length;
131  int offset = 0;
132  size_t concatenated_argv_len;
133  char *concatenated_argv;
134  const char *const_concatenated_argv;
135 
136  dbug_enter( "Tcl_MatrixCmd" );
137 
138  if ( argc < 3 )
139  {
140  Tcl_AppendResult( interp, "wrong # args: should be \"", argv[0],
141  " ?-persist? var type dim1 ?dim2? ?dim3? ...\"", (char *) NULL );
142  return TCL_ERROR;
143  }
144 
145  // Create hash table on first call
146 
147  if ( !matTable_initted )
148  {
149  matTable_initted = 1;
150  Tcl_InitHashTable( &matTable, TCL_STRING_KEYS );
151  }
152 
153  // Check for -persist flag
154 
155  for ( i = 1; i < argc; i++ )
156  {
157  c = argv[i][0];
158  argv0_length = strlen( argv[i] );
159 
160  // If found, set persist variable and compress argv-list
161 
162  if ( ( c == '-' ) && ( strncmp( argv[i], "-persist", argv0_length ) == 0 ) )
163  {
164  persist = 1;
165  argc--;
166  for ( j = i; j < argc; j++ )
167  argv[j] = argv[j + 1];
168  break;
169  }
170  }
171 
172  // Create matrix data structure
173 
174  matPtr = (tclMatrix *) malloc( sizeof ( tclMatrix ) );
175  matPtr->fdata = NULL;
176  matPtr->idata = NULL;
177  matPtr->name = NULL;
178  matPtr->dim = 0;
179  matPtr->len = 1;
180  matPtr->tracing = 0;
181  matPtr->indices = NULL;
182 
183  // MAX_ARRAY_DIM is #defined to be 3. Later programming logic
184  // treats all lower-dimensioned matrices as 3D matrices where the
185  // higher dimension size is 1. So must initialize all sizes
186  // to 1 here.
187  for ( i = 0; i < MAX_ARRAY_DIM; i++ )
188  matPtr->n[i] = 1;
189 
190  // Create name
191  // It should be unique
192 
193  argc--; argv++;
194 
195  if ( Tcl_GetCommandInfo( interp, argv[0], &infoPtr ) )
196  {
197  Tcl_AppendResult( interp, "Matrix operator \"", argv[0],
198  "\" already in use", (char *) NULL );
199  free( (void *) matPtr );
200  return TCL_ERROR;
201  }
202 
203  if ( Tcl_GetVar( interp, argv[0], 0 ) != NULL )
204  {
205  Tcl_AppendResult( interp, "Illegal name for Matrix operator \"",
206  argv[0], "\": local variable of same name is active",
207  (char *) NULL );
208  free( (void *) matPtr );
209  return TCL_ERROR;
210  }
211 
212  matPtr->name = (char *) malloc( strlen( argv[0] ) + 1 );
213  strcpy( matPtr->name, argv[0] );
214 
215  // Initialize type
216 
217  argc--; argv++;
218  c = argv[0][0];
219  argv0_length = strlen( argv[0] );
220 
221  if ( ( c == 'f' ) && ( strncmp( argv[0], "float", argv0_length ) == 0 ) )
222  {
223  matPtr->type = TYPE_FLOAT;
224  matPtr->put = MatrixPut_f;
225  matPtr->get = MatrixGet_f;
226  }
227  else if ( ( c == 'i' ) && ( strncmp( argv[0], "int", argv0_length ) == 0 ) )
228  {
229  matPtr->type = TYPE_INT;
230  matPtr->put = MatrixPut_i;
231  matPtr->get = MatrixGet_i;
232  }
233  else
234  {
235  Tcl_AppendResult( interp, "Matrix type \"", argv[0],
236  "\" not supported, should be \"float\" or \"int\"",
237  (char *) NULL );
238 
239  DeleteMatrixCmd( (ClientData) matPtr );
240  return TCL_ERROR;
241  }
242 
243  // Initialize dimensions
244 
245  argc--; argv++;
246  for (; argc > 0; argc--, argv++ )
247  {
248  // Check for initializer
249 
250  if ( strcmp( argv[0], "=" ) == 0 )
251  {
252  argc--; argv++;
253  initializer = 1;
254  break;
255  }
256 
257  // Must be a dimensional parameter. Increment number of dimensions.
258 
259  matPtr->dim++;
260  if ( matPtr->dim > MAX_ARRAY_DIM )
261  {
262  Tcl_AppendResult( interp,
263  "too many dimensions specified for Matrix operator \"",
264  matPtr->name, "\"", (char *) NULL );
265 
266  DeleteMatrixCmd( (ClientData) matPtr );
267  return TCL_ERROR;
268  }
269 
270  // Check to see if dimension is valid and store
271 
272  index = matPtr->dim - 1;
273  matPtr->n[index] = MAX( 0, atoi( argv[0] ) );
274  matPtr->len *= matPtr->n[index];
275  }
276 
277  if ( matPtr->dim < 1 )
278  {
279  Tcl_AppendResult( interp,
280  "insufficient dimensions given for Matrix operator \"",
281  matPtr->name, "\"", (char *) NULL );
282  DeleteMatrixCmd( (ClientData) matPtr );
283  return TCL_ERROR;
284  }
285 
286  // Allocate space for data
287 
288  switch ( matPtr->type )
289  {
290  case TYPE_FLOAT:
291  matPtr->fdata = (Mat_float *) malloc( (size_t) ( matPtr->len ) * sizeof ( Mat_float ) );
292  for ( i = 0; i < matPtr->len; i++ )
293  matPtr->fdata[i] = 0.0;
294  break;
295 
296  case TYPE_INT:
297  matPtr->idata = (Mat_int *) malloc( (size_t) ( matPtr->len ) * sizeof ( Mat_int ) );
298  for ( i = 0; i < matPtr->len; i++ )
299  matPtr->idata[i] = 0;
300  break;
301  }
302 
303  // Process the initializer, if present
304 
305  if ( initializer )
306  {
307  if ( argc <= 0 )
308  {
309  Tcl_AppendResult( interp,
310  "no initialization data given after \"=\" for Matrix operator \"",
311  matPtr->name, "\"", (char *) NULL );
312  DeleteMatrixCmd( (ClientData) matPtr );
313  return TCL_ERROR;
314  }
315 
316  // Prepare concatenated_argv string consisting of "{argv[0] argv[1] ... argv[argc-1]}"
317  // so that _any_ space-separated bunch of numerical arguments will work.
318  // Account for beginning and ending curly braces and trailing \0.
319  concatenated_argv_len = 3;
320  for ( i = 0; i < argc; i++ )
321  // Account for length of string + space separator.
322  concatenated_argv_len += strlen( argv[i] ) + 1;
323  concatenated_argv = (char *) malloc( concatenated_argv_len * sizeof ( char ) );
324 
325  // Prepare for string concatenation using strcat
326  concatenated_argv[0] = '\0';
327  strcat( concatenated_argv, "{" );
328  for ( i = 0; i < argc; i++ )
329  {
330  strcat( concatenated_argv, argv[i] );
331  strcat( concatenated_argv, " " );
332  }
333  strcat( concatenated_argv, "}" );
334 
335  const_concatenated_argv = (const char *) concatenated_argv;
336 
337  // Use all raw indices in row-major (C) order for put in MatrixAssign
338  matPtr->nindices = matPtr->len;
339  matPtr->indices = NULL;
340 
341  if ( MatrixAssign( interp, matPtr, 0, &offset, 1, &const_concatenated_argv ) != TCL_OK )
342  {
343  DeleteMatrixCmd( (ClientData) matPtr );
344  free( (void *) concatenated_argv );
345  return TCL_ERROR;
346  }
347  free( (void *) concatenated_argv );
348  }
349 
350  // For later use in matrix assigments
351  // N.B. matPtr->len could be large so this check for success might
352  // be more than pro forma.
353  if ( ( matPtr->indices = (int *) malloc( (size_t) ( matPtr->len ) * sizeof ( int ) ) ) == NULL )
354  {
355  Tcl_AppendResult( interp,
356  "memory allocation failed for indices vector associated with Matrix operator \"",
357  matPtr->name, "\"", (char *) NULL );
358  DeleteMatrixCmd( (ClientData) matPtr );
359  return TCL_ERROR;
360  }
361  // Delete matrix when it goes out of scope unless -persist specified
362  // Use local variable of same name as matrix and trace it for unsets
363 
364  if ( !persist )
365  {
366  if ( Tcl_SetVar( interp, matPtr->name,
367  "old_bogus_syntax_please_upgrade", 0 ) == NULL )
368  {
369  Tcl_AppendResult( interp, "unable to schedule Matrix operator \"",
370  matPtr->name, "\" for automatic deletion", (char *) NULL );
371  DeleteMatrixCmd( (ClientData) matPtr );
372  return TCL_ERROR;
373  }
374  matPtr->tracing = 1;
375  Tcl_TraceVar( interp, matPtr->name, TCL_TRACE_UNSETS,
376  (Tcl_VarTraceProc *) DeleteMatrixVar, (ClientData) matPtr );
377  }
378 
379  // Create matrix operator
380 
381 #ifdef DEBUG
382  fprintf( stderr, "Creating Matrix operator of name %s\n", matPtr->name );
383 #endif
384  Tcl_CreateCommand( interp, matPtr->name, (Tcl_CmdProc *) MatrixCmd,
385  (ClientData) matPtr, (Tcl_CmdDeleteProc *) DeleteMatrixCmd );
386 
387  // Store pointer to interpreter to handle bizarre uses of multiple
388  // interpreters (e.g. as in [incr Tcl])
389 
390  matPtr->interp = interp;
391 
392  // Create hash table entry for this matrix operator's data
393  // This should never fail
394 
395  hPtr = Tcl_CreateHashEntry( &matTable, matPtr->name, &new );
396  if ( !new )
397  {
398  Tcl_AppendResult( interp,
399  "Unable to create hash table entry for Matrix operator \"",
400  matPtr->name, "\"", (char *) NULL );
401  return TCL_ERROR;
402  }
403  Tcl_SetHashValue( hPtr, matPtr );
404 
405  Tcl_SetResult( interp, matPtr->name, TCL_VOLATILE );
406  return TCL_OK;
407 }
408 
409 //--------------------------------------------------------------------------
410 //
411 // Tcl_GetMatrixPtr --
412 //
413 // Returns a pointer to the specified matrix operator's data.
414 //
415 // Results:
416 // None.
417 //
418 // Side effects:
419 // None.
420 //
421 //--------------------------------------------------------------------------
422 
423 tclMatrix *
424 Tcl_GetMatrixPtr( Tcl_Interp *interp, const char *matName )
425 {
426  Tcl_HashEntry *hPtr;
427 
428  dbug_enter( "Tcl_GetMatrixPtr" );
429 
430  if ( !matTable_initted )
431  {
432  return NULL;
433  }
434 
435  hPtr = Tcl_FindHashEntry( &matTable, matName );
436  if ( hPtr == NULL )
437  {
438  Tcl_AppendResult( interp, "No matrix operator named \"",
439  matName, "\"", (char *) NULL );
440  return NULL;
441  }
442  return (tclMatrix *) Tcl_GetHashValue( hPtr );
443 }
444 
445 //--------------------------------------------------------------------------
446 //
447 // Tcl_MatrixInstallXtnsn --
448 //
449 // Install a tclMatrix extension subcommand.
450 //
451 // Results:
452 // Should be 1. Have to think about error results.
453 //
454 // Side effects:
455 // Enables you to install special purpose compiled code to handle
456 // custom operations on a tclMatrix.
457 //
458 //--------------------------------------------------------------------------
459 
462 
463 int
465 {
466 //
467 // My goodness how I hate primitive/pathetic C. With C++ this
468 // could've been as easy as:
469 // List<TclMatrixXtnsnDescr> xtnlist;
470 // xtnlist.append( tclMatrixXtnsnDescr(cmd,proc) );
471 // grrrrr.
472 //
473 
474  tclMatrixXtnsnDescr *new =
475  (tclMatrixXtnsnDescr *) malloc( sizeof ( tclMatrixXtnsnDescr ) );
476 
477  dbug_enter( "Tcl_MatrixInstallXtnsn" );
478 
479 #ifdef DEBUG
480  fprintf( stderr, "Installing a tclMatrix extension -> %s\n", cmd );
481 #endif
482 
483  new->cmd = malloc( strlen( cmd ) + 1 );
484  strcpy( new->cmd, cmd );
485  new->cmdproc = proc;
486  new->next = (tclMatrixXtnsnDescr *) NULL;
487 
488  if ( !head )
489  {
490  tail = head = new;
491  return 1;
492  }
493  else
494  {
495  tail = tail->next = new;
496  return 1;
497  }
498 }
499 
500 //--------------------------------------------------------------------------
501 //
502 // MatrixAssign --
503 //
504 // Assign values to the elements of a matrix.
505 //
506 // Returns TCL_OK on success or TC_ERROR on failure.
507 //
508 //--------------------------------------------------------------------------
509 
510 static int MatrixAssign( Tcl_Interp* interp, tclMatrix* m,
511  int level, int *offset, int nargs, const char** args )
512 {
513  static int verbose = 0;
514 
515  const char ** newargs;
516  int numnewargs;
517  int i;
518 
519  if ( verbose )
520  {
521  fprintf( stderr, "level %d offset %d nargs %d\n", level, *offset, nargs );
522  for ( i = 0; i < nargs; i++ )
523  {
524  fprintf( stderr, "i = %d, args[i] = %s\n", i, args[i] );
525  }
526  }
527  // Just in case of some programming error below that creates an infinite loop
528  if ( level > 100 )
529  {
530  Tcl_AppendResult( interp, "too many list levels", (char *) NULL );
531  return TCL_ERROR;
532  }
533 
534  for ( i = 0; i < nargs; i++ )
535  {
536  if ( Tcl_SplitList( interp, args[i], &numnewargs, &newargs )
537  != TCL_OK )
538  {
539  // Tcl_SplitList has already appended an error message
540  // to the result associated with interp so no need to
541  // append more.
542  return TCL_ERROR;
543  }
544 
545  if ( numnewargs == 1 && strlen( args[i] ) == strlen( newargs[0] ) && strcmp( args[i], newargs[0] ) == 0 )
546  {
547  // Tcl_SplitList has gone as deep as it can go into hierarchical lists ....
548  if ( *offset >= m->nindices )
549  {
550  // Ignore any values in array assignment beyond what are needed.
551  }
552  else
553  {
554  if ( verbose )
555  fprintf( stderr, "\ta[%d] = %s\n", *offset, args[i] );
556  if ( m->indices == NULL )
557  ( m->put )( (ClientData) m, interp, *offset, args[i] );
558  else
559  ( m->put )( (ClientData) m, interp, m->indices[*offset], args[i] );
560  ( *offset )++;
561  }
562  }
563  else if ( MatrixAssign( interp, m, level + 1, offset, numnewargs, newargs )
564  != TCL_OK )
565  {
566  Tcl_Free( (char *) newargs );
567  return TCL_ERROR;
568  }
569  Tcl_Free( (char *) newargs );
570  }
571  return TCL_OK;
572 }
573 
574 //--------------------------------------------------------------------------
575 //
576 // MatrixCmd --
577 //
578 // When a Tcl matrix command is invoked, this routine is called.
579 //
580 // Results:
581 // A standard Tcl result value, usually TCL_OK.
582 // On matrix get commands, one or a number of matrix elements are
583 // printed.
584 //
585 // Side effects:
586 // Depends on the matrix command.
587 //
588 //--------------------------------------------------------------------------
589 
590 static int
591 MatrixCmd( ClientData clientData, Tcl_Interp *interp,
592  int argc, const char **argv )
593 {
594  register tclMatrix *matPtr = (tclMatrix *) clientData;
595  int put = 0;
596  char c, tmp[200];
597  const char *name = argv[0];
598  // In one case (negative step and desired last actual index of 0)
599  // stop[i] is -1 so it must have an int type rather than size_t.
600  // To reduce casting most other slice-related types are also int
601  // rather than size_t.
602  int start[MAX_ARRAY_DIM], stop[MAX_ARRAY_DIM], step[MAX_ARRAY_DIM], sign_step[MAX_ARRAY_DIM];
603  int i, j, k;
604  int char_converted, change_default_start, change_default_stop;
605  size_t argv0_length;
606  // Needs dimension of 2 to contain ":" and terminating NULL as a result of sscanf calls below.
607  char c1[2], c2[2];
608 
609  // Initialize
610 
611  if ( argc < 2 )
612  {
613  Tcl_AppendResult( interp, "wrong # args, type: \"",
614  argv[0], " help\" for more info", (char *) NULL );
615  return TCL_ERROR;
616  }
617 
618  for ( i = 0; i < MAX_ARRAY_DIM; i++ )
619  {
620  start[i] = 0;
621  stop[i] = matPtr->n[i];
622  step[i] = 1;
623  sign_step[i] = 1;
624  }
625 
626  // First check for a matrix command
627 
628  argc--; argv++;
629  c = argv[0][0];
630  argv0_length = strlen( argv[0] );
631 
632  // dump -- send a nicely formatted listing of the array contents to stdout
633  // (very helpful for debugging)
634 
635  if ( ( c == 'd' ) && ( strncmp( argv[0], "dump", argv0_length ) == 0 ) )
636  {
637  for ( i = start[0]; i < stop[0]; i++ )
638  {
639  for ( j = start[1]; j < stop[1]; j++ )
640  {
641  for ( k = start[2]; k < stop[2]; k++ )
642  {
643  ( *matPtr->get )( (ClientData) matPtr, interp, I3D( i, j, k ), tmp );
644  printf( "%s ", tmp );
645  }
646  if ( matPtr->dim > 2 )
647  printf( "\n" );
648  }
649  if ( matPtr->dim > 1 )
650  printf( "\n" );
651  }
652  printf( "\n" );
653  return TCL_OK;
654  }
655 
656  // delete -- delete the array
657 
658  else if ( ( c == 'd' ) && ( strncmp( argv[0], "delete", argv0_length ) == 0 ) )
659  {
660 #ifdef DEBUG
661  fprintf( stderr, "Deleting array %s\n", name );
662 #endif
663  Tcl_DeleteCommand( interp, name );
664  return TCL_OK;
665  }
666 
667  // filter
668  // Only works on 1d matrices
669 
670  else if ( ( c == 'f' ) && ( strncmp( argv[0], "filter", argv0_length ) == 0 ) )
671  {
672  Mat_float *tmpMat;
673  int ifilt, nfilt;
674 
675  if ( argc != 2 )
676  {
677  Tcl_AppendResult( interp, "wrong # args: should be \"",
678  name, " ", argv[0], " num-passes\"",
679  (char *) NULL );
680  return TCL_ERROR;
681  }
682 
683  if ( matPtr->dim != 1 || matPtr->type != TYPE_FLOAT )
684  {
685  Tcl_AppendResult( interp, "can only filter a 1d float matrix",
686  (char *) NULL );
687  return TCL_ERROR;
688  }
689 
690  nfilt = atoi( argv[1] );
691  tmpMat = (Mat_float *) malloc( (size_t) ( matPtr->len + 2 ) * sizeof ( Mat_float ) );
692 
693  for ( ifilt = 0; ifilt < nfilt; ifilt++ )
694  {
695  // Set up temporary filtering array. Use even boundary conditions.
696 
697  j = 0; tmpMat[j] = matPtr->fdata[0];
698  for ( i = 0; i < matPtr->len; i++ )
699  {
700  j++; tmpMat[j] = matPtr->fdata[i];
701  }
702  j++; tmpMat[j] = matPtr->fdata[matPtr->len - 1];
703 
704  // Apply 3-point binomial filter
705 
706  for ( i = 0; i < matPtr->len; i++ )
707  {
708  j = i + 1;
709  matPtr->fdata[i] = 0.25 * ( tmpMat[j - 1] + 2 * tmpMat[j] + tmpMat[j + 1] );
710  }
711  }
712 
713  free( (void *) tmpMat );
714  return TCL_OK;
715  }
716 
717  // help
718 
719  else if ( ( c == 'h' ) && ( strncmp( argv[0], "help", argv0_length ) == 0 ) )
720  {
721  Tcl_AppendResult( interp,
722  "Available subcommands:\n\
723 dump - return the values in the matrix as a string\n\
724 delete - delete the matrix (including the matrix command)\n\
725 filter - apply a three-point averaging (with a number of passes; ome-dimensional only)\n\
726 help - this information\n\
727 info - return the dimensions\n\
728 max - return the maximum value for the entire matrix or for the first N entries\n\
729 min - return the minimum value for the entire matrix or for the first N entries\n\
730 redim - resize the matrix (for one-dimensional matrices only)\n\
731 scale - scale the values by a given factor (for one-dimensional matrices only)\n\
732 \n\
733 Set and get values:\n\
734 matrix m f 3 3 3 - define matrix command \"m\", three-dimensional, floating-point data\n\
735 m 1 2 3 - return the value of matrix element [1,2,3]\n\
736 m 1 2 3 = 2.0 - set the value of matrix element [1,2,3] to 2.0 (do not return the value)\n\
737 m * 2 3 = 2.0 - set a slice consisting of all elements with second index 2 and third index 3 to 2.0",
738  (char *) NULL );
739  return TCL_OK;
740  }
741 
742  // info
743 
744  else if ( ( c == 'i' ) && ( strncmp( argv[0], "info", argv0_length ) == 0 ) )
745  {
746  for ( i = 0; i < matPtr->dim; i++ )
747  {
748  sprintf( tmp, "%d", matPtr->n[i] );
749  // Must avoid trailing space.
750  if ( i < matPtr->dim - 1 )
751  Tcl_AppendResult( interp, tmp, " ", (char *) NULL );
752  else
753  Tcl_AppendResult( interp, tmp, (char *) NULL );
754  }
755  return TCL_OK;
756  }
757 
758  // max
759 
760  else if ( ( c == 'm' ) && ( strncmp( argv[0], "max", argv0_length ) == 0 ) )
761  {
762  int len;
763  if ( argc < 1 || argc > 2 )
764  {
765  Tcl_AppendResult( interp, "wrong # args: should be \"",
766  name, " ", argv[0], " ?length?\"",
767  (char *) NULL );
768  return TCL_ERROR;
769  }
770 
771  if ( argc == 2 )
772  {
773  len = atoi( argv[1] );
774  if ( len < 0 || len > matPtr->len )
775  {
776  Tcl_AppendResult( interp, "specified length out of valid range",
777  (char *) NULL );
778  return TCL_ERROR;
779  }
780  }
781  else
782  len = matPtr->len;
783 
784  if ( len == 0 )
785  {
786  Tcl_AppendResult( interp, "attempt to find maximum of array with zero elements",
787  (char *) NULL );
788  return TCL_ERROR;
789  }
790 
791  switch ( matPtr->type )
792  {
793  case TYPE_FLOAT: {
794  Mat_float max = matPtr->fdata[0];
795  for ( i = 1; i < len; i++ )
796  max = MAX( max, matPtr->fdata[i] );
797  //sprintf(tmp, "%.17g", max);
798  Tcl_PrintDouble( interp, max, tmp );
799  Tcl_AppendResult( interp, tmp, (char *) NULL );
800  break;
801  }
802  case TYPE_INT: {
803  Mat_int max = matPtr->idata[0];
804  for ( i = 1; i < len; i++ )
805  max = MAX( max, matPtr->idata[i] );
806  sprintf( tmp, "%d", max );
807  Tcl_AppendResult( interp, tmp, (char *) NULL );
808  break;
809  }
810  }
811  return TCL_OK;
812  }
813 
814  // min
815 
816  else if ( ( c == 'm' ) && ( strncmp( argv[0], "min", argv0_length ) == 0 ) )
817  {
818  int len;
819  if ( argc < 1 || argc > 2 )
820  {
821  Tcl_AppendResult( interp, "wrong # args: should be \"",
822  name, " ", argv[0], " ?length?\"",
823  (char *) NULL );
824  return TCL_ERROR;
825  }
826 
827  if ( argc == 2 )
828  {
829  len = atoi( argv[1] );
830  if ( len < 0 || len > matPtr->len )
831  {
832  Tcl_AppendResult( interp, "specified length out of valid range",
833  (char *) NULL );
834  return TCL_ERROR;
835  }
836  }
837  else
838  len = matPtr->len;
839 
840  if ( len == 0 )
841  {
842  Tcl_AppendResult( interp, "attempt to find minimum of array with zero elements",
843  (char *) NULL );
844  return TCL_ERROR;
845  }
846 
847  switch ( matPtr->type )
848  {
849  case TYPE_FLOAT: {
850  Mat_float min = matPtr->fdata[0];
851  for ( i = 1; i < len; i++ )
852  min = MIN( min, matPtr->fdata[i] );
853  //sprintf(tmp, "%.17g", min);
854  Tcl_PrintDouble( interp, min, tmp );
855  Tcl_AppendResult( interp, tmp, (char *) NULL );
856  break;
857  }
858  case TYPE_INT: {
859  Mat_int min = matPtr->idata[0];
860  for ( i = 1; i < len; i++ )
861  min = MIN( min, matPtr->idata[i] );
862  sprintf( tmp, "%d", min );
863  Tcl_AppendResult( interp, tmp, (char *) NULL );
864  break;
865  }
866  }
867  return TCL_OK;
868  }
869 
870  // redim
871  // Only works on 1d matrices
872 
873  else if ( ( c == 'r' ) && ( strncmp( argv[0], "redim", argv0_length ) == 0 ) )
874  {
875  int newlen;
876  void *data;
877 
878  if ( argc != 2 )
879  {
880  Tcl_AppendResult( interp, "wrong # args: should be \"",
881  name, " ", argv[0], " length\"",
882  (char *) NULL );
883  return TCL_ERROR;
884  }
885 
886  if ( matPtr->dim != 1 )
887  {
888  Tcl_AppendResult( interp, "can only redim a 1d matrix",
889  (char *) NULL );
890  return TCL_ERROR;
891  }
892 
893  newlen = atoi( argv[1] );
894  switch ( matPtr->type )
895  {
896  case TYPE_FLOAT:
897  data = realloc( matPtr->fdata, (size_t) newlen * sizeof ( Mat_float ) );
898  if ( newlen != 0 && data == NULL )
899  {
900  Tcl_AppendResult( interp, "redim failed!",
901  (char *) NULL );
902  return TCL_ERROR;
903  }
904  matPtr->fdata = (Mat_float *) data;
905  for ( i = matPtr->len; i < newlen; i++ )
906  matPtr->fdata[i] = 0.0;
907  break;
908 
909  case TYPE_INT:
910  data = realloc( matPtr->idata, (size_t) newlen * sizeof ( Mat_int ) );
911  if ( newlen != 0 && data == NULL )
912  {
913  Tcl_AppendResult( interp, "redim failed!",
914  (char *) NULL );
915  return TCL_ERROR;
916  }
917  matPtr->idata = (Mat_int *) data;
918  for ( i = matPtr->len; i < newlen; i++ )
919  matPtr->idata[i] = 0;
920  break;
921  }
922  matPtr->n[0] = matPtr->len = newlen;
923  // For later use in matrix assigments
924  // N.B. matPtr->len could be large so this check for success might
925  // be more than pro forma.
926  data = realloc( matPtr->indices, (size_t) ( matPtr->len ) * sizeof ( int ) );
927  if ( newlen != 0 && data == NULL )
928  {
929  Tcl_AppendResult( interp, "redim failed!", (char *) NULL );
930  return TCL_ERROR;
931  }
932  matPtr->indices = (int *) data;
933  return TCL_OK;
934  }
935 
936  // scale
937  // Only works on 1d matrices
938 
939  else if ( ( c == 's' ) && ( strncmp( argv[0], "scale", argv0_length ) == 0 ) )
940  {
941  Mat_float scale;
942 
943  if ( argc != 2 )
944  {
945  Tcl_AppendResult( interp, "wrong # args: should be \"",
946  name, " ", argv[0], " scale-factor\"",
947  (char *) NULL );
948  return TCL_ERROR;
949  }
950 
951  if ( matPtr->dim != 1 )
952  {
953  Tcl_AppendResult( interp, "can only scale a 1d matrix",
954  (char *) NULL );
955  return TCL_ERROR;
956  }
957 
958  scale = atof( argv[1] );
959  switch ( matPtr->type )
960  {
961  case TYPE_FLOAT:
962  for ( i = 0; i < matPtr->len; i++ )
963  matPtr->fdata[i] *= scale;
964  break;
965 
966  case TYPE_INT:
967  for ( i = 0; i < matPtr->len; i++ )
968  matPtr->idata[i] = (Mat_int) ( (Mat_float) ( matPtr->idata[i] ) * scale );
969  break;
970  }
971  return TCL_OK;
972  }
973 
974  // Not a "standard" command, check the extension commands.
975 
976  {
978  for (; p; p = p->next )
979  {
980  if ( ( c == p->cmd[0] ) && ( strncmp( argv[0], p->cmd, argv0_length ) == 0 ) )
981  {
982 #ifdef DEBUG
983  fprintf( stderr, "found a match, invoking %s\n", p->cmd );
984 #endif
985  return ( *( p->cmdproc ) )( matPtr, interp, --argc, ++argv );
986  }
987  }
988  }
989 
990  // Must be a put or get of an array slice or array value.
991 
992  // Determine array index slice adopting the same rules as the Python case
993  // documented at <https://docs.python.org/3/library/stdtypes.html#common-sequence-operations>
994  // Also, for the case where just a _single_ ":" is used to represent the
995  // complete range of indices for a dimension, the
996  // notation "*" can be used as well for backwards compatibility
997  // with the limited slice capability that was available before
998  // this full slice capability was implemented.
999 
1000  if ( argc < matPtr->dim )
1001  {
1002  Tcl_AppendResult( interp, "not enough dimensions specified for \"",
1003  name, "\"", (char *) NULL );
1004  return TCL_ERROR;
1005  }
1006 
1007  for ( i = 0; i < matPtr->dim; i++ )
1008  {
1009  // Because of argc and argv initialization and logic at end of
1010  // loop which decrements argc and increments argv, argv[0]
1011  // walks through the space-separated command-line strings that
1012  // have been parsed by Tcl for each iteration of this loop.
1013  // N.B. argv[0] should point to valid memory (i.e., one of the
1014  // command-line strings) because of the above initial argc
1015  // check and loop limits.
1016  argv0_length = strlen( argv[0] );
1017  // According to Linux man page for sscanf, a straightforward interpretation of the C standard
1018  // indicates that %n should not be counted as a successful conversion when calculating
1019  // the sscanf return value, but that man page also says should not count on that in general.
1020  // So in the logic below use the ">= " test to allow for both possibilities.
1021 
1022  // Default values if not determined below.
1023  start[i] = 0;
1024  stop[i] = matPtr->n[i];
1025  step[i] = 1;
1026  change_default_start = 0;
1027  change_default_stop = 0;
1028  // i:j:k
1029  if ( sscanf( argv[0], "%d%1[:]%d%1[:]%d%n", start + i, c1, stop + i, c2, step + i, &char_converted ) >= 5 )
1030  {
1031  }
1032  // i:j:
1033  else if ( sscanf( argv[0], "%d%1[:]%d%1[:]%n", start + i, c1, stop + i, c2, &char_converted ) >= 4 )
1034  {
1035  }
1036  // i:j
1037  else if ( sscanf( argv[0], "%d%1[:]%d%n", start + i, c1, stop + i, &char_converted ) >= 3 )
1038  {
1039  }
1040  // i::k
1041  else if ( sscanf( argv[0], "%d%1[:]%1[:]%d%n", start + i, c1, c2, step + i, &char_converted ) >= 4 )
1042  {
1043  if ( step[i] < 0 )
1044  {
1045  change_default_stop = 1;
1046  }
1047  }
1048  // i::
1049  else if ( sscanf( argv[0], "%d%1[:]%1[:]%n", start + i, c1, c2, &char_converted ) >= 3 )
1050  {
1051  }
1052  // i:
1053  else if ( sscanf( argv[0], "%d%1[:]%n", start + i, c1, &char_converted ) >= 2 )
1054  {
1055  }
1056  // :j:k
1057  else if ( sscanf( argv[0], "%1[:]%d%1[:]%d%n", c1, stop + i, c2, step + i, &char_converted ) >= 4 )
1058  {
1059  if ( step[i] < 0 )
1060  {
1061  change_default_start = 1;
1062  }
1063  }
1064  // :j:
1065  else if ( sscanf( argv[0], "%1[:]%d%1[:]%n", c1, stop + i, c2, &char_converted ) >= 3 )
1066  {
1067  }
1068  // :j
1069  else if ( sscanf( argv[0], "%1[:]%d%n", c1, stop + i, &char_converted ) >= 2 )
1070  {
1071  }
1072  // ::k
1073  else if ( sscanf( argv[0], "%1[:]%1[:]%d%n", c1, c2, step + i, &char_converted ) >= 3 )
1074  {
1075  if ( step[i] < 0 )
1076  {
1077  change_default_start = 1;
1078  change_default_stop = 1;
1079  }
1080  }
1081  // ::
1082  else if ( strcmp( argv[0], "::" ) == 0 )
1083  char_converted = 2;
1084  // :
1085  else if ( strcmp( argv[0], ":" ) == 0 )
1086  char_converted = 1;
1087  // *
1088  else if ( strcmp( argv[0], "*" ) == 0 )
1089  char_converted = 1;
1090  // i
1091  else if ( sscanf( argv[0], "%d%n", start + i, &char_converted ) >= 1 )
1092  {
1093  // Special checks for the pure index case (just like in Python).
1094  if ( start[i] < 0 )
1095  start[i] += matPtr->n[i];
1096  if ( start[i] < 0 || start[i] > matPtr->n[i] - 1 )
1097  {
1098  sprintf( tmp, "Array index %d out of bounds: original string = \"%s\"; transformed = %d; min = 0; max = %d\n",
1099  i, argv[0], start[i], matPtr->n[i] - 1 );
1100  Tcl_AppendResult( interp, tmp, (char *) NULL );
1101  return TCL_ERROR;
1102  }
1103  stop[i] = start[i] + 1;
1104  }
1105  else
1106  {
1107  sprintf( tmp, "Array slice for index %d with original string = \"%s\" could not be parsed\n",
1108  i, argv[0] );
1109  Tcl_AppendResult( interp, tmp, (char *) NULL );
1110  return TCL_ERROR;
1111  }
1112 
1113  // Check, convert and sanitize start[i], stop[i], and step[i] values.
1114  if ( step[i] == 0 )
1115  {
1116  Tcl_AppendResult( interp, "step part of slice must be non-zero",
1117  (char *) NULL );
1118  return TCL_ERROR;
1119  }
1120  sign_step[i] = ( step[i] > 0 ) ? 1 : -1;
1121  if ( (size_t) char_converted > argv0_length )
1122  {
1123  Tcl_AppendResult( interp, "MatrixCmd, internal logic error",
1124  (char *) NULL );
1125  return TCL_ERROR;
1126  }
1127  if ( (size_t) char_converted < argv0_length )
1128  {
1129  sprintf( tmp, "Array slice for index %d with original string = \"%s\" "
1130  "had trailing unparsed characters\n", i, argv[0] );
1131  Tcl_AppendResult( interp, tmp, (char *) NULL );
1132  return TCL_ERROR;
1133  }
1134  if ( start[i] < 0 )
1135  start[i] += matPtr->n[i];
1136  start[i] = MAX( 0, MIN( matPtr->n[i] - 1, start[i] ) );
1137  if ( change_default_start )
1138  start[i] = matPtr->n[i] - 1;
1139  if ( stop[i] < 0 )
1140  stop[i] += matPtr->n[i];
1141  if ( step[i] > 0 )
1142  stop[i] = MAX( 0, MIN( matPtr->n[i], stop[i] ) );
1143  else
1144  stop[i] = MAX( -1, MIN( matPtr->n[i], stop[i] ) );
1145  if ( change_default_stop )
1146  stop[i] = -1;
1147 
1148  // At this stage, start, stop, and step (!=0), correspond to
1149  // i, j, and k (!=0) in the slice documentation given at
1150  // <https://docs.python.org/3/library/stdtypes.html#common-sequence-operations>.
1151  // with all checks and conversions made. According to note 5
1152  // of that documentation (translated to the present start,
1153  // stop and step notation and also subject to the clarifying
1154  // discussion in <http://bugs.python.org/issue28614>) the
1155  // array index should take on the values
1156  // index = start + n*step
1157  // where n 0, 1, etc., with that sequence
1158  // terminated just before index = stop is reached.
1159  // Therefore, the for loop for a typical index when step is positive should read
1160  // for ( i = start[0]; i < stop[0]; i += step[0] )
1161  // and when step is negative should read
1162  // for ( i = start[0]; i > stop[0]; i += step[0] )
1163  // So to cover both cases, we use for loops of the
1164  // following form below
1165  // for ( i = start[0]; sign_step[0]*i < stop[0]; i += step[0] )
1166  // where stop has been transformed as follows:
1167 #ifdef DEBUG
1168  fprintf( stderr, "Array slice for index %d with original string = \"%s\" "
1169  "yielded start[i], stop[i], transformed stop[i], and step[i] = "
1170  "%d, %d, ", i, argv[0], start[i], stop[i] );
1171 #endif
1172  stop[i] = sign_step[i] * stop[i];
1173 #ifdef DEBUG
1174  fprintf( stderr, "%d, %d\n", stop[i], step[i] );
1175 #endif
1176  argc--; argv++;
1177  }
1178 
1179  // If there is an "=" after indices, it's a put. Do error checking.
1180 
1181  if ( argc > 0 )
1182  {
1183  put = 1;
1184  if ( strcmp( argv[0], "=" ) == 0 )
1185  {
1186  argc--; argv++;
1187  if ( argc == 0 )
1188  {
1189  Tcl_AppendResult( interp, "no value specified",
1190  (char *) NULL );
1191  return TCL_ERROR;
1192  }
1193  }
1194  else
1195  {
1196  Tcl_AppendResult( interp, "extra characters after indices: \"",
1197  argv[0], "\"", (char *) NULL );
1198  return TCL_ERROR;
1199  }
1200  }
1201 
1202  // Calculate which indices will be used for the given index slices.
1203  matPtr->nindices = 0;
1204 
1205  for ( i = start[0]; sign_step[0] * i < stop[0]; i += step[0] )
1206  {
1207  for ( j = start[1]; sign_step[1] * j < stop[1]; j += step[1] )
1208  {
1209  for ( k = start[2]; sign_step[2] * k < stop[2]; k += step[2] )
1210  {
1211  matPtr->indices[matPtr->nindices++] = I3D( i, j, k );
1212  }
1213  }
1214  }
1215 
1216  // Do the get/put.
1217  // The loop over all elements takes care of the multi-element cases.
1218  if ( put )
1219  {
1220  char *endptr;
1221  // Check whether argv[0] could be interpreted as a raw single
1222  // number with no trailing characters.
1223  switch ( matPtr->type )
1224  {
1225  case TYPE_FLOAT:
1226  strtod( argv[0], &endptr );
1227  break;
1228  case TYPE_INT:
1229  strtol( argv[0], &endptr, 10 );
1230  break;
1231  }
1232  if ( argc == 1 && *argv[0] != '\0' && *endptr == '\0' )
1233  {
1234  // If _all_ characters of single RHS string can be
1235  // successfully read as a single number, then assign all
1236  // matrix elements with indices in matPtr->indices to that
1237  // single number.
1238  for ( i = 0; i < matPtr->nindices; i++ )
1239  ( *matPtr->put )( (ClientData) matPtr, interp, matPtr->indices[i], argv[0] );
1240  }
1241  else
1242  {
1243  // If RHS cannot be successfully read as a single number,
1244  // then assume it is a collection of numbers (in list form
1245  // or white-space separated). Concatenate all remaining
1246  // elements of argv into list form, then use MatrixAssign
1247  // to assign all matrix elements with indices in
1248  // matPtr->indices using all (deep) non-list elements of
1249  // that list.
1250  int offset = 0;
1251  size_t concatenated_argv_len;
1252  char *concatenated_argv;
1253  const char *const_concatenated_argv;
1254 
1255  // Prepare concatenated_argv string consisting of
1256  // "{argv[0] argv[1] ... argv[argc-1]}" so that _any_
1257  // space-separated bunch of numerical arguments or lists
1258  // of those will work. Account for beginning and ending
1259  // curly braces and trailing \0.
1260  concatenated_argv_len = 3;
1261  for ( i = 0; i < argc; i++ )
1262  // Account for length of string + space separator.
1263  concatenated_argv_len += strlen( argv[i] ) + 1;
1264  concatenated_argv = (char *) malloc( concatenated_argv_len * sizeof ( char ) );
1265 
1266  // Prepare for string concatenation using strcat
1267  concatenated_argv[0] = '\0';
1268  strcat( concatenated_argv, "{" );
1269  for ( i = 0; i < argc; i++ )
1270  {
1271  strcat( concatenated_argv, argv[i] );
1272  strcat( concatenated_argv, " " );
1273  }
1274  strcat( concatenated_argv, "}" );
1275 
1276  const_concatenated_argv = (const char *) concatenated_argv;
1277 
1278  // Assign matrix elements using all numbers collected from
1279  // the potentially deep list, const_concatenated_argv.
1280  if ( MatrixAssign( interp, matPtr, 0, &offset, 1, &const_concatenated_argv ) != TCL_OK )
1281  {
1282  free( (void *) concatenated_argv );
1283  return TCL_ERROR;
1284  }
1285  free( (void *) concatenated_argv );
1286  }
1287  }
1288  else
1289  {
1290  // get
1291  for ( i = 0; i < matPtr->nindices; i++ )
1292  {
1293  ( *matPtr->get )( (ClientData) matPtr, interp, matPtr->indices[i], tmp );
1294  if ( i < matPtr->nindices - 1 )
1295  Tcl_AppendResult( interp, tmp, " ", (char *) NULL );
1296  else
1297  Tcl_AppendResult( interp, tmp, (char *) NULL );
1298  }
1299  }
1300 
1301  return TCL_OK;
1302 }
1303 
1304 //--------------------------------------------------------------------------
1305 //
1306 // Routines to handle Matrix get/put dependent on type:
1307 //
1308 // MatrixPut_f MatrixGet_f
1309 // MatrixPut_i MatrixGet_i
1310 //
1311 // A "put" converts from string format to the intrinsic type, storing into
1312 // the array.
1313 //
1314 // A "get" converts from the intrinsic type to string format, storing into
1315 // a string buffer.
1316 //
1317 //--------------------------------------------------------------------------
1318 
1319 static void
1320 MatrixPut_f( ClientData clientData, Tcl_Interp* PL_UNUSED( interp ), int index, const char *string )
1321 {
1322  tclMatrix *matPtr = (tclMatrix *) clientData;
1323 
1324  matPtr->fdata[index] = atof( string );
1325 }
1326 
1327 static void
1328 MatrixGet_f( ClientData clientData, Tcl_Interp* interp, int index, char *string )
1329 {
1330  tclMatrix *matPtr = (tclMatrix *) clientData;
1331  double value = matPtr->fdata[index];
1332 
1333  //sprintf(string, "%.17g", value);
1334  Tcl_PrintDouble( interp, value, string );
1335 }
1336 
1337 static void
1338 MatrixPut_i( ClientData clientData, Tcl_Interp* PL_UNUSED( interp ), int index, const char *string )
1339 {
1340  tclMatrix *matPtr = (tclMatrix *) clientData;
1341 
1342  if ( ( strlen( string ) > 2 ) && ( strncmp( string, "0x", 2 ) == 0 ) )
1343  {
1344  matPtr->idata[index] = (Mat_int) strtoul( &string[2], NULL, 16 );
1345  }
1346  else
1347  matPtr->idata[index] = atoi( string );
1348 }
1349 
1350 static void
1351 MatrixGet_i( ClientData clientData, Tcl_Interp* PL_UNUSED( interp ), int index, char *string )
1352 {
1353  tclMatrix *matPtr = (tclMatrix *) clientData;
1354 
1355  sprintf( string, "%d", matPtr->idata[index] );
1356 }
1357 
1358 //--------------------------------------------------------------------------
1359 //
1360 // DeleteMatrixVar --
1361 //
1362 // Causes matrix command to be deleted. Invoked when variable
1363 // associated with matrix command is unset.
1364 //
1365 // Results:
1366 // None.
1367 //
1368 // Side effects:
1369 // See DeleteMatrixCmd.
1370 //
1371 //--------------------------------------------------------------------------
1372 
1373 static char *
1374 DeleteMatrixVar( ClientData clientData,
1375  Tcl_Interp * PL_UNUSED( interp ), char * PL_UNUSED( name1 ), char * PL_UNUSED( name2 ), int PL_UNUSED( flags ) )
1376 {
1377  tclMatrix *matPtr = (tclMatrix *) clientData;
1378  Tcl_CmdInfo infoPtr;
1379  char *name;
1380 
1381  dbug_enter( "DeleteMatrixVar" );
1382 
1383  if ( matPtr->tracing != 0 )
1384  {
1385  matPtr->tracing = 0;
1386  name = (char *) malloc( strlen( matPtr->name ) + 1 );
1387  strcpy( name, matPtr->name );
1388 
1389 #ifdef DEBUG
1390  if ( Tcl_GetCommandInfo( matPtr->interp, matPtr->name, &infoPtr ) )
1391  {
1392  if ( Tcl_DeleteCommand( matPtr->interp, matPtr->name ) == TCL_OK )
1393  fprintf( stderr, "Deleted command %s\n", name );
1394  else
1395  fprintf( stderr, "Unable to delete command %s\n", name );
1396  }
1397 #else
1398  if ( Tcl_GetCommandInfo( matPtr->interp, matPtr->name, &infoPtr ) )
1399  Tcl_DeleteCommand( matPtr->interp, matPtr->name );
1400 #endif
1401  free( (void *) name );
1402  }
1403  return (char *) NULL;
1404 }
1405 
1406 //--------------------------------------------------------------------------
1407 //
1408 // DeleteMatrixCmd --
1409 //
1410 // Releases all the resources allocated to the matrix command.
1411 // Invoked just before a matrix command is removed from an interpreter.
1412 //
1413 // Note: If the matrix has tracing enabled, it means the user
1414 // explicitly deleted a non-persistent matrix. Not a good idea,
1415 // because eventually the local variable that was being traced will
1416 // become unset and the matrix data will be referenced in
1417 // DeleteMatrixVar. So I've massaged this so that at worst it only
1418 // causes a minor memory leak instead of imminent program death.
1419 //
1420 // Results:
1421 // None.
1422 //
1423 // Side effects:
1424 // All memory associated with the matrix operator is freed (usually).
1425 //
1426 //--------------------------------------------------------------------------
1427 
1428 static void
1429 DeleteMatrixCmd( ClientData clientData )
1430 {
1431  tclMatrix *matPtr = (tclMatrix *) clientData;
1432  Tcl_HashEntry *hPtr;
1433 
1434  dbug_enter( "DeleteMatrixCmd" );
1435 
1436 #ifdef DEBUG
1437  fprintf( stderr, "Freeing space associated with matrix %s\n", matPtr->name );
1438 #endif
1439 
1440  // Remove hash table entry
1441 
1442  hPtr = Tcl_FindHashEntry( &matTable, matPtr->name );
1443  if ( hPtr != NULL )
1444  Tcl_DeleteHashEntry( hPtr );
1445 
1446  // Free data
1447 
1448  if ( matPtr->fdata != NULL )
1449  {
1450  free( (void *) matPtr->fdata );
1451  matPtr->fdata = NULL;
1452  }
1453  if ( matPtr->idata != NULL )
1454  {
1455  free( (void *) matPtr->idata );
1456  matPtr->idata = NULL;
1457  }
1458  if ( matPtr->indices != NULL )
1459  {
1460  free( (void *) matPtr->indices );
1461  matPtr->indices = NULL;
1462  }
1463 
1464  // Attempt to turn off tracing if possible.
1465 
1466  if ( matPtr->tracing )
1467  {
1468  if ( Tcl_VarTraceInfo( matPtr->interp, matPtr->name, TCL_TRACE_UNSETS,
1469  (Tcl_VarTraceProc *) DeleteMatrixVar, NULL ) != NULL )
1470  {
1471  matPtr->tracing = 0;
1472  Tcl_UntraceVar( matPtr->interp, matPtr->name, TCL_TRACE_UNSETS,
1473  (Tcl_VarTraceProc *) DeleteMatrixVar, (ClientData) matPtr );
1474  Tcl_UnsetVar( matPtr->interp, matPtr->name, 0 );
1475  }
1476  }
1477 
1478  // Free name.
1479 
1480  if ( matPtr->name != NULL )
1481  {
1482  free( (void *) matPtr->name );
1483  matPtr->name = NULL;
1484  }
1485 
1486  // Free tclMatrix
1487 
1488  if ( !matPtr->tracing )
1489  free( (void *) matPtr );
1490 #ifdef DEBUG
1491  else
1492  fprintf( stderr, "OOPS! You just lost %d bytes\n", sizeof ( tclMatrix ) );
1493 #endif
1494 }
int Mat_int
Definition: tclMatrix.h:43
struct tclMatrixXtnsnDescr * next
Definition: tclMatrix.h:363
static const char * name
Definition: tkMain.c:135
static char ** argv
Definition: qt.cpp:40
int(* tclMatrixXtnsnProc)(tclMatrix *pm, Tcl_Interp *interp, int argc, const char *argv[])
Definition: tclMatrix.h:356
int Tcl_MatrixInstallXtnsn(const char *cmd, tclMatrixXtnsnProc proc)
Definition: tclMatrix.c:464
int min(int a, int b)
int n[MAX_ARRAY_DIM]
Definition: tclMatrix.h:71
int * indices
Definition: tclMatrix.h:91
int dim
Definition: tclMatrix.h:70
int tracing
Definition: tclMatrix.h:72
tclMatrix * Tcl_GetMatrixPtr(Tcl_Interp *interp, const char *matName)
Definition: tclMatrix.c:424
static int argc
Definition: qt.cpp:39
#define MAX(a, b)
Definition: tclMatrix.c:46
int nindices
Definition: tclMatrix.h:87
void(* put)(ClientData clientData, Tcl_Interp *interp, int index, const char *string)
Definition: tclMatrix.h:83
static void MatrixGet_i(ClientData clientData, Tcl_Interp *interp, int index, char *string)
void(* get)(ClientData clientData, Tcl_Interp *interp, int index, char *string)
Definition: tclMatrix.h:84
int Tcl_MatrixCmd(ClientData PL_UNUSED(clientData), Tcl_Interp *interp, int argc, const char **argv)
Definition: tclMatrix.c:122
static tclMatrixXtnsnDescr * head
Definition: tclMatrix.c:460
static void MatrixGet_f(ClientData clientData, Tcl_Interp *interp, int index, char *string)
Definition: tclMatrix.c:1328
Mat_float * fdata
Definition: tclMatrix.h:76
#define dbug_enter(a)
Definition: tclMatrix.c:59
Tcl_Interp * interp
Definition: tclMatrix.h:79
char * name
Definition: tclMatrix.h:74
Mat_int * idata
Definition: tclMatrix.h:77
#define MAX_ARRAY_DIM
Definition: tclMatrix.h:52
static int MatrixCmd(ClientData clientData, Tcl_Interp *interp, int argc, const char **argv)
Definition: tclMatrix.c:591
static char * DeleteMatrixVar(ClientData clientData, Tcl_Interp *interp, char *name1, char *name2, int flags)
static int matTable_initted
Definition: tclMatrix.c:64
int type
Definition: tclMatrix.h:64
static PLFLT value(double n1, double n2, double hue)
Definition: plctrl.c:1209
int max(int a, int b)
static int MatrixAssign(Tcl_Interp *interp, tclMatrix *m, int level, int *offset, int nargs, const char **args)
Definition: tclMatrix.c:510
#define PL_UNUSED(x)
Definition: plplot.h:128
#define I3D(i, j, k)
Definition: tclMatrix.h:56
static tclMatrixXtnsnDescr * tail
Definition: tclMatrix.c:461
static void DeleteMatrixCmd(ClientData clientData)
Definition: tclMatrix.c:1429
static Tcl_HashTable matTable
Definition: tclMatrix.c:65
static Tcl_Interp * interp
Definition: tkMain.c:120
#define MIN(a, b)
Definition: tclMatrix.c:49
PLFLT Mat_float
Definition: tclMatrix.h:38
static void MatrixPut_f(ClientData clientData, Tcl_Interp *interp, int index, const char *string)
static void MatrixPut_i(ClientData clientData, Tcl_Interp *interp, int index, const char *string)
int len
Definition: tclMatrix.h:69
tclMatrixXtnsnProc cmdproc
Definition: tclMatrix.h:362