--- rpl/src/rplexternals.h	2015/01/05 13:12:42	1.61
+++ rpl/src/rplexternals.h	2017/07/02 22:28:20	1.77
@@ -1,7 +1,7 @@
 /*
 ================================================================================
-  RPL/2 (R) version 4.1.19
-  Copyright (C) 1989-2015 Dr. BERTRAND Joël
+  RPL/2 (R) version 4.1.27
+  Copyright (C) 1989-2017 Dr. BERTRAND Joël
 
   This file is part of RPL/2.
 
@@ -29,8 +29,13 @@
 ================================================================================
 */
 
-#	define RPLARGS
-#	define struct_processus void
+// Si TYPE_DECLARATION est défini, toutes les structures internes du RPL/2
+// sont exposés pour travailler sur des nouveaux types de données.
+#	ifndef TYPE_DECLARATION
+#		define RPLARGS
+#		define struct_processus void
+#	endif
+
 #	include "rpl.h"
 
 /*
@@ -47,10 +52,10 @@
 				((*rpl_arguments).type_erreur == 'S')) \
 			return 0; } while(0)
 #define leave do { return(0); } while(0)
-#define allocation(a) librpl_allocation((*rpl_arguments).s_etat_processus, a)
-#define copie_objet(a, b) librpl_copie_objet( \
+#define _allocation(a) librpl_allocation((*rpl_arguments).s_etat_processus, a)
+#define _copie_objet(a, b) librpl_copie_objet( \
 			(*rpl_arguments).s_etat_processus, a, b)
-#define liberation(a) librpl_liberation((*rpl_arguments).s_etat_processus, a)
+#define _liberation(a) librpl_liberation((*rpl_arguments).s_etat_processus, a)
 
 #ifdef __RPLC_MAIN
 	struct_rpl_arguments __static_rpl_arguments;
@@ -68,6 +73,36 @@
 
 /*
 --------------------------------------------------------------------------------
+  Gestion des objets
+--------------------------------------------------------------------------------
+*/
+
+// new, dup, drop, disp, parse
+// __type_new(struct_rpl_arguments *rpl_arguments)
+#define declareTypeExtension(fct) \
+		int __type_##fct(struct_processus *s_etat_processus, void **arg) { \
+			char *rptr, *ptr, *iptr; \
+			rptr = (char *) ((*s_etat_processus).definitions_chainees + \
+					(*s_etat_processus).position_courante); \
+			ptr = rptr; \
+			iptr = (char *) (*s_etat_processus).instruction_courante; \
+			if ((ptr != rptr) && (iptr)) goto __parse_error;
+#define parseError	{ goto __parse_error; } while(0)
+#define typeError { return(0); } while(0)
+#define typeSystemError { (*s_etat_processus).erreur_systeme = \
+		d_es_execution_bibliotheque; return(0); } while(0)
+#define typeSuccess { return(1); } while(0)
+#define typeFound(a) { return(a); } while(0)
+#define endTypeExtension __parse_error: return(0); }
+#define sizeOfParse	(rptr - ptr)
+#define searchType(...) { recherche_type(s_etat_processus); \
+			if (((*s_etat_processus).erreur_execution != d_ex) || \
+					((*s_etat_processus).erreur_systeme != d_es)) \
+				{ __VA_ARGS__; return(0); } } while(0)
+#define integerFormat(a) formateur_nombre(s_etat_processus, a, 'I')
+
+/*
+--------------------------------------------------------------------------------
   Types
 --------------------------------------------------------------------------------
 */
@@ -130,7 +165,6 @@
 #define logical int
 #define string char *
 #define integer int
-#define object struct_objet *
 
 #define declareStructure typedef struct {
 #define declareUnion typedef union {
@@ -139,6 +173,7 @@
 #define target(a) (*a)
 #define address(a) (&a)
 
+#define subroutine(name) int name()
 #define beginGroup { __CATCH_SYSTEM_ERROR__;
 #define endGroup __CATCH_SYSTEM_ERROR__; }
 #define beginMacro do beginGroup
@@ -224,7 +259,7 @@
 	do { \
 		if (rpl_object == NULL) \
 			systemError("Nullified object"); \
-		liberation(rpl_object); \
+		_liberation(rpl_object); \
 		rpl_object = NULL; \
 	} while(0)
 
@@ -236,7 +271,7 @@
 
 #define dupObject(rpl_object) \
 	__CATCH_SYSTEM_ERROR__; \
-	do { if (copie_objet(rpl_object, 'P') != rpl_object) \
+	do { if (_copie_objet(rpl_object, 'P') != rpl_object) \
 		systemError("Memory allocation error"); } while(0)
 
 /*
@@ -245,8 +280,8 @@
 --------------------------------------------------------------------------------
 */
 
-#define CONCAT(a, b) __CONCAT(a, b)
-#define __CONCAT(a, b) a##b
+#define CONCAT(a, b) __RPL_CONCAT(a, b)
+#define __RPL_CONCAT(a, b) a##b
 #define FIRST(...) FIRST_HELPER(__VA_ARGS__, throwaway)
 #define FIRST_HELPER(first, ...) first
 #define REST(...) REST_HELPER(NUM(__VA_ARGS__), __VA_ARGS__)
@@ -319,7 +354,7 @@
 		do { syslog(LOG_NOTICE, __VA_ARGS__); } while(0) 
 
 #define exportExternalFunctions(...) \
-	char **__external_symbols(struct_rpl_arguments *rpl_arguments, \
+	char **___external_symbols(struct_rpl_arguments *rpl_arguments, \
 			integer8 *nb_symbols, \
 			const char *version) { \
 		char arguments[] = #__VA_ARGS__; \
@@ -327,6 +362,8 @@
 		char *ptr1, *ptr2; \
 		int drapeau; \
 		unsigned long i; \
+		struct_processus *s_etat_processus; \
+		s_etat_processus = (*rpl_arguments).s_etat_processus; \
 		if (strcmp(version, _d_version_rpl) != 0) \
 		{ \
 			notice(stdout, "Versions mismatch : library %s, expected %s\n", \
@@ -566,6 +603,8 @@
 //	Constantes symboliques
 
 #define createSymbolicConstant(rpl_object, type, value) do { \
+	struct_processus *s_etat_processus; \
+	s_etat_processus = (*rpl_arguments).s_etat_processus; \
 	if ((strcmp(#type, "integer") != 0) && (strcmp(#type, "real") != 0)) \
 		systemError("Type not allowed for symbolic constant"); \
 	__taille_bloc = sizeof(t_8_bits) * 8; \
@@ -606,6 +645,8 @@
 	__constante--; } while(0)
 
 #define createSymbolicComplexConstant(rpl_object, rp, ip) do { \
+	struct_processus *s_etat_processus; \
+	s_etat_processus = (*rpl_arguments).s_etat_processus; \
 	__taille_bloc = sizeof(t_8_bits) * 8; \
 	__indice_bloc = (35 - 1) / __taille_bloc; \
 	__indice_bit = (35 - 1) % __taille_bloc; \
@@ -642,9 +683,9 @@
 		if ((*rpl_object).nombre_occurrences > 1) \
 		{ \
 			struct_objet *__tmp_rpl_object; \
-			if ((__tmp_rpl_object = copie_objet(rpl_object, 'O')) == NULL) \
+			if ((__tmp_rpl_object = _copie_objet(rpl_object, 'O')) == NULL) \
 				systemError("Memory allocation error"); \
-			liberation(rpl_object); \
+			_liberation(rpl_object); \
 			rpl_object = __tmp_rpl_object; \
 		} \
 		(*((integer8 *) (*rpl_object).objet)) = (integer8) value; \
@@ -665,7 +706,7 @@
 #define createIntegerObject(rpl_object) do { \
 	if (rpl_object != NULL) \
 		systemError("Reallocated object"); \
-	if ((rpl_object = allocation(INT)) == NULL) \
+	if ((rpl_object = _allocation(INT)) == NULL) \
 		systemError("Memory allocation error"); \
 	setInteger(rpl_object, 0); } while(0)
 
@@ -677,9 +718,9 @@
 		if ((*rpl_object).nombre_occurrences > 1) \
 		{ \
 			struct_objet *__tmp_rpl_object; \
-			if ((__tmp_rpl_object = copie_objet(rpl_object, 'O')) == NULL) \
+			if ((__tmp_rpl_object = _copie_objet(rpl_object, 'O')) == NULL) \
 				systemError("Memory allocation error"); \
-			liberation(rpl_object); \
+			_liberation(rpl_object); \
 			rpl_object = __tmp_rpl_object; \
 		} \
 		(*((real8 *) (*rpl_object).objet)) = (real8) value; \
@@ -700,7 +741,7 @@
 #define createRealObject(rpl_object) do { \
 	if (rpl_object != NULL) \
 		systemError("Reallocated object"); \
-	if ((rpl_object = allocation(REL)) == NULL) \
+	if ((rpl_object = _allocation(REL)) == NULL) \
 		systemError("Memory allocation error"); \
 	setReal(rpl_object, 0); } while(0)
 
@@ -714,9 +755,9 @@
 		if ((*rpl_object).nombre_occurrences > 1) \
 		{ \
 			struct_objet *__tmp_rpl_object; \
-			if ((__tmp_rpl_object = copie_objet(rpl_object, 'O')) == NULL) \
+			if ((__tmp_rpl_object = _copie_objet(rpl_object, 'O')) == NULL) \
 				systemError("Memory allocation error"); \
-			liberation(rpl_object); \
+			_liberation(rpl_object); \
 			rpl_object = __tmp_rpl_object; \
 		} \
 		setRealPartOfComplex(rpl_object, __rp); \
@@ -728,9 +769,9 @@
 	if ((*rpl_object).nombre_occurrences > 1) \
 	{ \
 		struct_objet *__tmp_rpl_object; \
-		if ((__tmp_rpl_object = copie_objet(rpl_object, 'O')) == NULL) \
+		if ((__tmp_rpl_object = _copie_objet(rpl_object, 'O')) == NULL) \
 			systemError("Memory allocation error"); \
-		liberation(rpl_object); \
+		_liberation(rpl_object); \
 		rpl_object = __tmp_rpl_object; \
 	} \
 	ifIsComplex(rpl_object) (*((complex16 *) (*rpl_object).objet)) \
@@ -741,9 +782,9 @@
 	if ((*rpl_object).nombre_occurrences > 1) \
 	{ \
 		struct_objet *__tmp_rpl_object; \
-		if ((__tmp_rpl_object = copie_objet(rpl_object, 'O')) == NULL) \
+		if ((__tmp_rpl_object = _copie_objet(rpl_object, 'O')) == NULL) \
 			systemError("Memory allocation error"); \
-		liberation(rpl_object); \
+		_liberation(rpl_object); \
 		rpl_object = __tmp_rpl_object; \
 	} \
 	(*((complex16 *) (*rpl_object).objet)).partie_imaginaire = value; \
@@ -770,7 +811,7 @@
 #define createComplexObject(rpl_object) do { \
 	if (rpl_object != NULL) \
 		systemError("Reallocated object"); \
-	if ((rpl_object = allocation(CPL)) == NULL) \
+	if ((rpl_object = _allocation(CPL)) == NULL) \
 		systemError("Memory allocation error"); \
 	setComplex(rpl_object, 0, 0); } while(0)
 
@@ -778,9 +819,11 @@
 
 #define createVectorObject(rpl_object, size, otype, structure, cat) do { \
 	integer8 i; \
+	struct_processus *s_etat_processus; \
+	s_etat_processus = (*rpl_arguments).s_etat_processus; \
 	if (rpl_object != NULL) \
 		systemError("Reallocated object"); \
-	if ((rpl_object = allocation(cat)) == NULL) \
+	if ((rpl_object = _allocation(cat)) == NULL) \
 		systemError("Memory allocation error"); \
 	(*((structure *) (*rpl_object).objet)).taille = size; \
 	if (((*((structure *) (*rpl_object).objet)).tableau = \
@@ -816,9 +859,9 @@
 		if ((*rpl_object).nombre_occurrences > 1) \
 		{ \
 			struct_objet *__tmp_rpl_object; \
-			if ((__tmp_rpl_object = copie_objet(rpl_object, 'O')) == NULL) \
+			if ((__tmp_rpl_object = _copie_objet(rpl_object, 'O')) == NULL) \
 				systemError("Memory allocation error"); \
-			liberation(rpl_object); \
+			_liberation(rpl_object); \
 			rpl_object = __tmp_rpl_object; \
 		} \
 		__position--; \
@@ -864,9 +907,9 @@
 		if ((*rpl_object).nombre_occurrences > 1) \
 		{ \
 			struct_objet *__tmp_rpl_object; \
-			if ((__tmp_rpl_object = copie_objet(rpl_object, 'O')) == NULL) \
+			if ((__tmp_rpl_object = _copie_objet(rpl_object, 'O')) == NULL) \
 				systemError("Memory allocation error"); \
-			liberation(rpl_object); \
+			_liberation(rpl_object); \
 			rpl_object = __tmp_rpl_object; \
 		} \
 		__position--; \
@@ -900,7 +943,7 @@
 	else executionError("Type mismatch error"); } while(0)
 
 #define createRealVectorObject(rpl_object, size) \
-	createVectorObject(object, size, real8, struct_vecteur, VRL)
+	createVectorObject(rpl_object, size, real8, struct_vecteur, VRL)
 
 // A FIXER
 
@@ -920,9 +963,9 @@
 		if ((*rpl_object).nombre_occurrences > 1) \
 		{ \
 			struct_objet *__tmp_rpl_object; \
-			if ((__tmp_rpl_object = copie_objet(rpl_object, 'O')) == NULL) \
+			if ((__tmp_rpl_object = _copie_objet(rpl_object, 'O')) == NULL) \
 				systemError("Memory allocation error"); \
-			liberation(rpl_object); \
+			_liberation(rpl_object); \
 			rpl_object = __tmp_rpl_object; \
 		} \
 		(*((integer8 *) (*rpl_object).objet)) = (integer8) value; \
@@ -944,7 +987,7 @@
 #define createBinaryIntegerObject(rpl_object) do { \
 	if (rpl_object != NULL) \
 		systemError("Reallocated object"); \
-	if ((rpl_object = allocation(BIN)) == NULL) \
+	if ((rpl_object = _allocation(BIN)) == NULL) \
 		systemError("Memory allocation error"); \
 	setBinaryInteger(rpl_object, 0); } while(0)
 
@@ -957,14 +1000,16 @@
 #define elseIfIsName(rpl_object)  } else if (isName(rpl_object))
 
 #define setName(rpl_object, value) do { \
+	struct_processus *s_etat_processus; \
+	s_etat_processus = (*rpl_arguments).s_etat_processus; \
 	ifIsName(rpl_object) \
 	{ \
 		if ((*rpl_object).nombre_occurrences > 1) \
 		{ \
 			struct_objet *__tmp_rpl_object; \
-			if ((__tmp_rpl_object = copie_objet(rpl_object, 'O')) == NULL) \
+			if ((__tmp_rpl_object = _copie_objet(rpl_object, 'O')) == NULL) \
 				systemError("Memory allocation error"); \
-			liberation(rpl_object); \
+			_liberation(rpl_object); \
 			rpl_object = __tmp_rpl_object; \
 		} \
 		free((*((struct_nom *) (*rpl_object).objet)).nom); \
@@ -982,9 +1027,11 @@
 	(*((struct_nom *) (*rpl_object).objet)).symbole = d_vrai; } while(0)
 
 #define createNameObject(rpl_object) do { \
+	struct_processus *s_etat_processus; \
+	s_etat_processus = (*rpl_arguments).s_etat_processus; \
 	if (rpl_object != NULL) \
 		systemError("Reallocated object"); \
-	if ((rpl_object = allocation(NOM)) == NULL) \
+	if ((rpl_object = _allocation(NOM)) == NULL) \
 		systemError("Memory allocation error"); \
 	(*((struct_nom *) (*rpl_object).objet)).symbole = d_faux; \
 	if (((*((struct_nom *) (*rpl_object).objet)).nom = malloc( \
@@ -1001,6 +1048,8 @@
 #define elseIfIsString(rpl_object) else if (isString(rpl_object))
 
 #define setString(rpl_object, string) do { \
+	struct_processus *s_etat_processus; \
+	s_etat_processus = (*rpl_arguments).s_etat_processus; \
 	ifIsString(rpl_object) \
 	{ \
 		if (string == NULL) executionError("Nullified string"); else \
@@ -1008,9 +1057,10 @@
 			if ((*rpl_object).nombre_occurrences > 1) \
 			{ \
 				struct_objet *__tmp_rpl_object; \
-				if ((__tmp_rpl_object = copie_objet(rpl_object, 'O')) == NULL) \
+				if ((__tmp_rpl_object = _copie_objet(rpl_object, 'O')) \
+						== NULL) \
 					systemError("Memory allocation error"); \
-				liberation(rpl_object); \
+				_liberation(rpl_object); \
 				rpl_object = __tmp_rpl_object; \
 			} \
 			free((unsigned char *) (*rpl_object).objet); \
@@ -1028,9 +1078,11 @@
 	else executionError("Type mismatch error"); } while(0)
 
 #define createStringObject(rpl_object) do { \
+	struct_processus *s_etat_processus; \
+	s_etat_processus = (*rpl_arguments).s_etat_processus; \
 	if (rpl_object != NULL) \
 		systemError("Reallocated object"); \
-	if ((rpl_object = allocation(CHN)) == NULL) \
+	if ((rpl_object = _allocation(CHN)) == NULL) \
 		systemError("Memory allocation error"); \
 	if (((*rpl_object).objet = malloc(sizeof(unsigned char))) == NULL) \
 		systemError("Memory allocation error"); \
@@ -1047,17 +1099,19 @@
 #define createListObject(rpl_object) do { \
 	if (rpl_object != NULL) \
 		systemError("Reallocated object"); \
-	if ((rpl_object = allocation(LST)) == NULL) \
+	if ((rpl_object = _allocation(LST)) == NULL) \
 		systemError("Memory allocation error"); \
 	(*rpl_object).objet = NULL; } while(0)
 
 #define addObjectToList(list, rpl_object) do { \
+	struct_processus *s_etat_processus; \
+	s_etat_processus = (*rpl_arguments).s_etat_processus; \
 	ifIsList(list) \
 	{ \
 		struct_objet *__tmp_rpl_object; \
-		if ((__tmp_rpl_object = copie_objet(list, 'N')) == NULL) \
+		if ((__tmp_rpl_object = _copie_objet(list, 'N')) == NULL) \
 			systemError("Memory allocation error"); \
-		liberation(list); \
+		_liberation(list); \
 		list = __tmp_rpl_object; \
 		if ((*list).objet == NULL) \
 		{ \
@@ -1085,12 +1139,14 @@
 	else executionError("Type mistmatch error"); } while(0)
 
 #define insertObjectIntoList(list, rpl_object) do { \
+	struct_processus *s_etat_processus; \
+	s_etat_processus = (*rpl_arguments).s_etat_processus; \
 	ifIsList(list) \
 	{ \
 		struct_objet *__tmp_rpl_object; \
-		if ((__tmp_rpl_object = copie_objet(list, 'N')) == NULL) \
+		if ((__tmp_rpl_object = _copie_objet(list, 'N')) == NULL) \
 			systemError("Memory allocation error"); \
-		liberation(list); \
+		_liberation(list); \
 		list = __tmp_rpl_object; \
 		if ((*list).objet == NULL) \
 		{ \
@@ -1115,6 +1171,8 @@
 	else executionError("Type mistmatch error"); } while(0)
 
 #define removeObjectFromList(list, rpl_object) do { \
+	struct_processus *s_etat_processus; \
+	s_etat_processus = (*rpl_arguments).s_etat_processus; \
 	ifIsList(list) \
 	{ \
 		if ((*list).objet != NULL) \
@@ -1140,7 +1198,7 @@
 					__current = (*__current).suivant; \
 				} \
 			} \
-			liberation((*__current).donnee); \
+			_liberation((*__current).donnee); \
 			free(__current); \
 		} \
 	} \
@@ -1176,10 +1234,21 @@
 #define size(a) sizeof(a)
 
 #define allocate(a) ({ void *ptr; \
+	struct_processus *s_etat_processus; \
+	s_etat_processus = (*rpl_arguments).s_etat_processus; \
 	if ((ptr = malloc(a)) == NULL) \
 			systemError("Memory allocation error"); ptr; })
 
-#define deallocate(a) free(a)
+#define reallocate(a, s) ({ void *ptr; \
+	struct_processus *s_etat_processus; \
+	s_etat_processus = (*rpl_arguments).s_etat_processus; \
+	if ((ptr = realloc(a, s)) == NULL) \
+			systemError("Memory allocation error"); ptr; })
+
+#define deallocate(a) do { \
+	struct_processus *s_etat_processus; \
+	s_etat_processus = (*rpl_arguments).s_etat_processus; \
+	free(a); } while(0)
 
 /*
 --------------------------------------------------------------------------------