home *** CD-ROM | disk | FTP | other *** search
/ Fresh Fish 5 / FreshFish_July-August1994.bin / bbs / util / jade-3.0.lha / Jade / src / lispcmds.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-04-19  |  47.5 KB  |  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:: */
  311. {
  312.     while(CONSP(list))
  313.     {
  314.     VALUE car = VCAR(list);
  315.     if(CONSP(car) && (!valuecmp(elt, VCAR(car))))
  316.         return(car);
  317.     list = VCDR(list);
  318.     }
  319.     return(sym_nil);
  320. }
  321. _PR VALUE cmd_assq(VALUE, VALUE);
  322. DEFUN("assq", cmd_assq, subr_assq, (VALUE elt, VALUE list), V_Subr2, DOC_assq) /*
  323. ::doc:assq::
  324. (assq ELT ASSOC-LIST)
  325. Searches ASSOC-LIST for a list whose first element is ELT. `assq' uses `eq'
  326. to compare elements. Returns the sub-list starting from the first matching
  327. association.
  328. ::end:: */
  329. {
  330.     while(CONSP(list))
  331.     {
  332.     VALUE car = VCAR(list);
  333.     if(CONSP(car) && (elt == VCAR(car)))
  334.         return(car);
  335.     list = VCDR(list);
  336.     }
  337.     return(sym_nil);
  338. }
  339.  
  340. _PR VALUE cmd_nth(VALUE, VALUE);
  341. DEFUN("nth", cmd_nth, subr_nth, (VALUE index, VALUE list), V_Subr2, DOC_nth) /*
  342. ::doc:nth::
  343. (nth INDEX LIST)
  344. Returns the INDEXth element of LIST. The first element has an INDEX of zero.
  345. ::end:: */
  346. {
  347.     int i;
  348.     DECLARE1(index, NUMBERP);
  349.     i = VNUM(index);
  350.     while(i && CONSP(list))
  351.     {
  352.     list = VCDR(list);
  353.     i--;
  354.     }
  355.     if((!i) && CONSP(list))
  356.     return(VCAR(list));
  357.     return(sym_nil);
  358. }
  359.  
  360. _PR VALUE cmd_nthcdr(VALUE index, VALUE list);
  361. DEFUN("nthcdr", cmd_nthcdr, subr_nthcdr, (VALUE index, VALUE list), V_Subr2, DOC_nthcdr) /*
  362. ::doc:nthcdr::
  363. (nthcdr INDEX LIST)
  364. Returns the INDEXth cdr of LIST. The first is INDEX zero.
  365. ::end:: */
  366. {
  367.     int i;
  368.     DECLARE1(index, NUMBERP);
  369.     i = VNUM(index);
  370.     while(i && CONSP(list))
  371.     {
  372.     list = VCDR(list);
  373.     i--;
  374.     }
  375.     if(!i)
  376.     return(list);
  377.     return(sym_nil);
  378. }
  379.  
  380. _PR VALUE cmd_last(VALUE);
  381. DEFUN("last", cmd_last, subr_last, (VALUE list), V_Subr1, DOC_last) /*
  382. ::doc:last::
  383. (last LIST)
  384. Returns the last element of LIST.
  385. ::end:: */
  386. {
  387.     if(CONSP(list))
  388.     {
  389.     while(CONSP(VCDR(list)))
  390.         list = VCDR(list);
  391.     return(list);
  392.     }
  393.     return(sym_nil);
  394. }
  395.  
  396. _PR VALUE cmd_mapcar(VALUE, VALUE);
  397. DEFUN("mapcar", cmd_mapcar, subr_mapcar, (VALUE fun, VALUE list), V_Subr2, DOC_mapcar) /*
  398. ::doc:mapcar::
  399. (mapcar FUNCTION LIST)
  400. Calls FUNCTION-NAME with each element of LIST as an argument in turn and
  401. returns a new list constructed from the results, ie,
  402.   (mapcar (function (lambda (x) (1+ x))) '(1 2 3))
  403.    => (2 3 4)
  404. ::end:: */
  405. {
  406.     VALUE res = sym_nil;
  407.     VALUE *last = &res;
  408.     GCVAL gcv_list, gcv_argv, gcv_res;
  409.     VALUE argv = cmd_cons(fun, cmd_cons(sym_nil, sym_nil));
  410.     if(argv)
  411.     {
  412.     PUSHGC(gcv_res, res);
  413.     PUSHGC(gcv_argv, argv);
  414.     PUSHGC(gcv_list, list);
  415.     while(res && CONSP(list))
  416.     {
  417.         if(!(*last = cmd_cons(sym_nil, sym_nil)))
  418.         return(NULL);
  419.         VCAR(VCDR(argv)) = VCAR(list);
  420.         if(!(VCAR(*last) = cmd_funcall(argv)))
  421.         res = NULL;
  422.         else
  423.         {
  424.         last = &VCDR(*last);
  425.         list = VCDR(list);
  426.         }
  427.     }
  428.     POPGC; POPGC; POPGC;
  429.     }
  430.     return(res);
  431. }
  432.  
  433. _PR VALUE cmd_mapc(VALUE, VALUE);
  434. DEFUN("mapc", cmd_mapc, subr_mapc, (VALUE fun, VALUE list), V_Subr2, DOC_mapc) /*
  435. ::doc:mapc::
  436. (mapc FUNCTION LIST)
  437. Applies FUNCTION to each element in LIST, discards the results.
  438. ::end:: */
  439. {
  440.     VALUE argv, res = sym_nil;
  441.     GCVAL gcv_argv, gcv_list;
  442.     if(!(argv = cmd_cons(fun, cmd_cons(sym_nil, sym_nil))))
  443.     return(NULL);
  444.     PUSHGC(gcv_argv, argv);
  445.     PUSHGC(gcv_list, list);
  446.     while(res && CONSP(list))
  447.     {
  448.     VCAR(VCDR(argv)) = VCAR(list);
  449.     res = cmd_funcall(argv);
  450.     list = VCDR(list);
  451.     }
  452.     POPGC; POPGC;
  453.     return(res);
  454. }
  455.  
  456. _PR VALUE cmd_member(VALUE, VALUE);
  457. DEFUN("member", cmd_member, subr_member, (VALUE elt, VALUE list), V_Subr2, DOC_member) /*
  458. ::doc:member::
  459. (member ELT LIST)
  460. If ELT is a member of list LIST then return the tail of the list starting
  461. from the matched ELT, ie,
  462.   (member 1 '(2 1 3))
  463.    => (1 3)
  464. `member' uses `equal' to compare atoms.
  465. ::end:: */
  466. {
  467.     while(CONSP(list))
  468.     {
  469.     if(!valuecmp(elt, VCAR(list)))
  470.         return(list);
  471.     list = VCDR(list);
  472.     }
  473.     return(sym_nil);
  474. }
  475. _PR VALUE cmd_memq(VALUE, VALUE);
  476. DEFUN("memq", cmd_memq, subr_memq, (VALUE elt, VALUE list), V_Subr2, DOC_memq) /*
  477. ::doc:memq::
  478. (memq ELT LIST)
  479. If ELT is a member of list LIST then return the tail of the list starting
  480. from the matched ELT, ie,
  481.   (memq 1 '(2 1 3))
  482.    => (1 3)
  483. `memq' uses `eq' to compare atoms.
  484. ::end:: */
  485. {
  486.     while(CONSP(list))
  487.     {
  488.     if(elt == VCAR(list))
  489.         return(list);
  490.     list = VCDR(list);
  491.     }
  492.     return(sym_nil);
  493. }
  494.  
  495. _PR VALUE cmd_delete(VALUE, VALUE);
  496. DEFUN("delete", cmd_delete, subr_delete, (VALUE elt, VALUE list), V_Subr2, DOC_delete) /*
  497. ::doc:delete::
  498. (delete ELT LIST)
  499. Returns LIST with any members `equal' to ELT destructively removed.
  500. ::end:: */
  501. {
  502.     VALUE *head = &list;
  503.     while(CONSP(*head))
  504.     {
  505.     if(!valuecmp(elt, VCAR(*head)))
  506.         *head = VCDR(*head);
  507.     else
  508.         head = &VCDR(*head);
  509.     }
  510.     return(list);
  511. }
  512. _PR VALUE cmd_delq(VALUE, VALUE);
  513. DEFUN("delq", cmd_delq, subr_delq, (VALUE elt, VALUE list), V_Subr2, DOC_delq) /*
  514. ::doc:delq::
  515. (delq ELT LIST)
  516. Returns LIST with any members `eq' to ELT destructively removed.
  517. ::end:: */
  518. {
  519.     VALUE *head = &list;
  520.     while(CONSP(*head))
  521.     {
  522.     if(elt == VCAR(*head))
  523.         *head = VCDR(*head);
  524.     else
  525.         head = &VCDR(*head);
  526.     }
  527.     return(list);
  528. }
  529.  
  530. _PR VALUE cmd_delete_if(VALUE, VALUE);
  531. DEFUN("delete-if", cmd_delete_if, subr_delete_if, (VALUE pred, VALUE list), V_Subr2, DOC_delete_if) /*
  532. ::doc:delete_if::
  533. (delete-if FUNCTION LIST)
  534. Similar to `delete' except that a predicate function, FUNCTION-NAME, is
  535. used to decide which elements to delete (remove destructively).
  536. `delete-if' deletes an element if FUNCTION-NAME returns non-nil when 
  537. applied to that element, ie,
  538.   (delete-if '(lambda (x) (= x 1)) '(1 2 3 4 1 2))
  539.    => (2 3 4 2)
  540. ::end:: */
  541. {
  542.     VALUE *head = &list;
  543.     VALUE tmp;
  544.     while(CONSP(*head))
  545.     {
  546.     if(!(tmp = calllisp1(pred, VCAR(*head))))
  547.         return(NULL);
  548.     if(!NILP(tmp))
  549.         *head = VCDR(*head);
  550.     else
  551.         head = &VCDR(*head);
  552.     }
  553.     return(list);
  554. }
  555. _PR VALUE cmd_delete_if_not(VALUE, VALUE);
  556. DEFUN("delete-if-not", cmd_delete_if_not, subr_delete_if_not, (VALUE pred, VALUE list), V_Subr2, DOC_delete_if_not) /*
  557. ::doc:delete_if_not::
  558. (delete-if-not FUNCTION LIST)
  559. Similar to `delete' except that a predicate function, FUNCTION-NAME, is
  560. used to decide which elements to delete (remove destructively).
  561. `delete-if-not' deletes an element if FUNCTION-NAME returns nil when 
  562. applied to that element, ie,
  563.   (delete-if-not '(lambda (x) (= x 1)) '(1 2 3 4 1 2))
  564.    => (1 1)
  565. ::end:: */
  566. {
  567.     VALUE *head = &list;
  568.     VALUE tmp;
  569.     while(CONSP(*head))
  570.     {
  571.     if(!(tmp = calllisp1(pred, VCAR(*head))))
  572.         return(NULL);
  573.     if(NILP(tmp))
  574.         *head = VCDR(*head);
  575.     else
  576.         head = &VCDR(*head);
  577.     }
  578.     return(list);
  579. }
  580.  
  581. _PR VALUE cmd_vector(VALUE);
  582. DEFUN("vector", cmd_vector, subr_vector, (VALUE args), V_SubrN, DOC_vector) /*
  583. ::doc:vector::
  584. (vector ARGS...)
  585. Returns a new vector with ARGS... as its elements.
  586. ::end:: */
  587. {
  588.     VALUE res = newvector(listlen(args));
  589.     if(res)
  590.     {
  591.     int i = 0;
  592.     while(CONSP(args))
  593.     {
  594.         VVECT(res)->vc_Array[i] = VCAR(args);
  595.         args = VCDR(args);
  596.         i++;
  597.     }
  598.     }
  599.     return(res);
  600. }
  601.  
  602. _PR VALUE cmd_make_vector(VALUE, VALUE);
  603. DEFUN("make-vector", cmd_make_vector, subr_make_vector, (VALUE size, VALUE init), V_Subr2, DOC_make_vector) /*
  604. ::doc:make_vector::
  605. (make-vector SIZE [INITIAL-VALUE])
  606. Creates a new vector of size SIZE. If INITIAL-VALUE is provided each element
  607. will be set to that value, else they will all be nil.
  608. ::end:: */
  609. {
  610.     int len;
  611.     VALUE res;
  612.     DECLARE1(size, NUMBERP);
  613.     len = VNUM(size);
  614.     res = newvector(len);
  615.     if(res)
  616.     {
  617.     int i;
  618.     for(i = 0; i < len; i++)
  619.         VVECT(res)->vc_Array[i] = init;
  620.     }
  621.     return(res);
  622. }
  623.  
  624. _PR VALUE cmd_aset(VALUE, VALUE, VALUE);
  625. DEFUN("aset", cmd_aset, subr_aset, (VALUE seq, VALUE index, VALUE new), V_Subr3, DOC_aset) /*
  626. ::doc:aset::
  627. (aset SEQUENCE INDEX NEW-VALUE)
  628. Sets element number INDEX (a positive integer) of SEQUENCE (can be a list,
  629. vector or string) to NEW-VALUE, returning NEW-VALUE. Note that strings
  630. can only contain characters (ie, integers).
  631. ::end:: */
  632. {
  633.     DECLARE2(index, NUMBERP);
  634.     switch(VTYPE(seq))
  635.     {
  636.     case V_StaticString:
  637.     case V_String:
  638.     if(VNUM(index) < strlen(VSTR(seq)))
  639.     {
  640.         DECLARE3(new, NUMBERP);
  641.         VSTR(seq)[VNUM(index)] = (u_char)VCHAR(new);
  642.         return(new);
  643.     }
  644.     break;
  645.     case V_Vector:
  646.     if(VNUM(index) < VVECT(seq)->vc_Size)
  647.     {
  648.         VVECT(seq)->vc_Array[VNUM(index)] = new;
  649.         return(new);
  650.     }
  651.     break;
  652.     default:
  653.     cmd_signal(sym_bad_arg, list_2(seq, newnumber(1)));
  654.     return(NULL);
  655.     }
  656.     return(sym_nil);
  657. }
  658.  
  659. _PR VALUE cmd_aref(VALUE, VALUE);
  660. DEFUN("aref", cmd_aref, subr_aref, (VALUE seq, VALUE index), V_Subr2, DOC_aref) /*
  661. ::doc:aref::
  662. (aref SEQUENCE INDEX)
  663. Returns the INDEXth (a non-negative integer) element of SEQUENCE, which
  664. can be a list, vector or string. INDEX starts at zero.
  665. ::end:: */
  666. {
  667.     VALUE res = sym_nil;
  668.     DECLARE2(index, NUMBERP);
  669.     switch(VTYPE(seq))
  670.     {
  671.     case V_StaticString:
  672.     case V_String:
  673.     if(VNUM(index) < strlen(VSTR(seq)))
  674.         res = newnumber(VSTR(seq)[VNUM(index)]);
  675.     break;
  676.     case V_Vector:
  677.     if(VNUM(index) < VVECT(seq)->vc_Size)
  678.         res = VVECT(seq)->vc_Array[VNUM(index)];
  679.     break;
  680.     default:
  681.     cmd_signal(sym_bad_arg, list_2(seq, newnumber(1)));
  682.     res = NULL;
  683.     }
  684.     return(res);
  685. }
  686.  
  687. _PR VALUE cmd_make_string(VALUE, VALUE);
  688. DEFUN("make-string", cmd_make_string, subr_make_string, (VALUE len, VALUE init), V_Subr2, DOC_make_string) /*
  689. ::doc:make_string::
  690. (make-string LENGTH [INITIAL-VALUE])
  691. Returns a new string of length LENGTH, each character is initialised to
  692. INITIAL-VALUE, or to space if INITIAL-VALUE is not given.
  693. ::end:: */
  694. {
  695.     VALUE res;
  696.     DECLARE1(len, NUMBERP);
  697.     res = valstralloc(VNUM(len) + 1);
  698.     if(res)
  699.     {
  700.     memset(VSTR(res), NUMBERP(init) ? (u_char)VCHAR(init) : ' ', VNUM(len));
  701.     VSTR(res)[VNUM(len)] = 0;
  702.     }
  703.     return(res);
  704. }
  705.  
  706. static INLINE int
  707. extendconcat(u_char **buf, int *bufLen, int i, int addLen)
  708. {
  709.     u_char *newbuf;
  710.     int newbuflen;
  711.     if((i + addLen) < *bufLen)
  712.     return(TRUE);
  713.     newbuflen = *bufLen * 2;
  714.     newbuf = mystralloc(newbuflen);
  715.     if(newbuf)
  716.     {
  717.     memcpy(newbuf, *buf, i);
  718.     mystrfree(*buf);
  719.     *buf = newbuf;
  720.     *bufLen = newbuflen;
  721.     return(TRUE);
  722.     }
  723.     return(FALSE);
  724. }
  725. _PR VALUE cmd_concat(VALUE);
  726. DEFUN("concat", cmd_concat, subr_concat, (VALUE args), V_SubrN, DOC_concat) /*
  727. ::doc:concat::
  728. (concat ARGS...)
  729. Concatenates all ARGS... into a single string, each argument can be a string,
  730. a character or a list or vector of characters.
  731. ::end:: */
  732. {
  733.     int buflen = 128;
  734.     u_char *buf = mystralloc(buflen);
  735.     if(buf)
  736.     {
  737.     VALUE res = NULL;
  738.     int i = 0;
  739.     while(CONSP(args))
  740.     {
  741.         VALUE arg = VCAR(args);
  742.         switch(VTYPE(arg))
  743.         {
  744.         int slen, j;
  745.         case V_StaticString:
  746.         case V_String:
  747.         slen = strlen(VSTR(arg));
  748.         if(!extendconcat(&buf, &buflen, i, slen))
  749.             goto error;
  750.         memcpy(buf + i, VSTR(arg), slen);
  751.         i += slen;
  752.         break;
  753.         case V_Char:
  754.         if(!extendconcat(&buf, &buflen, i, 1))
  755.             goto error;
  756.         buf[i++] = VCHAR(arg);
  757.         break;
  758.         case V_Symbol:
  759.         if(arg != sym_nil)
  760.             break;
  761.         /* FALL THROUGH */
  762.         case V_Cons:
  763.         while(CONSP(arg))
  764.         {
  765.             VALUE ch = VCAR(arg);
  766.             if(VTYPEP(ch, V_Char))
  767.             {
  768.             if(!extendconcat(&buf, &buflen, i, 1))
  769.                 goto error;
  770.             buf[i++] = VCHAR(ch);
  771.             }
  772.             arg = VCDR(arg);
  773.         }
  774.         break;
  775.         case V_Vector:
  776.         for(j = 0; j < VVECT(arg)->vc_Size; j++)
  777.         {
  778.             if(VTYPEP(VVECT(arg)->vc_Array[j], V_Char))
  779.             {
  780.             if(!extendconcat(&buf, &buflen, i, 1))
  781.                 goto error;
  782.             buf[i++] = VCHAR(VVECT(arg)->vc_Array[j]);
  783.             }
  784.         }
  785.         break;
  786.         }
  787.         args = VCDR(args);
  788.     }
  789.     res = valstrdupn(buf, i);
  790.     if(res)
  791. error:
  792.     mystrfree(buf);
  793.     return(res);
  794.     }
  795.     return(NULL);
  796. }
  797.  
  798. _PR VALUE cmd_length(VALUE);
  799. DEFUN("length", cmd_length, subr_length, (VALUE sequence), V_Subr1, DOC_length) /*
  800. ::doc:length::
  801. (length SEQUENCE)
  802. Returns the number of elements in SEQUENCE (a string, list or vector).
  803. ::end:: */
  804. {
  805.     switch(VTYPE(sequence))
  806.     {
  807.     int i;
  808.     case V_StaticString:
  809.     case V_String:
  810.     return(newnumber(strlen(VSTR(sequence))));
  811.     break;
  812.     case V_Vector:
  813.     return(newnumber(VVECT(sequence)->vc_Size));
  814.     break;
  815.     case V_Cons:
  816.     i = 0;
  817.     while(CONSP(sequence))
  818.     {
  819.         sequence = VCDR(sequence);
  820.         i++;
  821.     }
  822.     return(newnumber(i));
  823.     break;
  824.     case V_Symbol:
  825.     if(sequence == sym_nil)
  826.         return(newnumber(0));
  827.     /* FALL THROUGH */
  828.     default:
  829.     cmd_signal(sym_bad_arg, list_2(sequence, newnumber(1)));
  830.     return(NULL);
  831.     }
  832. }
  833.  
  834. _PR VALUE cmd_prog1(VALUE);
  835. DEFUN("prog1", cmd_prog1, subr_prog1, (VALUE args), V_SF, DOC_prog1) /*
  836. ::doc:prog1::
  837. (prog1 FORM1 FORMS... ) <SPECIAL-FORM>
  838. First evals FORM1 then FORMS, returns the value that FORM1 gave.
  839. ::end:: */
  840. {
  841.     if(CONSP(args))
  842.     {
  843.     VALUE res;
  844.     GCVAL gcv_args, gcv_res;
  845.     PUSHGC(gcv_args, args);
  846.     res = cmd_eval(VCAR(args));
  847.     if(res)
  848.     {
  849.         PUSHGC(gcv_res, res);
  850.         if(!cmd_progn(VCDR(args)))
  851.         res = NULL;
  852.         POPGC;
  853.     }
  854.     POPGC;
  855.     return(res);
  856.     }
  857.     return(NULL);
  858. }
  859.  
  860. _PR VALUE cmd_prog2(VALUE);
  861. DEFUN("prog2", cmd_prog2, subr_prog2, (VALUE args), V_SF, DOC_prog2) /*
  862. ::doc:prog2::
  863. (prog2 FORM1 FORM2 FORMS...) <SPECIAL-FORM>
  864. Evals FORM1 then FORM2 then the rest. Returns whatever FORM2 gave.
  865. ::end:: */
  866. {
  867.     if(CONSP(args) && CONSP(VCDR(args)))
  868.     {
  869.     VALUE res;
  870.     GCVAL gcv_args, gcv_res;
  871.     PUSHGC(gcv_args, args);
  872.     if(cmd_eval(VCAR(args)))
  873.     {
  874.         res = cmd_eval(VCAR(VCDR(args)));
  875.         if(res)
  876.         {
  877.         PUSHGC(gcv_res, res);
  878.         if(!cmd_progn(VCDR(VCDR(args))))
  879.             res = NULL;
  880.         POPGC;
  881.         }
  882.     }
  883.     else
  884.         res = NULL;
  885.     POPGC;
  886.     return(res);
  887.     }
  888.     return(NULL);
  889. }
  890.  
  891. _PR VALUE cmd_while(VALUE);
  892. DEFUN("while", cmd_while, subr_while, (VALUE args), V_SF, DOC_while) /*
  893. ::doc:while::
  894. (while CONDITION FORMS... ) <SPECIAL-FORM>
  895. Eval CONDITION, if it is non-nil then execute FORMS and repeat the
  896. procedure, else return nil.
  897. ::end:: */
  898. {
  899.     if(CONSP(args))
  900.     {
  901.     GCVAL gcv_args;
  902.     VALUE cond = VCAR(args), wval, body = VCDR(args);
  903.     PUSHGC(gcv_args, args);
  904.     while((wval = cmd_eval(cond)) && !NILP(wval))
  905.     {
  906.         if(!cmd_progn(body))
  907.         {
  908.         wval = NULL;
  909.         break;
  910.         }
  911.     }
  912.     POPGC;
  913.     if(!wval)
  914.         return(NULL);
  915.     return(sym_nil);
  916.     }
  917.     return(NULL);
  918. }
  919.  
  920. _PR VALUE cmd_if(VALUE);
  921. DEFUN("if", cmd_if, subr_if, (VALUE args), V_SF, DOC_if) /*
  922. ::doc:if::
  923. (if CONDITION THEN-FORM [ELSE-FORMS...] ) <SPECIAL-FORM>
  924. Eval CONDITION, if it is non-nil then eval THEN-FORM and return it's 
  925. result, else do an implicit progn with the ELSE-FORMS returning its value.
  926. ::end:: */
  927. {
  928.     if(CONSP(args) && CONSP(VCDR(args)))
  929.     {
  930.     VALUE res;
  931.     GCVAL gcv_args;
  932.     PUSHGC(gcv_args, args);
  933.     res = cmd_eval(VCAR(args));
  934.     if(res)
  935.     {
  936.         if(!NILP(res))
  937.         res = cmd_eval(VCAR(VCDR(args)));
  938.         else
  939.         res = cmd_progn(VCDR(VCDR(args)));
  940.     }
  941.     POPGC;
  942.     return(res);
  943.     }
  944.     return(NULL);
  945. }
  946.  
  947. _PR VALUE cmd_when(VALUE);
  948. DEFUN("when", cmd_when, subr_when, (VALUE args), V_SF, DOC_when) /*
  949. ::doc:when::
  950. (when CONDITION FORMS... ) <SPECIAL-FORM>
  951. Evaluates CONDITION, if it is non-nil evaluates FORMS.
  952. ::end:: */
  953. {
  954.     VALUE res = sym_nil;
  955.     if(CONSP(args))
  956.     {
  957.     GCVAL gcv_args;
  958.     PUSHGC(gcv_args, args);
  959.     if((res = cmd_eval(VCAR(args))) && !NILP(res))
  960.         res = cmd_progn(VCDR(args));
  961.     POPGC;
  962.     }
  963.     return(res);
  964. }
  965.  
  966. _PR VALUE cmd_unless(VALUE);
  967. DEFUN("unless", cmd_unless, subr_unless, (VALUE args), V_SF, DOC_unless) /*
  968. ::doc:unless::
  969. (unless CONDITION FORMS... ) <SPECIAL-FORM>
  970. Evaluates CONDITION, if it is nil evaluates FORMS.
  971. ::end:: */
  972. {
  973.     VALUE res = sym_nil;
  974.     if(CONSP(args))
  975.     {
  976.     GCVAL gcv_args;
  977.     PUSHGC(gcv_args, args);
  978.     if((res = cmd_eval(VCAR(args))) && NILP(res))
  979.         res = cmd_progn(VCDR(args));
  980.     POPGC;
  981.     }
  982.     return(res);
  983. }
  984.  
  985. _PR VALUE cmd_cond(VALUE);
  986. DEFUN("cond", cmd_cond, subr_cond, (VALUE args), V_SF, DOC_cond) /*
  987. ::doc:cond::
  988. (cond (CONDITION FORMS... ) ... ) <SPECIAL-FORM>
  989. Find the first CONDITION which has a value of t when eval'ed, then perform
  990. a progn on its associated FORMS. If there are no FORMS with the CONDITION
  991. then the value of the CONDITION is returned. If no CONDITION is t then
  992. return nil.
  993. An example,
  994.   (cond
  995.     ((stringp foo)
  996.       (title "foo is a string"))
  997.     ((numberp foo)
  998.       (setq bar foo)
  999.       (title "foo is a number"))
  1000.     (t
  1001.       (title "foo is something else...")))
  1002. Note the use of plain `t' on it's own for the last CONDITION, this is
  1003. like the last else in an else-if statement in C.
  1004. ::end:: */
  1005. {
  1006.     VALUE res = sym_nil;
  1007.     GCVAL gcv_args;
  1008.     PUSHGC(gcv_args, args);
  1009.     while(CONSP(args) && CONSP(VCAR(args)))
  1010.     {
  1011.     VALUE cndlist = VCAR(args);
  1012.     if(!(res = cmd_eval(VCAR(cndlist))))
  1013.         break;
  1014.     if(!NILP(res))
  1015.     {
  1016.         if(CONSP(VCDR(cndlist)))
  1017.         {
  1018.         if(!(res = cmd_progn(VCDR(cndlist))))
  1019.             break;
  1020.         }
  1021.         break;
  1022.     }
  1023.     args = VCDR(args);
  1024.     }
  1025.     POPGC;
  1026.     return(res);
  1027. }
  1028.  
  1029. _PR VALUE cmd_apply(VALUE);
  1030. DEFUN("apply", cmd_apply, subr_apply, (VALUE args), V_SubrN, DOC_apply) /*
  1031. ::doc:apply::
  1032. (apply FUNCTION ARGS... ARG-LIST)
  1033. Calls FUNCTION passing all of ARGS to it as well as all elements in ARG-LIST.
  1034. ie,
  1035.   (apply '+ 1 2 3 '(4 5 6))
  1036.    => 21
  1037. ::end:: */
  1038. {
  1039.     VALUE list = sym_nil, *last;
  1040.     last = &list;
  1041.     if(CONSP(args))
  1042.     {
  1043.     while(CONSP(VCDR(args)))
  1044.     {
  1045.         if(!(*last = cmd_cons(VCAR(args), sym_nil)))
  1046.         return(NULL);
  1047.         last = &VCDR(*last);
  1048.         args = VCDR(args);
  1049.     }
  1050.     if(CONSP(VCAR(args)))
  1051.         *last = VCAR(args);
  1052.     return(cmd_funcall(list));
  1053.     }
  1054.     return(NULL);
  1055. }
  1056.  
  1057. _PR VALUE cmd_load(VALUE file, VALUE noerr_p, VALUE nopath_p, VALUE nosuf_p);
  1058. DEFUN("load", cmd_load, subr_load, (VALUE file, VALUE noerr_p, VALUE nopath_p, VALUE nosuf_p), V_Subr4, DOC_load) /*
  1059. ::doc:load::
  1060. (load FILE [NO-ERROR-P] [NO-PATH-P] [NO-SUFFIX-P])
  1061. Attempt to open and then read-and-eval the file of Lisp code FILE.
  1062.  
  1063. For each directory named in the variable `load-path' tries the value of
  1064. FILE with `.jlc' (compiled-lisp) appended to it, then with `.jl' appended
  1065. to it, finally tries FILE without modification.
  1066.  
  1067. If NO-ERROR-P is non-nil no error is signalled if FILE can't be found.
  1068. If NO-PATH-P is non-nil the `load-path' variable is not used, just the value
  1069. of FILE.
  1070. If NO-SUFFIX-P is non-nil no suffixes are appended to FILE.
  1071.  
  1072. If the compiled version is older than it's source code, the source code is
  1073. loaded and a warning is displayed.
  1074. ::end:: */
  1075. {
  1076.     VALUE name = NULL, stream, path;
  1077.     DECLARE1(file, STRINGP);
  1078.     if(NILP(nopath_p))
  1079.     {
  1080.     if(!(path = cmd_symbol_value(sym_load_path)) || !CONSP(path))
  1081.         return(cmd_signal(sym_void_value, LIST_1(sym_load_path)));
  1082.     }
  1083.     else
  1084.     path = cmd_cons(MKSTR(""), sym_nil);
  1085.     while(!name && CONSP(path))
  1086.     {
  1087.     u_char *dir = STRINGP(VCAR(path)) ? VSTR(VCAR(path)) : (u_char *)"";
  1088.     if(NILP(nosuf_p))
  1089.     {
  1090.         bool jl_p = fileexists3(dir, VSTR(file), ".jl");
  1091.         if(fileexists3(dir, VSTR(file), ".jlc"))
  1092.         {
  1093.         name = concat3(dir, VSTR(file), ".jlc");
  1094.         if(jl_p)
  1095.         {
  1096.             VALUE tmp = concat3(dir, VSTR(file), ".jl");
  1097.             if(filemodtime(VSTR(tmp)) > filemodtime(VSTR(name)))
  1098.             {
  1099.             settitlefmt("Warning: %s newer than %s, using .jl",
  1100.                      VSTR(tmp), VSTR(name));
  1101.             name = tmp;
  1102.             }
  1103.         }
  1104.         }
  1105.         else if(jl_p)
  1106.         name = concat3(dir, VSTR(file), ".jl");
  1107.     }
  1108.     if(!name && fileexists2(dir, VSTR(file)))
  1109.         name = concat2(dir, VSTR(file));
  1110.     path = VCDR(path);
  1111.     }
  1112.     if(!name)
  1113.     {
  1114.     if(NILP(noerr_p))
  1115.         return(cmd_signal(sym_file_error,
  1116.                   list_2(MKSTR("Can't open lisp-file"), file)));
  1117.     else
  1118.         return(sym_nil);
  1119.     }
  1120.     if((stream = cmd_open(name, MKSTR("r"), sym_nil)) && FILEP(stream))
  1121.     {
  1122.     VALUE obj;
  1123.     int c;
  1124.     GCVAL gcv_stream;
  1125.     PUSHGC(gcv_stream, stream);
  1126.     c = streamgetc(stream);
  1127.     while((c != EOF) && (obj = readlispexp(stream, &c)))
  1128.     {
  1129.         if(!cmd_eval(obj))
  1130.         {
  1131.         POPGC;
  1132.         return(NULL);
  1133.         }
  1134.     }
  1135.     POPGC;
  1136.     return(sym_t);
  1137.     }
  1138.     return(NULL);
  1139. }
  1140.  
  1141. /*
  1142.  * some arithmetic commands
  1143.  */
  1144.  
  1145. #define APPLY_OP( op ) \
  1146.     if(CONSP(args) && NUMBERP(VCAR(args))) \
  1147.     { \
  1148.     long sum = VNUM(VCAR(args)); \
  1149.     args = VCDR(args); \
  1150.     while(CONSP(args) && NUMBERP(VCAR(args))) \
  1151.     { \
  1152.         sum = sum op VNUM(VCAR(args)); \
  1153.         args = VCDR(args); \
  1154.     } \
  1155.     return(newnumber(sum)); \
  1156.     } \
  1157.     return(NULL);
  1158.  
  1159. _PR VALUE cmd_plus(VALUE);
  1160. DEFUN("+", cmd_plus, subr_plus, (VALUE args), V_SubrN, DOC_plus) /*
  1161. ::doc:plus::
  1162. (+ NUMBERS...)
  1163. Adds all NUMBERS together.
  1164. ::end:: */
  1165. {
  1166.     APPLY_OP( + )
  1167. }
  1168.  
  1169. _PR VALUE cmd_minus(VALUE);
  1170. DEFUN("-", cmd_minus, subr_minus, (VALUE args), V_SubrN, DOC_minus) /*
  1171. ::doc:minus::
  1172. (- NUMBER [NUMBERS...])
  1173. Either returns the negation of NUMBER or the value of NUMBER minus
  1174. NUMBERS
  1175. ::end:: */
  1176. {
  1177.     if(CONSP(args))
  1178.     {
  1179.     if(!CONSP(VCDR(args)))
  1180.         return(newnumber(-VNUM(VCAR(args))));
  1181.     else
  1182.         APPLY_OP( - )
  1183.     }
  1184.     return(NULL);
  1185. }
  1186.  
  1187. _PR VALUE cmd_product(VALUE);
  1188. DEFUN("*", cmd_product, subr_product, (VALUE args), V_SubrN, DOC_product) /*
  1189. ::doc:product::
  1190. (* NUMBERS...)
  1191. Multiplies all NUMBERS together
  1192. ::end:: */
  1193. {
  1194.     APPLY_OP( * )
  1195. }
  1196.  
  1197. _PR VALUE cmd_divide(VALUE);
  1198. DEFUN("/", cmd_divide, subr_divide, (VALUE args), V_SubrN, DOC_divide) /*
  1199. ::doc:divide::
  1200. (/ NUMBERS...)
  1201. Divides NUMBERS (in left-to-right order), ie,
  1202.   (/ 100 2
  1203.    => 10
  1204. ::end:: */
  1205. {
  1206.     APPLY_OP( / )
  1207. }
  1208.  
  1209. _PR VALUE cmd_mod(VALUE);
  1210. DEFUN("mod", cmd_mod, subr_mod, (VALUE args), V_SubrN, DOC_mod) /*
  1211. ::doc:mod::
  1212. (mod NUMBERS...)
  1213. Applies the modulus operator between each of NUMBERS.
  1214. ::end:: */
  1215. {
  1216.     APPLY_OP( % )
  1217. }
  1218.  
  1219. _PR VALUE cmd_bit_not(VALUE);
  1220. DEFUN("bit-not", cmd_bit_not, subr_bit_not, (VALUE num), V_Subr1, DOC_bit_not) /*
  1221. ::doc:bit_not::
  1222. (bit-not NUMBER)
  1223. Returns the bitwise not of NUMBER.
  1224. ::end:: */
  1225. {
  1226.     DECLARE1(num, NUMBERP);
  1227.     return(newnumber(~VNUM(num)));
  1228. }
  1229.  
  1230. _PR VALUE cmd_not(VALUE);
  1231. DEFUN("not", cmd_not, subr_not, (VALUE arg), V_Subr1, DOC_not) /*
  1232. ::doc:not::
  1233. (not ARG)
  1234. If ARG is nil returns t, else returns nil.
  1235. ::end:: */
  1236. {
  1237.     if(NILP(arg))
  1238.     return(sym_t);
  1239.     return(sym_nil);
  1240. }
  1241.  
  1242. _PR VALUE cmd_bit_or(VALUE);
  1243. DEFUN("bit-or", cmd_bit_or, subr_bit_or, (VALUE args), V_SubrN, DOC_bit_or) /*
  1244. ::doc:bit_or::
  1245. (bit-or NUMBERS...)
  1246. Bitwise ORs all NUMBERS together.
  1247. ::end:: */
  1248. {
  1249.     APPLY_OP( | )
  1250. }
  1251.  
  1252. _PR VALUE cmd_or(VALUE);
  1253. DEFUN("or", cmd_or, subr_or, (VALUE args), V_SF, DOC_or) /*
  1254. ::doc:or::
  1255. (or FORMS...) <SPECIAL-FORM>
  1256. Evals each FORM while they return nil, returns the first non-nil result or
  1257. nil if all FORMS return nil.
  1258. ::end:: */
  1259. {
  1260.     VALUE res = sym_nil;
  1261.     GCVAL gcv_args, gcv_res;
  1262.     PUSHGC(gcv_args, args);
  1263.     PUSHGC(gcv_res, res);
  1264.     while(res && CONSP(args) && NILP(res))
  1265.     {
  1266.     res = cmd_eval(VCAR(args));
  1267.     args = VCDR(args);
  1268.     }
  1269.     POPGC;
  1270.     POPGC;
  1271.     return(res);
  1272. }
  1273.  
  1274. _PR VALUE cmd_bit_and(VALUE);
  1275. DEFUN("bit-and", cmd_bit_and, subr_bit_and, (VALUE args), V_SubrN, DOC_bit_and) /*
  1276. ::doc:bit_and::
  1277. (bit-and NUMBERS...)
  1278. Bitwise AND all NUMBERS together.
  1279. ::end:: */
  1280. {
  1281.     APPLY_OP( & )
  1282. }
  1283.  
  1284. _PR VALUE cmd_and(VALUE);
  1285. DEFUN("and", cmd_and, subr_and, (VALUE args), V_SF, DOC_and) /*
  1286. ::doc:and::
  1287. (and FORMS... ) <SPECIAL-FORM>
  1288. Evals each FORM until one returns nil, it returns that value, or t if all
  1289. FORMS return t.
  1290. ::end:: */
  1291. {
  1292.     VALUE res = sym_t;
  1293.     GCVAL gcv_args, gcv_res;
  1294.     PUSHGC(gcv_args, args);
  1295.     PUSHGC(gcv_res, res);
  1296.     while(res && CONSP(args) && !NILP(res))
  1297.     {
  1298.     res = cmd_eval(VCAR(args));
  1299.     args = VCDR(args);
  1300.     }
  1301.     POPGC;
  1302.     POPGC;
  1303.     return(res);
  1304. }
  1305.  
  1306. _PR VALUE cmd_equal(VALUE, VALUE);
  1307. DEFUN("equal", cmd_equal, subr_equal, (VALUE val1, VALUE val2), V_Subr2, DOC_equal) /*
  1308. ::doc:equal::
  1309. (equal VALUE1 VALUE2)
  1310. Compares VALUE1 and VALUE2, compares the actual structure of the objects not
  1311. just whether the objects are one and the same. ie, will return t for two
  1312. strings built from the same characters in the same order even if the strings'
  1313. location in memory is different.
  1314. ::end:: */
  1315. {
  1316.     if(valuecmp(val1, val2))
  1317.     return(sym_nil);
  1318.     return(sym_t);
  1319. }
  1320.  
  1321. _PR VALUE cmd_eq(VALUE, VALUE);
  1322. DEFUN("eq", cmd_eq, subr_eq, (VALUE val1, VALUE val2), V_Subr2, DOC_eq) /*
  1323. ::doc:eq::
  1324. (eq VALUE1 VALUE2)
  1325. Returns t if VALUE1 and VALUE2 are one and the same object. Note that
  1326.   (eq 1 1)
  1327.    => nil
  1328. ::end:: */
  1329. {
  1330.     if(val1 == val2)
  1331.     return(sym_t);
  1332.     return(sym_nil);
  1333. }
  1334.  
  1335. _PR VALUE cmd_string_head_eq(VALUE, VALUE);
  1336. DEFUN("string-head-eq", cmd_string_head_eq, subr_string_head_eq, (VALUE str1, VALUE str2), V_Subr2, DOC_string_head_eq) /*
  1337. ::doc:string_head_eq::
  1338. (string-head-eq STRING1 STRING2)
  1339. Returns t if STRING2 matches the beginning of STRING1, ie,
  1340.   (string-head-eq "foobar" "foo")
  1341.    => t
  1342.   (string-head-eq "foo" "foobar")
  1343.    => nil
  1344. ::end:: */
  1345. {
  1346.     u_char *s1, *s2;
  1347.     DECLARE1(str1, STRINGP);
  1348.     DECLARE2(str2, STRINGP);
  1349.     s1 = VSTR(str1);
  1350.     s2 = VSTR(str2);
  1351.     while(*s1 && *s2)
  1352.     {
  1353.     if(*s1++ != *s2++)
  1354.         return(sym_nil);
  1355.     }
  1356.     if(*s1 || (*s1 == *s2))
  1357.     return(sym_t);
  1358.     return(sym_nil);
  1359. }
  1360.  
  1361. _PR VALUE cmd_num_eq(VALUE num1, VALUE num2);
  1362. DEFUN("=", cmd_num_eq, subr_num_eq, (VALUE num1, VALUE num2), V_Subr2, DOC_num_eq) /*
  1363. ::doc:num_eq::
  1364. (= NUMBER1 NUMBER2)
  1365. Returns t if NUMBER1 and NUMBER2 are equal.
  1366. ::end:: */
  1367. {
  1368.     DECLARE1(num1, NUMBERP);
  1369.     DECLARE2(num2, NUMBERP);
  1370.     if(VNUM(num1) == VNUM(num2))
  1371.     return(sym_t);
  1372.     return(sym_nil);
  1373. }
  1374.  
  1375. _PR VALUE cmd_num_noteq(VALUE num1, VALUE num2);
  1376. DEFUN("/=", cmd_num_noteq, subr_num_noteq, (VALUE num1, VALUE num2), V_Subr2, DOC_num_noteq) /*
  1377. ::doc:num_noteq::
  1378. (/= NUMBER1 NUMBER2)
  1379. Returns t if NUMBER1 and NUMBER2 are unequal.
  1380. ::end:: */
  1381. {
  1382.     DECLARE1(num1, NUMBERP);
  1383.     DECLARE2(num2, NUMBERP);
  1384.     if(VNUM(num1) != VNUM(num2))
  1385.     return(sym_t);
  1386.     return(sym_nil);
  1387. }
  1388.  
  1389. _PR VALUE cmd_gtthan(VALUE, VALUE);
  1390. DEFUN(">", cmd_gtthan, subr_gtthan, (VALUE arg1, VALUE arg2), V_Subr2, DOC_gtthan) /*
  1391. ::doc:gtthan::
  1392. (> ARG1 ARG2)
  1393. Returns t if ARG1 is greater than ARG2. Note that this command isn't
  1394. limited to numbers, it can do strings, positions, marks, etc as well.
  1395. ::end:: */
  1396. {
  1397.     if(valuecmp(arg1, arg2) > 0)
  1398.     return(sym_t);
  1399.     return(sym_nil);
  1400. }
  1401.  
  1402. _PR VALUE cmd_gethan(VALUE, VALUE);
  1403. DEFUN(">=", cmd_gethan, subr_gethan, (VALUE arg1, VALUE arg2), V_Subr2, DOC_gethan) /*
  1404. ::doc:gethan::
  1405. (>= ARG1 ARG2)
  1406. Returns t if ARG1 is greater-or-equal than ARG2. Note that this command
  1407. isn't limited to numbers, it can do strings, positions, marks, etc as well.
  1408. ::end:: */
  1409. {
  1410.     if(valuecmp(arg1, arg2) >= 0)
  1411.     return(sym_t);
  1412.     return(sym_nil);
  1413. }
  1414.  
  1415. _PR VALUE cmd_ltthan(VALUE, VALUE);
  1416. DEFUN("<", cmd_ltthan, subr_ltthan, (VALUE arg1, VALUE arg2), V_Subr2, DOC_ltthan) /*
  1417. ::doc:ltthan::
  1418. (< ARG1 ARG2)
  1419. Returns t if ARG1 is less than ARG2. Note that this command isn't limited to
  1420. numbers, it can do strings, positions, marks, etc as well.
  1421. ::end:: */
  1422. {
  1423.     if(valuecmp(arg1, arg2) < 0)
  1424.     return(sym_t);
  1425.     return(sym_nil);
  1426. }
  1427.  
  1428. _PR VALUE cmd_lethan(VALUE, VALUE);
  1429. DEFUN("<=", cmd_lethan, subr_lethan, (VALUE arg1, VALUE arg2), V_Subr2, DOC_lethan) /*
  1430. ::doc:lethan::
  1431. (<= ARG1 ARG2)
  1432. Returns t if ARG1 is less-or-equal than ARG2. Note that this command isn't
  1433. limited to numbers, it can do strings, positions, marks, etc as well.
  1434. ::end:: */
  1435. {
  1436.     if(valuecmp(arg1, arg2) <= 0)
  1437.     return(sym_t);
  1438.     return(sym_nil);
  1439. }
  1440.  
  1441. _PR VALUE cmd_plus1(VALUE);
  1442. DEFUN("1+", cmd_plus1, subr_plus1, (VALUE num), V_Subr1, DOC_plus1) /*
  1443. ::doc:plus1::
  1444. (1+ NUMBER)
  1445. Return NUMBER plus 1.
  1446. ::end:: */
  1447. {
  1448.     DECLARE1(num, NUMBERP);
  1449.     return(newnumber(VNUM(num) + 1));
  1450. }
  1451.  
  1452. _PR VALUE cmd_sub1(VALUE);
  1453. DEFUN("1-", cmd_sub1, subr_sub1, (VALUE num), V_Subr1, DOC_sub1) /*
  1454. ::doc:sub1::
  1455. (1- NUMBER)
  1456. Return NUMBER minus 1.
  1457. ::end:: */
  1458. {
  1459.     DECLARE1(num, NUMBERP);
  1460.     return(newnumber(VNUM(num) - 1));
  1461. }
  1462.  
  1463. _PR VALUE cmd_lsh(VALUE, VALUE);
  1464. DEFUN("lsh", cmd_lsh, subr_lsh, (VALUE num, VALUE shift), V_Subr2, DOC_lsh) /*
  1465. ::doc:lsh::
  1466. (lsh NUMBER COUNT)
  1467. Shift the bits in NUMBER by COUNT bits to the left, a negative COUNT means
  1468. shift right.
  1469. ::end:: */
  1470. {
  1471.     DECLARE1(num, NUMBERP);
  1472.     DECLARE2(shift, NUMBERP);
  1473.     if(VNUM(shift) > 0)
  1474.     return(newnumber(VNUM(num) << VNUM(shift)));
  1475.     return(newnumber(VNUM(num) >> -VNUM(shift)));
  1476. }
  1477.  
  1478. _PR VALUE cmd_zerop(VALUE);
  1479. DEFUN("zerop", cmd_zerop, subr_zerop, (VALUE num), V_Subr1, DOC_zerop) /*
  1480. ::doc:zerop::
  1481. (zerop NUMBER)
  1482. t if NUMBER is zero.
  1483. ::end:: */
  1484. {
  1485.     if(NUMBERP(num) && (VNUM(num) == 0))
  1486.     return(sym_t);
  1487.     return(sym_nil);
  1488. }
  1489.  
  1490. _PR VALUE cmd_null(VALUE);
  1491. DEFUN("null", cmd_null, subr_null, (VALUE arg), V_Subr1, DOC_null) /*
  1492. ::doc:null::
  1493. (null ARG)
  1494. Returns t if ARG is nil.
  1495. ::end:: */
  1496. {
  1497.     if(NILP(arg))
  1498.     return(sym_t);
  1499.     return(sym_nil);
  1500. }
  1501.  
  1502. _PR VALUE cmd_atom(VALUE);
  1503. DEFUN("atom", cmd_atom, subr_atom, (VALUE arg), V_Subr1, DOC_atom) /*
  1504. ::doc:atom::
  1505. (atom ARG)
  1506. Returns t if ARG is not a cons-cell.
  1507. ::end:: */
  1508. {
  1509.     if(!CONSP(arg))
  1510.     return(sym_t);
  1511.     return(sym_nil);
  1512. }
  1513.  
  1514. _PR VALUE cmd_consp(VALUE);
  1515. DEFUN("consp", cmd_consp, subr_consp, (VALUE arg), V_Subr1, DOC_consp) /*
  1516. ::doc:consp::
  1517. (consp ARG)
  1518. Returns t if ARG is a cons-cell.
  1519. ::end:: */
  1520. {
  1521.     if(CONSP(arg))
  1522.     return(sym_t);
  1523.     return(sym_nil);
  1524. }
  1525.  
  1526. _PR VALUE cmd_listp(VALUE);
  1527. DEFUN("listp", cmd_listp, subr_listp, (VALUE arg), V_Subr1, DOC_listp) /*
  1528. ::doc:listp::
  1529. (listp ARG)
  1530. Returns t if ARG is a list, (either a cons-cell or nil).
  1531. ::end:: */
  1532. {
  1533.     if(NILP(arg) || CONSP(arg))
  1534.     return(sym_t);
  1535.     return(sym_nil);
  1536. }
  1537.  
  1538. _PR VALUE cmd_numberp(VALUE);
  1539. DEFUN("numberp", cmd_numberp, subr_numberp, (VALUE arg), V_Subr1, DOC_numberp) /*
  1540. ::doc:numberp::
  1541. (numberp ARG)
  1542. Return t if ARG is a number.
  1543. ::end:: */
  1544. {
  1545.     if(NUMBERP(arg))
  1546.     return(sym_t);
  1547.     return(sym_nil);
  1548. }
  1549.  
  1550. _PR VALUE cmd_stringp(VALUE);
  1551. DEFUN("stringp", cmd_stringp, subr_stringp, (VALUE arg), V_Subr1, DOC_stringp) /*
  1552. ::doc:stringp::
  1553. (stringp ARG)
  1554. Returns t is ARG is a string.
  1555. ::end:: */
  1556. {
  1557.     if(STRINGP(arg))
  1558.     return(sym_t);
  1559.     return(sym_nil);
  1560. }
  1561.  
  1562. _PR VALUE cmd_vectorp(VALUE);
  1563. DEFUN("vectorp", cmd_vectorp, subr_vectorp, (VALUE arg), V_Subr1, DOC_vectorp) /*
  1564. ::doc:vectorp::
  1565. (vectorp ARG)
  1566. Returns t if ARG is a vector.
  1567. ::end:: */
  1568. {
  1569.     if(VECTORP(arg))
  1570.     return(sym_t);
  1571.     return(sym_nil);
  1572. }
  1573.  
  1574. _PR VALUE cmd_functionp(VALUE);
  1575. DEFUN("functionp", cmd_functionp, subr_functionp, (VALUE arg), V_Subr1, DOC_functionp) /*
  1576. ::doc:functionp::
  1577. (functionp ARG)
  1578. Returns t if ARG is a function (ie, a symbol or a list whose car is the
  1579. symbol `lambda'
  1580. ::end:: */
  1581. {
  1582.     if(SYMBOLP(arg))
  1583.     {
  1584.     if(!(arg = VSYM(arg)->sym_Function))
  1585.         return(sym_nil);
  1586.     }
  1587.     switch(VTYPE(arg))
  1588.     {
  1589.     case V_Subr0:
  1590.     case V_Subr1:
  1591.     case V_Subr2:
  1592.     case V_Subr3:
  1593.     case V_Subr4:
  1594.     case V_Subr5:
  1595.     case V_SubrN:
  1596.     return(sym_t);
  1597.     case V_Cons:
  1598.     arg = VCAR(arg);
  1599.     if((arg == sym_lambda) || (arg == sym_autoload))
  1600.         return(sym_t);
  1601.     /* FALL THROUGH */
  1602.     default:
  1603.     return(sym_nil);
  1604.     }
  1605. }
  1606.  
  1607. _PR VALUE cmd_special_form_p(VALUE);
  1608. DEFUN("special-form-p", cmd_special_form_p, subr_special_form_p, (VALUE arg), V_Subr1, DOC_special_form_p) /*
  1609. ::doc:special_form_p::
  1610. (special-form-p ARG)
  1611. Returns t if ARG is a special-form.
  1612. ::end:: */
  1613. {
  1614.     if(SYMBOLP(arg))
  1615.     {
  1616.     if(!(arg = VSYM(arg)->sym_Function))
  1617.          return(sym_nil);
  1618.     }
  1619.     if(VTYPEP(arg, V_SF))
  1620.     return(sym_t);
  1621.     return(sym_nil);
  1622. }
  1623.  
  1624. _PR VALUE cmd_keymapp(VALUE);
  1625. DEFUN("keymapp", cmd_keymapp, subr_keymapp, (VALUE arg), V_Subr1, DOC_keymapp) /*
  1626. ::doc:keymapp::
  1627. (keymapp ARG)
  1628. Returns t if ARG is a keytab or a keylist.
  1629. ::end:: */
  1630. {
  1631.     if(VTYPEP(arg, V_Keytab) || VTYPEP(arg, V_Keylist))
  1632.     return(sym_t);
  1633.     return(sym_nil);
  1634. }
  1635.  
  1636. _PR VALUE cmd_subr_p(VALUE arg);
  1637. DEFUN("subr-p", cmd_subr_p, subr_subr_p, (VALUE arg), V_Subr1, DOC_subr_p) /*
  1638. ::doc:subr_p::
  1639. (subr-p ARG)
  1640. Returns t if arg is a primitive function.
  1641. ::end:: */
  1642. {
  1643.     switch(VTYPE(arg))
  1644.     {
  1645.     case V_Subr0:
  1646.     case V_Subr1:
  1647.     case V_Subr2:
  1648.     case V_Subr3:
  1649.     case V_Subr4:
  1650.     case V_Subr5:
  1651.     case V_SubrN:
  1652.     case V_SF:
  1653.     case V_Var:
  1654.     return(sym_t);
  1655.     default:
  1656.     return(sym_nil);
  1657.     }
  1658. }
  1659.  
  1660. _PR VALUE cmd_subr_documentation(VALUE subr, VALUE useVar);
  1661. DEFUN("subr-documentation", cmd_subr_documentation, subr_subr_documentation, (VALUE subr, VALUE useVar), V_Subr2, DOC_subr_documentation) /*
  1662. ::doc:subr_documentation::
  1663. (subr-documentation SUBR [USE-VAR])
  1664. Returns the doc-string associated with SUBR.
  1665. ::end:: */
  1666. {
  1667.     if(SYMBOLP(subr))
  1668.     {
  1669.     if(NILP(useVar))
  1670.     {
  1671.         if(VSYM(subr)->sym_Function)
  1672.         subr = VSYM(subr)->sym_Function;
  1673.     }
  1674.     else
  1675.     {
  1676.         if(VSYM(subr)->sym_Value)
  1677.         subr = VSYM(subr)->sym_Value;
  1678.     }
  1679.     }
  1680.     switch(VTYPE(subr))
  1681.     {
  1682.     case V_Subr0:
  1683.     case V_Subr1:
  1684.     case V_Subr2:
  1685.     case V_Subr3:
  1686.     case V_Subr4:
  1687.     case V_Subr5:
  1688.     case V_SubrN:
  1689.     case V_SF:
  1690.     case V_Var:
  1691.     return(cmd_read_file_from_to(MKSTR(DOC_FILE),
  1692.                      newnumber(VSUBR(subr)->subr_DocIndex),
  1693.                      newnumber((int)'\f')));
  1694.     default:
  1695.     return(sym_nil);
  1696.     }
  1697. }
  1698.  
  1699. _PR VALUE cmd_subr_name(VALUE subr, VALUE useVar);
  1700. DEFUN("subr-name", cmd_subr_name, subr_subr_name, (VALUE subr, VALUE useVar), V_Subr2, DOC_subr_name) /*
  1701. ::doc:subr_name::
  1702. (subr-name SUBR [USE-VAR])
  1703. Returns the name (a string) associated with SUBR.
  1704. ::end:: */
  1705. {
  1706.     if(SYMBOLP(subr))
  1707.     {
  1708.     if(NILP(useVar))
  1709.     {
  1710.         if(VSYM(subr)->sym_Function)
  1711.         subr = VSYM(subr)->sym_Function;
  1712.     }
  1713.     else
  1714.     {
  1715.         if(VSYM(subr)->sym_Value)
  1716.         subr = VSYM(subr)->sym_Value;
  1717.     }
  1718.     }
  1719.     switch(VTYPE(subr))
  1720.     {
  1721.     case V_Subr0:
  1722.     case V_Subr1:
  1723.     case V_Subr2:
  1724.     case V_Subr3:
  1725.     case V_Subr4:
  1726.     case V_Subr5:
  1727.     case V_SubrN:
  1728.     case V_SF:
  1729.     case V_Var:
  1730.     return(VSUBR(subr)->subr_Name);
  1731.     default:
  1732.     return(sym_nil);
  1733.     }
  1734. }
  1735.  
  1736. _PR VALUE cmd_eval_hook(VALUE);
  1737. DEFUN("eval-hook", cmd_eval_hook, subr_eval_hook, (VALUE args), V_SubrN, DOC_eval_hook) /*
  1738. ::doc:eval_hook::
  1739. (eval-hook HOOK ARGS...)
  1740. Evaluate the hook, HOOK (a symbol), with arguments ARGS
  1741.  
  1742. The way hooks work is that the hook-symbol's value is a list of functions
  1743. to call. Each function in turn is called with ARGS until one returns non-nil,
  1744. this non-nil value is then the result of `eval-hook'. If all functions return
  1745. nil then `eval-hook' returns nil.
  1746. ::end:: */
  1747. {
  1748.     if(CONSP(args))
  1749.     {
  1750.     VALUE hook = VCAR(args);
  1751.     VALUE alist = VCDR(args);
  1752.     VALUE res = sym_nil;
  1753.     GCVAL gcv_alist, gcv_hook;
  1754.     PUSHGC(gcv_alist, alist);
  1755.     switch(VTYPE(hook))
  1756.     {
  1757.     case V_StaticString:
  1758.     case V_String:
  1759.         if(!(hook = cmd_find_symbol(hook, sym_nil)))
  1760.         goto end;
  1761.         /* FALL THROUGH */
  1762.     case V_Symbol:
  1763.         if(!(hook = cmd_symbol_value(hook)))
  1764.         goto end;
  1765.         break;
  1766.     }
  1767.     PUSHGC(gcv_hook, hook);
  1768.     while(res && NILP(res) && CONSP(hook))
  1769.     {
  1770.         res = funcall(VCAR(hook), alist);
  1771.         hook = VCDR(hook);
  1772.     }
  1773.     POPGC;
  1774. end:
  1775.     POPGC;
  1776.     return(res);
  1777.     }
  1778.     return(NULL);
  1779. }
  1780. _PR VALUE cmd_eval_hook2(VALUE hook, VALUE arg);
  1781. DEFUN("eval-hook2", cmd_eval_hook2, subr_eval_hook2, (VALUE hook, VALUE arg), V_Subr2, DOC_eval_hook2) /*
  1782. ::doc:eval_hook2::
  1783. (eval-hook2 HOOK ARG)
  1784. Similar to `eval-hook', the only reason this function exists is because it
  1785. is easier to call a 2-argument function from C than an N-argument function.
  1786. ::end:: */
  1787. {
  1788.     VALUE res = sym_nil, alist;
  1789.     /* Not possible to use GCVAL's since this is often called from C code
  1790.        which may not be protected.  */
  1791.     int oldgci = GCinhibit;
  1792.     if(!(alist = cmd_cons(arg, sym_nil)))
  1793.     return(NULL);
  1794.     GCinhibit = TRUE;
  1795.     switch(VTYPE(hook))
  1796.     {
  1797.     case V_StaticString:
  1798.     case V_String:
  1799.     if(!(hook = cmd_find_symbol(hook, sym_nil)))
  1800.         goto end;
  1801.     /* FALL THROUGH */
  1802.     case V_Symbol:
  1803.     if(!(hook = cmd_symbol_value(hook)))
  1804.         goto end;
  1805.     break;
  1806.     }
  1807.     while(res && NILP(res) && CONSP(hook))
  1808.     {
  1809.     res = funcall(VCAR(hook), alist);
  1810.     hook = VCDR(hook);
  1811.     }
  1812. end:
  1813.     GCinhibit = oldgci;
  1814.     return(res);
  1815. }
  1816.  
  1817. _PR VALUE cmd_catch(VALUE);
  1818. DEFUN("catch", cmd_catch, subr_catch, (VALUE args), V_SF, DOC_catch) /*
  1819. ::doc:catch::
  1820. (catch TAG FORMS...) <SPECIAL-FORM>
  1821. Evaluates FORMS, non-local exits are allowed with `(throw TAG)'.
  1822. The value of `catch' is either the value of the last FORM or the
  1823. value given to the throw command.
  1824.  
  1825. There are several pre-defined `catch'es which are,
  1826.   'defun
  1827.      Around all defuns, the `return' command uses this, it basically does
  1828.      (throw 'defun X).
  1829.   'exit
  1830.      Exits one level of recursive-editing (but doesn't work in the top
  1831.      level.
  1832.   'top-level
  1833.      At the top-level recursive-edit (ie, the one which you're in when
  1834.      the editor is started).
  1835.   'quit
  1836.      Kills the editor.
  1837. ::end:: */
  1838.     /* Non-local exits don't bother with jmp_buf's and the like, they just
  1839.        unwind normally through all levels of recursion with a NULL result.
  1840.        This is slow but it's easy to work with.  */
  1841. {
  1842.     if(CONSP(args))
  1843.     {
  1844.     VALUE tag, res = NULL;
  1845.     GCVAL gcv_args, gcv_tag;
  1846.     PUSHGC(gcv_args, args);
  1847.     tag = cmd_eval(VCAR(args));
  1848.     if(tag)
  1849.     {
  1850.         PUSHGC(gcv_tag, tag);
  1851.         if(!(res = cmd_progn(VCDR(args))))
  1852.         {
  1853.         if(ThrowValue && (VCAR(ThrowValue) == tag))
  1854.         {
  1855.             res = VCDR(ThrowValue);
  1856.             ThrowValue = NULL;
  1857.         }
  1858.         }
  1859.         POPGC;
  1860.     }
  1861.     POPGC;
  1862.     return(res);
  1863.     }
  1864.     return(NULL);
  1865. }
  1866.  
  1867. _PR VALUE cmd_throw(VALUE, VALUE);
  1868. DEFUN("throw", cmd_throw, subr_throw, (VALUE tag, VALUE val), V_Subr2, DOC_throw) /*
  1869. ::doc:throw::
  1870. (throw TAG VALUE)
  1871. Performs a non-local exit to the `catch' waiting for TAG and return
  1872. VALUE from it. TAG and VALUE are both evaluated fully.
  1873. ::end:: */
  1874. {
  1875.     /* Only one thing can use `ThrowValue' at once.  */
  1876.     if(!ThrowValue)
  1877.     ThrowValue = cmd_cons(tag, val);
  1878.     return(NULL);
  1879. }
  1880.  
  1881. _PR VALUE cmd_return(VALUE);
  1882. DEFUN("return", cmd_return, subr_return, (VALUE arg), V_Subr1, DOC_return) /*
  1883. ::doc:return::
  1884. (return VALUE)
  1885. Arranges it so that the innermost defun returns VALUE as its result, this
  1886. is achieved by doing what amounts to `(throw 'defun VALUE)'.
  1887. ::end:: */
  1888. {
  1889.     if(!ThrowValue)
  1890.     ThrowValue = cmd_cons(sym_defun, arg);
  1891.     return(NULL);
  1892. }
  1893.  
  1894. _PR VALUE cmd_unwind_protect(VALUE);
  1895. DEFUN("unwind-protect", cmd_unwind_protect, subr_unwind_protect, (VALUE args), V_SF, DOC_unwind_protect) /*
  1896. ::doc:unwind_protect::
  1897. (unwind-protect BODY CLEANUP-FORMS...) <SPECIAL-FORM>
  1898. Eval and return the value of BODY guaranteeing that the CLEANUP-FORMS will
  1899. be evalled no matter what happens (ie, error, non-local exit, etc) while
  1900. BODY is being evaluated.
  1901. ::end:: */
  1902. {
  1903.     if(CONSP(args))
  1904.     {
  1905.     VALUE res;
  1906.     GCVAL gcv_args, gcv_res;
  1907.     PUSHGC(gcv_args, args);
  1908.     res = cmd_eval(VCAR(args));
  1909.     PUSHGC(gcv_res, res);
  1910.     if(!cmd_progn(VCDR(args)))
  1911.         res = NULL;
  1912.     POPGC; POPGC;
  1913.     return(res);
  1914.     }
  1915.     return(NULL);
  1916. }
  1917.  
  1918. void
  1919. lispcmds_init(void)
  1920. {
  1921.     ADD_SUBR(subr_quote);
  1922.     ADD_SUBR(subr_function);
  1923.     ADD_SUBR(subr_defmacro);
  1924.     ADD_SUBR(subr_defun);
  1925.     ADD_SUBR(subr_car);
  1926.     ADD_SUBR(subr_cdr);
  1927.     ADD_SUBR(subr_list);
  1928.     ADD_SUBR(subr_copy_list);
  1929.     ADD_SUBR(subr_make_list);
  1930.     ADD_SUBR(subr_append);
  1931.     ADD_SUBR(subr_nconc);
  1932.     ADD_SUBR(subr_rplaca);
  1933.     ADD_SUBR(subr_rplacd);
  1934.     ADD_SUBR(subr_reverse);
  1935.     ADD_SUBR(subr_nreverse);
  1936.     ADD_SUBR(subr_assoc);
  1937.     ADD_SUBR(subr_assq);
  1938.     ADD_SUBR(subr_nth);
  1939.     ADD_SUBR(subr_nthcdr);
  1940.     ADD_SUBR(subr_last);
  1941.     ADD_SUBR(subr_mapcar);
  1942.     ADD_SUBR(subr_mapc);
  1943.     ADD_SUBR(subr_member);
  1944.     ADD_SUBR(subr_memq);
  1945.     ADD_SUBR(subr_delete);
  1946.     ADD_SUBR(subr_delq);
  1947.     ADD_SUBR(subr_delete_if);
  1948.     ADD_SUBR(subr_delete_if_not);
  1949.     ADD_SUBR(subr_vector);
  1950.     ADD_SUBR(subr_make_vector);
  1951.     ADD_SUBR(subr_aset);
  1952.     ADD_SUBR(subr_aref);
  1953.     ADD_SUBR(subr_make_string);
  1954.     ADD_SUBR(subr_concat);
  1955.     ADD_SUBR(subr_length);
  1956.     ADD_SUBR(subr_prog1);
  1957.     ADD_SUBR(subr_prog2);
  1958.     ADD_SUBR(subr_while);
  1959.     ADD_SUBR(subr_if);
  1960.     ADD_SUBR(subr_when);
  1961.     ADD_SUBR(subr_unless);
  1962.     ADD_SUBR(subr_cond);
  1963.     ADD_SUBR(subr_apply);
  1964.     ADD_SUBR(subr_load);
  1965.     ADD_SUBR(subr_plus);
  1966.     ADD_SUBR(subr_minus);
  1967.     ADD_SUBR(subr_product);
  1968.     ADD_SUBR(subr_divide);
  1969.     ADD_SUBR(subr_mod);
  1970.     ADD_SUBR(subr_bit_not);
  1971.     ADD_SUBR(subr_not);
  1972.     ADD_SUBR(subr_bit_or);
  1973.     ADD_SUBR(subr_or);
  1974.     ADD_SUBR(subr_bit_and);
  1975.     ADD_SUBR(subr_and);
  1976.     ADD_SUBR(subr_equal);
  1977.     ADD_SUBR(subr_eq);
  1978.     ADD_SUBR(subr_string_head_eq);
  1979.     ADD_SUBR(subr_num_eq);
  1980.     ADD_SUBR(subr_num_noteq);
  1981.     ADD_SUBR(subr_gtthan);
  1982.     ADD_SUBR(subr_gethan);
  1983.     ADD_SUBR(subr_ltthan);
  1984.     ADD_SUBR(subr_lethan);
  1985.     ADD_SUBR(subr_plus1);
  1986.     ADD_SUBR(subr_sub1);
  1987.     ADD_SUBR(subr_lsh);
  1988.     ADD_SUBR(subr_zerop);
  1989.     ADD_SUBR(subr_null);
  1990.     ADD_SUBR(subr_atom);
  1991.     ADD_SUBR(subr_consp);
  1992.     ADD_SUBR(subr_listp);
  1993.     ADD_SUBR(subr_numberp);
  1994.     ADD_SUBR(subr_stringp);
  1995.     ADD_SUBR(subr_vectorp);
  1996.     ADD_SUBR(subr_functionp);
  1997.     ADD_SUBR(subr_special_form_p);
  1998.     ADD_SUBR(subr_keymapp);
  1999.     ADD_SUBR(subr_subr_p);
  2000.     ADD_SUBR(subr_subr_documentation);
  2001.     ADD_SUBR(subr_subr_name);
  2002.     ADD_SUBR(subr_eval_hook);
  2003.     ADD_SUBR(subr_eval_hook2);
  2004.     ADD_SUBR(subr_catch);
  2005.     ADD_SUBR(subr_throw);
  2006.     ADD_SUBR(subr_return);
  2007.     ADD_SUBR(subr_unwind_protect);
  2008.     INTERN(sym_load_path, "load-path");
  2009.     VSYM(sym_load_path)->sym_Value = list_2(NullString, MKSTR(LISP_LIB_DIR));
  2010.     DOC_VAR(sym_load_path, DOC_load_path);
  2011.     INTERN(sym_lisp_lib_dir, "lisp-lib-dir");
  2012.     VSYM(sym_lisp_lib_dir)->sym_Value = MKSTR(LISP_LIB_DIR);
  2013.     DOC_VAR(sym_lisp_lib_dir, DOC_lisp_lib_dir);
  2014. }
  2015.