home *** CD-ROM | disk | FTP | other *** search
/ Fresh Fish 4 / FreshFish_May-June1994.bin / bbs / may94 / util / edit / jade.lha / Jade / src / lispcmds.c < prev    next >
C/C++ Source or Header  |  1994-04-19  |  49KB  |  2,015 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. _PR void lispcmds_init(void);
  26.  
  27. _PR VALUE sym_load_path;
  28. VALUE sym_load_path, sym_lisp_lib_dir;
  29. /*
  30. ::doc:load_path::
  31. A list of directory names. When `load' opens a lisp-file it searches each
  32. directory named in this list in turn until the file is found or the list
  33. is exhausted.
  34. ::end::
  35. ::doc:lisp_lib_dir::
  36. The name of the directory in which the standard lisp files live.
  37. ::end::
  38. */
  39.  
  40. _PR VALUE cmd_quote(VALUE);
  41. DEFUN("quote", cmd_quote, subr_quote, (VALUE args), V_SF, DOC_quote) /*
  42. ::doc:quote::
  43. (quote ARG) <SPECIAL-FORM>
  44. 'ARG
  45. Returns ARG.
  46. ::end:: */
  47. {
  48.     if(CONSP(args))
  49.     return(VCAR(args));
  50.     return(NULL);
  51. }
  52.  
  53. _PR VALUE cmd_function(VALUE);
  54. DEFUN("function", cmd_function, subr_function, (VALUE args), V_SF, DOC_function) /*
  55. ::doc:function::
  56. (function ARG) <SPECIAL-FORM>
  57. #'ARG
  58. Normally the same as `quote'. When being compiled, if ARG is not a symbol
  59. it causes ARG to be compiled as a lambda expression.
  60. ::end:: */
  61. {
  62.     if(CONSP(args))
  63.     return(VCAR(args));
  64.     return(NULL);
  65. }
  66.  
  67. _PR VALUE cmd_defmacro(VALUE);
  68. DEFUN("defmacro", cmd_defmacro, subr_defmacro, (VALUE args), V_SF, DOC_defmacro) /*
  69. ::doc:defmacro::
  70. (defmacro NAME LAMBDA-LIST [DOC-STRING] BODY...)
  71. Defines a macro called NAME with argument spec. LAMBDA-LIST, documentation
  72. DOC-STRING (optional) and body BODY. The actual function value is 
  73.     `(macro lambda LAMBDA-LIST [DOC-STRING] BODY...)'
  74. Macros are called with their arguments un-evaluated, they are expected to
  75. return a form which will be executed to provide the result of the expression.
  76.  
  77. A pathetic example could be,
  78.   (defmacro foo (x) (list 'cons nil x))
  79.    => foo
  80.   (foo 'bar)
  81.    => (nil . bar)
  82. This makes `(foo X)' a pseudonym for `(cons nil X)'.
  83.  
  84. Note that macros are expanded at *compile-time* (unless, of course, the Lisp
  85. code has not been compiled).
  86. ::end:: */
  87. {
  88.     if(CONSP(args))
  89.     return(cmd_fset(VCAR(args), cmd_cons(sym_macro, cmd_cons(sym_lambda, VCDR(args)))));
  90.     else
  91.     return(NULL);
  92. }
  93.  
  94. _PR VALUE cmd_defun(VALUE);
  95. DEFUN("defun", cmd_defun, subr_defun, (VALUE args), V_SF, DOC_defun) /*
  96. ::doc:defun::
  97. (defun NAME LAMBDA-LIST [DOC-STRING] BODY...)
  98. Defines a function called NAME with argument specification LAMBDA-LIST,
  99. documentation DOC-STRING (optional) and body BODY. The actual function
  100. value is,
  101.     `(lambda LAMBDA-LIST [DOC-STRING] BODY...)'
  102. ::end:: */
  103. {
  104.     if(CONSP(args))
  105.     return(cmd_fset(VCAR(args), cmd_cons(sym_lambda, VCDR(args))));
  106.     else
  107.     return(NULL);
  108. }
  109.  
  110. _PR VALUE cmd_car(VALUE);
  111. DEFUN("car", cmd_car, subr_car, (VALUE cons), V_Subr1, DOC_car) /*
  112. ::doc:car::
  113. (car CONS-CELL)
  114. Returns the value stored in the car slot of CONS-CELL, or nil if CONS-CELL
  115. is nil.
  116. ::end:: */
  117. {
  118.     if(CONSP(cons))
  119.     return(VCAR(cons));
  120.     return(sym_nil);
  121. }
  122. _PR VALUE cmd_cdr(VALUE);
  123. DEFUN("cdr", cmd_cdr, subr_cdr, (VALUE cons), V_Subr1, DOC_cdr) /*
  124. ::doc:cdr::
  125. (cdr CONS-CELL)
  126. Returns the value stored in the cdr slot of CONS-CELL, or nil if CONS-CELL
  127. is nil.
  128. ::end:: */
  129. {
  130.     if(CONSP(cons))
  131.     return(VCDR(cons));
  132.     return(sym_nil);
  133. }
  134.  
  135. _PR VALUE cmd_list(VALUE);
  136. DEFUN("list", cmd_list, subr_list, (VALUE args), V_SubrN, DOC_list) /*
  137. ::doc:list::
  138. (list ARGS...)
  139. Returns a new list with members ARGS...
  140. ::end:: */
  141. {
  142.     return(args);
  143. }
  144.  
  145. _PR VALUE cmd_copy_list(VALUE);
  146. DEFUN("copy-list", cmd_copy_list, subr_copy_list, (VALUE list), V_Subr1, DOC_copy_list) /*
  147. ::doc:copy_list::
  148. (copy-list LIST)
  149. Returns a new list which is identical to LIST except that the cons cells
  150. which it is made from are different, all elements are shared however.
  151. ::end:: */
  152. {
  153.     VALUE res = sym_nil;
  154.     VALUE *last = &res;
  155.     while(CONSP(list))
  156.     {
  157.     if(!(*last = cmd_cons(VCAR(list), sym_nil)))
  158.         return(NULL);
  159.     last = &VCDR(*last);
  160.     list = VCDR(list);
  161.     }
  162.     return(res);
  163. }
  164.  
  165. _PR VALUE cmd_make_list(VALUE, VALUE);
  166. DEFUN("make-list", cmd_make_list, subr_make_list, (VALUE len, VALUE init), V_Subr2, DOC_make_list) /*
  167. ::doc:make_list::
  168. (make-list LENGTH [INITIAL-VALUE])
  169. Returns a new list with LENGTH members, each of which is initialised to
  170. INITIAL-VALUE, or nil.
  171. ::end:: */
  172. {
  173.     int i;
  174.     VALUE res = sym_nil;
  175.     VALUE *last;
  176.     DECLARE1(len, NUMBERP);
  177.     last = &res;
  178.     for(i = 0; i < VNUM(len); i++)
  179.     {
  180.     if(!(*last = cmd_cons(init, sym_nil)))
  181.         return(NULL);
  182.     last = &VCDR(*last);
  183.     }
  184.     return(res);
  185. }
  186.  
  187. _PR VALUE cmd_append(VALUE);
  188. DEFUN("append", cmd_append, subr_append, (VALUE args), V_SubrN, DOC_append) /*
  189. ::doc:append::
  190. (append LISTS...)
  191. Non-destructively concatenates each of it's argument LISTS... into one
  192. new list which is returned.
  193. ::end:: */
  194. {
  195.     VALUE res = sym_nil;
  196.     VALUE *resend = &res;
  197.     while(CONSP(args))
  198.     {
  199.     if(CONSP(VCAR(args)))
  200.         *resend = copylist(VCONS(args)->cn_Car);
  201.     else
  202.         *resend = VCAR(args);
  203.     while(CONSP(*resend))
  204.         resend = &(VCDR(*resend));
  205.     args = VCDR(args);
  206.     }
  207.     return(res);
  208. }
  209.  
  210. _PR VALUE cmd_nconc(VALUE);
  211. DEFUN("nconc", cmd_nconc, subr_nconc, (VALUE args), V_SubrN, DOC_nconc) /*
  212. ::doc:nconc::
  213. (nconc LISTS... )
  214. Destructively concatenates each of it's argument LISTS... into one new
  215. list. Every LIST but the last is modified so that it's last cdr points
  216. to the beginning of the next list. Returns the new list.
  217. ::end:: */
  218. {
  219.     VALUE res = sym_nil;
  220.     VALUE *resend = &res;
  221.     while(CONSP(args))
  222.     {
  223.     VALUE tmp = VCAR(args);
  224.     if(CONSP(tmp))
  225.     {
  226.         *resend = tmp;
  227.         while(CONSP(VCDR(tmp)))
  228.         tmp = VCDR(tmp);
  229.         resend = &VCDR(tmp);
  230.     }
  231.     args = VCDR(args);
  232.     }
  233.     return(res);
  234. }
  235.  
  236. _PR VALUE cmd_rplaca(VALUE, VALUE);
  237. DEFUN("rplaca", cmd_rplaca, subr_rplaca, (VALUE cons, VALUE car), V_Subr2, DOC_rplaca) /*
  238. ::doc:rplaca::
  239. (rplaca CONS-CELL NEW-CAR)
  240. Sets the value of the car slot in CONS-CELL to NEW-CAR. Returns the new
  241. value.
  242. ::end:: */
  243. {
  244.     DECLARE1(cons, CONSP);
  245.     VCAR(cons) = car;
  246.     return(car);
  247. }
  248. _PR VALUE cmd_rplacd(VALUE, VALUE);
  249. DEFUN("rplacd", cmd_rplacd, subr_rplacd, (VALUE cons, VALUE cdr), V_Subr2, DOC_rplacd) /*
  250. ::doc:rplacd::
  251. (rplacd CONS-CELL NEW-CDR)
  252. Sets the value of the cdr slot in CONS-CELL to NEW-CAR. Returns the new
  253. value.
  254. ::end:: */
  255. {
  256.     DECLARE1(cons, CONSP);
  257.     VCDR(cons) = cdr;
  258.     return(cdr);
  259. }
  260.  
  261. _PR VALUE cmd_reverse(VALUE);
  262. DEFUN("reverse", cmd_reverse, subr_reverse, (VALUE head), V_Subr1, DOC_reverse) /*
  263. ::doc:reverse::
  264. (reverse LIST)
  265. Returns a new list which is a copy of LIST except that the members are in
  266. reverse order.
  267. ::end:: */
  268. {
  269.     VALUE res = sym_nil;
  270.     while(CONSP(head))
  271.     {
  272.     VALUE new;
  273.     if(!(new = cmd_cons(VCAR(head), res)))
  274.         return(NULL);
  275.     head = VCDR(head);
  276.     }
  277.     return(res);
  278. }
  279.  
  280. _PR VALUE cmd_nreverse(VALUE);
  281. DEFUN("nreverse", cmd_nreverse, subr_nreverse, (VALUE head), V_Subr1, DOC_nreverse) /*
  282. ::doc:nreverse::
  283. (nreverse LIST)
  284. Returns LIST altered so that it's members are in reverse order to what they
  285. were. This function is destructive towards it's argument.
  286. ::end:: */
  287. {
  288.     VALUE res = sym_nil;
  289.     VALUE nxt;
  290.     if(!CONSP(head))
  291.     return(sym_nil);
  292.     do {
  293.     if(CONSP(VCDR(head)))
  294.         nxt = VCDR(head);
  295.     else
  296.         nxt = NULL;
  297.     VCDR(head) = res;
  298.     res = head;
  299.     } while((head = nxt));
  300.     return(res);
  301. }
  302.  
  303. _PR VALUE cmd_assoc(VALUE, VALUE);
  304. DEFUN("assoc", cmd_assoc, subr_assoc, (VALUE elt, VALUE list), V_Subr2, DOC_assoc) /*
  305. ::doc:assoc::
  306. (assoc ELT ASSOC-LIST)
  307. Searches ASSOC-LIST for a list whose first element is ELT. `assoc' uses
  308. `equal' to compare elements. Returns the sub-list starting from the first 
  309. matching association.
  310. ::end:: */