home *** CD-ROM | disk | FTP | other *** search
/ Gold Fish 3 / goldfish_volume_3.bin / files / util / edit / jade / src / lispcmds.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-10-04  |  54.9 KB  |  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 to NEW-CAR. Returns the new
  331. value.
  332. ::end:: */
  333. {
  334.     DECLARE1(cons, CONSP);
  335.     VCAR(cons) = car;
  336.     return(car);
  337. }
  338.  
  339. _PR VALUE cmd_rplacd(VALUE, VALUE);
  340. DEFUN("rplacd", cmd_rplacd, subr_rplacd, (VALUE cons, VALUE cdr), V_Subr2, DOC_rplacd) /*
  341. ::doc:rplacd::
  342. rplacd CONS-CELL NEW-CDR
  343.  
  344. Sets the value of the cdr slot in CONS-CELL to NEW-CAR. Returns the new
  345. value.
  346. ::end:: */
  347. {
  348.     DECLARE1(cons, CONSP);
  349.     VCDR(cons) = cdr;
  350.     return(cdr);
  351. }
  352.  
  353. _PR VALUE cmd_reverse(VALUE);
  354. DEFUN("reverse", cmd_reverse, subr_reverse, (VALUE head), V_Subr1, DOC_reverse) /*
  355. ::doc:reverse::
  356. reverse LIST
  357.  
  358. Returns a new list which is a copy of LIST except that the members are in
  359. reverse order.
  360. ::end:: */
  361. {
  362.     VALUE res = sym_nil;
  363.     while(CONSP(head))
  364.     {
  365.     res = cmd_cons(VCAR(head), res);
  366.     if(res == NULL)
  367.         return(NULL);
  368.     head = VCDR(head);
  369.     TEST_INT;
  370.     if(INT_P)
  371.         return(NULL);
  372.     }
  373.     return(res);
  374. }
  375.  
  376. _PR VALUE cmd_nreverse(VALUE);
  377. DEFUN("nreverse", cmd_nreverse, subr_nreverse, (VALUE head), V_Subr1, DOC_nreverse) /*
  378. ::doc:nreverse::
  379. nreverse LIST
  380.  
  381. Returns LIST altered so that it's members are in reverse order to what they
  382. were. This function is destructive towards it's argument.
  383. ::end:: */
  384. {
  385.     VALUE res = sym_nil;
  386.     VALUE nxt;
  387.     if(!CONSP(head))
  388.     return(sym_nil);
  389.     do {
  390.     if(CONSP(VCDR(head)))
  391.         nxt = VCDR(head);
  392.     else
  393.         nxt = NULL;
  394.     VCDR(head) = res;
  395.     res = head;
  396.     TEST_INT;
  397.     if(INT_P)
  398.         return(NULL);
  399.     } while((head = nxt));
  400.     return(res);
  401. }
  402.  
  403. _PR VALUE cmd_assoc(VALUE, VALUE);
  404. DEFUN("assoc", cmd_assoc, subr_assoc, (VALUE elt, VALUE list), V_Subr2, DOC_assoc) /*
  405. ::doc:assoc::
  406. assoc ELT ASSOC-LIST
  407.  
  408. Searches ASSOC-LIST for a list whose first element is ELT. `assoc' uses
  409. `equal' to compare elements. Returns the sub-list starting from the first 
  410. matching association.
  411. For example,
  412.     (assoc 'three '((one . 1) (two . 2) (three . 3) (four . 4)))
  413.      => (three . 3)
  414. ::end:: */
  415. {
  416.     while(CONSP(list))
  417.     {
  418.     register VALUE car = VCAR(list);
  419.     if(CONSP(car) && (!value_cmp(elt, VCAR(car))))
  420.         return(car);
  421.     list = VCDR(list);
  422.     TEST_INT;
  423.     if(INT_P)
  424.         return(NULL);
  425.     }
  426.     return(sym_nil);
  427. }
  428.  
  429. _PR VALUE cmd_assq(VALUE, VALUE);
  430. DEFUN("assq", cmd_assq, subr_assq, (VALUE elt, VALUE list), V_Subr2, DOC_assq) /*
  431. ::doc:assq::
  432. assq ELT ASSOC-LIST
  433.  
  434. Searches ASSOC-LIST for a list whose first element is ELT. `assq' uses `eq'
  435. to compare elements. Returns the sub-list starting from the first matching
  436. association.
  437. ::end:: */
  438. {
  439.     while(CONSP(list))
  440.     {
  441.     register VALUE car = VCAR(list);
  442.     if(CONSP(car) && (elt == VCAR(car)))
  443.         return(car);
  444.     list = VCDR(list);
  445.     TEST_INT;
  446.     if(INT_P)
  447.         return(NULL);
  448.     }
  449.     return(sym_nil);
  450. }
  451.  
  452. _PR VALUE cmd_rassoc(VALUE, VALUE);
  453. DEFUN("rassoc", cmd_rassoc, subr_rassoc, (VALUE elt, VALUE list), V_Subr2, DOC_rassoc) /*
  454. ::doc:rassoc::
  455. rassoc ELT ASSOC-LIST
  456.  
  457. Searches ASSOC-LIST for a cons-cell whose cdr element is `equal' to ELT. 
  458. Returns the first cons-cell which matches, or nil.
  459. For example,
  460.     (rassoc 3 '((one . 1) (two . 2) (three . 3) (four . 4)))
  461.      => (three . 3)
  462. ::end:: */
  463. {
  464.     while(CONSP(list))
  465.     {
  466.     register VALUE car = VCAR(list);
  467.     if(CONSP(car) && (!value_cmp(elt, VCDR(car))))
  468.         return(car);
  469.     list = VCDR(list);
  470.     TEST_INT;
  471.     if(INT_P)
  472.         return(NULL);
  473.     }
  474.     return(sym_nil);
  475. }
  476.  
  477. _PR VALUE cmd_rassq(VALUE, VALUE);
  478. DEFUN("rassq", cmd_rassq, subr_rassq, (VALUE elt, VALUE list), V_Subr2, DOC_rassq) /*
  479. ::doc:rassq::
  480. rassq ELT ASSOC-LIST
  481.  
  482. Searches ASSOC-LIST for a cons-cell whose cdr is `eq' to ELT.
  483. Returns the first matching cons-cell, else nil.
  484. ::end:: */
  485. {
  486.     while(CONSP(list))
  487.     {
  488.     register VALUE car = VCAR(list);
  489.     if(CONSP(car) && (elt == VCDR(car)))
  490.         return(car);
  491.     list = VCDR(list);
  492.     TEST_INT;
  493.     if(INT_P)
  494.         return(NULL);
  495.     }
  496.     return(sym_nil);
  497. }
  498.  
  499. _PR VALUE cmd_nth(VALUE, VALUE);
  500. DEFUN("nth", cmd_nth, subr_nth, (VALUE index, VALUE list), V_Subr2, DOC_nth) /*
  501. ::doc:nth::
  502. nth INDEX LIST
  503.  
  504. Returns the INDEXth element of LIST. The first element has an INDEX of zero.
  505. ::end:: */
  506. {
  507.     int i;
  508.     DECLARE1(index, NUMBERP);
  509.     i = VNUM(index);
  510.     while(i && CONSP(list))
  511.     {
  512.     list = VCDR(list);
  513.     i--;
  514.     }
  515.     if((!i) && CONSP(list))
  516.     return(VCAR(list));
  517.     return(sym_nil);
  518. }
  519.  
  520. _PR VALUE cmd_nthcdr(VALUE index, VALUE list);
  521. DEFUN("nthcdr", cmd_nthcdr, subr_nthcdr, (VALUE index, VALUE list), V_Subr2, DOC_nthcdr) /*
  522. ::doc:nthcdr::
  523. nthcdr INDEX LIST
  524.  
  525. Returns the INDEXth cdr of LIST. The first is INDEX zero.
  526. ::end:: */
  527. {
  528.     int i;
  529.     DECLARE1(index, NUMBERP);
  530.     i = VNUM(index);
  531.     while(i && CONSP(list))
  532.     {
  533.     list = VCDR(list);
  534.     i--;
  535.     }
  536.     if(!i)
  537.     return(list);
  538.     return(sym_nil);
  539. }
  540.  
  541. _PR VALUE cmd_last(VALUE);
  542. DEFUN("last", cmd_last, subr_last, (VALUE list), V_Subr1, DOC_last) /*
  543. ::doc:last::
  544. last LIST
  545.  
  546. Returns the last element of LIST.
  547. ::end:: */
  548. {
  549.     if(CONSP(list))
  550.     {
  551.     while(CONSP(VCDR(list)))
  552.     {
  553.         list = VCDR(list);
  554.         TEST_INT;
  555.         if(INT_P)
  556.         return(NULL);
  557.     }
  558.     return(list);
  559.     }
  560.     return(sym_nil);
  561. }
  562.  
  563. _PR VALUE cmd_mapcar(VALUE, VALUE);
  564. DEFUN("mapcar", cmd_mapcar, subr_mapcar, (VALUE fun, VALUE list), V_Subr2, DOC_mapcar) /*
  565. ::doc:mapcar::
  566. mapcar FUNCTION LIST
  567.  
  568. Calls FUNCTION-NAME with each element of LIST as an argument in turn and
  569. returns a new list constructed from the results, ie,
  570.   (mapcar (function (lambda (x) (1+ x))) '(1 2 3))
  571.    => (2 3 4)
  572. ::end:: */
  573. {
  574.     VALUE res = sym_nil;
  575.     VALUE *last = &res;
  576.     GCVAL gcv_list, gcv_argv, gcv_res;
  577.     VALUE argv = cmd_cons(fun, cmd_cons(sym_nil, sym_nil));
  578.     if(argv)
  579.     {
  580.     PUSHGC(gcv_res, res);
  581.     PUSHGC(gcv_argv, argv);
  582.     PUSHGC(gcv_list, list);
  583.     while(res && CONSP(list))
  584.     {
  585.         if(!(*last = cmd_cons(sym_nil, sym_nil)))
  586.         return(NULL);
  587.         VCAR(VCDR(argv)) = VCAR(list);
  588.         if(!(VCAR(*last) = cmd_funcall(argv)))
  589.         res = NULL;
  590.         else
  591.         {
  592.         last = &VCDR(*last);
  593.         list = VCDR(list);
  594.         }
  595.         TEST_INT;
  596.         if(INT_P)
  597.         {
  598.         res = NULL;
  599.         break;
  600.         }
  601.     }
  602.     POPGC; POPGC; POPGC;
  603.     }
  604.     return(res);
  605. }
  606.  
  607. _PR VALUE cmd_mapc(VALUE, VALUE);
  608. DEFUN("mapc", cmd_mapc, subr_mapc, (VALUE fun, VALUE list), V_Subr2, DOC_mapc) /*
  609. ::doc:mapc::
  610. mapc FUNCTION LIST
  611.  
  612. Applies FUNCTION to each element in LIST, discards the results.
  613. ::end:: */
  614. {
  615.     VALUE argv, res = list;
  616.     GCVAL gcv_argv, gcv_list;
  617.     if(!(argv = cmd_cons(fun, cmd_cons(sym_nil, sym_nil))))
  618.     return(NULL);
  619.     PUSHGC(gcv_argv, argv);
  620.     PUSHGC(gcv_list, list);
  621.     while(res && CONSP(list))
  622.     {
  623.     VCAR(VCDR(argv)) = VCAR(list);
  624.     if(!cmd_funcall(argv))
  625.         res = NULL;
  626.     list = VCDR(list);
  627.     TEST_INT;
  628.     if(INT_P)
  629.         res = NULL;
  630.     }
  631.     POPGC; POPGC;
  632.     return(res);
  633. }
  634.  
  635. _PR VALUE cmd_member(VALUE, VALUE);
  636. DEFUN("member", cmd_member, subr_member, (VALUE elt, VALUE list), V_Subr2, DOC_member) /*
  637. ::doc:member::
  638. member ELT LIST
  639.  
  640. If ELT is a member of list LIST then return the tail of the list starting
  641. from the matched ELT, ie,
  642.   (member 1 '(2 1 3))
  643.    => (1 3)
  644. `member' uses `equal' to compare atoms.
  645. ::end:: */
  646. {
  647.     while(CONSP(list))
  648.     {
  649.     if(!value_cmp(elt, VCAR(list)))
  650.         return(list);
  651.     list = VCDR(list);
  652.     TEST_INT;
  653.     if(INT_P)
  654.         return(NULL);
  655.     }
  656.     return(sym_nil);
  657. }
  658.  
  659. _PR VALUE cmd_memq(VALUE, VALUE);
  660. DEFUN("memq", cmd_memq, subr_memq, (VALUE elt, VALUE list), V_Subr2, DOC_memq) /*
  661. ::doc:memq::
  662. memq ELT LIST
  663.  
  664. If ELT is a member of list LIST then return the tail of the list starting
  665. from the matched ELT, ie,
  666.   (memq 1 '(2 1 3))
  667.    => (1 3)
  668. `memq' uses `eq' to compare atoms.
  669. ::end:: */
  670. {
  671.     while(CONSP(list))
  672.     {
  673.     if(elt == VCAR(list))
  674.         return(list);
  675.     list = VCDR(list);
  676.     TEST_INT;
  677.     if(INT_P)
  678.         return(NULL);
  679.     }
  680.     return(sym_nil);
  681. }
  682.  
  683. _PR VALUE cmd_delete(VALUE, VALUE);
  684. DEFUN("delete", cmd_delete, subr_delete, (VALUE elt, VALUE list), V_Subr2, DOC_delete) /*
  685. ::doc:delete::
  686. delete ELT LIST
  687.  
  688. Returns LIST with any members `equal' to ELT destructively removed.
  689. ::end:: */
  690. {
  691.     VALUE *head = &list;
  692.     while(CONSP(*head))
  693.     {
  694.     if(!value_cmp(elt, VCAR(*head)))
  695.         *head = VCDR(*head);
  696.     else
  697.         head = &VCDR(*head);
  698.     TEST_INT;
  699.     if(INT_P)
  700.         return(NULL);
  701.     }
  702.     return(list);
  703. }
  704.  
  705. _PR VALUE cmd_delq(VALUE, VALUE);
  706. DEFUN("delq", cmd_delq, subr_delq, (VALUE elt, VALUE list), V_Subr2, DOC_delq) /*
  707. ::doc:delq::
  708. delq ELT LIST
  709.  
  710. Returns LIST with any members `eq' to ELT destructively removed.
  711. ::end:: */
  712. {
  713.     VALUE *head = &list;
  714.     while(CONSP(*head))
  715.     {
  716.     if(elt == VCAR(*head))
  717.         *head = VCDR(*head);
  718.     else
  719.         head = &VCDR(*head);
  720.     TEST_INT;
  721.     if(INT_P)
  722.         return(NULL);
  723.     }
  724.     return(list);
  725. }
  726.  
  727. _PR VALUE cmd_delete_if(VALUE, VALUE);
  728. DEFUN("delete-if", cmd_delete_if, subr_delete_if, (VALUE pred, VALUE list), V_Subr2, DOC_delete_if) /*
  729. ::doc:delete_if::
  730. delete-if FUNCTION LIST
  731.  
  732. Similar to `delete' except that a predicate function, FUNCTION-NAME, is
  733. used to decide which elements to delete (remove destructively).
  734. `delete-if' deletes an element if FUNCTION-NAME returns non-nil when 
  735. applied to that element, ie,
  736.   (delete-if '(lambda (x) (= x 1)) '(1 2 3 4 1 2))
  737.    => (2 3 4 2)
  738. ::end:: */
  739. {
  740.     VALUE *head = &list;
  741.     VALUE tmp;
  742.     while(CONSP(*head))
  743.     {
  744.     if(!(tmp = call_lisp1(pred, VCAR(*head))))
  745.         return(NULL);
  746.     if(!NILP(tmp))
  747.         *head = VCDR(*head);
  748.     else
  749.         head = &VCDR(*head);
  750.     TEST_INT;
  751.     if(INT_P)
  752.         return(NULL);
  753.     }
  754.     return(list);
  755. }
  756.  
  757. _PR VALUE cmd_delete_if_not(VALUE, VALUE);
  758. DEFUN("delete-if-not", cmd_delete_if_not, subr_delete_if_not, (VALUE pred, VALUE list), V_Subr2, DOC_delete_if_not) /*
  759. ::doc:delete_if_not::
  760. delete-if-not FUNCTION LIST
  761.  
  762. Similar to `delete' except that a predicate function, FUNCTION-NAME, is
  763. used to decide which elements to delete (remove destructively).
  764. `delete-if-not' deletes an element if FUNCTION-NAME returns nil when 
  765. applied to that element, ie,
  766.   (delete-if-not '(lambda (x) (= x 1)) '(1 2 3 4 1 2))
  767.    => (1 1)
  768. ::end:: */
  769. {
  770.     VALUE *head = &list;
  771.     VALUE tmp;
  772.     while(CONSP(*head))
  773.     {
  774.     if(!(tmp = call_lisp1(pred, VCAR(*head))))
  775.         return(NULL);
  776.     if(NILP(tmp))
  777.         *head = VCDR(*head);
  778.     else
  779.         head = &VCDR(*head);
  780.     TEST_INT;
  781.     if(INT_P)
  782.         return(NULL);
  783.     }
  784.     return(list);
  785. }
  786.  
  787. _PR VALUE cmd_vector(VALUE);
  788. DEFUN("vector", cmd_vector, subr_vector, (VALUE args), V_SubrN, DOC_vector) /*
  789. ::doc:vector::
  790. vector ARGS...
  791.  
  792. Returns a new vector with ARGS... as its elements.
  793. ::end:: */
  794. {
  795.     VALUE res = make_vector(list_length(args));
  796.     if(res)
  797.     {
  798.     int i = 0;
  799.     while(CONSP(args))
  800.     {
  801.         VVECT(res)->vc_Array[i] = VCAR(args);
  802.         args = VCDR(args);
  803.         i++;
  804.         TEST_INT;
  805.         if(INT_P)
  806.         return(NULL);
  807.     }
  808.     }
  809.     return(res);
  810. }
  811.  
  812. _PR VALUE cmd_make_vector(VALUE, VALUE);
  813. DEFUN("make-vector", cmd_make_vector, subr_make_vector, (VALUE size, VALUE init), V_Subr2, DOC_make_vector) /*
  814. ::doc:make_vector::
  815. make-vector SIZE [INITIAL-VALUE]
  816.  
  817. Creates a new vector of size SIZE. If INITIAL-VALUE is provided each element
  818. will be set to that value, else they will all be nil.
  819. ::end:: */
  820. {
  821.     int len;
  822.     VALUE res;
  823.     DECLARE1(size, NUMBERP);
  824.     len = VNUM(size);
  825.     res = make_vector(len);
  826.     if(res)
  827.     {
  828.     int i;
  829.     for(i = 0; i < len; i++)
  830.         VVECT(res)->vc_Array[i] = init;
  831.     }
  832.     return(res);
  833. }
  834.  
  835. _PR VALUE cmd_arrayp(VALUE);
  836. DEFUN("arrayp", cmd_arrayp, subr_arrayp, (VALUE arg), V_Subr1, DOC_arrayp) /*
  837. ::doc:arrayp::
  838. arrayp ARG
  839.  
  840. Returns t when ARG is an array.
  841. ::end:: */
  842. {
  843.     return((VECTORP(arg) || STRINGP(arg)) ? sym_t : sym_nil);
  844. }
  845.  
  846. _PR VALUE cmd_aset(VALUE, VALUE, VALUE);
  847. DEFUN("aset", cmd_aset, subr_aset, (VALUE array, VALUE index, VALUE new), V_Subr3, DOC_aset) /*
  848. ::doc:aset::
  849. aset ARRAY INDEX NEW-VALUE
  850.  
  851. Sets element number INDEX (a positive integer) of ARRAY (can be a vector
  852. or a string) to NEW-VALUE, returning NEW-VALUE. Note that strings
  853. can only contain characters (ie, integers).
  854. ::end:: */
  855. {
  856.     DECLARE2(index, NUMBERP);
  857.     switch(VTYPE(array))
  858.     {
  859.     case V_DynamicString:
  860.     if(VNUM(index) < STRING_LEN(array))
  861.     {
  862.         DECLARE3(new, NUMBERP);
  863.         VSTR(array)[VNUM(index)] = (u_char)VCHAR(new);
  864.         return(new);
  865.     }
  866.     break;
  867.     case V_Vector:
  868.     if(VNUM(index) < VVECT(array)->vc_Size)
  869.     {
  870.         VVECT(array)->vc_Array[VNUM(index)] = new;
  871.         return(new);
  872.     }
  873.     break;
  874.     default:
  875.     return(signal_arg_error(array, 1));
  876.     }
  877.     return(signal_arg_error(index, 2));
  878. }
  879.  
  880. _PR VALUE cmd_aref(VALUE, VALUE);
  881. DEFUN("aref", cmd_aref, subr_aref, (VALUE array, VALUE index), V_Subr2, DOC_aref) /*
  882. ::doc:aref::
  883. aref ARRAY INDEX
  884.  
  885. Returns the INDEXth (a non-negative integer) element of ARRAY, which
  886. can be a vector or a string. INDEX starts at zero.
  887. ::end:: */
  888. {
  889.     DECLARE2(index, NUMBERP);
  890.     switch(VTYPE(array))
  891.     {
  892.     case V_StaticString:
  893.     case V_DynamicString:
  894.     if(VNUM(index) < STRING_LEN(array))
  895.         return(make_number(VSTR(array)[VNUM(index)]));
  896.     break;
  897.     case V_Vector:
  898.     if(VNUM(index) < VVECT(array)->vc_Size)
  899.         return(VVECT(array)->vc_Array[VNUM(index)]);
  900.     break;
  901.     default:
  902.     return(cmd_signal(sym_bad_arg, list_2(array, make_number(1))));
  903.     }
  904.     return(sym_nil);
  905. }
  906.  
  907. _PR VALUE cmd_make_string(VALUE, VALUE);
  908. DEFUN("make-string", cmd_make_string, subr_make_string, (VALUE len, VALUE init), V_Subr2, DOC_make_string) /*
  909. ::doc:make_string::
  910. make-string LENGTH [INITIAL-VALUE]
  911.  
  912. Returns a new string of length LENGTH, each character is initialised to
  913. INITIAL-VALUE, or to space if INITIAL-VALUE is not given.
  914. ::end:: */
  915. {
  916.     VALUE res;
  917.     DECLARE1(len, NUMBERP);
  918.     res = make_string(VNUM(len) + 1);
  919.     if(res)
  920.     {
  921.     memset(VSTR(res), NUMBERP(init) ? (u_char)VCHAR(init) : ' ', VNUM(len));
  922.     VSTR(res)[VNUM(len)] = 0;
  923.     }
  924.     return(res);
  925. }
  926.  
  927. static INLINE int
  928. extend_concat(u_char **buf, int *bufLen, int i, int addLen)
  929. {
  930.     u_char *newbuf;
  931.     int newbuflen;
  932.     if((i + addLen) < *bufLen)
  933.     return(TRUE);
  934.     newbuflen = (i + addLen) * 2;
  935.     newbuf = str_alloc(newbuflen);
  936.     if(newbuf)
  937.     {
  938.     memcpy(newbuf, *buf, i);
  939.     str_free(*buf);
  940.     *buf = newbuf;
  941.     *bufLen = newbuflen;
  942.     return(TRUE);
  943.     }
  944.     return(FALSE);
  945. }
  946. _PR VALUE cmd_concat(VALUE);
  947. DEFUN("concat", cmd_concat, subr_concat, (VALUE args), V_SubrN, DOC_concat) /*
  948. ::doc:concat::
  949. concat ARGS...
  950.  
  951. Concatenates all ARGS... into a single string, each argument can be a string,
  952. a character or a list or vector of characters.
  953. ::end:: */
  954. {
  955.     int buflen = 128;
  956.     u_char *buf = str_alloc(buflen);
  957.     if(buf)
  958.     {
  959.     VALUE res = NULL;
  960.     int i = 0;
  961.     while(CONSP(args))
  962.     {
  963.         VALUE arg = VCAR(args);
  964.         switch(VTYPE(arg))
  965.         {
  966.         int slen, j;
  967.         case V_StaticString:
  968.         case V_DynamicString:
  969.         slen = STRING_LEN(arg);
  970.         if(!extend_concat(&buf, &buflen, i, slen))
  971.             goto error;
  972.         memcpy(buf + i, VSTR(arg), slen);
  973.         i += slen;
  974.         break;
  975.         case V_Char:
  976.         if(!extend_concat(&buf, &buflen, i, 1))
  977.             goto error;
  978.         buf[i++] = VCHAR(arg);
  979.         break;
  980.         case V_Symbol:
  981.         if(arg != sym_nil)
  982.             break;
  983.         /* FALL THROUGH */
  984.         case V_Cons:
  985.         while(CONSP(arg))
  986.         {
  987.             VALUE ch = VCAR(arg);
  988.             if(VTYPEP(ch, V_Char))
  989.             {
  990.             if(!extend_concat(&buf, &buflen, i, 1))
  991.                 goto error;
  992.             buf[i++] = VCHAR(ch);
  993.             }
  994.             arg = VCDR(arg);
  995.             TEST_INT;
  996.             if(INT_P)
  997.             goto error;
  998.         }
  999.         break;
  1000.         case V_Vector:
  1001.         for(j = 0; j < VVECT(arg)->vc_Size; j++)
  1002.         {
  1003.             if(VTYPEP(VVECT(arg)->vc_Array[j], V_Char))
  1004.             {
  1005.             if(!extend_concat(&buf, &buflen, i, 1))
  1006.                 goto error;
  1007.             buf[i++] = VCHAR(VVECT(arg)->vc_Array[j]);
  1008.             }
  1009.         }
  1010.         break;
  1011.         }
  1012.         args = VCDR(args);
  1013.     }
  1014.     res = string_dupn(buf, i);
  1015.     if(res)
  1016. error:
  1017.     str_free(buf);
  1018.     return(res);
  1019.     }
  1020.     return(NULL);
  1021. }
  1022.  
  1023. _PR VALUE cmd_length(VALUE);
  1024. DEFUN("length", cmd_length, subr_length, (VALUE sequence), V_Subr1, DOC_length) /*
  1025. ::doc:length::
  1026. length SEQUENCE
  1027.  
  1028. Returns the number of elements in SEQUENCE (a string, list or vector).
  1029. ::end:: */
  1030. {
  1031.     switch(VTYPE(sequence))
  1032.     {
  1033.     int i;
  1034.     case V_StaticString:
  1035.     case V_DynamicString:
  1036.     return(make_number(STRING_LEN(sequence)));
  1037.     break;
  1038.     case V_Vector:
  1039.     return(make_number(VVECT(sequence)->vc_Size));
  1040.     break;
  1041.     case V_Cons:
  1042.     i = 0;
  1043.     while(CONSP(sequence))
  1044.     {
  1045.         sequence = VCDR(sequence);
  1046.         i++;
  1047.         TEST_INT;
  1048.         if(INT_P)
  1049.         return(NULL);
  1050.     }
  1051.     return(make_number(i));
  1052.     break;
  1053.     case V_Symbol:
  1054.     if(sequence == sym_nil)
  1055.         return(make_number(0));
  1056.     /* FALL THROUGH */
  1057.     default:
  1058.     cmd_signal(sym_bad_arg, list_2(sequence, make_number(1)));
  1059.     return(NULL);
  1060.     }
  1061. }
  1062.  
  1063. _PR VALUE cmd_copy_sequence(VALUE);
  1064. DEFUN("copy-sequence", cmd_copy_sequence, subr_copy_sequence, (VALUE seq), V_Subr1, DOC_copy_sequence) /*
  1065. ::doc:copy_sequence::
  1066. copy-sequence SEQUENCE
  1067.  
  1068. Returns a new sequence whose elements are eq to those in SEQUENCE.
  1069. ::end:: */
  1070. {
  1071.     VALUE res = sym_nil;
  1072.     switch(VTYPE(seq))
  1073.     {
  1074.     case V_Symbol:
  1075.     if(!NILP(seq))
  1076.         res = signal_arg_error(seq, 1);
  1077.     break;
  1078.     case V_Cons:
  1079.     {
  1080.         VALUE *last = &res;
  1081.         while(CONSP(seq))
  1082.         {
  1083.         TEST_INT;
  1084.         if(INT_P)
  1085.             return(NULL);
  1086.         if(!(*last = cmd_cons(VCAR(seq), sym_nil)))
  1087.             return(NULL);
  1088.         last = &VCDR(*last);
  1089.         seq = VCDR(seq);
  1090.         }
  1091.     }
  1092.     break;
  1093.     case V_Vector:
  1094.     res = make_vector(VVECT(seq)->vc_Size);
  1095.     if(res)
  1096.     {
  1097.         int i;
  1098.         for(i = 0; i < VVECT(seq)->vc_Size; i++)
  1099.         VVECTI(res, i) = VVECTI(seq, i);
  1100.     }
  1101.     break;
  1102.     case V_DynamicString:
  1103.     case V_StaticString:
  1104.     res = string_dupn(VSTR(seq), STRING_LEN(seq));
  1105.     break;
  1106.     default:
  1107.     res = signal_arg_error(seq, 1);
  1108.     }
  1109.     return(res);
  1110. }
  1111.  
  1112. _PR VALUE cmd_elt(VALUE, VALUE);
  1113. DEFUN("elt", cmd_elt, subr_elt, (VALUE seq, VALUE index), V_Subr2, DOC_elt) /*
  1114. ::doc:elt::
  1115. elt SEQUENCE INDEX
  1116.  
  1117. Return the element of SEQUENCE at position INDEX (counting from zero).
  1118. ::end:: */
  1119. {
  1120.     if(NILP(cmd_arrayp(seq)))
  1121.     return(cmd_nth(index, seq));
  1122.     else
  1123.     return(cmd_aref(seq, index));
  1124. }
  1125.  
  1126. _PR VALUE cmd_prog1(VALUE);
  1127. DEFUN("prog1", cmd_prog1, subr_prog1, (VALUE args), V_SF, DOC_prog1) /*
  1128. ::doc:prog1::
  1129. prog1 FORM1 FORMS...
  1130.  
  1131. First evals FORM1 then FORMS, returns the value that FORM1 gave.
  1132. ::end:: */
  1133. {
  1134.     if(CONSP(args))
  1135.     {
  1136.     VALUE res;
  1137.     GCVAL gcv_args, gcv_res;
  1138.     PUSHGC(gcv_args, args);
  1139.     res = cmd_eval(VCAR(args));
  1140.     if(res)
  1141.     {
  1142.         PUSHGC(gcv_res, res);
  1143.         if(!cmd_progn(VCDR(args)))
  1144.         res = NULL;
  1145.         POPGC;
  1146.     }
  1147.     POPGC;
  1148.     return(res);
  1149.     }
  1150.     return(NULL);
  1151. }
  1152.  
  1153. _PR VALUE cmd_prog2(VALUE);
  1154. DEFUN("prog2", cmd_prog2, subr_prog2, (VALUE args), V_SF, DOC_prog2) /*
  1155. ::doc:prog2::
  1156. prog2 FORM1 FORM2 FORMS...
  1157.  
  1158. Evals FORM1 then FORM2 then the rest. Returns whatever FORM2 gave.
  1159. ::end:: */
  1160. {
  1161.     if(CONSP(args) && CONSP(VCDR(args)))
  1162.     {
  1163.     VALUE res;
  1164.     GCVAL gcv_args, gcv_res;
  1165.     PUSHGC(gcv_args, args);
  1166.     if(cmd_eval(VCAR(args)))
  1167.     {
  1168.         res = cmd_eval(VCAR(VCDR(args)));
  1169.         if(res)
  1170.         {
  1171.         PUSHGC(gcv_res, res);
  1172.         if(!cmd_progn(VCDR(VCDR(args))))
  1173.             res = NULL;
  1174.         POPGC;
  1175.         }
  1176.     }
  1177.     else
  1178.         res = NULL;
  1179.     POPGC;
  1180.     return(res);
  1181.     }
  1182.     return(NULL);
  1183. }
  1184.  
  1185. _PR VALUE cmd_while(VALUE);
  1186. DEFUN("while", cmd_while, subr_while, (VALUE args), V_SF, DOC_while) /*
  1187. ::doc:while::
  1188. while CONDITION FORMS...
  1189.  
  1190. Eval CONDITION, if it is non-nil then execute FORMS and repeat the
  1191. procedure, else return nil.
  1192. ::end:: */
  1193. {
  1194.     if(CONSP(args))
  1195.     {
  1196.     GCVAL gcv_args;
  1197.     VALUE cond = VCAR(args), wval, body = VCDR(args);
  1198.     PUSHGC(gcv_args, args);
  1199.     while((wval = cmd_eval(cond)) && !NILP(wval))
  1200.     {
  1201.         TEST_INT;
  1202.         if(INT_P || !cmd_progn(body))
  1203.         {
  1204.         wval = NULL;
  1205.         break;
  1206.         }
  1207.     }
  1208.     POPGC;
  1209.     if(!wval)
  1210.         return(NULL);
  1211.     return(sym_nil);
  1212.     }
  1213.     return(NULL);
  1214. }
  1215.  
  1216. _PR VALUE cmd_if(VALUE);
  1217. DEFUN("if", cmd_if, subr_if, (VALUE args), V_SF, DOC_if) /*
  1218. ::doc:if::
  1219. if CONDITION THEN-FORM [ELSE-FORMS...]
  1220.  
  1221. Eval CONDITION, if it is non-nil then eval THEN-FORM and return it's 
  1222. result, else do an implicit progn with the ELSE-FORMS returning its value.
  1223. ::end:: */
  1224. {
  1225.     if(CONSP(args) && CONSP(VCDR(args)))
  1226.     {
  1227.     VALUE res;
  1228.     GCVAL gcv_args;
  1229.     PUSHGC(gcv_args, args);
  1230.     res = cmd_eval(VCAR(args));
  1231.     if(res)
  1232.     {
  1233.         if(!NILP(res))
  1234.         res = cmd_eval(VCAR(VCDR(args)));
  1235.         else
  1236.         res = cmd_progn(VCDR(VCDR(args)));
  1237.     }
  1238.     POPGC;
  1239.     return(res);
  1240.     }
  1241.     return(NULL);
  1242. }
  1243.  
  1244. _PR VALUE cmd_when(VALUE);
  1245. DEFUN("when", cmd_when, subr_when, (VALUE args), V_SF, DOC_when) /*
  1246. ::doc:when::
  1247. when CONDITION FORMS...
  1248.  
  1249. Evaluates CONDITION, if it is non-nil evaluates FORMS.
  1250. ::end:: */
  1251. {
  1252.     VALUE res = sym_nil;
  1253.     if(CONSP(args))
  1254.     {
  1255.     GCVAL gcv_args;
  1256.     PUSHGC(gcv_args, args);
  1257.     if((res = cmd_eval(VCAR(args))) && !NILP(res))
  1258.         res = cmd_progn(VCDR(args));
  1259.     POPGC;
  1260.     }
  1261.     return(res);
  1262. }
  1263.  
  1264. _PR VALUE cmd_unless(VALUE);
  1265. DEFUN("unless", cmd_unless, subr_unless, (VALUE args), V_SF, DOC_unless) /*
  1266. ::doc:unless::
  1267. unless CONDITION FORMS...
  1268.  
  1269. Evaluates CONDITION, if it is nil evaluates FORMS.
  1270. ::end:: */
  1271. {
  1272.     VALUE res = sym_nil;
  1273.     if(CONSP(args))
  1274.     {
  1275.     GCVAL gcv_args;
  1276.     PUSHGC(gcv_args, args);
  1277.     if((res = cmd_eval(VCAR(args))) && NILP(res))
  1278.         res = cmd_progn(VCDR(args));
  1279.     POPGC;
  1280.     }
  1281.     return(res);
  1282. }
  1283.  
  1284. _PR VALUE cmd_cond(VALUE);
  1285. DEFUN("cond", cmd_cond, subr_cond, (VALUE args), V_SF, DOC_cond) /*
  1286. ::doc:cond::
  1287. cond (CONDITION FORMS... ) ...
  1288.  
  1289. Find the first CONDITION which has a value of t when eval'ed, then perform
  1290. a progn on its associated FORMS. If there are no FORMS with the CONDITION
  1291. then the value of the CONDITION is returned. If no CONDITION is t then
  1292. return nil.
  1293. An example,
  1294.   (cond
  1295.     ((stringp foo)
  1296.       (title "foo is a string"))
  1297.     ((numberp foo)
  1298.       (setq bar foo)
  1299.       (title "foo is a number"))
  1300.     (t
  1301.       (title "foo is something else...")))
  1302. Note the use of plain `t' on it's own for the last CONDITION, this is
  1303. like the last else in an else-if statement in C.
  1304. ::end:: */
  1305. {
  1306.     VALUE res = sym_nil;
  1307.     GCVAL gcv_args;
  1308.     PUSHGC(gcv_args, args);
  1309.     while(CONSP(args) && CONSP(VCAR(args)))
  1310.     {
  1311.     VALUE cndlist = VCAR(args);
  1312.     if(!(res = cmd_eval(VCAR(cndlist))))
  1313.         break;
  1314.     if(!NILP(res))
  1315.     {
  1316.         if(CONSP(VCDR(cndlist)))
  1317.         {
  1318.         if(!(res = cmd_progn(VCDR(cndlist))))
  1319.             break;
  1320.         }
  1321.         break;
  1322.     }
  1323.     args = VCDR(args);
  1324.     }
  1325.     POPGC;
  1326.     return(res);
  1327. }
  1328.  
  1329. _PR VALUE cmd_apply(VALUE);
  1330. DEFUN("apply", cmd_apply, subr_apply, (VALUE args), V_SubrN, DOC_apply) /*
  1331. ::doc:apply::
  1332. apply FUNCTION ARGS... ARG-LIST
  1333.  
  1334. Calls FUNCTION passing all of ARGS to it as well as all elements in ARG-LIST.
  1335. ie,
  1336.   (apply '+ 1 2 3 '(4 5 6))
  1337.    => 21
  1338. ::end:: */
  1339. {
  1340.     VALUE list = sym_nil, *last;
  1341.     last = &list;
  1342.     if(CONSP(args))
  1343.     {
  1344.     while(CONSP(VCDR(args)))
  1345.     {
  1346.         if(!(*last = cmd_cons(VCAR(args), sym_nil)))
  1347.         return(NULL);
  1348.         last = &VCDR(*last);
  1349.         args = VCDR(args);
  1350.         TEST_INT;
  1351.         if(INT_P)
  1352.         return(NULL);
  1353.     }
  1354.     if(!NILP(cmd_listp(VCAR(args))))
  1355.         *last = VCAR(args);
  1356.     else
  1357.         return(cmd_signal(sym_bad_arg, LIST_1(VCAR(args))));
  1358.     return(cmd_funcall(list));
  1359.     }
  1360.     return(cmd_signal(sym_missing_arg, LIST_1(make_number(1))));
  1361. }
  1362.  
  1363. _PR VALUE cmd_load(VALUE file, VALUE noerr_p, VALUE nopath_p, VALUE nosuf_p);
  1364. DEFUN_INT("load", cmd_load, subr_load, (VALUE file, VALUE noerr_p, VALUE nopath_p, VALUE nosuf_p), V_Subr4, DOC_load, "fLisp file to load:") /*
  1365. ::doc:load::
  1366. load FILE [NO-ERROR-P] [NO-PATH-P] [NO-SUFFIX-P]
  1367.  
  1368. Attempt to open and then read-and-eval the file of Lisp code FILE.
  1369.  
  1370. For each directory named in the variable `load-path' tries the value of
  1371. FILE with `.jlc' (compiled-lisp) appended to it, then with `.jl' appended
  1372. to it, finally tries FILE without modification.
  1373.  
  1374. If NO-ERROR-P is non-nil no error is signalled if FILE can't be found.
  1375. If NO-PATH-P is non-nil the `load-path' variable is not used, just the value
  1376. of FILE.
  1377. If NO-SUFFIX-P is non-nil no suffixes are appended to FILE.
  1378.  
  1379. If the compiled version is older than it's source code, the source code is
  1380. loaded and a warning is displayed.
  1381. ::end:: */
  1382. {
  1383.     VALUE name = NULL, stream, path;
  1384.     DECLARE1(file, STRINGP);
  1385.     if(NILP(nopath_p))
  1386.     {
  1387.     path = cmd_symbol_value(sym_load_path, sym_nil);
  1388.     if(!path)
  1389.         return(NULL);
  1390.     }
  1391.     else
  1392.     path = cmd_cons(MKSTR(""), sym_nil);
  1393.     while(!name && CONSP(path))
  1394.     {
  1395.     u_char *dir = STRINGP(VCAR(path)) ? VSTR(VCAR(path)) : (u_char *)"";
  1396.     if(NILP(nosuf_p))
  1397.     {
  1398.         bool jl_p = file_exists3(dir, VSTR(file), ".jl");
  1399.         if(file_exists3(dir, VSTR(file), ".jlc"))
  1400.         {
  1401.         name = concat3(dir, VSTR(file), ".jlc");
  1402.         if(jl_p)
  1403.         {
  1404.             VALUE tmp = concat3(dir, VSTR(file), ".jl");
  1405.             if(file_mod_time(VSTR(tmp)) > file_mod_time(VSTR(name)))
  1406.             {
  1407.             messagef("Warning: %s newer than %s, using .jl",
  1408.                      VSTR(tmp), VSTR(name));
  1409.             name = tmp;
  1410.             }
  1411.         }
  1412.         }
  1413.         else if(jl_p)
  1414.         name = concat3(dir, VSTR(file), ".jl");
  1415.     }
  1416.     if(!name && file_exists2(dir, VSTR(file)))
  1417.         name = concat2(dir, VSTR(file));
  1418.     path = VCDR(path);
  1419.     TEST_INT;
  1420.     if(INT_P)
  1421.         return(NULL);
  1422.     }
  1423.     if(!name)
  1424.     {
  1425.     if(NILP(noerr_p))
  1426.         return(cmd_signal(sym_file_error,
  1427.                   list_2(MKSTR("Can't open lisp-file"), file)));
  1428.     else
  1429.         return(sym_nil);
  1430.     }
  1431.     if((stream = cmd_open(name, MKSTR("r"), sym_nil)) && FILEP(stream))
  1432.     {
  1433.     VALUE obj;
  1434.     int c;
  1435.     GCVAL gcv_stream;
  1436.     PUSHGC(gcv_stream, stream);
  1437.     c = stream_getc(stream);
  1438.     while((c != EOF) && (obj = readl(stream, &c)))
  1439.     {
  1440.         TEST_INT;
  1441.         if(INT_P || !cmd_eval(obj))
  1442.         {
  1443.         POPGC;
  1444.         return(NULL);
  1445.         }
  1446.     }
  1447.     POPGC;
  1448.     return(sym_t);
  1449.     }
  1450.     return(NULL);
  1451. }
  1452.  
  1453. /*
  1454.  * some arithmetic commands
  1455.  */
  1456.  
  1457. #define APPLY_OP( op ) \
  1458.     if(CONSP(args) && NUMBERP(VCAR(args))) \
  1459.     { \
  1460.     long sum = VNUM(VCAR(args)); \
  1461.     args = VCDR(args); \
  1462.     while(CONSP(args) && NUMBERP(VCAR(args))) \
  1463.     { \
  1464.         sum = sum op VNUM(VCAR(args)); \
  1465.         args = VCDR(args); \
  1466.         TEST_INT; \
  1467.         if(INT_P) \
  1468.         return(NULL); \
  1469.     } \
  1470.     return(make_number(sum)); \
  1471.     } \
  1472.     return(NULL);
  1473.  
  1474. _PR VALUE cmd_plus(VALUE);
  1475. DEFUN("+", cmd_plus, subr_plus, (VALUE args), V_SubrN, DOC_plus) /*
  1476. ::doc:plus::
  1477. + NUMBERS...
  1478.  
  1479. Adds all NUMBERS together.
  1480. ::end:: */
  1481. {
  1482.     APPLY_OP( + )
  1483. }
  1484.  
  1485. _PR VALUE cmd_minus(VALUE);
  1486. DEFUN("-", cmd_minus, subr_minus, (VALUE args), V_SubrN, DOC_minus) /*
  1487. ::doc:minus::
  1488. - NUMBER [NUMBERS...]
  1489.  
  1490. Either returns the negation of NUMBER or the value of NUMBER minus
  1491. NUMBERS
  1492. ::end:: */
  1493. {
  1494.     if(CONSP(args))
  1495.     {
  1496.     if(!CONSP(VCDR(args)))
  1497.         return(make_number(-VNUM(VCAR(args))));
  1498.     else
  1499.         APPLY_OP( - )
  1500.     }
  1501.     return(NULL);
  1502. }
  1503.  
  1504. _PR VALUE cmd_product(VALUE);
  1505. DEFUN("*", cmd_product, subr_product, (VALUE args), V_SubrN, DOC_product) /*
  1506. ::doc:product::
  1507. * NUMBERS...
  1508.  
  1509. Multiplies all NUMBERS together
  1510. ::end:: */
  1511. {
  1512.     APPLY_OP( * )
  1513. }
  1514.  
  1515. _PR VALUE cmd_divide(VALUE);
  1516. DEFUN("/", cmd_divide, subr_divide, (VALUE args), V_SubrN, DOC_divide) /*
  1517. ::doc:divide::
  1518. / NUMBERS...
  1519.  
  1520. Divides NUMBERS (in left-to-right order), ie,
  1521.   (/ 100 2
  1522.    => 10
  1523. ::end:: */
  1524. {
  1525.     APPLY_OP( / )
  1526. }
  1527.  
  1528. _PR VALUE cmd_remainder(VALUE);
  1529. DEFUN("%", cmd_remainder, subr_remainder, (VALUE args), V_SubrN, DOC_remainder) /*
  1530. ::doc:remainder::
  1531. % NUMBERS...
  1532.  
  1533. Applies the remainder operator between each of NUMBERS.
  1534. ::end:: */
  1535. {
  1536.     APPLY_OP( % )
  1537. }
  1538.  
  1539. _PR VALUE cmd_lognot(VALUE);
  1540. DEFUN("lognot", cmd_lognot, subr_lognot, (VALUE num), V_Subr1, DOC_lognot) /*
  1541. ::doc:lognot::
  1542. lognot NUMBER
  1543.  
  1544. Returns the bitwise logical `not' of NUMBER.
  1545. ::end:: */
  1546. {
  1547.     DECLARE1(num, NUMBERP);
  1548.     return(make_number(~VNUM(num)));
  1549. }
  1550.  
  1551. _PR VALUE cmd_not(VALUE);
  1552. DEFUN("not", cmd_not, subr_not, (VALUE arg), V_Subr1, DOC_not) /*
  1553. ::doc:not::
  1554. not ARG
  1555.  
  1556. If ARG is nil returns t, else returns nil.
  1557. ::end:: */
  1558. {
  1559.     if(NILP(arg))
  1560.     return(sym_t);
  1561.     return(sym_nil);
  1562. }
  1563.  
  1564. _PR VALUE cmd_logior(VALUE);
  1565. DEFUN("logior", cmd_logior, subr_logior, (VALUE args), V_SubrN, DOC_logior) /*
  1566. ::doc:logior::
  1567. logior NUMBERS...
  1568.  
  1569. Returns the bitwise logical `inclusive-or' of its arguments.
  1570. ::end:: */
  1571. {
  1572.     APPLY_OP( | )
  1573. }
  1574.  
  1575. _PR VALUE cmd_logxor(VALUE);
  1576. DEFUN("logxor", cmd_logxor, subr_logxor, (VALUE args), V_SubrN, DOC_logxor) /*
  1577. ::doc:logxor::
  1578. logxor NUMBERS...
  1579.  
  1580. Returns the bitwise logical `exclusive-or' of its arguments.
  1581. ::end:: */
  1582. {
  1583.     APPLY_OP( ^ )
  1584. }
  1585.  
  1586. _PR VALUE cmd_or(VALUE);
  1587. DEFUN("or", cmd_or, subr_or, (VALUE args), V_SF, DOC_or) /*
  1588. ::doc:or::
  1589. or FORMS...
  1590.  
  1591. Evals each FORM while they return nil, returns the first non-nil result or
  1592. nil if all FORMS return nil.
  1593. ::end:: */
  1594. {
  1595.     VALUE res = sym_nil;
  1596.     GCVAL gcv_args, gcv_res;
  1597.     PUSHGC(gcv_args, args);
  1598.     PUSHGC(gcv_res, res);
  1599.     while(res && CONSP(args) && NILP(res))
  1600.     {
  1601.     res = cmd_eval(VCAR(args));
  1602.     args = VCDR(args);
  1603.     TEST_INT;
  1604.     if(INT_P)
  1605.         res = NULL;
  1606.     }
  1607.     POPGC;
  1608.     POPGC;
  1609.     return(res);
  1610. }
  1611.  
  1612. _PR VALUE cmd_logand(VALUE);
  1613. DEFUN("logand", cmd_logand, subr_logand, (VALUE args), V_SubrN, DOC_logand) /*
  1614. ::doc:logand::
  1615. logand NUMBERS...
  1616.  
  1617. Returns the bitwise logical `and' of its arguments.
  1618. ::end:: */
  1619. {
  1620.     APPLY_OP( & )
  1621. }
  1622.  
  1623. _PR VALUE cmd_and(VALUE);
  1624. DEFUN("and", cmd_and, subr_and, (VALUE args), V_SF, DOC_and) /*
  1625. ::doc:and::
  1626. and FORMS...
  1627.  
  1628. Evals each FORM until one returns nil, it returns that value, or t if all
  1629. FORMS return t.
  1630. ::end:: */
  1631. {
  1632.     VALUE res = sym_t;
  1633.     GCVAL gcv_args, gcv_res;
  1634.     PUSHGC(gcv_args, args);
  1635.     PUSHGC(gcv_res, res);
  1636.     while(res && CONSP(args) && !NILP(res))
  1637.     {
  1638.     res = cmd_eval(VCAR(args));
  1639.     args = VCDR(args);
  1640.     TEST_INT;
  1641.     if(INT_P)
  1642.         res = NULL;
  1643.     }
  1644.     POPGC;
  1645.     POPGC;
  1646.     return(res);
  1647. }
  1648.  
  1649. _PR VALUE cmd_equal(VALUE, VALUE);
  1650. DEFUN("equal", cmd_equal, subr_equal, (VALUE val1, VALUE val2), V_Subr2, DOC_equal) /*
  1651. ::doc:equal::
  1652. equal VALUE1 VALUE2
  1653.  
  1654. Compares VALUE1 and VALUE2, compares the actual structure of the objects not
  1655. just whether the objects are one and the same. ie, will return t for two
  1656. strings built from the same characters in the same order even if the strings'
  1657. location in memory is different.
  1658. ::end:: */
  1659. {
  1660.     if(value_cmp(val1, val2))
  1661.     return(sym_nil);
  1662.     return(sym_t);
  1663. }
  1664.  
  1665. _PR VALUE cmd_eq(VALUE, VALUE);
  1666. DEFUN("eq", cmd_eq, subr_eq, (VALUE val1, VALUE val2), V_Subr2, DOC_eq) /*
  1667. ::doc:eq::
  1668. eq VALUE1 VALUE2
  1669.  
  1670. Returns t if VALUE1 and VALUE2 are one and the same object. Note that
  1671. this may or may not be true for numbers of the same value (see `eql').
  1672. ::end:: */
  1673. {
  1674.     if(val1 == val2)
  1675.     return(sym_t);
  1676.     return(sym_nil);
  1677. }
  1678.  
  1679. _PR VALUE cmd_eql(VALUE arg1, VALUE arg2);
  1680. DEFUN("eql", cmd_eql, subr_eql, (VALUE arg1, VALUE arg2), V_Subr2, DOC_eql) /*
  1681. ::doc:eql::
  1682. eql ARG1 ARG2
  1683. Similar to `eq' except that numbers (integers, characters) with the same
  1684. value will always be considered `eql' (this may or may not be the case
  1685. with `eq'.
  1686. ::end:: */
  1687. {
  1688.     if(NUMBERP(arg1) && NUMBERP(arg2))
  1689.     return(VNUM(arg1) == VNUM(arg2) ? sym_t : sym_nil);
  1690.     else
  1691.     return(arg1 == arg2 ? sym_t : sym_nil);
  1692. }
  1693.  
  1694. _PR VALUE cmd_string_head_eq(VALUE, VALUE);
  1695. DEFUN("string-head-eq", cmd_string_head_eq, subr_string_head_eq, (VALUE str1, VALUE str2), V_Subr2, DOC_string_head_eq) /*
  1696. ::doc:string_head_eq::
  1697. string-head-eq STRING1 STRING2
  1698.  
  1699. Returns t if STRING2 matches the beginning of STRING1, ie,
  1700.   (string-head-eq "foobar" "foo")
  1701.    => t
  1702.   (string-head-eq "foo" "foobar")
  1703.    => nil
  1704. ::end:: */
  1705. {
  1706.     u_char *s1, *s2;
  1707.     DECLARE1(str1, STRINGP);
  1708.     DECLARE2(str2, STRINGP);
  1709.     s1 = VSTR(str1);
  1710.     s2 = VSTR(str2);
  1711.     while(*s1 && *s2)
  1712.     {
  1713.     if(*s1++ != *s2++)
  1714.         return(sym_nil);
  1715.     }
  1716.     if(*s1 || (*s1 == *s2))
  1717.     return(sym_t);
  1718.     return(sym_nil);
  1719. }
  1720.  
  1721. _PR VALUE cmd_num_eq(VALUE num1, VALUE num2);
  1722. DEFUN("=", cmd_num_eq, subr_num_eq, (VALUE num1, VALUE num2), V_Subr2, DOC_num_eq) /*
  1723. ::doc:num_eq::
  1724. = NUMBER1 NUMBER2
  1725.  
  1726. Returns t if NUMBER1 and NUMBER2 are equal.
  1727. ::end:: */
  1728. {
  1729.     DECLARE1(num1, NUMBERP);
  1730.     DECLARE2(num2, NUMBERP);
  1731.     if(VNUM(num1) == VNUM(num2))
  1732.     return(sym_t);
  1733.     return(sym_nil);
  1734. }
  1735.  
  1736. _PR VALUE cmd_num_noteq(VALUE num1, VALUE num2);
  1737. DEFUN("/=", cmd_num_noteq, subr_num_noteq, (VALUE num1, VALUE num2), V_Subr2, DOC_num_noteq) /*
  1738. ::doc:num_noteq::
  1739. /= NUMBER1 NUMBER2
  1740.  
  1741. Returns t if NUMBER1 and NUMBER2 are unequal.
  1742. ::end:: */
  1743. {
  1744.     DECLARE1(num1, NUMBERP);
  1745.     DECLARE2(num2, NUMBERP);
  1746.     if(VNUM(num1) != VNUM(num2))
  1747.     return(sym_t);
  1748.     return(sym_nil);
  1749. }
  1750.  
  1751. _PR VALUE cmd_gtthan(VALUE, VALUE);
  1752. DEFUN(">", cmd_gtthan, subr_gtthan, (VALUE arg1, VALUE arg2), V_Subr2, DOC_gtthan) /*
  1753. ::doc:gtthan::
  1754. > ARG1 ARG2
  1755.  
  1756. Returns t if ARG1 is greater than ARG2. Note that this command isn't
  1757. limited to numbers, it can do strings, positions, marks, etc as well.
  1758. ::end:: */
  1759. {
  1760.     if(value_cmp(arg1, arg2) > 0)
  1761.     return(sym_t);
  1762.     return(sym_nil);
  1763. }
  1764.  
  1765. _PR VALUE cmd_gethan(VALUE, VALUE);
  1766. DEFUN(">=", cmd_gethan, subr_gethan, (VALUE arg1, VALUE arg2), V_Subr2, DOC_gethan) /*
  1767. ::doc:gethan::
  1768. >= ARG1 ARG2
  1769.  
  1770. Returns t if ARG1 is greater-or-equal than ARG2. Note that this command
  1771. isn't limited to numbers, it can do strings, positions, marks, etc as well.
  1772. ::end:: */
  1773. {
  1774.     if(value_cmp(arg1, arg2) >= 0)
  1775.     return(sym_t);
  1776.     return(sym_nil);
  1777. }
  1778.  
  1779. _PR VALUE cmd_ltthan(VALUE, VALUE);
  1780. DEFUN("<", cmd_ltthan, subr_ltthan, (VALUE arg1, VALUE arg2), V_Subr2, DOC_ltthan) /*
  1781. ::doc:ltthan::
  1782. < ARG1 ARG2
  1783.  
  1784. Returns t if ARG1 is less than ARG2. Note that this command isn't limited to
  1785. numbers, it can do strings, positions, marks, etc as well.
  1786. ::end:: */
  1787. {
  1788.     if(value_cmp(arg1, arg2) < 0)
  1789.     return(sym_t);
  1790.     return(sym_nil);
  1791. }
  1792.  
  1793. _PR VALUE cmd_lethan(VALUE, VALUE);
  1794. DEFUN("<=", cmd_lethan, subr_lethan, (VALUE arg1, VALUE arg2), V_Subr2, DOC_lethan) /*
  1795. ::doc:lethan::
  1796. <= ARG1 ARG2
  1797.  
  1798. Returns t if ARG1 is less-or-equal than ARG2. Note that this command isn't
  1799. limited to numbers, it can do strings, positions, marks, etc as well.
  1800. ::end:: */
  1801. {
  1802.     if(value_cmp(arg1, arg2) <= 0)
  1803.     return(sym_t);
  1804.     return(sym_nil);
  1805. }
  1806.  
  1807. _PR VALUE cmd_plus1(VALUE);
  1808. DEFUN("1+", cmd_plus1, subr_plus1, (VALUE num), V_Subr1, DOC_plus1) /*
  1809. ::doc:plus1::
  1810. 1+ NUMBER
  1811.  
  1812. Return NUMBER plus 1.
  1813. ::end:: */
  1814. {
  1815.     DECLARE1(num, NUMBERP);
  1816.     return(make_number(VNUM(num) + 1));
  1817. }
  1818.  
  1819. _PR VALUE cmd_sub1(VALUE);
  1820. DEFUN("1-", cmd_sub1, subr_sub1, (VALUE num), V_Subr1, DOC_sub1) /*
  1821. ::doc:sub1::
  1822. 1- NUMBER
  1823.  
  1824. Return NUMBER minus 1.
  1825. ::end:: */
  1826. {
  1827.     DECLARE1(num, NUMBERP);
  1828.     return(make_number(VNUM(num) - 1));
  1829. }
  1830.  
  1831. _PR VALUE cmd_lsh(VALUE, VALUE);
  1832. DEFUN("lsh", cmd_lsh, subr_lsh, (VALUE num, VALUE shift), V_Subr2, DOC_lsh) /*
  1833. ::doc:lsh::
  1834. lsh NUMBER COUNT
  1835.  
  1836. Shift the bits in NUMBER by COUNT bits to the left, a negative COUNT means
  1837. shift right.
  1838. ::end:: */
  1839. {
  1840.     DECLARE1(num, NUMBERP);
  1841.     DECLARE2(shift, NUMBERP);
  1842.     if(VNUM(shift) > 0)
  1843.     return(make_number(VNUM(num) << VNUM(shift)));
  1844.     /* ensure that a zero is in the top bit. */
  1845.     return(make_number((VNUM(num) >> -VNUM(shift)) & 0x7fffffff));
  1846. }
  1847.  
  1848. _PR VALUE cmd_ash(VALUE, VALUE);
  1849. DEFUN("ash", cmd_ash, subr_ash, (VALUE num, VALUE shift), V_Subr2, DOC_ash) /*
  1850. ::doc:ash::
  1851. ash NUMBER COUNT
  1852.  
  1853. Use an arithmetic shift to shift the bits in NUMBER by COUNT bits to the left,
  1854. a negative COUNT means shift right.
  1855. ::end:: */
  1856. {
  1857.     DECLARE1(num, NUMBERP);
  1858.     DECLARE2(shift, NUMBERP);
  1859.     if(VNUM(shift) > 0)
  1860.     return(make_number(VNUM(num) << VNUM(shift)));
  1861.     return(make_number(VNUM(num) >> -VNUM(shift)));
  1862. }
  1863.  
  1864. _PR VALUE cmd_zerop(VALUE);
  1865. DEFUN("zerop", cmd_zerop, subr_zerop, (VALUE num), V_Subr1, DOC_zerop) /*
  1866. ::doc:zerop::
  1867. zerop NUMBER
  1868.  
  1869. t if NUMBER is zero.
  1870. ::end:: */
  1871. {
  1872.     if(NUMBERP(num) && (VNUM(num) == 0))
  1873.     return(sym_t);
  1874.     return(sym_nil);
  1875. }
  1876.  
  1877. _PR VALUE cmd_null(VALUE);
  1878. DEFUN("null", cmd_null, subr_null, (VALUE arg), V_Subr1, DOC_null) /*
  1879. ::doc:null::
  1880. null ARG
  1881.  
  1882. Returns t if ARG is nil.
  1883. ::end:: */
  1884. {
  1885.     if(NILP(arg))
  1886.     return(sym_t);
  1887.     return(sym_nil);
  1888. }
  1889.  
  1890. _PR VALUE cmd_atom(VALUE);
  1891. DEFUN("atom", cmd_atom, subr_atom, (VALUE arg), V_Subr1, DOC_atom) /*
  1892. ::doc:atom::
  1893. atom ARG
  1894.  
  1895. Returns t if ARG is not a cons-cell.
  1896. ::end:: */
  1897. {
  1898.     if(!CONSP(arg))
  1899.     return(sym_t);
  1900.     return(sym_nil);
  1901. }
  1902.  
  1903. _PR VALUE cmd_consp(VALUE);
  1904. DEFUN("consp", cmd_consp, subr_consp, (VALUE arg), V_Subr1, DOC_consp) /*
  1905. ::doc:consp::
  1906. consp ARG
  1907.  
  1908. Returns t if ARG is a cons-cell.
  1909. ::end:: */
  1910. {
  1911.     if(CONSP(arg))
  1912.     return(sym_t);
  1913.     return(sym_nil);
  1914. }
  1915.  
  1916. _PR VALUE cmd_listp(VALUE);
  1917. DEFUN("listp", cmd_listp, subr_listp, (VALUE arg), V_Subr1, DOC_listp) /*
  1918. ::doc:listp::
  1919. listp ARG
  1920.  
  1921. Returns t if ARG is a list, (either a cons-cell or nil).
  1922. ::end:: */
  1923. {
  1924.     if(NILP(arg) || CONSP(arg))
  1925.     return(sym_t);
  1926.     return(sym_nil);
  1927. }
  1928.  
  1929. _PR VALUE cmd_numberp(VALUE);
  1930. DEFUN("numberp", cmd_numberp, subr_numberp, (VALUE arg), V_Subr1, DOC_numberp) /*
  1931. ::doc:numberp::
  1932. numberp ARG
  1933.  
  1934. Return t if ARG is a number.
  1935. ::end:: */
  1936. {
  1937.     if(NUMBERP(arg))
  1938.     return(sym_t);
  1939.     return(sym_nil);
  1940. }
  1941.  
  1942. _PR VALUE cmd_integerp(VALUE);
  1943. DEFUN("integerp", cmd_integerp, subr_integerp, (VALUE arg), V_Subr1, DOC_integerp) /*
  1944. ::doc:integerp::
  1945. integerp ARG
  1946.  
  1947. Return t if ARG is a integer.
  1948. ::end:: */
  1949. {
  1950.     if(NUMBERP(arg))
  1951.     return(sym_t);
  1952.     return(sym_nil);
  1953. }
  1954.  
  1955. _PR VALUE cmd_stringp(VALUE);
  1956. DEFUN("stringp", cmd_stringp, subr_stringp, (VALUE arg), V_Subr1, DOC_stringp) /*
  1957. ::doc:stringp::
  1958. stringp ARG
  1959.  
  1960. Returns t is ARG is a string.
  1961. ::end:: */
  1962. {
  1963.     if(STRINGP(arg))
  1964.     return(sym_t);
  1965.     return(sym_nil);
  1966. }
  1967.  
  1968. _PR VALUE cmd_vectorp(VALUE);
  1969. DEFUN("vectorp", cmd_vectorp, subr_vectorp, (VALUE arg), V_Subr1, DOC_vectorp) /*
  1970. ::doc:vectorp::
  1971. vectorp ARG
  1972.  
  1973. Returns t if ARG is a vector.
  1974. ::end:: */
  1975. {
  1976.     if(VECTORP(arg))
  1977.     return(sym_t);
  1978.     return(sym_nil);
  1979. }
  1980.  
  1981. _PR VALUE cmd_functionp(VALUE);
  1982. DEFUN("functionp", cmd_functionp, subr_functionp, (VALUE arg), V_Subr1, DOC_functionp) /*
  1983. ::doc:functionp::
  1984. functionp ARG
  1985.  
  1986. Returns t if ARG is a function (ie, a symbol or a list whose car is the
  1987. symbol `lambda'
  1988. ::end:: */
  1989. {
  1990.     if(SYMBOLP(arg))
  1991.     {
  1992.     if(!(arg = VSYM(arg)->sym_Function))
  1993.         return(sym_nil);
  1994.     }
  1995.     switch(VTYPE(arg))
  1996.     {
  1997.     case V_Subr0:
  1998.     case V_Subr1:
  1999.     case V_Subr2:
  2000.     case V_Subr3:
  2001.     case V_Subr4:
  2002.     case V_Subr5:
  2003.     case V_SubrN:
  2004.     return(sym_t);
  2005.     case V_Cons:
  2006.     arg = VCAR(arg);
  2007.     if((arg == sym_lambda) || (arg == sym_autoload))
  2008.         return(sym_t);
  2009.     /* FALL THROUGH */
  2010.     default:
  2011.     return(sym_nil);
  2012.     }
  2013. }
  2014.  
  2015. _PR VALUE cmd_special_form_p(VALUE);
  2016. DEFUN("special-form-p", cmd_special_form_p, subr_special_form_p, (VALUE arg), V_Subr1, DOC_special_form_p) /*
  2017. ::doc:special_form_p::
  2018. special-form-p ARG
  2019.  
  2020. Returns t if ARG is a special-form.
  2021. ::end:: */
  2022. {
  2023.     if(SYMBOLP(arg))
  2024.     {
  2025.     if(!(arg = VSYM(arg)->sym_Function))
  2026.          return(sym_nil);
  2027.     }
  2028.     if(VTYPEP(arg, V_SF))
  2029.     return(sym_t);
  2030.     return(sym_nil);
  2031. }
  2032.  
  2033. _PR VALUE cmd_subrp(VALUE arg);
  2034. DEFUN("subrp", cmd_subrp, subr_subrp, (VALUE arg), V_Subr1, DOC_subrp) /*
  2035. ::doc:subrp::
  2036. subrp ARG
  2037.  
  2038. Returns t if arg is a primitive function.
  2039. ::end:: */
  2040. {
  2041.     switch(VTYPE(arg))
  2042.     {
  2043.     case V_Subr0:
  2044.     case V_Subr1:
  2045.     case V_Subr2:
  2046.     case V_Subr3:
  2047.     case V_Subr4:
  2048.     case V_Subr5:
  2049.     case V_SubrN:
  2050.     case V_SF:
  2051.     case V_Var:
  2052.     return(sym_t);
  2053.     default:
  2054.     return(sym_nil);
  2055.     }
  2056. }
  2057.  
  2058. _PR VALUE cmd_sequencep(VALUE arg);
  2059. DEFUN("sequencep", cmd_sequencep, subr_sequencep, (VALUE arg), V_Subr1, DOC_sequencep) /*
  2060. ::doc:sequencep::
  2061. sequencep ARG
  2062.  
  2063. Returns t is ARG is a sequence (a list, vector or string).
  2064. ::end:: */
  2065. {
  2066.     if(NILP(arg) || CONSP(arg) || VECTORP(arg) || STRINGP(arg))
  2067.     return(sym_t);
  2068.     return(sym_nil);
  2069. }
  2070.  
  2071. _PR VALUE cmd_subr_documentation(VALUE subr, VALUE useVar);
  2072. DEFUN("subr-documentation", cmd_subr_documentation, subr_subr_documentation, (VALUE subr, VALUE useVar), V_Subr2, DOC_subr_documentation) /*
  2073. ::doc:subr_documentation::
  2074. subr-documentation SUBR [USE-VAR]
  2075.  
  2076. Returns the doc-string associated with SUBR.
  2077. ::end:: */
  2078. {
  2079.     if(SYMBOLP(subr))
  2080.     {
  2081.     if(NILP(useVar))
  2082.     {
  2083.         if(VSYM(subr)->sym_Function)
  2084.         subr = VSYM(subr)->sym_Function;
  2085.     }
  2086.     else
  2087.     {
  2088.         if(VSYM(subr)->sym_Value)
  2089.         subr = VSYM(subr)->sym_Value;
  2090.     }
  2091.     }
  2092.     switch(VTYPE(subr))
  2093.     {
  2094.     case V_Subr0:
  2095.     case V_Subr1:
  2096.     case V_Subr2:
  2097.     case V_Subr3:
  2098.     case V_Subr4:
  2099.     case V_Subr5:
  2100.     case V_SubrN:
  2101.     case V_SF:
  2102.     case V_Var:
  2103.     return(cmd_read_file_from_to(MKSTR(DOC_FILE),
  2104.                      make_number(VSUBR(subr)->subr_DocIndex),
  2105.                      make_number((int)'\f')));
  2106.     default:
  2107.     return(sym_nil);
  2108.     }
  2109. }
  2110.  
  2111. _PR VALUE cmd_subr_name(VALUE subr, VALUE useVar);
  2112. DEFUN("subr-name", cmd_subr_name, subr_subr_name, (VALUE subr, VALUE useVar), V_Subr2, DOC_subr_name) /*
  2113. ::doc:subr_name::
  2114. subr-name SUBR [USE-VAR]
  2115.  
  2116. Returns the name (a string) associated with SUBR.
  2117. ::end:: */
  2118. {
  2119.     if(SYMBOLP(subr))
  2120.     {
  2121.     if(NILP(useVar))
  2122.     {
  2123.         if(VSYM(subr)->sym_Function)
  2124.         subr = VSYM(subr)->sym_Function;
  2125.     }
  2126.     else
  2127.     {
  2128.         if(VSYM(subr)->sym_Value)
  2129.         subr = VSYM(subr)->sym_Value;
  2130.     }
  2131.     }
  2132.     switch(VTYPE(subr))
  2133.     {
  2134.     case V_Subr0:
  2135.     case V_Subr1:
  2136.     case V_Subr2:
  2137.     case V_Subr3:
  2138.     case V_Subr4:
  2139.     case V_Subr5:
  2140.     case V_SubrN:
  2141.     case V_SF:
  2142.     case V_Var:
  2143.     return(VSUBR(subr)->subr_Name);
  2144.     default:
  2145.     return(sym_nil);
  2146.     }
  2147. }
  2148.  
  2149. _PR VALUE cmd_eval_hook(VALUE);
  2150. DEFUN("eval-hook", cmd_eval_hook, subr_eval_hook, (VALUE args), V_SubrN, DOC_eval_hook) /*
  2151. ::doc:eval_hook::
  2152. eval-hook HOOK ARGS...
  2153.  
  2154. Evaluate the hook, HOOK (a symbol), with arguments ARGS
  2155.  
  2156. The way hooks work is that the hook-symbol's value is a list of functions
  2157. to call. Each function in turn is called with ARGS until one returns non-nil,
  2158. this non-nil value is then the result of `eval-hook'. If all functions return
  2159. nil then `eval-hook' returns nil.
  2160. ::end:: */
  2161. {
  2162.     if(CONSP(args))
  2163.     {
  2164.     VALUE hook = VCAR(args);
  2165.     VALUE alist = VCDR(args);
  2166.     VALUE res = sym_nil;
  2167.     GCVAL gcv_alist, gcv_hook;
  2168.     PUSHGC(gcv_alist, alist);
  2169.     switch(VTYPE(hook))
  2170.     {
  2171.     case V_StaticString:
  2172.     case V_DynamicString:
  2173.         if(!(hook = cmd_find_symbol(hook, sym_nil)))
  2174.         goto end;
  2175.         /* FALL THROUGH */
  2176.     case V_Symbol:
  2177.         hook = cmd_symbol_value(hook, sym_t);
  2178.         if(VOIDP(hook))
  2179.         goto end;
  2180.         break;
  2181.     }
  2182.     PUSHGC(gcv_hook, hook);
  2183.     while(res && NILP(res) && CONSP(hook))
  2184.     {
  2185.         res = funcall(VCAR(hook), alist);
  2186.         hook = VCDR(hook);
  2187.         TEST_INT;
  2188.         if(INT_P)
  2189.         res = NULL;
  2190.     }
  2191.     POPGC;
  2192. end:
  2193.     POPGC;
  2194.     return(res);
  2195.     }
  2196.     return(NULL);
  2197. }
  2198.  
  2199. _PR VALUE cmd_eval_hook2(VALUE hook, VALUE arg);
  2200. DEFUN("eval-hook2", cmd_eval_hook2, subr_eval_hook2, (VALUE hook, VALUE arg), V_Subr2, DOC_eval_hook2) /*
  2201. ::doc:eval_hook2::
  2202. eval-hook2 HOOK ARG
  2203.  
  2204. Similar to `eval-hook', the only reason this function exists is because it
  2205. is easier to call a 2-argument function from C than an N-argument function.
  2206. ::end:: */
  2207. {
  2208.     VALUE res = sym_nil, alist;
  2209.     /* Not possible to use GCVAL's since this is often called from C code
  2210.        which may not be protected.  */
  2211.     int oldgci = gc_inhibit;
  2212.     if(!(alist = cmd_cons(arg, sym_nil)))
  2213.     return(NULL);
  2214.     gc_inhibit = TRUE;
  2215.     switch(VTYPE(hook))
  2216.     {
  2217.     case V_StaticString:
  2218.     case V_DynamicString:
  2219.     if(!(hook = cmd_find_symbol(hook, sym_nil)))
  2220.         goto end;
  2221.     /* FALL THROUGH */
  2222.     case V_Symbol:
  2223.     hook = cmd_symbol_value(hook, sym_t);
  2224.     if(VOIDP(hook))
  2225.         goto end;
  2226.     break;
  2227.     }
  2228.     while(res && NILP(res) && CONSP(hook))
  2229.     {
  2230.     res = funcall(VCAR(hook), alist);
  2231.     hook = VCDR(hook);
  2232.     TEST_INT;
  2233.     if(INT_P)
  2234.         res = NULL;
  2235.     }
  2236. end:
  2237.     gc_inhibit = oldgci;
  2238.     return(res);
  2239. }
  2240.  
  2241. _PR VALUE cmd_catch(VALUE);
  2242. DEFUN("catch", cmd_catch, subr_catch, (VALUE args), V_SF, DOC_catch) /*
  2243. ::doc:catch::
  2244. catch TAG FORMS...
  2245.  
  2246. Evaluates FORMS, non-local exits are allowed with `(throw TAG)'.
  2247. The value of `catch' is either the value of the last FORM or the
  2248. value given to the throw command.
  2249.  
  2250. There are several pre-defined `catch'es which are,
  2251.   'defun
  2252.      Around all defuns, the `return' command uses this, it basically does
  2253.      (throw 'defun X).
  2254.   'exit
  2255.      Exits one level of recursive-editing (but doesn't work in the top
  2256.      level.
  2257.   'top-level
  2258.      At the top-level recursive-edit (ie, the one which you're in when
  2259.      the editor is started).
  2260.   'quit
  2261.      Kills the editor.
  2262. ::end:: */
  2263.     /* Non-local exits don't bother with jmp_buf's and the like, they just
  2264.        unwind normally through all levels of recursion with a NULL result.
  2265.        This is slow but it's easy to work with.  */
  2266. {
  2267.     if(CONSP(args))
  2268.     {
  2269.     VALUE tag, res = NULL;
  2270.     GCVAL gcv_args, gcv_tag;
  2271.     PUSHGC(gcv_args, args);
  2272.     tag = cmd_eval(VCAR(args));
  2273.     if(tag)
  2274.     {
  2275.         PUSHGC(gcv_tag, tag);
  2276.         if(!(res = cmd_progn(VCDR(args))))
  2277.         {
  2278.         if(throw_value && (VCAR(throw_value) == tag))
  2279.         {
  2280.             res = VCDR(throw_value);
  2281.             throw_value = NULL;
  2282.         }
  2283.         }
  2284.         POPGC;
  2285.     }
  2286.     POPGC;
  2287.     return(res);
  2288.     }
  2289.     return(NULL);
  2290. }
  2291.  
  2292. _PR VALUE cmd_throw(VALUE, VALUE);
  2293. DEFUN("throw", cmd_throw, subr_throw, (VALUE tag, VALUE val), V_Subr2, DOC_throw) /*
  2294. ::doc:throw::
  2295. throw TAG VALUE
  2296.  
  2297. Performs a non-local exit to the `catch' waiting for TAG and return
  2298. VALUE from it. TAG and VALUE are both evaluated fully.
  2299. ::end:: */
  2300. {
  2301.     /* Only one thing can use `throw_value' at once.  */
  2302.     if(!throw_value)
  2303.     throw_value = cmd_cons(tag, val);
  2304.     return(NULL);
  2305. }
  2306.  
  2307. _PR VALUE cmd_return(VALUE);
  2308. DEFUN("return", cmd_return, subr_return, (VALUE arg), V_Subr1, DOC_return) /*
  2309. ::doc:return::
  2310. return [VALUE]
  2311.  
  2312. Arranges it so that the innermost defun returns VALUE (or nil) as its result.
  2313. ::end:: */
  2314. {
  2315.     if(!throw_value)
  2316.     throw_value = cmd_cons(sym_defun, arg);
  2317.     return(NULL);
  2318. }
  2319.  
  2320. _PR VALUE cmd_unwind_protect(VALUE);
  2321. DEFUN("unwind-protect", cmd_unwind_protect, subr_unwind_protect, (VALUE args), V_SF, DOC_unwind_protect) /*
  2322. ::doc:unwind_protect::
  2323. unwind-protect BODY CLEANUP-FORMS...
  2324.  
  2325. Eval and return the value of BODY guaranteeing that the CLEANUP-FORMS will
  2326. be evalled no matter what happens (ie, error, non-local exit, etc) while
  2327. BODY is being evaluated.
  2328. ::end:: */
  2329. {
  2330.     if(CONSP(args))
  2331.     {
  2332.     VALUE res, throwval;
  2333.     GCVAL gcv_args, gcv_res, gcv_throwval;
  2334.     PUSHGC(gcv_args, args);
  2335.     res = cmd_eval(VCAR(args));
  2336.     PUSHGC(gcv_res, res);
  2337.     throwval = throw_value;
  2338.     throw_value = NULL;
  2339.     PUSHGC(gcv_throwval, throwval);
  2340.     if(!cmd_progn(VCDR(args)))
  2341.         res = NULL;
  2342.     throw_value = throwval;
  2343.     POPGC; POPGC; POPGC;
  2344.     return(res);
  2345.     }
  2346.     return(NULL);
  2347. }
  2348.  
  2349. void
  2350. lispcmds_init(void)
  2351. {
  2352.     ADD_SUBR(subr_quote);
  2353.     ADD_SUBR(subr_function);
  2354.     ADD_SUBR(subr_defmacro);
  2355.     ADD_SUBR(subr_defun);
  2356.     ADD_SUBR(subr_defvar);
  2357.     ADD_SUBR(subr_defconst);
  2358.     ADD_SUBR(subr_car);
  2359.     ADD_SUBR(subr_cdr);
  2360.     ADD_SUBR(subr_list);
  2361.     ADD_SUBR(subr_make_list);
  2362.     ADD_SUBR(subr_append);
  2363.     ADD_SUBR(subr_nconc);
  2364.     ADD_SUBR(subr_rplaca);
  2365.     ADD_SUBR(subr_rplacd);
  2366.     ADD_SUBR(subr_reverse);
  2367.     ADD_SUBR(subr_nreverse);
  2368.     ADD_SUBR(subr_assoc);
  2369.     ADD_SUBR(subr_assq);
  2370.     ADD_SUBR(subr_rassoc);
  2371.     ADD_SUBR(subr_rassq);
  2372.     ADD_SUBR(subr_nth);
  2373.     ADD_SUBR(subr_nthcdr);
  2374.     ADD_SUBR(subr_last);
  2375.     ADD_SUBR(subr_mapcar);
  2376.     ADD_SUBR(subr_mapc);
  2377.     ADD_SUBR(subr_member);
  2378.     ADD_SUBR(subr_memq);
  2379.     ADD_SUBR(subr_delete);
  2380.     ADD_SUBR(subr_delq);
  2381.     ADD_SUBR(subr_delete_if);
  2382.     ADD_SUBR(subr_delete_if_not);
  2383.     ADD_SUBR(subr_vector);
  2384.     ADD_SUBR(subr_make_vector);
  2385.     ADD_SUBR(subr_arrayp);
  2386.     ADD_SUBR(subr_aset);
  2387.     ADD_SUBR(subr_aref);
  2388.     ADD_SUBR(subr_make_string);
  2389.     ADD_SUBR(subr_concat);
  2390.     ADD_SUBR(subr_length);
  2391.     ADD_SUBR(subr_copy_sequence);
  2392.     ADD_SUBR(subr_elt);
  2393.     ADD_SUBR(subr_prog1);
  2394.     ADD_SUBR(subr_prog2);
  2395.     ADD_SUBR(subr_while);
  2396.     ADD_SUBR(subr_if);
  2397.     ADD_SUBR(subr_when);
  2398.     ADD_SUBR(subr_unless);
  2399.     ADD_SUBR(subr_cond);
  2400.     ADD_SUBR(subr_apply);
  2401.     ADD_SUBR(subr_load);
  2402.     ADD_SUBR(subr_plus);
  2403.     ADD_SUBR(subr_minus);
  2404.     ADD_SUBR(subr_product);
  2405.     ADD_SUBR(subr_divide);
  2406.     ADD_SUBR(subr_remainder);
  2407.     ADD_SUBR(subr_lognot);
  2408.     ADD_SUBR(subr_not);
  2409.     ADD_SUBR(subr_logior);
  2410.     ADD_SUBR(subr_logxor);
  2411.     ADD_SUBR(subr_or);
  2412.     ADD_SUBR(subr_logand);
  2413.     ADD_SUBR(subr_and);
  2414.     ADD_SUBR(subr_equal);
  2415.     ADD_SUBR(subr_eq);
  2416.     ADD_SUBR(subr_eql);
  2417.     ADD_SUBR(subr_string_head_eq);
  2418.     ADD_SUBR(subr_num_eq);
  2419.     ADD_SUBR(subr_num_noteq);
  2420.     ADD_SUBR(subr_gtthan);
  2421.     ADD_SUBR(subr_gethan);
  2422.     ADD_SUBR(subr_ltthan);
  2423.     ADD_SUBR(subr_lethan);
  2424.     ADD_SUBR(subr_plus1);
  2425.     ADD_SUBR(subr_sub1);
  2426.     ADD_SUBR(subr_lsh);
  2427.     ADD_SUBR(subr_ash);
  2428.     ADD_SUBR(subr_zerop);
  2429.     ADD_SUBR(subr_null);
  2430.     ADD_SUBR(subr_atom);
  2431.     ADD_SUBR(subr_consp);
  2432.     ADD_SUBR(subr_listp);
  2433.     ADD_SUBR(subr_numberp);
  2434.     ADD_SUBR(subr_integerp);
  2435.     ADD_SUBR(subr_stringp);
  2436.     ADD_SUBR(subr_vectorp);
  2437.     ADD_SUBR(subr_functionp);
  2438.     ADD_SUBR(subr_special_form_p);
  2439.     ADD_SUBR(subr_subrp);
  2440.     ADD_SUBR(subr_subr_documentation);
  2441.     ADD_SUBR(subr_sequencep);
  2442.     ADD_SUBR(subr_subr_name);
  2443.     ADD_SUBR(subr_eval_hook);
  2444.     ADD_SUBR(subr_eval_hook2);
  2445.     ADD_SUBR(subr_catch);
  2446.     ADD_SUBR(subr_throw);
  2447.     ADD_SUBR(subr_return);
  2448.     ADD_SUBR(subr_unwind_protect);
  2449.     INTERN(sym_load_path, "load-path");
  2450.     VSYM(sym_load_path)->sym_Value = list_2(null_string, MKSTR(LISP_LIB_DIR));
  2451.     DOC_VAR(sym_load_path, DOC_load_path);
  2452.     INTERN(sym_lisp_lib_dir, "lisp-lib-dir");
  2453.     VSYM(sym_lisp_lib_dir)->sym_Value = MKSTR(LISP_LIB_DIR);
  2454.     DOC_VAR(sym_lisp_lib_dir, DOC_lisp_lib_dir);
  2455. }
  2456.