Context Navigation

datatype.cpp @ 1b5b24e

devel

Last change on this file since 1b5b24e was 171e6a0, checked in by Pedro Gea <pgea@…>, 11 years ago

Refs #1910
Se incorporan los CMakeLists.txt
Se modifica el código para incorpora rlas diferencias entre los dos compiladores en Windows.

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

Property mode set to 100644

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

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

Context Navigation

source: tol/vbtol/source/datatype.cpp @ 1b5b24e

Download in other formats: