home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Fresh Fish 8
/
FreshFishVol8-CD1.bin
/
new
/
util
/
edit
/
jade
/
src
/
lispcmds.c
< prev
next >
Wrap
C/C++ Source or Header
|
1994-10-04
|
56KB
|
2,456 lines
/* lispcmds.c -- Lots of standard Lisp functions
Copyright (C) 1993, 1994 John Harper <jsh@ukc.ac.uk>
This file is part of Jade.
Jade 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 2, or (at your option)
any later version.
Jade 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 Jade; see the file COPYING. If not, write to
the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
#include "jade.h"
#include "jade_protos.h"
#include <string.h>
#ifdef NEED_MEMORY_H
# include <memory.h>
#endif
_PR void lispcmds_init(void);
_PR VALUE sym_load_path;
VALUE sym_load_path, sym_lisp_lib_dir;
/*
::doc:load_path::
A list of directory names. When `load' opens a lisp-file it searches each
directory named in this list in turn until the file is found or the list
is exhausted.
::end::
::doc:lisp_lib_dir::
The name of the directory in which the standard lisp files live.
::end::
*/
_PR VALUE cmd_quote(VALUE);
DEFUN("quote", cmd_quote, subr_quote, (VALUE args), V_SF, DOC_quote) /*
::doc:quote::
quote ARG
'ARG
Returns ARG.
::end:: */
{
if(CONSP(args))
return(VCAR(args));
return(NULL);
}
_PR VALUE cmd_function(VALUE);
DEFUN("function", cmd_function, subr_function, (VALUE args), V_SF, DOC_function) /*
::doc:function::
function ARG
#'ARG
Normally the same as `quote'. When being compiled, if ARG is not a symbol
it causes ARG to be compiled as a lambda expression.
::end:: */
{
if(CONSP(args))
return(VCAR(args));
return(NULL);
}
_PR VALUE cmd_defmacro(VALUE);
DEFUN("defmacro", cmd_defmacro, subr_defmacro, (VALUE args), V_SF, DOC_defmacro) /*
::doc:defmacro::
defmacro NAME LAMBDA-LIST [DOC-STRING] BODY...
Defines a macro called NAME with argument spec. LAMBDA-LIST, documentation
DOC-STRING (optional) and body BODY. The actual function value is
`(macro lambda LAMBDA-LIST [DOC-STRING] BODY...)'
Macros are called with their arguments un-evaluated, they are expected to
return a form which will be executed to provide the result of the expression.
A pathetic example could be,
(defmacro foo (x) (list 'cons nil x))
=> foo
(foo 'bar)
=> (nil . bar)
This makes `(foo X)' a pseudonym for `(cons nil X)'.
Note that macros are expanded at *compile-time* (unless, of course, the Lisp
code has not been compiled).
::end:: */
{
if(CONSP(args)
&& cmd_fset(VCAR(args),
cmd_cons(sym_macro, cmd_cons(sym_lambda, VCDR(args)))))
{
return(VCAR(args));
}
return(NULL);
}
_PR VALUE cmd_defun(VALUE);
DEFUN("defun", cmd_defun, subr_defun, (VALUE args), V_SF, DOC_defun) /*
::doc:defun::
defun NAME LAMBDA-LIST [DOC-STRING] BODY...
Defines a function called NAME with argument specification LAMBDA-LIST,
documentation DOC-STRING (optional) and body BODY. The actual function
value is,
`(lambda LAMBDA-LIST [DOC-STRING] BODY...)'
::end:: */
{
if(CONSP(args)
&& cmd_fset(VCAR(args), cmd_cons(sym_lambda, VCDR(args))))
{
return(VCAR(args));
}
return(NULL);
}
_PR VALUE cmd_defvar(VALUE);
DEFUN("defvar", cmd_defvar, subr_defvar, (VALUE args), V_SF, DOC_defvar) /*
::doc:defvar::
defvar NAME DEFAULT-VALUE [DOC-STRING]
Define a variable called NAME whose standard value is DEFAULT-
VALUE. If NAME is already bound to a value it is left as it is.
If the symbol NAME is marked buffer-local the *default value* of the
variable will be set (if necessary) not the local value.
::end:: */
{
if(CONSP(args) && CONSP(VCDR(args)))
{
GCVAL gcv_args;
VALUE sym = VCAR(args), val;
VALUE tmp = cmd_default_boundp(sym);
if(!tmp)
return(NULL);
PUSHGC(gcv_args, args);
val = cmd_eval(VCAR(VCDR(args)));
POPGC;
if(!val)
return(NULL);
if(NILP(tmp))
{
if(!cmd_set_default(sym, val))
return(NULL);
}
if(CONSP(VCDR(VCDR(args))))
{
if(!cmd_put(sym, sym_variable_documentation, VCAR(VCDR(VCDR(args)))))
return(NULL);
}
return(sym);
}
return(NULL);
}
_PR VALUE cmd_defconst(VALUE);
DEFUN("defconst", cmd_defconst, subr_defconst, (VALUE args), V_SF, DOC_defconst) /*
::doc:defconst::
defconst NAME VALUE [DOC-STRING]
Define a constant NAME whose (default) value is VALUE. If NAME is already
bound an error is signalled.
Constants are treated specially by the Lisp compiler, basically they are
hard-coded into the byte-code. For more details see the comments in
the compiler source (`lisp/compiler.jl').
::end:: */
{
if(CONSP(args))
{
VALUE tmp = cmd_default_boundp(VCAR(args));
if(tmp && !NILP(tmp))
{
return(cmd_signal(sym_error, list_2(MKSTR("Constant already bound"),
VCAR(args))));
}
tmp = cmd_defvar(args);
if(tmp)
return(cmd_set_const_variable(tmp, sym_nil));
return(tmp);
}
return(signal_arg_error(sym_nil, 1));
}
_PR VALUE cmd_car(VALUE);
DEFUN("car", cmd_car, subr_car, (VALUE cons), V_Subr1, DOC_car) /*
::doc:car::
car CONS-CELL
Returns the value stored in the car slot of CONS-CELL, or nil if CONS-CELL
is nil.
::end:: */
{
if(CONSP(cons))
return(VCAR(cons));
return(sym_nil);
}
_PR VALUE cmd_cdr(VALUE);
DEFUN("cdr", cmd_cdr, subr_cdr, (VALUE cons), V_Subr1, DOC_cdr) /*
::doc:cdr::
cdr CONS-CELL
Returns the value stored in the cdr slot of CONS-CELL, or nil if CONS-CELL
is nil.
::end:: */
{
if(CONSP(cons))
return(VCDR(cons));
return(sym_nil);
}
_PR VALUE cmd_list(VALUE);
DEFUN("list", cmd_list, subr_list, (VALUE args), V_SubrN, DOC_list) /*
::doc:list::
list ARGS...
Returns a new list with elements ARGS...
::end:: */
{
VALUE res = sym_nil;
VALUE *ptr = &res;
while(CONSP(args))
{
if(!(*ptr = cmd_cons(VCAR(args), sym_nil)))
return(NULL);
ptr = &VCDR(*ptr);
args = VCDR(args);
}
return(res);
}
_PR VALUE cmd_make_list(VALUE, VALUE);
DEFUN("make-list", cmd_make_list, subr_make_list, (VALUE len, VALUE init), V_Subr2, DOC_make_list) /*
::doc:make_list::
make-list LENGTH [INITIAL-VALUE]
Returns a new list with LENGTH members, each of which is initialised to
INITIAL-VALUE, or nil.
::end:: */
{
int i;
VALUE res = sym_nil;
VALUE *last;
DECLARE1(len, NUMBERP);
last = &res;
for(i = 0; i < VNUM(len); i++)
{
if(!(*last = cmd_cons(init, sym_nil)))
return(NULL);
last = &VCDR(*last);
}
return(res);
}
_PR VALUE cmd_append(VALUE);
DEFUN("append", cmd_append, subr_append, (VALUE args), V_SubrN, DOC_append) /*
::doc:append::
append LISTS...
Non-destructively concatenates each of it's argument LISTS... into one
new list which is returned.
::end:: */
{
VALUE res = sym_nil;
VALUE *resend = &res;
while(CONSP(args))
{
if(CONSP(VCAR(args)) && CONSP(VCDR(args)))
{
/* Only make a new copy if there's another list after this
one. */
*resend = copy_list(VCAR(args));
}
else
*resend = VCAR(args); /* Use the old object */
while(CONSP(*resend))
{
TEST_INT;
if(INT_P)
return(NULL);
resend = &(VCDR(*resend));
}
args = VCDR(args);
}
return(res);
}
_PR VALUE cmd_nconc(VALUE);
DEFUN("nconc", cmd_nconc, subr_nconc, (VALUE args), V_SubrN, DOC_nconc) /*
::doc:nconc::
nconc LISTS...
Destructively concatenates each of it's argument LISTS... into one new
list. Every LIST but the last is modified so that it's last cdr points
to the beginning of the next list. Returns the new list.
::end:: */
{
VALUE res = sym_nil;
VALUE *resend = &res;
while(CONSP(args))
{
VALUE tmp = VCAR(args);
if(CONSP(tmp))
{
*resend = tmp;
while(CONSP(VCDR(tmp)))
{
TEST_INT;
if(INT_P)
return(NULL);
tmp = VCDR(tmp);
}
resend = &VCDR(tmp);
}
args = VCDR(args);
}
return(res);
}
_PR VALUE cmd_rplaca(VALUE, VALUE);
DEFUN("rplaca", cmd_rplaca, subr_rplaca, (VALUE cons, VALUE car), V_Subr2, DOC_rplaca) /*
::doc:rplaca::
rplaca CONS-CELL NEW-CAR
Sets the value of the car slot in CONS-CELL