/* xlsys.c - xlisp builtin system functions */
/*        Copyright (c) 1985, by David Michael Betz
          All Rights Reserved
          Permission is granted for unrestricted non-commercial use   */

#include "flp1_xlisp_h"

/* external variables */
extern NODE *xlenv;
extern int anodes;
extern FILE *tfp;

/* external symbols */
extern NODE *a_subr,*a_fsubr;
extern NODE *a_list,*a_sym,*a_int,*a_float,*a_str,*a_obj,*a_fptr,*a_vect;
extern NODE *true;

/* external routines */
extern FILE *fopen();

/* xload - direct input from a file */
NODE *xload(args)
  NODE *args;
{
    int vflag,pflag;
    NODE *fname;
    char *name;

    /* get the file name, verbose flag and print flag */
    fname = xlarg(&args);
    vflag = (args ? xlarg(&args) != NIL : TRUE);
    pflag = (args ? xlarg(&args) != NIL : FALSE);
    xllastarg(args);

    /* get the filename string */
    if (symbolp(fname))
          name = getstring(getpname(fname));
    else if (stringp(fname))
          name = getstring(fname);
    else
          xlerror("bad argument type",fname);

    /* load the file */
    return (xlload(name,vflag,pflag) ? true : NIL);
}

/* xtranscript - open or close a transcript file */
NODE *xtranscript(args)
  NODE *args;
{
    char *name;

    /* get the transcript file name */
    name = (args ? getstring(xlmatch(STR,&args)) : NULL);
    xllastarg(args);

    /* close the current transcript */
    if (tfp) fclose(tfp);

    /* open the new transcript */
    tfp = (name ? fopen(name,"w") : NULL);

    /* return T if a transcript is open, NIL otherwise */
    return (tfp ? true : NIL);
}

/* xgc - xlisp function to force garbage collection */
NODE *xgc(args)
  NODE *args;
{
    /* make sure there aren't any arguments */
    xllastarg(args);

    /* garbage collect */
    gc();

    /* return nil */
    return (NIL);
}

/* xexpand - xlisp function to force memory expansion */
NODE *xexpand(args)
  NODE *args;
{
    int n,i;

    /* get the new number to allocate */
    n = (args ? getfixnum(xlmatch(INT,&args)) : 1);
    xllastarg(args);

    /* allocate more segments */
    for (i = 0; i < n; i++)
          if (!addseg())
              break;

    /* return the number of segments added */
    return (cvfixnum((FIXNUM)i));
}

/* xalloc - xlisp function to set the number of nodes to allocate */
NODE *xalloc(args)
  NODE *args;
{
    int n,oldn;

    /* get the new number to allocate */
    n = getfixnum(xlmatch(INT,&args));

    /* make sure there aren't any more arguments */
    xllastarg(args);

    /* set the new number of nodes to allocate */
    oldn = anodes;
    anodes = n;

    /* return the old number */
    return (cvfixnum((FIXNUM)oldn));
}

/* xmem - xlisp function to print memory statistics */
NODE *xmem(args)
  NODE *args;
{
    /* make sure there aren't any arguments */
    xllastarg(args);

    /* print the statistics */
    stats();

    /* return nil */
    return (NIL);
}

/* xtype - return type of a thing */
NODE *xtype(args)
    NODE *args;
{
    NODE *arg;

    if (!(arg = xlarg(&args)))
          return (NIL);

    switch (ntype(arg)) {
          case SUBR:          return (a_subr);
          case FSUBR:         return (a_fsubr);
          case LIST:          return (a_list);
          case SYM: return (a_sym);
          case INT: return (a_int);
          case FLOAT:         return (a_float);
          case STR: return (a_str);
          case OBJ: return (a_obj);
          case FPTR:          return (a_fptr);
          case VECT:          return (a_vect);
          default:  xlfail("bad node type");
    }
}

/* xbaktrace - print the trace back stack */
NODE *xbaktrace(args)
  NODE *args;
{
    int n;

    n = (args ? getfixnum(xlmatch(INT,&args)) : -1);
    xllastarg(args);
    xlbaktrace(n);
    return (NIL);
}

/* xexit - get out of xlisp */
NODE *xexit(args)
  NODE *args;
{
    xllastarg(args);
    wrapup();
}

/* xpeek - peek at a location in memory */
NODE *xpeek(args)
  NODE *args;
{
    int *adr;

    /* get the address */
    adr = (int *)getfixnum(xlmatch(INT,&args));
    xllastarg(args);

    /* return the value at that address */
    return (cvfixnum((FIXNUM)*adr));
}

/* xpoke - poke a value into memory */
NODE *xpoke(args)
  NODE *args;
{
    int *adr;
    NODE *val;

    /* get the address and the new value */
    adr = (int *)getfixnum(xlmatch(INT,&args));
    val = xlmatch(INT,&args);
    xllastarg(args);

    /* store the new value */
    *adr = (int)getfixnum(val);

    /* return the new value */
    return (val);
}

/* xaddrs - get the address of an XLISP node */
NODE *xaddrs(args)
  NODE *args;
{
    NODE *val;

    /* get the node */
    val = xlarg(&args);
    xllastarg(args);

    /* return the address of the node */
    return (cvfixnum((FIXNUM)val));
}