/* newlisp.c --- enrty point and main functions for newLISP


    Copyright (C) 2016 Lutz Mueller

    This program is free software: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program.  If not, see <http://www.gnu.org/licenses/>.
*/

#include "newlisp.h"
#include "protos.h"
#include "primes.h"

#ifdef WINDOWS
#include <winsock2.h>
#else
#include <sys/socket.h>
#endif

#ifdef READLINE
#include <readline/readline.h>
/* take following line out on Slackware Linux */
#include <readline/history.h>
#endif /* end READLINE */

#ifdef SUPPORT_UTF8
#include <wctype.h>
#endif

#define freeMemory free

#define INIT_FILE "init.lsp"

#ifdef WINDOWS
#define fprintf win_fprintf
#define fgets win_fgets
#define fclose win_fclose
#endif

#ifdef LIBRARY
extern STREAM libStrStream;
int newlispLibConsoleFlag = 0;
#endif

#ifdef LINUX
#ifdef ANDROID
int opsys = 11;
#else
int opsys = 1;
#endif
#endif

#ifdef _BSD
int opsys = 2;
#endif

#ifdef MAC_OSX
#ifdef EMSCRIPTEN
int opsys = 11;
#else
int opsys = 3;
#endif
#endif

#ifdef SOLARIS
int opsys = 4;
#endif

#ifdef WINDOWS
int opsys = 6;
#endif

#ifdef OS2 
int opsys = 7; 
#endif

#ifdef CYGWIN
int opsys = 8;
#endif

#ifdef TRU64
int opsys = 9; 
#endif

#ifdef AIX
int opsys = 10;
#endif


/* opsys = 11 taken for ANDROID; see LINUX */

int bigEndian = 1; /* gets set in main() */

int version = 10700;

char copyright[]=
"\nnewLISP v.10.7.0 Copyright (c) 2016 Lutz Mueller. All rights reserved.\n\n%s\n\n";

#ifndef NEWLISP64
#ifdef SUPPORT_UTF8
char banner[]=
"newLISP v.10.7.0 32-bit on %s IPv4/6 UTF-8%s%s\n\n";
#else
char banner[]=
"newLISP v.10.7.0 32-bit on %s IPv4/6%s%s\n\n";
#endif
#else /* NEWLISP64 */
#ifdef SUPPORT_UTF8
char banner[]=
"newLISP v.10.7.0 64-bit on %s IPv4/6 UTF-8%s%s\n\n";
#else
char banner[]=
"newLISP v.10.7.0 64-bit on %s IPv4/6%s%s\n\n";
#endif 
#endif /* NEWLISP64 */

char banner2[]= ", options: newlisp -h";

void linkSource(char *, char *, char *);
char linkOffset[] = "&&&&@@@@";
char preLoad[] = 
#ifdef EMSCRIPTEN
    "(set (global 'module) (fn ($x) (load (append {/newlisp-js/} $x))))"
#else
    "(set (global 'module) (fn ($x) (load (append (env {NEWLISPDIR}) {/modules/} $x))))"
#endif
    "(context 'Tree) (constant 'Tree:Tree) (context MAIN)"
    "(define (Class:Class) (cons (context) (args)))";
void printHelpText(void);
#ifdef READLINE
char ** newlisp_completion (char * text, int start, int end);
#endif
/* --------------------- globals -------------------------------------- */

/* interactive command line */

int isTTY = FALSE;
int daemonMode = 0;

int noPromptMode = 0;
int forcePromptMode = 0;
int httpMode = 0;
int evalSilent = 0;


#ifdef WINDOWS
int IOchannelIsSocketStream = 0;
#endif
FILE * IOchannel;
char * IOdomain = NULL;
int IOport = 0;
int connectionTimeout = 0;

int logTraffic = 0;
#define LOG_LESS 1
#define LOG_MORE 2

/* initialization */
int MAX_CPU_STACK = 0x800;
int MAX_ENV_STACK;
int MAX_RESULT_STACK;
#define MAX_OBJECT_STACK 64
#ifndef NEWLISP64
INT MAX_CELL_COUNT = 0x10000000;
#else
INT MAX_CELL_COUNT = 0x800000000000000LL;
#endif
INT blockCount = 0;

CELL * firstFreeCell = NULL;

CELL * nilCell;
CELL * trueCell;
CELL * lastCellCopied;
CELL * countCell;
SYMBOL * nilSymbol;
SYMBOL * trueSymbol;
SYMBOL * starSymbol;
SYMBOL * plusSymbol;
SYMBOL * questionSymbol;
SYMBOL * atSymbol;
SYMBOL * currentFunc;
SYMBOL * argsSymbol;
SYMBOL * mainArgsSymbol;
SYMBOL * listIdxSymbol;
SYMBOL * itSymbol;
SYMBOL * sysxSymbol;
SYMBOL * countSymbol;
SYMBOL * beginSymbol;
SYMBOL * expandSymbol;

SYMBOL * sysSymbol[MAX_REGEX_EXP];

SYMBOL * currentContext = NULL;
SYMBOL * mainContext = NULL;
SYMBOL * errorEvent;
SYMBOL * timerEvent;
SYMBOL * promptEvent;
SYMBOL * commandEvent;
SYMBOL * transferEvent;
SYMBOL * readerEvent;

SYMBOL * symHandler[32];
int currentSignal = 0;

SYMBOL * symbolCheck = NULL;
CELL * stringCell = NULL;
void * stringIndexPtr = NULL;

jmp_buf errorJump;

char lc_decimal_point;

/* error and exception handling */

#define EXCEPTION_THROW -1
int errorReg = 0;
CELL * throwResult;

/* buffers for read-line and error reporting */
STREAM readLineStream;
STREAM errorStream;

/* compiler */

size_t cellCount = 0;
size_t symbolCount = 0;

int parStackCounter = 0;

/* expression evaluation */

static CELL * (*evalFunc)(CELL *) = NULL;

UINT * envStack = NULL;
UINT * envStackIdx;
UINT * envStackTop;
UINT * resultStack = NULL;
UINT * resultStackIdx;
UINT * resultStackTop;
UINT * lambdaStack = NULL;
UINT * lambdaStackIdx;

/* internal dummy to carry FOOP object */
SYMBOL objSymbol = {SYMBOL_GLOBAL | SYMBOL_BUILTIN, 
    0, "container of (self)", 0, NULL, NULL, NULL, NULL};
CELL * objCell;

extern PRIMITIVE primitive[];

/* debugger in nl-debug.c */
extern char debugPreStr[];
extern char debugPostStr[];
extern CELL * debugPrintCell;

int traceFlag = 0;
int evalCatchFlag = 0;
int recursionCount = 0;

int prettyPrintPars = 0;
int prettyPrintCurrent = 0;
int prettyPrintFlags = 0;
int prettyPrintLength = 0;
char * prettyPrintTab = " ";
char * prettyPrintFloat = "%1.16g";
#define MAX_PRETTY_PRINT_LENGTH 80
UINT prettyPrintMaxLength =  MAX_PRETTY_PRINT_LENGTH;
int stringOutputRaw = TRUE;

#define pushLambda(A) (*(lambdaStackIdx++) = (UINT)(A))

int pushResultFlag = TRUE;

char startupDir[PATH_MAX]; /* start up directory, if defined via -w */
char * tempDir; /* /tmp on unix or geten("TMP") on Windows */
char logFile[PATH_MAX]; /* logFile, is define with -l, -L */

/* nl-filesys.c */
int pagesize;

/* ============================== MAIN ================================ */

#ifndef EMSCRIPTEN
/*
void setupSignalHandler(int sig, void (* handler)(int))
{
static struct sigaction sig_act;
sig_act.sa_handler = handler;
sigemptyset(&sig_act.sa_mask);
sig_act.sa_flags = SA_RESTART | SA_NOCLDSTOP;
if(sigaction(sig, &sig_act, 0) != 0)
    printf("Error setting signal:%d handler\n", sig);
}
*/
void setupSignalHandler(int sig, void (* handler)(int))
{
if(signal(sig, handler) == SIG_ERR)
    printf("Error setting signal:%d handler\n", sig);
}

#if defined(SOLARIS) || defined(TRU64) || defined(AIX)
void sigpipe_handler(int sig)
{
setupSignalHandler(SIGPIPE, sigpipe_handler);
}

void sigchld_handler(int sig)
{
waitpid(-1, (int *)0, WNOHANG);
}

void ctrlC_handler(int sig) 
{
char chr; 

setupSignalHandler(SIGINT, ctrlC_handler);

traceFlag |= TRACE_SIGINT;

printErrorMessage(ERR_SIGINT, NULL, 0);
printf("%s", "(c)ontinue, e(x)it, (r)eset:");
fflush(NULL);
chr = getchar();
if(chr == 'x') exit(1);
if(chr == 'c') traceFlag &= ~TRACE_SIGINT;
}


void sigalrm_handler(int sig)
{
setupSignalHandler(sig, sigalrm_handler);
/* check if not sitting idle */
if(recursionCount)
  traceFlag |= TRACE_TIMER;
else /* if idle */
  executeSymbol(timerEvent, NULL, NULL);
}

#endif /* SOLARIS, TRUE64, AIX */


void setupAllSignals(void)
{
#if defined(SOLARIS) || defined(TRU64) || defined(AIX)
setupSignalHandler(SIGINT, ctrlC_handler);
#else
setupSignalHandler(SIGINT, signal_handler);
#endif

#ifndef WINDOWS

#if defined(SOLARIS) || defined(TRU64) || defined(AIX)
setupSignalHandler(SIGALRM, sigalrm_handler);
setupSignalHandler(SIGVTALRM, sigalrm_handler);
setupSignalHandler(SIGPROF, sigalrm_handler);
setupSignalHandler(SIGPIPE, sigpipe_handler);
setupSignalHandler(SIGCHLD, sigchld_handler);
#else
setupSignalHandler(SIGALRM, signal_handler);
setupSignalHandler(SIGVTALRM, signal_handler);
setupSignalHandler(SIGPROF, signal_handler);
setupSignalHandler(SIGPIPE, signal_handler);
setupSignalHandler(SIGCHLD, signal_handler);
#endif

#endif
}

void signal_handler(int sig)
{
#ifndef WINDOWS
char chr; 
#endif

if(sig > 32 || sig < 1) return;

#if defined(SOLARIS) || defined(TRU64) || defined(AIX)
switch(sig)
  {
  case SIGALRM:
  case SIGVTALRM:
  case SIGPROF:
    setupSignalHandler(sig, sigalrm_handler);
    break;
  case SIGPIPE:
    setupSignalHandler(SIGPIPE, sigpipe_handler);
    break;
  case SIGCHLD:
    setupSignalHandler(SIGCHLD, sigchld_handler);
    break;
  }
#else
setupSignalHandler(sig, signal_handler);
#endif

if(symHandler[sig - 1] != nilSymbol)
    {
    if(recursionCount)
        {
        currentSignal = sig;
        traceFlag |= TRACE_SIGNAL;
        return;
        }
    else
        {
        executeSymbol(symHandler[sig-1], stuffInteger(sig), NULL);
        return;
        }
    }

switch(sig)
    {
    case SIGINT:
        printErrorMessage(ERR_SIGINT, NULL, 0);

#ifdef WINDOWS
        traceFlag |= TRACE_SIGINT;
#else
        printf("%s", "\n(c)ontinue, (d)ebug, e(x)it, (r)eset:");
        fflush(NULL);
        chr = getchar();
        if(chr == 'x') exit(1);
        if(chr == 'd') 
            {
            traceFlag &= ~TRACE_SIGINT;
            openTrace();
            }
        if(chr == 'r') traceFlag |= TRACE_SIGINT;
        break;
    case SIGPIPE:
        break;
    case SIGALRM:
    case SIGVTALRM:
    case SIGPROF:
        /* check if not sitting idle */
        if(recursionCount)
            traceFlag |= TRACE_TIMER;
        else /* if idle */
            executeSymbol(timerEvent, NULL, NULL);
        break;
    case SIGCHLD:
        waitpid(-1, (int *)0, WNOHANG);
#endif
        break;
    default:
        return;
    }   
}
#endif /* no EMSCRIPTEN */
 
char * which(char * name, char * buff)
{
char *path_list, *test, *tmp, *path_parsed;
struct stat filestat;
int count = 1;
int i, len, nlen;
int found = FALSE;

path_list = getenv("PATH");
if (!path_list) path_list = "/bin:/sbin:/usr/bin:/usr/sbin:/usr/local/bin";

len = strlen(path_list);
nlen = strlen(name);
path_parsed = alloca(len + 1);
strncpy(path_parsed, path_list, len + 1);

test = path_parsed;
while (TRUE) 
    {
#ifdef WINDOWS
    tmp = strchr(test, ';');
#else
    tmp = strchr(test, ':');
#endif
    if (tmp == NULL) break;
    *tmp = 0;
    test = tmp + 1;
    count++;
    }   

test = path_parsed;
for (i = 0; i < count; i++) 
    {
    len = strlen(test);
    if((len + nlen + 2) > PATH_MAX) 
	    return(NULL);
    strncpy(buff, test, len + 1);
    buff[len] = '/';
    memcpy(buff + len + 1, name, nlen);
    buff[len + 1 + nlen] = 0;
    if (stat (buff, &filestat) == 0 && filestat.st_mode & S_IXUSR)
        {
        found = TRUE;
        break;
        }
    test += (len + 1);
    }

if(!found) return(NULL);
errno = 0;
return(buff);
}

#ifndef LIBRARY
void loadStartup(char * name)
{
char initFile[PATH_MAX];
char * envPtr;
int len;

/* normal newLISP start up */
if(strncmp(linkOffset + 4, "@@@@", 4) == 0)
    {
    if(getenv("HOME"))
        strncpy(initFile, getenv("HOME"), PATH_MAX - 16);
    else if(getenv("USERPROFILE"))
        strncpy(initFile, getenv("USERPROFILE"), PATH_MAX - 16);
    else if(getenv("DOCUMENT_ROOT"))
        strncpy(initFile, getenv("DOCUMENT_ROOT"), PATH_MAX - 16);

    len = strlen(initFile);
    memcpy(initFile + len, "/.", 2);
    memcpy(initFile + len + 2, INIT_FILE, 8);
    initFile[len + 2 + 8] = 0;
    if(loadFile(initFile, 0, 0, mainContext) == NULL)
        {
        envPtr = getenv("NEWLISPDIR");
        if(envPtr)
            {
            strncpy(initFile, envPtr, PATH_MAX - 16);
            len = strlen(envPtr);
            memcpy(initFile + len, "/", 1);
            memcpy(initFile + len + 1, INIT_FILE, 8);
            initFile[len + 1 + 8] = 0;
            loadFile(initFile, 0, 0, mainContext);      
            }
        }
    }
/* load part at offset no init.lsp or .init.lsp is loaded */
else
    {
#ifdef WINDOWS
	name = win_getExePath(alloca(MAX_PATH));
    loadFile(name, *(unsigned int *)linkOffset, 1, mainContext);
#else /* if not Win32 get full pathname of file in name */
    if(strchr(name, '/') == NULL) 
        if((name = which(name, alloca(PATH_MAX))) == NULL)
            {
            printf("%s: %s\n", strerror(ENOENT), name);
            exit(ENOENT);
            }
    loadFile(name, *(unsigned int *)linkOffset, 1, mainContext);
#endif
    }
}
#endif /* LIBRARY */

#ifdef _BSD
struct lconv    *localeconv(void);
char            *setlocale(int, const char *);  
#endif

void initLocale(void)
{
#ifndef ANDROID
struct lconv * lc;
#endif
char * locale;

#ifndef SUPPORT_UTF8
locale = setlocale(LC_ALL, "C");
#else
locale = setlocale(LC_ALL, "");
#endif

if (locale != NULL)
  stringOutputRaw = (strcmp(locale, "C") == 0);

#ifdef ANDROID
lc_decimal_point = '.';
#else
lc = localeconv();
lc_decimal_point = *lc->decimal_point;
#endif
}

/* set NEWLISPDIR only if not set already */
void initNewlispDir(void)
{
#ifdef WINDOWS
char * varValue;
char * newlispDir;
int len;

if(getenv("NEWLISPDIR") == NULL)
    {
    newlispDir = alloca(MAX_PATH);
    varValue = getenv("PROGRAMFILES");
    if(varValue != NULL)
        {
        len = strlen(varValue);
        strncpy(newlispDir, varValue, MAX_PATH - 12);
        memcpy(newlispDir + len, "/newlisp", 8);
        newlispDir[len + 8] = 0; 
        setenv("NEWLISPDIR", newlispDir, TRUE);
        }
    else setenv("NEWLISPDIR", "newlisp", TRUE);
    }
#else
if(getenv("NEWLISPDIR") == NULL)
    setenv("NEWLISPDIR", NEWLISPDIR, TRUE);
#endif
}

void initTempDir()
{
#ifdef WINDOWS
if((tempDir = getenv("TMP")) == NULL)
    {
    printf("Environment variable TMP not set, assuming /tmp .");
    tempDir = "/tmp";
    }
#else
#ifdef ANDROID
tempDir = "/data/tmp";
#else /* all UNIX */
tempDir = "/tmp";
#endif
#endif
return;
}

#ifndef  LIBRARY
char * getArg(char * * arg, int argc, int * index)
{
if(strlen(arg[*index]) > 2)
    return(arg[*index] + 2);

if(*index >= (argc - 1))
    {
    printf("missing parameter for %s\n", arg[*index]);
    exit(-1);
    }

*index = *index + 1;

return(arg[*index]);
}

#ifndef WINDOWS
char ** MainArgs;
#endif 

CELL * getMainArgs(char * mainArgs[])
{
CELL * argList;
int idx = 0;

#ifndef WINDOWS
MainArgs = mainArgs;
#endif

argList = getCell(CELL_EXPRESSION);

while(mainArgs[idx] != NULL)
    addList(argList, stuffString(mainArgs[idx++]));

return(argList);
}

char * getCommandLine(int batchMode, int * length);
    
int main(int argc, char * argv[])
{
char command[MAX_COMMAND_LINE];
STREAM cmdStream = {NULL, NULL, 0, 0, 0};
char * cmd;
int idx;

#ifdef WINDOWS
WSADATA WSAData;
if(WSAStartup(MAKEWORD(2,2), &WSAData) != 0)
    {
    printf("Winsocket initialization failed\n");
    exit(-1);
    }
pagesize = 4096;

/* replace '_CRT_fmode = _O_BINARY' in nl-filesys.c for 10.4.8, thanks to Kosh */
_setmode(_fileno(stdin), _O_BINARY);
_setmode(_fileno(stdout), _O_BINARY);
_setmode(_fileno(stderr), _O_BINARY);
#endif

#ifdef SUPPORT_UTF8
opsys += 128;
#endif

#ifdef NEWLISP64
opsys += 256;
#endif

#ifdef FFI
opsys += 1024;
initFFI();
#endif

#ifndef WINDOWS
#ifndef OS2
pagesize = getpagesize();
#endif
tzset();
#endif

#ifdef OS2
/* Reset the floating point coprocessor */
_fpreset();
#endif

initLocale();
initNewlispDir();
initTempDir();

IOchannel = stdin;
bigEndian = (*((char *)&bigEndian) == 0);

initStacks();
initialize();
initDefaultInAddr(); 

#ifdef WINDOWS
#ifdef SUPPORT_UTF8
 {
   /*
     command line parameter is MBCS.
     MBCS -> Unicode(UTF-16) -> UTF-8
   */
   char **argv_utf8 = allocMemory((argc + 1)* sizeof(char *)) ;
   {
   for(idx = 0 ; idx<argc ; idx++)
      {
      WCHAR *p_argvW = ansi_mbcs_to_utf16(argv[idx]) ;
      char *p_argvU = utf16_to_utf8(p_argvW) ;
      argv_utf8[idx] = p_argvU ;
      }
   argv_utf8[idx] = NULL ;
   argv = argv_utf8 ;
   }
 }
#endif
#endif
mainArgsSymbol->contents = (UINT)getMainArgs(argv);

if((errorReg = setjmp(errorJump)) != 0) 
    {
    if((errorEvent != nilSymbol) || (errorReg == ERR_USER_RESET)) 
        executeSymbol(errorEvent, NULL, NULL);
    else exit(-1);
    goto AFTER_ERROR_ENTRY;
    }

setupAllSignals();

sysEvalString(preLoad, mainContext, nilCell, EVAL_STRING);

/* loading of init.lsp can be suppressed with -n as first option
   but is never done when program is link.lsp'd */

if(argc < 2 || strncmp(argv[1], "-n", 2))
    {
    if(!(argc >= 2 && strcmp(argv[1], "-x") == 0)) 
        loadStartup(argv[0]);
    }
   
errno = 0;

if(realpath(".", startupDir) == NULL)
    fatalError(ERR_IO_ERROR, 0, 0);

for(idx = 1; idx < argc; idx++)
    {
    if(strncmp(argv[idx], "-c", 2) == 0)
        {
        noPromptMode = TRUE;
        continue;
        }

    if(strncmp(argv[idx], "-C", 2) == 0)
        {
        forcePromptMode = TRUE;
        continue;
        }

    if(strncmp(argv[idx], "-http", 5) == 0)
        {
        noPromptMode = TRUE;
        httpMode = TRUE;
        continue;
        }

    if(strncmp(argv[idx], "-s", 2) == 0)
        {
        MAX_CPU_STACK = atoi(getArg(argv, argc, &idx));

        if(MAX_CPU_STACK < 1024) MAX_CPU_STACK = 1024;
        initStacks();
        continue;
        }

    if(strncmp(argv[idx], "-p", 2) == 0 || strncmp(argv[idx], "-d", 2) == 0  )
        {
        if(strncmp(argv[idx], "-d", 2) == 0)
            daemonMode = TRUE;

        IOdomain = getArg(argv, argc, &idx);
        IOport = atoi(IOdomain);

        setupServer(0);
        continue;
        }

    if(strncmp(argv[idx], "-t", 2) == 0)
        {
        connectionTimeout = atoi(getArg(argv, argc, &idx));
        continue;
        }

    if(strncmp(argv[idx], "-l", 2) == 0 || strncmp(argv[idx], "-L", 2) == 0)
        {
        logTraffic = (strncmp(argv[idx], "-L", 2) == 0) ? LOG_MORE : LOG_LESS;
        if(realpath(getArg(argv, argc, &idx), logFile) == NULL)
            close(openFile(logFile, "w", 0));

        continue;
        }

    if(strncmp(argv[idx], "-m", 2) == 0)
        {
#ifndef NEWLISP64
        MAX_CELL_COUNT =  abs(0x0010000 * atoi(getArg(argv, argc, &idx)));
#else
        MAX_CELL_COUNT =  abs(0x0008000 * atoi(getArg(argv, argc, &idx)));
#endif
        continue;
        }

    if(strncmp(argv[idx], "-w", 2) == 0)
        {
        if(realpath(getArg(argv, argc, &idx), startupDir) == NULL 
                                        || chdir(startupDir) < 0)
            fatalError(ERR_WORKING_DIR, 0, 0);
        continue;
        }   

    if(strcmp(argv[idx], "-6") == 0)
        {
        ADDR_FAMILY = AF_INET6;
        initDefaultInAddr(); 
        continue;
        }

    if(strcmp(argv[idx], "-v") == 0)
        {
        varPrintf(OUT_CONSOLE, banner, OSTYPE, LIBFFI, ".");
        exit(0);
        }

    if(strncmp(argv[idx], "-e", 2) == 0)
        {
        executeCommandLine(getArg(argv, argc, &idx), OUT_CONSOLE, &cmdStream);
        exit(0);
        }       

    if(strncmp(argv[idx], "-x", 2) == 0)
        {
        if(argc == 4)
            linkSource(argv[0], argv[idx + 1], argv[idx + 2]);
        exit(0);
        }

    if(strcmp(argv[idx], "-h") == 0)
        {
        printHelpText();
        exit(0);
        }
    
    loadFile(argv[idx], 0, 0, mainContext);
    }

AFTER_ERROR_ENTRY:

if(isatty(fileno(IOchannel)))
    {
    isTTY = TRUE;
    if(!noPromptMode)   
        varPrintf(OUT_CONSOLE, banner, OSTYPE, LIBFFI, banner2);
    }
else
    {
#ifdef WINDOWS
    if(!IOchannelIsSocketStream) 
#endif
        setbuf(IOchannel,0);
    if(forcePromptMode)
        varPrintf(OUT_CONSOLE, banner, OSTYPE, LIBFFI, banner2);
    }

/* ======================= main entry on reset ====================== */


errorReg = setjmp(errorJump);

setupAllSignals();
reset();
initStacks();

if(errorReg && !isNil((CELL*)errorEvent->contents) ) 
    executeSymbol(errorEvent, NULL, NULL);


#ifdef READLINE
rl_readline_name = "newlisp";
rl_attempted_completion_function = (char ** (*) (const char *, int, int))newlisp_completion;
#if defined(LINUX) || defined(_BSD)
/* in Bash .inputrc put 'set blink-matching-paren on' */
rl_set_paren_blink_timeout(300000); /* 300 ms */
#endif
#endif

while(TRUE)
    {
    cleanupResults(resultStack);
    if(isTTY)  
        {
        cmd = getCommandLine(FALSE, NULL);
        executeCommandLine(cmd, OUT_CONSOLE, &cmdStream);
        free(cmd);
        continue;
        }

    if(IOchannel != stdin || forcePromptMode) 
        varPrintf(OUT_CONSOLE, "%s", prompt());

    /* daemon mode timeout if nothing read after accepting connection */
    if(connectionTimeout && IOchannel && daemonMode)
        {
#ifdef WINDOWS
        if(IOchannelIsSocketStream)
          if(wait_ready(getSocket(IOchannel), connectionTimeout, 0) == 0)
#else
        if(wait_ready(fileno(IOchannel), connectionTimeout, 0) == 0)
#endif
            {
            fclose(IOchannel);
            setupServer(1);
            continue;
            }
        }

    if(IOchannel == NULL || fgets(command, MAX_COMMAND_LINE - 1, IOchannel) == NULL)
        {
        if(!daemonMode)  exit(1);
        if(IOchannel != NULL) fclose(IOchannel);
        setupServer(1);
        continue;
        }

    executeCommandLine(command, OUT_CONSOLE, &cmdStream);
    }

#ifndef WINDOWS
return 0;
#endif
}
#endif /* not LIBRARY */

#ifdef READLINE
char * command_generator(char * text, int state)
{
static int list_index, len, clen;
char * name;
     
if (!state)
    {
    list_index = 0;
    len = strlen (text);
    }
     
while((name = primitive[list_index].name))
    {
    list_index++;
     
    if (strncmp (name, text, len) == 0)
        {
        clen = strlen(name) + 1;
        return(strncpy(malloc(clen), name, clen));
        }
    }
     
return ((char *)NULL);
}

char ** completion_matches(const char * text,  char * (*commands)(const char *, int)); 

char ** newlisp_completion (char * text, int start, int end)
{
return(completion_matches(text,  (char * (*) (const char *, int) )command_generator));
}

#endif /* READLINE */


char * getCommandLine(int batchMode, int * length)
{
char * cmd;
int len;

#ifndef READLINE
if(!batchMode) varPrintf(OUT_CONSOLE, "%s", prompt());
cmd = calloc(MAX_COMMAND_LINE + 4, 1);
if(fgets(cmd, MAX_COMMAND_LINE - 1, IOchannel) == NULL) 
    {
    puts("");
    exit(0);
    }
len = strlen(cmd);
/* cut off line terminators  left by fgets */
*(cmd + len - LINE_FEED_LEN) = 0;
len -= LINE_FEED_LEN; /* v.10.6.2 */
#else /*  READLINE */
int errnoSave = errno;
if((cmd = readline(batchMode ? "" : prompt())) == NULL) 
    {
    puts("");
    exit(0);
    }
errno = errnoSave; /* reset errno, set by readline() */
len = strlen(cmd);
if(len > 0) 
    add_history(cmd);
#endif  

if(length != NULL) *length = len;
return(cmd);
}

#ifndef LIBRARY

void printHelpText(void)
{
varPrintf(OUT_CONSOLE, copyright, 
    "usage: newlisp [file | url ...] [options ...] [file | url ...]\n\noptions:");
varPrintf(OUT_CONSOLE, 
    "%s\n%s\n%s\n%s\n%s\n%s\n%s\n%s\n%s\n%s\n%s\n%s\n%s\n%s\n%s\n%s\n%s\n%s\n\n",
    " -h this help",
    " -n no init.lsp (must be first)",
    " -x <source> <target> link",
    " -v version",
    " -s <stacksize>",
    " -m <max-mem-MB> cell memory",
    " -e <quoted lisp expression>",
    " -l <path-file> log connections",
    " -L <path-file> log all",
    " -w <working dir>",
    " -c no prompts, net-eval, HTTP",
    " -C force prompts",
    " -t <usec-server-timeout>",
    " -p <port-no>",
    " -d <port-no> daemon mode",
    " -http only mode",
    " -6 IPv6 mode",
    "\nmore info at http://newlisp.org");
}

void setupServer(int reconnect)
{
if((IOchannel  = serverFD(IOport,  IOdomain, reconnect)) == NULL)
    {
    printf("newLISP server setup on %s failed.\n", IOdomain);
    exit(1);
    }

#ifdef WINDOWS
else    IOchannelIsSocketStream = TRUE; 

if(!IOchannelIsSocketStream)
#endif
    setbuf(IOchannel,0);

if(!reconnect && !noPromptMode)
    varPrintf(OUT_CONSOLE, banner, OSTYPE, LIBFFI, ".");
}

#endif /* ifndef LIBRARY */

char * prompt(void)
{
char * contextName = "";
CELL * result;
static char string[64];

if(evalSilent || noPromptMode) 
    {
    evalSilent = 0;
    return("");
    }

if(promptEvent != nilSymbol)
    {
    if(executeSymbol(promptEvent, stuffSymbol(currentContext), &result) == CELL_STRING)
        {
        strncpy(string, (char *)result->contents, 64);
        string[63] = 0;
        deleteList(result);
        return(string);
        }
    deleteList(result);
    }
    
if(currentContext != mainContext)
    contextName = currentContext->name;

if(traceFlag & TRACE_SIGINT) 
    {
    traceFlag &= ~TRACE_SIGINT;
    longjmp(errorJump, errorReg);
    }
    
if(traceFlag && !(traceFlag & TRACE_PRINT_EVAL))
    snprintf(string, 63, "%d %s> ", recursionCount, contextName);
else
    snprintf(string, 63, "%s> ", contextName);

return(string);
}


void reset()
{
recoverEnvironment(envStack);

while(resultStackIdx > resultStack)
    deleteList(popResult());

envStackIdx = envStack;
lambdaStackIdx = lambdaStack;

freeCellBlocks();

if(printDevice) close((int)printDevice);
printDevice = recursionCount  = traceFlag = prettyPrintFlags = 0;
evalFunc = NULL;
#ifdef XML_SUPPORT
xmlTags = NULL; /* force recreation */
#endif
pushResultFlag = TRUE;
currentContext = mainContext;
itSymbol->contents = (UINT)nilCell;
}


void recoverEnvironment(UINT * index)
{
SYMBOL * symbol;
CELL * cell;

while(envStackIdx > index)
    {
    symbol = (SYMBOL *)popEnvironment();
    cell = (CELL*)popEnvironment();
    if(cell != (CELL*)symbol->contents)
        {
        deleteList((CELL*)symbol->contents);
        symbol->contents = (UINT)cell;
        }
    }
}


char * processCommandEvent(char * command);

void executeCommandLine(char * command, UINT outDevice, STREAM * cmdStream)
{
STREAM stream;
char buff[MAX_COMMAND_LINE];
char * cmd;
int batchMode = 0;
int len;

memset(buff + MAX_COMMAND_LINE -2, 0, 2);

if(memcmp(command, "[cmd]", 5) == 0)
    batchMode = 2;
else if(isTTY && (*command == '\n' || *command == '\r' || *command == 0))
    batchMode = 1;

#ifndef LIBRARY
if(!batchMode && commandEvent != nilSymbol)
    command = processCommandEvent(command);
#endif

if(!isTTY && (*command == '\n' || *command == '\r' || *command == 0)) return;

if(!batchMode) 
    {
    if(logTraffic == LOG_MORE) 
        writeLog(command, TRUE);
#ifndef LIBRARY
    if(strncmp(command, "GET /", 5) == 0) 
        executeHTTPrequest(command + 5, HTTP_GET);
    else if(strncmp(command, "HEAD /", 6) == 0)
        executeHTTPrequest(command + 6, HTTP_HEAD);
    else if(strncmp(command, "PUT /", 5) == 0)
        executeHTTPrequest(command + 5, HTTP_PUT);
    else if(strncmp(command, "POST /", 6) == 0)
        executeHTTPrequest(command + 6, HTTP_POST);
    else if(strncmp(command, "DELETE /", 8) == 0)
        executeHTTPrequest(command + 8, HTTP_DELETE);
#endif
    else if(!httpMode) goto EXEC_COMMANDLINE;
    return;
    }

if(httpMode) goto RETURN_BATCHMODE;

EXEC_COMMANDLINE:
if(noPromptMode == FALSE && *command == '!' && *(command + 1) != ' ' && strlen(command) > 1)
    {
    if(system(command + 1)) return; /* avoid stupid compiler warning */
    return;
    }
    
if(cmdStream != NULL && batchMode)
    {
    openStrStream(cmdStream, 1024, TRUE);
    for(;;)
        {
        if(isTTY) 
            {
            cmd = getCommandLine(TRUE, &len);
            if(len > (MAX_COMMAND_LINE - 3))
                len = MAX_COMMAND_LINE - 3;
            memcpy(buff, cmd, len);
            memcpy(buff + len, LINE_FEED, LINE_FEED_LEN);
            buff[len + LINE_FEED_LEN] = 0; 
            free(cmd);
            }
        else
            if(fgets(buff, MAX_COMMAND_LINE - 1, IOchannel) == NULL) break;
        if( (memcmp(buff, "[/cmd]", 6) == 0 && batchMode == 2) || 
                (batchMode == 1 && (*buff == '\n' || *buff == '\r' || *buff == 0)))
            {
            if(logTraffic) 
                writeLog(cmdStream->buffer, 0);
            makeStreamFromString(&stream, cmdStream->buffer);
            evaluateStream(&stream, outDevice, 0);
            return;
            }
        writeStreamStr(cmdStream, buff, 0);
        }
    closeStrStream(cmdStream);
RETURN_BATCHMODE:
    if(!daemonMode)  exit(1);
    if(IOchannel != NULL) fclose(IOchannel);
#ifndef LIBRARY
    setupServer(1);
#endif
    return;
    }

if(logTraffic == LOG_LESS) writeLog(command, TRUE);
prettyPrintLength = 0;

makeStreamFromString(&stream, command);
evaluateStream(&stream, outDevice, 0);
}

char * processCommandEvent(char * command)
{
CELL * result;

if(executeSymbol(commandEvent, stuffString(command), &result) == CELL_STRING)
    {
    pushResult(result);
    command = (char *)result->contents;
    }

return(command);
}

/*
void printResultStack()
{
printf("result stack:\n");
while(resultStackIdx > resultStack)
    {
    --resultStackIdx;
    printCell(*resultStackIdx, TRUE, OUT_CONSOLE);
    printf("\n");
    }
printf("\n");
}
*/

/* used for loadFile() and and executeCommandLine() */
CELL * evaluateStream(STREAM * stream, UINT outDevice, int flag)
{
CELL * program;
CELL * eval = nilCell;
CELL * xlate;
UINT * resultIdxSave = resultStackIdx;
int result = TRUE;

while(result)
    {
    pushResult(program = getCell(CELL_QUOTE));
    result = compileExpression(stream, program);
    if(readerEvent != nilSymbol && result)
        {
        --resultStackIdx; /* program cell consumed by executeSymbol() */
        executeSymbol(readerEvent, program, &xlate);
        pushResult(program = makeCell(CELL_QUOTE, (UINT)xlate));
        }
    if(result)
        {
        if(flag && eval != nilCell) deleteList(eval);
        eval = evaluateExpression((CELL *)program->contents);
        if(outDevice != 0 && !evalSilent) 
            {
            printCell(eval, TRUE, outDevice);
            varPrintf(outDevice, "\n");
            if(logTraffic == LOG_MORE)
                {
                writeLog("-> ", 0);
                printCell(eval, TRUE, OUT_LOG);
                writeLog("", TRUE);
                }
#ifdef EMSCRIPTEN
            if(outDevice) fflush(NULL);
#endif
            }
        if(flag) eval = copyCell(eval);
        }
    cleanupResults(resultIdxSave);
    }

if(flag) return(eval);
return(NULL);
}


int executeSymbol(SYMBOL * symbol, CELL * params, CELL * * result)
{
CELL * program;
CELL * cell;
UINT * resultIdxSave = resultStackIdx;

if(symbol == nilSymbol || symbol == trueSymbol || symbol == NULL)   return(0);
pushResult(program = getCell(CELL_EXPRESSION));
cell = makeCell(CELL_SYMBOL, (UINT)symbol);
program->contents = (UINT)cell;
if(params != NULL) cell->next = params;

if(result == NULL)
    {
    evaluateExpression(program);
    cleanupResults(resultIdxSave);
    return(0);
    }

*result = copyCell(evaluateExpression(program));
cleanupResults(resultIdxSave);

return((*result)->type);
}


/* -------------------------- initialization -------------------- */

void initialize()
{
SYMBOL * symbol;
CELL * pCell;
char  symName[8];
int i;

/* build true and false cells */
nilCell = getCell(CELL_NIL);
nilCell->aux = nilCell->contents = (UINT)nilCell;
nilCell->next =  nilCell;

trueCell = getCell(CELL_TRUE);
trueCell->contents = (UINT)trueCell;

/* make first symbol, which is context MAIN */
currentContext = createRootContext("MAIN");

/* build symbols for primitives */
for(i = 0; primitive[i].name != NULL; i++)
    {
    pCell = getCell(CELL_PRIMITIVE);
    symbol = translateCreateSymbol(
        primitive[i].name, CELL_PRIMITIVE, mainContext, TRUE);
    symbol->contents = (UINT)pCell;
    symbol->flags = primitive[i].flags | SYMBOL_GLOBAL | SYMBOL_BUILTIN | SYMBOL_PROTECTED;
    pCell->contents = (UINT)primitive[i].function;
    pCell->aux = (UINT)symbol->name;
    }

/* build nil, true, * and ? symbols and others  */
nilSymbol = translateCreateSymbol("nil", CELL_NIL, mainContext, TRUE);
nilSymbol->contents = (UINT)nilCell;
trueSymbol = translateCreateSymbol("true", CELL_TRUE, mainContext, TRUE);
trueSymbol->contents = (UINT)trueCell;
starSymbol = translateCreateSymbol("*", CELL_PRIMITIVE, mainContext, TRUE);
plusSymbol = translateCreateSymbol("+", CELL_PRIMITIVE, mainContext, TRUE);
questionSymbol = translateCreateSymbol("?", CELL_NIL, mainContext, TRUE);
atSymbol = translateCreateSymbol("@", CELL_NIL, mainContext, TRUE);
argsSymbol = translateCreateSymbol("$args", CELL_NIL, mainContext, TRUE);
mainArgsSymbol = translateCreateSymbol("$main-args", CELL_NIL, mainContext, TRUE);
listIdxSymbol = translateCreateSymbol("$idx", CELL_NIL, mainContext, TRUE);
itSymbol = translateCreateSymbol("$it", CELL_NIL, mainContext, TRUE);
countSymbol = translateCreateSymbol("$count", CELL_NIL, mainContext, TRUE);
sysxSymbol = translateCreateSymbol("$x", CELL_NIL, mainContext, TRUE);
beginSymbol = translateCreateSymbol("begin", CELL_NIL, mainContext, TRUE);
expandSymbol = translateCreateSymbol("expand", CELL_NIL, mainContext, TRUE);

symbol = translateCreateSymbol("ostype", CELL_STRING, mainContext, TRUE);
symbol->flags = SYMBOL_GLOBAL | SYMBOL_BUILTIN | SYMBOL_PROTECTED;
symbol->contents = (UINT)stuffString(OSTYPE);

for(i = 0; i < MAX_REGEX_EXP; i++)
    {
    snprintf(symName, 8, "$%d", i);
    sysSymbol[i] = translateCreateSymbol(symName, CELL_NIL, mainContext, TRUE);
    sysSymbol[i]->flags |= SYMBOL_GLOBAL | SYMBOL_BUILTIN;
    }

currentFunc = errorEvent = timerEvent = promptEvent = commandEvent = transferEvent = readerEvent = nilSymbol;

trueSymbol->flags |= SYMBOL_GLOBAL | SYMBOL_BUILTIN | SYMBOL_PROTECTED;
nilSymbol->flags |= SYMBOL_GLOBAL | SYMBOL_BUILTIN | SYMBOL_PROTECTED;
questionSymbol->flags |= SYMBOL_GLOBAL | SYMBOL_BUILTIN | SYMBOL_PROTECTED;
atSymbol->flags |=  SYMBOL_GLOBAL | SYMBOL_BUILTIN | SYMBOL_PROTECTED;
argsSymbol->flags |= SYMBOL_GLOBAL | SYMBOL_BUILTIN | SYMBOL_PROTECTED;
mainArgsSymbol->flags |= SYMBOL_GLOBAL | SYMBOL_BUILTIN | SYMBOL_PROTECTED;
listIdxSymbol->flags |= SYMBOL_GLOBAL | SYMBOL_BUILTIN | SYMBOL_PROTECTED;
itSymbol->flags |= SYMBOL_GLOBAL | SYMBOL_BUILTIN | SYMBOL_PROTECTED;
countSymbol->flags |= SYMBOL_GLOBAL | SYMBOL_BUILTIN | SYMBOL_PROTECTED;
sysxSymbol->flags |= SYMBOL_GLOBAL | SYMBOL_BUILTIN;

countCell = stuffInteger(0);
countSymbol->contents = (UINT)countCell ;
argsSymbol->contents = (UINT)getCell(CELL_EXPRESSION);
objSymbol.contents = (UINT)nilCell;
objSymbol.context = mainContext;
objCell = nilCell;

/* init signal handlers */
for(i = 0; i < 32; i++)
  symHandler[i] = nilSymbol;

/* init system wide string streams */
openStrStream(&readLineStream, 16, 0);
openStrStream(&errorStream, MAX_LINE, 0);
}

void initStacks()
{
MAX_ENV_STACK = (MAX_CPU_STACK * 8 * 2);
MAX_RESULT_STACK = (MAX_CPU_STACK * 2);
if(envStack != NULL) freeMemory(envStack);
if(resultStack != NULL) freeMemory(resultStack);
if(lambdaStack != NULL) freeMemory(lambdaStack);
envStackIdx = envStack = (UINT *)allocMemory((MAX_ENV_STACK + 16) * sizeof(UINT));
envStackTop = envStack + MAX_ENV_STACK;
resultStackIdx = resultStack = (UINT *)allocMemory((MAX_RESULT_STACK + 16) * sizeof(UINT));
resultStackTop = resultStack + MAX_RESULT_STACK;
lambdaStackIdx = lambdaStack = (UINT *)allocMemory((MAX_RESULT_STACK + 16) * sizeof(UINT));
}

    
/* ------------------------- evaluate s-expression --------------------- */


CELL * evaluateExpression(CELL * cell)
{
#ifdef ISO_C90
CELL * result;
UINT * resultIdxSave = resultStackIdx;
CELL * args = NULL;
CELL * pCell = NULL;
SYMBOL * newContext = NULL;
SYMBOL * sPtr = NULL;
#endif

symbolCheck = NULL;
stringCell = NULL;

if(isSelfEval(cell->type))
    return(cell);

if(cell->type == CELL_SYMBOL || cell->type == CELL_CONTEXT)
    {
    symbolCheck = (SYMBOL *)cell->contents;
    return((CELL *)symbolCheck->contents);
    }

#ifndef ISO_C90
CELL * result;
UINT * resultIdxSave = resultStackIdx;
CELL * args = NULL;
CELL * pCell = NULL;
SYMBOL * newContext = NULL;
SYMBOL * sPtr = NULL;
#endif

switch(cell->type)
    {
    case CELL_QUOTE:
        return((CELL *)cell->contents);

    case CELL_EXPRESSION:
        args = (CELL *)cell->contents;
        if(++recursionCount > (int)MAX_CPU_STACK)
            fatalError(ERR_OUT_OF_CALL_STACK, args, 0);
        
        if(args->type == CELL_SYMBOL) /* precheck for speedup */
            {
            sPtr = (SYMBOL *)args->contents;
            newContext = sPtr->context;
            pCell =  (CELL*)sPtr->contents;
            }
        else if(args->type == CELL_DYN_SYMBOL)
            {
            sPtr = getDynamicSymbol(args);
            newContext = sPtr->context;
            pCell = (CELL *)sPtr->contents;
            }
        else
            { 
            pCell = evaluateExpression(args);
            newContext = currentContext;
            }

        if(traceFlag) traceEntry(cell, pCell, args);

            /* check for 'default' functor
            * allow function call with context name, i.e: (ctx)
            * assumes that a ctx:ctx contains a function
            */
        if(pCell->type == CELL_CONTEXT)
            {
            newContext = (SYMBOL *)pCell->contents;
            sPtr= translateCreateSymbol(newContext->name, CELL_NIL, newContext, TRUE);
            pCell = (CELL *)sPtr->contents;

            /* if the default functor contains nil, it works like a hash function */
            if(isNil(pCell))
                {
                result = evaluateNamespaceHash(args->next, newContext);
                break;
                }
            }

        /* pCell is evaluated op element */
        if(pCell->type == CELL_PRIMITIVE)
            {
            evalFunc = (CELL *(*)(CELL*))pCell->contents;
            result = evalFunc(args->next);
            evalFunc = NULL;
            break;
            }
        
        if(pCell->type == CELL_LAMBDA)
            { 
            pushLambda(cell);
            result = evaluateLambda((CELL *)pCell->contents, args->next, newContext); 
            --lambdaStackIdx; 
            break; 
            }
        
        if(pCell->type == CELL_FEXPR)
            { 
            pushLambda(cell);
            result = evaluateLambdaMacro((CELL *)pCell->contents, args->next, newContext);
            --lambdaStackIdx; 
            break;
            }
#ifndef EMSCRIPTEN
        /* simple ffi with CDECL or DLL and extended libffi */
        if(pCell->type & IMPORT_MASK) 
            {
            result = executeLibfunction(pCell, args->next);  
            break;
            }
#endif
        /* implicit indexing or resting for list, array or string 
        */
        if(args->next != nilCell)
            {
            /* implicit indexing array */
            if(pCell->type == CELL_EXPRESSION)
                {
                if(!sPtr) sPtr = symbolCheck;
                result = implicitIndexList(pCell, args->next);
                symbolCheck = sPtr;
                pushResultFlag = FALSE;
                }

            /* implicit indexing array */
            else if(pCell->type == CELL_ARRAY)
                {
                if(!sPtr) sPtr = symbolCheck;
                result = implicitIndexArray(pCell, args->next);
                symbolCheck = sPtr;
                pushResultFlag = FALSE;
                }   

            /* implicit indexing string */
            else if(pCell->type == CELL_STRING)
                {
                if(sPtr || (sPtr = symbolCheck))
                    {
                    result = implicitIndexString(pCell, args->next);
                    /* result is always a copy */
                    pushResult(result);
                    symbolCheck = sPtr;
                    --recursionCount;
                    return(result);
                    }
                else
                    result = implicitIndexString(pCell, args->next); 
                }

            /* implicit resting for lists and strings */
            else if(isNumber(pCell->type))
                result = implicitNrestSlice(pCell, args->next);
    
            else 
                result = errorProcExt(ERR_INVALID_FUNCTION, cell);                              
            } /* implixit indexing, resting on lists and strings */
        else 
            result = errorProcExt(ERR_INVALID_FUNCTION, cell);
        break;

    case CELL_DYN_SYMBOL:
        symbolCheck = getDynamicSymbol(cell);
        return((CELL *)symbolCheck->contents);
        
    default:
        result = nilCell;
    }

if(pushResultFlag) 
    {
    if(resultStackIdx > resultStackTop)
        fatalError(ERR_OUT_OF_CALL_STACK, pCell, 0);

    while(resultStackIdx > resultIdxSave)
        deleteList(popResult());

    pushResult(result);
    }
else 
    pushResultFlag = TRUE;

if(traceFlag) traceExit(result, cell, pCell, args);
--recursionCount;
return(result);
}


CELL *  evaluateExpressionSafe(CELL * cell, int * errNo)
{
jmp_buf errorJumpSave;
CELL * result;

memcpy(errorJumpSave, errorJump, sizeof(jmp_buf));
if((*errNo = setjmp(errorJump)) != 0)
    {
    memcpy(errorJump, errorJumpSave, sizeof(jmp_buf));
    return(NULL);
    }

result = evaluateExpression(cell);
memcpy(errorJump, errorJumpSave, sizeof(jmp_buf));
return(result);
}


CELL * evaluateNamespaceHash(CELL * args, SYMBOL * newContext)
{   
SYMBOL * sPtr;
CELL * pCell;

pCell = evaluateExpression(args);
if(pCell->type == CELL_STRING || isNumber(pCell->type))
    {
    /* set contents */
    if(args->next != nilCell)
        {
        sPtr = makeSafeSymbol(pCell, newContext, TRUE);
        
        itSymbol->contents = sPtr->contents; 
        /* itSymbol may occur in evaluateExpression() */
        itSymbol->contents = (UINT)copyCell(evaluateExpression(args->next));
        deleteList((CELL *)sPtr->contents);
        sPtr->contents = itSymbol->contents;
        itSymbol->contents = (UINT)nilCell;
        
        if(isNil((CELL *)sPtr->contents))
            {
            deleteAndFreeSymbol(sPtr, FALSE);
            return(nilCell);
            }

        symbolCheck = sPtr;
        pushResultFlag = FALSE;
        return((CELL *)sPtr->contents);
        }
    /* get contents */
    else 
        {
        sPtr = makeSafeSymbol(pCell, newContext, FALSE);
        if(sPtr == NULL)
            return(nilCell);
        else
            {
            symbolCheck = sPtr;
            pushResultFlag = FALSE;
            return((CELL *)sPtr->contents);
            }
        }
    }
/* create Tree from association list */
else if(pCell->type == CELL_EXPRESSION)
    {
    args = (CELL *)pCell->contents;
    while(args->type == CELL_EXPRESSION)
        {
        pCell = (CELL *)args->contents;
        if(pCell->type == CELL_STRING || isNumber(pCell->type))
            {
            sPtr = makeSafeSymbol(pCell, newContext, TRUE);
            deleteList((CELL *)sPtr->contents);
            sPtr->contents = (UINT)copyCell(pCell->next);
            }
        args = args->next;
        }
    return(stuffSymbol(newContext));
    }
/* return association list */
else if(pCell->type == CELL_NIL)
    return(associationsFromTree(newContext));

return(errorProcExt(ERR_INVALID_PARAMETER, pCell));
}


/* a symbol belonging to a dynamic context
   the parent context symbol points to the real context  
   cell->contents -> name str of this symbol
   cell->aux -> symbol var which holds context (dynamic) 
   ((SYMBOL*)cell->aux)->contents -> context cell
 */
SYMBOL * getDynamicSymbol(CELL * cell)
{
CELL * contextCell;

contextCell = (CELL *)((SYMBOL *)cell->aux)->contents;
if(contextCell->type != CELL_CONTEXT)
    fatalError(ERR_CONTEXT_EXPECTED, stuffSymbol((SYMBOL*)cell->aux), TRUE);

return(translateCreateSymbol( 
        (char*)cell->contents, /* name of dyn symbol */
        CELL_NIL,
        (SYMBOL*)contextCell->contents, /* contextPtr */
        TRUE));
}


void cleanupResults(UINT * from)
{
while(resultStackIdx > from)
    deleteList(popResult());
}

/* -------------------- evaluate lambda function ----------------------- */

CELL * evaluateLambda(CELL * localLst, CELL * arg, SYMBOL * newContext)
{
CELL * local;
CELL * result = nilCell;
CELL * cell;
SYMBOL * symbol;
SYMBOL * contextSave;
UINT * resultIdxSave;
int localCount = 1; /* 1 for $args */

if(envStackIdx > envStackTop)
    return(errorProc(ERR_OUT_OF_ENV_STACK));

if(localLst->type != CELL_EXPRESSION)
    return(errorProcExt(ERR_INVALID_LAMBDA, localLst));

/* evaluate arguments */
if(arg != nilCell)
    {
    /* this symbol precheck does 10% speed improvement on lambdas  */
    if(arg->type == CELL_SYMBOL)
        cell = result = copyCell((CELL*)((SYMBOL *)arg->contents)->contents);
    else
        cell = result = copyCell(evaluateExpression(arg));
       
    while((arg = arg->next) != nilCell)
        {
        if(arg->type == CELL_SYMBOL)
            cell = cell->next = copyCell((CELL*)((SYMBOL *)arg->contents)->contents);
        else
            cell = cell->next = copyCell(evaluateExpression(arg));
        }
    }

/* change to new context */
contextSave = currentContext;
currentContext = newContext;

/* save environment and get parameters */
local = (CELL*)localLst->contents;
for(;;)
    {
    if(local->type == CELL_SYMBOL)
        symbol = (SYMBOL *)local->contents;
    /* get default parameters */
    else if(local->type == CELL_EXPRESSION)
        {
        cell = (CELL *)local->contents;
        if(cell->type == CELL_SYMBOL)
            {
            symbol = (SYMBOL *)cell->contents;
            if(result == nilCell)
                result = copyCell(evaluateExpression(cell->next));
            }
        else break;
        }
    else break;

    if(isProtected(symbol->flags))
        return(errorProcExt(ERR_SYMBOL_PROTECTED, local));

    /* save symbol environment */
    pushEnvironment(symbol->contents);
    pushEnvironment((UINT)symbol);

    /* fill local symbols */
    if(result == nilCell) result = copyCell(nilCell);
    symbol->contents = (UINT)result;

    cell = result;
    result = result->next;

    /* unlink list */
    cell->next = nilCell;

    local = local->next;
    localCount++;
    }

/* put unassigned args in protected $args */
pushEnvironment(argsSymbol->contents);
pushEnvironment((UINT)argsSymbol);
argsSymbol->contents = (UINT)makeCell(CELL_EXPRESSION, (UINT)result);

/* get contents for (self), is nil if no ancestor caller is colon : */
objSymbol.contents = (UINT)objCell;

#ifdef FOOP_DEBUG
printf("objCell in lambda:");
printCell(objCell, TRUE, OUT_CONSOLE);
printf(" context:%s\n", currentContext->name);
#endif

/* evaluate body expressions */
resultIdxSave = resultStackIdx;
result = nilCell;
while( (localLst = localLst->next) != nilCell)
    {
    while(resultStackIdx > resultIdxSave)
        deleteList(popResult());
    result = evaluateExpression(localLst);
    }
result = copyCell(result);

/* restore symbols used as locals */
while(localCount--)
    {
    symbol = (SYMBOL *)popEnvironment();
    deleteList((CELL *)symbol->contents);
    symbol->contents = popEnvironment();
    }

currentContext = contextSave;
symbolCheck = NULL;
stringCell = NULL;
return(result);
}


CELL * evaluateLambdaMacro(CELL * localLst, CELL * arg, SYMBOL * newContext)
{
CELL * local;
CELL * result = nilCell;
CELL * cell;
SYMBOL * symbol;
SYMBOL * contextSave;
UINT * resultIdxSave;
int localCount = 1; /* for $args */

if(envStackIdx > envStackTop)
    return(errorProc(ERR_OUT_OF_ENV_STACK));

if(localLst->type != CELL_EXPRESSION)
    return(errorProcExt(ERR_INVALID_MACRO, localLst));

local = (CELL *)localLst->contents;

contextSave = currentContext;
currentContext = newContext;

/* save environment and get parameters */
while (TRUE)
  {
  if(local->type == CELL_SYMBOL)
    symbol = (SYMBOL *)local->contents;
  /* get default parameters */
  else if(local->type == CELL_EXPRESSION)
        {
        if(((CELL*)local->contents)->type == CELL_SYMBOL)
            {
            cell = (CELL *)local->contents;
            if(cell->type == CELL_SYMBOL)
                {
                symbol = (SYMBOL *)cell->contents;
                if(arg == nilCell)
                    arg = evaluateExpression(cell->next);
                }
            else break;
            }
        else break;
        }
  else break;

  if(isProtected(symbol->flags))
    return(errorProcExt(ERR_SYMBOL_PROTECTED, local));

  pushEnvironment(symbol->contents);
  pushEnvironment((UINT)symbol);
  symbol->contents = (UINT)copyCell(arg);
  local = local->next;
  arg = arg->next;
  localCount++;
  }

/* put unassigned args in $args */
pushEnvironment(argsSymbol->contents);
pushEnvironment((UINT)argsSymbol);
argsSymbol->contents = (UINT)makeCell(CELL_EXPRESSION, (UINT)copyList(arg));

/* evaluate body expressions */
resultIdxSave = resultStackIdx;
while((localLst = localLst->next) != nilCell)
    {
    while(resultStackIdx > resultIdxSave)
        deleteList(popResult());
    result = evaluateExpression(localLst);
    }
result = copyCell(result);

/* restore symbols used as locals */
while(localCount--)
    {
    symbol = (SYMBOL *)popEnvironment();
    deleteList((CELL *)symbol->contents);
    symbol->contents = popEnvironment();
    }

currentContext = contextSave;   
symbolCheck = NULL;
stringCell = NULL;
return(result);
}


/* -------------- list/cell creation/deletion routines ---------------- */


CELL * stuffInteger(UINT contents)
{
CELL * cell;

if(firstFreeCell == NULL) allocBlock();
cell = firstFreeCell;
firstFreeCell = cell->next;
++cellCount;

cell->type = CELL_LONG;
cell->next = nilCell;
cell->aux = (UINT)nilCell;
cell->contents = contents;

return(cell);
}

#ifndef NEWLISP64
CELL * stuffInteger64(INT64 contents)
{
CELL * cell;

if(firstFreeCell == NULL) allocBlock();
cell = firstFreeCell;
firstFreeCell = cell->next;
++cellCount;

cell->type = CELL_INT64;
cell->next = nilCell;

*(INT64 *)&cell->aux = contents;
return(cell);
}
#endif

CELL * stuffIntegerList(int argc, ...)
{
CELL * cell;
CELL * list;
va_list ap;

va_start(ap, argc);

list = makeCell(CELL_EXPRESSION, (UINT)stuffInteger(va_arg(ap, UINT)));
cell = (CELL *)list->contents;

while(--argc)
    cell = cell->next = stuffInteger(va_arg(ap, UINT));

va_end(ap);

return(list);
}

#ifdef BIGINT
CELL * stuffBigint(char * token)
{
int len;
CELL * cell;

cell = getCell(CELL_BIGINT);
cell->contents = (UINT)strToBigint(token, strlen(token), &len);
cell->aux = len + 1;

return(cell);
}
#endif

/* only safe for text content */
CELL * stuffString(char * string)
{
CELL * cell;

cell = getCell(CELL_STRING);
cell->aux = strlen(string) + 1;
cell->contents = (UINT)allocMemory((UINT)cell->aux);

memcpy((void *)cell->contents, string, (UINT)cell->aux);
return(cell);
}

/* safe for binary content */
CELL * stuffStringN(char * string, int len)
{
CELL * cell;

cell = getCell(CELL_STRING);
cell->aux = len + 1;
cell->contents = (UINT)allocMemory((UINT)cell->aux);
memcpy((void *)cell->contents, string, len);
*(char*)(cell->contents + len) = 0;
return(cell);
}

CELL * stuffFloat(double floatVal)
{
CELL * cell;

cell = getCell(CELL_FLOAT);
#ifndef NEWLISP64
*(double *)&cell->aux = floatVal;
#else
*(double *)&cell->contents = floatVal;
#endif
return(cell);
}

CELL * stuffSymbol(SYMBOL * sPtr)
{
CELL * cell;

cell = getCell(CELL_SYMBOL);
cell->contents = (UINT)sPtr;
return(cell);
}

/* appends to a list, the list must have be either optimized
   with list->aux pointing to the last cell, or list->aux must
   contain nilCell and be empty
*/

void addList(CELL * list, CELL * new)
{
if(list->aux == (UINT)nilCell)
    list->contents = (UINT)new;
else
    ((CELL *)list->aux)->next = new;
list->aux = (UINT)new;
}

ssize_t convertNegativeOffset(ssize_t offset, CELL * list)
{
int len = 0;

while(list != nilCell)
    {
    ++len;
    list = list->next;
    }
offset = len + offset;
if(offset < 0) 
    errorProc(ERR_LIST_INDEX_INVALID);

return(offset);
}

/* ------------------------ creating and freeing cells ------------------- */

CELL * getCell(int type)
{
CELL * cell;

if(firstFreeCell == NULL) allocBlock();
cell = firstFreeCell;
firstFreeCell = cell->next;
++cellCount;

cell->type = type;
cell->next = nilCell;
cell->aux = (UINT)nilCell;
cell->contents = (UINT)nilCell;

return(cell);
}


CELL * makeCell(int type, UINT contents)
{
CELL * cell;

if(firstFreeCell == NULL) allocBlock();
cell = firstFreeCell;
firstFreeCell = cell->next;
++cellCount;

cell->type = type;
cell->next = nilCell;
cell->aux = (UINT)nilCell;
cell->contents = contents;

return(cell);
}


CELL * makeStringCell(char * contents, size_t size)
{
CELL * cell;

if(firstFreeCell == NULL) allocBlock();
cell = firstFreeCell;
firstFreeCell = cell->next;
++cellCount;

cell->type = CELL_STRING;
cell->next = nilCell;
cell->aux = (UINT)size + 1;
cell->contents = (UINT)contents;

return(cell);
}

CELL * copyCell(CELL * cell)
{
#ifdef ISO_C90
CELL * newCell;
CELL * list;
UINT len;
#endif

/* avoids copy if cell on resultStack */
if(cell == (CELL *)*(resultStackIdx))
    {
    if(cell != nilCell && cell != trueCell)
        return(popResult());
    }

#ifndef ISO_C90
CELL * newCell;
CELL * list;
UINT len;
#endif

if(firstFreeCell == NULL) allocBlock();
newCell = firstFreeCell;
firstFreeCell = newCell->next;
++cellCount;

newCell->type = cell->type;
newCell->next = nilCell;
newCell->aux = cell->aux;
newCell->contents = cell->contents;

if(isEnvelope(cell->type))
    {
    if(cell->type == CELL_ARRAY)
        newCell->contents = (UINT)copyArray(cell);
    else /* normal list expression */
        {
        if(cell->contents != (UINT)nilCell) 
            {
            newCell->contents = (UINT)copyCell((CELL *)cell->contents);
            list = (CELL *)newCell->contents;
            cell = (CELL *)cell->contents;
            while((cell = cell->next) != nilCell)
                list = list->next = copyCell(cell);
            newCell->aux = (UINT)list;  /* last element optimization */
            }
        }
    }
else if(cell->type == CELL_STRING)
    {
    newCell->contents = (UINT)allocMemory((UINT)cell->aux);
    memcpy((void *)newCell->contents, (void*)cell->contents, (UINT)cell->aux);
    }
else if(cell->type == CELL_DYN_SYMBOL)
    {
    len = strlen((char *)cell->contents);
    newCell->contents = (UINT)allocMemory(len + 1);
    memcpy((char *)newCell->contents, (char *)cell->contents, len + 1);
    }
#ifdef BIGINT
else if(cell->type == CELL_BIGINT)
    {
    newCell->contents = (UINT)allocMemory((UINT)cell->aux * sizeof(int));
    memcpy((void *)newCell->contents, (void*)cell->contents, (UINT)cell->aux * sizeof(int));
    }
#endif

return(newCell);
}


/* this routine must be called with the list head
   if copying with envelope call copyCell() instead */
CELL * copyList(CELL * cell)
{
#ifdef ISO_C90
CELL * firstCell;
CELL * newCell;
#endif

if(cell == nilCell) 
    {
    lastCellCopied = nilCell;
    return(cell);
    }

#ifndef ISO_C90
CELL * firstCell;
CELL * newCell;
#endif

firstCell = newCell = copyCell(cell);

while((cell = cell->next) != nilCell)
    newCell = newCell->next = copyCell(cell);
    
lastCellCopied = newCell;
return(firstCell);
}


/* for deleting lists _and_ cells */
void deleteList(CELL * cell)
{
CELL * next;

while(cell != nilCell)
    {
    if(isEnvelope(cell->type))
        {
        if(cell->type == CELL_ARRAY)
            deleteArray(cell);
        else
            deleteList((CELL *)cell->contents);
        }

    else if(cell->type == CELL_STRING || cell->type == CELL_DYN_SYMBOL 
#ifdef BIGINT
                || cell->type == CELL_BIGINT
#endif
            )
        freeMemory( (void *)cell->contents);
    
    /* free cell changes in 10.6.3 */
    if(cell == nilCell || cell == trueCell) 
        cell = cell->next;
    else    
        {
        next = cell->next;
        cell->type = CELL_FREE;
        cell->next = firstFreeCell;
        firstFreeCell = cell;
        --cellCount;
        cell = next;
        }

    }
}

/* --------------- cell / memory allocation and deallocation -------------

   allthough (MAC_BLOCK + 1) are allocated only MAX_BLOCK cells
   are used. The last cell only serves as a pointer to the next block
*/

CELL * cellMemory = NULL;/* start of cell memory */
CELL * cellBlock = NULL; /* the last block allocated */

void allocBlock()
{
int i;

if(cellCount > MAX_CELL_COUNT - MAX_BLOCK)  
    {
    printErrorMessage(ERR_NOT_ENOUGH_MEMORY, NULL, 0);
    exit(ERR_NOT_ENOUGH_MEMORY);
    }

if(cellMemory == NULL)
    {
    cellMemory = (CELL *)allocMemory((MAX_BLOCK + 1) * sizeof(CELL));
    cellBlock = cellMemory;
    }
else
    {
    (cellBlock + MAX_BLOCK)->next = 
        (CELL *)allocMemory((MAX_BLOCK + 1) * sizeof(CELL));
    cellBlock = (cellBlock + MAX_BLOCK)->next;
    }

for(i = 0; i < MAX_BLOCK; i++)
    {
    (cellBlock + i)->type = CELL_FREE;
    (cellBlock + i)->next = (cellBlock + i + 1);
    }
(cellBlock + MAX_BLOCK - 1)->next = NULL;
(cellBlock + MAX_BLOCK)->next = NULL;
firstFreeCell = cellBlock;
++ blockCount;
}


/* Return unused blocks to OS, this is normally only called under error 
   conditions but can also be forced issuing a (reset nil)

   Older versions also did a complete cell mark and sweep. Now all
   error conditons clean out allocated cells and memory before doing
   the longjmp().
*/

/* not used, not tested
void freeAllCells()
{
CELL * blockPtr = cellMemory;
int i, j;

for(i = 0; i < blockCount; i++)
    {
    for(j = 0; j < MAX_BLOCK; j++)
        {
        if(*(UINT *)blockPtr != CELL_FREE)
            {
            deleteList(blockPtr);
            }
        blockPtr++;
        }
    blockPtr = blockPtr->next;
    }        
}
*/

void freeCellBlocks()
{
CELL * blockPtr;
CELL * lastBlockPtr = NULL;
CELL * lastFreeCell = NULL;
CELL * prevLastFreeCell;
CELL * prevCellBlock;
int i, freeCount;

cellBlock = blockPtr = cellMemory;
firstFreeCell = NULL;
while(blockPtr != NULL)
    {
    prevLastFreeCell = lastFreeCell;
    prevCellBlock = cellBlock;
    cellBlock = blockPtr;
    for(i = freeCount = 0; i < MAX_BLOCK; i++)
        {
        if(*(UINT *)blockPtr == CELL_FREE)
            {
            if(firstFreeCell == NULL)
                firstFreeCell = lastFreeCell = blockPtr;
            else
                {
                lastFreeCell->next = blockPtr;
                lastFreeCell = blockPtr;
                }
            freeCount++;
            }
        blockPtr++;
        }
    if(freeCount == MAX_BLOCK)
        {
        lastFreeCell = prevLastFreeCell;
        cellBlock = prevCellBlock;
        blockPtr = blockPtr->next;
        freeMemory(lastBlockPtr->next);
        --blockCount;
        lastBlockPtr->next = blockPtr;
        }
    else 
        {
        lastBlockPtr = blockPtr;
        blockPtr = blockPtr->next;
        }
    }
lastFreeCell->next = NULL;
}


/* OS memory allocation */

void * allocMemory(size_t nbytes)
{
void * ptr;

if( (ptr = (void *)malloc(nbytes)) == NULL)
    fatalError(ERR_NOT_ENOUGH_MEMORY, NULL, 0);

return(ptr);
}

void * callocMemory(size_t nbytes)
{
void * ptr;

if( (ptr = (void *)calloc(nbytes, 1)) == NULL)
    fatalError(ERR_NOT_ENOUGH_MEMORY, NULL, 0);

return(ptr);
}

void * reallocMemory(void * prevPtr, UINT size)
{
void * ptr;

if( (ptr = realloc(prevPtr, size)) == NULL)
    fatalError(ERR_NOT_ENOUGH_MEMORY, NULL, 0);

return(ptr);
}

/* -------------------------- I/O routines ------------------------------ */

UINT printDevice;
void prettyPrint(UINT device);

void varPrintf(UINT device, char * format, ...)
{
char * buffer;
va_list argptr;
 
va_start(argptr,format);

/* defined in nl-filesys.c if not in libc */
vasprintf(&buffer, format, argptr); 

prettyPrintLength += strlen(buffer);
switch(device)
    {
    case OUT_NULL:
        return;

    case OUT_DEVICE:
        if(printDevice != 0)
            {
            if(write(printDevice, buffer, strlen(buffer)) < 0)
                fatalError(ERR_IO_ERROR, 0, 0);
            break;
            }
    case OUT_CONSOLE:
#ifdef LIBRARY
        if(!newlispLibConsoleFlag)
            {
            writeStreamStr(&libStrStream, buffer, 0);
            freeMemory(buffer);
            fflush(NULL);
            return;
            }
        else
#endif
        if(IOchannel == stdin)
            {
            printf("%s", buffer);
            if(!isTTY) fflush(NULL);
            }
        else if(IOchannel != NULL) 
            fprintf(IOchannel, "%s", buffer);
        break;
    case OUT_LOG:
        writeLog(buffer, 0);
        break;
    default:
        writeStreamStr((STREAM *)device, buffer, 0);
        break;
    }

freeMemory(buffer);

va_end(argptr);
}


void printCell(CELL * cell, UINT printFlag, UINT device)
{
SYMBOL * sPtr;
SYMBOL * sp;
#ifdef BIGINT
char * ptr;
#endif

if(cell == debugPrintCell)
    varPrintf(device, "%s", debugPreStr);

switch(cell->type)
    {
    case CELL_NIL:
        varPrintf(device, "nil"); break;

    case CELL_TRUE:
        varPrintf(device, "true"); break;
    
    case CELL_LONG:
        varPrintf(device,"%"PRIdPTR, cell->contents); break;
#ifndef NEWLISP64
    case CELL_INT64:
        varPrintf(device,"%"PRId64, *(INT64 *)&cell->aux); break;
#endif /* NEWLISP64 */
#ifdef BIGINT
    case CELL_BIGINT:
        ptr = bigintToDigits((int *)cell->contents, cell->aux - 1, 48, NULL);        
        varPrintf(device, "%sL", ptr);
        free(ptr);
        break;
#endif
    case CELL_FLOAT:
#ifndef NEWLISP64
        varPrintf(device, prettyPrintFloat ,*(double *)&cell->aux);
#else
        varPrintf(device, prettyPrintFloat ,*(double *)&cell->contents);
#endif
        break;

    case CELL_STRING:
        if(printFlag)
            printString((char *)cell->contents, device, cell->aux - 1);
        else
            varPrintf(device,"%s",cell->contents);
        break;
    
    case CELL_SYMBOL:
    case CELL_CONTEXT:
        sPtr = (SYMBOL *)cell->contents;
        if(sPtr->context != currentContext  
            /* if not global or global overwritten in current context */
            && (!(sPtr->flags & SYMBOL_GLOBAL) || (lookupSymbol(sPtr->name, currentContext)))
            && (symbolType(sPtr) != CELL_CONTEXT || 
                (SYMBOL *)((CELL*)sPtr->contents)->contents != sPtr)) /* context var */
            {
            varPrintf(device,"%s:%s", (char*)((SYMBOL*)sPtr->context)->name, sPtr->name);
            break;
            }
        /* overwriting global in MAIN */
        if(sPtr->context == currentContext
            && currentContext != mainContext
            && ((sp = lookupSymbol(sPtr->name, mainContext)) != NULL)
            && (sp->flags & SYMBOL_GLOBAL) )
            {
            varPrintf(device,"%s:%s", currentContext->name, sPtr->name);
            break;
            }

        varPrintf(device,"%s",sPtr->name);
        break;
    
    case CELL_PRIMITIVE:
        varPrintf(device,"%s@%lX", (char *)cell->aux, cell->contents);
        break;
    case CELL_IMPORT_CDECL:
    case CELL_IMPORT_FFI:
#if defined(WINDOWS) || defined(CYGWIN)
    case CELL_IMPORT_DLL:
#endif

#ifdef FFI
        if(cell->type == CELL_IMPORT_FFI)
            varPrintf(device,"%s@%lX", (char *)((FFIMPORT *)cell->aux)->name,
                                                 cell->contents);
        else
            varPrintf(device,"%s@%lX", (char *)cell->aux, cell->contents);
#else
        varPrintf(device,"%s@%lX", (char *)cell->aux, cell->contents);
#endif
        break;
    
    case CELL_QUOTE:
        varPrintf(device, "'");
        prettyPrintFlags |= PRETTYPRINT_DOUBLE;
        printCell((CELL *)cell->contents, printFlag, device);
        break;
    
    case CELL_EXPRESSION:
    case CELL_LAMBDA:
    case CELL_FEXPR:
        printExpression(cell, device);
        break;

    case CELL_DYN_SYMBOL:
        varPrintf(device, "%s:%s", ((SYMBOL*)cell->aux)->name, (char*)cell->contents);
        break;                                                                                                                                                                             
    case CELL_ARRAY:
        printArray(cell, device);
        break;

    default:
        varPrintf(device,"?");
    }

if(cell == debugPrintCell)
    varPrintf(device, "%s", debugPostStr);

prettyPrintFlags &= ~PRETTYPRINT_DOUBLE;
}


void printString(char * str, UINT  device, int size)
{
char chr;

if(size >= MAX_STRING)
    {
    varPrintf(device, "[text]");
    while(size--) varPrintf(device, "%c", *str++);
    varPrintf(device, "[/text]");
    return;
    }

varPrintf(device,"\"");
while(size--)
    {
    switch(chr = *str++)
        {
        case '\b': varPrintf(device,"\\b"); break;
        case '\f': varPrintf(device,"\\f"); break;
        case '\n': varPrintf(device,"\\n"); break;
        case '\r': varPrintf(device,"\\r"); break;
        case '\t': varPrintf(device,"\\t"); break;
        case '\\': varPrintf(device,"\\\\"); break;
        case '"': varPrintf(device,"\\%c",'"'); break;
        default: 
            if((unsigned char)chr < 32 || (stringOutputRaw && (unsigned char)chr > 126))
                            varPrintf(device,"\\%03u", (unsigned char)chr);
                        else
                varPrintf(device,"%c",chr); break;
        }
    }
varPrintf(device,"\"");
}


void printExpression(CELL * cell, UINT device)
{
CELL * item;
int i, pFlags;

item = (CELL *)cell->contents;


if(prettyPrintPars <= prettyPrintCurrent || 
    prettyPrintLength > prettyPrintMaxLength)
    prettyPrint(device);

if(cell->type == CELL_LAMBDA) 
    {
    varPrintf(device, "(lambda ");
    ++prettyPrintPars;
    }
else if(cell->type == CELL_FEXPR) 
    {
    varPrintf(device, "(lambda-macro ");
    ++prettyPrintPars;
    }
else 
    {
    if(isSymbol(item->type))
        {
        if(item->type == CELL_SYMBOL)
             pFlags = ((SYMBOL *)item->contents)->flags;
        else
             pFlags = 0;

        if((pFlags & PRINT_TYPE_MASK) != 0)
            {
            prettyPrint(device);
            varPrintf(device, "(");
            ++prettyPrintPars;
            for(i = 0; i < (pFlags & PRINT_TYPE_MASK); i++)
                {
                if(item == nilCell) 
                    {prettyPrintFlags |= PRETTYPRINT_DOUBLE; break;}
                printCell(item, TRUE, device);
                item = item->next;
                if(item != nilCell) varPrintf(device," ");
                else prettyPrintFlags |= PRETTYPRINT_DOUBLE;
                }
            prettyPrint(device);
            }
        else 
            {
            varPrintf(device, "(");
            ++prettyPrintPars;
            }
        }
    else 
        {
        varPrintf(device, "(");
        ++prettyPrintPars;
        }
    }


while(item != nilCell)
    {
    if(prettyPrintLength > prettyPrintMaxLength) prettyPrint(device);
    printCell(item, TRUE, device);
    item = item->next;
    if(item != nilCell) varPrintf(device," ");
    }

varPrintf(device,")");
--prettyPrintPars;
}


void prettyPrint(UINT device)
{
int i;

if(prettyPrintFlags) return;

if(prettyPrintPars > 0) 
    varPrintf(device, LINE_FEED);

for(i = 0; i < prettyPrintPars; i++) 
    varPrintf(device, "%s", prettyPrintTab);

prettyPrintLength = prettyPrintCurrent = prettyPrintPars;
prettyPrintFlags |= PRETTYPRINT_DOUBLE;
}


void printSymbol(SYMBOL * sPtr, UINT device)
{
CELL * cell;
CELL * list = NULL;
char * setStr;
size_t offset, len;

prettyPrintCurrent = prettyPrintPars = 1;
prettyPrintLength = 0;
prettyPrintFlags &= ~PRETTYPRINT_DOUBLE;

if(sPtr->flags & SYMBOL_PROTECTED)
    setStr = "(constant ";
else
    setStr = "(set ";

switch(symbolType(sPtr))
    {
    case CELL_PRIMITIVE:
    case CELL_IMPORT_CDECL:
    case CELL_IMPORT_FFI:
#if defined(WINDOWS) || defined(CYGWIN) 
    case CELL_IMPORT_DLL:
#endif
        break;
    case CELL_SYMBOL:
    case CELL_DYN_SYMBOL:
        varPrintf(device, "%s", setStr);
        printSymbolNameExt(device, sPtr);
        varPrintf(device,"'");
        printCell((CELL *)sPtr->contents, TRUE, device);
        varPrintf(device, ")");
        break;
    case CELL_ARRAY:
    case CELL_EXPRESSION:
        varPrintf(device, "%s", setStr);
        printSymbolNameExt(device, sPtr);
        cell = (CELL *)sPtr->contents;

        if(symbolType(sPtr) == CELL_ARRAY)
            {
            varPrintf(device, "(array ");
            printArrayDimensions(cell, device);
            varPrintf(device, "(flat ");
            list = cell = arrayList(cell, TRUE);
            }

        cell = (CELL *)cell->contents;

        varPrintf(device,"'(");
        prettyPrintPars = 2;
        if(cell->type == CELL_EXPRESSION) prettyPrint(device);
        while(cell != nilCell)
            {
            if(prettyPrintLength > prettyPrintMaxLength) 
                    prettyPrint(device);
            printCell(cell, TRUE, device);
            cell = cell->next;
            if(cell != nilCell) varPrintf(device, " ");
            }
        varPrintf(device, "))");
        if(symbolType(sPtr) == CELL_ARRAY)
            {
            deleteList(list);
            varPrintf(device ,"))");
            }
        break;
    case CELL_LAMBDA:
    case CELL_FEXPR:
        if(isProtected(sPtr->flags))
            {
            varPrintf(device, "%s%s%s", LINE_FEED, LINE_FEED, setStr);
            printSymbolNameExt(device, sPtr);
            printExpression((CELL *)sPtr->contents, device);
            varPrintf(device, ")");
            }
        else if (isGlobal(sPtr->flags))
            {
            printLambda(sPtr, device);
            varPrintf(device, "%s%s", LINE_FEED, LINE_FEED);
            printSymbolNameExt(device, sPtr);
            }
        else printLambda(sPtr, device);
        break;
    default:
        varPrintf(device, "%s", setStr);
        printSymbolNameExt(device, sPtr);
        cell = (CELL *)sPtr->contents;
        if(cell->type == CELL_STRING && cell->aux > MAX_STRING) /* size > 2047 */
            {
            varPrintf(device, "%s ", "(append ");
            offset = 0;
            while(offset < cell->aux - 1)
                {
                varPrintf(device, "%s  ", LINE_FEED); 
                len = (cell->aux - 1 - offset);
                len = len > 72 ? 72 : len;
                printString((char *)(cell->contents + offset), device, len); 
                offset += len;
                }
            varPrintf(device, "))");
            break; 
            }
        printCell(cell, TRUE, device);
        varPrintf(device, ")");
        break;
    }

varPrintf(device, "%s%s", LINE_FEED, LINE_FEED);

prettyPrintLength = prettyPrintPars = 0;
}


void printLambda(SYMBOL * sPtr, UINT device)
{
CELL * lambda;
CELL * cell;

lambda = (CELL *)sPtr->contents;
cell = (CELL *)lambda->contents;
if(cell->type == CELL_EXPRESSION)
    cell = (CELL *)cell->contents;

if(!isLegalSymbol(sPtr->name))
        {
        varPrintf(device, "(set (sym ");
        printString(sPtr->name, device, strlen(sPtr->name));
        varPrintf(device, " %s) ", ((SYMBOL*)sPtr->context)->name);
        printExpression((CELL *)sPtr->contents, device);
        varPrintf(device, ")");
        return;
        }
    
if(symbolType(sPtr) == CELL_LAMBDA)
    varPrintf(device, "(define (");
else 
    varPrintf(device, "(define-macro (");
prettyPrintPars += 2;

printSymbolName(device, sPtr);
varPrintf(device, " ");

while(cell != nilCell)
    {
    printCell(cell, TRUE, device);
    cell = cell->next;
    if(cell != nilCell) varPrintf(device, " ");
    }
varPrintf(device, ")");
--prettyPrintPars;
prettyPrint(device);

cell = (CELL *)lambda->contents;
while((cell = cell->next) != nilCell)
    {
    if(prettyPrintLength > prettyPrintMaxLength) prettyPrint(device);
    printCell(cell, TRUE, device);
    if(!(cell->type & ENVELOPE_TYPE_MASK) && cell->next != nilCell) varPrintf(device, " ");
    }

varPrintf(device, ")");
--prettyPrintPars;
}


void printSymbolName(UINT device, SYMBOL * sPtr)
{
SYMBOL * sp;

if(sPtr->context == currentContext)
    {
    if(*sPtr->name == *currentContext->name && strcmp(sPtr->name, currentContext->name) == 0)
        varPrintf(device, "%s:%s", sPtr->name, sPtr->name);

    else if(currentContext != mainContext 
        && ((sp = lookupSymbol(sPtr->name, mainContext)) != NULL)
        && (sp->flags &  SYMBOL_GLOBAL) )
        varPrintf(device, "%s:%s", currentContext->name, sPtr->name);
    else
        varPrintf(device,"%s", sPtr->name);
    }
else
    varPrintf(device,"%s:%s", 
        (char *)((SYMBOL*)sPtr->context)->name, sPtr->name);
}


void printSymbolNameExt(UINT device, SYMBOL * sPtr)
{
if(isGlobal(sPtr->flags))
    {
    varPrintf(device, "(global '");
    printSymbolName(device, sPtr);
    if(symbolType(sPtr) == CELL_LAMBDA || symbolType(sPtr) == CELL_FEXPR)
        varPrintf(device, ")");
    else varPrintf(device, ") ");
    }
else 
    {
    if(!isLegalSymbol(sPtr->name))
        {
        varPrintf(device, " (sym ");
        printString(sPtr->name, device, strlen(sPtr->name));
        varPrintf(device, " MAIN:%s) ", ((SYMBOL*)sPtr->context)->name);
        }
    else
        {
        varPrintf(device, "'");
        printSymbolName(device, sPtr);
        }
    varPrintf(device, " ");
    }
}


CELL * p_prettyPrint(CELL * params)
{
CELL * result;
char * str;
size_t len;

if(params != nilCell)
    params = getInteger(params, &prettyPrintMaxLength);
if(params != nilCell)
    {
    params = getStringSize(params, &str, &len, TRUE);
    prettyPrintTab = allocMemory(len + 1);
    memcpy(prettyPrintTab, str, len + 1);
    }
if(params != nilCell)
    {
    getStringSize(params, &str, &len, TRUE);
    prettyPrintFloat = allocMemory(len + 1);
    memcpy(prettyPrintFloat, str, len + 1);
    }

result = getCell(CELL_EXPRESSION);
addList(result, stuffInteger(prettyPrintMaxLength));
addList(result, stuffString(prettyPrintTab));
addList(result, stuffString(prettyPrintFloat));

return(result);
}



/* -------------------------- error handling --------------------------- */

char * errorMessage[] =
    {
    "",                             /* 0 */
    "not enough memory",            /* 1 */
    "environment stack overflow",   /* 2 */
    "call or result stack overflow",/* 3 */
    "problem accessing file",       /* 4 */
    "illegal token or expression",  /* 5 */
    "missing parenthesis",          /* 6 */
    "string token too long",        /* 7 */
    "missing argument",             /* 8 */
    "number or string expected",    /* 9 */
    "value expected",               /* 10 */
    "string expected",              /* 11 */
    "symbol expected",              /* 12 */
    "context expected",             /* 13 */
    "symbol or context expected",   /* 14 */
    "list expected",                /* 15 */
    "list or array expected",       /* 15 */
    "list or symbol expected",      /* 17 */
    "list or string expected",      /* 18 */
    "list or number expected",      /* 19 */
    "array expected",               /* 20 */
    "array, list or string expected", /* 21 */
    "lambda expected",              /* 22 */
    "lambda-macro expected",        /* 23 */
    "invalid function",             /* 24 */
    "invalid lambda expression",    /* 25 */
    "invalid macro expression",     /* 26 */
    "invalid let parameter list",   /* 27 */
    "problem saving file",          /* 28 */
    "division by zero",             /* 29 */
    "matrix expected",              /* 30 */ 
    "wrong dimensions",             /* 31 */
    "matrix is singular",           /* 32 */
    "invalid option",               /* 33 */
    "throw without catch",          /* 34 */
    "problem loading library",      /* 35 */
    "import function not found",    /* 36 */
    "symbol is protected",          /* 37 */
    "number out of range",          /* 38 */
    "regular expression",           /* 39 */
    "end of text [/text] tag",      /* 40 */
    "mismatch in number of arguments",  /* 41 */
    "problem in format string",     /* 42 */
    "data type and format don't match", /* 43 */
    "invalid parameter",            /* 44 */
    "invalid parameter: 0.0",       /* 45 */
    "invalid parameter: NaN",       /* 46 */
    "invalid UTF8 string",          /* 47 */
    "illegal parameter type",       /* 48 */
    "symbol not in MAIN context",   /* 49 */
    "symbol not in current context", /* 50 */
    "target cannot be MAIN",        /* 51 */
    "invalid list index",           /* 52 */
    "array index out of bounds",    /* 53 */
    "invalid string index",         /* 54 */
    "nesting level to deep",        /* 55 */
    "list reference changed",       /* 56 */
    "invalid syntax",               /* 57 */
    "user error",                   /* 58 */
    "user reset -",                 /* 59 */
    "received SIGINT -",            /* 60 */
    "function is not reentrant",    /* 61 */
    "not allowed on local symbol",  /* 62 */
    "no reference found",           /* 63 */
    "list is empty",                /* 64 */
    "I/O error",                    /* 65 */
    "no working directory found",   /* 66 */
    "invalid PID",                  /* 67 */
    "cannot open socket pair",      /* 68 */
    "cannot fork process",          /* 69 */
    "no comm channel found",        /* 70 */
    "ffi preparation failed",       /* 71 */
    "invalid ffi type",             /* 72 */
    "ffi struct expected",          /* 73 */
    "bigint type not applicable",   /* 74 */
    "not a number or infinite",     /* 75 */
    "cannot convert NULL to string",/* 76 */
    NULL
    };


void errorMissingPar(STREAM * stream)
{
char str[48]; 
snprintf(str, 40, "...%.40s", ((char *)((stream->ptr - stream->buffer) > 40 ? stream->ptr - 40 : stream->buffer)));
errorProcExt2(ERR_MISSING_PAR, stuffString(str));
}

CELL * errorProcAll(int errorNumber, CELL * expr, int deleteFlag)
{
if(!traceFlag) fatalError(errorNumber, expr, deleteFlag);
printErrorMessage(errorNumber, expr, deleteFlag);
return(nilCell);
}

CELL * errorProc(int errorNumber)
{
return(errorProcAll(errorNumber, NULL, 0));
}

/* extended error info in expr */
CELL * errorProcExt(int errorNumber, CELL * expr)
{
return(errorProcAll(errorNumber, expr, 0));
}

/* extended error info in expr, which has to be discarded after printing */
CELL * errorProcExt2(int errorNumber, CELL * expr)
{
return(errorProcAll(errorNumber, expr, 1));
}

CELL * errorProcArgs(int errorNumber, CELL * expr)
{
if(expr == nilCell) 
    return(errorProcExt(ERR_MISSING_ARGUMENT, NULL));

return(errorProcExt(errorNumber, expr));
}

void fatalError(int errorNumber, CELL * expr, int deleteFlag)
{
printErrorMessage(errorNumber, expr, deleteFlag);
#ifndef LIBRARY
closeTrace();
#endif
longjmp(errorJump, errorReg);
}

void printErrorMessage(UINT errorNumber, CELL * expr, int deleteFlag)
{
CELL * lambdaFunc;
CELL * lambdaExpr;
UINT * stackIdx = lambdaStackIdx;
SYMBOL * context;
int i;

if(errorNumber == EXCEPTION_THROW)
    errorNumber = ERR_THROW_WO_CATCH;

errorReg = errorNumber;

if(!errorNumber) return;

openStrStream(&errorStream, MAX_STRING, 1);
writeStreamStr(&errorStream, "ERR: ", 5);
writeStreamStr(&errorStream, errorMessage[errorReg], 0);

for(i = 0; primitive[i].name != NULL; i++)
    {
    if(evalFunc == primitive[i].function)
        {
        writeStreamStr(&errorStream, " in function ", 0);
        writeStreamStr(&errorStream, primitive[i].name, 0);
        break;
        }
    }

if(expr != NULL)
    {
    writeStreamStr(&errorStream, " : ", 3);
    printCell(expr, (errorNumber != ERR_USER_ERROR), (UINT)&errorStream);
    if(deleteFlag) deleteList(expr);
    }

while(stackIdx > lambdaStack)
    {
    lambdaExpr = (CELL *)*(--stackIdx);
    lambdaFunc = (CELL *)lambdaExpr->contents;
    if(lambdaFunc->type == CELL_SYMBOL)
        {
        writeStreamStr(&errorStream, LINE_FEED, 0);
        writeStreamStr(&errorStream, "called from user function ", 0);
        context = ((SYMBOL *)lambdaFunc->contents)->context;
        if(context != mainContext)
          {
          writeStreamStr(&errorStream, context->name, 0);
          writeStreamStr(&errorStream, ":", 0);
          }
        /* writeStreamStr(&errorStream, ((SYMBOL *)lambdaFunc->contents)->name, 0); */
        printCell(lambdaExpr, (errorNumber != ERR_USER_ERROR), (UINT)&errorStream); /* 10.6.3 */
        }
    }

if(!(traceFlag & TRACE_SIGINT)) evalFunc = NULL; 
parStackCounter = prettyPrintPars = 0;

if(evalCatchFlag && !((traceFlag & TRACE_SIGINT) 
        || (traceFlag & TRACE_IN_DEBUG))) return;

if(errorEvent == nilSymbol)
    {
    if(errorNumber == ERR_SIGINT)
        printf("%s", errorStream.buffer);
    else
        {
        varPrintf(OUT_CONSOLE, "\n%.1024s\n", errorStream.buffer);
        if(logTraffic == LOG_MORE) writeLog(errorStream.buffer, TRUE);
        }
    }

if(traceFlag & TRACE_PRINT_EVAL) tracePrint(errorStream.buffer, NULL);
}


/* --------------------------- load source file ------------------------- */


CELL * loadFile(char * fileName, UINT offset, int linkFlag, SYMBOL * context)
{
CELL * result;
STREAM stream;
int errNo, sourceLen;
jmp_buf errorJumpSave;
SYMBOL * contextSave;
#ifdef LOAD_DEBUG
int i;
#endif

contextSave = currentContext;
currentContext = context;
if(linkFlag)
    sourceLen = *((int *) (linkOffset + 4));
else sourceLen = MAX_FILE_BUFFER;

#ifndef EMSCRIPTEN
if(my_strnicmp(fileName, "http://", 7) == 0)
    {
    result = getPutPostDeleteUrl(fileName, nilCell, HTTP_GET, CONNECT_TIMEOUT);
    pushResult(result);
    if(memcmp((char *)result->contents, "ERR:", 4) == 0)
        return(errorProcExt2(ERR_ACCESSING_FILE, stuffString((char *)result->contents)));
    result = copyCell(sysEvalString((char *)result->contents, context, nilCell, EVAL_STRING));
    currentContext = contextSave;
    return(result);
    }
#endif

if(makeStreamFromFile(&stream, fileName, sourceLen + 4 * MAX_STRING, offset) == 0) 
    return(NULL);

memcpy(errorJumpSave, errorJump, sizeof(jmp_buf));
if((errNo = setjmp(errorJump)) != 0)
    {
    closeStrStream(&stream);
    memcpy(errorJump, errorJumpSave, sizeof(jmp_buf));
    currentContext = contextSave;
    longjmp(errorJump, errNo);
    }
    
#ifdef LOAD_DEBUG
for(i = 0; i<recursionCount; i++) printf("  "); 
printf("load: %s\n", fileName);
#endif

result = evaluateStream(&stream, 0, TRUE);
currentContext = contextSave;

#ifdef LOAD_DEBUG
for(i = 0; i<recursionCount; i++) printf("  "); 
printf("finish load: %s\n", fileName);
#endif

memcpy(errorJump, errorJumpSave, sizeof(jmp_buf));
closeStrStream(&stream);
return(result);
}


void linkSource(char * pathname, char * source, char * target)
{
int sourceLen;
char * buffer;
int size, offset = 0;
char * ptr;

#ifdef WINDOWS
/* gets full path of currently executing newlisp.exe */
pathname = win_getExePath(alloca(PATH_MAX));
#else /* Unix */
if(strchr(pathname, '/') == NULL) 
    pathname = which(pathname, alloca(PATH_MAX));
#endif

size = readFile(pathname, &buffer);
sourceLen = (size_t)fileSize(source);

if(errno) 
    {
    printf("%s\n", strerror(errno));
    exit(errno);
    }

ptr = buffer;

if(strncmp(linkOffset + 4, "@@@@", 4) != 0) return; /* already linked */
do  {
    offset = searchBuffer(ptr, size - (ptr - buffer) , "@@@@", 4, 1);
    ptr = ptr + offset + 4;
    } while (strncmp(ptr - 8, "&&&&", 4) != 0); /* the linkOffset */

offset = (ptr - buffer - 8);
*(int *)(buffer + offset) = (int)size;
*(int *)(buffer + offset + 4) = (int)sourceLen;
writeFile(target, buffer, size, "w");
readFile(source, &buffer);
writeFile(target, buffer, sourceLen, "a");

free(buffer);
}

/* -------------------------- parse / compile -----------------------------

   Takes source in a string stream and and envelope cell and compiles
   newLISP source into an internal LISP cell structure tree. The tree
   can be decompiled to source at any time and is processed by the
   evaluateExpression() function.

*/
int references(SYMBOL *, int);
int compileExpression(STREAM * stream, CELL * cell)
{
char token[MAX_STRING + 4];
double floatNumber;
CELL * newCell;
CELL * contextCell;
CELL * preCell;
SYMBOL * contextPtr;
SYMBOL * sPtr;
int listFlag, tklen;
char * lastPtr;
int errnoSave;
INT64 number;

listFlag = TRUE; /* cell is either quote or list envelope */

GETNEXT:
lastPtr = stream->ptr;
switch(getToken(stream, token, &tklen))
    {
    case TKN_ERROR:
        errorProcExt2(ERR_EXPRESSION, stuffStringN(lastPtr, 
            (strlen(lastPtr) < 60) ? strlen(lastPtr) : 60));
        return(FALSE);

    case TKN_EMPTY:
        if(parStackCounter != 0) errorMissingPar(stream);
        return(FALSE);

    case TKN_CHARACTER:
        newCell = stuffInteger((UINT)token[0]);
        break;

    case TKN_HEX:
        newCell = stuffInteger64((INT64)strtoull(token,NULL,0));
        break;

    case TKN_BINARY:
        newCell = stuffInteger64((INT64)strtoull(&token[2],NULL,2));
        break;
    
    case TKN_OCTAL:
        newCell = stuffInteger64(strtoll(token,NULL,0));
        break;

    case TKN_DECIMAL:
        errnoSave = errno;
        errno = 0;
#ifdef BIGINT
        if(*(token + tklen - 1) == 'L')
            {
            newCell = stuffBigint(token);
            break;
            }
#endif

#ifndef NEWLISP64
        number = (INT64)strtoll(token, NULL, 0);
#else
        number = strtoll(token, NULL, 0);
#endif
        
#ifdef BIGINT
        if(errno == ERANGE)
            {
            newCell = stuffBigint(token);
            errno = errnoSave;
            break;
            }
#endif

        newCell = stuffInteger64(number);
        errno = errnoSave;
        break;

    case TKN_FLOAT:
        floatNumber = (double)atof(token);
        newCell = stuffFloat(floatNumber);
        break;

    case TKN_STRING:
        newCell = stuffStringN(token, tklen);
        break;

    case TKN_SYMBOL:
        if(strcmp(token, "lambda") == 0 || strcmp(token, "fn") == 0)
            {
            if(cell->type != CELL_EXPRESSION)
                {
                errorProcExt2(ERR_INVALID_LAMBDA, stuffString(lastPtr));
                return(FALSE);
                }
            cell->type =  CELL_LAMBDA;
            cell->aux = (UINT)nilCell;
            goto GETNEXT;
            }
        else if(strcmp(token, "lambda-macro") == 0 || strcmp(token, "fn-macro") == 0)
            {
            if(cell->type != CELL_EXPRESSION)
                {
                errorProcExt2(ERR_INVALID_LAMBDA, stuffString(lastPtr));
                return(FALSE);
                }
            cell->type =  CELL_FEXPR;
            cell->aux = (UINT)nilCell;
            goto GETNEXT;
            }
        else if(strncmp(token, "[text]", 6) == 0) 
            {
            newCell = makeCell(CELL_STRING, (UINT)readStreamText(stream, &tklen));
            if(newCell->contents == 0)
                {
                deleteList(newCell); 
                errorProc(ERR_TEXT_END_TAG);
                }
            newCell->aux = tklen + 1;
            break;
            }
        newCell = getCell(CELL_SYMBOL);
        if(*token == '$')
            {
            newCell->contents = (UINT)translateCreateSymbol(
                token, CELL_NIL, mainContext, TRUE);
            ((SYMBOL *)newCell->contents)->flags |= SYMBOL_GLOBAL;
            }
        else
            newCell->contents = (UINT)translateCreateSymbol(
                token, CELL_NIL, currentContext, 0);
        break;

    case TKN_CONTEXT:
        contextPtr = NULL;
        if(currentContext != mainContext)
            {
            if(strcmp(currentContext->name, token) == 0)
                contextPtr = currentContext;
            else
                contextPtr = lookupSymbol(token, currentContext);
            }

        if(contextPtr == NULL)
            {
            contextPtr = translateCreateSymbol(
                token, CELL_CONTEXT, mainContext, TRUE);
            }

        contextCell = (CELL *)contextPtr->contents;
        if(getToken(stream, token, &tklen) != TKN_SYMBOL)
            errorProcExt2(ERR_SYMBOL_EXPECTED, stuffString(lastPtr));

        /* context does not exist */
        if(contextCell->type != CELL_CONTEXT 
           || contextPtr != (SYMBOL*)contextCell->contents)
            {
            newCell = getCell(CELL_DYN_SYMBOL);
            newCell->aux = (UINT)contextPtr;
            newCell->contents = (UINT)allocMemory(tklen + 1);
            strncpy((char *)newCell->contents, token, tklen + 1);
            break;
            }

        /* context exists make a symbol for it */
        newCell = getCell(CELL_SYMBOL);
        newCell->contents = (UINT)translateCreateSymbol(
                token, CELL_NIL, contextPtr, TRUE);
        break;

    case TKN_QUOTE:
        newCell = getCell(CELL_QUOTE);
        compileExpression(stream, newCell);
        break;

    case TKN_LEFT_PAR:
        ++parStackCounter;
        newCell = getCell(CELL_EXPRESSION);
        compileExpression(stream, newCell);
        if(((CELL *)newCell->contents)->type == CELL_SYMBOL)
            {
            sPtr = (SYMBOL *)((CELL *)newCell->contents)->contents;
            /* macro expansion */
            if(sPtr->flags & SYMBOL_MACRO)     
                {
                preCell = copyCell(evaluateExpression(newCell));
                deleteList(newCell);
                newCell = preCell;
                }
            }
        break;

    case TKN_RIGHT_PAR:
        if(parStackCounter == 0) errorMissingPar(stream);
        --parStackCounter;
        cell->next = nilCell;
        return(TRUE);

    default:
        errorProcExt2(ERR_EXPRESSION, stuffString(lastPtr));
        return(FALSE);

    }

linkCell(cell, newCell, listFlag);

if(cell->type == CELL_QUOTE && listFlag == TRUE)
    return(TRUE);

listFlag = FALSE;
cell = newCell;

if(parStackCounter != 0)
    {
    if(*(stream->ptr) != 0) goto GETNEXT;
    else errorMissingPar(stream);
    }

return(FALSE);
}


void linkCell(CELL * left, CELL * right, int linkFlag)
{
if(linkFlag == 0) left->next = right;
else left->contents = (UINT)right;
}

int getToken(STREAM * stream, char * token, int * ptr_len)
{
char *tkn;
char chr;
int tknLen;
#ifdef SUPPORT_UTF8
int len;
#endif
int floatFlag;
int bracketBalance;
char buff[8];

tkn = token;
tknLen = floatFlag = 0;
*tkn = 0;

STRIP:
if(stream->ptr > (stream->buffer + stream->size - 4 * MAX_STRING))
    {
    if(stream->handle == 0)
        {
        /* coming from commmand line or p_evalString */
        stream->buffer = stream->ptr;
        }
    else
        {
        stream->position += (stream->ptr - stream->buffer);
                lseek((int)stream->handle, stream->position, SEEK_SET);
        memset(stream->buffer, 0, stream->size + 1);

        if(read(stream->handle, stream->buffer, stream->size) > 0)
            stream->ptr = stream->buffer;
        else
            {
            *stream->ptr = 0;
            return(TKN_EMPTY);
            }
        }
    }

while((unsigned char)*stream->ptr <= ' ' && (unsigned char)*stream->ptr != 0)
    ++stream->ptr;

if(*stream->ptr == 0) return(TKN_EMPTY);

/* check for comments */
if(*stream->ptr == ';' || *stream->ptr == '#')
    {
    stream->ptr++;
    for(;;)
        {
        if(*stream->ptr == 0) return(TKN_EMPTY);
        if(*stream->ptr == '\n' || *stream->ptr == '\r')
            break;
        stream->ptr++;
        }
    stream->ptr++;
    goto STRIP;
    }


if( *stream->ptr == '-' || *stream->ptr == '+')
    {
    if(isDigit((unsigned char)*(stream->ptr + 1)) 
        || *(stream->ptr + 1) == lc_decimal_point ) /* added 10.4.8 to allow -.9 */
        *(tkn++) = *(stream->ptr++), tknLen++;
    }

    
if(isDigit((unsigned char)*stream->ptr) || 
                (*stream->ptr == lc_decimal_point && 
                isDigit((unsigned char)*(stream->ptr + 1))))
    {
    if(*stream->ptr == '0' && isDigit((unsigned char)*(stream->ptr + 1)))
        {
        *(tkn++) = *(stream->ptr++), tknLen++;
        while(*stream->ptr < '8' && *stream->ptr >= '0' && *stream->ptr != 0)
            *(tkn++) = *(stream->ptr++), tknLen++;
        *tkn = 0;
        return(TKN_OCTAL);
        }
        
    while(isDigit((unsigned char)*stream->ptr) && tknLen < MAX_DIGITS)
        *(tkn++) = *(stream->ptr++), tknLen++;
    
    if(toupper(*stream->ptr) == 'X' && token[0] == '0')
        {
        *(tkn++) = *(stream->ptr++), tknLen++;
        while(isxdigit((unsigned char)*stream->ptr) && tknLen < MAX_HEX_NO)
            *(tkn++) = *(stream->ptr++), tknLen++;
        *tkn = 0;
        return(TKN_HEX);
        }

    if(toupper(*stream->ptr) == 'B' && token[0] == '0')
        {
        *(tkn++) = *(stream->ptr++), tknLen++;
        while((*stream->ptr == '0' || *stream->ptr == '1') && tknLen < MAX_BIN_NO)
            *(tkn++) = *(stream->ptr++), tknLen++;
        *tkn = 0;
        return(TKN_BINARY);
        }

    if(*stream->ptr == lc_decimal_point)
        {
        *(tkn++) = *(stream->ptr++), tknLen++;
        while(isDigit((unsigned char)*stream->ptr) && tknLen < MAX_DECIMALS)
            *(tkn++) = *(stream->ptr++), tknLen++;
        floatFlag = TRUE;
        }
    else if(toupper(*stream->ptr) != 'E')
        {
        if(*stream->ptr == 'L') *(tkn++) = *(stream->ptr++), tknLen++;
        *tkn = 0;
        *ptr_len = tknLen;
        return(TKN_DECIMAL);
        }
    
    if(toupper(*stream->ptr) == 'E') 
        {
        if(isDigit((unsigned char)*(stream->ptr+2))
        && ( *(stream->ptr+1) == '-' || *(stream->ptr+1) == '+') )
            *(tkn++) = *(stream->ptr++), tknLen++;
        if(isDigit((unsigned char)*(stream->ptr+1)))
            {
            *(tkn++) = *(stream->ptr++), tknLen++;
            while(isDigit((unsigned char)*stream->ptr) && tknLen < MAX_SYMBOL)
                *(tkn++) = *(stream->ptr++), tknLen++;
            }
        else 
            {
            *tkn = 0;
            if(floatFlag == TRUE) return(TKN_FLOAT);
            else 
                {
                *ptr_len = tknLen;
                return(TKN_DECIMAL);
                }
            }
        }
    *tkn = 0;
    return(TKN_FLOAT);
    }
else
    {
    chr = *stream->ptr;
    *(tkn++) = *(stream->ptr++), tknLen++;
    switch(chr)
     {
     case '"':
        --tkn; --tknLen;
        while(*stream->ptr != '"' && *stream->ptr != 0 
                      && tknLen < MAX_STRING) 
            {
            if(*stream->ptr == '\\')
                {
                stream->ptr++;
                if(isDigit((unsigned char)*stream->ptr) && 
                          isDigit((unsigned char)*(stream->ptr+1)) && 
                          isDigit((unsigned char)*(stream->ptr+2)))
                    {
                    memcpy(buff, stream->ptr, 3);
                    buff[3] = 0;
                    *(tkn++) = atoi(buff);
                    tknLen++;
                    stream->ptr += 3;
                    continue;
                    }

                switch(*stream->ptr)
                    {
                    case 0:
                        goto SRING_TO_LONG_ERROR;
                        break;
                    case 'n':
                        *(tkn++) = '\n'; break;
                    case '\\':
                        *(tkn++) = '\\'; break;
                    case 'b':
                        *(tkn++) = '\b'; break;
                    case 'f':
                        *(tkn++) = '\f'; break;
                    case 'r':
                        *(tkn++) = '\r'; break;
                    case 't':
                        *(tkn++) = '\t'; break;
                    case '"':
                        *(tkn++) = '"';  break;
                    case 'x':
                        if(isxdigit((unsigned char)*(stream->ptr + 1)) &&
                           isxdigit((unsigned char)*(stream->ptr + 2)))
                            {
                            buff[0] = '0';
                            buff[1] = (unsigned char)*(stream->ptr + 1);
                            buff[2] = (unsigned char)*(stream->ptr + 2);
                            buff[3] = 0;
                            *(tkn++) = strtol(buff, NULL, 16);
                            stream->ptr += 2;
                            break;
                            }
                    case 'u':
                        if(isxdigit((unsigned char)*(stream->ptr + 1)) &&
                           isxdigit((unsigned char)*(stream->ptr + 2)) &&
                           isxdigit((unsigned char)*(stream->ptr + 3)) &&
                           isxdigit((unsigned char)*(stream->ptr + 4)))
                            {
#ifdef SUPPORT_UTF8
                            buff[0] = '0';
                            buff[1] = 'x';
                            memcpy(buff + 2, stream->ptr + 1, 4);
                            buff[6] = 0;
                            len = wchar_utf8(strtol(buff, NULL, 16), tkn);
                            stream->ptr += 4;
                            tkn += len;
                            tknLen += len -1;
#else
                            *(tkn++) = '\\';
                            memcpy(tkn, stream->ptr, 5);
                            tknLen = 5;   
                            tkn += 5;
                            stream->ptr += 4;
#endif
                            break;
                            }
                    default:
                        *(tkn++) = *stream->ptr;
                    }
                stream->ptr++;
                tknLen++;
                }
            else *(tkn++) = *(stream->ptr++), tknLen++;
            }
        if(*stream->ptr == '\"')
            {
            *tkn = 0;
            stream->ptr++;
            *ptr_len = tknLen;
            return(TKN_STRING);
            }
        else
            {
            goto SRING_TO_LONG_ERROR;
            }
        break;

     case '\'':
     case '(':
     case ')':
        *tkn = 0;
        return(chr);
     case '{':
        --tkn; --tknLen;
        bracketBalance = 1;
        while(*stream->ptr != 0  && tknLen < MAX_STRING) 
            {
            if(*stream->ptr == '{') ++bracketBalance;
            if(*stream->ptr == '}') --bracketBalance;
            if(bracketBalance == 0) break;
            *(tkn++) = *(stream->ptr++), tknLen++;
            }
        if(*stream->ptr == '}')
            {
            *tkn = 0;
            stream->ptr++;
                        *ptr_len = tknLen;
            return(TKN_STRING);
            }
        else
            {
            goto SRING_TO_LONG_ERROR;
            }
        break;

        
     case ',':
     case ':':
        *tkn = 0;
        *ptr_len = tknLen;
        return(TKN_SYMBOL);

    case '[':
        while( tknLen < MAX_SYMBOL && *stream->ptr != 0 && *stream->ptr != ']')
            *(tkn++) = *(stream->ptr++), tknLen++;
        if(*stream->ptr == 0) return(TKN_ERROR);
        *tkn++ = ']';
        *tkn = 0;
        *ptr_len = ++tknLen;
        stream->ptr++;

        return(TKN_SYMBOL);

     default:
        while(  tknLen < MAX_SYMBOL
            && (unsigned char)*stream->ptr > ' ' 
            && *stream->ptr != '"' && *stream->ptr != '\''
            && *stream->ptr != '(' && *stream->ptr != ')'
            && *stream->ptr != ':' && *stream->ptr != ','
                        && *stream->ptr != 0)
                *(tkn++) = *(stream->ptr++), tknLen++;
        *tkn = 0;
        *ptr_len = tknLen;
        if(*stream->ptr == ':') 
            {
            stream->ptr++;
            return(TKN_CONTEXT);
            }
        return(TKN_SYMBOL);
     }
    }
*tkn=0;
return(TKN_ERROR);

SRING_TO_LONG_ERROR:
*tkn = 0;
errorProcExt2(ERR_STRING_TOO_LONG, 
    stuffStringN(token, strlen(token) < 40 ? strlen(token) : 40));
return(TKN_ERROR);
}

/* -------------------------- utilities ------------------------------------ */

size_t listlen(CELL * listHead)
{
size_t len = 0;

while(listHead != nilCell)
  {
  len++;
  listHead = listHead->next;
  }
  
return(len);
}

/* -------------------------- functions to get parameters ------------------ */

int getFlag(CELL * params)
{
params = evaluateExpression(params);
return(!isNil(params));
}

CELL * getInteger(CELL * params, UINT * number)
{
CELL * cell;
#ifdef BIGINT
INT64 longNum;
#endif
    
cell = evaluateExpression(params);

#ifndef NEWLISP64
if(cell->type == CELL_INT64)
    {
    if(*(INT64 *)&cell->aux >  0xFFFFFFFF) *number = 0xFFFFFFFF;
    else if(*(INT64 *)&cell->aux < INT32_MIN_AS_INT64) *number = 0x80000000;
    else *number = *(INT64 *)&cell->aux;
    }
else if(cell->type == CELL_LONG)
    *number = cell->contents;
else if(cell->type == CELL_FLOAT)
    {
#ifdef WINDOWS
    if(isnan(*(double *)&cell->aux) || !_finite(*(double *)&cell->aux)) *number = 0;
#else
    if(isnan(*(double *)&cell->aux)) *number = 0; 
#endif
    else if(*(double *)&cell->aux >  4294967295.0) *number = 0xFFFFFFFF;
    else if(*(double *)&cell->aux < -2147483648.0) *number = 0x80000000;
    else *number = *(double *)&cell->aux;
    }
#else /* NEWLISP64 */
if(cell->type == CELL_LONG)
    *number = cell->contents;
else if(cell->type == CELL_FLOAT)
    {
    if(isnan(*(double *)&cell->contents)) *number = 0;
    else if(*(double *)&cell->contents >  9223372036854775807.0) *number = 0x7FFFFFFFFFFFFFFFLL;
    else if(*(double *)&cell->contents < -9223372036854775808.0) *number = 0x8000000000000000LL;
    else *number = *(double *)&cell->contents;
    }
#endif
else
    {
#ifdef BIGINT
    if(cell->type == CELL_BIGINT)
        {
        longNum = bigintToInt64(cell);
        *number = longNum;
#ifndef NEWLISP64
        if(longNum > 2147483647LL || longNum < -2147483648LL)
            return(errorProcExt(ERR_NUMBER_OUT_OF_RANGE, cell));
#endif
        }
    else
#endif
        {
        *number = 0;
        return(errorProcArgs(ERR_NUMBER_EXPECTED, params));
        }
    }

return(params->next);
}

#ifndef NEWLISP64
CELL * getInteger64Ext(CELL * params, INT64 * number, int evalFlag)
{
CELL * cell;
   
if(evalFlag) 
    cell = evaluateExpression(params);
else
    cell = params;

if(cell->type == CELL_INT64)
    *number = *(INT64 *)&cell->aux;
else if(cell->type == CELL_LONG)
    *number = (int)cell->contents;
else if(cell->type == CELL_FLOAT)
    {
    if(isnan(*(double *)&cell->aux)) *number = 0; 
    else if(*(double *)&cell->aux >  9223372036854775807.0) *number = 0x7FFFFFFFFFFFFFFFLL;
    else if(*(double *)&cell->aux < -9223372036854775808.0) *number = 0x8000000000000000LL;
    else *number = *(double *)&cell->aux;
    }
else /* check for bigint if size * != NULL, then return bigint address in number */
    {
#ifdef BIGINT
    if(cell->type == CELL_BIGINT)
        *number = bigintToInt64(cell);
    else
#endif
        {
        *number = 0; 
        return(errorProcExt(ERR_NUMBER_EXPECTED, params));
        }
    }

return(params->next);
}

#else /* NEWLISP64 */
CELL * getInteger64Ext(CELL * params, INT64 * number, int evalFlag)
{
CELL * cell;

if(evalFlag)
    cell = evaluateExpression(params);
else
    cell = params;

if(cell->type == CELL_LONG)
    *number = cell->contents;
else if(cell->type == CELL_FLOAT)
    {
    if(isnan(*(double *)&cell->contents)) *number = 0;
    else if(*(double *)&cell->contents >  9223372036854775807.0) *number = 0x7FFFFFFFFFFFFFFFLL;
    else if(*(double *)&cell->contents < -9223372036854775808.0) *number = 0x8000000000000000LL;
    else *number = *(double *)&cell->contents;
    }
else
    {
#ifdef BIGINT
    if(cell->type == CELL_BIGINT)
        *number = bigintToInt64(cell);
    else
#endif
        {
        *number = 0;
        return(errorProcArgs(ERR_NUMBER_EXPECTED, params));
        }
    }

return(params->next);
}
#endif

CELL * getIntegerExt(CELL * params, UINT * number, int evalFlag)
{
CELL * cell;
#ifdef BIGINT
INT64 longNum;
#endif

if(evalFlag)
    cell = evaluateExpression(params);
else cell = params;

#ifndef NEWLISP64
if(cell->type == CELL_INT64)
    {
    if(*(INT64 *)&cell->aux >  0xFFFFFFFF) *number = 0xFFFFFFFF;
    else if(*(INT64 *)&cell->aux < INT32_MIN_AS_INT64) *number = 0x80000000;
    else *number = *(INT64 *)&cell->aux;
    }
else if(cell->type == CELL_LONG)
    *number = cell->contents;
else if(cell->type == CELL_FLOAT)
    {
#ifdef WINDOWS
    if(isnan(*(double *)&cell->aux) || !_finite(*(double *)&cell->aux)) *number = 0;
#else
    if(isnan(*(double *)&cell->aux)) *number = 0; 
#endif
    else if(*(double *)&cell->aux >  4294967295.0) *number = 0xFFFFFFFF;
    else if(*(double *)&cell->aux < -2147483648.0) *number = 0x80000000;
    else *number = *(double *)&cell->aux;
    }
#else /* NEWLISP64 */
if(cell->type == CELL_LONG)
    *number = cell->contents;
else if(cell->type == CELL_FLOAT)
    {
    if(isnan(*(double *)&cell->contents)) *number = 0;
    else if(*(double *)&cell->contents >  9223372036854775807.0) *number = 0x7FFFFFFFFFFFFFFFLL;
    else if(*(double *)&cell->contents < -9223372036854775808.0) *number = 0x8000000000000000LL;
    else *number = *(double *)&cell->contents;
    }
#endif
else /* if BIGNUM type throw ERR_NUMBER_OUT_OF_RANGE */
    {
#ifdef BIGINT
    if(cell->type == CELL_BIGINT)
        {
        longNum = bigintToInt64(cell);
        *number = longNum;
#ifndef NEWLISP64
        if(longNum > 2147483647LL || longNum < -2147483648LL)
            return(errorProcExt(ERR_NUMBER_OUT_OF_RANGE, cell));
#endif
        }
    else
     
#endif /* BIGINT */
        {
        *number = 0;
        return(errorProcArgs(ERR_NUMBER_EXPECTED, params));
        }
    }

return(params->next);
}


CELL * getFloat(CELL * params, double * floatNumber)
{
CELL * cell;

cell = evaluateExpression(params);

#ifndef NEWLISP64
if(cell->type == CELL_FLOAT)
    *floatNumber = *(double *)&cell->aux;
else if(cell->type == CELL_INT64)
    *floatNumber = *(INT64 *)&cell->aux;
#else
if(cell->type == CELL_FLOAT)
    *floatNumber = *(double *)&cell->contents;
#endif
else if(cell->type == CELL_LONG)
    *floatNumber = (INT)cell->contents;
else
    {
#ifdef BIGINT
    if(cell->type == CELL_BIGINT)
        *floatNumber = bigintCellToFloat(cell);
    else
#endif
        { 
        *floatNumber = 0.0;
        return(errorProcArgs(ERR_NUMBER_EXPECTED, params));
        }
    }

return(params->next);
}


CELL * getString(CELL * params, char * * stringPtr)
{
CELL * cell;
SYMBOL * sPtr;

cell = evaluateExpression(params);

if(cell->type == CELL_CONTEXT)
    {
    sPtr = translateCreateSymbol( ((SYMBOL*)cell->contents)->name, CELL_NIL,
        (SYMBOL*)cell->contents, TRUE);
    cell = (CELL *)sPtr->contents;
    }

if(cell->type != CELL_STRING)
    {
    *stringPtr = "";
    return(errorProcArgs(ERR_STRING_EXPECTED, params));
    }

*stringPtr = (char *)cell->contents;
return(params->next);
}


CELL * getStringSize(CELL * params, char * * stringPtr, size_t * size, int evalFlag)
{
CELL * cell;
SYMBOL * sPtr;

if(evalFlag)
    cell = evaluateExpression(params);
else 
    cell = params;

if(cell->type == CELL_CONTEXT)
    {
    sPtr = translateCreateSymbol( ((SYMBOL*)cell->contents)->name, CELL_NIL,
        (SYMBOL*)cell->contents, TRUE);
    symbolCheck = sPtr;
    cell = (CELL *)sPtr->contents;
    }

if(cell->type != CELL_STRING)
    {
    *stringPtr = "";
    return(errorProcArgs(ERR_STRING_EXPECTED, params));
    }

*stringPtr = (char *)cell->contents;

if(size) *size = cell->aux - 1;
return(params->next);
}


CELL * getSymbol(CELL * params, SYMBOL * * symbol)
{
CELL * cell;

cell = evaluateExpression(params);

if(cell->type != CELL_SYMBOL)
    {
    if(cell->type == CELL_DYN_SYMBOL)
        {
        *symbol = getDynamicSymbol(cell);
        return(params->next);
        }
    *symbol = nilSymbol;
    return(errorProcArgs(ERR_SYMBOL_EXPECTED, params));
    }

*symbol = (SYMBOL *)cell->contents;
return(params->next);
}

/* only used for internal syms: $timer, $error-event, $prompt-event, $command-event
   $transfer-event, and $signal-1-> $signal-32 
   If a quoted symbols hasn't been passed take the evaluated params as contents
   of the system event symbols starting with $ */
CELL * getCreateSymbol(CELL * params, SYMBOL * * symbol, char * name)
{
CELL * cell;
CELL * cellForDelete;

cell = evaluateExpression(params);

if(cell->type != CELL_SYMBOL)
    {
    if(cell->type == CELL_DYN_SYMBOL)
        {
        *symbol = getDynamicSymbol(cell);
        return(params->next);
        }
    *symbol = translateCreateSymbol(name, CELL_NIL, mainContext, TRUE);
    (*symbol)->flags |= SYMBOL_PROTECTED | SYMBOL_GLOBAL;
    cellForDelete = (CELL *)(*symbol)->contents;
    if(isNil(cell)) 
        *symbol = nilSymbol;
    else if(cell->type != CELL_LAMBDA && cell->type != CELL_FEXPR && cell->type != CELL_PRIMITIVE)
        {
        *symbol = nilSymbol;
        deleteList(cellForDelete);
        return(errorProcExt(ERR_INVALID_PARAMETER, params));
        }
    else if(compareCells(cellForDelete, cell) != 0)
        {
        (*symbol)->contents = (UINT)copyCell(cell);
        deleteList(cellForDelete);
        }
    }
else
    *symbol = (SYMBOL *)cell->contents;

return(params->next);
}


CELL * getContext(CELL * params, SYMBOL * * context)
{
CELL * cell;

cell = evaluateExpression(params);

if(cell->type == CELL_CONTEXT || cell->type == CELL_SYMBOL)
    *context = (SYMBOL *)cell->contents;
else    
    {
    *context = NULL;
    return(errorProcArgs(ERR_CONTEXT_EXPECTED, params));
    }

if(symbolType(*context) != CELL_CONTEXT)
    return(errorProcExt(ERR_CONTEXT_EXPECTED, params));

return(params->next);
}


CELL * getEvalDefault(CELL * params, CELL * * result)
{
CELL * cell;

cell = evaluateExpression(params);

if(cell->type == CELL_CONTEXT)
    {
    symbolCheck = translateCreateSymbol( ((SYMBOL*)cell->contents)->name, CELL_NIL,
        (SYMBOL*)cell->contents, TRUE);
    cell = (CELL *)symbolCheck->contents;
    }

*result = cell;

return(params->next);
}

/* gets the first element, without list envelope in head
   and return the list with envelope
*/
CELL * getListHead(CELL * params, CELL * * head)
{
CELL * cell;
SYMBOL * sPtr;

cell = evaluateExpression(params);

if(cell->type == CELL_CONTEXT)
    {
    sPtr = translateCreateSymbol( ((SYMBOL*)cell->contents)->name, CELL_NIL,
        (SYMBOL*)cell->contents, TRUE);
    cell = (CELL *)sPtr->contents;
    }

if(!isList(cell->type))
    {
    *head = nilCell;
    return(errorProcExt(ERR_LIST_EXPECTED, params));
    }

*head = (CELL *)cell->contents;

return(params->next);
}

/* ------------------------------- core predicates ------------------------ */

CELL * p_setLocale(CELL * params)
{
#ifndef ANDROID
struct lconv * lc;
#endif
char * locale;
UINT category;
CELL * cell;

if(params != nilCell)
    params = getString(params, &locale);
else locale = NULL;

getEvalDefault(params, &cell);
if(isNumber(cell->type)) /* second parameter */
    getIntegerExt(cell, &category, FALSE);
else category = LC_ALL;

locale = setlocale(category, locale);

if(locale == NULL)
    return(nilCell);

stringOutputRaw = (strcmp(locale, "C") == 0);

#ifndef ANDROID
lc = localeconv();  
lc_decimal_point = *lc->decimal_point;
#endif
cell = getCell(CELL_EXPRESSION);
addList(cell, stuffString(locale));
#ifdef ANDROID
addList(cell, stuffStringN(".", 1));
#else
addList(cell, stuffStringN(lc->decimal_point, 1));
#endif
return(cell);
}

CELL * p_quote(CELL * params)
{
return(copyCell(params));
}


CELL * p_eval(CELL * params)
{
CELL * result;

params = evaluateExpression(params);
result = evaluateExpression(params);
pushResultFlag = FALSE;
return(result);
}


CELL * p_catch(CELL * params)
{
jmp_buf errorJumpSave;
UINT * envStackIdxSave;
UINT * lambdaStackIdxSave;
int recursionCountSave;
int value;
CELL * expr;
CELL * result;
SYMBOL * symbol = NULL;
SYMBOL * contextSave;
CELL * objSave;
CELL * objCellSave;

expr = params;
if(params->next != nilCell)
    {
    getSymbol(params->next, &symbol);
    if(isProtected(symbol->flags))
        return(errorProcExt2(ERR_SYMBOL_PROTECTED, stuffSymbol(symbol)));
    }

memcpy(errorJumpSave, errorJump, sizeof(jmp_buf));
/* save general environment */
envStackIdxSave = envStackIdx;
recursionCountSave = recursionCount;
lambdaStackIdxSave = lambdaStackIdx;
contextSave = currentContext;
/* save FOOP environment */
objSave = (CELL *)objSymbol.contents;
objCellSave = objCell;
itSymbol->contents = (UINT)nilCell;

if((value = setjmp(errorJump)) != 0)
    {
    memcpy(errorJump, errorJumpSave, (sizeof(jmp_buf)));
    /* restore general environment */
    recoverEnvironment(envStackIdxSave);
    recursionCount = recursionCountSave;
    lambdaStackIdx = lambdaStackIdxSave;
    currentContext = contextSave;
    /* restore FOOP environment */
    objSymbol.contents = (UINT)objSave;
    objCell = objCellSave;

    evalCatchFlag--;
    if(value == EXCEPTION_THROW)
        {
        if(symbol == NULL) return(throwResult);
        deleteList((CELL*)symbol->contents);
        symbol->contents = (UINT)throwResult;
        return(trueCell);
        }
        
    if(errorStream.buffer != NULL)
        {
        if(symbol == NULL) 
            {
            if(errorEvent == nilSymbol && evalCatchFlag == 0)
                varPrintf(OUT_CONSOLE, "\n%.1024s\n", errorStream.buffer);
            longjmp(errorJump, value);
            }
        deleteList((CELL*)symbol->contents);
        symbol->contents = (UINT)stuffString(errorStream.buffer);
        }

    return(nilCell);
    }

evalCatchFlag++;
result = copyCell(evaluateExpression(expr));
evalCatchFlag--;
memcpy(errorJump, errorJumpSave, sizeof(jmp_buf));

if(symbol == NULL) return(result);

deleteList((CELL*)symbol->contents);
symbol->contents = (UINT)result;

return(trueCell);
}


CELL * p_throw(CELL * params)
{
if(evalCatchFlag == 0) 
    return(errorProc(ERR_THROW_WO_CATCH));

throwResult = copyCell(evaluateExpression(params));
longjmp(errorJump, EXCEPTION_THROW);

return(trueCell);
}

CELL * p_throwError(CELL * params)
{
evalFunc = NULL;
errorProcExt(ERR_USER_ERROR, evaluateExpression(params));
return(nilCell);
}

CELL * evalString(CELL * params, int mode);

CELL * p_evalString(CELL * params) { return(evalString(params, EVAL_STRING)); }
CELL * p_readExpr(CELL * params) { return(evalString(params, READ_EXPR)); }

CELL * evalString(CELL * params, int mode)
{
SYMBOL * context = currentContext;
char * evalStr;

params = getString(params, &evalStr);

if(params != nilCell)
    {
    if((context = getCreateContext(params, TRUE)) == NULL)
        return(errorProcExt(ERR_SYMBOL_OR_CONTEXT_EXPECTED, params));
    }

if(mode == EVAL_STRING)
    return(copyCell(sysEvalString(evalStr, context, params->next, mode)));

/* returns a new object not yet marked for deletion */
return(sysEvalString(evalStr, context, params->next, mode));
}

/* modes:
EVAL_STRING  
  the classic eval-string: read the string, compile to s-expression , evaluate
READ_EXPR_SYNC
  used by p_sync() in nl-filesys.c 
READ_EXPR
  used by p_readExpr 
READ_EXPR_NET
  used by p_netEval introduces in 10.6.3, before READ_EXPR_SYNC was used
*/


CELL * sysEvalString(char * evalString, SYMBOL * context, CELL * proc, int mode)
{
CELL * program;
STREAM stream;
CELL * resultCell = nilCell;
SYMBOL * contextSave = NULL;
UINT * resultIdxSave;
jmp_buf errorJumpSave;
int recursionCountSave;
UINT * envStackIdxSave;
UINT offset;
CELL * xlate;

makeStreamFromString(&stream, evalString);
if(proc->next != nilCell)
    {
    getInteger(proc->next, &offset);
    stream.ptr += offset;
    }

resultIdxSave = resultStackIdx;
contextSave = currentContext;
currentContext = context;

if(proc != nilCell)
    {
    recursionCountSave = recursionCount;
    envStackIdxSave = envStackIdx;
    evalCatchFlag++;
    memcpy(errorJumpSave, errorJump, sizeof(jmp_buf));

    if(setjmp(errorJump) != 0)
        {
        memcpy(errorJump, errorJumpSave, (sizeof(jmp_buf)));
        recoverEnvironment(envStackIdxSave);
        evalCatchFlag--;
        recursionCount = recursionCountSave;
        currentContext = contextSave;
        if(mode == READ_EXPR)
            return(copyCell(evaluateExpression(proc)));
        return(evaluateExpression(proc));
        }
    }

while(TRUE)
    {
    pushResult(program = getCell(CELL_QUOTE));
    if(compileExpression(&stream, program) == 0) 
        break;
    if(readerEvent != nilSymbol)
        {
        --resultStackIdx;
        executeSymbol(readerEvent, program, &xlate);
        pushResult(program = makeCell(CELL_QUOTE, (UINT)xlate));
        }
    if(mode == EVAL_STRING)
        resultCell = evaluateExpression((CELL *)program->contents);
    else /* READ_EXPR, READ_EXPR_SYNC, READ_EXPR_NET */
        {
        if(resultCell != nilCell) pushResult(resultCell); /* 10.6.3 */
        countCell->contents = (UINT)(stream.ptr - stream.buffer);
        resultCell = (CELL *)program->contents;
        program->contents = (UINT)nilCell; /* de-couple */
        if(mode == READ_EXPR_SYNC || mode == READ_EXPR) /* 10.6.3 */
            break; /* only do first expression */
        }

    if(resultStackIdx > resultStackTop - 256)
        {
        program = popResult(); /* leave last result */
        cleanupResults(resultIdxSave);
        pushResult(program);
        }
    }

currentContext = contextSave;

if(proc != nilCell)
    {
    memcpy(errorJump, errorJumpSave, (sizeof(jmp_buf)));
    evalCatchFlag--;
    }

return(resultCell);
}

#ifdef EMSCRIPTEN
extern char *emscripten_run_script_string(const char *script);
char * evalJSbuff = NULL;

char * evalStringJS(char * cmd, size_t len)
{
if(evalJSbuff != NULL) free(evalJSbuff);

evalJSbuff = callocMemory(len + 1);
memcpy(evalJSbuff, cmd, len);

return(emscripten_run_script_string(evalJSbuff));
}


CELL * p_evalStringJS(CELL * params)
{
char * cmd;
size_t len;
char * result;

getStringSize(params, &cmd, &len, TRUE);
result = evalStringJS(cmd, len);

return(stuffString(result));
}
#endif


CELL * p_curry(CELL * params)
{
CELL * lambda;
CELL * cell;

cell = makeCell(CELL_EXPRESSION, (UINT)stuffSymbol(sysxSymbol));
lambda = makeCell(CELL_LAMBDA, (UINT)cell);
cell->next = getCell(CELL_EXPRESSION);
cell = cell->next;
cell->contents = (UINT)copyCell(params);
cell = (CELL *)cell->contents;
/* take left parameter */
cell->next = copyCell(params->next);
cell = cell->next;
cell->next = stuffSymbol(sysxSymbol);
/* take right parameter
cell->next = stuffSymbol(sysxSymbol);
cell = cell->next;
cell->next = copyCell(params->next);
*/
return(lambda);
}


CELL * p_apply(CELL * params)
{
CELL * expr;
CELL * args;
CELL * cell;
CELL * result;
CELL * func;
ssize_t count = 0, cnt;
UINT * resultIdxSave;

func = evaluateExpression(params);
params = getEvalDefault(params->next, &args);
cell = copyCell(func);
expr = makeCell(CELL_EXPRESSION, (UINT)cell);

if(args->type == CELL_ARRAY)
    {
    args = arrayList(args, FALSE);
    pushResult(args);
    }

if(args->type != CELL_EXPRESSION)
    {
    pushResult(expr);
    if(isNil(args))
        return(copyCell(evaluateExpression(expr)));
    else
        return(errorProcExt(ERR_LIST_EXPECTED, args));
    }

args = (CELL *)args->contents;        

if(params != nilCell)
    getInteger(params, (UINT *)&count);
if(count < 2) count = MAX_LONG;
cnt = count;

resultIdxSave = resultStackIdx + 2;
for(;;)
    {
    while(args != nilCell && cnt--)
        {
        if(isSelfEval(args->type))
            cell->next = copyCell(args);
        else
            cell->next = makeCell(CELL_QUOTE, (UINT)copyCell(args));
        cell = cell->next;
        args = args->next;
        }
    pushResult(expr);
    if(args == nilCell)
        {
        result = evaluateExpression(expr);
        if(symbolCheck) 
            {
            pushResultFlag = FALSE;
            return(result);
            }
        else return(copyCell(result));
        }       
    result = copyCell(evaluateExpression(expr));
    cell = copyCell(func);
    expr = makeCell(CELL_EXPRESSION, (UINT)cell);
    cell->next = makeCell(CELL_QUOTE, (UINT)result);
    cell = cell->next;
    cnt = count - 1;
    cleanupResults(resultIdxSave);
    }
}

CELL * p_args(CELL * params)
{
if(params != nilCell) 
    return(copyCell(implicitIndexList((CELL*)argsSymbol->contents, params)));
return(copyCell((CELL*)argsSymbol->contents));
}

/* in-place expansion, if symbol==NULL all uppercase, non-nil vars are expanded */
CELL * expand(CELL * expr, SYMBOL * symbol)
{
CELL * cell = nilCell;
SYMBOL * sPtr;
int enable = 1;
CELL * cont;
int wchar;

if(isList(expr->type) || expr->type == CELL_QUOTE)
    cell = (CELL*)expr->contents;
else if(expr->type == CELL_SYMBOL && expr->contents == (UINT)symbol)
    expandExprSymbol(expr, symbol);

while(cell != nilCell)
    {   
    if(cell->type == CELL_SYMBOL && (cell->contents == (UINT)symbol || symbol == NULL) )
        {
        sPtr = (SYMBOL *)cell->contents;
        if(symbol == NULL)
            {
#ifndef SUPPORT_UTF8
            wchar = *sPtr->name;
#else
            utf8_wchar(sPtr->name, &wchar);
#endif
            enable = (wchar > 64 && wchar < 91);
            cont = (CELL*)sPtr->contents;
            enable = (enable && cont->contents != (UINT)nilCell 
                            && cont->contents != (UINT)nilSymbol);
            }

        if(symbol || enable)
            expandExprSymbol(cell, sPtr);
        }

    else if(isEnvelope(cell->type)) expand(cell, symbol);
    cell = cell->next;
    }

return(expr);
}


void expandExprSymbol(CELL * cell, SYMBOL * sPtr)
{
CELL * rep;

rep = copyCell((CELL*)sPtr->contents);
/* check for and undo copyCell optimization */
while((UINT)rep == sPtr->contents)
    rep = copyCell((CELL*)sPtr->contents);

cell->type = rep->type;
cell->aux = rep->aux;
cell->contents = rep->contents;
rep->type = CELL_LONG;
deleteList(rep);
}


/* expands one or a chain of expressions */

CELL * blockExpand(CELL * block, SYMBOL * symbol)
{
CELL * expanded = nilCell;
CELL * next = nilCell;

while(block != nilCell)
    {
    if(expanded == nilCell)
        {
        next = expand(copyCell(block), symbol);
        expanded = next;
        }
    else
        {
        next->next = expand(copyCell(block), symbol);
        next = next->next;
        }
    block = block->next;
    }

return(expanded);
}


CELL * p_expand(CELL * params)
{
SYMBOL * symbol;
CELL * expr;
CELL * next;
CELL * list;
CELL * cell;
int evalFlag;

params = getEvalDefault(params, &expr);

if((next = params) == nilCell)
    return(expand(copyCell(expr), NULL));

while((params = next) != nilCell)
    {
    next = params->next;
    params = evaluateExpression(params);
    if(params->type == CELL_SYMBOL)
        symbol = (SYMBOL*)params->contents;
    else if(params->type == CELL_DYN_SYMBOL)
        symbol = getDynamicSymbol(params);
    else if(params->type == CELL_EXPRESSION)
        {
        evalFlag = getFlag(next);
        list = (CELL*)params->contents; /* expansion assoc list */
        while(list != nilCell)
            {
            if(list->type != CELL_EXPRESSION)
                return(errorProcExt(ERR_LIST_EXPECTED, list));
            cell = (CELL *)list->contents;
            if(cell->type != CELL_SYMBOL)
                return(errorProcExt(ERR_SYMBOL_EXPECTED, cell));
            symbol = (SYMBOL*)cell->contents;
            pushEnvironment(symbol->contents);
            pushEnvironment(symbol);
            if(evalFlag)
                symbol->contents = (UINT)copyCell(evaluateExpression(cell->next));
            else
                symbol->contents = (UINT)cell->next;
            expr = expand(copyCell(expr), symbol);
            if(evalFlag) deleteList((CELL *)symbol->contents); 
            symbol = (SYMBOL*)popEnvironment();
            symbol->contents = popEnvironment();
            pushResult(expr);
            list = list->next;
            continue;
            }
        break;
        }
    else 
        return(errorProcExt(ERR_LIST_OR_SYMBOL_EXPECTED, params));
    expr = expand(copyCell(expr), symbol);
    pushResult(expr);
    }

return(copyCell(expr));
}


CELL * defineOrMacro(CELL * params, UINT cellType, int flag)
{
SYMBOL * symbol;
CELL * argsPtr;
CELL * lambda;
CELL * args;
CELL * body;
CELL * cell;

if(params->type != CELL_EXPRESSION)
    return(errorProcExt(ERR_LIST_OR_SYMBOL_EXPECTED, params));

/* symbol to be defined */
argsPtr = (CELL *)params->contents;
if(argsPtr->type != CELL_SYMBOL)
    {
    if(argsPtr->type == CELL_DYN_SYMBOL)
        symbol = getDynamicSymbol(argsPtr);
    else
        return(errorProcExt(ERR_SYMBOL_EXPECTED, params));
    }
else symbol = (SYMBOL *)argsPtr->contents;

if(isProtected(symbol->flags))
    return(errorProc(ERR_SYMBOL_PROTECTED));

/* local symbols */
argsPtr = copyList(argsPtr->next);

args = getCell(CELL_EXPRESSION);
args->contents = (UINT)argsPtr;
/* body expressions */
body = copyList(params->next);

/* if expansion macro insert expand symbol for body expansion
   (expand 'body) */
if(flag)
    {
    if(body->next != nilCell)
        {
        /* body has multiple expressions (expand '(begin ...)) */
        cell = stuffSymbol(beginSymbol);
        cell->next = body;
        body = makeCell(CELL_EXPRESSION, (UINT)cell);
        }
    cell = stuffSymbol(expandSymbol);
    cell->next = makeCell(CELL_QUOTE, (UINT)body);
    body = makeCell(CELL_EXPRESSION, (UINT)cell);
    symbol->flags |= SYMBOL_MACRO;
    }

args->next = body;
lambda = makeCell(cellType, (UINT)args);

deleteList((CELL *)symbol->contents);
symbol->contents = (UINT)lambda;

pushResultFlag = FALSE;
return(lambda);
}


CELL * p_define(CELL * params)
{
if(params->type != CELL_SYMBOL)
    {
    if(params->type != CELL_DYN_SYMBOL)
        return(defineOrMacro(params, CELL_LAMBDA, FALSE));
    return(setDefine(getDynamicSymbol(params), params->next, SET_SET));
    }

return(setDefine((SYMBOL *)params->contents, params->next, SET_SET));
}

CELL * p_defineMacro(CELL * params)
{
return(defineOrMacro(params, CELL_FEXPR, FALSE));
}

CELL * p_macro(CELL * params)
{
return(defineOrMacro(params, CELL_FEXPR, TRUE));
}

/* also called from setq */
CELL * p_setf(CELL *params)
{
SYMBOL * symbolRef = NULL;
CELL * cell;
CELL * new;
CELL * stringRef;
char * indexRefPtr;

SETF_BEGIN:
if(params->next == nilCell)
    return(errorProc(ERR_MISSING_ARGUMENT));
        
cell = evaluateExpression(params);

if(cell == nilCell || cell == trueCell)
    errorProcExt(ERR_IS_NOT_REFERENCED, cell);
            
symbolRef = symbolCheck;
stringRef = stringCell;
indexRefPtr = stringIndexPtr;

if(symbolRef && isProtected(symbolRef->flags))
    return(errorProcExt2(ERR_SYMBOL_PROTECTED, stuffSymbol(symbolRef)));

itSymbol->contents = (UINT)cell;
new = copyCell(evaluateExpression(params->next));
itSymbol->contents = (UINT)nilCell;
    
params = params->next; 
params = params->next; 


if(stringRef && indexRefPtr)
    {
    cell = setNthStr((CELL *)stringRef, new, indexRefPtr);
    if(params != nilCell) goto SETF_BEGIN;
    return(cell);
    }

/* delete contents of original cell */
if(isEnvelope(cell->type))
    {
    if(cell->type == CELL_ARRAY)
        deleteArray(cell);
    else
        deleteList((CELL *)cell->contents);
    }
else if(cell->type == CELL_STRING || cell->type == CELL_DYN_SYMBOL 
#ifdef BIGINT
        || cell->type == CELL_BIGINT
#endif
        )
    freeMemory( (void *)cell->contents);
    
    
/* get new contents */  
cell->type = new->type;
cell->aux = new->aux;
cell->contents = new->contents;

/* free cell */
new->type = CELL_FREE;
new->aux = 0;
new->contents = 0;
new->next = firstFreeCell;
firstFreeCell = new;
--cellCount;

if(params != nilCell) goto SETF_BEGIN;

/* return modified cell */
symbolCheck = symbolRef;
pushResultFlag = FALSE;
return(cell);
}


CELL * p_set(CELL *params)
{
SYMBOL * symbol;
CELL * next;

for(;;)
    {
    params = getSymbol(params, &symbol);
    next = params->next;
    if(params == nilCell)
        return(errorProc(ERR_MISSING_ARGUMENT));
    if(next == nilCell) return(setDefine(symbol, params, SET_SET));
    setDefine(symbol, params, SET_SET);
    params = next;
    }
}


CELL * p_constant(CELL *params)
{
SYMBOL * symbol;
CELL * next;
UINT * idx = envStackIdx;

for(;;)
    {
    params = getSymbol(params, &symbol);
    /* make sure symbol is not used as local in call hierachy */
    while(idx > envStack)
        {
        if(symbol == (SYMBOL *)*(--idx))
            errorProcExt2(ERR_CANNOT_PROTECT_LOCAL, stuffSymbol(symbol));
        --idx;
        }

    /* protect contexts from being set, but not vars holding contexts */
    if((symbolType(symbol) == CELL_CONTEXT && (SYMBOL *)((CELL *)symbol->contents)->contents == symbol)
            || symbol == countSymbol)
        return(errorProcExt2(ERR_SYMBOL_PROTECTED, stuffSymbol(symbol)));
    next = params->next;
    if(symbol->context != currentContext)
        return(errorProcExt2(ERR_NOT_CURRENT_CONTEXT, stuffSymbol(symbol)));
    symbol->flags |= SYMBOL_PROTECTED;
    if(params == nilCell)
        return(copyCell((CELL*)symbol->contents));
    if(next == nilCell) 
        {
        next = setDefine(symbol, params, SET_CONSTANT);
        pushResultFlag = TRUE;
        return(copyCell(next));
        }
    setDefine(symbol, params, SET_CONSTANT);
    pushResultFlag = TRUE;
    params = next;
    }
}


CELL * setDefine(SYMBOL * symbol, CELL * params, int type)
{
CELL * cell;

if(isProtected(symbol->flags))
    {
    if(type == SET_CONSTANT)
        {
        if(symbol == nilSymbol || symbol == trueSymbol)
            return(errorProcExt2(ERR_SYMBOL_EXPECTED, stuffSymbol(symbol)));
        }
    else
        return(errorProcExt2(ERR_SYMBOL_PROTECTED, stuffSymbol(symbol)));
    }

cell = copyCell(evaluateExpression(params));

deleteList((CELL *)symbol->contents);
symbol->contents = (UINT)(cell);

symbolCheck = symbol;
pushResultFlag = FALSE; 

return(cell);
}


CELL * p_global(CELL * params)
{
SYMBOL * sPtr;

do
    {
    params = getSymbol(params, &sPtr);
    if(sPtr->context != mainContext || currentContext != mainContext)
        return(errorProcExt2(ERR_NOT_IN_MAIN, stuffSymbol(sPtr)));
    else 
        sPtr->flags |= SYMBOL_GLOBAL;
    } while (params != nilCell);

return(stuffSymbol(sPtr));
}

#define LET_STD 0
#define LET_NEST 1
#define LET_EXPAND 2
#define LET_LOCAL 3

CELL * let(CELL * params, int type);

CELL * p_let(CELL * params) { return(let(params, LET_STD)); }
CELL * p_letn(CELL * params) { return(let(params, LET_NEST)); }
CELL * p_letExpand(CELL * params) { return(let(params, LET_EXPAND)); }
CELL * p_local(CELL * params) { return(let(params, LET_LOCAL)); }

CELL * let(CELL * params, int type)
{
CELL * inits;
CELL * cell;
CELL * result = nilCell;
CELL * args = NULL, * list = NULL;
CELL * body;
SYMBOL * symbol;
int localCount = 0;

if(params->type != CELL_EXPRESSION)
    return(errorProcExt(ERR_INVALID_LET, params));

/* evaluate symbol assignments in parameter list 
   handle double syntax classic: (let ((s1 e1) (s2 e2) ...) ...) 
                            and: (let (s1 e1 s2 e2 ...) ...)
*/
inits = (CELL*)params->contents;
body = params->next;

if(type == LET_LOCAL)
    {
    while(inits != nilCell)
        {
        if(inits->type != CELL_SYMBOL)
            return(errorProcExt(ERR_SYMBOL_EXPECTED, inits));
        symbol = (SYMBOL *)inits->contents;
        if(isProtected(symbol->flags))
                return(errorProcExt(ERR_SYMBOL_PROTECTED, inits));
        pushEnvironment(symbol->contents);
        pushEnvironment(symbol);
        symbol->contents = (UINT)copyCell(nilCell);
        localCount++;
        inits = inits->next;
        }
    goto EVAL_LET_BODY; 
    }

while(inits != nilCell)
    {
    if(inits->type != CELL_EXPRESSION)
        {
        if(inits->type != CELL_SYMBOL)
            return(errorProcExt(ERR_INVALID_LET, inits));
        cell = inits;
        inits = ((CELL*)cell->next)->next;
        }
    else 
        {
        cell = (CELL *)inits->contents;
        if(cell->type != CELL_SYMBOL)
            return(errorProcExt(ERR_SYMBOL_EXPECTED, inits));
        inits = inits->next;
        }

    if(type == LET_STD || type == LET_EXPAND)
        {
        if(localCount == 0) 
            list = args = copyCell(evaluateExpression(cell->next));
        else 
            {
            args->next = copyCell(evaluateExpression(cell->next));
            args = args->next;
            }
        }
    else /* LET_NEST */
        {
        symbol = (SYMBOL *)cell->contents;
        if(isProtected(symbol->flags))
                return(errorProcExt(ERR_SYMBOL_PROTECTED, cell));
        args = copyCell(evaluateExpression(cell->next));
        pushEnvironment((CELL *)symbol->contents);
        pushEnvironment((UINT)symbol);
        symbol->contents = (UINT)args;
        }

    localCount++;
    }

/* save symbols and get new bindings */
if(type == LET_STD || type == LET_EXPAND) 
    {
    inits = (CELL*)params->contents;
    while(inits != nilCell)
        {
        if(inits->type == CELL_EXPRESSION)
            {
            cell = (CELL *)inits->contents;
            inits = inits->next;
            }
        else
            {
            cell = inits;
            inits = ((CELL*)cell->next)->next;
            }   

        symbol = (SYMBOL *)cell->contents;

        if(isProtected(symbol->flags))
            return(errorProcExt(ERR_SYMBOL_PROTECTED, cell));

        pushEnvironment((CELL *)symbol->contents);
        pushEnvironment((UINT)symbol);
        symbol->contents = (UINT)list;

        args = list;
        list = list->next;
        args->next = nilCell; /* decouple */

        /* hook in LET_EXPAND mode here */
        if(type == LET_EXPAND)
            {
            body = blockExpand(body, symbol);
            pushResult(body);
            }

        }
    }

EVAL_LET_BODY:
/* evaluate body expressions */
while(body != nilCell)
    {
    if(result != nilCell) deleteList(result);
    result = copyCell(evaluateExpression(body));
    body = body->next;
    }

/* restore environment */
while(localCount--)
    {
    symbol = (SYMBOL *)popEnvironment();
    deleteList((CELL *)symbol->contents);
    symbol->contents = popEnvironment();
    }

return(result);
}

CELL * p_first(CELL * params)
{
char str[2];
CELL * cell;
CELL * result;
#ifdef SUPPORT_UTF8
size_t len;
#endif

getEvalDefault(params, &cell);

if(cell->type == CELL_STRING)
    {
    stringCell = cell;
    if((str[0] = *(char *)cell->contents) == 0)
        return(stuffString(""));
    
#ifndef SUPPORT_UTF8
    str[1] = 0;
    result = stuffString(str);
#else
    len =  utf8_1st_len((char*)cell->contents);
    if(len > cell->aux -1)
        return(errorProc(ERR_INVALID_UTF8));
    result = stuffStringN((char*)cell->contents, len);
#endif

    stringIndexPtr = (char *)cell->contents;
    if(symbolCheck)
        {
        pushResult(result);
        pushResultFlag = FALSE;
        }
    return(result);
    }

else if(isList(cell->type))
    {
    if(cell->contents == (UINT)nilCell)
        return(errorProcExt(ERR_LIST_EMPTY, params));

    pushResultFlag = FALSE;
    return((CELL *)cell->contents);
    }

else if(cell->type == CELL_ARRAY)
    {
    pushResultFlag = FALSE;
    return(*(CELL * *)cell->contents);
    }

return(errorProcExt(ERR_ARRAY_LIST_OR_STRING_EXPECTED, params));
}


CELL * p_rest(CELL * params)
{
CELL * cell;
CELL * tail;
#ifdef SUPPORT_UTF8
size_t size;
#endif

/* cell = evaluateExpression(params); */
getEvalDefault(params, &cell);

if(isList(cell->type))
    {
    tail = makeCell(CELL_EXPRESSION, (UINT)copyList(((CELL*)cell->contents)->next));
    return(tail);
    }
else if(cell->type == CELL_ARRAY)
    return(subarray(cell, 1, MAX_LONG));

else if(cell->type == CELL_STRING)
    {
    if(*(char *)cell->contents == 0)
        return(stuffString(""));
#ifndef SUPPORT_UTF8
    return(stuffString((char *)(cell->contents + 1)));
#else
    size = utf8_1st_len((char *)cell->contents);
    if(size > cell->aux - 1)
        return(errorProc(ERR_INVALID_UTF8));
    return(stuffString((char *)(cell->contents + size)));
#endif
    }

return(errorProcExt(ERR_ARRAY_LIST_OR_STRING_EXPECTED, params));
}

CELL * implicitNrestSlice(CELL * num, CELL * params)
{
CELL * list;
ssize_t  n, len;

getIntegerExt(num, (UINT *)&n, FALSE);
list = evaluateExpression(params);

if(list->type == CELL_CONTEXT)
    list = (CELL *)(translateCreateSymbol(
        ((SYMBOL*)list->contents)->name,
        CELL_NIL,
        (SYMBOL*)list->contents,
        TRUE))->contents;

/* slice  */
if(isNumber(list->type))
    {
    getIntegerExt(list, (UINT*)&len, FALSE);
    list = evaluateExpression(params->next);

    if(list->type == CELL_CONTEXT)
    list = (CELL *)(translateCreateSymbol(
        ((SYMBOL*)list->contents)->name,
        CELL_NIL,
        (SYMBOL*)list->contents,
        TRUE))->contents;

    if(isList(list->type))    
        return(sublist((CELL *)list->contents, n, len));
    else if(list->type == CELL_STRING)
        return(substring((char *)list->contents, list->aux-1, n, len));
    else if(list->type == CELL_ARRAY)
        return(subarray(list, n, len));
    }
    
/* nrest lists */
else if(isList(list->type))
    {
    list = (CELL *)list->contents;

    if(n < 0) n = convertNegativeOffset(n, list);
    
    while(n-- && list != nilCell)
        list = list->next;
  
    return(makeCell(CELL_EXPRESSION, (UINT)copyList(list)));
    }

/* nrest strings 
   this was UTF-8 sensitive before 9.1.11, but only the
   explicit first/last/rest should be UTF8-sensitive
*/
else if(list->type == CELL_STRING) 
    return(substring((char *)list->contents, list->aux - 1, n, MAX_LONG));

else if(list->type == CELL_ARRAY)
    return(subarray(list, n, MAX_LONG));

return(errorProcExt(ERR_ILLEGAL_TYPE, params));
}


CELL * p_cons(CELL * params)
{
CELL * cons;
CELL * head;
CELL * tail;

if(params == nilCell)
    return(getCell(CELL_EXPRESSION));

head = copyCell(evaluateExpression(params));
cons = makeCell(CELL_EXPRESSION, (UINT)head);
params = params->next;

if(params != nilCell)
    {
    tail = evaluateExpression(params);
    
    if(isList(tail->type))
        {
        head->next = copyList((CELL *)tail->contents);
        cons->type = tail->type;    
        }
    else
        head->next = copyCell(tail);
    }

return(cons);
}


CELL * p_list(CELL * params)
{
CELL * list;
CELL * lastCopy = NULL;
CELL * copy;
CELL * cell;
UINT * resultIdxSave;

list = getCell(CELL_EXPRESSION);

resultIdxSave = resultStackIdx;
while(params != nilCell)
    {
    cell = evaluateExpression(params);
    if(cell->type == CELL_ARRAY)
        copy = arrayList(cell, TRUE);
    else
        copy = copyCell(cell);
    if(lastCopy == NULL)
        list->contents = (UINT)copy;
    else lastCopy->next = copy;
    lastCopy = copy;
    cleanupResults(resultIdxSave);
    params = params->next;
    }

return(list);
}


CELL * p_last(CELL * params)
{
CELL * cell;
CELL * listPtr;
CELL * result;
char * str;

getEvalDefault(params, &cell);

if(cell->type == CELL_STRING)
    {
    stringCell = cell;
    str = (char *)cell->contents;
    if(*str == 0) return(copyCell(cell));
#ifndef SUPPORT_UTF8
    str += (cell->aux - 2);
    result = stuffString(str);
#else
    str = utf8_index(str, utf8_wlen(str, str + cell->aux) -1);
    result = stuffString(str);
#endif
    stringIndexPtr = (char *)str;
    if(symbolCheck)
        {
        pushResult(result);
        pushResultFlag = FALSE;
        }
    return(result);
    }

else if(isList(cell->type))
    {
    if(cell->contents == (UINT)nilCell)
        return(errorProcExt(ERR_LIST_EMPTY, params));

    if(cell->aux != (UINT)nilCell) 
        {
        pushResultFlag = FALSE;
        return((CELL *)cell->aux);
        }
        
    listPtr = (CELL *)cell->contents;
    while(listPtr->next != nilCell) listPtr = listPtr->next;
    cell->aux = (UINT)listPtr;
    pushResultFlag = FALSE;
    return(listPtr);
    }

else if(cell->type == CELL_ARRAY)
    {
    pushResultFlag = FALSE;
    return(*((CELL * *)cell->contents + (cell->aux - 1) / sizeof(UINT) - 1));
    }

return(errorProcExt(ERR_ARRAY_LIST_OR_STRING_EXPECTED, params));
}


/* -------------------------- program flow  and logical ------------------ */

CELL * evaluateBlock(CELL * cell)
{
CELL * result;

result = nilCell;

while(cell != nilCell)
    {
    result = evaluateExpression(cell);
    cell = cell->next;
    }
return(result);
}


CELL * p_if(CELL * params)
{
CELL * cell;

cell = evaluateExpression(params);
itSymbol->contents = (UINT)cell;
while(isNil(cell) || isEmpty(cell))
    {
    params = params->next;
    if(params->next == nilCell) 
        goto IF_RETURN;
    params = params->next;
    cell = evaluateExpression(params);
    }

if(params->next != nilCell) 
    cell = evaluateExpression(params->next);
   
IF_RETURN: 
itSymbol->contents = (UINT)nilCell;
pushResultFlag = FALSE;
return(cell);
}


CELL * p_ifNot(CELL * params)
{
CELL * cell;

cell = evaluateExpression(params);
if(!isNil(cell) && !isEmpty(cell))
    params = params->next;

cell = evaluateExpression(params->next);

pushResultFlag = FALSE;
return(cell);
}


CELL * p_when(CELL * params)
{
CELL * cell;

cell = evaluateExpression(params);
if(isNil(cell) || isEmpty(cell)) goto WHEN_END;

while((params = params->next) != nilCell)
    cell = evaluateExpression(params);

WHEN_END:
pushResultFlag = FALSE;
return(cell);
}

CELL * p_unless(CELL * params)
{
CELL * cell;

cell = evaluateExpression(params);
if(!isNil(cell) && !isEmpty(cell)) goto UNLESS_END;

while((params = params->next) != nilCell)
    cell = evaluateExpression(params);

UNLESS_END:
pushResultFlag = FALSE;
return(cell);
}


CELL * p_condition(CELL * params)
{
CELL * condition;
CELL * eval = nilCell;

while(params != nilCell)
    {
    if(params->type == CELL_EXPRESSION)
        {
        condition = (CELL *)params->contents;
        eval = evaluateExpression(condition);
        if(!isNil(eval) && !isEmpty(eval))
            {
            if(condition->next != nilCell)
                eval = evaluateBlock(condition->next);
            break;
            }
        params = params->next;
        }
    else return(errorProc(ERR_LIST_EXPECTED));
    }

pushResultFlag = FALSE;
return(eval);
}


CELL * p_case(CELL * params)
{
CELL * cases;
CELL * cond;
CELL * eval;

cases = params->next;
params = evaluateExpression(params);
while(cases != nilCell)
  {
  if(cases->type == CELL_EXPRESSION)
    {
    cond = (CELL *)cases->contents;
    if(compareCells(params, cond) == 0
      || (cond->type == CELL_SYMBOL && symbolType((SYMBOL *)cond->contents) == CELL_TRUE)
          || cond->type == CELL_TRUE)
        {
        eval = evaluateBlock(cond->next);
        pushResultFlag = FALSE;
        return(eval);
        }
    }
    cases = cases->next;
  }

return(nilCell);
}

#define REPEAT_WHILE 0
#define REPEAT_DOWHILE 1
#define REPEAT_UNTIL 2
#define REPEAT_DOUNTIL 3

CELL * p_while(CELL * params) { return(repeat(params, REPEAT_WHILE)); }
CELL * p_doWhile(CELL * params) { return(repeat(params, REPEAT_DOWHILE)); }
CELL * p_until(CELL * params) { return(repeat(params, REPEAT_UNTIL)); }
CELL * p_doUntil(CELL * params) { return(repeat(params, REPEAT_DOUNTIL)); }


CELL * repeat(CELL * params, int type)
{
CELL * result;
CELL * cell;
CELL * cellIdx;
UINT * resultIdxSave;
SYMBOL * symbolRef = NULL;

cellIdx = initIteratorIndex();

resultIdxSave = resultStackIdx;
result = nilCell;
while(TRUE)
    {
    switch(type)
        {
        case REPEAT_WHILE:
            cell = evaluateExpression(params);
            if(isNil(cell) || isEmpty(cell)) goto END_REPEAT;
            cleanupResults(resultIdxSave);
            result = evaluateBlock(params->next);
            symbolRef = symbolCheck;
            break;
        case REPEAT_DOWHILE:
            result = evaluateBlock(params->next);
            symbolRef = symbolCheck;
            cell = evaluateExpression(params);
            if(isNil(cell) || isEmpty(cell)) goto END_REPEAT;
            cleanupResults(resultIdxSave);
            break;
        case REPEAT_UNTIL:
            cell = evaluateExpression(params);
            if(!isNil(cell) && !isEmpty(cell)) 
                {
                if(params->next == nilCell)
                    result = cell;
                goto END_REPEAT;
                }
            cleanupResults(resultIdxSave);
            result = evaluateBlock(params->next);
            symbolRef = symbolCheck;
            break;
        case REPEAT_DOUNTIL:
            result = evaluateBlock(params->next);
            symbolRef = symbolCheck;
            cell = evaluateExpression(params);
            if(!isNil(cell) && !isEmpty(cell))
                {
                if(params->next == nilCell)
                    result = cell;
                goto END_REPEAT;
                }
            cleanupResults(resultIdxSave);
            break;
        default:
            break;
        }

    if(cellIdx->type == CELL_LONG) cellIdx->contents += 1;
    }

END_REPEAT:
recoverIteratorIndex(cellIdx);

symbolCheck = symbolRef;
pushResultFlag = FALSE;
return(result);
}


CELL * getPushSymbolParam(CELL * params, SYMBOL * * sym)
{
SYMBOL * symbol;
CELL * cell;

if(params->type != CELL_EXPRESSION)
    return(errorProcExt(ERR_LIST_EXPECTED, params));

cell = (CELL *)params->contents;
if(cell->type != CELL_SYMBOL)
    return(errorProcExt(ERR_SYMBOL_EXPECTED, cell));

*sym = symbol = (SYMBOL *)cell->contents;
if(isProtected(symbol->flags))
    return(errorProcExt2(ERR_SYMBOL_PROTECTED, stuffSymbol(symbol)));

pushEnvironment((CELL *)symbol->contents);
pushEnvironment((UINT)symbol);
symbol->contents = (UINT)nilCell;

return(cell->next);
}


CELL * initIteratorIndex(void)
{
CELL * cell = stuffInteger(0);

pushEnvironment(listIdxSymbol->contents);
pushEnvironment(listIdxSymbol);
listIdxSymbol->contents = (UINT)cell;

return(cell);
}

void recoverIteratorIndex(CELL * cellIdx)
{
deleteList(cellIdx);
listIdxSymbol = (SYMBOL*)popEnvironment();
listIdxSymbol->contents = (UINT)popEnvironment();
}

CELL * loop(CELL * params, int forFlag)
{
CELL * cell;
CELL * cond = nilCell;
CELL * block;
SYMBOL * symbol = NULL;
double fromFlt, toFlt, interval, step, cntFlt;
INT64 stepCnt, i;
INT64 fromInt64 = 0, toInt64 = 0;
int intFlag;
UINT * resultIdxSave;

cell = getPushSymbolParam(params, &symbol);

/* integer loops for dotimes and (for (i from to) ...) */
if((intFlag = ((CELL *)cell->next)->next == nilCell))
    {
    if(forFlag)
        {
        cell = getInteger64Ext(cell, &fromInt64, TRUE);
        getInteger64Ext(cell, &toInt64, TRUE);
        stepCnt = (toInt64 > fromInt64) ? toInt64 - fromInt64 : fromInt64 - toInt64;
        }
    else /* dotimes */
        {
        fromInt64 = toInt64 = 0;
        cond = getInteger64Ext(cell, &stepCnt, TRUE);
        }
    }
else /* float (for (i from to step) ...) */
    {
    cell = getFloat(cell, &fromFlt);
    cell = getFloat(cell, &toFlt);
    cond = getFloat(cell, &step);
    if(isnan(fromFlt) || isnan(toFlt) || isnan(step))
        return(errorProc(ERR_INVALID_PARAMETER_NAN));
    if(step < 0) step = -step;
    if(fromFlt > toFlt) step = -step;
    cntFlt = (fromFlt < toFlt) ? (toFlt - fromFlt)/step : (fromFlt - toFlt)/step;
    stepCnt = (cntFlt > 0.0) ? floor(cntFlt + 0.0000000001) : floor(-cntFlt + 0.0000000001);
    }
    
block = params->next;
resultIdxSave = resultStackIdx;
cell = nilCell;
for(i = 0; i <= stepCnt; i++)
    {
    if(!forFlag && i == stepCnt) break;
    deleteList((CELL *)symbol->contents);
    if(intFlag) 
        {
        symbol->contents = 
            (UINT)stuffInteger64((fromInt64 > toInt64) ? fromInt64 - i: 
                                                         fromInt64 + i);
        }
    else
        {
        interval = fromFlt + i * step;
        symbol->contents = (UINT)stuffFloat(interval);
        }
    /* cleanupResults(resultIdxSave);*/
    while(resultStackIdx > resultIdxSave) deleteList(popResult());
    if(cond != nilCell)  
            {
            cell = evaluateExpression(cond);
            if(!isNil(cell)) break;
            }
    cell = evaluateBlock(block);
    }


if(symbolCheck && cell != (CELL *)symbol->contents && symbol != symbolCheck)
    pushResultFlag = FALSE;
else
    cell = copyCell(cell);

deleteList((CELL *)symbol->contents);
symbol = (SYMBOL*)popEnvironment();
symbol->flags &= ~SYMBOL_PROTECTED;
symbol->contents = (UINT)popEnvironment();

return(cell);
}


CELL * p_dotimes(CELL * params)
{
return(loop(params, 0));
}

CELL * p_for(CELL * params)
{
return(loop(params, 1));
}


#define DOLIST 0
#define DOTREE 1
#define DOARGS 2
#define DOSTRING 3

CELL * p_dolist(CELL * params)
{
return(dolist(params, DOLIST));
}

CELL * p_dotree(CELL * params)
{
return(dolist(params, DOTREE));
}

CELL * p_doargs(CELL * params)
{
return(dolist(params, DOARGS));
}

CELL * p_dostring(CELL * params)
{
return(dolist(params, DOSTRING));
}

CELL * dolist(CELL * params, int doType)
{
CELL * cell;
CELL * list = nilCell;
char * str;
#ifdef SUPPORT_UTF8
int chr;
#endif
CELL * cond = nilCell;
SYMBOL * symbol = NULL;
SYMBOL * sPtr;
CELL * cellIdx;
UINT * resultIdxSave;

cell = getPushSymbolParam(params, &symbol);
cellIdx = initIteratorIndex();

switch(doType)
    {
    case DOLIST:
        /* list = copyCell(evaluateExpression(cell)); */
        getEvalDefault(cell, &list);
        if(isList(list->type)) list = copyCell(list);
        else if(list->type == CELL_ARRAY) list = arrayList(list, FALSE);
        else return(errorProcExt(ERR_LIST_EXPECTED, cell));
        cond = cell->next;
        break;
    case DOTREE:
        getContext(cell, &sPtr);
        list = getCell(CELL_EXPRESSION);
        collectSymbols((SYMBOL *)((CELL *)sPtr->contents)->aux, list);
        cond = (getFlag(cell->next) == 1) ? trueCell : nilCell;
        break;  
    case DOARGS:
        list = copyCell((CELL *)argsSymbol->contents);
        cond = cell;
        break;
    case DOSTRING:
        getString(cell, &str);
        resultIdxSave = resultStackIdx;
        cond = cell->next;
        while(*str)
            {
            cleanupResults(resultIdxSave);
            deleteList((CELL *)symbol->contents);
#ifdef SUPPORT_UTF8
            str = utf8_wchar(str, &chr);
            symbol->contents = (UINT)stuffInteger(chr);
#else
            symbol->contents = (UINT)stuffInteger((int)*str++);
#endif
            if(cond != nilCell)
                {
                cell = evaluateExpression(cond);
                if(!isNil(cell)) break;
                }
            cell = evaluateBlock(params->next);
            if(cellIdx->type == CELL_LONG) cellIdx->contents += 1;
            }
        goto FINISH_DO;
        break;
    }

/* make sure worklist gets destroyed */
pushResult(list); 
list = (CELL *)list->contents;

resultIdxSave = resultStackIdx;
cell = nilCell;
while(list!= nilCell)
    {
    cleanupResults(resultIdxSave);
    deleteList((CELL *)symbol->contents);
    symbol->contents = (UINT)copyCell(list);
    if(cond != nilCell)
        {
        if(doType == DOTREE)
            {
            sPtr = (SYMBOL *)list->contents;
            if(*sPtr->name != '_') 
                {
                cell = nilCell;
                goto DO_CONTINUE;
                }
            }
        else
            {
            cell = evaluateExpression(cond);
            if(!isNil(cell)) break;
            }
        }
    cell = evaluateBlock(params->next);
    if(cellIdx->type == CELL_LONG) cellIdx->contents += 1;
    DO_CONTINUE:    
    list = list->next;
    }

FINISH_DO:
if(symbolCheck && cell != (CELL *)symbol->contents && symbol != symbolCheck)
    pushResultFlag = FALSE;
else
    cell = copyCell(cell);

recoverIteratorIndex(cellIdx);

deleteList((CELL *)symbol->contents);
symbol = (SYMBOL*)popEnvironment();
symbol->contents = (UINT)popEnvironment();

return(cell);
}


CELL * p_evalBlock(CELL * params)
{
CELL * result = nilCell;

while(params != nilCell)
    {
    result = evaluateExpression(params);
    params = params->next;
    }

pushResultFlag = FALSE;
return(result);
}

extern UINT getAddress(CELL * params);

CELL * p_copy(CELL * params)
{
CELL * copy;

/* experimental: copy a cell from address, from:
   http://www.newlispfanclub.alh.net/forum/viewtopic.php?f=5&t=4548
   June 14, 2014 "get-cell function patch"
*/
if(params->next != nilCell && getFlag(params->next))
    return(copyCell((CELL *)getAddress(params)));

copy = copyCell(evaluateExpression(params));
symbolCheck = NULL;
return(copy);
}

CELL * p_silent(CELL * params)
{
CELL * cell;
evalSilent  = TRUE;

cell = evaluateBlock(params);
if(symbolCheck)
    {
    pushResultFlag = FALSE;
    return(cell);
    }
    
return(copyCell(cell));
}


CELL * p_and(CELL * params)
{
CELL * result = trueCell;

while(params != nilCell)
    {
    result = evaluateExpression(params);
    if(isNil(result) || isEmpty(result)) return(copyCell(result));
    params = params->next;
    }

if(symbolCheck)
    {
    pushResultFlag = FALSE;
    return(result);
    }
    
return(copyCell(result));     
}


CELL * p_or(CELL * params)
{
CELL * result = nilCell;

while(params != nilCell)
    {
    result = evaluateExpression(params);
    if(!isNil(result) && !isEmpty(result)) 
        {
        if(symbolCheck)
            {
            pushResultFlag = FALSE;
            return(result);
            }
        return(copyCell(result));
        }
    params = params->next;
    }

return(copyCell(result));
}


CELL * p_not(CELL * params)
{
CELL * eval;

eval = evaluateExpression(params);
if(isNil(eval) || isEmpty(eval)) 
    return(trueCell);
return(nilCell);
}



/* ------------------------------ I / O --------------------------------- */

CELL * p_print(CELL * params)
{
return println(params, FALSE);
}


CELL * p_println(CELL * params)
{
return println(params, TRUE);
}


CELL * println(CELL * params, int lineFeed)
{
CELL * result;

result = nilCell;
while(params != nilCell)
    {
    result = evaluateExpression(params);
    printCell(result, 0, OUT_DEVICE);
    params = params->next;
    }

if(lineFeed) varPrintf(OUT_DEVICE, LINE_FEED);

return(copyCell(result));
}


CELL * p_device(CELL * params)
{
if(params != nilCell)
    getInteger(params, &printDevice);
return(stuffInteger(printDevice));
}


CELL * p_load(CELL * params)
{
char * fileName;
CELL * result = nilCell;
CELL * next;
SYMBOL * context;
int count = 0;

/* get last parameter */
if((next = params) == nilCell)
    errorProc(ERR_MISSING_ARGUMENT);
while(next->next != nilCell)
    {
    count++;
    next = next->next;
    }

next = evaluateExpression(next);
if(next->type == CELL_STRING)
    {
    count++;
    context = mainContext;
    }
else
    {
    if(count == 0)
        errorProcExt(ERR_STRING_EXPECTED, next);
    if((context = getCreateContext(next, FALSE)) == NULL)
        errorProcExt(ERR_SYMBOL_OR_CONTEXT_EXPECTED, next);
    next = NULL;
    }

while(count--)
    {
    /* if last arg was a string, avoid double evaluation */
    if(count == 0 && next != NULL)
        getStringSize(next, &fileName, NULL, FALSE);
    else 
        params = getString(params, &fileName);

    result = loadFile(fileName, 0, 0, context);

    if(result == NULL)
        return(errorProcExt2(ERR_ACCESSING_FILE, stuffString(fileName)));
    }

return(result);
}


void saveContext(SYMBOL * sPtr, UINT device)
{
SYMBOL * contextSave;

contextSave = currentContext;

currentContext = sPtr;

if(currentContext != mainContext)
    {
    varPrintf(device, "%s(context '%s)%s%s", 
        LINE_FEED, sPtr->name, LINE_FEED, LINE_FEED);
    /* make sure 'set' is not overwritten */
    if((sPtr = lookupSymbol("set", currentContext)) != NULL)
        {
        deleteList((CELL *)sPtr->contents);
        sPtr->contents = (UINT)copyCell(nilCell);
        }
    }
            

saveSymbols((SYMBOL *)((CELL*)currentContext->contents)->aux, device);

if(currentContext != mainContext)
    varPrintf(device, "%s(context MAIN)%s%s", 
        LINE_FEED, LINE_FEED, LINE_FEED);

currentContext = contextSave;
}


void saveSymbols(SYMBOL * sPtr, UINT device)
{
int type;

if(sPtr != NIL_SYM && sPtr != NULL)
    {
    saveSymbols(sPtr->left, device);
    type = symbolType(sPtr);
    if(type == CELL_CONTEXT)
        {
        if(sPtr == (SYMBOL *)((CELL *)sPtr->contents)->contents)
            {
            if(sPtr != currentContext && *sPtr->name != '$') saveContext(sPtr, device);
            }
        else printSymbol(sPtr, device); 
        }
    /* don't save primitives, symbols containing nil and the trueSymbol */
    else if(type != CELL_PRIMITIVE && type != CELL_NIL
        && sPtr != trueSymbol && type != CELL_IMPORT_CDECL && type != CELL_IMPORT_FFI
#if defined(WINDOWS) || defined(CYGWIN)
        && type != CELL_IMPORT_DLL
#endif
        )
        if(*sPtr->name != '$') printSymbol(sPtr, device);
    saveSymbols(sPtr->right, device);
    }
}


CELL * p_save(CELL * params)
{
char * fileName;
STREAM strStream = {NULL, NULL, 0, 0, 0};
SYMBOL * contextSave;
#ifndef EMSCRIPTEN
CELL * result;
CELL * dataCell;
#endif
int errorFlag = 0;

contextSave = currentContext;
currentContext = mainContext;

params = getString(params, &fileName);

openStrStream(&strStream, MAX_STRING, 0);
serializeSymbols(params, (UINT)&strStream);

#ifndef EMSCRIPTEN
/* check for URL format */
if(my_strnicmp(fileName, "http://", 7) == 0)
    {
    dataCell = stuffString(strStream.buffer);
    result = getPutPostDeleteUrl(fileName, dataCell, HTTP_PUT, CONNECT_TIMEOUT);
    pushResult(result);
    deleteList(dataCell);
    errorFlag = (strncmp((char *)result->contents, "ERR:", 4) == 0);
    }
else
#endif
    errorFlag = writeFile(fileName, strStream.buffer, strStream.position, "w");

closeStrStream(&strStream);

currentContext = contextSave;

if(errorFlag)
    return(errorProcExt2(ERR_SAVING_FILE, stuffString(fileName)));

return(trueCell);
}

void serializeSymbols(CELL * params, UINT device)
{
SYMBOL * sPtr;

if(params->type == CELL_NIL)
    saveSymbols((SYMBOL *)((CELL*)currentContext->contents)->aux, device);
else
    while(params != nilCell)
    {
    params = getSymbol(params, &sPtr);
    if(symbolType(sPtr) == CELL_CONTEXT)
        saveContext((SYMBOL*)((CELL *)sPtr->contents)->contents, device);
    else        
        printSymbol(sPtr, device);
    }
}

/* ----------------------- copy a context with 'new' -------------- */
static SYMBOL * fromContext;
static SYMBOL * toContext;
static int overWriteFlag;

CELL * copyContextList(CELL * cell);
UINT * copyContextArray(CELL * array);


CELL * copyContextCell(CELL * cell)
{
CELL * newCell;
SYMBOL * sPtr;
SYMBOL * newSptr;

if(firstFreeCell == NULL) allocBlock();
newCell = firstFreeCell;
firstFreeCell = newCell->next;
++cellCount;

newCell->type = cell->type;
newCell->next = nilCell;
newCell->aux = cell->aux;
newCell->contents = cell->contents;

if(cell->type == CELL_DYN_SYMBOL)
    {
    sPtr = (SYMBOL*)cell->aux;
    if(sPtr->context == fromContext)
        newCell->aux =
            (UINT)translateCreateSymbol(sPtr->name, 0, toContext, TRUE);
    newCell->contents = (UINT)allocMemory(strlen((char *)cell->contents) + 1);
    memcpy((void *)newCell->contents,
        (void*)cell->contents, strlen((char *)cell->contents) + 1);
    }

if(cell->type == CELL_SYMBOL)
    {
    /* if the cell copied, itself contains a symbol copy it recursevely,
       if new, if not done here it might not been seen as new later and left
       without contents */
    sPtr = (SYMBOL *)cell->contents;
    /* don't copy symbols of builtins and libffi */
    if(sPtr->context == fromContext && !(sPtr->flags & (SYMBOL_BUILTIN | SYMBOL_FFI)))
        {
        if((newSptr = lookupSymbol(sPtr->name, toContext)) == NULL)
            {
            newSptr = translateCreateSymbol(sPtr->name, symbolType(sPtr), toContext, TRUE);
            deleteList((CELL *)newSptr->contents);
            newSptr->contents = (UINT)copyContextCell((CELL*)sPtr->contents);
            }
        newCell->contents = (UINT)newSptr;
        newSptr->flags = sPtr->flags;
        }
    }

if(isEnvelope(cell->type))
    {
    if(cell->type == CELL_ARRAY)
        newCell->contents = (UINT)copyContextArray(cell);
    else
        {
        /* undo push last optimization */
        newCell->aux = (UINT)nilCell;
        newCell->contents = (UINT)copyContextList((CELL *)cell->contents);
        }
    }
else if(cell->type == CELL_STRING)
    {
    newCell->contents = (UINT)allocMemory((UINT)cell->aux);
    memcpy((void *)newCell->contents, (void*)cell->contents, (UINT)cell->aux);
    }

return(newCell);
}


CELL * copyContextList(CELL * cell)
{
CELL * firstCell;
CELL * newCell;

if(cell == nilCell || cell == trueCell) return(cell);

firstCell = newCell = copyContextCell(cell);

while((cell = cell->next) != nilCell)
    {
    newCell->next = copyContextCell(cell);
    newCell = newCell->next;
    }
    
return(firstCell);
}


UINT * copyContextArray(CELL * array)
{
CELL * * newAddr;
CELL * * orgAddr;
CELL * * addr;
size_t size;

addr = newAddr = (CELL * *)callocMemory(array->aux);

size = (array->aux - 1) / sizeof(UINT);
orgAddr = (CELL * *)array->contents;

while(size--)
    *(newAddr++) = copyContextCell(*(orgAddr++));
    
return((UINT*)addr);
}


void iterateCopyCreateSymbols(SYMBOL * sPtr)
{
int type, newFlag = FALSE;
SYMBOL * newPtr = NULL;

if(sPtr != NIL_SYM && sPtr != NULL && !(sPtr->flags & SYMBOL_BUILTIN))
    {
    iterateCopyCreateSymbols(sPtr->left);
    type = symbolType(sPtr);

    /* optimized check for default symbol, translate default symbol to default symbol */
    if(*sPtr->name == *fromContext->name && strcmp(sPtr->name, fromContext->name) == 0)
        {
        if((newPtr = lookupSymbol(toContext->name, toContext)) == NULL)
            {
            newPtr = translateCreateSymbol(toContext->name, type, toContext, TRUE);
            newFlag = TRUE;
            }
        }
    else
        {
        if((newPtr = lookupSymbol(sPtr->name, toContext)) == NULL)
            {
            newPtr = translateCreateSymbol(sPtr->name, type, toContext, TRUE);
            newFlag = TRUE;
            }
        }

    if(overWriteFlag == TRUE || newFlag == TRUE)
        {
        deleteList((CELL *)newPtr->contents);
        newPtr->contents = (UINT)copyContextCell((CELL*)sPtr->contents);
        }

    newPtr->flags |= sPtr->flags & SYMBOL_PROTECTED;
    iterateCopyCreateSymbols(sPtr->right);
    }
}



CELL * p_new(CELL * params)
{
CELL * next;

overWriteFlag = FALSE;

params = getContext(params, &fromContext);
if(!fromContext) return(nilCell); /* for debug mode */

next = params->next;

if(params == nilCell)
    toContext = currentContext;
else 
    {
    params = evaluateExpression(params);
    if(params->type == CELL_CONTEXT || params->type == CELL_SYMBOL)
        toContext = (SYMBOL *)params->contents;
    else
        return(errorProcExt(ERR_CONTEXT_EXPECTED, params));

        overWriteFlag = (evaluateExpression(next)->type != CELL_NIL);

    /* allow symbols to be converted to contexts */
    if(symbolType(toContext) != CELL_CONTEXT)
        {
        if(isProtected(toContext->flags))
            return(errorProcExt(ERR_SYMBOL_PROTECTED, params));

        if(toContext->context != mainContext)
            return(errorProcExt2(ERR_NOT_IN_MAIN, stuffSymbol(toContext)));

        deleteList((CELL *)toContext->contents);
        makeContextFromSymbol(toContext, NULL);
        }
    }

if(toContext == mainContext)
    return(errorProc(ERR_TARGET_NO_MAIN));

iterateCopyCreateSymbols((SYMBOL *)((CELL*)fromContext->contents)->aux);

return(copyCell((CELL*)toContext->contents));
}


CELL * p_defineNew(CELL * params)
{
SYMBOL * sourcePtr;
SYMBOL * targetPtr;
char * name;

params = getSymbol(params, &sourcePtr);
if(params != nilCell)
    {
    getSymbol(params, &targetPtr);
    name = targetPtr->name;
    toContext = targetPtr->context;
    }
else
    {
    name = sourcePtr->name;
    toContext = currentContext;
    }

if(toContext == mainContext)
    return(errorProc(ERR_TARGET_NO_MAIN));

fromContext = sourcePtr->context;
targetPtr = translateCreateSymbol(name, symbolType(sourcePtr), toContext, TRUE);

deleteList((CELL *)targetPtr->contents);
targetPtr->contents = (UINT)copyContextCell((CELL*)sourcePtr->contents);

targetPtr->flags = sourcePtr->flags;

return(stuffSymbol(targetPtr));
}
    


/* ------------------------------ system ------------------------------ */

CELL * isType(CELL *, int);

CELL * p_isNil(CELL * params)
{
params = evaluateExpression(params);

if(isNil(params))
        return(trueCell);

return(nilCell);
}

CELL * p_isEmpty(CELL * params)
{
CELL * cell;

getEvalDefault(params, &cell);
return(isEmptyFunc(cell));
}

CELL * isEmptyFunc(CELL * cell)
{
if(cell->type == CELL_STRING)
    {
    if(*(char*)cell->contents == 0)
        return(trueCell);
    else return(nilCell);
    }

if(!isList(cell->type))
        return(errorProcExt(ERR_LIST_OR_STRING_EXPECTED, cell));
if(cell->contents == (UINT)nilCell)
    return(trueCell);
return(nilCell);
}

CELL * isZero(CELL * cell)
{
#ifdef BIGINT
int * numPtr;
#endif

switch(cell->type)
    {
#ifndef NEWLISP64
    case CELL_INT64:
        if(*(INT64 *)&cell->aux == 0)
            return(trueCell);
        break;
#endif
    case CELL_FLOAT:
#ifndef NEWLISP64
        if(*(double *)&cell->aux == 0.0)
#else
        if(*(double *)&cell->contents == 0.0)
#endif
            return(trueCell);
        break;
    case CELL_LONG:
        if(cell->contents == 0)
            return(trueCell);
        break;
#ifdef BIGINT
    case CELL_BIGINT:
        numPtr = (int *)(UINT)cell->contents;
        if(cell->aux == 2 && numPtr[1] == 0)
            return(trueCell);
        break;
#endif
    default:
        break;
    }

return(nilCell);
}


CELL * p_isNull(CELL * params)
{
CELL * cell;

cell = evaluateExpression(params);
if(isNil(cell))
    return(trueCell);

if( (cell->type == CELL_STRING || isList(cell->type)))
    return(isEmptyFunc(cell));

#ifndef NEWLISP64
if(cell->type == CELL_FLOAT && (isnan(*(double *)&cell->aux)) )
#else
if(cell->type == CELL_FLOAT && (isnan(*(double *)&cell->contents)))
#endif
    return(trueCell);

return(isZero(cell));
}

CELL * p_isZero(CELL * params)
{
return(isZero(evaluateExpression(params)));
}


CELL * p_isTrue(CELL * params)
{
params = evaluateExpression(params);
if(!isNil(params) && !isEmpty(params))
        return(trueCell);

return(nilCell);
}

CELL * p_isInteger(CELL * params)
{
params = evaluateExpression(params);
if((params->type & COMPARE_TYPE_MASK) == CELL_INT)
    return(trueCell);
return(nilCell);
}

#ifdef BIGINT
CELL * p_isBigInteger(CELL * params)
    { return(isType(params, CELL_BIGINT)); }
#endif

CELL * p_isFloat(CELL * params)
    { return(isType(params, CELL_FLOAT)); }
    
CELL * p_isNumber(CELL * params)
{
params = evaluateExpression(params);
if(isNumber(params->type)) return(trueCell);
return(nilCell);
}

CELL * p_isString(CELL * params)
    { return(isType(params, CELL_STRING)); }

CELL * p_isSymbol(CELL * params)
        { return(isType(params, CELL_SYMBOL)); }

CELL * p_isContext(CELL * params)
{
char * symStr;
SYMBOL * ctx;

/* check type */
if(params->next == nilCell) 
    return(isType(params, CELL_CONTEXT)); 

/* check for existense of symbol */
params = getContext(params, &ctx);
if(!ctx) return(nilCell); /* for debug mode */
getString(params, &symStr);

return (lookupSymbol(symStr, ctx) ? trueCell : nilCell);    
}

CELL * p_isPrimitive(CELL * params)
    { return(isType(params, CELL_PRIMITIVE)); }


CELL * p_isGlobal(CELL * params)
{
params = evaluateExpression(params);
if(isSymbol(params->type) && isGlobal(((SYMBOL *)params->contents)->flags))
    return(trueCell);
return(nilCell);
}

CELL * p_isProtected(CELL * params)
{
params = evaluateExpression(params);
if(isSymbol(params->type) && isProtected(((SYMBOL *)params->contents)->flags))
    return(trueCell);
return(nilCell);
}
    
CELL * p_isAtom(CELL * params)
{
if(params == nilCell)
    return(errorProc(ERR_MISSING_ARGUMENT));
params = evaluateExpression(params);
if(params->type & ENVELOPE_TYPE_MASK) return(nilCell);
return(trueCell);
}

CELL * p_isQuote(CELL *params)
    { return(isType(params, CELL_QUOTE)); }

CELL * p_isList(CELL * params)
    { return(isType(params, CELL_EXPRESSION)); }

CELL * p_isLambda(CELL * params)
    { return(isType(params, CELL_LAMBDA)); }

CELL * p_isMacro(CELL * params)
{ 
SYMBOL * sPtr;

if(params == nilCell)
    return(errorProc(ERR_MISSING_ARGUMENT));
params = evaluateExpression(params);
if(params->type == CELL_FEXPR) /* lambda-macro */
    return(trueCell);
if(params->type == CELL_SYMBOL)
    {
    sPtr = (SYMBOL *)params->contents;
    if(sPtr->flags & SYMBOL_MACRO)
        return(trueCell);
    }
return(nilCell);
}

CELL * p_isArray(CELL * params)
    { return(isType(params, CELL_ARRAY)); }

CELL * isType(CELL * params, int operand)
{
CELL * contextCell;

if(params == nilCell)
    return(errorProc(ERR_MISSING_ARGUMENT));
params = evaluateExpression(params);
if((UINT)operand == params->type) return(trueCell);
switch(operand)
    {
    case CELL_PRIMITIVE:
        if(params->type == CELL_IMPORT_CDECL
        || params->type == CELL_IMPORT_FFI
#if defined(WINDOWS) || defined(CYGWIN)
        || params->type == CELL_IMPORT_DLL 
#endif
        )
            return(trueCell);
        break;
    case CELL_EXPRESSION:
        if(isList(params->type)) return(trueCell);
                break;
    case CELL_SYMBOL:
        if(params->type == CELL_DYN_SYMBOL) /* check if already created */
            {
            contextCell = (CELL *)((SYMBOL *)params->aux)->contents;
            if(contextCell->type != CELL_CONTEXT)
                fatalError(ERR_CONTEXT_EXPECTED, 
                    stuffSymbol((SYMBOL*)params->aux), TRUE);
            if(lookupSymbol((char *)params->contents, (SYMBOL*)contextCell->contents))
                return(trueCell);
            }
            
        break;
    default:
        break;
    }

return(nilCell);
}


CELL * p_isLegal(CELL * params)
{
char * symStr;

getString(params, &symStr);

if(isLegalSymbol(symStr)) return(trueCell);

return(nilCell);
}


int isLegalSymbol(char * source)
{
STREAM stream;
char token[MAX_SYMBOL + 1];
int tklen;

if(*source == (char)'"' || *source == (char)'{' 
   || (unsigned char)*source <= (unsigned char)' ' || *source == (char)';' || *source == (char)'#')
        return(0);

makeStreamFromString(&stream, source);

return(getToken(&stream, token, &tklen) == TKN_SYMBOL && tklen == stream.size - 4 * MAX_STRING);
}

CELL * p_exit(CELL * params)
{
UINT result;

#ifndef EMSCRIPTEN
if(daemonMode) 
    {
    fclose(IOchannel);
#ifndef WINDOWS
    IOchannel = NULL;
#endif
    longjmp(errorJump, ERR_USER_RESET);
    }
#else
return(nilCell);
#endif

if(params != nilCell) getInteger(params, &result);
else result = 0;

#ifdef HAVE_FORK
/* release spawn resources */
purgeSpawnList(TRUE);
#endif

exit(result);
return(trueCell);
}


#ifdef EMSCRIPTEN
void emscriptenReload(void)
{
char * cmd = "location.reload();";
printf("# newLISP is reloading ...\n");
evalStringJS(cmd, strlen(cmd));
}
#endif


CELL * p_reset(CELL * params)
{
int blockCountBefore = blockCount;

if(params != nilCell)
    {
    params = evaluateExpression(params);
    if(isNumber(params->type))
        {
        getIntegerExt(params, (UINT*)&MAX_CELL_COUNT, FALSE);
        if(MAX_CELL_COUNT < MAX_BLOCK) MAX_CELL_COUNT = MAX_BLOCK;
        return(stuffInteger(MAX_CELL_COUNT));
        }
    else if(isNil(params)) 
        {
        freeCellBlocks(); 
        return(stuffIntegerList(2, blockCountBefore, blockCount)); /* 10.3.3 */
        }
#ifndef LIBRARY
#ifndef WINDOWS
    else
        execv(MainArgs[0], MainArgs);
#endif
#endif
#ifdef EMSCRIPTEN
        emscriptenReload();
#endif
    }
else
#ifndef EMSCRIPTEN
    longjmp(errorJump, ERR_USER_RESET);
#else
    return(nilCell);
#endif

return(trueCell);
}

CELL * setEvent(CELL * params, SYMBOL * * eventSymPtr, char * sysSymName)
{
if(params != nilCell) getCreateSymbol(params, eventSymPtr, sysSymName);
return(makeCell(CELL_SYMBOL, (UINT)*eventSymPtr));
}

CELL * p_errorEvent(CELL * params)
{
return(setEvent(params, &errorEvent, "$error-event"));
}

CELL * p_promptEvent(CELL * params)
{
return(setEvent(params, &promptEvent, "$prompt-event"));
}

CELL * p_commandEvent(CELL * params)
{
return(setEvent(params, &commandEvent, "$command-event"));
}

CELL * p_transferEvent(CELL * params)
{
return(setEvent(params, &transferEvent, "$transfer-event"));
}

CELL * p_readerEvent(CELL * params)
{
return(setEvent(params, &readerEvent, "$reader-event"));
}


#ifndef WINDOWS

CELL * p_timerEvent(CELL * params)
{
double seconds;
UINT timerOption = 0;
struct itimerval timerVal;
struct itimerval outVal;
static double duration;

if(params != nilCell) 
  {
  params = getCreateSymbol(params, &timerEvent, "$timer");

  if(params != nilCell)
    {
    params = getFloat(params, &seconds);
    duration = seconds;
    if(params != nilCell)
        getInteger(params, &timerOption);
    memset(&timerVal, 0, sizeof(timerVal));
    timerVal.it_value.tv_sec = seconds;
    timerVal.it_value.tv_usec = (seconds - timerVal.it_value.tv_sec) * 1000000;
    if(setitimer((int)timerOption, &timerVal, &outVal) == -1)
      return(nilCell);
    return(stuffInteger(0));
    }
  else
    getitimer(timerOption, &outVal);

  seconds = duration - (outVal.it_value.tv_sec + outVal.it_value.tv_usec / 1000000.0);
  return(stuffFloat(seconds));
  }
  
return(makeCell(CELL_SYMBOL, (UINT)timerEvent));
}
#endif

#ifndef EMSCRIPTEN
#define IGNORE_S 0
#define DEFAULT_S 1
#define RESET_S 2
CELL * p_signal(CELL * params)
{
SYMBOL * signalEvent;
UINT sig;
char sigStr[12];
char mode;

params = getInteger(params, &sig);
if(sig > 32 || sig < 1) return(nilCell);

if(params->type == CELL_STRING)
    {
    mode = toupper(*(char *)params->contents);
    symHandler[sig - 1] = nilSymbol;
    if(mode == 'I') /* "ignore" */
        return(signal(sig, SIG_IGN) == SIG_ERR ? nilCell: trueCell);
    else if(mode == 'D') /* "default" */
        return(signal(sig, SIG_DFL) == SIG_ERR ? nilCell: trueCell);
    else if(mode == 'R') /* "reset" */
        return(signal(sig, signal_handler) == SIG_ERR ? nilCell: trueCell);
    }
else if(params != nilCell)
    {
    snprintf(sigStr, 11, "$signal-%d", (int)sig);
    getCreateSymbol(params, &signalEvent, sigStr);
    symHandler[sig - 1] = signalEvent;
    if(signal(sig, signal_handler) == SIG_ERR) return(nilCell);
    }
  
return(makeCell(CELL_SYMBOL, (UINT)symHandler[sig - 1]));
}
#endif

CELL * p_lastError(CELL * params)
{
CELL * result;
char * sPtr;
UINT errNum = errorReg;

if(params != nilCell)
    getInteger(params, &errNum);

if(!errNum) return(nilCell);

result = makeCell(CELL_EXPRESSION, (UINT)stuffInteger(errNum));
if(params != nilCell)
    sPtr = (errNum > MAX_ERROR_NUMBER) ? UNKNOWN_ERROR : errorMessage[errNum];
else
    sPtr = errorStream.buffer;

((CELL *)result->contents)->next = stuffString(sPtr);

return(result);
}


CELL * p_dump(CELL * params)
{
CELL * blockPtr;
CELL * cell;
UINT count = 0;
int i;

if(params != nilCell)
    {
    cell = evaluateExpression(params);
    return(stuffIntegerList
           (5, cell, cell->type, cell->next, cell->aux, cell->contents));
    }

blockPtr = cellMemory;
while(blockPtr != NULL)
    {
    for(i = 0; i <  MAX_BLOCK; i++)
        {
        if(*(UINT *)blockPtr != CELL_FREE)
            {
            varPrintf(OUT_DEVICE, "address=%lX type=%d contents=", blockPtr, blockPtr->type);
            printCell(blockPtr, TRUE, OUT_DEVICE);
            varPrintf(OUT_DEVICE, LINE_FEED);
            ++count;
            }
        ++blockPtr;
        }
    blockPtr = blockPtr->next;
    }

return(stuffInteger(count));
}


CELL * p_mainArgs(CELL * params)
{
CELL * cell;
ssize_t idx;

cell = (CELL*)mainArgsSymbol->contents;
if(params != nilCell && cell->type == CELL_EXPRESSION)
    {
    getInteger(params, (UINT *)&idx);
    cell = (CELL *)cell->contents;
    if(idx < 0) idx = convertNegativeOffset(idx, (CELL *)cell);
    while(idx--) cell = cell->next;
    }

return(copyCell(cell));
}


CELL * p_context(CELL * params)
{
CELL * cell;
SYMBOL * sPtr;
SYMBOL * cPtr;
char * newSymStr;

if(params->type == CELL_NIL)
    return(copyCell((CELL *)currentContext->contents));

if((cPtr = getCreateContext(params, TRUE)) == NULL)
    return(errorProcExt(ERR_SYMBOL_OR_CONTEXT_EXPECTED, params));
    
if(params->next == nilCell)
    {
    currentContext = cPtr;
    return(copyCell( (CELL *)currentContext->contents));
    }
    
params = params->next;
cell = evaluateExpression(params);
if(cell->type == CELL_STRING)
    newSymStr = (char *)cell->contents;
else if(cell->type == CELL_SYMBOL)  
    newSymStr = ((SYMBOL *)cell->contents)->name;
else if(cell->type == CELL_DYN_SYMBOL)
    {
    sPtr = getDynamicSymbol(cell);
    newSymStr = sPtr->name;
    }
else
    return(errorProcExt(ERR_ILLEGAL_TYPE, cell));


if(params->next == nilCell)
    {
    pushResultFlag = FALSE;
    sPtr = lookupSymbol(newSymStr, cPtr);
    if(sPtr == NULL)
        return(nilCell);
    else
        return((CELL *)sPtr->contents);
    }


sPtr = translateCreateSymbol(newSymStr, CELL_NIL, cPtr, TRUE);

return(setDefine(sPtr, params->next, SET_SET));
}


SYMBOL * getCreateContext(CELL * cell, int evaluate)
{
SYMBOL * contextSymbol;

if(evaluate)
    cell = evaluateExpression(cell);
if(cell->type == CELL_SYMBOL || cell->type == CELL_CONTEXT)
    contextSymbol = (SYMBOL *)cell->contents;
else
    return(NULL);


if(symbolType(contextSymbol) != CELL_CONTEXT)
    {
    if(contextSymbol->context != mainContext)
        {
        contextSymbol= translateCreateSymbol(
            contextSymbol->name, CELL_CONTEXT, mainContext, 1);
        }

    if(symbolType(contextSymbol) != CELL_CONTEXT)
        {
        if(isProtected(contextSymbol->flags))
            errorProcExt2(ERR_SYMBOL_PROTECTED, stuffSymbol(contextSymbol));

        deleteList((CELL *)contextSymbol->contents);
        makeContextFromSymbol(contextSymbol, NULL);
        }
    }

/* if this is a context var retrieve the real context symbol */
return((SYMBOL *)((CELL *)contextSymbol->contents)->contents);
}


CELL * p_default(CELL * params)
{
SYMBOL * contextSymbol;

getContext(params, &contextSymbol);

symbolCheck = translateCreateSymbol(contextSymbol->name, CELL_NIL, contextSymbol, TRUE);
pushResultFlag = FALSE;
return((CELL *)symbolCheck->contents);
}


/* FOOP fuctions */

/* filled in colon, only used internally and by obj function */
/* need stack for objSymbol.contents */
/* what happens to stack when using catch/throw */

CELL * p_colon(CELL * params)
{
SYMBOL * contextSymbol = NULL;
SYMBOL * methodSymbol;
SYMBOL * sPtr;
CELL * proc;
CELL * cell;
CELL * obj;
CELL * objSave;
CELL * objCellSave;
SYMBOL * objSymbolContextSave;
int objSymbolFlagsSave;

if(params->type != CELL_SYMBOL)
    return(errorProcExt(ERR_SYMBOL_EXPECTED, params));

methodSymbol = (SYMBOL *)params->contents;
params = getEvalDefault(params->next, &obj);

objSymbolFlagsSave = objSymbol.flags;
objSymbolContextSave = objSymbol.context;
if(symbolCheck) 
    {
    objSymbol.flags = symbolCheck->flags;
    objSymbol.context = symbolCheck->context;
    }   

objSave = (CELL *)objSymbol.contents;
objCellSave = objCell;
objCell = obj;

#ifdef FOOP_DEBUG
printf("entering colon, saving in objSave:");
printCell(objSave, TRUE, OUT_CONSOLE);
puts("");
#endif

cell = (CELL *)obj->contents;
if(obj->type != CELL_EXPRESSION)
    return(errorProcExt(ERR_LIST_EXPECTED, obj));

if(cell->type == CELL_SYMBOL || cell->type == CELL_CONTEXT)
    contextSymbol = (SYMBOL *)cell->contents;
if(contextSymbol == NULL || symbolType(contextSymbol) != CELL_CONTEXT)
    return(errorProcExt(ERR_CONTEXT_EXPECTED, cell));

sPtr = methodSymbol;
if((methodSymbol = lookupSymbol(sPtr->name, contextSymbol)) == NULL)
    return(errorProcExt2(ERR_INVALID_FUNCTION, stuffSymbol(sPtr)));

cell = stuffSymbol(methodSymbol);
proc = makeCell(CELL_EXPRESSION, (UINT)cell);

while(params != nilCell)
    {
    cell->next = copyCell(params);
    cell = cell->next;
    params = params->next;
    }

pushResult(proc);

#ifdef FOOP_DEBUG
printf("colon calling %s in %s with objCell:", methodSymbol->name, contextSymbol->name);
printCell(objCell, TRUE, OUT_CONSOLE);
puts("");
#endif

cell = copyCell(evaluateExpression(proc));

objSymbol.flags = objSymbolFlagsSave;
objSymbol.context = objSymbolContextSave;

objSymbol.contents = (UINT)objSave;
objCell = objCellSave;

#ifdef FOOP_DEBUG
printf("leavin colon, objCell restored to:");
printCell(obj, TRUE, OUT_CONSOLE);
puts("");
#endif


return(cell);
}

CELL * p_self(CELL * params)
{
CELL * result;

if(objSymbol.contents == (UINT)nilCell)
    return(nilCell);

if(params == nilCell)
    {
    symbolCheck = &objSymbol;
    pushResultFlag = FALSE;
    return((CELL *)objSymbol.contents);
    }

result = implicitIndexList((CELL*)objSymbol.contents, params);

symbolCheck = &objSymbol;
pushResultFlag = FALSE;

return(result);
}


CELL * p_systemSymbol(CELL * params)
{
UINT idx;

getInteger(params, &idx);

if(idx > 15) return(nilCell);

return(copyCell((CELL*)sysSymbol[idx]->contents));
}


/* end of file */
