/** 
   --  Subroutines for the Internal Forth-System
   
    Copyright (C) Tektronix, Inc. 1998 - 2001. All rights reserved.
  
    @see     GNU LGPL
    @author  Tektronix CTE            @(#) %derived_by: guidod %
    @version %version: bln_mpt1!1.48 %
      (%date_modified: Wed Jul 24 11:37:14 2002 %)
 */
/*@{*/
#if defined(__version_control__) && defined(__GNUC__)
static char* id __attribute__((unused)) = 
"@(#) $Id: %full_filespec:  engine-sub.c~bln_mpt1!1.48:csrc:bln_12xx!1 % $";
#endif

#define _P4_SOURCE 1

#include <pfe/pfe-base.h>
#include <pfe/def-xtra.h>

#include <stdio.h>
#include <stdlib.h>
#include <stdarg.h>
#include <errno.h>
#include <string.h>
#include <setjmp.h>

#ifdef _K12_SOURCE
#include <pfe/main-k12.h>
#endif

#include <pfe/option-ext.h>
#include <pfe/double-sub.h>
#include <pfe/debug-ext.h>
#include <pfe/block-sub.h>
#include <pfe/file-sub.h>
#include <pfe/term-sub.h>
#include <pfe/_missing.h>
#include <pfe/exception-sub.h>
#include <pfe/chainlist-ext.h>

#include <pfe/logging.h>

FCode(p4_noop)
{
    /* well, nothing... */
}



/* ********************************************************************** 
   inner and outer interpreter						  
 */

#ifndef PFE_SBR_CALL_THREADING

/* jumpbuf is a jmp_buf enanced by space to preserve variables that
   may be stored in cpu register, would be the Forth VM
 */
typedef struct	
{
    jmp_buf jmp;
# ifdef P4_REGRP
    p4xcode **rp;
# endif
# ifdef P4_REGSP
    p4cell *sp;
# endif
# ifdef P4_REGLP
    p4cell *lp;
# endif
# ifdef P4_REGFP
    double *fp;
# endif
}

jumpbuf;

/**
   longjmp via (jumpbuf*) following inline
   - purpose: stop the inner interpreter
 */
FCode_XE (p4_jump)	
{   FX_USE_CODE_ADDR 
{
    jumpbuf *buf = (jumpbuf *) *IP;

# ifdef P4_REGRP		/* save global register variables */
    buf->rp = RP;
# endif
# ifdef P4_REGSP
    buf->sp = SP;
# endif
# ifdef P4_REGLP
    buf->lp = LP;
# endif
# ifndef P4_NO_FP
# ifdef P4_REGFP
    buf->fp = FP;
# endif
# endif
    longjmp (buf->jmp, 1);
    /*FX_USE_CODE_EXIT;*/
}
}


#endif /* ! SBR_THREADING */

/**
   Run a forth word from within C-code
   - this is the inner interpreter
 */
_export void
p4_run_forth (p4xt xt)
{
#if defined PFE_SBR_CALL_THREADING
    p4_sbr_call (xt);
    return;
#else

    jumpbuf stop;

#  if ! defined PFE_CALL_THREADING
    static p4code jump_p = PFX (p4_jump);
    p4xcode list[3];
    list[0] = xt;
    list[1] = &jump_p;
    list[2] = (p4xcode) &stop;
#  else
    /* sbr-stub, xt-code, xt-data, sbr-stub, jump-code, jump-data */
    p4xcode list[6] /* = { 0,0,0,0,0,0 } */ ;
    *p4_compile_xcode(
	p4_compile_comma(
	    list,
	    xt),
	PFX(p4_jump)) = (p4xcode) &stop;
#  endif

    IP = list;
#  if !defined P4_WP_VIA_IP && !defined PFE_CALL_THREADING
    p4WP = *IP;
#  endif

    if (setjmp (stop.jmp))
    
{
#     ifdef P4_REGRP		/* restore global register variables */
        RP = stop.rp;		/* clobbered by longjmp() */
#     endif
#     ifdef P4_REGSP
        SP = stop.sp;
#     endif
#     ifdef P4_REGLP
        LP = stop.lp;
#     endif
#     ifndef P4_NO_FP
#     ifdef P4_REGFP
        FP = stop.fp;
#     endif
#     endif
        return;
    }


    /* next_loop */
    for (;;)
    
{
#    ifdef PFE_CALL_THREADING
#      define NVAR register p4code c;
#      define NEXT c = *IP++, (c)()
#    elif defined P4_WP_VIA_IP
#      define NVAR register p4xt w;
#      define NEXT w = *IP++, (*w) ()	/* ip is register but p4WP isn't */
#    else
#      define NVAR
#      define NEXT p4WP = *IP++, (*p4WP) ()	
				/* ip and p4WP are same: register or not */
#    endif

        NVAR;
#     ifdef UNROLL_NEXT		/* USER-CONFIG: if it helps */
        NEXT; NEXT; NEXT; NEXT;	/* do a little loop unrolling for speed */
        NEXT; NEXT; NEXT; NEXT;
#     else
        NEXT;			/* on some machines it doesn't do any good */
#     endif
    }


#endif /* ! PFE_SBR_CALL_THREADING */
}


/**
 */
_export void
p4_call (p4xt xt)
{
# if 0 && defined __target_os_sunos
    void *saved_ip;

    saved_ip = IP;
    printf ("%X/%X\n", IP, saved_ip);
    p4_run_forth (xt);
    printf ("%X/%X\n", IP, saved_ip);
    IP = saved_ip;
    printf ("%X/%X\n\n", IP, saved_ip);
# elif !defined PFE_SBR_CALL_THREADING
    p4xcode *saved_ip = IP;
    p4_run_forth (xt);
    IP = saved_ip;
# else
    p4_sbr_call (xt);
# endif
}


/**
   the NEXT call. Can be replaced by p4_debug_execute to
   trace the inner forth interpreter.
 */
_export void
p4_normal_execute (p4xt xt)
{
#  if defined PFE_SBR_CALL_THREADING /*FIXME: BODY / CODE ADDR needed? */
    (*p4_to_code(xt))();
#  else
    p4_call(xt);
#  endif
}


/**
   quick execute - unsafe and slow and simple
  
   use this routine for callbacks that might go through some forth
   colon-routines - that code shall not THROW or do some other nifty
   tricks with the return-stack or the inner interpreter. 
   Just simple things - use only for primitives or colon-routines,
   nothing curried with a DOES part in SBR-threading or sth. like that.
 */
_export void
p4_simple_execute (p4xt xt)
{
#  if defined PFE_SBR_CALL_THREADING /*FIXME: BODY / CODE ADDR needed? */
    (*p4_to_code(xt))();
#  elif defined PFE_CALL_THREADING 
    P4_REGIP_T ip = IP;
    P4_REGRP_T rp = RP; 
    p4xcode body = (p4xcode) P4_TO_BODY(xt);
    IP = &body; /* fake the body-field, just in case it is needed */
    (*p4_to_code(xt))();
    while (RP < rp) 
{ NVAR; NEXT; }

    IP = ip;
#  else /* ITC: */
    P4_REGIP_T ip = IP;
    P4_REGRP_T rp = RP; 
    IP = & xt;
    do 
{ NVAR; NEXT; }
  while (RP < rp);
    IP = ip;
#  endif
}


/* ================= INTERPRET =================== */

static p4ucell
FXCode (p4_interpret_find) /* hereclean */
{
    register p4char *s;
    register p4xt xt;

    /* WORD-string is at HERE and at PFE.word.ptr / PFE.word.len */
    s = p4_find (PFE.word.ptr, PFE.word.len);
    if (! s) return (p4cell) s; /* quick path, even alias null returncode */

    xt = p4_name_from (s);
    if (! STATE || *_FFA(s) & P4xIMMEDIATE)
    
{
	p4_call (xt);           /* execute it now */
	FX (p4_Q_stack);        /* check stack */
    }
else
{
	FX_COMPILE_COMMA (xt);  /* comma token */
    }

    return 1;
}



static p4ucell
FXCode (p4_interpret_number) /* hereclean */
{
    p4dcell d;

    /* WORD-string is at HERE and at PFE.word.ptr / PFE.word.len */
    if (! p4_number_question (PFE.word.ptr, PFE.word.len, &d))
	return 0; /* quick path */

    if (STATE)
    
{
	if (p4_DPL >= 0) 
	
{   
	    FX_COMPILE (p4_two_literal);
	    FX_COMMA_ (d.hi,'D');
            FX_COMMA_ (d.lo,'d');
	}
else
{
	    FX_COMPILE (p4_literal);
            FX_SCOMMA (d.lo);
	}

    }
else
{
	*--SP = d.lo;
	if (p4_DPL >= 0) 
	    *--SP = d.hi;
    }

    return 1;
}


/**
   the => INTERPRET as called by the outer interpreter
 */
FCode (p4_interpret)
{
    register int i;

    /* HACK: until proper initialization bindings, we do init'
     * the interpret-vectors right in here. This *will* go away.
     */
    if (! PFE.interpret[3])
    
{
	/* PFE.interpret[6] = PFX (p4_interpret_dstrings); */
	/* PFE.interpret[5] = PFX (p4_interpret_locals); */
	PFE.interpret[4] = PFX (p4_interpret_find);
	PFE.interpret[3] = PFX (p4_interpret_number);
	/* PFE.interpret[2] = PFX (p4_interpret_float); */
	/* PFE.interpret[1] = PFX (p4_interpret_smart); */
    }


    PFE.last_here = PFE.dp;
    for (;;)
    
{
    again:
        for (;;)
        
{
	    /* the parsed string is in PFE.word.ptr / PFE.word.len,
	     * and by setting the HERE-string to length null, THROW
	     * will not try to report it but instead it prints PFE.word.
	     */
	    p4_word_parseword (' '); /* PARSE-WORD-NOHERE */
            if (PFE.word.len) 
{ *DP = 0; break; }

            
            switch (SOURCE_ID)
            
{
             default:
                 if (p4_next_line ())
                 
{
                     PFE.last_here = PFE.dp;
                     continue;
                 }

             case 0:
             case -1:
                 return;
            }

        }
  

	i = DIM (PFE.interpret);
	while ( i-- )
	
{
	    if (! PFE.interpret[i]) continue;
	    if (PFE.interpret[i] (FX_VOID)) goto again;
	}

        p4_throw (P4_ON_UNDEFINED);
    }

}


/**
   => INTERPRET buffer
 */
_export void
p4_evaluate (char *p, int n)
{
#  if !defined P4_RP_IN_VM
    Iframe saved;
    p4_link_saved_input (&saved);
#  else
    RP = (p4xcode **) p4_save_input (RP);
#  endif
    SOURCE_ID = -1;
    BLK = 0;
    TIB = p;
    NUMBER_TIB = n;
    TO_IN = 0;
    FX (p4_interpret);
#  if defined P4_RP_IN_VM
    RP = (p4xcode **) p4_restore_input (RP);
#  else
    p4_unlink_saved_input (&saved);
#  endif
}


/**
 */
_export void
p4_include_file (p4_File *fid)
{
    if (fid == NULL || fid->f == NULL)
        p4_throws (P4_ON_FILE_NEX, fid->name, 0);
    else
    
{
#      if !defined P4_RP_IN_VM
	Iframe saved;
	p4_link_saved_input (&saved);
#      else
	RP = (p4xcode **) p4_save_input (RP);
#      endif
	SOURCE_ID = (p4cell) fid;
	BLK = 0;
	TO_IN = 0;
	FX (p4_interpret);
#      if defined P4_RP_IN_VM
	RP = (p4xcode **) p4_restore_input (RP);
#      else
	p4_unlink_saved_input (&saved);
#      endif
    }

}


/**
   called by INCLUDED and INCLUDE
 */
_export int
p4_included1 (const char *name, int len, int throws)
{
    File* f;
    char* fn;
    
    fn = p4_pocket_expanded_filename (name, len, 
				      P4_opt.incpaths, P4_opt.incext);
    f = p4_open_file (fn, strlen (fn), FMODE_RO);
    if (!f)
    
{  
        if (throws) 
        
{
            p4_throws (P4_ON_FILE_NEX, fn, 0); 
        }
else
{ 
            P4_fail2 ("- could not open '%s' (paths='%s')\n", 
              fn, P4_opt.incpaths); 
            return 0; 
        }

    }

#   ifdef _K12_SOURCE
    
{
        register struct k12_priv* k12p = P4_K12_PRIV(p4TH);
        k12p->state = K12_EMU_NOT_LOADED;
        /* before GetEvent, it goes _IDLE in term-k12.c FIXME: generalize!!*/
    }

#   endif

    p4_include_file (f);
    p4_close_file (f);
    return 1;
}


/**
   INCLUDED
 */
_export void
p4_included (const char* name, int len)
{
    p4_included1 (name, len, 1);
}


/*
 */
_export void
p4_unnest_input (p4_Iframe *p)
{
    while (PFE.saved_input && PFE.saved_input != p)
    
{
        switch (SOURCE_ID)
	
{
         case -1:
         case 0:
             break;
         default:
             p4_close_file (SOURCE_FILE);
	}

#     if defined P4_RP_IN_VM
        RP = (p4xcode **) p4_restore_input (PFE.saved_input);
#     else
	p4_unlink_saved_input (PFE.saved_input);
#     endif
    }

}


/**
   walk the filedescriptors and close/free the fds. This function
   is usefully called from => ABORT - otherwise it may rip too
   many files in use.
 */
FCode (p4_closeall_files) 
{
    /*FIXME: look at p4_close_all_files, is it the same?? */
    File* f;

    /* see => p4_free_file_slot for an example */
    for (f = PFE.files; f < PFE.files_top; f++) 
        if (f->f != NULL)
        
{
            if (f->name && f->name[0] == '<')
                continue; /* stdIn, stdOut, stdErr, a.k.a. "<STDIN>" etc. */
            else
                p4_close_file(f);
        }

}


/* ********************************************************************** 
    QUIT, ABORT, INTERPRET
 */

/**
   a little helper that just emits "ok", called in outer interpreter,
   also useful on the command line to copy lines for re-execution
 */
FCode (p4_ok)
{
    if (!STATE)
    
{
        p4_outs ("ok");
        if (PFE.nr) 
{
            p4_outc ('-');
            p4_outc ('0' + PFE.nr % 10); 
        }

        FX (p4_space);
    }

}


/*
   things => QUIT has to initialize 
 */
static void
quit_system (P4_VOID)
{
#  ifdef P4_RP_IN_VM
    CSP = (p4cell*) RP;         /* come_back marker */
    RP = p4_R0;			/* return stack to its bottom */
#  endif
    LP = NULL;			/* including all local variables */
    STATE = P4_FALSE;		/* interpreting now */
    PFE.cAtch = NULL;		/* and no exceptions caught */
    p4_debug_off ();		/* turn off debugger */
}


/*
   things => ABORT has to initialize
 */
static void
abort_system (P4_VOID)
{
    SP = p4_S0;				/* stacks */
    if (PFE.abort[2]) 
{ (PFE.abort[2]) (FX_VOID); }
 /* -> floating */
    if (PFE.abort[3]) 
{ (PFE.abort[3]) (FX_VOID); }
 /* -> dstrings */
    if (p4_RESET_ORDER)  
{ FX (p4_reset_order); }
   /* reset search order */
    FX (p4_decimal);			/* number i/o base */
    FX (p4_standard_io);		/* disable i/o redirection */
    FX (p4_closeall_files);             /* close open filedescriptors */
    if (PFE.dictlimit - PFE_MINIMAL_UNUSED > PFE.dp)
        return;
    else
    
{
        P4_fail2 ("DICT OVER - reset HERE from %+i to %+i",
                  PFE.dp - PFE.dict, PFE.last_here - PFE.dict);

        PFE.dp = PFE.last_here;
    }

}


FCode (p4_paren_abort)
{
    abort_system (FX_VOID);
    quit_system (FX_VOID);
}


/** 
   the outer interpreter, in PFE the jumppoint for both => ABORT and => QUIT
 */
_export int
p4_interpret_loop (P4_VOID)
{
    register int err;
    switch (err = setjmp(PFE.loop))
    
{
     case  0:  /* newloop -> do abort*/
         /* initialize */
     case 'A': /* do abort */
         abort_system (FX_VOID);
         p4_redo_all_words (PFE.abort_wl);
         /* -> do quit */
     case 'Q': /* do quit */
         quit_system (FX_VOID);
     case 'S': /* schedule */
				/* normal interactive QUIT */
                                /* doing the QUERY-INTERPRET loop */
         p4_unnest_input (NULL);
         for (;;)
         
{
             p4_do_all_words (PFE.prompt_wl);
             FX (p4_ok);
             FX (p4_cr);	
             FX (p4_query);		
             FX (p4_interpret);		
             FX (p4_Q_stack);	
         }


     case 'X': /* exit / bye */
         /* -> PFE.atexit_cleanup (); */
         return 0;
    }

    return err;
}


/* ********************************************************************** 
   Initialize dictionary, and system variables, include files		  
 */

/**
   setup all system variables and initialize the dictionary
   to reach a very clean status as if right after cold boot.
 */
static void
cold_system (void)
{
    SP = p4_S0;
#  ifndef P4_NO_FP
    FP = p4_F0;
#  endif
#  ifdef P4_RP_IN_VM
    RP = p4_R0;
#  endif
    TIB = PFE.tib;
    BASE = 10;
    p4_DPL = -1;
    PRECISION = p4_search_option_value("precision",9, 6, PFE.set);
    WORDL_FLAG = 0; /* implicitly enables HASHing */
    if (p4_search_option_value("source-any-case",15, PFE_set.find_any_case,
          PFE.set)) WORDL_FLAG |= WORDL_NOCASE;
    if (p4_search_option_value("source-upper-case",17, PFE_set.upper_case_on,
          PFE.set)) WORDL_FLAG |= WORDL_UPPER_CASE;
    LOWER_CASE_FN = p4_search_option_value("lower-case-filenames",20, 
      PFE_set.lower_case_fn, PFE.set);
    FLOAT_INPUT = P4_opt.float_input;
    PFE.local = (char (*)[32]) PFE.stack;

    memset (PFE.files_top - 3, 0, sizeof (File) * 3);

    PFE.stdIn = PFE.files_top - 3;
    PFE.stdIn->f = stdin;
    strcpy (PFE.stdIn->name, "<STDIN>");
    strcpy (PFE.stdIn->mdstr, "r");
    PFE.stdIn->mode = FMODE_RO;
    
    PFE.stdOut = PFE.files_top - 2;
    PFE.stdOut->f = stdout;
    strcpy (PFE.stdOut->name, "<STDOUT>");
    strcpy (PFE.stdOut->mdstr, "a");
    PFE.stdOut->mode = FMODE_WO;
    
    PFE.stdErr = PFE.files_top - 1;
    PFE.stdErr->f = stderr;
    strcpy (PFE.stdErr->name, "<STDERR>");
    strcpy (PFE.stdErr->mdstr, "a");
    PFE.stdErr->mode = FMODE_WO;
    
    REDEFINED_MSG = P4_FALSE;
    
    /* Wipe the dictionary: */
    memset (PFE.dict, 0, (PFE.dictlimit - PFE.dict));
    p4_preload_only ();
    if (! PFE.abort_wl)  PFE.abort_wl  = p4_new_wordlist (0);
    if (! PFE.prompt_wl) PFE.prompt_wl = p4_new_wordlist (0);
    FX (p4_only_RT);
    
{
        /* Defines the following default search order:
         * FORTH EXTENSIONS ONLY */
#ifndef MODULE0
#define MODULE0 extensions
#endif
        extern const p4Words P4WORDS (forth);
        extern const p4Words P4WORDS (MODULE0); 
        
#ifdef MODULE1
        extern const p4Words P4WORDS (MODULE1);
#endif
#ifdef MODULE2
        extern const p4Words P4WORDS (MODULE2);
#endif
#ifdef MODULE3
        extern const p4Words P4WORDS (MODULE3);
#endif

        p4_load_words (&P4WORDS (forth), ONLY, 0);
        p4_load_words (&P4WORDS (MODULE0), ONLY, 0);
        
#ifdef MODULE1
        p4_load_words (&P4WORDS (MODULE1), ONLY, 0);
#endif
#ifdef MODULE2
        p4_load_words (&P4WORDS (MODULE2), ONLY, 0);
#endif
#ifdef MODULE3
        p4_load_words (&P4WORDS (MODULE3), ONLY, 0);
#endif
	/* should be replaced by p4_load_words someday... fixme: */
        if (PFE.set->loadlist[0]) 
            p4_load_words (PFE.set->loadlist[0], ONLY, 0);
        if (PFE.set->loadlist[1]) 
            p4_load_words (PFE.set->loadlist[1], ONLY, 0);
        if (PFE.set->loadlist[2]) 
            p4_load_words (PFE.set->loadlist[2], ONLY, 0);
        if (PFE.set->loadlist[3]) 
            p4_load_words (PFE.set->loadlist[3], ONLY, 0);
    }

    /* last step of bootup default search-order is 
       FORTH DEFINITIONS a.k.a.  FORTH-WORDLIST CONTEXT ! DEFINITIONS
    */
    CURRENT = CONTEXT[0] = PFE.forth_wl; /* points to FORTH vocabulary */
    FX (p4_default_order);
    
    REDEFINED_MSG = P4_TRUE;
}
    

/**
   setup all system variables and initialize the dictionary
 */
_export void
p4_boot_system (void)
{
    if (PFE.nr) 
{ printf (" CPU%i ", PFE.nr); }


    /* Action of COLD ABORT and QUIT, but don't enter the interactive QUIT */
    RESET_ORDER = P4_TRUE;
    cold_system ();
    abort_system ();
    quit_system ();

    REDEFINED_MSG = P4_FALSE;

    
{ 
	register const char* file;
#       ifndef PFE_BLOCK_FILE /* USER-CONFIG: --block-file=<mapped-file> */
#       define PFE_BLOCK_FILE PFE_DEFAULT_BLKFILE 
#       endif

	if ((file = p4_search_option_string (
	    "block-file", 10, PFE_BLOCK_FILE, PFE.set)))
	
{
	    if (! p4_set_blockfile (p4_open_blockfile(file, strlen (file)))
		&& strcmp (file, PFE_DEFAULT_BLKFILE) != 0)
	    
{
		P4_fatal1 ("Can't find block file %s", file);
		PFE.exitcode = 4;
		p4_longjmp_exit ();
	    }

	}


#       ifndef PFE_BOOT_FILE /* USER-CONFIG: --boot-file=<included-file> */
#       define PFE_BOOT_FILE 0
#       endif
	if ((file = p4_search_option_string (
	    "boot-file", 9, PFE_BOOT_FILE, PFE.set)))
	
{
	    p4_included1 (file, strlen (file), 0);
	}

    }


    /*  read_help_index (PFE_PKGHELPDIR, "index"); */

    /* According to the ANS Forth description, the order after BOOT must
     * include the FORTH-WORDLIST, and the CURRENT definition-wordlist
     * must be the FORTH-WORDLIST. Here we assume that the various LOADs
     * before have kept atleast one occurence of FORTH-WORDLIST in the
     * search-order but we explicitly set the CURRENT definition-wordlist
     * Then we do DEFAULT-ORDER so it can pop up in a RESET-ORDER on ABORT
     * BEWARE: a bootscript can arrange the items in the search-order but
     * it can not arrange to set the CURRENT definitions-wordlist as well.
     * Note that ONLY is always searched, so one can always get back at FORTH
     * OTOH, in main-sub, the first include-file is loaded after boot_system
     * so it can arrange for a different the DEFAULT-ORDER incl. CURRENT.
     */
    CURRENT = PFE.forth_wl;
    FX (p4_default_order);

    FENCE = DP;
    LAST  = NULL;

    REDEFINED_MSG = P4_TRUE;
}


/*@}*/