/* xstring - return a string consisting of a single character */
LVAL xstring(void)
{
LVAL arg;
/* get the argument */
arg = xlgetarg();
xllastarg();
/* make sure its not NIL */
if (null(arg))
xlbadtype(arg);
/* check the argument type */
switch (ntype(arg)) {
case STRING:
return (arg);
case SYMBOL:
return (getpname(arg));
case CHAR:
buf[0] = (int)getchcode(arg);
buf[1] = '\0';
return (cvstring(buf));
case FIXNUM:
buf[0] = getfixnum(arg);
buf[1] = '\0';
return (cvstring(buf));
default:
xlbadtype(arg);
return NIL; /* never happens */
}
}
/* xformat - formatted output function */
LVAL xformat(void)
{
unsigned char *fmt;
LVAL stream,val;
int ch;
/* protect stream in case it is a new ustream */
xlsave1(stream);
/* get the stream and format string */
stream = xlgetarg();
if (stream == NIL)
val = stream = newustream();
else {
if (stream == s_true)
stream = getvalue(s_stdout);
else if (!streamp(stream) && !ustreamp(stream))
xlbadtype(stream);
val = NIL;
}
fmt = getstring(xlgastring());
/* process the format string */
while ((ch = *fmt++))
if (ch == '~') {
switch (*fmt++) {
case '\0':
xlerror("expecting a format directive",cvstring((char *) (fmt-1)));
case 'a': case 'A':
xlprint(stream,xlgetarg(),FALSE);
break;
case 's': case 'S':
xlprint(stream,xlgetarg(),TRUE);
break;
case '%':
xlterpri(stream);
break;
case '~':
xlputc(stream,'~');
break;
case '\n':
case '\r':
/* mac may read \r -- this should be ignored */
if (*fmt == '\r') fmt++;
while (*fmt && *fmt != '\n' && isspace(*fmt))
++fmt;
break;
default:
xlerror("unknown format directive",cvstring((char *) (fmt-1)));
}
}
else
xlputc(stream,ch);
/* return the value */
if (val) val = getstroutput(val);
xlpop();
return val;
}
/* xlgetfname - get a filename */
LVAL xlgetfname(V)
{
LVAL name;
/* get the next argument */
name = xlgetarg();
/* get the filename string */
#ifdef FILETABLE
if (streamp(name) && getfile(name) > CONSOLE)
/* "Steal" name from file stream */
name = cvstring(filetab[getfile(name)].tname);
else
#endif
if (symbolp(name))
name = getpname(name);
else if (!stringp(name))
xlbadtype(name);
if (getslength(name) >= FNAMEMAX)
xlerror("file name too long", name);
/* return the name */
return (name);
}
/* Added by Ning Hu May.2001
xsetdir - set current directory of the process */
LVAL xsetdir() {
TCHAR ssCurDir[MAX_PATH], szCurDir[MAX_PATH];
int verbose = TRUE;
strcpy(ssCurDir, getstring(xlgastring()));
if (moreargs()) {
verbose = (xlgetarg() != NIL);
}
xllastarg();
if (ok_to_open(ssCurDir, "r")) {
if (SetCurrentDirectory(ssCurDir)) {
if (GetCurrentDirectory(
sizeof(szCurDir)/sizeof(TCHAR), szCurDir)) {
return cvstring(szCurDir);
/* create the result string
stdputstr("Current Directory: ");
stdputstr(szCurDir);
stdputstr("\n"); */
}
}
}
if (verbose) stdputstr("Directory Setting Error\n");
/* return nil on error*/
return NIL;
}
/* xfind_in_xlisp_path -- search XLISPPATH for file, return full path */
LVAL xfind_in_xlisp_path()
{
LVAL string = xlgastring();
const char *path = (const char *) getstring(string);
xllastarg();
path = find_in_xlisp_path(path);
return (path ? cvstring(path) : NULL);
}
/* SHLIB-INIT funtab &optional (version -1) (oldest version) */
LVAL xshlibinit()
{
LVAL subr, val, sym;
xlshlib_modinfo_t *info = getnpaddr(xlganatptr());
FUNDEF *p = info->funs;
FIXCONSTDEF *pfix = info->fixconsts;
FLOCONSTDEF *pflo = info->floconsts;
STRCONSTDEF *pstr = info->strconsts;
struct version_info defversion;
defversion.current = moreargs()?getfixnum(xlgafixnum()):-1;
defversion.oldest = moreargs()?getfixnum(xlgafixnum()):defversion.current;
xllastarg();
if (! check_version(&defsysversion, &(info->sysversion)))
xlfail("shared library not compatible with current system");
if (defversion.current >= 0 &&
! check_version(&defversion, &(info->modversion)))
xlfail("module not compatible with requested version");
xlsave1(val);
val = NIL;
if (p != NULL)
for (val = NIL; (p->fd_subr) != (LVAL(*)(void)) NULL; p++) {
subr = cvsubr(p->fd_subr, p->fd_type & TYPEFIELD, 0);
setmulvalp(subr, (p->fd_type & (TYPEFIELD + 1)) ? TRUE : FALSE);
val = cons(subr, val);
if (p->fd_name != NULL) {
sym = xlenter(p->fd_name);
setfunction(sym, subr);
}
}
if (pfix != NULL)
for (; pfix->name != NULL; pfix++) {
sym = xlenter(pfix->name);
defconstant(sym, cvfixnum(pfix->val));
}
if (pflo != NULL)
for (; pflo->name != NULL; pflo++) {
sym = xlenter(pflo->name);
defconstant(sym, cvflonum(pflo->val));
}
if (pstr != NULL)
for (; pstr->name != NULL; pstr++) {
sym = xlenter(pstr->name);
defconstant(sym, cvstring(pstr->val));
}
if (info->sysversion.current >= MAKEVERSION(0,1)) {
ULONGCONSTDEF *pulong = info->ulongconsts;
if (pulong != NULL)
for (; pulong->name != NULL; pulong++) {
sym = xlenter(pulong->name);
defconstant(sym, ulong2lisp(pulong->val));
}
}
xlpop();
return xlnreverse(val);
}
/* cvsymbol - convert a string to a symbol */
NODE *cvsymbol( char *pname)
{
NODE ***oldstk,*val __HEAPIFY;
oldstk = xlsave1(&val);
val = newnode(SYM);
val->n_symplist = newnode(LIST);
rplaca(val->n_symplist,cvstring(pname));
xlstack = oldstk;
return (val);
}
/* SHLIB-INFO funtab */
LVAL xshlibinfo()
{
LVAL val;
xlshlib_modinfo_t *info = getnpaddr(xlganatptr());
FUNDEF *p = info->funs;
FIXCONSTDEF *pfix = info->fixconsts;
FLOCONSTDEF *pflo = info->floconsts;
STRCONSTDEF *pstr = info->strconsts;
xllastarg();
if (! check_version(&defsysversion, &(info->sysversion)))
xlfail("shared library not compatible with current system");
xlsave1(val);
val = cons(cvfixnum((FIXTYPE) info->modversion.current), NIL);
val = cons(cvfixnum((FIXTYPE) info->modversion.oldest), val);
val = cons(NIL, val);
if (p != NULL) {
for (; (p->fd_subr) != (LVAL(*)(void)) NULL; p++)
rplaca(val, cons(cvstring(p->fd_name), car(val)));
rplaca(val, xlnreverse(car(val)));
}
val = cons(NIL, val);
if (pfix != NULL)
for (; pfix->name != NULL; pfix++)
rplaca(val, cons(cvstring(pfix->name), car(val)));
if (pflo != NULL)
for (; pflo->name != NULL; pflo++)
rplaca(val, cons(cvstring(pflo->name), car(val)));
if (pstr != NULL)
for (; pstr->name != NULL; pstr++)
rplaca(val, cons(cvstring(pstr->name), car(val)));
if (info->sysversion.current >= MAKEVERSION(0,1)) {
ULONGCONSTDEF *pulong = info->ulongconsts;
for (; pulong->name != NULL; pulong++)
rplaca(val, cons(cvstring(pulong->name), car(val)));
}
rplaca(val, xlnreverse(car(val)));
xlpop();
return xlnreverse(val);
}
/* xget_env - get the value of an environment variable */
LVAL xget_env(void)
{
const char *name = (char *) getstring(xlgetfname());
char *val;
/* check for too many arguments */
xllastarg();
/* get the value of the environment variable */
val = getenv(name);
return (val ? cvstring(val) : NULL);
}
static LVAL base_variable_label(V)
{
int var, set = FALSE;
char *label = NULL;
LVAL result;
var = getfixnum(xlgafixnum());
if (moreargs()) {
set = TRUE;
label = (char *) getstring(xlgastring());
}
xllastarg();
if (set) IViewSetVariableLabel(wind, var, label);
label = IViewVariableLabel(wind, var);
if (label == NULL) result = cvstring("");
else result = cvstring(label);
return(result);
}
/* cvsymbol - convert a string to a symbol */
LVAL cvsymbol(char *pname)
{
LVAL val;
xlsave1(val);
val = newvector(SYMSIZE);
val->n_type = SYMBOL;
setvalue(val,s_unbound);
setfunction(val,s_unbound);
setpname(val,cvstring(pname));
xlpop();
return (val);
}
/* initwks - build an initial workspace */
LOCAL void initwks(void)
{
FUNDEF *p;
int i;
xlsinit(); /* initialize xlsym.c */
xlsymbols();/* enter all symbols used by the interpreter */
xlrinit(); /* initialize xlread.c */
xloinit(); /* initialize xlobj.c */
/* setup defaults */
setvalue(s_evalhook,NIL); /* no evalhook function */
setvalue(s_applyhook,NIL); /* no applyhook function */
setvalue(s_tracelist,NIL); /* no functions being traced */
setvalue(s_tracenable,NIL); /* traceback disabled */
setvalue(s_tlimit,NIL); /* trace limit infinite */
setvalue(s_breakenable,NIL); /* don't enter break loop on errors */
setvalue(s_loadingfiles,NIL); /* not loading any files initially */
setvalue(s_profile,NIL); /* don't do profiling */
setvalue(s_gcflag,NIL); /* don't show gc information */
setvalue(s_gchook,NIL); /* no gc hook active */
setvalue(s_ifmt,cvstring(IFMT)); /* integer print format */
setvalue(s_ffmt,cvstring("%g")); /* float print format */
setvalue(s_printcase,k_upcase); /* upper case output of symbols */
/* install the built-in functions and special forms */
for (i = 0, p = funtab; p->fd_subr != NULL; ++i, ++p)
if (p->fd_name)
xlsubr(p->fd_name,p->fd_type,p->fd_subr,i);
/* add some synonyms */
setfunction(xlenter("NOT"),getfunction(xlenter("NULL")));
setfunction(xlenter("FIRST"),getfunction(xlenter("CAR")));
setfunction(xlenter("SECOND"),getfunction(xlenter("CADR")));
setfunction(xlenter("THIRD"),getfunction(xlenter("CADDR")));
setfunction(xlenter("FOURTH"),getfunction(xlenter("CADDDR")));
setfunction(xlenter("REST"),getfunction(xlenter("CDR")));
}
/* xget_user -- get a string identifying the user, for use in file names */
LVAL xget_user()
{
char *user = getenv("USER");
if (!user || !*user) {
user = getenv("USERNAME");
if (!user || !*user) {
errputstr("Warning: could not get user ID, using 'nyquist'\n");
user = "******";
}
}
return cvstring(user);
}
/* xget_temp_path -- get a path to create temp files */
LVAL xget_temp_path()
{
char *p;
char szDir[MAX_PATH];
int rslt = GetTempPath(MAX_PATH, szDir);
if (!(rslt > MAX_PATH || rslt <= 0)) {
/* Vista apparently treats c:\windows with
* special semantics, so just don't allow
* GetTempPath to put us in c:\windows...
*/
if (!is_windows_dir(szDir)) {
return cvstring(szDir);
}
}
// if not defined or "c:\\windows", which is bad
p = getenv("TEMP");
if (p && strlen(p) < MAX_PATH) strcpy(szDir, p);
else *szDir = 0;
if (!is_windows_dir(szDir)) {
return cvstring(szDir);
}
return cvstring("");
}
/* xsetdir -- set current directory of the process */
LVAL xsetdir()
{
char *dir = (char *)getstring(xlgastring());
int result;
LVAL cwd = NULL;
xllastarg();
result = chdir(dir);
if (result) {
perror("SETDIR");
}
dir = getcwd(NULL, 1000);
if (dir) {
cwd = cvstring(dir);
free(dir);
}
return cwd;
}
LVAL xlistdir(void)
{
const char *path;
LVAL result = NULL;
LVAL *tail;
/* get the path, converting unsigned char * to char * */
path = (char *)getstring(xlgetfname());
/* try to start listing */
if (osdir_list_start(path)) {
const char *filename;
xlsave1(result);
tail = &result;
while ((filename = osdir_list_next())) {
*tail = cons(NIL, NIL);
rplaca(*tail, cvstring(filename));
tail = &cdr(*tail);
}
osdir_list_finish();
xlpop();
}
return result;
}
/* xget_temp_path -- get a path to create temp files */
LVAL xget_temp_path()
{
char *tmp;
#if defined(WINDOWS)
tmp = getenv("TEMP");
#else
tmp = getenv("TMPDIR");
#endif
if (!tmp || !*tmp) {
tmp = getenv("TMP");
if (!tmp || !*tmp) {
#if defined(WINDOWS)
tmp = "/";
#else
tmp = "/tmp/";
#endif
}
}
return cvstring(tmp);
}
/******************************************************************************
* (FSCANF-STRING <stream> <scanf-format>)
* This routine calls fscanf(3s) on a <stream> that was previously openend
* via open or popen. It will not work on an USTREAM.
* <scanf-format> is a format string containing a single conversion
* directive that will result in a string valued conversion.
* %s, %c, and %[...] style conversions are acceptable for
* this routine.
* WARNING: specifying a <scanf-format> that will result in the conversion
* of a result larger than 1024 characters will result in corrupted
* memory and core dumps.
*
* This routine will return a string if fscanf() returns 1 (i.e. if
* the one expected conversion has succeeded. It will return NIL if the
* conversion wasn't successful, or if EOF was reached.
******************************************************************************/
LVAL Prim_FSCANF_STRING()
{
LVAL lval_stream;
char* fmt;
char result[BUFSIZ];
lval_stream = xlgastream();
if (getfile(lval_stream) == NULL)
xlerror("File not opened.", lval_stream);
fmt = (char *) getstring(xlgastring());
xllastarg();
result[0] = result[1] = '\0'; /* if the conversion is %c, then fscanf
doesn't null terminate the string,
so do it just incase */
/* if scanf returns result <1 then an error or eof occured. */
if (fscanf(getfile(lval_stream), fmt, result) < 1)
return (NIL);
else
return (cvstring(result));
}
VOID StGWGetAllocInfo P7C(LVAL, object, char **, title,
int *, left, int *, top, int *, width, int *, height, int *, goAway)
{
LVAL window_title;
if (slot_value(object, s_hardware_address) != NIL)
send_message(object, sk_dispose);
window_title = slot_value(object, s_title);
if (!stringp(window_title)) {
window_title = cvstring(IVIEW_WINDOW_TITLE);
set_slot_value(object, s_title, window_title);
}
*title = (char *) getstring(window_title);
*left = IVIEW_WINDOW_LEFT;
*top = IVIEW_WINDOW_TOP;
*width = IVIEW_WINDOW_WIDTH;
*height = IVIEW_WINDOW_HEIGHT;
get_window_bounds(object, left, top, width, height);
*goAway = slot_value(object, s_go_away) != NIL;
}
// Copy a node (recursively if appropriate)
LOCAL LVAL nyx_dup_value(LVAL val)
{
LVAL nval = val;
// Protect old and new values
xlprot1(val);
xlprot1(nval);
// Copy the node
if (val != NIL) {
switch (ntype(val))
{
case FIXNUM:
nval = cvfixnum(getfixnum(val));
break;
case FLONUM:
nval = cvflonum(getflonum(val));
break;
case CHAR:
nval = cvchar(getchcode(val));
break;
case STRING:
nval = cvstring((char *) getstring(val));
break;
case VECTOR:
{
int len = getsize(val);
int i;
nval = newvector(len);
nval->n_type = ntype(val);
for (i = 0; i < len; i++) {
if (getelement(val, i) == val) {
setelement(nval, i, val);
}
else {
setelement(nval, i, nyx_dup_value(getelement(val, i)));
}
}
}
break;
case CONS:
nval = nyx_dup_value(cdr(val));
nval = cons(nyx_dup_value(car(val)), nval);
break;
case SUBR:
case FSUBR:
nval = cvsubr(getsubr(val), ntype(val), getoffset(val));
break;
// Symbols should never be copied since their addresses are cached
// all over the place.
case SYMBOL:
nval = val;
break;
// Streams are not copied (although USTREAM could be) and reference
// the original value.
case USTREAM:
case STREAM:
nval = val;
break;
// Externals aren't copied because I'm not entirely certain they can be.
case EXTERN:
nval = val;
break;
// For all other types, just allow them to reference the original
// value. Probably not the right thing to do, but easier.
case OBJECT:
case CLOSURE:
default:
nval = val;
break;
}
}
xlpop();
xlpop();
return nval;
}
LVAL cvstrornil P1C(char *, s)
{
return s == NULL ? NIL : cvstring(s);
}
/* xlload - load a file of xlisp expressions */
int xlload(char *fname, int vflag, int pflag)
{
char fullname[STRMAX+1];
char *ptr;
LVAL fptr,expr;
XLCONTEXT cntxt;
FILE *fp;
int sts;
/* protect some pointers */
xlstkcheck(2);
xlsave(fptr);
xlsave(expr);
/* space for copy + extension? */
if (strlen(fname) > STRMAX - 4) goto toolong;
strcpy(fullname,fname);
#ifdef WINDOWS
#ifdef WINGUI
if (strcmp(fullname, "*") == 0) {
if (sfn_valid) {
strcpy(fullname, save_file_name);
} else {
strcpy(fullname, "*.*");
}
}
if (strcmp(fullname, "*.*") == 0) {
char *name = getfilename(NULL, "lsp", "r", "Load file");
if (name) {
strcpy(fullname, name);
strcpy(save_file_name, name);
sfn_valid = TRUE;
} else {
xlpopn(2);
return FALSE;
}
}
#endif
/* replace "/" with "\" so that (current-path) will work */
for (ptr = fullname; *ptr; ptr++) {
if (*ptr == '/') *ptr = '\\';
}
#endif
/* default the extension if there is room */
if (needsextension(fullname)) {
strcat(fullname,".lsp");
}
/* allocate a file node */
fptr = cvfile(NULL);
/* open the file */
if ((fp = osaopen(fullname,"r")) == NULL) {
#ifdef UNIX
if (fname[0] != '/') {
char *paths = getenv("XLISPPATH");
if (!paths || !*paths) {
char msg[512];
sprintf(msg, "\n%s\n%s\n%s\n%s\n%s\n",
"Warning: XLISP failed to find XLISPPATH in the environment.",
"If you are using Nyquist, probably you should cd to the",
"nyquist directory and type:",
" setenv XLISPPATH `pwd`/runtime:`pwd`/lib",
"or set XLISPPATH in your .login or .cshrc file.");
errputstr(msg);
}
/* make sure we got paths, and the list is not empty */
while (paths && *paths) {
char *ptr = fullname;
/* skip over separator */
while (*paths == ':') paths++;
/* scan next directory into fullname */
while (*paths && (*paths != ':')) {
if ((ptr - fullname) >= STRMAX) goto toolong;
*ptr++ = *paths++;
}
/* add "/" if needed */
if (ptr[-1] != '/') *ptr++ = '/';
/* append the file name */
if ((ptr - fullname) + strlen(fname) + 4 > STRMAX)
goto toolong;
strcpy(ptr, fname);
/* append the .lsp extension */
if (needsextension(fullname)) {
strcat(fullname, ".lsp");
}
if (fp = osaopen(fullname, "r")) goto gotfile;
}
}
#endif
#ifdef WINDOWS
/* is this a relative path? */
if (fname[0] != '\\' && (strlen(fname) < 2 || fname[1] != ':')) {
#define paths_max 1024
char paths[paths_max];
char *p = paths;
get_xlisp_path(paths, paths_max);
/* make sure we got paths, and the list is not empty */
if (!*p) {
sprintf(paths, "\n%s\n%s\n%s\n",
"Warning: XLISP failed to find XLISPPATH in the Registry.",
"You should follow the installation instructions. Enter an",
"empty string if you really want no search path.");
errputstr(paths);
*p = 0;
}
while (*p) {
char *ptr = fullname;
/* skiip over separator */
while (*p == ',') p++;
/* scan next directory into fullname */
while (*p && (*p != ',')) {
if ((ptr - fullname) >= STRMAX) goto toolong;
*ptr++ = *p++;
}
/* add "\" if needed */
if (ptr[-1] != '\\') *ptr++ = '\\';
/* append the file name */
if ((ptr - fullname) + strlen(fname) + 4 > STRMAX)
goto toolong;
strcpy(ptr, fname);
/* append the .lsp extension */
if (needsextension(fullname)) {
strcat(fullname, ".lsp");
}
/* printf("Trying to open \"%s\"\n", fullname); */
if (fp = osaopen(fullname, "r")) goto gotfile;
}
}
#endif
#ifdef MACINTOSH
/* is this a relative path? I don't know how to do this
* correctly, so we'll assume it's relative if there is no
* embedded colon (:)
*/
if (strchr(fname, ':') == NULL) {
#define paths_max 1024
char paths[paths_max];
char *p = paths;
int prefs_found = false;
get_xlisp_path(paths, paths_max, &prefs_found);
/* make sure we got paths, and the list is not empty */
if (!*p) {
if (prefs_found) {
sprintf(paths, "\n%s\n%s\n%s\n",
"Warning: XLISP failed to find XLISPPATH in XLisp Preferences.",
"You should probably delete XLisp Preferences and let XLisp",
"create a new one for you.");
} else {
sprintf(paths, "\n%s\n%s\n%s\n%s\n%s\n",
"Warning: XLISP failed to find XLisp Preferences.",
"You should manually locate and load the file runtime:init.lsp",
"Nyquist will create an XLisp Preferences file to automatically",
"find the file next time. You may edit XLisp Preferences to add",
"additional search paths, using a comma as separator.");
}
errputstr(paths);
*p = 0;
}
while (*p) {
char *ptr = fullname;
/* skiip over separator */
while (*p == ',') p++;
/* scan next directory into fullname */
while (*p && (*p != ',')) {
if ((ptr - fullname) >= STRMAX) goto toolong;
*ptr++ = *p++;
}
/* add ":" if needed */
if (ptr[-1] != ':') *ptr++ = ':';
/* append the file name */
if ((ptr - fullname) + strlen(fname) + 4 > STRMAX)
goto toolong;
strcpy(ptr, fname);
/* append the .lsp extension */
if (needsextension(fullname)) {
strcat(fullname, ".lsp");
}
/* printf("Trying to open \"%s\"\n", fullname); */
if (fp = osaopen(fullname, "r")) goto gotfile;
}
}
#endif
xlpopn(2);
return (FALSE);
}
gotfile:
#ifdef MACINTOSH
/* We found the file ok, call setup_preferences to create
* XLisp Preferences file (this only happens if previous
* attempt to find the file failed
*/
setup_preferences(fullname);
#endif
setfile(fptr,fp);
setvalue(s_loadingfiles, cons(fptr, getvalue(s_loadingfiles)));
setvalue(s_loadingfiles, cons(cvstring(fullname), getvalue(s_loadingfiles)));
/* print the information line */
if (vflag)
{ sprintf(buf,"; loading \"%s\"\n",fullname); stdputstr(buf); }
/* read, evaluate and possibly print each expression in the file */
xlbegin(&cntxt,CF_ERROR,s_true);
if (setjmp(cntxt.c_jmpbuf))
sts = FALSE;
else {
while (xlread(fptr,&expr,FALSE)) {
expr = xleval(expr);
if (pflag)
stdprint(expr);
}
sts = TRUE;
}
xlend(&cntxt);
/* close the file */
osclose(getfile(fptr));
setfile(fptr,NULL);
if (consp(getvalue(s_loadingfiles)) &&
consp(cdr(getvalue(s_loadingfiles))) &&
car(cdr(getvalue(s_loadingfiles))) == fptr) {
setvalue(s_loadingfiles, cdr(cdr(getvalue(s_loadingfiles))));
}
/* restore the stack */
xlpopn(2);
/* return status */
return (sts);
toolong:
xlcerror("ignore file", "file name too long", NIL);
xlpopn(2);
return FALSE;
}
/* rmhash - read macro for '#' */
LVAL rmhash(void)
{
LVAL fptr,mch,val;
int escflag,ch;
/* protect some pointers */
xlsave1(val);
/* get the file and macro character */
fptr = xlgetfile();
mch = xlgachar();
xllastarg();
/* make the return value */
val = consa(NIL);
/* check the next character */
switch (ch = xlgetc(fptr)) {
case '\'':
rplaca(val,pquote(fptr,s_function));
break;
case '(':
rplaca(val,pvector(fptr));
break;
case 'b':
case 'B':
rplaca(val,pnumber(fptr,2));
break;
case 'o':
case 'O':
rplaca(val,pnumber(fptr,8));
break;
case 'x':
case 'X':
rplaca(val,pnumber(fptr,16));
break;
case '\\':
xlungetc(fptr,ch);
pname(fptr,&escflag);
ch = buf[0];
if (strlen(buf) > 1) {
upcase((char *) buf);
if (strcmp(buf,"NEWLINE") == 0)
ch = '\n';
else if (strcmp(buf,"SPACE") == 0)
ch = ' ';
else if (strcmp(buf,"TAB") == 0)
ch = '\t';
else
xlerror("unknown character name",cvstring(buf));
}
rplaca(val,cvchar(ch));
break;
case ':':
rplaca(val,punintern(fptr));
break;
case '|':
pcomment(fptr);
val = NIL;
break;
default:
xlerror("illegal character after #",cvfixnum((FIXTYPE)ch));
}
/* restore the stack */
xlpop();
/* return the value */
return (val);
}
LVAL xget_user()
{
// not implemented for Windows, just use "nyquist"
return cvstring("nyquist");
}
