mirror of
https://github.com/cookiengineer/audacity
synced 2025-10-10 08:33:36 +02:00
Move library tree where it belongs
This commit is contained in:
ra
254
lib-src/libnyquist/nyquist/xlisp/xlsys.c
Normal file
254
lib-src/libnyquist/nyquist/xlisp/xlsys.c
Normal file
@@ -0,0 +1,254 @@
|
||||
/* xlsys.c - xlisp builtin system functions */
|
||||
/* Copyright (c) 1985, by David Michael Betz
|
||||
All Rights Reserved
|
||||
Permission is granted for unrestricted non-commercial use */
|
||||
|
||||
/* HISTORY
|
||||
*
|
||||
* 28-Apr-03 Dominic Mazzoni
|
||||
* Eliminated some compiler warnings
|
||||
*
|
||||
* 25-Oct-87 Roger Dannenberg at NeXT
|
||||
* profiling code added: enable with (PROFILE t), disable with
|
||||
* (PROFILE nil). While enabled, the profile code counts evals
|
||||
* within functions and macros. The count is only for evals
|
||||
* directly within the form; i.e. only the count of the most
|
||||
* top-most function or macro form on the stack is incremented.
|
||||
* Also, counts are only maintained for named functions and macros
|
||||
* because the count itself is on the property list of the function
|
||||
* or macro name under the *PROFILE* property. If a function or
|
||||
* macro is entered and the *PROFILE* does not exist, the property
|
||||
* is created with initial value 0, and the name is inserted at the
|
||||
* head of the list stored as the value of *PROFILE*. Thus, *PROFILE*
|
||||
* will list the functions that were touched, and the *PROFILE* property
|
||||
* of each function gives some idea of how much time it consumed.
|
||||
* See the file profile.lsp for helpful profiling functions.
|
||||
*/
|
||||
|
||||
#include "xlisp.h"
|
||||
|
||||
/* profile variables */
|
||||
static FIXTYPE invisible_counter;
|
||||
FIXTYPE *profile_count_ptr = &invisible_counter;
|
||||
FIXTYPE profile_flag = FALSE;
|
||||
|
||||
|
||||
/* external variables */
|
||||
extern jmp_buf top_level;
|
||||
extern FILE *tfp;
|
||||
extern int xl_main_loop;
|
||||
|
||||
/* external symbols */
|
||||
extern LVAL a_subr,a_fsubr,a_cons,a_symbol;
|
||||
extern LVAL a_fixnum,a_flonum,a_string,a_object,a_stream;
|
||||
extern LVAL a_vector,a_closure,a_char,a_ustream;
|
||||
extern LVAL k_verbose,k_print;
|
||||
extern LVAL s_true;
|
||||
|
||||
/* external routines */
|
||||
extern FILE *osaopen();
|
||||
extern LVAL exttype();
|
||||
|
||||
/* xload - read and evaluate expressions from a file */
|
||||
LVAL xload(void)
|
||||
{
|
||||
unsigned char *name;
|
||||
int vflag,pflag;
|
||||
LVAL arg;
|
||||
|
||||
/* get the file name */
|
||||
name = getstring(xlgetfname());
|
||||
|
||||
/* get the :verbose flag */
|
||||
if (xlgetkeyarg(k_verbose,&arg))
|
||||
vflag = (arg != NIL);
|
||||
else
|
||||
vflag = TRUE;
|
||||
|
||||
/* get the :print flag */
|
||||
if (xlgetkeyarg(k_print,&arg))
|
||||
pflag = (arg != NIL);
|
||||
else
|
||||
pflag = FALSE;
|
||||
|
||||
/* load the file */
|
||||
return (xlload((char *) name, vflag, pflag) ? s_true : NIL);
|
||||
}
|
||||
|
||||
/* xtranscript - open or close a transcript file */
|
||||
LVAL xtranscript(void)
|
||||
{
|
||||
unsigned char *name;
|
||||
|
||||
/* get the transcript file name */
|
||||
name = (moreargs() ? getstring(xlgetfname()) : NULL);
|
||||
xllastarg();
|
||||
|
||||
/* close the current transcript */
|
||||
if (tfp) osclose(tfp);
|
||||
|
||||
/* open the new transcript */
|
||||
tfp = (name ? osaopen((char *) name,"w") : NULL);
|
||||
|
||||
/* return T if a transcript is open, NIL otherwise */
|
||||
return (tfp ? s_true : NIL);
|
||||
}
|
||||
|
||||
/* xtype - return type of a thing */
|
||||
LVAL xtype(void)
|
||||
{
|
||||
LVAL arg;
|
||||
|
||||
if (!(arg = xlgetarg()))
|
||||
return (NIL);
|
||||
|
||||
switch (ntype(arg)) {
|
||||
case SUBR: return (a_subr);
|
||||
case FSUBR: return (a_fsubr);
|
||||
case CONS: return (a_cons);
|
||||
case SYMBOL: return (a_symbol);
|
||||
case FIXNUM: return (a_fixnum);
|
||||
case FLONUM: return (a_flonum);
|
||||
case STRING: return (a_string);
|
||||
case OBJECT: return (a_object);
|
||||
case STREAM: return (a_stream);
|
||||
case VECTOR: return (a_vector);
|
||||
case CLOSURE: return (a_closure);
|
||||
case CHAR: return (a_char);
|
||||
case USTREAM: return (a_ustream);
|
||||
case EXTERN: return (exttype(arg));
|
||||
default: xlfail("bad node type");
|
||||
return NIL; /* never happens */
|
||||
}
|
||||
}
|
||||
|
||||
/* xbaktrace - print the trace back stack */
|
||||
LVAL xbaktrace(void)
|
||||
{
|
||||
LVAL num;
|
||||
int n;
|
||||
|
||||
if (moreargs()) {
|
||||
num = xlgafixnum();
|
||||
n = getfixnum(num);
|
||||
}
|
||||
else
|
||||
n = -1;
|
||||
xllastarg();
|
||||
xlbaktrace(n);
|
||||
return (NIL);
|
||||
}
|
||||
|
||||
/* xquit - get out of read/eval/print loop */
|
||||
LVAL xquit()
|
||||
{
|
||||
xllastarg();
|
||||
xl_main_loop = FALSE;
|
||||
return NIL;
|
||||
}
|
||||
|
||||
|
||||
/* xexit does not return anything, so turn off "no return value" warning" */
|
||||
/* #pragma warning(disable: 4035) */
|
||||
|
||||
/* xexit - get out of xlisp */
|
||||
LVAL xexit(void)
|
||||
{
|
||||
xllastarg();
|
||||
xlisp_wrapup();
|
||||
return NIL; /* never happens */
|
||||
}
|
||||
|
||||
#ifdef PEEK_AND_POKE
|
||||
/* xpeek - peek at a location in memory */
|
||||
LVAL xpeek(void)
|
||||
{
|
||||
LVAL num;
|
||||
int *adr;
|
||||
|
||||
/* get the address */
|
||||
num = xlgafixnum(); adr = (int *)getfixnum(num);
|
||||
xllastarg();
|
||||
|
||||
/* return the value at that address */
|
||||
return (cvfixnum((FIXTYPE)*adr));
|
||||
}
|
||||
|
||||
/* xpoke - poke a value into memory */
|
||||
LVAL xpoke(void)
|
||||
{
|
||||
LVAL val;
|
||||
int *adr;
|
||||
|
||||
/* get the address and the new value */
|
||||
val = xlgafixnum(); adr = (int *)getfixnum(val);
|
||||
val = xlgafixnum();
|
||||
xllastarg();
|
||||
|
||||
/* store the new value */
|
||||
*adr = (int)getfixnum(val);
|
||||
|
||||
/* return the new value */
|
||||
return (val);
|
||||
}
|
||||
|
||||
/* xaddrs - get the address of an XLISP node */
|
||||
LVAL xaddrs(void)
|
||||
{
|
||||
LVAL val;
|
||||
|
||||
/* get the node */
|
||||
val = xlgetarg();
|
||||
xllastarg();
|
||||
|
||||
/* return the address of the node */
|
||||
return (cvfixnum((FIXTYPE)val));
|
||||
}
|
||||
#endif PEEK_AND_POKE
|
||||
|
||||
/* xprofile - turn profiling on and off */
|
||||
LVAL xprofile()
|
||||
{
|
||||
LVAL flag, result;
|
||||
|
||||
/* get the argument */
|
||||
flag = xlgetarg();
|
||||
xllastarg();
|
||||
|
||||
result = (profile_flag ? s_true : NIL);
|
||||
profile_flag = !null(flag);
|
||||
/* turn off profiling right away: */
|
||||
if (!profile_flag) profile_count_ptr = &invisible_counter;
|
||||
return result;
|
||||
}
|
||||
|
||||
|
||||
#ifdef DEBUG_INPUT
|
||||
FILE *debug_input_fp = NULL;
|
||||
|
||||
FILE *to_input_buffer = NULL;
|
||||
FILE *read_by_xlisp = NULL;
|
||||
|
||||
LVAL xstartrecordio()
|
||||
{
|
||||
to_input_buffer = fopen("to-input-buffer.txt", "w");
|
||||
read_by_xlisp = fopen("read-by-xlisp.txt", "w");
|
||||
if (!to_input_buffer || !read_by_xlisp) {
|
||||
return NIL;
|
||||
}
|
||||
return s_true;
|
||||
}
|
||||
|
||||
|
||||
LVAL xstoprecordio()
|
||||
{
|
||||
if (to_input_buffer) fclose(to_input_buffer);
|
||||
if (read_by_xlisp) fclose(read_by_xlisp);
|
||||
to_input_buffer = NULL;
|
||||
read_by_xlisp = NULL;
|
||||
return NIL;
|
||||
}
|
||||
|
||||
#endif
|
||||
|
||||
|
||||
Reference in New Issue
Block a user