Context Navigation

datatype.cpp @ 2b19912

1941-docker-image-to-testdevel

Last change on this file since 2b19912 was e58c684, checked in by Liván Ramírez Dorta <livanr68@…>, 18 years ago

changes from CVS not merged previously

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

Property mode set to 100644

File size: 27.2 KB

Line
1	/* datatype.cpp: This file implements an interface between objects in tol
2	and "objects" in Visual Basic
3	This file define a set of utils functions.
4	GNU/VBTol Library
5
6	Copyright (C) 2001, 2002, 2003 - Bayes Decisión, SL
7
8	This program is free software; you can redistribute it and/or modify
9	it under the terms of the GNU General Public License as published by
10	the Free Software Foundation; either version 2, or (at your option)
11	any later version.
12
13	This program is distributed in the hope that it will be useful,
14	but WITHOUT ANY WARRANTY; without even the implied warranty of
15	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16	GNU General Public License for more details.
17
18	You should have received a copy of the GNU General Public License
19	along with this program; if not, write to the Free Software
20	Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
21	USA.
22	*/
23
24	#include <config.h>
25	#include <tol_init.h>
26	#include <tol_bgrammar.h>
27	#include <tol/tol_bdat.h>
28	#include <tol/tol_bdatgra.h>
29	#include <tol/tol_blanguag.h>
30	#include <tol/tol_btxtgra.h>
31	#include <tol/tol_bmatgra.h>
32
33	#include "VButils.h"
34
35	/*
36	* Obtains the value of an object TOL of type Text
37	*
38	* lvalue - Name of the object TOL
39	* retvalue - Variable where the value of the object will be returned
40	*
41	* returns 1 if the object was found and its value returned, otherwise 0
42	*/
43	//---------------------------------------------------------------------------
44	short __declspec(dllexport) CALLBACK TolGetText(BSTR lvalue, BSTR * retvalue)
45	//---------------------------------------------------------------------------
46	{
47	LPSTR str_lvalue = (LPSTR)lvalue;
48	short ret = 0;
49
50	BSyntaxObject * so = GraText()->EvaluateExpr(str_lvalue);
51	if (so) {
52	BText & d = Text(so);
53	char * st = (char *)(d.String());
54	SysFreeString(*retvalue);
55	*retvalue = SysAllocStringByteLen(st, strlen(st));
56	DESTROY(so);
57	ret = 1;
58	}
59	return ret;
60	}
61
62	/*
63	* Creates an object TOL of type Text
64	*
65	* name - Name of the object TOL
66	* value - Value of the object
67	*
68	* returns 1 if the object was created, otherwise returns 0
69	*/
70	//---------------------------------------------------------------------------
71	short __declspec(dllexport) CALLBACK TolCreateText(BSTR name, BSTR value)
72	//---------------------------------------------------------------------------
73	{
74	LPSTR str_name = (LPSTR)name;
75	LPSTR str_value = (LPSTR)value;
76	short ret = 0;
77
78	BSyntaxObject * so = new BContensText(str_name, str_value, "");
79	if (so) {
80	BList* result = NIL;
81	BList* aux = NIL;
82	LstFastAppend(result, aux, so);
83	VB_concat(&VB_stack, result);
84	ret = 1;
85	}
86	return ret;
87	}
88
89	//---------------------------------------------------------------------------
90
91	#define Known 0
92	#define Unknown 1
93	#define Pos_Inf 2
94	#define Neg_Inf 3
95
96	// Structure for the Real Tol object.
97	struct stolreal
98	{
99	short kind; // support for special values
100	double value;
101	};
102
103	/*
104	* Obtains the value of an object TOL of type Real
105	*
106	* lvalue - Name of the object TOL
107	* retvalue - Variable where the value of the object will be returned
108	*
109	* returns 1 if the object was found and its value returned, otherwise 0
110	*/
111	//---------------------------------------------------------------------------
112	short __declspec(dllexport) CALLBACK TolGetReal(BSTR lvalue, stolreal * retvalue)
113	//---------------------------------------------------------------------------
114	{
115	LPSTR str_lvalue = (LPSTR)lvalue;
116	short ret = 0;
117
118	BSyntaxObject * so = GraReal()->EvaluateExpr(str_lvalue);
119	if (so) {
120	BDat & d = Dat(so);
121	retvalue->value = d.Value();
122	if (d.IsKnown()) {
123	if (d.IsFinite())
124	retvalue->kind = Known;
125	else
126	if (d.IsPosInf())
127	retvalue->kind = Pos_Inf;
128	else
129	retvalue->kind = Neg_Inf;
130	}
131	else
132	retvalue->kind = Unknown;
133	DESTROY(so);
134	ret = 1;
135	}
136	return ret;
137	}
138
139	/*
140	* Creates an object TOL of type Real
141	*
142	* name - Name of the object TOL
143	* value - Value of the object
144	*
145	* returns 1 if the object was created, otherwise returns 0
146	*/
147	//---------------------------------------------------------------------------
148	short __declspec(dllexport) CALLBACK TolCreateReal(BSTR name, stolreal * value)
149	//---------------------------------------------------------------------------
150	{
151	LPSTR str_name = (LPSTR)name;
152	short ret = 0;
153	BDat d;
154
155	if (value->kind==Known)
156	d.PutValue(value->value);
157	else
158	if (value->kind==Unknown)
159	d.PutKnown(BUNKNOWN);
160	else
161	if (value->kind==Pos_Inf)
162	d.PutValue(BDat::PosInf());
163	else
164	if (value->kind==Neg_Inf)
165	d.PutValue(BDat::NegInf());
166	else
167	return 0;
168	BSyntaxObject * so = new BContensDat(str_name, d, "");
169	if (so) {
170	BList* result = NIL;
171	BList* aux = NIL;
172	LstFastAppend(result, aux, so);
173	VB_concat(&VB_stack, result);
174	ret = 1;
175	}
176	return ret;
177	}
178
179	//---------------------------------------------------------------------------
180
181	// Structure of the masks cells with special values
182	struct smaskcell
183	{
184	long r, c; // index row and column
185	short kind; // special value
186	};
187
188	// List of cells of the mask
189	struct listcell
190	{
191	smaskcell cell;
192	listcell * next;
193	};
194
195	/*
196	* Gets the value of a range of an object TOL of type Matrix
197	*
198	* See functions TolGetRange, TolGetMatrix, TolGetRow,
199	* TolGetColumn and TolGetCell below
200	*/
201	//---------------------------------------------------------------------------
202	short GetMatrixRange(BSTR lvalue,
203	long frow, long lrow,
204	long fcol, long lcol,
205	LPSAFEARRAY FAR * retvalue,
206	LPSAFEARRAY FAR * retmask)
207	//---------------------------------------------------------------------------
208	{
209	LPSTR str_lvalue = (LPSTR)lvalue;
210	short ret = 0;
211
212	if (!retmask \|\| !(*retmask)) // check parameter retmask
213	return -1;
214	if ((*retmask)->cDims != 1)
215	return -1;
216	if ((*retmask)->cbElements != sizeof(smaskcell))
217	return -1;
218	if (!((*retmask)->rgsabound))
219	return -1;
220	unsigned short fFeatures = (*retmask)->fFeatures;
221	if (fFeatures & FADF_STATIC \|\| fFeatures & FADF_FIXEDSIZE) // not sized with BasicŽs ReDim
222	return -1;
223
224	if (SafeArrayDestroy(*retvalue)) // Free previous array
225	return -1;
226	*retvalue = NULL;
227	// Get Tol Object
228	BSyntaxObject * so = GraMatrix()->EvaluateExpr(str_lvalue);
229	if (so) {
230	BMat & m = Mat(so); // Tol Matrix
231	BInt cols = m.Columns();
232	BInt rows = m.Rows();
233
234	if (lrow>rows \|\| lcol>cols) { // check the validity of the range
235	DESTROY(so);
236	return 0;
237	}
238	if (!frow) // update values of the range without definition
239	frow = 1;
240	if (!fcol)
241	fcol = 1;
242	if (!lrow)
243	lrow = rows;
244	if (!lcol)
245	lcol = cols;
246	SAFEARRAYBOUND aDims[2];
247	// Create a new 2-D array of Doubles
248	// Equivalent to: Dim retvalue(1 To rows, 1 To cols) As Double
249	aDims[0].lLbound = 1;
250	aDims[0].cElements = lrow-frow+1;
251	aDims[1].lLbound = 1;
252	aDims[1].cElements = lcol-fcol+1;
253	*retvalue = SafeArrayCreate(VT_R8, 2, aDims);
254	if (*retvalue==NULL) { // ERROR_NOT_ENOUGH_MEMORY
255	DESTROY(so);
256	return -1;
257	}
258	// Get values
259	// Modify 2-D array with SafeArrayPtrOfIndex, SafeArrayLock and SafeArrayUnlock
260	long ai[2];
261	double iVal;
262	double * pInOut = NIL;
263	HRESULT hres_SafeArrayLock,
264	hres_SafeArrayUnlock,
265	hres_SafeArrayPtrOfIndex;
266	long cells = 0;
267	listcell * fcell = NULL, * pcell;
268
269	hres_SafeArrayLock = SafeArrayLock(*retvalue);
270	assert(!hres_SafeArrayLock);
271	for (int r=1; r<=lrow-frow+1; ++r) {
272	ai[0] = r;
273	for (int c=1; c<=lcol-fcol+1; ++c) {
274	ai[1] = c;
275	BDat & d = m(frow+r-2, fcol+c-2);
276	iVal = d.Value();
277	hres_SafeArrayPtrOfIndex = SafeArrayPtrOfIndex(retvalue, ai, (void *)&pInOut);
278	assert (!hres_SafeArrayPtrOfIndex);
279	*pInOut = iVal;
280	if (d.IsUnknown() \|\| !d.IsFinite()) {
281	++cells;
282	pcell = new listcell;
283	pcell->cell.c = c;
284	pcell->cell.r = r;
285	pcell->cell.kind = d.IsUnknown() ? Unknown :
286	d.IsPosInf() ? Pos_Inf : Neg_Inf;
287	pcell->next = fcell;
288	fcell = pcell;
289	}
290	}
291	}
292	hres_SafeArrayUnlock = SafeArrayUnlock(*retvalue);
293	assert(!hres_SafeArrayUnlock);
294	// Redim a 1-D array of MaskCell
295	SAFEARRAYBOUND maskaDims;
296	maskaDims.lLbound = 1;
297	maskaDims.cElements = cells;
298	HRESULT hres_SafeArrayRedim;
299	hres_SafeArrayRedim = SafeArrayRedim(*retmask, &maskaDims);
300	if (hres_SafeArrayRedim) {
301	DESTROY(so);
302	while (pcell = fcell) {
303	fcell = fcell->next;
304	delete pcell;
305	}
306	return -1;
307	}
308	// Get mask for special values
309	if (retmask && *retmask && cells) {
310	hres_SafeArrayLock = SafeArrayLock(*retmask);
311	assert(!hres_SafeArrayLock);
312	smaskcell * maskpInOut = (smaskcell )((retmask)->pvData);
313	for (int i=0; i<cells; ++i) {
314	maskpInOut[i] = fcell->cell;
315	pcell = fcell;
316	fcell = fcell->next;
317	delete pcell;
318	}
319	hres_SafeArrayUnlock = SafeArrayUnlock(*retmask);
320	assert(!hres_SafeArrayUnlock);
321	}
322
323	DESTROY(so);
324	ret = 1;
325	}
326	return ret;
327	}
328
329	/*
330	* Gets the value of a range of an object TOL of type Matrix
331	*
332	* lvalue - Name of the object TOL
333	* retvalue - Variable where the values of the range will be returned
334	* retmask - Variable where the cells with special values will be returned
335	* frow, lrow, fcol, lcol - first row, last row, first column, last column
336	* that define the range
337	*
338	* returns 1 if the object was found, the specified range was correct and
339	* its value returned; otherwise 0,
340	* also it returns -1 when a critical error has happened like
341	* a memory allocation error or
342	* an incorrect type of the array retmask given as a parameter
343	*/
344	//---------------------------------------------------------------------------
345	short __declspec(dllexport) CALLBACK TolGetRange(BSTR lvalue,
346	long frow, long lrow,
347	long fcol, long lcol,
348	LPSAFEARRAY FAR * retvalue,
349	LPSAFEARRAY FAR * retmask)
350	//---------------------------------------------------------------------------
351	{
352	if (frow<1 \|\| fcol<1 \|\| frow>lrow \|\| fcol>lcol) // check the definition of range
353	return 0;
354	return GetMatrixRange(lvalue, frow, lrow, fcol, lcol, retvalue, retmask);
355	}
356
357	/*
358	* Obtains the value of an object TOL of type Matrix
359	*
360	* lvalue - Name of the object TOL
361	* retvalue - Variable where the value of the object will be returned
362	* retmask - Variable where the cells with special values will be returned
363	*
364	* returns 1 if the object was found and its value returned, otherwise 0,
365	* also it returns -1 when a critical error has happened like
366	* a memory allocation error or
367	* an incorrect type of the array retmask given as a parameter
368	*/
369	//---------------------------------------------------------------------------
370	short __declspec(dllexport) CALLBACK TolGetMatrix(BSTR lvalue,
371	LPSAFEARRAY FAR * retvalue,
372	LPSAFEARRAY FAR * retmask)
373	//---------------------------------------------------------------------------
374	{
375	return GetMatrixRange(lvalue, 0, 0, 0, 0, retvalue, retmask);
376	}
377
378	/*
379	* Gets the value of a row of an object TOL of type Matrix
380	*
381	* lvalue - Name of the object TOL
382	* retvalue - Variable where the values of the row will be returned
383	* retmask - Variable where the cells with special values will be returned
384	* row - index of the row to obtain
385	*
386	* returns 1 if the object was found, the specified row was correct and
387	* its value returned; otherwise 0,
388	* also it returns -1 when a critical error has happened like
389	* a memory allocation error or
390	* an incorrect type of the array retmask given as a parameter
391	*/
392	//---------------------------------------------------------------------------
393	short __declspec(dllexport) CALLBACK TolGetRow(BSTR lvalue, long row,
394	LPSAFEARRAY FAR * retvalue,
395	LPSAFEARRAY FAR * retmask)
396	//---------------------------------------------------------------------------
397	{
398	if (row<1) // check the definition of the row
399	return 0;
400	return GetMatrixRange(lvalue, row, row, 0, 0, retvalue, retmask);
401	}
402
403	/*
404	* Gets the value of a column of an object TOL of type Matrix
405	*
406	* lvalue - Name of the object TOL
407	* retvalue - Variable where the values of the column will be returned
408	* retmask - Variable where the cells with special values will be returned
409	* col - index of the column to obtain
410	*
411	* returns 1 if the object was found, the specified column was correct and
412	* its value returned; otherwise 0,
413	* also it returns -1 when a critical error has happened like
414	* a memory allocation error or
415	* an incorrect type of the array retmask given as a parameter
416	*/
417	//---------------------------------------------------------------------------
418	short __declspec(dllexport) CALLBACK TolGetColumn(BSTR lvalue, long col,
419	LPSAFEARRAY FAR * retvalue,
420	LPSAFEARRAY FAR * retmask)
421	//---------------------------------------------------------------------------
422	{
423	if (col<1) // check the definition of the column
424	return 0;
425	return GetMatrixRange(lvalue, 0, 0, col, col, retvalue, retmask);
426	}
427
428	/*
429	* Gets the value of a cell of an object TOL of type Matrix
430	*
431	* lvalue - Name of the object TOL
432	* retvalue - Variable where the value of the cell will be returned
433	* row, col - position of the cell to obtain
434	*
435	* returns 1 if the object was found, the specified position of the cell
436	* was correct and its value returned; otherwise returns 0.
437	*/
438	//---------------------------------------------------------------------------
439	short __declspec(dllexport) CALLBACK TolGetCell(BSTR lvalue, long row, long col,
440	stolreal * retvalue)
441	//---------------------------------------------------------------------------
442	{
443	if (row<1 \|\| col<1) // check the position of the cell
444	return 0;
445	LPSTR str_lvalue = (LPSTR)lvalue;
446	short ret = 0;
447	// Get Tol Matrix Object
448	BSyntaxObject * so = GraMatrix()->EvaluateExpr(str_lvalue);
449	if (so) {
450	BMat & m = Mat(so); // Tol Matrix
451	if (row>m.Rows() \|\| col>m.Columns()) { // check the validity of the position
452	DESTROY(so);
453	return 0;
454	}
455	BDat & d = m(row-1, col-1); // Tol Real (Cell)
456	retvalue->value = d.Value(); // Get value
457	if (d.IsKnown()) {
458	if (d.IsFinite())
459	retvalue->kind = Known;
460	else
461	if (d.IsPosInf())
462	retvalue->kind = Pos_Inf;
463	else
464	retvalue->kind = Neg_Inf;
465	}
466	else
467	retvalue->kind = Unknown;
468	DESTROY(so);
469	ret = 1;
470	}
471	return ret;
472	}
473
474	/*
475	* Puts the values of a range of an object TOL of type Matrix
476	*
477	* See functions TolPutRange, TolPutMatrix, TolPutRow,
478	* TolPutColumn and TolPutCell below
479	*/
480	//---------------------------------------------------------------------------
481	short PutMatrixRange(BSTR lvalue, long row, long col,
482	LPSAFEARRAY FAR * value,
483	LPSAFEARRAY FAR * mask)
484	//---------------------------------------------------------------------------
485	{
486	LPSTR str_lvalue = (LPSTR)lvalue;
487	short ret = 0;
488
489	if (!value \|\| !(*value)) // check parameter value
490	return -1;
491	if ((*value)->cDims != 2)
492	return -1;
493	SAFEARRAYBOUND * aDims = (*value)->rgsabound;
494	if (!aDims)
495	return -1;
496	int cMin = aDims[0].lLbound;
497	int rMin = aDims[1].lLbound;
498	BInt v_cols = aDims[0].cElements;
499	BInt v_rows = aDims[1].cElements;
500	if (v_cols<=0 \|\| v_rows<=0)
501	return -1;
502
503	int cells; // check parameter mask
504	if (!mask \|\| !(*mask))
505	cells = 0;
506	else {
507	if ((*mask)->cDims != 1)
508	return -1;
509	if ((*mask)->cbElements != sizeof(smaskcell))
510	return -1;
511	SAFEARRAYBOUND * maskaDims = (*mask)->rgsabound;
512	if (!maskaDims)
513	return -1;
514	cells = maskaDims->cElements;
515	if (cells<0)
516	return -1;
517	}
518	// Get Tol Object
519	BSyntaxObject * so = GraMatrix()->EvaluateExpr(str_lvalue);
520	if (so) {
521	BMat & d = Mat(so); // Tol Matrix
522	BInt m_cols = d.Columns();
523	BInt m_rows = d.Rows();
524
525	if (!row) // update values of the range without definition
526	row = 1;
527	if (!col)
528	col = 1;
529	if (row+v_rows-1 > m_rows \|\| col+v_cols-1 > m_cols) { // check the validity of the range
530	DESTROY(so);
531	return 0;
532	}
533	// Put values
534	// Use 2-D array with SafeArrayPtrOfIndex, SafeArrayLock and SafeArrayUnlock
535	long ai[2];
536	double * pInOut = NULL;
537	HRESULT hres_SafeArrayLock,
538	hres_SafeArrayUnlock,
539	hres_SafeArrayPtrOfIndex;
540
541	hres_SafeArrayLock = SafeArrayLock(*value);
542	assert(!hres_SafeArrayLock);
543	for (int r=0; r<v_rows; ++r) {
544	ai[0] = r + rMin;
545	for (int c=0; c<v_cols; ++c) {
546	ai[1] = c + cMin;
547	hres_SafeArrayPtrOfIndex = SafeArrayPtrOfIndex(value, ai, (void *)(&pInOut));
548	assert(!hres_SafeArrayPtrOfIndex);
549	d(r+row-1, c+col-1) = *pInOut;
550	}
551	}
552	hres_SafeArrayUnlock = SafeArrayUnlock(*value);
553	assert(!hres_SafeArrayUnlock);
554	// Put special values
555	if (cells) {
556	hres_SafeArrayLock = SafeArrayLock(*mask);
557	assert(!hres_SafeArrayLock);
558	smaskcell * maskpInOut = (smaskcell )((mask)->pvData);
559	for (int i=0; i<cells; ++i) {
560	long p_row = maskpInOut[i].r - rMin;
561	long p_col = maskpInOut[i].c - cMin;
562	if (p_row<0 \|\| p_row>=v_rows \|\| p_col<0 \|\| p_col>=v_cols ) {
563	hres_SafeArrayUnlock = SafeArrayUnlock(*mask);
564	assert(!hres_SafeArrayUnlock);
565	DESTROY(so);
566	return 0;
567	}
568	short kind = maskpInOut[i].kind;
569	if (kind==Unknown)
570	d(p_row+row-1, p_col+col-1).PutKnown(BUNKNOWN);
571	else
572	if (kind==Pos_Inf)
573	d(p_row+row-1, p_col+col-1).PutValue(BDat::PosInf());
574	else
575	if (kind==Neg_Inf)
576	d(p_row+row-1, p_col+col-1).PutValue(BDat::NegInf());
577	else
578	if (kind==Known)
579	;
580	else {
581	hres_SafeArrayUnlock = SafeArrayUnlock(*mask);
582	assert(!hres_SafeArrayUnlock);
583	DESTROY(so);
584	return 0;
585	}
586	}
587	hres_SafeArrayUnlock = SafeArrayUnlock(*mask);
588	assert(!hres_SafeArrayUnlock);
589	}
590
591	DESTROY(so);
592	ret = 1;
593	}
594	return ret;
595	}
596
597	/*
598	* Puts the values of a range of an object TOL of type Matrix
599	*
600	* lvalue - Name of the object TOL
601	* value - Values of the range
602	* mask - Array of mask cells with special values
603	* row, col - position of the begining of the range
604	*
605	* returns 1 if the object was found, the specified range was correct and
606	* its values updated; otherwise 0,
607	* also it returns -1 when a critical error has happened like
608	* incorrect dimensions of the array given as a parameter or
609	* an incorrect type of the array mask given as a parameter
610	*/
611	//---------------------------------------------------------------------------
612	short __declspec(dllexport) CALLBACK TolPutRange(BSTR lvalue, long row, long col,
613	LPSAFEARRAY FAR * value,
614	LPSAFEARRAY FAR * mask)
615	//---------------------------------------------------------------------------
616	{
617	if (row<1 \|\| col<1) // check the begining of the range
618	return 0;
619	return PutMatrixRange(lvalue, row, col, value, mask);
620	}
621
622	/*
623	* Puts the values of a row of an object TOL of type Matrix
624	*
625	* lvalue - Name of the object TOL
626	* value - Values of the row
627	* mask - Array of mask cells with special values
628	* row - index of the row
629	*
630	* returns 1 if the object was found, the specified row was correct and
631	* its values updated; otherwise 0,
632	* also it returns -1 when a critical error has happened like
633	* incorrect dimensions of the array given as a parameter or
634	* an incorrect type of the array mask given as a parameter
635	*/
636	//---------------------------------------------------------------------------
637	short __declspec(dllexport) CALLBACK TolPutRow(BSTR lvalue, long row,
638	LPSAFEARRAY FAR * value,
639	LPSAFEARRAY FAR * mask)
640	//---------------------------------------------------------------------------
641	{
642	if (row<1) // check the index of the row
643	return 0;
644	return PutMatrixRange(lvalue, row, 0, value, mask);
645	}
646
647	/*
648	* Puts the values of a column of an object TOL of type Matrix
649	*
650	* lvalue - Name of the object TOL
651	* value - Values of the column
652	* mask - Array of mask cells with special values
653	* col - index of the column
654	*
655	* returns 1 if the object was found, the specified column was correct and
656	* its values updated; otherwise 0,
657	* also it returns -1 when a critical error has happened like
658	* incorrect dimensions of the array given as a parameter or
659	* an incorrect type of the array mask given as a parameter
660	*/
661	//---------------------------------------------------------------------------
662	short __declspec(dllexport) CALLBACK TolPutColumn(BSTR lvalue, long col,
663	LPSAFEARRAY FAR * value,
664	LPSAFEARRAY FAR * mask)
665	//---------------------------------------------------------------------------
666	{
667	if (col<1) // check the index of the column
668	return 0;
669	return PutMatrixRange(lvalue, 0, col, value, mask);
670	}
671
672	/*
673	* Puts the value of a cell of an object TOL of type Matrix
674	*
675	* lvalue - Name of the object TOL
676	* value - Value of the cell
677	* row, col - position of the cell
678	*
679	* returns 1 if the object was found, the specified position of the cell
680	* was correct and its value updated; otherwise returns 0.
681	*/
682	//---------------------------------------------------------------------------
683	short __declspec(dllexport) CALLBACK TolPutCell(BSTR lvalue, long row, long col,
684	stolreal * value)
685	//---------------------------------------------------------------------------
686	{
687	if (row<1 \|\| col<1) // check the position of the cell
688	return 0;
689	LPSTR str_lvalue = (LPSTR)lvalue;
690	short ret = 0;
691	// Get Tol Matrix Object
692	BSyntaxObject * so = GraMatrix()->EvaluateExpr(str_lvalue);
693	if (so) {
694	BMat & m = Mat(so); // Tol Matrix
695	if (row>m.Rows() \|\| col>m.Columns()) { // check the validity of the position
696	DESTROY(so);
697	return 0;
698	}
699	BDat & d = m(row-1, col-1); // Tol Real (Cell)
700	if (value->kind==Known)
701	d.PutValue(value->value);
702	else
703	if (value->kind==Unknown)
704	d.PutKnown(BUNKNOWN);
705	else
706	if (value->kind==Pos_Inf)
707	d.PutValue(BDat::PosInf());
708	else
709	if (value->kind==Neg_Inf)
710	d.PutValue(BDat::NegInf());
711	else {
712	DESTROY(so);
713	return 0;
714	}
715	DESTROY(so);
716	ret = 1;
717	}
718	return ret;
719	}
720
721	/*
722	* Creates an object TOL of type Matrix
723	*
724	* name - Name of the object TOL
725	* value - Value of the object
726	* mask - Array of mask cells with special values
727	*
728	* returns 1 if the object was created, otherwise returns 0,
729	* also it returns -1 when a critical error has happened like
730	* incorrect dimensions of the array given as a parameter or
731	* an incorrect type of the array retmask given as a parameter
732	*/
733	//---------------------------------------------------------------------------
734	short __declspec(dllexport) CALLBACK TolCreateMatrix(BSTR name,
735	LPSAFEARRAY FAR * value,
736	LPSAFEARRAY FAR * mask)
737	//---------------------------------------------------------------------------
738	{
739	LPSTR str_name = (LPSTR)name;
740	short ret = 0;
741
742	if (!value \|\| !(*value)) // check parameter value
743	return -1;
744	if ((*value)->cDims != 2)
745	return -1;
746	SAFEARRAYBOUND * aDims = (*value)->rgsabound;
747	if (!aDims)
748	return -1;
749	int cMin = aDims[0].lLbound;
750	int rMin = aDims[1].lLbound;
751	BInt cols = aDims[0].cElements;
752	BInt rows = aDims[1].cElements;
753	if (cols<=0 \|\| rows<=0)
754	return -1;
755
756	int cells; // check parameter mask
757	if (!mask \|\| !(*mask))
758	cells = 0;
759	else {
760	if ((*mask)->cDims != 1)
761	return -1;
762	if ((*mask)->cbElements != sizeof(smaskcell))
763	return -1;
764	SAFEARRAYBOUND * maskaDims = (*mask)->rgsabound;
765	if (!maskaDims)
766	return -1;
767	cells = maskaDims->cElements;
768	if (cells<0)
769	return -1;
770	}
771
772	BMat d(rows, cols); // Tol Matrix
773	// Put values
774	// Use 2-D array with SafeArrayPtrOfIndex, SafeArrayLock and SafeArrayUnlock
775	long ai[2];
776	double * pInOut = NULL;
777	HRESULT hres_SafeArrayLock,
778	hres_SafeArrayUnlock,
779	hres_SafeArrayPtrOfIndex;
780
781	hres_SafeArrayLock = SafeArrayLock(*value);
782	assert(!hres_SafeArrayLock);
783	for (int r=0; r<rows; ++r) {
784	ai[0] = r + rMin;
785	for (int c=0; c<cols; ++c) {
786	ai[1] = c + cMin;
787	hres_SafeArrayPtrOfIndex = SafeArrayPtrOfIndex(value, ai, (void *)(&pInOut));
788	assert(!hres_SafeArrayPtrOfIndex);
789	d(r, c) = *pInOut;
790	}
791	}
792	hres_SafeArrayUnlock = SafeArrayUnlock(*value);
793	assert(!hres_SafeArrayUnlock);
794	// Put special values
795	if (cells) {
796	hres_SafeArrayLock = SafeArrayLock(*mask);
797	assert(!hres_SafeArrayLock);
798	smaskcell * maskpInOut = (smaskcell )((mask)->pvData);
799	for (int i=0; i<cells; ++i) {
800	long row = maskpInOut[i].r - rMin;
801	long col = maskpInOut[i].c - cMin;
802	if (row<0 \|\| row>=rows \|\| col<0 \|\| col>=cols ) {
803	hres_SafeArrayUnlock = SafeArrayUnlock(*mask);
804	assert(!hres_SafeArrayUnlock);
805	return 0;
806	}
807	short kind = maskpInOut[i].kind;
808	if (kind==Unknown)
809	d(row, col).PutKnown(BUNKNOWN);
810	else
811	if (kind==Pos_Inf)
812	d(row, col).PutValue(BDat::PosInf());
813	else
814	if (kind==Neg_Inf)
815	d(row, col).PutValue(BDat::NegInf());
816	else
817	if (kind==Known)
818	;
819	else {
820	hres_SafeArrayUnlock = SafeArrayUnlock(*mask);
821	assert(!hres_SafeArrayUnlock);
822	return 0;
823	}
824	}
825	hres_SafeArrayUnlock = SafeArrayUnlock(*mask);
826	assert(!hres_SafeArrayUnlock);
827	}
828	// Create Tol Object
829	BSyntaxObject * so = new BContensMat(str_name, d, "");
830	if (so) {
831	BList* result = NIL;
832	BList* aux = NIL;
833	LstFastAppend(result, aux, so);
834	VB_concat(&VB_stack, result);
835	ret = 1;
836	}
837	return ret;
838	}
839

Note: See TracBrowser for help on using the repository browser.

Context Navigation

source: tol/vbtol/source/datatype.cpp @ 2b19912

Download in other formats: