PLplot 5.15.0
Loading...
Searching...
No Matches
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
64static int matTable_initted = 0; // Hash table initialization flag
65static Tcl_HashTable matTable; // Hash table for external access to data
66
67// Function prototypes
68
69// Handles matrix initialization lists
70
71static int
72MatrixAssign( 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
77static int
78MatrixCmd( ClientData clientData, Tcl_Interp *interp, int argc, const char **argv );
79
80// Causes matrix command to be deleted.
81
82static char *
83DeleteMatrixVar( ClientData clientData,
84 Tcl_Interp *interp, char *name1, char *name2, int flags );
85
86// Releases all the resources allocated to the matrix command.
87
88static void
89DeleteMatrixCmd( ClientData clientData );
90
91// These do the put/get operations for each supported type
92
93static void
94MatrixPut_f( ClientData clientData, Tcl_Interp* interp, int index, const char *string );
95
96static void
97MatrixGet_f( ClientData clientData, Tcl_Interp* interp, int index, char *string );
98
99static void
100MatrixPut_i( ClientData clientData, Tcl_Interp* interp, int index, const char *string );
101
102static void
103MatrixGet_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
121int
122Tcl_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 {
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
423tclMatrix *
424Tcl_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
463int
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
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
510static 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
590static int
591MatrixCmd( 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\
723dump - return the values in the matrix as a string\n\
724delete - delete the matrix (including the matrix command)\n\
725filter - apply a three-point averaging (with a number of passes; ome-dimensional only)\n\
726help - this information\n\
727info - return the dimensions\n\
728max - return the maximum value for the entire matrix or for the first N entries\n\
729min - return the minimum value for the entire matrix or for the first N entries\n\
730redim - resize the matrix (for one-dimensional matrices only)\n\
731scale - scale the values by a given factor (for one-dimensional matrices only)\n\
732\n\
733Set and get values:\n\
734matrix m f 3 3 3 - define matrix command \"m\", three-dimensional, floating-point data\n\
735m 1 2 3 - return the value of matrix element [1,2,3]\n\
736m 1 2 3 = 2.0 - set the value of matrix element [1,2,3] to 2.0 (do not return the value)\n\
737m * 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
1319static void
1320MatrixPut_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
1327static void
1328MatrixGet_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
1337static void
1338MatrixPut_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
1350static void
1351MatrixGet_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
1373static char *
1374DeleteMatrixVar( 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
1428static void
1429DeleteMatrixCmd( 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}
#define min(x, y)
Definition nnpi.c:87
#define max(x, y)
Definition nnpi.c:88
static PLFLT value(double n1, double n2, double hue)
Definition plctrl.c:1219
#define PL_UNUSED(x)
Definition plplot.h:138
static int argc
Definition qt.cpp:48
static char ** argv
Definition qt.cpp:49
struct tclMatrixXtnsnDescr * next
Definition tclMatrix.h:363
tclMatrixXtnsnProc cmdproc
Definition tclMatrix.h:362
int Tcl_MatrixCmd(ClientData PL_UNUSED(clientData), Tcl_Interp *interp, int argc, const char **argv)
Definition tclMatrix.c:122
tclMatrix * Tcl_GetMatrixPtr(Tcl_Interp *interp, const char *matName)
Definition tclMatrix.c:424
static int matTable_initted
Definition tclMatrix.c:64
#define MIN(a, b)
Definition tclMatrix.c:49
static void MatrixGet_f(ClientData clientData, Tcl_Interp *interp, int index, char *string)
Definition tclMatrix.c:1328
static void MatrixPut_f(ClientData clientData, Tcl_Interp *interp, int index, const char *string)
#define dbug_enter(a)
Definition tclMatrix.c:59
static int MatrixCmd(ClientData clientData, Tcl_Interp *interp, int argc, const char **argv)
Definition tclMatrix.c:591
static void DeleteMatrixCmd(ClientData clientData)
Definition tclMatrix.c:1429
static void MatrixPut_i(ClientData clientData, Tcl_Interp *interp, int index, const char *string)
static Tcl_HashTable matTable
Definition tclMatrix.c:65
static char * DeleteMatrixVar(ClientData clientData, Tcl_Interp *interp, char *name1, char *name2, int flags)
int Tcl_MatrixInstallXtnsn(const char *cmd, tclMatrixXtnsnProc proc)
Definition tclMatrix.c:464
static int MatrixAssign(Tcl_Interp *interp, tclMatrix *m, int level, int *offset, int nargs, const char **args)
Definition tclMatrix.c:510
static void MatrixGet_i(ClientData clientData, Tcl_Interp *interp, int index, char *string)
static tclMatrixXtnsnDescr * tail
Definition tclMatrix.c:461
static tclMatrixXtnsnDescr * head
Definition tclMatrix.c:460
#define MAX(a, b)
Definition tclMatrix.c:46
@ TYPE_FLOAT
Definition tclMatrix.h:46
@ TYPE_INT
Definition tclMatrix.h:46
#define I3D(i, j, k)
Definition tclMatrix.h:56
int Mat_int
Definition tclMatrix.h:43
PLFLT Mat_float
Definition tclMatrix.h:38
int(* tclMatrixXtnsnProc)(tclMatrix *pm, Tcl_Interp *interp, int argc, const char *argv[])
Definition tclMatrix.h:356
#define MAX_ARRAY_DIM
Definition tclMatrix.h:52
static Tcl_Interp * interp
Definition tkMain.c:120
static const char * name
Definition tkMain.c:135