/* Part of XPCE --- The SWI-Prolog GUI toolkit Author: Jan Wielemaker and Anjo Anjewierden E-mail: jan@swi.psy.uva.nl WWW: http://www.swi.psy.uva.nl/projects/xpce/ Copyright (c) 1985-2002, University of Amsterdam All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. */ #include static char *ppsavestring(const char *s); status toString(Any obj, PceString s) { char tmp[25]; char *str; status rval = FAIL; if ( instanceOfObject(obj, ClassCharArray) ) { CharArray ca = obj; str_cphdr(s, &ca->data); s->s_text = ca->data.s_text; succeed; } else if ( isInteger(obj) ) { sprintf(tmp, "%" PRIdPTR, valInt(obj)); str = ppsavestring(tmp); rval = SUCCEED; } else if ( instanceOfObject(obj, ClassReal) ) { sprintf(tmp, "%g", valReal(obj)); str = ppsavestring(tmp); rval = SUCCEED; } else if ( instanceOfObject(obj, ClassNumber) ) { sprintf(tmp, "%" PRIdPTR, ((Number)obj)->value); str = ppsavestring(tmp); rval = SUCCEED; } if ( rval ) { str_set_ascii(s, str); } return rval; } char * toCharp(Any obj) { string s; if ( toString(obj, &s) ) return (char *)s.s_text; return NULL; } Int toInteger(Any obj) { if ( isInteger(obj) ) /* int */ { return (Int) obj; } else if ( instanceOfObject(obj, ClassNumber) ) /* number */ { return toInt(((Number)obj)->value); } else if ( instanceOfObject(obj, ClassReal) ) /* real */ { return toInt(rfloat(valReal(obj))); } else if ( instanceOfObject(obj, ClassCharArray) ) /* char_array */ { CharArray ca = obj; PceString s = &ca->data; if ( isstrA(s) && s->s_size > 0 ) { char *end; long i; i = strtol((char *)s->s_textA, &end, 10); if ( end == (char *)&s->s_textA[s->s_size] ) return toInt(i); } } fail; } Real toReal(Any obj) { if ( instanceOfObject(obj, ClassReal) ) return obj; return getConvertReal(ClassReal, obj); } BoolObj toBool(Any obj) { Int i; string s; if ( isBoolean(obj) ) return obj; if ( (i = checkType(obj, TypeInt, NIL)) ) { if ( i == ZERO ) return OFF; else if ( i == ONE ) return ON; } if ( toString(obj, &s) && isstrA(&s) ) { if ( streq_ignore_case((char *)s.s_textA, "@on") || streq_ignore_case((char *)s.s_textA, "true") || streq_ignore_case((char *)s.s_textA, "yes") || str_icase_eq(&s, &ON->name->data) ) return ON; else if ( streq_ignore_case((char *)s.s_textA, "@off") || streq_ignore_case((char *)s.s_textA, "false") || streq_ignore_case((char *)s.s_textA, "no") || str_icase_eq(&s, &OFF->name->data) ) return OFF; } fail; } Name toName(Any obj) { string s; if (isName(obj)) return obj; if ( toString(obj, &s) ) return StringToName(&s); fail; } Type toType(Any obj) { Name name; if ( instanceOfObject(obj, ClassType) ) return obj; if ( (name = toName(obj)) ) return nameToType(name); fail; } /******************************** * PP * ********************************/ #define PPRINGSIZE 16 static char *ppring[PPRINGSIZE]; static int ppindex = 0; /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - Donot use (un)alloc() to faciliate debugging of the allocation routines. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ static char * ppsavestring(const char *s) { char *q = pceMalloc(strlen(s)+1); strcpy(q, s); if ( ppring[ppindex] ) pceFree(ppring[ppindex]); ppring[ppindex] = q; ppindex = (ppindex+1) % PPRINGSIZE; return q; } /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - Safe version of strName(), making sure the datastructures are fairly ok. Used for debugging purposes only. Returns the string as UTF-8. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ static char * safeStringName(Name n) { if ( isProperObject(n) && instanceOfObject(n, ClassName) ) return nameToUTF8(n); else { char buf[100]; sprintf(buf, "%p", (void*)n); return ppsavestring(buf); } } /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - do_pp() creates a UTF-8 string to describe an object on behalf of debugging. The function is careful to check the consistency before doing most of its work to avoid crashes on partial or corrupted datastructures. The returned string either points to static data or is part of a ring, which implies upto PPRINGSIZE values can be requested before overwrite. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ static char * do_pp(Any obj) { char tmp[LINESIZE]; char summary[256]; char *s; if ( !obj ) return ppsavestring("FAIL"); if ( isInteger(obj) ) { sprintf(tmp, "%" PRIdPTR, valInt(obj)); return ppsavestring(tmp); } if ( isProperObject(obj) ) { if ( isName(obj)) return safeStringName((Name) obj); if ( instanceOfObject(obj, ClassCharArray) && isAddress(((CharArray)obj)->data.s_text) ) { CharArray ca = obj; summary[0] = '"'; if ( ca->data.s_size < 25 ) { strcpy(&summary[1], charArrayToUTF8(ca)); } else { strncpy(&summary[1], charArrayToUTF8(ca), 25); summary[26] = '\0'; strcat(summary, " ..."); } strcat(summary, "\""); s = summary; } else if ( instanceOfObject(obj, ClassType) && isName(((Type)obj)->fullname) ) { s = nameToUTF8(((Type)obj)->fullname); } else if ( instanceOfObject(obj, ClassReal) ) { sprintf(summary, "%g", valReal(obj)); s = summary; } else if ( instanceOfObject(obj, ClassNumber) ) { sprintf(summary, "%" PRIdPTR, ((Number)obj)->value); s = summary; } else if ( instanceOfObject(obj, ClassHostData) ) { Any pn = qadGetv(obj, NAME_printName, 0, NULL); if ( pn && instanceOfObject(pn, ClassCharArray) ) return ppsavestring(charArrayToUTF8(pn)); else s = nameToUTF8(classOfObject(obj)->name); } else s = nameToUTF8(classOfObject(obj)->name); { Name name; if ( (name = getNameAssoc(obj)) ) sprintf(tmp, "@%s/%s", nameToUTF8(name), s); else sprintf(tmp, "@%" PRIdPTR "/%s", valInt(PointerToInt(obj)), s); } if ( isFreedObj(obj) ) strcat(tmp, " (freed)"); else if ( isFreeingObj(obj) ) strcat(tmp, " (unlinking)"); return ppsavestring(tmp); } sprintf(tmp, "%p", obj); return ppsavestring(tmp); } /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - The biggest mess of all. Basically, the above may yield error when passed wrong data. The code below catches these errors and prints the value hexadecimal in case of error. We have structure exception-handling of Windows, Unix with traditional signal(), Unix with sigaction (preserves more context) and systems with and without SIGBUS ... This is hard on MinGW. There is a library libSEH that is supposed to do the job, but this is basically just to make XPCE deal with errors more elegantly, so for now we just run the code unprotected. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ #ifdef __WINDOWS__ #ifdef __MINGW32__ char * pcePP(Any obj) { return do_pp(obj); } #else #include char * pcePP(Any obj) { char *s; #ifndef O_RUNTIME int old = PCEdebugging; PCEdebugging = FALSE; #endif __try { s = do_pp(obj); } __except(EXCEPTION_EXECUTE_HANDLER) { char tmp[100]; sprintf(tmp, "0x%p", obj); s = ppsavestring(tmp); } #ifndef O_RUNTIME PCEdebugging = old; #endif return s; } #endif /*__MINGW32__*/ #else /*__WINDOWS__*/ #include #include jmp_buf pp_env; static RETSIGTYPE pp_sig(int sig) { longjmp(pp_env, 1); } typedef RETSIGTYPE (*handler_t)(); #ifdef HAVE_SIGACTION typedef struct sigaction sigsave_t; static void set_sighandler(int sig, handler_t func, sigsave_t *old) { struct sigaction new; memset(&new, 0, sizeof(new)); /* deal with other fields */ new.sa_handler = func; sigaction(sig, &new, (struct sigaction *)old); /*Cprintf("pcePP: handler = %p, flags = 0x%x\n", old->sa_handler, old->sa_flags); */ } static void restore_handler(int sig, struct sigaction *old) { sigaction(sig, old, NULL); } #else /*HAVE_SIGACTION*/ typedef handler_t sigsave_t; static void set_sighandler(int sig, handler_t func, handler_t *old) { old = signal(sig, new); } static void restore_handler(int sig, handler_t *old) { signal(sig, *old); } #endif /*HAVE_SIGACTION*/ char * pcePP(Any obj) { char *s; #ifndef O_RUNTIME int old = PCEdebugging; #endif sigsave_t oldsegv; #ifdef SIGBUS sigsave_t oldbus; #endif set_sighandler(SIGSEGV, pp_sig, &oldsegv); #ifdef SIGBUS set_sighandler(SIGBUS, pp_sig, &oldbus); #endif #ifndef O_RUNTIME PCEdebugging = FALSE; #endif if ( setjmp(pp_env) == 0 ) { s = do_pp(obj); } else { char tmp[100]; sprintf(tmp, "0x%lx", (unsigned long)obj); s = ppsavestring(tmp); } #ifndef O_RUNTIME PCEdebugging = old; #endif restore_handler(SIGSEGV, &oldsegv); #ifdef SIGBUS restore_handler(SIGBUS, &oldbus); #endif return s; } #endif /*__WINDOWS__*/ /******************************** * FUNCTIONS * ********************************/ Any expandFunction(Any obj) { while ( isFunction(obj) ) { Function f = (Function) obj; Any rval = getExecuteFunction(f); if ( rval == FAIL ) { DEBUG(NAME_obtain, Cprintf("Function: %s\n", pp(f))); fail; } obj = rval; } return obj; }