1 /* lispcmds.c -- Lots of standard Lisp functions
2 Copyright (C) 1993, 1994 John Harper <john@dcs.warwick.ac.uk>
3 $Id$
4
5 This file is part of Jade.
6
7 Jade is free software; you can redistribute it and/or modify it
8 under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
10 any later version.
11
12 Jade is distributed in the hope that it will be useful, but
13 WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with Jade; see the file COPYING. If not, write to
19 the Free Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */
20
21 #define _GNU_SOURCE
22
23 #include "repint.h"
24 #include "build.h"
25
26 #include <string.h>
27 #include <stdlib.h>
28 #include <ctype.h>
29 #include <assert.h>
30
31 #ifdef NEED_MEMORY_H
32 # include <memory.h>
33 #endif
34
35 DEFSTRING(default_rep_directory, REP_DIRECTORY);
36 DEFSTRING(dot, ".");
37
38 static repv default_suffixes;
39
40 DEFSYM(or, "or");
41 DEFSYM(and, "and");
42 DEFSYM(load_path, "load-path");
43 DEFSYM(dl_load_path, "dl-load-path");
44 DEFSYM(after_load_alist, "after-load-alist");
45 DEFSYM(provide, "provide");
46 DEFSYM(rep_directory, "rep-directory");
47 DEFSYM(lisp_lib_directory, "lisp-lib-directory");
48 DEFSYM(site_lisp_directory, "site-lisp-directory");
49 DEFSYM(exec_directory, "exec-directory");
50 DEFSYM(documentation_file, "documentation-file");
51 DEFSYM(documentation_files, "documentation-files");
52 DEFSYM(_load_suffixes, "%load-suffixes");
53 DEFSYM(dl_load_reloc_now, "dl-load-reloc-now");
54 DEFSYM(load_filename, "load-filename"); /*
55 ::doc:load-path::
56 A list of directory names. When `load' opens a lisp-file it searches each
57 directory named in this list in turn until the file is found or the list
58 is exhausted.
59 ::end::
60 ::doc:dl-load-path::
61 List of directories searched for dynamically loaded object files.
62 ::end::
63 ::doc:after-load-alist::
64 A list of (LIBRARY FORMS...). Whenever the `load' command reads a file
65 of Lisp code LIBRARY, it executes each of FORMS. Note that LIBRARY must
66 exactly match the FILE argument given to `load'.
67 ::end::
68 ::doc:rep-directory::
69 The directory in which all installed data files live.
70 ::end::
71 ::doc:lisp-lib-directory::
72 The name of the directory in which the standard lisp files live.
73 ::end::
74 ::doc:site-lisp-directory::
75 The name of the directory in which site-specific Lisp files are stored.
76 ::end::
77 ::doc:exec-directory::
78 The name of the directory containing architecture specific files.
79 ::end::
80 ::doc:documentation-file::
81 The name of the database containing the lisp-library's documentation strings.
82 ::end::
83 ::doc:documentation-files::
84 A list of database names containing all documentation strings.
85 ::end::
86 ::doc:dl-load-reloc-now::
87 When non-nil, dynamically loaded libraries have all symbol relocations
88 perfromed at load-time, not as required.
89 ::end::
90 ::doc:load-filename::
91 While using the `load' function to load a Lisp library, this variable is
92 set to the name of the file being loaded.
93 ::end:: */
94
95 DEFUN("quote", Fquote, Squote, (repv args, repv tail_posn), rep_SF) /*
96 ::doc:rep.lang.interpreter#quote::
97 quote ARG
98 'ARG
99
100 Returns ARG.
101 ::end:: */
102 {
103 if(rep_CONSP(args))
104 return(rep_CAR(args));
105 return rep_signal_missing_arg(1);
106 }
107
108 DEFUN("lambda", Flambda, Slambda, (repv args, repv tail_posn), rep_SF) /*
109 ::doc:rep.lang.interpreter#lambda::
110 lambda LAMBDA-LIST BODY...
111
112 Evaluates to an anonymous function.
113 ::end:: */
114 {
115 if(rep_CONSP(args))
116 return Fmake_closure (Fcons (Qlambda, args), Qnil);
117 else
118 return rep_signal_missing_arg(1);
119 }
120
121 DEFUN("car", Fcar, Scar, (repv cons), rep_Subr1) /*
122 ::doc:rep.data#car::
123 car CONS-CELL
124
125 Returns the value stored in the car slot of CONS-CELL, or nil if CONS-CELL
126 is nil.
127 ::end:: */
128 {
129 if(rep_CONSP(cons))
130 return(rep_CAR(cons));
131 return(Qnil);
132 }
133 DEFUN("cdr", Fcdr, Scdr, (repv cons), rep_Subr1) /*
134 ::doc:rep.data#cdr::
135 cdr CONS-CELL
136
137 Returns the value stored in the cdr slot of CONS-CELL, or nil if CONS-CELL
138 is nil.
139 ::end:: */
140 {
141 if(rep_CONSP(cons))
142 return(rep_CDR(cons));
143 return(Qnil);
144 }
145
146 DEFUN("list", Flist, Slist, (int argc, repv *argv), rep_SubrV) /*
147 ::doc:rep.data#list::
148 list ARGS...
149
150 Returns a new list with elements ARGS...
151 ::end:: */
152 {
153 repv lst = Qnil;
154 int i;
155
156 for (i = argc - 1; i >= 0; i--)
157 {
158 lst = Fcons (argv[i], lst);
159 }
160
161 return lst;
162 }
163
164 DEFUN("list*", Flist_star, Slist_star, (int argc, repv *argv), rep_SubrV) /*
165 ::doc:rep.data#list*::
166 list* ARG1 ARG2 ... ARGN
167
168 Returns a new list (ARG1 ARG2 ... ARGN-1 . ARGN). That is, the same as from
169 `list' but the last argument is dotted to the last but one argument.
170 ::end:: */
171 {
172 repv lst;
173 int i;
174
175 if (argc == 0)
176 return Qnil;
177
178 lst = argv[argc - 1];
179 for (i = argc - 2; i >= 0; i--)
180 {
181 lst = Fcons (argv[i], lst);
182 }
183
184 return lst;
185 }
186
187 DEFUN("make-list", Fmake_list, Smake_list, (repv len, repv init), rep_Subr2) /*
188 ::doc:rep.data#make-list::
189 make-list LENGTH [INITIAL-repv]
190
191 Returns a new list with LENGTH members, each of which is initialised to
192 INITIAL-repv, or nil.
193 ::end:: */
194 {
195 int i;
196 repv list = Qnil;
197 rep_DECLARE1(len, rep_INTP);
198 if(rep_INT(len) < 0)
199 return rep_signal_arg_error(len, 1);
200 for(i = 0; list != rep_NULL && i < rep_INT(len); i++)
201 list = Fcons(init, list);
202 return(list);
203 }
204
205 DEFUN("append", Fappend, Sappend, (int argc, repv *argv), rep_SubrV) /*
206 ::doc:rep.data#append::
207 append LISTS...
208
209 Non-destructively concatenates each of it's argument LISTS... into one
210 new list which is returned.
211 ::end:: */
212 {
213 int i;
214 repv res = Qnil, *res_end = &res;
215
216 for (i = 0; i < argc; i++)
217 {
218 if (i != argc - 1)
219 {
220 if (!rep_LISTP(argv[i]))
221 return rep_signal_arg_error (argv[i], i + 1);
222
223 /* Only make a new copy if there's another list after this one. */
224 *res_end = rep_copy_list (argv[i]);
225 }
226 else
227 *res_end = argv[i];
228
229 while (rep_CONSP (*res_end))
230 {
231 rep_TEST_INT;
232 if (rep_INTERRUPTP)
233 return rep_NULL;
234 res_end = rep_CDRLOC (*res_end);
235 }
236 }
237
238 return res;
239 }
240
241 DEFUN("nconc", Fnconc_, Snconc, (int argc, repv *argv), rep_SubrV) /*
242 ::doc:rep.data#nconc::
243 nconc LISTS...
244
245 Destructively concatenates each of it's argument LISTS... into one new
246 list. Every LIST but the last is modified so that it's last cdr points
247 to the beginning of the next list. Returns the new list.
248 ::end:: */
249 {
250 int i;
251 repv res = Qnil, *res_end = &res;
252
253 for (i = 0; i < argc; i++)
254 {
255 if (i != argc - 1)
256 {
257 if (!rep_LISTP (argv[i]))
258 return rep_signal_arg_error (argv[i], i + 1);
259
260 if (!rep_CONS_WRITABLE_P (argv[i]))
261 return Fsignal (Qsetting_constant, rep_LIST_1 (argv[i]));
262 }
263
264 *res_end = argv[i];
265
266 while (rep_CONSP (*res_end))
267 {
268 rep_TEST_INT;
269 if (rep_INTERRUPTP)
270 return rep_NULL;
271 res_end = rep_CDRLOC (*res_end);
272 }
273 }
274
275 return res;
276 }
277
278 DEFUN("rplaca", Frplaca, Srplaca, (repv cons, repv car), rep_Subr2) /*
279 ::doc:rep.data#rplaca::
280 rplaca CONS-CELL NEW-CAR
281
282 Sets the value of the car slot in CONS-CELL to NEW-CAR.
283 Returns the CONS-CELL.
284 ::end:: */
285 {
286 rep_DECLARE1(cons, rep_CONSP);
287 if(!rep_CONS_WRITABLE_P(cons))
288 return Fsignal(Qsetting_constant, rep_LIST_1(cons));
289 rep_CAR(cons) = car;
290 return(cons);
291 }
292
293 DEFUN("rplacd", Frplacd, Srplacd, (repv cons, repv cdr), rep_Subr2) /*
294 ::doc:rep.data#rplacd::
295 rplacd CONS-CELL NEW-CDR
296
297 Sets the value of the cdr slot in CONS-CELL to NEW-CDR.
298 Returns the CONS-CELL.
299 ::end:: */
300 {
301 rep_DECLARE1(cons, rep_CONSP);
302 if(!rep_CONS_WRITABLE_P(cons))
303 return Fsignal(Qsetting_constant, rep_LIST_1(cons));
304 rep_CDR(cons) = cdr;
305 return(cons);
306 }
307
308 DEFUN("reverse", Freverse, Sreverse, (repv head), rep_Subr1) /*
309 ::doc:rep.data#reverse::
310 reverse LIST
311
312 Returns a new list which is a copy of LIST except that the members are in
313 reverse order.
314 ::end:: */
315 {
316 repv res = Qnil;
317 rep_DECLARE1(head, rep_LISTP);
318 while(rep_CONSP(head))
319 {
320 res = Fcons(rep_CAR(head), res);
321 head = rep_CDR(head);
322 rep_TEST_INT;
323 if(res == rep_NULL || rep_INTERRUPTP)
324 return(rep_NULL);
325 }
326 return(res);
327 }
328
329 DEFUN("nreverse", Fnreverse, Snreverse, (repv head), rep_Subr1) /*
330 ::doc:rep.data#nreverse::
331 nreverse LIST
332
333 Returns LIST altered so that it's members are in reverse order to what they
334 were. This function is destructive towards it's argument.
335 ::end:: */
336 {
337 repv res = Qnil;
338 repv nxt;
339 rep_DECLARE1(head, rep_LISTP);
340 if(rep_NILP(head))
341 return(head);
342 if(!rep_CONS_WRITABLE_P(head))
343 return Fsignal(Qsetting_constant, rep_LIST_1(head));
344 do {
345 if(rep_CONSP(rep_CDR(head)))
346 nxt = rep_CDR(head);
347 else
348 nxt = rep_NULL;
349 rep_CDR(head) = res;
350 res = head;
351 rep_TEST_INT;
352 if(rep_INTERRUPTP)
353 return(rep_NULL);
354 } while((head = nxt) != rep_NULL);
355 return(res);
356 }
357
358 DEFUN("assoc", Fassoc, Sassoc, (repv elt, repv list), rep_Subr2) /*
359 ::doc:rep.data#assoc::
360 assoc ELT ASSOC-LIST
361
362 Searches ASSOC-LIST for a list whose first element is ELT. `assoc' uses
363 `equal' to compare elements. Returns the sub-list starting from the first
364 matching association.
365 For example,
366 (assoc 'three '((one . 1) (two . 2) (three . 3) (four . 4)))
367 => (three . 3)
368 ::end:: */
369 {
370 rep_DECLARE2(list, rep_LISTP);
371 while(rep_CONSP(list))
372 {
373 register repv car = rep_CAR(list);
374 if(rep_CONSP(car) && (!rep_value_cmp(elt, rep_CAR(car))))
375 return(car);
376 list = rep_CDR(list);
377 rep_TEST_INT;
378 if(rep_INTERRUPTP)
379 return(rep_NULL);
380 }
381 return(Qnil);
382 }
383
384 DEFUN("assq", Fassq, Sassq, (repv elt, repv list), rep_Subr2) /*
385 ::doc:rep.data#assq::
386 assq ELT ASSOC-LIST
387
388 Searches ASSOC-LIST for a list whose first element is ELT. `assq' uses `eq'
389 to compare elements. Returns the sub-list starting from the first matching
390 association.
391 ::end:: */
392 {
393 rep_DECLARE2(list, rep_LISTP);
394 while(rep_CONSP(list))
395 {
396 register repv car = rep_CAR(list);
397 if(rep_CONSP(car) && (elt == rep_CAR(car)))
398 return(car);
399 list = rep_CDR(list);
400 rep_TEST_INT;
401 if(rep_INTERRUPTP)
402 return(rep_NULL);
403 }
404 return(Qnil);
405 }
406
407 DEFUN("rassoc", Frassoc, Srassoc, (repv elt, repv list), rep_Subr2) /*
408 ::doc:rep.data#rassoc::
409 rassoc ELT ASSOC-LIST
410
411 Searches ASSOC-LIST for a cons-cell whose cdr element is `equal' to ELT.
412 Returns the first cons-cell which matches, or nil.
413 For example,
414 (rassoc 3 '((one . 1) (two . 2) (three . 3) (four . 4)))
415 => (three . 3)
416 ::end:: */
417 {
418 rep_DECLARE2(list, rep_LISTP);
419 while(rep_CONSP(list))
420 {
421 register repv car = rep_CAR(list);
422 if(rep_CONSP(car) && (!rep_value_cmp(elt, rep_CDR(car))))
423 return(car);
424 list = rep_CDR(list);
425 rep_TEST_INT;
426 if(rep_INTERRUPTP)
427 return(rep_NULL);
428 }
429 return(Qnil);
430 }
431
432 DEFUN("rassq", Frassq, Srassq, (repv elt, repv list), rep_Subr2) /*
433 ::doc:rep.data#rassq::
434 rassq ELT ASSOC-LIST
435
436 Searches ASSOC-LIST for a cons-cell whose cdr is `eq' to ELT.
437 Returns the first matching cons-cell, else nil.
438 ::end:: */
439 {
440 rep_DECLARE2(list, rep_LISTP);
441 while(rep_CONSP(list))
442 {
443 register repv car = rep_CAR(list);
444 if(rep_CONSP(car) && (elt == rep_CDR(car)))
445 return(car);
446 list = rep_CDR(list);
447 rep_TEST_INT;
448 if(rep_INTERRUPTP)
449 return(rep_NULL);
450 }
451 return(Qnil);
452 }
453
454 DEFUN("nth", Fnth, Snth, (repv index, repv list), rep_Subr2) /*
455 ::doc:rep.data#nth::
456 nth INDEX LIST
457
458 Returns the INDEXth element of LIST. The first element has an INDEX of zero.
459 ::end:: */
460 {
461 int i;
462 rep_DECLARE1(index, rep_INTP);
463 rep_DECLARE2(list, rep_LISTP);
464 i = rep_INT(index);
465 if(i < 0)
466 return rep_signal_arg_error(index, 1);
467 while((i-- > 0) && rep_CONSP(list))
468 {
469 list = rep_CDR(list);
470 rep_TEST_INT;
471 if(rep_INTERRUPTP)
472 return rep_NULL;
473 }
474 return (i <= 0 && rep_CONSP(list)) ? rep_CAR(list) : Qnil;
475 }
476
477 DEFUN("nthcdr", Fnthcdr, Snthcdr, (repv index, repv list), rep_Subr2) /*
478 ::doc:rep.data#nthcdr::
479 nthcdr INDEX LIST
480
481 Returns the INDEXth cdr of LIST. The first is INDEX zero.
482 ::end:: */
483 {
484 int i;
485 rep_DECLARE1(index, rep_INTP);
486 rep_DECLARE2(list, rep_LISTP);
487 i = rep_INT(index);
488 if(i < 0)
489 return rep_signal_arg_error(index, 1);
490 while((i-- > 0) && rep_CONSP(list))
491 {
492 list = rep_CDR(list);
493 rep_TEST_INT;
494 if(rep_INTERRUPTP)
495 return rep_NULL;
496 }
497 return list;
498 }
499
500 DEFUN("last", Flast, Slast, (repv list), rep_Subr1) /*
501 ::doc:rep.data#last::
502 last LIST
503
504 Returns the last element of LIST.
505 ::end:: */
506 {
507 rep_DECLARE1(list, rep_LISTP);
508 if(rep_CONSP(list))
509 {
510 while(rep_CONSP(rep_CDR(list)))
511 {
512 list = rep_CDR(list);
513 rep_TEST_INT;
514 if(rep_INTERRUPTP)
515 return(rep_NULL);
516 }
517 return(rep_CAR(list));
518 }
519 return(Qnil);
520 }
521
522 DEFUN("mapcar", Fmapcar, Smapcar, (repv fun, repv list), rep_Subr2) /*
523 ::doc:rep.data#mapcar::
524 mapcar FUNCTION LIST
525
526 Calls FUNCTION-NAME with each element of LIST as an argument in turn and
527 returns a new list constructed from the results, ie,
528 (mapcar (function (lambda (x) (1+ x))) '(1 2 3))
529 => (2 3 4)
530 ::end:: */
531 {
532 repv res = Qnil;
533 repv *last = &res;
534 rep_GC_root gc_list, gc_fun, gc_res;
535 rep_DECLARE2(list, rep_LISTP);
536
537 rep_PUSHGC(gc_res, res);
538 rep_PUSHGC(gc_fun, fun);
539 rep_PUSHGC(gc_list, list);
540 while(res != rep_NULL && rep_CONSP(list))
541 {
542 rep_TEST_INT;
543 if(rep_INTERRUPTP
544 || !(*last = Fcons(Qnil, Qnil))
545 || !(rep_CAR(*last) = rep_call_lisp1(fun, rep_CAR(list))))
546 res = rep_NULL;
547 else
548 {
549 last = &rep_CDR(*last);
550 list = rep_CDR(list);
551 }
552 }
553 rep_POPGC; rep_POPGC; rep_POPGC;
554 return res;
555 }
556
557 DEFUN("mapc", Fmapc, Smapc, (repv fun, repv list), rep_Subr2) /*
558 ::doc:rep.data#mapc::
559 mapc FUNCTION LIST
560
561 Applies FUNCTION to each element in LIST, discards the results.
562 ::end:: */
563 {
564 repv res = Qnil;
565 rep_GC_root gc_fun, gc_list;
566 rep_DECLARE2(list, rep_LISTP);
567 rep_PUSHGC(gc_fun, fun);
568 rep_PUSHGC(gc_list, list);
569 while(res != rep_NULL && rep_CONSP(list))
570 {
571 rep_TEST_INT;
572 if(rep_INTERRUPTP || !rep_call_lisp1(fun, rep_CAR(list)))
573 res = rep_NULL;
574 list = rep_CDR(list);
575 }
576 rep_POPGC; rep_POPGC;
577 return res;
578 }
579
580 DEFUN("filter", Ffilter, Sfilter, (repv pred, repv list), rep_Subr2) /*
581 ::doc:rep.data#filter::
582 filter PREDICATE LIST
583
584 Return a new list, consisting of the elements in LIST which the function
585 PREDICATE returns t when applied to; i.e. something like
586
587 (mapcar 'nconc (mapcar #'(lambda (x)
588 (when (PREDICATE x)
589 (list x)))
590 LIST))
591 ::end:: */
592 {
593 repv output = Qnil, *ptr = &output;
594 rep_GC_root gc_pred, gc_list, gc_output;
595 rep_DECLARE2(list, rep_LISTP);
596 rep_PUSHGC(gc_pred, pred);
597 rep_PUSHGC(gc_list, list);
598 rep_PUSHGC(gc_output, output);
599 while(rep_CONSP(list))
600 {
601 repv tem = rep_call_lisp1(pred, rep_CAR(list));
602 rep_TEST_INT;
603 if(tem == rep_NULL || rep_INTERRUPTP)
604 {
605 output = rep_NULL;
606 break;
607 }
608 if(!rep_NILP(tem))
609 {
610 *ptr = Fcons(rep_CAR(list), Qnil);
611 ptr = &rep_CDR(*ptr);
612 }
613 list = rep_CDR(list);
614 }
615 rep_POPGC; rep_POPGC; rep_POPGC;
616 return output;
617 }
618
619 DEFUN("member", Fmember, Smember, (repv elt, repv list), rep_Subr2) /*
620 ::doc:rep.data#member::
621 member ELT LIST
622
623 If ELT is a member of list LIST then return the tail of the list starting
624 from the matched ELT, ie,
625 (member 1 '(2 1 3))
626 => (1 3)
627 `member' uses `equal' to compare atoms.
628 ::end:: */
629 {
630 rep_DECLARE2(list, rep_LISTP);
631 while(rep_CONSP(list))
632 {
633 if(!rep_value_cmp(elt, rep_CAR(list)))
634 return(list);
635 list = rep_CDR(list);
636 rep_TEST_INT;
637 if(rep_INTERRUPTP)
638 return(rep_NULL);
639 }
640 return(Qnil);
641 }
642
643 DEFUN("memq", Fmemq, Smemq, (repv elt, repv list), rep_Subr2) /*
644 ::doc:rep.data#memq::
645 memq ELT LIST
646
647 If ELT is a member of list LIST then return the tail of the list starting
648 from the matched ELT, ie,
649 (memq 1 '(2 1 3))
650 => (1 3)
651 `memq' uses `eq' to compare atoms.
652 ::end:: */
653 {
654 rep_DECLARE2(list, rep_LISTP);
655 while(rep_CONSP(list))
656 {
657 if(elt == rep_CAR(list))
658 return(list);
659 list = rep_CDR(list);
660 rep_TEST_INT;
661 if(rep_INTERRUPTP)
662 return(rep_NULL);
663 }
664 return(Qnil);
665 }
666
667 DEFUN("memql", Fmemql, Smemql, (repv elt, repv list), rep_Subr2) /*
668 ::doc:rep.data#memql::
669 memql ELT LIST
670
671 If ELT is a member of list LIST then return the tail of the list starting
672 from the matched ELT. `memql' uses `eql' to compare list items.
673 ::end:: */
674 {
675 rep_DECLARE2 (list, rep_LISTP);
676 while (rep_CONSP (list))
677 {
678 if (elt == rep_CAR (list))
679 return list;
680 else
681 {
682 repv tem = Feql (elt, rep_CAR (list));
683 if (tem && tem != Qnil)
684 return list;
685 }
686 list = rep_CDR (list);
687 rep_TEST_INT;
688 if (rep_INTERRUPTP)
689 return rep_NULL;
690 }
691 return Qnil;
692 }
693
694 DEFUN("delete", Fdelete, Sdelete, (repv elt, repv list), rep_Subr2) /*
695 ::doc:rep.data#delete::
696 delete ELT LIST
697
698 Returns LIST with any members `equal' to ELT destructively removed.
699 ::end:: */
700 {
701 repv *head = &list;
702 rep_DECLARE2(list, rep_LISTP);
703 while(rep_CONSP(*head))
704 {
705 if(!rep_value_cmp(elt, rep_CAR(*head)))
706 *head = rep_CDR(*head);
707 else
708 head = &rep_CDR(*head);
709 rep_TEST_INT;
710 if(rep_INTERRUPTP)
711 return(rep_NULL);
712 }
713 return(list);
714 }
715
716 DEFUN("delq", Fdelq, Sdelq, (repv elt, repv list), rep_Subr2) /*
717 ::doc:rep.data#delq::
718 delq ELT LIST
719
720 Returns LIST with any members `eq' to ELT destructively removed.
721 ::end:: */
722 {
723 repv *head = &list;
724 rep_DECLARE2(list, rep_LISTP);
725 while(rep_CONSP(*head))
726 {
727 if(elt == rep_CAR(*head))
728 *head = rep_CDR(*head);
729 else
730 head = &rep_CDR(*head);
731 rep_TEST_INT;
732 if(rep_INTERRUPTP)
733 return(rep_NULL);
734 }
735 return(list);
736 }
737
738 DEFUN("delete-if", Fdelete_if, Sdelete_if, (repv pred, repv list), rep_Subr2) /*
739 ::doc:rep.data#delete-if::
740 delete-if FUNCTION LIST
741
742 Similar to `delete' except that a predicate function, FUNCTION-NAME, is
743 used to decide which elements to delete (remove destructively).
744 `delete-if' deletes an element if FUNCTION-NAME returns non-nil when
745 applied to that element, ie,
746 (delete-if '(lambda (x) (= x 1)) '(1 2 3 4 1 2))
747 => (2 3 4 2)
748 ::end:: */
749 {
750 repv *head = &list;
751 rep_GC_root gc_list, gc_pred;
752 rep_DECLARE2(list, rep_LISTP);
753 rep_PUSHGC(gc_list, list);
754 rep_PUSHGC(gc_pred, pred);
755 while(rep_CONSP(*head))
756 {
757 repv tmp = rep_call_lisp1(pred, rep_CAR(*head));
758 rep_TEST_INT;
759 if(rep_INTERRUPTP || !tmp)
760 {
761 list = rep_NULL;
762 break;
763 }
764 if(!rep_NILP(tmp))
765 *head = rep_CDR(*head);
766 else
767 head = &rep_CDR(*head);
768 }
769 rep_POPGC; rep_POPGC;
770 return list;
771 }
772
773 DEFUN("delete-if-not", Fdelete_if_not, Sdelete_if_not, (repv pred, repv list), rep_Subr2) /*
774 ::doc:rep.data#delete-if-not::
775 delete-if-not FUNCTION LIST
776
777 Similar to `delete' except that a predicate function, FUNCTION-NAME, is
778 used to decide which elements to delete (remove destructively).
779 `delete-if-not' deletes an element if FUNCTION-NAME returns nil when
780 applied to that element, ie,
781 (delete-if-not '(lambda (x) (= x 1)) '(1 2 3 4 1 2))
782 => (1 1)
783 ::end:: */
784 {
785 repv *head = &list;
786 rep_GC_root gc_list, gc_pred;
787 rep_DECLARE2(list, rep_LISTP);
788 rep_PUSHGC(gc_list, list);
789 rep_PUSHGC(gc_pred, pred);
790 while(rep_CONSP(*head))
791 {
792 repv tmp = rep_call_lisp1(pred, rep_CAR(*head));
793 rep_TEST_INT;
794 if(rep_INTERRUPTP || !tmp)
795 {
796 list = rep_NULL;
797 break;
798 }
799 if(rep_NILP(tmp))
800 *head = rep_CDR(*head);
801 else
802 head = &rep_CDR(*head);
803 }
804 rep_POPGC; rep_POPGC;
805 return list;
806 }
807
808 DEFUN("vector", Fvector, Svector, (int argc, repv *argv), rep_SubrV) /*
809 ::doc:rep.data#vector::
810 vector ARGS...
811
812 Returns a new vector with ARGS... as its elements.
813 ::end:: */
814 {
815 repv vec = rep_make_vector (argc);
816
817 if(vec != rep_NULL)
818 {
819 memcpy (rep_VECT (vec)->array, argv, argc * sizeof (repv));
820 }
821
822 return vec;
823 }
824
825 DEFUN("make-vector", Fmake_vector, Smake_vector, (repv size, repv init), rep_Subr2) /*
826 ::doc:rep.data#make-vector::
827 make-vector SIZE [INITIAL-repv]
828
829 Creates a new vector of size SIZE. If INITIAL-repv is provided each element
830 will be set to that value, else they will all be nil.
831 ::end:: */
832 {
833 int len;
834 repv res;
835 rep_DECLARE1(size, rep_INTP);
836 if(rep_INT(size) < 0)
837 return rep_signal_arg_error(size, 1);
838 len = rep_INT(size);
839 res = rep_make_vector(len);
840 if(res)
841 {
842 int i;
843 for(i = 0; i < len; i++)
844 rep_VECTI(res, i) = init;
845 }
846 return(res);
847 }
848
849 DEFUN("arrayp", Farrayp, Sarrayp, (repv arg), rep_Subr1) /*
850 ::doc:rep.data#arrayp::
851 arrayp ARG
852
853 Returns t when ARG is an array.
854 ::end:: */
855 {
856 return((rep_VECTORP(arg) || rep_STRINGP(arg) || rep_COMPILEDP(arg)) ? Qt : Qnil);
857 }
858
859 DEFUN("aset", Faset, Saset, (repv array, repv index, repv new), rep_Subr3) /*
860 ::doc:rep.data#aset::
861 aset ARRAY INDEX NEW-VALUE
862
863 Sets element number INDEX (a positive integer) of ARRAY (can be a vector
864 or a string) to NEW-VALUE, returning NEW-VALUE. Note that strings
865 can only contain characters (ie, integers).
866 ::end:: */
867 {
868 rep_DECLARE2(index, rep_INTP);
869 if(rep_INT(index) < 0)
870 return rep_signal_arg_error(index, 2);
871 if(rep_STRINGP(array))
872 {
873 if(!rep_STRING_WRITABLE_P(array))
874 return Fsignal(Qsetting_constant, rep_LIST_1(array));
875 if(rep_INT(index) < rep_STRING_LEN(array))
876 {
877 rep_DECLARE3(new, rep_INTP);
878 ((unsigned char *)rep_STR(array))[rep_INT(index)] = (unsigned char)rep_INT(new);
879 rep_string_modified (array);
880 return(new);
881 }
882 }
883 else if(rep_VECTORP(array) || rep_COMPILEDP(array))
884 {
885 if(!rep_VECTOR_WRITABLE_P(array))
886 return Fsignal(Qsetting_constant, rep_LIST_1(array));
887 if(rep_INT(index) < rep_VECT_LEN(array))
888 {
889 rep_VECTI(array, rep_INT(index)) = new;
890 return(new);
891 }
892 }
893 else
894 return(rep_signal_arg_error(array, 1));
895 return(rep_signal_arg_error(index, 2));
896 }
897
898 DEFUN("aref", Faref, Saref, (repv array, repv index), rep_Subr2) /*
899 ::doc:rep.data#aref::
900 aref ARRAY INDEX
901
902 Returns the INDEXth (a non-negative integer) element of ARRAY, which
903 can be a vector or a string. INDEX starts at zero.
904 ::end:: */
905 {
906 rep_DECLARE2(index, rep_INTP);
907 if(rep_INT(index) < 0)
908 return rep_signal_arg_error(index, 2);
909 if(rep_STRINGP(array))
910 {
911 if(rep_INT(index) < rep_STRING_LEN(array))
912 return(rep_MAKE_INT(((unsigned char *)rep_STR(array))[rep_INT(index)]));
913 }
914 else if(rep_VECTORP(array) || rep_COMPILEDP(array))
915 {
916 if(rep_INT(index) < rep_VECT_LEN(array))
917 return(rep_VECTI(array, rep_INT(index)));
918 }
919 else
920 return rep_signal_arg_error (array, 1);
921 return rep_signal_arg_error (index, 2);
922 }
923
924 DEFUN("make-string", Fmake_string, Smake_string, (repv len, repv init), rep_Subr2) /*
925 ::doc:rep.data#make-string::
926 make-string LENGTH [INITIAL-VALUE]
927
928 Returns a new string of length LENGTH, each character is initialised to
929 INITIAL-repv, or to space if INITIAL-VALUE is not given.
930 ::end:: */
931 {
932 repv res;
933 rep_DECLARE1(len, rep_INTP);
934 if(rep_INT(len) < 0)
935 return rep_signal_arg_error(len, 1);
936 res = rep_make_string(rep_INT(len) + 1);
937 if(res)
938 {
939 memset(rep_STR(res), rep_INTP(init) ? (char)rep_INT(init) : ' ', rep_INT(len));
940 rep_STR(res)[rep_INT(len)] = 0;
941 }
942 return(res);
943 }
944
945 DEFUN("substring", Fsubstring, Ssubstring, (repv string, repv start, repv end), rep_Subr3) /*
946 ::doc:rep.data#substring::
947 substring STRING START [END]
948
949 Returns the portion of STRING starting at character number START and ending
950 at the character before END (or the end of the string if END is not given).
951 All indices start at zero.
952 ::end:: */
953 {
954 int slen;
955 rep_DECLARE1(string, rep_STRINGP);
956 rep_DECLARE2(start, rep_INTP);
957 rep_DECLARE3_OPT(end, rep_INTP);
958 slen = rep_STRING_LEN(string);
959 if(rep_INT(start) > slen || rep_INT(start) < 0)
960 return(rep_signal_arg_error(start, 2));
961 if(rep_INTP(end))
962 {
963 if((rep_INT(end) > slen) || (rep_INT(end) < rep_INT(start)))
964 return(rep_signal_arg_error(end, 3));
965 return(rep_string_dupn(rep_STR(string) + rep_INT(start), rep_INT(end) - rep_INT(start)));
966 }
967 else
968 return(rep_string_dupn(rep_STR(string) + rep_INT(start), slen - rep_INT(start)));
969 }
970
971 DEFUN("concat", Fconcat, Sconcat, (int argc, repv *argv), rep_SubrV) /*
972 ::doc:rep.data#concat::
973 concat ARGS...
974
975 Concatenates all ARGS... into a single string, each argument can be a string,
976 a character or a list or vector of characters.
977 ::end:: */
978 {
979 unsigned int length;
980 repv elt, string;
981 char *ptr;
982 int i;
983
984 /* Pass 1. calculate the length of the new string. */
985
986 length = 0;
987 for (i = 0; i < argc; i++)
988 {
989 elt = argv[i];
990
991 if (rep_INTP (elt))
992 {
993 length++;
994 }
995 else if (rep_CONSP (elt))
996 {
997 length += rep_list_length (elt);
998 }
999 else
1000 {
1001 switch (rep_CELL8_TYPE (elt))
1002 {
1003 case rep_String:
1004 length += rep_STRING_LEN (elt);
1005 break;
1006
1007 case rep_Vector:
1008 length += rep_VECT_LEN (elt);
1009 break;
1010 }
1011 }
1012 }
1013
1014 if (length == 0)
1015 return rep_null_string ();
1016
1017 /* Allocate the string. */
1018
1019 string = rep_make_string (length + 1);
1020 ptr = rep_STR (string);
1021
1022 /* Pass 2: copy in the data */
1023
1024 for (i = 0; i < argc; i++)
1025 {
1026 elt = argv[i];
1027
1028 if (rep_INTP (elt))
1029 {
1030 *ptr++ = rep_INT (elt);
1031 }
1032 else if (rep_CONSP (elt))
1033 {
1034 repv tem = elt, c;
1035
1036 while (rep_CONSP (tem))
1037 {
1038 c = rep_CAR (tem);
1039
1040 if (rep_INTP (c))
1041 *ptr++ = rep_INT (c);
1042
1043 tem = rep_CDR (tem);
1044 }
1045 }
1046 else
1047 {
1048 switch (rep_CELL8_TYPE (elt))
1049 {
1050 int i;
1051 repv c;
1052
1053 case rep_String:
1054 memcpy (ptr, rep_STR (elt), rep_STRING_LEN (elt));
1055 ptr += rep_STRING_LEN (elt);
1056 break;
1057
1058 case rep_Vector:
1059 for (i = 0; i < rep_VECT_LEN (elt); i++)
1060 {
1061 c = rep_VECTI (elt, i);
1062 if (rep_INTP (c))
1063 *ptr++ = rep_INT (c);
1064 }
1065 break;
1066 }
1067 }
1068 }
1069
1070 if (rep_STRING_LEN (string) != (ptr - rep_STR (string)))
1071 rep_set_string_len (string, ptr - rep_STR (string));
1072
1073 *ptr++ = '\0';
1074
1075 return string;
1076 }
1077
1078 DEFUN("length", Flength, Slength, (repv sequence), rep_Subr1) /*
1079 ::doc:rep.data#length::
1080 length SEQUENCE
1081
1082 Returns the number of elements in SEQUENCE (a string, list or vector).
1083 ::end:: */
1084 {
1085 if (sequence == Qnil)
1086 return rep_MAKE_INT (0);
1087
1088 switch(rep_TYPE(sequence))
1089 {
1090 int i;
1091 case rep_String:
1092 return(rep_MAKE_INT(rep_STRING_LEN(sequence)));
1093 break;
1094 case rep_Vector: case rep_Compiled:
1095 return(rep_MAKE_INT(rep_VECT_LEN(sequence)));
1096 break;
1097 case rep_Cons:
1098 i = 0;
1099 while(rep_CONSP(sequence))
1100 {
1101 sequence = rep_CDR(sequence);
1102 i++;
1103 rep_TEST_INT;
1104 if(rep_INTERRUPTP)
1105 return(rep_NULL);
1106 }
1107 return(rep_MAKE_INT(i));
1108 break;
1109 default:
1110 return rep_signal_arg_error (sequence, 1);
1111 }
1112 }
1113
1114 DEFUN("copy-sequence", Fcopy_sequence, Scopy_sequence, (repv seq), rep_Subr1) /*
1115 ::doc:rep.data#copy-sequence::
1116 copy-sequence SEQUENCE
1117
1118 Returns a new sequence whose elements are eq to those in SEQUENCE.
1119 ::end:: */
1120 {
1121 repv res = Qnil;
1122 if (seq == Qnil)
1123 return Qnil;
1124 switch(rep_TYPE(seq))
1125 {
1126 case rep_Cons:
1127 {
1128 repv *last = &res;
1129 while(rep_CONSP(seq))
1130 {
1131 rep_TEST_INT;
1132 if(rep_INTERRUPTP)
1133 return(rep_NULL);
1134 if(!(*last = Fcons(rep_CAR(seq), Qnil)))
1135 return(rep_NULL);
1136 last = &rep_CDR(*last);
1137 seq = rep_CDR(seq);
1138 }
1139 }
1140 break;
1141 case rep_Vector: case rep_Compiled:
1142 res = rep_make_vector(rep_VECT_LEN(seq));
1143 if(res)
1144 {
1145 int i, len = rep_VECT_LEN(seq);
1146 rep_VECT(res)->car = rep_VECT(seq)->car;
1147 for(i = 0; i < len; i++)
1148 rep_VECTI(res, i) = rep_VECTI(seq, i);
1149 }
1150 break;
1151 case rep_String:
1152 res = rep_string_dupn(rep_STR(seq), rep_STRING_LEN(seq));
1153 break;
1154 default:
1155 res = rep_signal_arg_error(seq, 1);
1156 }
1157 return(res);
1158 }
1159
1160 DEFUN("elt", Felt, Selt, (repv seq, repv index), rep_Subr2) /*
1161 ::doc:rep.data#elt::
1162 elt SEQUENCE INDEX
1163
1164 Return the element of SEQUENCE at position INDEX (counting from zero).
1165 ::end:: */
1166 {
1167 if(rep_NILP(Farrayp(seq)))
1168 return(Fnth(index, seq));
1169 else
1170 return(Faref(seq, index));
1171 }
1172
1173 DEFUN("cond", Fcond, Scond, (repv args, repv tail_posn), rep_SF) /*
1174 ::doc:rep.lang.interpreter#cond::
1175 cond (CONDITION FORMS... ) ...
1176
1177 Find the first CONDITION which has a value of t when eval'ed, then perform
1178 a progn on its associated FORMS. If there are no FORMS with the CONDITION
1179 then the value of the CONDITION is returned. If no CONDITION is t then
1180 return nil.
1181 An example,
1182 (cond
1183 ((stringp foo)
1184 (title "foo is a string"))
1185 ((numberp foo)
1186 (setq bar foo)
1187 (title "foo is a number"))
1188 (t
1189 (title "foo is something else...")))
1190 Note the use of plain `t' on it's own for the last CONDITION, this is
1191 like the last else in an else-if statement in C.
1192 ::end:: */
1193 {
1194 repv res = Qnil;
1195 rep_GC_root gc_args;
1196 rep_PUSHGC(gc_args, args);
1197 while(rep_CONSP(args) && rep_CONSP(rep_CAR(args)))
1198 {
1199 repv cndlist = rep_CAR(args);
1200 if(!(res = rep_eval(rep_CAR(cndlist), Qnil)))
1201 break;
1202 if(!rep_NILP(res))
1203 {
1204 if(rep_CONSP(rep_CDR(cndlist)))
1205 {
1206 if(!(res = Fprogn(rep_CDR(cndlist), tail_posn)))
1207 break;
1208 }
1209 break;
1210 }
1211 args = rep_CDR(args);
1212 }
1213 rep_POPGC;
1214 return(res);
1215 }
1216
1217 static inline repv
load_file_exists_p(repv name)1218 load_file_exists_p (repv name)
1219 {
1220 repv tem = Ffile_readable_p (name);
1221 if (tem && tem != Qnil)
1222 {
1223 tem = Ffile_directory_p (name);
1224 if (tem)
1225 return (tem == Qnil) ? Qt : Qnil;
1226 }
1227 return tem;
1228 }
1229
1230 DEFUN ("load-file", Fload_file, Sload_file,
1231 (repv name, repv structure), rep_Subr2) /*
1232 ::doc:rep.io.files#load-file::
1233 load-file FILENAME [STRUCTURE]
1234
1235 Load the file of Lisp forms called FILENAME (no suffixes are added, or
1236 paths searched). The file is loaded in a null lexical environment,
1237 within STRUCTURE. The value of the last form evaluated is returned.
1238 ::end:: */
1239 {
1240 repv stream, bindings = Qnil, result, tem;
1241 rep_GC_root gc_stream, gc_bindings;
1242 struct rep_Call lc;
1243 int c;
1244
1245 if (structure == Qnil)
1246 structure = rep_structure;
1247
1248 rep_DECLARE1 (name, rep_STRINGP);
1249 rep_DECLARE2 (structure, rep_STRUCTUREP);
1250
1251 rep_PUSHGC (gc_stream, name);
1252 rep_PUSHGC (gc_bindings, structure);
1253 stream = Fopen_file (name, Qread);
1254 rep_POPGC; rep_POPGC;
1255 if (!stream || !rep_FILEP (stream))
1256 return rep_NULL;
1257
1258 bindings = rep_bind_symbol (bindings, Qload_filename, name);
1259 rep_PUSHGC (gc_stream, stream);
1260 rep_PUSHGC (gc_bindings, bindings);
1261
1262 /* Create the lexical environment for the file. */
1263 lc.fun = Qnil;
1264 lc.args = Qnil;
1265 rep_PUSH_CALL (lc);
1266 rep_env = Qnil;
1267 rep_structure = structure;
1268
1269 result = Qnil;
1270 c = rep_stream_getc (stream);
1271 while ((c != EOF) && (tem = rep_readl (stream, &c)))
1272 {
1273 rep_TEST_INT;
1274 if (rep_INTERRUPTP || !(result = rep_eval (tem, Qnil)))
1275 {
1276 result = rep_NULL;
1277 goto out;
1278 }
1279 }
1280 if (rep_throw_value
1281 && rep_CAR (rep_throw_value) == Qerror
1282 && rep_CONSP (rep_CDR(rep_throw_value))
1283 && rep_CAR (rep_CDR(rep_throw_value)) == Qend_of_stream)
1284 {
1285 /* lose the end-of-stream error. */
1286 rep_throw_value = rep_NULL;
1287 }
1288 out:
1289 rep_POP_CALL (lc);
1290 rep_POPGC; rep_POPGC;
1291
1292 rep_PUSHGC (gc_stream, result);
1293 rep_unbind_symbols (bindings);
1294 Fclose_file (stream);
1295 rep_POPGC;
1296
1297 return result;
1298 }
1299
1300 DEFUN ("load-dl-file", Fload_dl_file, Sload_dl_file,
1301 (repv name, repv structure), rep_Subr2)
1302 {
1303 struct rep_Call lc;
1304 repv result;
1305
1306 if (structure == Qnil)
1307 structure = rep_structure;
1308
1309 rep_DECLARE1 (name, rep_STRINGP);
1310 rep_DECLARE2 (structure, rep_STRUCTUREP);
1311
1312 /* Create the lexical environment for the file. */
1313 lc.fun = Qnil;
1314 lc.args = Qnil;
1315 rep_PUSH_CALL (lc);
1316 rep_env = Qnil;
1317 rep_structure = structure;
1318
1319 #ifdef HAVE_DYNAMIC_LOADING
1320 result = rep_open_dl_library (name);
1321 #else
1322 result = Fsignal (Qerror, rep_LIST_1 (rep_string_dup ("No support for dynamic loading of shared libraries")));
1323 #endif
1324
1325 rep_POP_CALL (lc);
1326 return result;
1327 }
1328
1329 DEFUN_INT("load", Fload, Sload, (repv file, repv noerr_p, repv nopath_p, repv nosuf_p, repv unused), rep_Subr5, "fLisp file to load:") /*
1330 ::doc:rep.io.files#load::
1331 load FILE [NO-ERROR] [NO-PATH] [NO-SUFFIX]
1332
1333 Attempt to open and then read-and-eval the file of Lisp code FILE.
1334
1335 For each directory named in the variable `load-path' tries the value of
1336 FILE with `.jlc' (compiled-lisp) appended to it, then with `.jl' appended
1337 to it, finally tries FILE without modification.
1338
1339 If NO-ERROR is non-nil no error is signalled if FILE can't be found. If
1340 NO-PATH is non-nil the `load-path' variable is not used, just the value
1341 of FILE. If NO-SUFFIX is non-nil no suffixes are appended to FILE.
1342
1343 If the compiled version is older than it's source code, the source code is
1344 loaded and a warning is displayed.
1345 ::end:: */
1346 {
1347 /* Avoid the need to protect these args from GC. */
1348 rep_bool no_error_p = !rep_NILP(noerr_p);
1349 rep_bool no_suffix_p = !rep_NILP(nosuf_p);
1350 rep_bool interp_mode = Fsymbol_value (Qinterpreted_mode, Qt) != Qnil;
1351
1352 repv name = Qnil, path;
1353 repv dir = rep_NULL, try = rep_NULL;
1354 repv result = rep_NULL;
1355 repv suffixes;
1356 rep_bool trying_dl = rep_FALSE;
1357
1358 rep_GC_root gc_file, gc_name, gc_path, gc_dir, gc_try, gc_result, gc_suffixes;
1359
1360 rep_DECLARE1(file, rep_STRINGP);
1361 if(rep_NILP(nopath_p))
1362 {
1363 path = Fsymbol_value(Qload_path, Qnil);
1364 if(!path)
1365 return(rep_NULL);
1366 }
1367 else
1368 path = Fcons(rep_null_string(), Qnil);
1369
1370 suffixes = F_structure_ref (rep_structure, Q_load_suffixes);
1371 if (!suffixes || !rep_CONSP (suffixes))
1372 suffixes = default_suffixes;
1373
1374 rep_PUSHGC(gc_name, name);
1375 rep_PUSHGC(gc_file, file);
1376 rep_PUSHGC(gc_path, path);
1377 rep_PUSHGC(gc_dir, dir);
1378 rep_PUSHGC(gc_try, try);
1379 rep_PUSHGC(gc_suffixes, suffixes);
1380
1381 /* Scan the path for the file to load. */
1382 research:
1383 while(rep_NILP(name) && rep_CONSP(path))
1384 {
1385 if (rep_STRINGP (rep_CAR(path)))
1386 {
1387 dir = Fexpand_file_name (file, rep_CAR(path));
1388 if(dir == rep_NULL || !rep_STRINGP(dir))
1389 goto path_error;
1390
1391 if(trying_dl || !no_suffix_p)
1392 {
1393 repv tem;
1394 int i = 1;
1395 if (!trying_dl && interp_mode)
1396 i = 0;
1397 for(; i >= 0; i--)
1398 {
1399 #ifdef HAVE_DYNAMIC_LOADING
1400 if (trying_dl)
1401 {
1402 if (i == 1)
1403 try = rep_concat2(rep_STR(dir), ".so");
1404 else
1405 {
1406 try = (Fexpand_file_name
1407 (rep_concat3 ("lib", rep_STR(file), ".so"),
1408 rep_CAR(path)));
1409 }
1410 }
1411 else
1412 #endif
1413 {
1414 repv sfx = ((i == 0)
1415 ? rep_CAR(suffixes) : rep_CDR(suffixes));
1416 if (rep_STRINGP (sfx))
1417 try = rep_concat2(rep_STR(dir), rep_STR(sfx));
1418 }
1419
1420 if (try && rep_STRINGP (try))
1421 {
1422 tem = load_file_exists_p (try);
1423 if(!tem)
1424 goto path_error;
1425 if(tem != Qnil)
1426 {
1427 if(name != Qnil)
1428 {
1429 if(rep_file_newer_than(try, name))
1430 {
1431 if (rep_message_fun != 0)
1432 (*rep_message_fun)(rep_messagef, "Warning: %s newer than %s, using %s", rep_STR(try), rep_STR(name), rep_STR(try));
1433 name = try;
1434 }
1435 }
1436 else
1437 name = try;
1438 }
1439 }
1440 }
1441 }
1442 if(!trying_dl && name == Qnil && no_suffix_p)
1443 {
1444 /* Try without a suffix */
1445 repv tem = load_file_exists_p (dir);
1446 if(!tem)
1447 goto path_error;
1448 if(tem != Qnil)
1449 name = dir;
1450 }
1451 }
1452 path = rep_CDR(path);
1453 rep_TEST_INT;
1454 if(rep_INTERRUPTP)
1455 goto path_error;
1456 }
1457
1458 #ifdef HAVE_DYNAMIC_LOADING
1459 if(rep_NILP(name) && !trying_dl)
1460 {
1461 if(rep_NILP(nopath_p))
1462 {
1463 path = Fsymbol_value(Qdl_load_path, Qnil);
1464 if(!path)
1465 return rep_NULL;
1466 }
1467 else
1468 path = rep_LIST_1(rep_null_string());
1469 trying_dl = rep_TRUE;
1470 goto research;
1471 }
1472 #endif
1473
1474 path_error:
1475 rep_POPGC; rep_POPGC; rep_POPGC; rep_POPGC; rep_POPGC; rep_POPGC;
1476
1477 if(rep_NILP(name))
1478 {
1479 if(!no_error_p)
1480 return rep_signal_file_error(file);
1481 else
1482 return Qnil;
1483 }
1484
1485 rep_PUSHGC (gc_file, file);
1486 #ifdef HAVE_DYNAMIC_LOADING
1487 if(trying_dl)
1488 result = Fload_dl_file (name, rep_structure);
1489 else
1490 #endif
1491 result = Fload_file (name, rep_structure);
1492 rep_POPGC;
1493 if (result == rep_NULL)
1494 return rep_NULL;
1495
1496 /* Loading succeeded. Look for an applicable item in
1497 the after-load-alist. */
1498 if (rep_STRUCTUREP (result) && rep_STRUCTURE (result)->name != Qnil)
1499 /* use the canonical name in case of aliasing.. */
1500 file = rep_SYM (rep_STRUCTURE (result)->name)->name;
1501 rep_PUSHGC (gc_result, result);
1502 rep_PUSHGC (gc_file, file);
1503 {
1504 repv tem;
1505 again:
1506 tem = Fsymbol_value(Qafter_load_alist, Qt);
1507 if(tem != rep_NULL && rep_CONSP(tem))
1508 {
1509 tem = Fassoc(file, tem);
1510 if(tem != rep_NULL && rep_CONSP(tem))
1511 {
1512 /* Delete this entry */
1513 Fset(Qafter_load_alist,
1514 Fdelq(tem, Fsymbol_value (Qafter_load_alist, Qt)));
1515
1516 /* Then call it */
1517 tem = rep_CDR (tem);
1518 while (rep_CONSP (tem) && !rep_INTERRUPTP)
1519 {
1520 rep_GC_root gc_tem;
1521 rep_PUSHGC (gc_tem, tem);
1522 rep_call_lisp0 (rep_CAR (tem));
1523 rep_POPGC;
1524 tem = rep_CDR (tem);
1525 }
1526
1527 /* Try for another entry */
1528 goto again;
1529 }
1530 }
1531 }
1532 rep_POPGC;
1533 rep_POPGC;
1534
1535 return result;
1536 }
1537
1538 DEFUN("equal", Fequal, Sequal, (repv val1, repv val2), rep_Subr2) /*
1539 ::doc:rep.data#equal::
1540 equal VALUE1 VALUE2
1541
1542 Compares VALUE1 and VALUE2, compares the actual structure of the objects not
1543 just whether the objects are one and the same. ie, will return t for two
1544 strings built from the same characters in the same order even if the strings'
1545 location in memory is different.
1546 ::end:: */
1547 {
1548 return (rep_value_cmp(val1, val2) == 0) ? Qt : Qnil;
1549 }
1550
1551 DEFUN("eq", Feq, Seq, (repv val1, repv val2), rep_Subr2) /*
1552 ::doc:rep.data#eq::
1553 eq VALUE1 VALUE2
1554
1555 Returns t if VALUE1 and VALUE2 are one and the same object. Note that
1556 this may or may not be true for numbers of the same value (see `eql').
1557 ::end:: */
1558 {
1559 return (val1 == val2) ? Qt : Qnil;
1560 }
1561
1562 DEFUN("not", Fnot, Snot, (repv arg), rep_Subr1) /*
1563 ::doc:rep.data#not::
1564 not ARG
1565
1566 If ARG is nil returns t, else returns nil.
1567 ::end:: */
1568 {
1569 if(rep_NILP(arg))
1570 return(Qt);
1571 return(Qnil);
1572 }
1573
1574 DEFUN("string-head-eq", Fstring_head_eq, Sstring_head_eq, (repv str1, repv str2), rep_Subr2) /*
1575 ::doc:rep.data#string-head-eq::
1576 string-head-eq STRING1 STRING2
1577
1578 Returns t if STRING2 matches the beginning of STRING1, ie,
1579 (string-head-eq "foobar" "foo")
1580 => t
1581 (string-head-eq "foo" "foobar")
1582 => nil
1583 ::end:: */
1584 {
1585 char *s1, *s2;
1586 rep_DECLARE1(str1, rep_STRINGP);
1587 rep_DECLARE2(str2, rep_STRINGP);
1588 s1 = rep_STR(str1);
1589 s2 = rep_STR(str2);
1590 while(*s1 && *s2)
1591 {
1592 if(*s1++ != *s2++)
1593 return(Qnil);
1594 }
1595 if(*s1 || (*s1 == *s2))
1596 return(Qt);
1597 return(Qnil);
1598 }
1599
1600 DEFUN("string-equal", Fstring_equal, Sstring_equal, (repv str1, repv str2), rep_Subr2) /*
1601 ::doc:rep.data#string-equal::
1602 string-equal STRING1 STRING2
1603
1604 Returns t if STRING1 and STRING2 are the same, ignoring case.
1605 ::end:: */
1606 {
1607 char *s1, *s2;
1608 rep_DECLARE1(str1, rep_STRINGP);
1609 rep_DECLARE2(str2, rep_STRINGP);
1610 s1 = rep_STR(str1);
1611 s2 = rep_STR(str2);
1612 while(*s1 && *s2)
1613 {
1614 if (toupper (*s1) != toupper (*s2))
1615 return Qnil;
1616 s1++; s2++;
1617 }
1618 return (*s1 || *s2) ? Qnil : Qt;
1619 }
1620
1621 DEFUN("string-lessp", Fstring_lessp, Sstring_lessp, (repv str1, repv str2), rep_Subr2) /*
1622 ::doc:rep.data#string-lessp::
1623 string-lessp STRING1 STRING2
1624
1625 Returns t if STRING1 is `less' than STRING2, ignoring case.
1626 ::end:: */
1627 {
1628 char *s1, *s2;
1629 rep_DECLARE1(str1, rep_STRINGP);
1630 rep_DECLARE2(str2, rep_STRINGP);
1631 s1 = rep_STR(str1);
1632 s2 = rep_STR(str2);
1633 while(*s1 && *s2)
1634 {
1635 if (toupper (*s1) != toupper (*s2))
1636 return (toupper (*s1) < toupper (*s2)) ? Qt : Qnil;
1637 s1++; s2++;
1638 }
1639 return *s2 ? Qt : Qnil;
1640 }
1641
1642 #define APPLY_COMPARISON(op) \
1643 int i, sign; \
1644 if (argc < 2) \
1645 return rep_signal_missing_arg (argc + 1); \
1646 for (i = 1; i < argc; i++) \
1647 { \
1648 repv a = argv[i-1], b = argv[i]; \
1649 if (rep_NUMBERP (a) || rep_NUMBERP (b)) \
1650 sign = rep_compare_numbers (a, b); \
1651 else \
1652 sign = rep_value_cmp (a, b); \
1653 if (!(sign op 0)) \
1654 return Qnil; \
1655 } \
1656 return Qt;
1657
1658 DEFUN("=", Fnum_eq, Snum_eq, (int argc, repv *argv), rep_SubrV) /*
1659 ::doc:rep.data#=::
1660 = ARG1 ARG2 [ARG3 ...]
1661
1662 Returns t if each value is the same as every other value. (Using
1663 `equal' to compare values, except for numbers, where exactness is
1664 ignored.)
1665 ::end:: */
1666 {
1667 APPLY_COMPARISON(==)
1668 }
1669
1670 DEFUN("/=", Fnum_noteq, Snum_noteq, (int argc, repv *argv), rep_SubrV) /*
1671 ::doc:rep.data#:/=::
1672 /= ARG1 ARG2 ...
1673
1674 Returns t if each value is different from every other value. (Using
1675 `equal' to compare values, except for numbers, where exactness is
1676 ignored.)
1677 ::end:: */
1678 {
1679 repv ret = Fnum_eq (argc, argv);
1680 return !ret ? rep_NULL : ret == Qnil ? Qt : Qnil;
1681 }
1682
1683 DEFUN(">", Fgtthan, Sgtthan, (int argc, repv *argv), rep_SubrV) /*
1684 ::doc:rep.data#>::
1685 > ARG1 ARG2 [ARG3 ...]
1686
1687 Returns t if ARG1 is greater than ARG2, and if ARG2 is greater than ARG3,
1688 and so on. Note that this command isn't limited to numbers, it can do
1689 strings, positions, marks, etc as well.
1690 ::end:: */
1691 {
1692 APPLY_COMPARISON(>)
1693 }
1694
1695 DEFUN(">=", Fgethan, Sgethan, (int argc, repv *argv), rep_SubrV) /*
1696 ::doc:rep.data#>=::
1697 >= ARG1 ARG2 [ARG3 ...]
1698
1699 Returns t if ARG1 is greater-or-equal than ARG2. Note that this command
1700 isn't limited to numbers, it can do strings, positions, marks, etc as well.
1701 ::end:: */
1702 {
1703 APPLY_COMPARISON(>=)
1704 }
1705
1706 DEFUN("<", Fltthan, Sltthan, (int argc, repv *argv), rep_SubrV) /*
1707 ::doc:rep.data#<::
1708 < ARG1 ARG2 [ARG3 ...]
1709
1710 Returns t if ARG1 is less than ARG2. Note that this command isn't limited to
1711 numbers, it can do strings, positions, marks, etc as well.
1712 ::end:: */
1713 {
1714 APPLY_COMPARISON(<)
1715 }
1716
1717 DEFUN("<=", Flethan, Slethan, (int argc, repv *argv), rep_SubrV) /*
1718 ::doc:rep.data#<=::
1719 <= ARG1 ARG2 [ARG3 ...]
1720
1721 Returns t if ARG1 is less-or-equal than ARG2. Note that this command isn't
1722 limited to numbers, it can do strings, positions, marks, etc as well.
1723 ::end:: */
1724 {
1725 APPLY_COMPARISON(<=)
1726 }
1727
1728 DEFUN("null", Fnull, Snull, (repv arg), rep_Subr1) /*
1729 ::doc:rep.data#null::
1730 null ARG
1731
1732 Returns t if ARG is nil.
1733 ::end:: */
1734 {
1735 return rep_NILP(arg) ? Qt : Qnil;
1736 }
1737
1738 DEFUN("atom", Fatom, Satom, (repv arg), rep_Subr1) /*
1739 ::doc:rep.data#atom::
1740 atom ARG
1741
1742 Returns t if ARG is not a cons-cell.
1743 ::end:: */
1744 {
1745 return rep_CONSP(arg) ? Qnil : Qt;
1746 }
1747
1748 DEFUN("consp", Fconsp, Sconsp, (repv arg), rep_Subr1) /*
1749 ::doc:rep.data#consp::
1750 consp ARG
1751
1752 Returns t if ARG is a cons-cell.
1753 ::end:: */
1754 {
1755 return rep_CONSP(arg) ? Qt : Qnil;
1756 }
1757
1758 DEFUN("listp", Flistp, Slistp, (repv arg), rep_Subr1) /*
1759 ::doc:rep.data#listp::
1760 listp ARG
1761
1762 Returns t if ARG is a list, (either a cons-cell or nil).
1763 ::end:: */
1764 {
1765 return rep_LISTP(arg) ? Qt : Qnil;
1766 }
1767
1768 DEFUN("stringp", Fstringp, Sstringp, (repv arg), rep_Subr1) /*
1769 ::doc:rep.data#stringp::
1770 stringp ARG
1771
1772 Returns t is ARG is a string.
1773 ::end:: */
1774 {
1775 return rep_STRINGP(arg) ? Qt : Qnil;
1776 }
1777
1778 DEFUN("vectorp", Fvectorp, Svectorp, (repv arg), rep_Subr1) /*
1779 ::doc:rep.data#vectorp::
1780 vectorp ARG
1781
1782 Returns t if ARG is a vector.
1783 ::end:: */
1784 {
1785 return rep_VECTORP(arg) ? Qt : Qnil;
1786 }
1787
1788 DEFUN("functionp", Ffunctionp, Sfunctionp, (repv arg), rep_Subr1) /*
1789 ::doc:rep.lang.interpreter#functionp::
1790 functionp ARG
1791
1792 Returns t if ARG is a function.
1793 ::end:: */
1794 {
1795 switch(rep_TYPE(arg))
1796 {
1797 case rep_Subr0:
1798 case rep_Subr1:
1799 case rep_Subr2:
1800 case rep_Subr3:
1801 case rep_Subr4:
1802 case rep_Subr5:
1803 case rep_SubrN:
1804 case rep_Funarg:
1805 return Qt;
1806
1807 case rep_Cons:
1808 arg = rep_CAR(arg);
1809 if(arg == Qautoload)
1810 return(Qt);
1811 /* FALL THROUGH */
1812
1813 default:
1814 return(Qnil);
1815 }
1816 }
1817
1818 DEFUN("macrop", Fmacrop, Smacrop, (repv arg), rep_Subr1) /*
1819 ::doc:rep.lang.interpreter#macrop::
1820 macrop ARG
1821
1822 Returns t if ARG is a macro.
1823 ::end:: */
1824 {
1825 if(rep_CONSP(arg) && rep_CAR(arg) == Qmacro)
1826 return Qt;
1827 else
1828 return Qnil;
1829 }
1830
1831 DEFUN("special-form-p", Fspecial_form_p, Sspecial_form_p, (repv arg), rep_Subr1) /*
1832 ::doc:rep.lang.interpreter#special-form-p::
1833 special-form-p ARG
1834
1835 Returns t if ARG is a special-form.
1836 ::end:: */
1837 {
1838 if(rep_TYPEP(arg, rep_SF))
1839 return(Qt);
1840 return(Qnil);
1841 }
1842
1843 DEFUN("subrp", Fsubrp, Ssubrp, (repv arg), rep_Subr1) /*
1844 ::doc:rep.lang.interpreter#subrp::
1845 subrp ARG
1846
1847 Returns t if arg is a primitive function.
1848 ::end:: */
1849 {
1850 switch(rep_TYPE(arg))
1851 {
1852 case rep_Subr0:
1853 case rep_Subr1:
1854 case rep_Subr2:
1855 case rep_Subr3:
1856 case rep_Subr4:
1857 case rep_Subr5:
1858 case rep_SubrN:
1859 case rep_SF:
1860 return(Qt);
1861 default:
1862 return(Qnil);
1863 }
1864 }
1865
1866 DEFUN("sequencep", Fsequencep, Ssequencep, (repv arg), rep_Subr1) /*
1867 ::doc:rep.data#sequencep::
1868 sequencep ARG
1869
1870 Returns t is ARG is a sequence (a list, vector or string).
1871 ::end:: */
1872 {
1873 if(rep_LISTP(arg) || rep_VECTORP(arg) || rep_STRINGP(arg) || rep_COMPILEDP(arg))
1874 return Qt;
1875 else
1876 return Qnil;
1877 }
1878
1879 DEFUN("subr-name", Fsubr_name, Ssubr_name, (repv subr, repv useVar), rep_Subr2) /*
1880 ::doc:rep.lang.interpreter#subr-name::
1881 subr-name SUBR [USE-VAR]
1882
1883 Returns the name (a string) associated with SUBR.
1884 ::end:: */
1885 {
1886 switch(rep_TYPE(subr))
1887 {
1888 case rep_Subr0:
1889 case rep_Subr1:
1890 case rep_Subr2:
1891 case rep_Subr3:
1892 case rep_Subr4:
1893 case rep_Subr5:
1894 case rep_SubrN:
1895 case rep_SF:
1896 return(rep_SUBR(subr)->name);
1897 default:
1898 return(Qnil);
1899 }
1900 }
1901
1902 DEFUN("call-hook", Fcall_hook, Scall_hook, (repv hook, repv arg_list, repv type), rep_Subr3) /*
1903 ::doc:rep.system#call-hook::
1904 call-hook HOOK ARG-LIST [TYPE]
1905
1906 Call the hook named by the symbol HOOK, passing all functions the arguments
1907 in the list ARG-LIST. Note that HOOK may also be the actual list of functions
1908 to call.
1909
1910 TYPE defines how the return values of each function in the hook are
1911 treated. If TYPE is nil they are ignored, if TYPE is the symbol `and'
1912 the hook aborts after a function returns nil, if TYPE is `or' the hook
1913 aborts when a function returns non-nil.
1914
1915 In all cases the value returned by the last-evaluated function is
1916 returned.
1917 ::end:: */
1918 {
1919 rep_GC_root gc_hook, gc_arg_list, gc_type;
1920 repv res = Qnil;
1921 rep_DECLARE2(arg_list, rep_LISTP);
1922 if(!rep_LISTP(hook))
1923 {
1924 rep_DECLARE1(hook, rep_SYMBOLP);
1925 hook = Fsymbol_value(hook, Qt);
1926 if(rep_VOIDP(hook) || rep_NILP(hook))
1927 return Qnil;
1928 }
1929 rep_PUSHGC(gc_hook, hook);
1930 rep_PUSHGC(gc_arg_list, arg_list);
1931 rep_PUSHGC(gc_type, type);
1932 while(rep_CONSP(hook))
1933 {
1934 res = Ffuncall(Fcons(rep_CAR(hook), arg_list));
1935 hook = rep_CDR(hook);
1936 rep_TEST_INT;
1937 if(rep_INTERRUPTP)
1938 res = rep_NULL;
1939 if(res == rep_NULL
1940 || (type == Qand && rep_NILP(res))
1941 || (type == Qor && !rep_NILP(res)))
1942 break;
1943 }
1944 rep_POPGC; rep_POPGC; rep_POPGC;
1945 return res;
1946 }
1947
1948 DEFUN("call-with-exception-handler", Fcall_with_exception_handler,
1949 Scall_with_exception_handler, (repv thunk, repv handler),
1950 rep_Subr2) /*
1951 ::doc:rep.lang.interpreter#call-with-exception-handler::
1952 call-with-exception-handler THUNK HANDLER
1953
1954 Call THUNK and return its value. However if an exception of any form
1955 occurs, call HANDLER with a single argument, the exception data, and
1956 return its value.
1957 ::end:: */
1958 /* Non-local exits don't bother with jmp_buf's and the like, they just
1959 unwind normally through all levels of recursion with a rep_NULL result.
1960 This is slow but it's easy to work with. */
1961 {
1962 rep_GC_root gc_handler;
1963 repv ret;
1964
1965 rep_DECLARE (1, thunk, Ffunctionp (thunk) != Qnil);
1966 rep_DECLARE (2, handler, Ffunctionp (handler) != Qnil);
1967
1968 rep_PUSHGC (gc_handler, handler);
1969 ret = rep_call_lisp0 (thunk);
1970 rep_POPGC;
1971 if (ret == rep_NULL)
1972 {
1973 repv data = rep_throw_value;
1974 rep_throw_value = rep_NULL;
1975 assert (data != rep_NULL);
1976 ret = rep_call_lisp1 (handler, data);
1977 }
1978 return ret;
1979 }
1980
1981 DEFUN("raise-exception", Fraise_exception,
1982 Sraise_exception, (repv ex), rep_Subr1) /*
1983 ::doc:rep.lang.interpreter#raise-exception::
1984 raise-exception DATA
1985
1986 Raise the exception represented by the cons cell DATA.
1987 ::end:: */
1988 {
1989 /* Only one thing can use `rep_throw_value' at once. */
1990 rep_DECLARE1 (ex, rep_CONSP);
1991 if (rep_throw_value == rep_NULL)
1992 rep_throw_value = ex;
1993 return rep_NULL;
1994 }
1995
1996 /* XXX compatibility */
Fthrow(repv tag,repv value)1997 repv Fthrow (repv tag, repv value) {
1998 return Fraise_exception (Fcons (tag, value));
1999 }
2000
2001 DEFSTRING(jl, ".jl");
2002 DEFSTRING(jlc, ".jlc");
2003
2004 static void
add_path(const char * env,repv var)2005 add_path (const char *env, repv var)
2006 {
2007 repv list = Qnil, vec[2];
2008 char *ptr;
2009
2010 ptr = getenv (env);
2011 while (ptr != 0 && *ptr != 0)
2012 {
2013 char *end = strchr (ptr, ':');
2014 list = Fcons (end ? rep_string_dupn (ptr, end - ptr)
2015 : rep_string_dup (ptr), list);
2016 ptr = end ? end + 1 : 0;
2017 }
2018
2019 vec[0] = Fnreverse (list);
2020 vec[1] = Fsymbol_value (var, Qt);
2021 Fset (var, Fnconc_ (2, vec));
2022 }
2023
2024 void
rep_lispcmds_init(void)2025 rep_lispcmds_init(void)
2026 {
2027 DEFSTRING (common_exec, REP_COMMON_EXEC_DIRECTORY);
2028 repv tem;
2029
2030 tem = rep_push_structure ("rep.lang.interpreter");
2031 rep_ADD_SUBR(Squote);
2032 rep_ADD_SUBR(Slambda);
2033 rep_ADD_SUBR(Scond);
2034 rep_ADD_SUBR(Scall_with_exception_handler);
2035 rep_ADD_SUBR(Sraise_exception);
2036 rep_ADD_SUBR(Sfunctionp);
2037 rep_ADD_SUBR(Smacrop);
2038 rep_ADD_SUBR(Sspecial_form_p);
2039 rep_ADD_SUBR(Ssubrp);
2040 rep_ADD_SUBR(Ssubr_name);
2041 rep_pop_structure (tem);
2042
2043 tem = rep_push_structure ("rep.data");
2044 rep_ADD_SUBR(Scar);
2045 rep_ADD_SUBR(Scdr);
2046 rep_ADD_SUBR(Slist);
2047 rep_ADD_SUBR(Slist_star);
2048 rep_ADD_SUBR(Smake_list);
2049 rep_ADD_SUBR(Sappend);
2050 rep_ADD_SUBR(Snconc);
2051 rep_ADD_SUBR(Srplaca);
2052 rep_ADD_SUBR(Srplacd);
2053 rep_ADD_SUBR(Sreverse);
2054 rep_ADD_SUBR(Snreverse);
2055 rep_ADD_SUBR(Sassoc);
2056 rep_ADD_SUBR(Sassq);
2057 rep_ADD_SUBR(Srassoc);
2058 rep_ADD_SUBR(Srassq);
2059 rep_ADD_SUBR(Snth);
2060 rep_ADD_SUBR(Snthcdr);
2061 rep_ADD_SUBR(Slast);
2062 rep_ADD_SUBR(Smapcar);
2063 rep_ADD_SUBR(Smapc);
2064 rep_ADD_SUBR(Sfilter);
2065 rep_ADD_SUBR(Smember);
2066 rep_ADD_SUBR(Smemq);
2067 rep_ADD_SUBR(Smemql);
2068 rep_ADD_SUBR(Sdelete);
2069 rep_ADD_SUBR(Sdelq);
2070 rep_ADD_SUBR(Sdelete_if);
2071 rep_ADD_SUBR(Sdelete_if_not);
2072 rep_ADD_SUBR(Svector);
2073 rep_ADD_SUBR(Smake_vector);
2074 rep_ADD_SUBR(Sarrayp);
2075 rep_ADD_SUBR(Saset);
2076 rep_ADD_SUBR(Saref);
2077 rep_ADD_SUBR(Smake_string);
2078 rep_ADD_SUBR(Ssubstring);
2079 rep_ADD_SUBR(Sconcat);
2080 rep_ADD_SUBR(Slength);
2081 rep_ADD_SUBR(Scopy_sequence);
2082 rep_ADD_SUBR(Selt);
2083 rep_ADD_SUBR(Snot);
2084 rep_ADD_SUBR(Sequal);
2085 rep_ADD_SUBR(Seq);
2086 rep_ADD_SUBR(Sstring_head_eq);
2087 rep_ADD_SUBR(Sstring_equal);
2088 rep_ADD_SUBR(Sstring_lessp);
2089 rep_ADD_SUBR(Snum_eq);
2090 rep_ADD_SUBR(Snum_noteq);
2091 rep_ADD_SUBR(Sgtthan);
2092 rep_ADD_SUBR(Sgethan);
2093 rep_ADD_SUBR(Sltthan);
2094 rep_ADD_SUBR(Slethan);
2095 rep_ADD_SUBR(Snull);
2096 rep_ADD_SUBR(Satom);
2097 rep_ADD_SUBR(Sconsp);
2098 rep_ADD_SUBR(Slistp);
2099 rep_ADD_SUBR(Sstringp);
2100 rep_ADD_SUBR(Svectorp);
2101 rep_ADD_SUBR(Ssequencep);
2102 rep_pop_structure (tem);
2103
2104 tem = rep_push_structure ("rep.io.files");
2105 rep_ADD_SUBR (Sload_file);
2106 rep_ADD_SUBR (Sload_dl_file);
2107 rep_ADD_SUBR_INT(Sload);
2108 rep_pop_structure (tem);
2109
2110 tem = rep_push_structure ("rep.system");
2111 rep_ADD_SUBR(Scall_hook);
2112 rep_pop_structure (tem);
2113
2114 rep_INTERN(provide);
2115
2116 rep_INTERN_SPECIAL(rep_directory);
2117 if(getenv("REPDIR") != 0)
2118 Fset (Qrep_directory, rep_string_dup(getenv("REPDIR")));
2119 else
2120 Fset (Qrep_directory, rep_VAL(&default_rep_directory));
2121
2122 rep_INTERN_SPECIAL(lisp_lib_directory);
2123 if(getenv("REPLISPDIR") != 0)
2124 Fset (Qlisp_lib_directory, rep_string_dup(getenv("REPLISPDIR")));
2125 else
2126 Fset (Qlisp_lib_directory, rep_string_dup(REP_LISP_DIRECTORY));
2127
2128 rep_INTERN_SPECIAL(site_lisp_directory);
2129 if(getenv("REPSITELISPDIR") != 0)
2130 Fset(Qsite_lisp_directory, rep_string_dup(getenv("REPSITELISPDIR")));
2131 else
2132 Fset (Qsite_lisp_directory,
2133 rep_concat2(rep_STR(Fsymbol_value (Qrep_directory, Qt)),
2134 "/site-lisp"));
2135
2136 rep_INTERN_SPECIAL(exec_directory);
2137 if(getenv("REPEXECDIR") != 0)
2138 Fset (Qexec_directory, rep_string_dup(getenv("REPEXECDIR")));
2139 else
2140 Fset (Qexec_directory, rep_string_dup(REP_EXEC_DIRECTORY));
2141
2142 rep_INTERN_SPECIAL(documentation_file);
2143 if(getenv("REPDOCFILE") != 0)
2144 Fset (Qdocumentation_file, rep_string_dup(getenv("REPDOCFILE")));
2145 else
2146 {
2147 DEFSTRING (doc_file, REP_DOC_FILE);
2148 Fset (Qdocumentation_file, rep_VAL (&doc_file));
2149 }
2150
2151 rep_INTERN_SPECIAL(documentation_files);
2152 Fset (Qdocumentation_files,
2153 Fcons (Fsymbol_value (Qdocumentation_file, Qt), Qnil));
2154
2155 rep_INTERN_SPECIAL(load_path);
2156 Fset (Qload_path, Fcons (Fsymbol_value (Qlisp_lib_directory, Qt),
2157 Fcons (Fsymbol_value (Qsite_lisp_directory, Qt),
2158 Fcons (rep_VAL(&dot), Qnil))));
2159 add_path ("REP_LOAD_PATH", Qload_path);
2160
2161 rep_INTERN_SPECIAL(dl_load_path);
2162 Fset (Qdl_load_path, Fcons (Fsymbol_value (Qexec_directory, Qt),
2163 Fcons (rep_VAL (&common_exec), Qnil)));
2164 add_path ("REP_DL_LOAD_PATH", Qdl_load_path);
2165
2166 rep_INTERN_SPECIAL(after_load_alist);
2167 Fset (Qafter_load_alist, Qnil);
2168
2169 rep_INTERN(or); rep_INTERN(and);
2170
2171 rep_INTERN_SPECIAL(dl_load_reloc_now);
2172 Fset (Qdl_load_reloc_now, Qnil);
2173
2174 rep_INTERN_SPECIAL(load_filename);
2175
2176 default_suffixes = Fcons (rep_VAL (&jl), rep_VAL (&jlc));
2177 rep_mark_static (&default_suffixes);
2178 rep_INTERN (_load_suffixes);
2179 }
2180