home *** CD-ROM | disk | FTP | other *** search
/ Fresh Fish 8 / FreshFishVol8-CD1.bin / new / util / edit / jade / src / lispcmds.c < prev    next >
C/C++ Source or Header  |  1994-10-04  |  56KB  |  2,456 lines
  1. /* lispcmds.c -- Lots of standard Lisp functions
  2.    Copyright (C) 1993, 1994 John Harper <jsh@ukc.ac.uk>
  3.  
  4.    This file is part of Jade.
  5.  
  6.    Jade is free software; you can redistribute it and/or modify it
  7.    under the terms of the GNU General Public License as published by
  8.    the Free Software Foundation; either version 2, or (at your option)
  9.    any later version.
  10.  
  11.    Jade is distributed in the hope that it will be useful, but
  12.    WITHOUT ANY WARRANTY; without even the implied warranty of
  13.    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14.    GNU General Public License for more details.
  15.  
  16.    You should have received a copy of the GNU General Public License
  17.    along with Jade; see the file COPYING.    If not, write to
  18.    the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */
  19.  
  20. #include "jade.h"
  21. #include "jade_protos.h"
  22.  
  23. #include <string.h>
  24.  
  25. #ifdef NEED_MEMORY_H
  26. # include <memory.h>
  27. #endif
  28.  
  29. _PR void lispcmds_init(void);
  30.  
  31. _PR VALUE sym_load_path;
  32. VALUE sym_load_path, sym_lisp_lib_dir;
  33. /*
  34. ::doc:load_path::
  35. A list of directory names. When `load' opens a lisp-file it searches each
  36. directory named in this list in turn until the file is found or the list
  37. is exhausted.
  38. ::end::
  39. ::doc:lisp_lib_dir::
  40. The name of the directory in which the standard lisp files live.
  41. ::end::
  42. */
  43.  
  44. _PR VALUE cmd_quote(VALUE);
  45. DEFUN("quote", cmd_quote, subr_quote, (VALUE args), V_SF, DOC_quote) /*
  46. ::doc:quote::
  47. quote ARG
  48. 'ARG
  49.  
  50. Returns ARG.
  51. ::end:: */
  52. {
  53.     if(CONSP(args))
  54.     return(VCAR(args));
  55.     return(NULL);
  56. }
  57.  
  58. _PR VALUE cmd_function(VALUE);
  59. DEFUN("function", cmd_function, subr_function, (VALUE args), V_SF, DOC_function) /*
  60. ::doc:function::
  61. function ARG
  62. #'ARG
  63.  
  64. Normally the same as `quote'. When being compiled, if ARG is not a symbol
  65. it causes ARG to be compiled as a lambda expression.
  66. ::end:: */
  67. {
  68.     if(CONSP(args))
  69.     return(VCAR(args));
  70.     return(NULL);
  71. }
  72.  
  73. _PR VALUE cmd_defmacro(VALUE);
  74. DEFUN("defmacro", cmd_defmacro, subr_defmacro, (VALUE args), V_SF, DOC_defmacro) /*
  75. ::doc:defmacro::
  76. defmacro NAME LAMBDA-LIST [DOC-STRING] BODY...
  77.  
  78. Defines a macro called NAME with argument spec. LAMBDA-LIST, documentation
  79. DOC-STRING (optional) and body BODY. The actual function value is
  80.     `(macro lambda LAMBDA-LIST [DOC-STRING] BODY...)'
  81. Macros are called with their arguments un-evaluated, they are expected to
  82. return a form which will be executed to provide the result of the expression.
  83.  
  84. A pathetic example could be,
  85.   (defmacro foo (x) (list 'cons nil x))
  86.    => foo
  87.   (foo 'bar)
  88.    => (nil . bar)
  89. This makes `(foo X)' a pseudonym for `(cons nil X)'.
  90.  
  91. Note that macros are expanded at *compile-time* (unless, of course, the Lisp
  92. code has not been compiled).
  93. ::end:: */
  94. {
  95.     if(CONSP(args)
  96.        && cmd_fset(VCAR(args),
  97.             cmd_cons(sym_macro, cmd_cons(sym_lambda, VCDR(args)))))
  98.     {
  99.     return(VCAR(args));
  100.     }
  101.     return(NULL);
  102. }
  103.  
  104. _PR VALUE cmd_defun(VALUE);
  105. DEFUN("defun", cmd_defun, subr_defun, (VALUE args), V_SF, DOC_defun) /*
  106. ::doc:defun::
  107. defun NAME LAMBDA-LIST [DOC-STRING] BODY...
  108.  
  109. Defines a function called NAME with argument specification LAMBDA-LIST,
  110. documentation DOC-STRING (optional) and body BODY. The actual function
  111. value is,
  112.     `(lambda LAMBDA-LIST [DOC-STRING] BODY...)'
  113. ::end:: */
  114. {
  115.     if(CONSP(args)
  116.        && cmd_fset(VCAR(args), cmd_cons(sym_lambda, VCDR(args))))
  117.     {
  118.     return(VCAR(args));
  119.     }
  120.     return(NULL);
  121. }
  122.  
  123. _PR VALUE cmd_defvar(VALUE);
  124. DEFUN("defvar", cmd_defvar, subr_defvar, (VALUE args), V_SF, DOC_defvar) /*
  125. ::doc:defvar::
  126. defvar NAME DEFAULT-VALUE [DOC-STRING]
  127.  
  128. Define a variable called NAME whose standard value is DEFAULT-
  129. VALUE. If NAME is already bound to a value it is left as it is.
  130. If the symbol NAME is marked buffer-local the *default value* of the
  131. variable will be set (if necessary) not the local value.
  132. ::end:: */
  133. {
  134.     if(CONSP(args) && CONSP(VCDR(args)))
  135.     {
  136.     GCVAL gcv_args;
  137.     VALUE sym = VCAR(args), val;
  138.     VALUE tmp = cmd_default_boundp(sym);
  139.     if(!tmp)
  140.         return(NULL);
  141.     PUSHGC(gcv_args, args);
  142.     val = cmd_eval(VCAR(VCDR(args)));
  143.     POPGC;
  144.     if(!val)
  145.         return(NULL);
  146.     if(NILP(tmp))
  147.     {
  148.         if(!cmd_set_default(sym, val))
  149.         return(NULL);
  150.     }
  151.     if(CONSP(VCDR(VCDR(args))))
  152.     {
  153.         if(!cmd_put(sym, sym_variable_documentation, VCAR(VCDR(VCDR(args)))))
  154.         return(NULL);
  155.     }
  156.     return(sym);
  157.     }
  158.     return(NULL);
  159. }
  160.  
  161. _PR VALUE cmd_defconst(VALUE);
  162. DEFUN("defconst", cmd_defconst, subr_defconst, (VALUE args), V_SF, DOC_defconst) /*
  163. ::doc:defconst::
  164. defconst NAME VALUE [DOC-STRING]
  165.  
  166. Define a constant NAME whose (default) value is VALUE. If NAME is already
  167. bound an error is signalled.
  168.  
  169. Constants are treated specially by the Lisp compiler, basically they are
  170. hard-coded into the byte-code. For more details see the comments in
  171. the compiler source (`lisp/compiler.jl').
  172. ::end:: */
  173. {
  174.     if(CONSP(args))
  175.     {
  176.     VALUE tmp = cmd_default_boundp(VCAR(args));
  177.     if(tmp && !NILP(tmp))
  178.     {
  179.         return(cmd_signal(sym_error, list_2(MKSTR("Constant already bound"),
  180.                         VCAR(args))));
  181.     }
  182.     tmp = cmd_defvar(args);
  183.     if(tmp)
  184.         return(cmd_set_const_variable(tmp, sym_nil));
  185.     return(tmp);
  186.     }
  187.     return(signal_arg_error(sym_nil, 1));
  188. }
  189.  
  190. _PR VALUE cmd_car(VALUE);
  191. DEFUN("car", cmd_car, subr_car, (VALUE cons), V_Subr1, DOC_car) /*
  192. ::doc:car::
  193. car CONS-CELL
  194.  
  195. Returns the value stored in the car slot of CONS-CELL, or nil if CONS-CELL
  196. is nil.
  197. ::end:: */
  198. {
  199.     if(CONSP(cons))
  200.     return(VCAR(cons));
  201.     return(sym_nil);
  202. }
  203. _PR VALUE cmd_cdr(VALUE);
  204. DEFUN("cdr", cmd_cdr, subr_cdr, (VALUE cons), V_Subr1, DOC_cdr) /*
  205. ::doc:cdr::
  206. cdr CONS-CELL
  207.  
  208. Returns the value stored in the cdr slot of CONS-CELL, or nil if CONS-CELL
  209. is nil.
  210. ::end:: */
  211. {
  212.     if(CONSP(cons))
  213.     return(VCDR(cons));
  214.     return(sym_nil);
  215. }
  216.  
  217. _PR VALUE cmd_list(VALUE);
  218. DEFUN("list", cmd_list, subr_list, (VALUE args), V_SubrN, DOC_list) /*
  219. ::doc:list::
  220. list ARGS...
  221.  
  222. Returns a new list with elements ARGS...
  223. ::end:: */
  224. {
  225.     VALUE res = sym_nil;
  226.     VALUE *ptr = &res;
  227.     while(CONSP(args))
  228.     {
  229.     if(!(*ptr = cmd_cons(VCAR(args), sym_nil)))
  230.         return(NULL);
  231.     ptr = &VCDR(*ptr);
  232.     args = VCDR(args);
  233.     }
  234.     return(res);
  235. }
  236.  
  237. _PR VALUE cmd_make_list(VALUE, VALUE);
  238. DEFUN("make-list", cmd_make_list, subr_make_list, (VALUE len, VALUE init), V_Subr2, DOC_make_list) /*
  239. ::doc:make_list::
  240. make-list LENGTH [INITIAL-VALUE]
  241.  
  242. Returns a new list with LENGTH members, each of which is initialised to
  243. INITIAL-VALUE, or nil.
  244. ::end:: */
  245. {
  246.     int i;
  247.     VALUE res = sym_nil;
  248.     VALUE *last;
  249.     DECLARE1(len, NUMBERP);
  250.     last = &res;
  251.     for(i = 0; i < VNUM(len); i++)
  252.     {
  253.     if(!(*last = cmd_cons(init, sym_nil)))
  254.         return(NULL);
  255.     last = &VCDR(*last);
  256.     }
  257.     return(res);
  258. }
  259.  
  260. _PR VALUE cmd_append(VALUE);
  261. DEFUN("append", cmd_append, subr_append, (VALUE args), V_SubrN, DOC_append) /*
  262. ::doc:append::
  263. append LISTS...
  264.  
  265. Non-destructively concatenates each of it's argument LISTS... into one
  266. new list which is returned.
  267. ::end:: */
  268. {
  269.     VALUE res = sym_nil;
  270.     VALUE *resend = &res;
  271.     while(CONSP(args))
  272.     {
  273.     if(CONSP(VCAR(args)) && CONSP(VCDR(args)))
  274.     {
  275.         /* Only make a new copy if there's another list after this
  276.            one. */
  277.         *resend = copy_list(VCAR(args));
  278.     }
  279.     else
  280.         *resend = VCAR(args);    /* Use the old object */
  281.     while(CONSP(*resend))
  282.     {
  283.         TEST_INT;
  284.         if(INT_P)
  285.         return(NULL);
  286.         resend = &(VCDR(*resend));
  287.     }
  288.     args = VCDR(args);
  289.     }
  290.     return(res);
  291. }
  292.  
  293. _PR VALUE cmd_nconc(VALUE);
  294. DEFUN("nconc", cmd_nconc, subr_nconc, (VALUE args), V_SubrN, DOC_nconc) /*
  295. ::doc:nconc::
  296. nconc LISTS...
  297.  
  298. Destructively concatenates each of it's argument LISTS... into one new
  299. list. Every LIST but the last is modified so that it's last cdr points
  300. to the beginning of the next list. Returns the new list.
  301. ::end:: */
  302. {
  303.     VALUE res = sym_nil;
  304.     VALUE *resend = &res;
  305.     while(CONSP(args))
  306.     {
  307.     VALUE tmp = VCAR(args);
  308.     if(CONSP(tmp))
  309.     {
  310.         *resend = tmp;
  311.         while(CONSP(VCDR(tmp)))
  312.         {
  313.         TEST_INT;
  314.         if(INT_P)
  315.             return(NULL);
  316.         tmp = VCDR(tmp);
  317.         }
  318.         resend = &VCDR(tmp);
  319.     }
  320.     args = VCDR(args);
  321.     }
  322.     return(res);
  323. }
  324.  
  325. _PR VALUE cmd_rplaca(VALUE, VALUE);
  326. DEFUN("rplaca", cmd_rplaca, subr_rplaca, (VALUE cons, VALUE car), V_Subr2, DOC_rplaca) /*
  327. ::doc:rplaca::
  328. rplaca CONS-CELL NEW-CAR
  329.  
  330. Sets the value of the car slot in CONS-CELL