1 /* symbols.c -- Lisp symbol handling
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 #define NDEBUG
24
25 /* AIX requires this to be the first thing in the file. */
26 #include <config.h>
27 #ifdef __GNUC__
28 # define alloca __builtin_alloca
29 #else
30 # if HAVE_ALLOCA_H
31 # include <alloca.h>
32 # else
33 # ifdef _AIX
34 #pragma alloca
35 # else
36 # ifndef alloca /* predefined by HP cc +Olibcalls */
37 char *alloca ();
38 # endif
39 # endif
40 # endif
41 #endif
42
43 #include "repint.h"
44
45 #include <string.h>
46 #include <ctype.h>
47 #include <stdlib.h>
48 #include <assert.h>
49
50 /* The number of hash buckets in each rep_obarray, this is a prime number. */
51 #define rep_OBSIZE 509
52 #define rep_KEY_OBSIZE 127
53
54 #define rep_FUNARGBLK_SIZE 204 /* ~4k */
55
56 /* Closure allocation blocks */
57 typedef struct rep_funarg_block_struct {
58 struct rep_funarg_block_struct *next;
59 rep_ALIGN_CELL(rep_funarg data[rep_FUNARGBLK_SIZE]);
60 } rep_funarg_block;
61
62 /* Main storage of symbols. */
63 repv rep_obarray, rep_keyword_obarray;
64
65 /* Plist storage */
66 static repv plist_structure;
67
68 DEFSYM(t, "t");
69
70 DEFSYM(documentation, "documentation");
71 DEFSYM(permanent_local, "permanent-local");
72
73 /* Function vectors to implement local symbols through. */
74 repv (*rep_deref_local_symbol_fun)(repv sym) = 0;
75 repv (*rep_set_local_symbol_fun)(repv sym, repv val) = 0;
76
77 /* This value is stored in the cells of a symbol to denote a void object. */
78 rep_ALIGN_CELL(static rep_cell void_object) = { rep_Void };
79 repv rep_void_value = rep_VAL(&void_object);
80
81 /* The special value which signifies the end of a hash-bucket chain.
82 It can be any Lisp object which isn't a symbol. */
83 #define OB_NIL rep_VAL(&void_object)
84
85 /* Used to mark lexical bindings */
86 rep_ALIGN_CELL(static rep_cell lextag) = { rep_Void };
87 #define LEXTAG rep_VAL(&lextag)
88
89 static rep_funarg_block *funarg_block_chain;
90 static rep_funarg *funarg_freelist;
91 int rep_allocated_funargs, rep_used_funargs;
92
93 /* support for scheme boolean type */
94 repv rep_scm_t, rep_scm_f;
95
96 repv rep_undefined_value;
97
98
99 /* Symbol management */
100
101 DEFUN("make-symbol", Fmake_symbol, Smake_symbol, (repv name), rep_Subr1) /*
102 ::doc:rep.lang.symbols#make-symbol::
103 make-symbol NAME
104
105 Returns a new, uninterned, symbol with print-name NAME. It's value and
106 function definition are both void and it has a nil property-list.
107 ::end:: */
108 {
109 rep_DECLARE1(name, rep_STRINGP);
110 return rep_make_tuple (rep_Symbol, rep_NULL, name);
111 }
112
113 static void
symbol_sweep(void)114 symbol_sweep(void)
115 {
116 /* Need to clear mark bits of dumped symbols, since they're mutable */
117 if (rep_dumped_symbols_start != rep_dumped_symbols_end)
118 {
119 rep_symbol *s;
120 for(s = rep_dumped_symbols_start; s < rep_dumped_symbols_end; s++)
121 {
122 if(rep_GC_CELL_MARKEDP(rep_VAL(s)))
123 rep_GC_CLR_CELL(rep_VAL(s));
124 }
125 }
126 }
127
128 static int
symbol_cmp(repv v1,repv v2)129 symbol_cmp(repv v1, repv v2)
130 {
131 if(rep_TYPE(v1) == rep_TYPE(v2))
132 {
133 if (v1 == v2)
134 return 0;
135 else
136 return rep_value_cmp (rep_SYM(v1)->name, rep_SYM(v2)->name);
137 }
138 else
139 return 1;
140 }
141
142 static void
symbol_princ(repv strm,repv obj)143 symbol_princ(repv strm, repv obj)
144 {
145 rep_stream_puts(strm, rep_PTR(rep_SYM(obj)->name), -1, rep_TRUE);
146 }
147
148 static void
symbol_print(repv strm,repv obj)149 symbol_print(repv strm, repv obj)
150 {
151 /* output a maximum of 2n chars for a symbol name of length n */
152 char *buf = alloca (rep_STRING_LEN (rep_SYM (obj)->name) * 2);
153 register char *out = buf;
154 register char *s;
155 rep_bool seen_digit = rep_FALSE;
156
157 if (rep_SYMBOL_LITERAL_P (obj))
158 {
159 symbol_princ (strm, obj);
160 return;
161 }
162
163 s = rep_STR (rep_SYM (obj)->name);
164 switch (*s++)
165 {
166 case '0': case '1': case '2': case '3': case '4':
167 case '5': case '6': case '7': case '8': case '9':
168 seen_digit = rep_TRUE;
169
170 case '-': case '+': case '.':
171
172 pass1:
173 switch (*s++)
174 {
175 case 0:
176 if (seen_digit)
177 *out++ = '\\';
178 break;
179
180 case '0': case '1': case '2': case '3': case '4':
181 case '5': case '6': case '7': case '8': case '9':
182 seen_digit = rep_TRUE;
183 case '/': case '.':
184 goto pass1;
185 }
186 }
187
188 s = rep_STR (rep_SYM (obj)->name);
189 while (1)
190 {
191 char c = *s++;
192 switch (c)
193 {
194 case 0:
195 goto out;
196
197 case ' ': case '\t': case '\n': case '\f':
198 case '(': case ')': case '[': case ']':
199 case '\'': case '"': case ';': case '\\':
200 case '|': case ',': case '`':
201 *out++ = '\\';
202 break;
203
204 case '#':
205 if (!(rep_KEYWORDP (obj) && s-1 == rep_STR (rep_SYM (obj)->name)))
206 *out++ = '\\';
207 break;
208
209 default:
210 if (iscntrl (c))
211 *out++ = '\\';
212 break;
213 }
214 *out++ = c;
215 }
216 out:
217 rep_stream_puts (strm, buf, out - buf, rep_FALSE);
218 }
219
220 void
rep_intern_static(repv * symp,repv name)221 rep_intern_static(repv *symp, repv name)
222 {
223 if((*symp = Fintern(name, Qnil)))
224 rep_mark_static(symp);
225 else
226 abort();
227 }
228
229 static inline unsigned long
hash(char * str)230 hash(char *str)
231 {
232 register unsigned long value = 0;
233 while(*str)
234 value = (value * 33) + *str++;
235 return(value);
236 }
237
238 DEFUN("make-obarray", Fmake_obarray, Smake_obarray, (repv size), rep_Subr1) /*
239 ::doc:rep.lang.symbols#make-obarray::
240 make-obarray SIZE
241
242 Creates a new structure for storing symbols in. This is basically a vector
243 with a few slight differences (all elements initialised to a special value).
244 ::end:: */
245 {
246 rep_DECLARE1(size, rep_INTP);
247 return(Fmake_vector(size, OB_NIL));
248 }
249
250 DEFUN("find-symbol", Ffind_symbol, Sfind_symbol, (repv name, repv ob), rep_Subr2) /*
251 ::doc:rep.lang.symbols#find-symbol::
252 find-symbol NAME [OBARRAY]
253
254 Returns the symbol with print-name NAME, found by searching OBARRAY (or
255 the default `rep_obarray' if nil), or nil if no such symbol exists.
256 ::end:: */
257 {
258 int vsize;
259 rep_DECLARE1(name, rep_STRINGP);
260 if(!rep_VECTORP(ob))
261 ob = rep_obarray;
262 if((vsize = rep_VECT_LEN(ob)) == 0)
263 return(Qnil);
264 ob = rep_VECT(ob)->array[hash(rep_STR(name)) % vsize];
265 while(rep_SYMBOLP(ob))
266 {
267 if(!strcmp(rep_STR(name), rep_STR(rep_SYM(ob)->name)))
268 return(ob);
269 ob = rep_SYM(ob)->next;
270 }
271 return(Qnil);
272 }
273
274 DEFSTRING(already_interned, "Symbol is already interned");
275
276 DEFUN("intern-symbol", Fintern_symbol, Sintern_symbol, (repv sym, repv ob), rep_Subr2) /*
277 ::doc:rep.lang.symbols#intern-symbol::
278 intern-symbol SYMBOL [OBARRAY]
279
280 Stores SYMBOL in OBARRAY (or the default). If SYMBOL has already been interned
281 somewhere an error is signalled.
282 ::end:: */
283 {
284 int vsize, hashid;
285 rep_DECLARE1(sym, rep_SYMBOLP);
286 if(rep_SYM(sym)->next != rep_NULL)
287 {
288 Fsignal(Qerror, rep_list_2(rep_VAL(&already_interned), sym));
289 return rep_NULL;
290 }
291 if(!rep_VECTORP(ob))
292 ob = rep_obarray;
293 if((vsize = rep_VECT_LEN(ob)) == 0)
294 return rep_NULL;
295 hashid = hash(rep_STR(rep_SYM(sym)->name)) % vsize;
296 rep_SYM(sym)->next = rep_VECT(ob)->array[hashid];
297 rep_VECT(ob)->array[hashid] = sym;
298 return(sym);
299 }
300
301 DEFUN("intern", Fintern, Sintern, (repv name, repv ob), rep_Subr2) /*
302 ::doc:rep.lang.symbols#intern::
303 intern NAME [OBARRAY]
304
305 If a symbol with print-name exists in OBARRAY (or the default) return it.
306 Else use `(make-symbol NAME)' to create a new symbol, intern that into the
307 OBARRAY, then return it.
308 ::end:: */
309 {
310 repv sym;
311 rep_DECLARE1(name, rep_STRINGP);
312 if(!(sym = Ffind_symbol(name, ob)) || (rep_NILP(sym)))
313 {
314 sym = Fmake_symbol(name);
315 if(sym)
316 return(Fintern_symbol(sym, ob));
317 }
318 return(sym);
319 }
320
321 DEFUN("unintern", Funintern, Sunintern, (repv sym, repv ob), rep_Subr2) /*
322 ::doc:rep.lang.symbols#unintern::
323 unintern SYMBOL [OBARRAY]
324
325 Removes SYMBOL from OBARRAY (or the default). Use this with caution.
326 ::end:: */
327 {
328 repv list;
329 int vsize, hashid;
330 rep_DECLARE1(sym, rep_SYMBOLP);
331 if(!rep_VECTORP(ob))
332 ob = rep_obarray;
333 if((vsize = rep_VECT_LEN(ob)) == 0)
334 return rep_NULL;
335 hashid = hash(rep_STR(rep_SYM(sym)->name)) % vsize;
336 list = rep_VECT(ob)->array[hashid];
337 rep_VECT(ob)->array[hashid] = OB_NIL;
338 while(rep_SYMBOLP(list))
339 {
340 repv nxt = rep_SYM(list)->next;
341 if(list != sym)
342 {
343 rep_SYM(list)->next = rep_VECT(ob)->array[hashid];
344 rep_VECT(ob)->array[hashid] = rep_VAL(list);
345 }
346 list = nxt;
347 }
348 rep_SYM(sym)->next = rep_NULL;
349 return(sym);
350 }
351
352
353 /* Closures */
354
355 DEFUN("make-closure", Fmake_closure, Smake_closure,
356 (repv fun, repv name), rep_Subr2) /*
357 ::doc:rep.lang.interpreter#make-closure::
358 make-closure FUNCTION &optional NAME
359
360 Return a functional object which makes the closure of FUNCTION and the
361 current environment.
362 ::end:: */
363 {
364 rep_funarg *f;
365 if(!funarg_freelist)
366 {
367 rep_funarg_block *sb = rep_ALLOC_CELL(sizeof(rep_funarg_block));
368 if(sb)
369 {
370 int i;
371 rep_allocated_funargs += rep_FUNARGBLK_SIZE;
372 sb->next = funarg_block_chain;
373 funarg_block_chain = sb;
374 for(i = 0; i < (rep_FUNARGBLK_SIZE - 1); i++)
375 sb->data[i].car = rep_VAL(&sb->data[i + 1]);
376 sb->data[i].car = rep_VAL(funarg_freelist);
377 funarg_freelist = sb->data;
378 }
379 }
380
381 f = funarg_freelist;
382 funarg_freelist = rep_FUNARG (f->car);
383 rep_data_after_gc += sizeof (rep_funarg);
384 f->car = rep_Funarg;
385 f->fun = fun;
386 f->name = name;
387 f->env = rep_env;
388 f->structure = rep_structure;
389 return rep_VAL (f);
390 }
391
392 DEFUN("closure-function", Fclosure_function,
393 Sclosure_function, (repv funarg), rep_Subr1) /*
394 ::doc:rep.lang.interpreter#closure-function::
395 closure-function FUNARG
396
397 Return the function value associated with the closure FUNARG.
398 ::end:: */
399 {
400 rep_DECLARE1(funarg, rep_FUNARGP);
401 return rep_FUNARG(funarg)->fun;
402 }
403
404 DEFUN("set-closure-function", Fset_closure_function,
405 Sset_closure_function, (repv funarg, repv fun), rep_Subr2) /*
406 ::doc:rep.lang.interpreter#set-closure-function::
407 set-closure-function FUNARG FUNCTION
408
409 Set the function value in the closure FUNARG to FUNCTION.
410 ::end:: */
411 {
412 rep_DECLARE1(funarg, rep_FUNARGP);
413 rep_FUNARG(funarg)->fun = fun;
414 return fun;
415 }
416
417 DEFUN("closure-structure", Fclosure_structure,
418 Sclosure_structure, (repv funarg), rep_Subr1) /*
419 ::doc:rep.structures#closure-function::
420 closure-structure FUNARG
421
422 Return the structure associated with the closure FUNARG.
423 ::end:: */
424 {
425 rep_DECLARE1(funarg, rep_FUNARGP);
426 return rep_FUNARG(funarg)->structure;
427 }
428
429 DEFUN("subr-structure", Fsubr_structure,
430 Ssubr_structure, (repv arg), rep_Subr1) /*
431 ::doc:rep.structures#closure-function::
432 subr-structure SUBR
433
434 Return the structure associated with the subr SUBR.
435 ::end:: */
436 {
437 /* Simple rep_DECLARE1 can't be used. Borrow rep_DECLARE1 macro
438 definition. */
439 do{
440 if(Fsubrp(arg) == Qnil){
441 rep_signal_arg_error(arg, 1);
442 return rep_NULL;
443 }
444 }while(0);
445
446 if(rep_XSUBR(arg)->structure != rep_NULL){
447 return rep_XSUBR(arg)->structure;
448 }else{
449 return Qnil;
450 }
451 }
452
453 DEFUN ("set-closure-structure", Fset_closure_structure,
454 Sset_closure_structure, (repv closure, repv structure), rep_Subr2)
455 {
456 rep_DECLARE1 (closure, rep_FUNARGP);
457 rep_DECLARE2 (structure, rep_STRUCTUREP);
458 rep_FUNARG (closure)->structure = structure;
459 return Qnil;
460 }
461
462 DEFUN("closure-name", Fclosure_name,
463 Sclosure_name, (repv funarg), rep_Subr1) /*
464 ::doc:rep.lang.interpreter#closure-name::
465 closure-name FUNARG
466
467 Return the name associated with the closure FUNARG.
468 ::end:: */
469 {
470 rep_DECLARE1(funarg, rep_FUNARGP);
471 return rep_FUNARG(funarg)->name;
472 }
473
474 DEFUN("closurep", Fclosurep, Sclosurep, (repv arg), rep_Subr1) /*
475 ::doc:rep.lang.interpreter#closurep::
476 funargp ARG
477
478 Returns t if ARG is a closure
479 ::end:: */
480 {
481 return rep_FUNARGP(arg) ? Qt : Qnil;
482 }
483
484 DEFUN("set-special-environment", Fset_special_environment,
485 Sset_special_environment, (repv env, repv structure), rep_Subr2) /*
486 ::doc:rep.structures#set-special-environment::
487 set-special-environment ENV STRUCTURE
488 ::end:: */
489 {
490 rep_DECLARE2 (structure, rep_STRUCTUREP);
491 rep_STRUCTURE (structure)->special_env = env;
492 return Qt;
493 }
494
495 static void
funarg_sweep(void)496 funarg_sweep (void)
497 {
498 rep_funarg_block *sb = funarg_block_chain;
499 funarg_freelist = NULL;
500 rep_used_funargs = 0;
501 while(sb)
502 {
503 int i;
504 rep_funarg_block *nxt = sb->next;
505 for(i = 0; i < rep_FUNARGBLK_SIZE; i++)
506 {
507 /* if on the freelist then the CELL_IS_8 bit
508 will be unset (since the pointer is long aligned) */
509 if (rep_CELL_CONS_P(rep_VAL(&sb->data[i]))
510 || !rep_GC_CELL_MARKEDP(rep_VAL(&sb->data[i])))
511 {
512 sb->data[i].car = rep_VAL(funarg_freelist);
513 funarg_freelist = &sb->data[i];
514 }
515 else
516 {
517 rep_GC_CLR_CELL(rep_VAL(&sb->data[i]));
518 rep_used_funargs++;
519 }
520 }
521 sb = nxt;
522 }
523 }
524
525 /* Returns (SYM . VALUE) if a lexical binding, or nil */
526 static repv
search_environment(repv sym)527 search_environment (repv sym)
528 {
529 register repv env;
530 for (env = rep_env; env != Qnil; env = rep_CDR (env))
531 {
532 if (rep_CONSP (rep_CAR (env))
533 && rep_CAAR(env) == LEXTAG
534 && rep_CADAR(env) == sym)
535 {
536 return rep_CDAR (env);
537 }
538 }
539 return Qnil;
540 }
541
542 /* this is also in lispmach.c and fluids.c */
543 static inline repv
inlined_search_special_bindings(repv sym)544 inlined_search_special_bindings (repv sym)
545 {
546 register repv env;
547 for (env = rep_special_bindings; env != Qnil; env = rep_CDR (env))
548 {
549 if (rep_CAAR(env) == sym)
550 return rep_CAR (env);
551 }
552 return Qnil;
553 }
554
555 static repv
search_special_bindings(repv sym)556 search_special_bindings (repv sym)
557 {
558 return inlined_search_special_bindings (sym);
559 }
560
561 static inline int
inlined_search_special_environment(repv sym)562 inlined_search_special_environment (repv sym)
563 {
564 register repv env = rep_SPECIAL_ENV;
565 while (rep_CONSP(env) && rep_CAR(env) != sym)
566 env = rep_CDR(env);
567
568 if (rep_CONSP(env))
569 return 1;
570 else if (env == Qt)
571 return -1;
572 else
573 return 0;
574 }
575
576 static int
search_special_environment__(repv sym)577 search_special_environment__ (repv sym)
578 {
579 return inlined_search_special_environment (sym);
580 }
581
582 static inline int
search_special_environment(repv sym)583 search_special_environment (repv sym)
584 {
585 if (rep_SPECIAL_ENV == Qt)
586 return -1;
587 else
588 return search_special_environment__ (sym);
589 }
590
591 repv
rep_call_with_closure(repv closure,repv (* fun)(repv arg),repv arg)592 rep_call_with_closure (repv closure, repv (*fun)(repv arg), repv arg)
593 {
594 repv ret = rep_NULL;
595 if (rep_FUNARGP (closure))
596 {
597 struct rep_Call lc;
598 lc.fun = lc.args = Qnil;
599 rep_PUSH_CALL (lc);
600 rep_USE_FUNARG (closure);
601 ret = fun (arg);
602 rep_POP_CALL (lc);
603 }
604 return ret;
605 }
606
607
608 /* Symbol binding */
609
610 repv
rep_bind_special(repv oldList,repv symbol,repv newVal)611 rep_bind_special (repv oldList, repv symbol, repv newVal)
612 {
613 if (inlined_search_special_environment (symbol))
614 {
615 rep_special_bindings = Fcons (Fcons (symbol, newVal),
616 rep_special_bindings);
617 oldList = rep_MARK_SPEC_BINDING (oldList);
618 }
619 else
620 Fsignal (Qvoid_value, rep_LIST_1(symbol));
621 return oldList;
622 }
623
624 /* This give SYMBOL a new value, saving the old one onto the front of
625 the list OLDLIST. OLDLIST is structured like (NSPECIALS . NLEXICALS)
626 Returns the new version of OLDLIST. */
627 repv
rep_bind_symbol(repv oldList,repv symbol,repv newVal)628 rep_bind_symbol(repv oldList, repv symbol, repv newVal)
629 {
630 if (oldList == Qnil)
631 oldList = rep_NEW_FRAME;
632
633 if (rep_SYM(symbol)->car & rep_SF_SPECIAL)
634 {
635 /* special binding */
636 oldList = rep_bind_special (oldList, symbol, newVal);
637 }
638 else
639 {
640 rep_env = Fcons (Fcons (LEXTAG, Fcons (symbol, newVal)), rep_env);
641 oldList = rep_MARK_LEX_BINDING (oldList);
642 }
643 return oldList;
644 }
645
646 /* Undoes what the above function does. Returns the number of special
647 bindings undone. */
648 int
rep_unbind_symbols(repv oldList)649 rep_unbind_symbols(repv oldList)
650 {
651 if (oldList != Qnil)
652 {
653 register repv tem;
654 int lexicals, specials;
655 int i;
656
657 assert (rep_INTP(oldList));
658
659 lexicals = rep_LEX_BINDINGS (oldList);
660 specials = rep_SPEC_BINDINGS (oldList);
661
662 tem = rep_env;
663 for (i = lexicals; i > 0; i--)
664 tem = rep_CDR (tem);
665 rep_env = tem;
666
667 tem = rep_special_bindings;
668 for (i = specials; i > 0; i--)
669 {
670 tem = rep_CDR (tem);
671 }
672 rep_special_bindings = tem;
673
674 assert (rep_special_bindings != rep_void_value);
675 assert (rep_env != rep_void_value);
676
677 return specials;
678 }
679 else
680 return 0;
681 }
682
683 repv
rep_add_binding_to_env(repv env,repv sym,repv value)684 rep_add_binding_to_env (repv env, repv sym, repv value)
685 {
686 return Fcons (Fcons (LEXTAG, Fcons (sym, value)), env);
687 }
688
689
690 /* More lisp functions */
691
692 DEFUN("defvar", Fdefvar, Sdefvar, (repv args, repv tail_posn), rep_SF) /*
693 ::doc:rep.lang.interpreter#defvar::
694 defvar NAME [DEFAULT-VALUE [DOC-STRING]]
695
696 Define a special variable called NAME whose standard value is DEFAULT-
697 VALUE. If NAME is already bound to a value (that's not an autoload
698 definition) it is left as it is, otherwise DEFAULT-VALUE is evaluated
699 and the special value of NAME is bound to the result.
700
701 If DOC-STRING is given, and is a string, it will be used to set the
702 `documentation' property of the symbol NAME.
703
704 (If the symbol NAME is marked buffer-local the default value of the
705 variable will be set (if necessary) not the local value.)
706 ::end:: */
707 {
708 if(rep_CONSP(args))
709 {
710 int spec;
711 repv sym = rep_CAR(args), val;
712 rep_bool need_to_eval;
713 repv tmp = Fdefault_boundp(sym);
714 if(!tmp)
715 return rep_NULL;
716
717 if (rep_CONSP(rep_CDR(args)))
718 {
719 val = rep_CADR(args);
720 args = rep_CDDR (args);
721 }
722 else
723 {
724 val = Qnil;
725 args = Qnil;
726 }
727
728 need_to_eval = rep_TRUE;
729 if(!rep_NILP(tmp))
730 {
731 /* Variable is bound, see if it's an autoload defn to overwrite. */
732 repv val = Fsymbol_value (sym, Qt);
733 if (rep_FUNARGP(val))
734 {
735 val = rep_FUNARG(val)->fun;
736 if(rep_CONSP(val) && rep_CAR(val) == Qautoload)
737 {
738 Fmakunbound (sym);
739 tmp = Qnil;
740 }
741 }
742 }
743
744 /* Only allowed to defvar in restricted environments
745 if the symbol hasn't yet been defvar'd or it's weak */
746 spec = search_special_environment (sym);
747 if (spec == 0 && (rep_SYM(sym)->car & rep_SF_DEFVAR)
748 && !(rep_SYM(sym)->car & rep_SF_WEAK))
749 {
750 return Fsignal (Qvoid_value, rep_LIST_1(sym)); /* XXX */
751 }
752
753 /* if initially making it special, check for a lexical binding
754 in the current module */
755 if (!(rep_SYM(sym)->car & rep_SF_SPECIAL))
756 {
757 repv tem = rep_get_initial_special_value (sym);
758 if (tem)
759 {
760 val = tem;
761 need_to_eval = rep_FALSE;
762 tmp = Qnil;
763 }
764 }
765
766 /* Only set the [default] value if its not boundp or
767 the definition is weak and we're currently unrestricted */
768 if(rep_NILP(tmp)
769 || ((rep_SYM(sym)->car & rep_SF_WEAK)
770 && !(rep_SYM(sym)->car & rep_SF_WEAK_MOD)
771 && rep_SPECIAL_ENV == Qt))
772 {
773 if (need_to_eval)
774 {
775 rep_GC_root gc_sym, gc_args;
776 rep_PUSHGC (gc_sym, sym);
777 rep_PUSHGC (gc_args, args);
778 val = Feval (val);
779 rep_POPGC; rep_POPGC;
780 if (!val)
781 return rep_NULL;
782 }
783 Fstructure_define (rep_specials_structure, sym, val);
784 }
785
786 rep_SYM(sym)->car |= rep_SF_SPECIAL | rep_SF_DEFVAR;
787
788 if (spec == 0)
789 {
790 /* defvar'ing an undefvar'd variable from a restricted
791 environment sets it as weak, and adds it to the env */
792
793 rep_SYM(sym)->car |= rep_SF_WEAK;
794 rep_SPECIAL_ENV = Fcons (sym, rep_SPECIAL_ENV);
795 }
796 else if (rep_SPECIAL_ENV == Qt && (rep_SYM(sym)->car & rep_SF_WEAK))
797 {
798 /* defvar'ing a weak variable from an unrestricted
799 environment removes the weak status, but marks
800 it as `was weak, but now strong'. This prevents
801 exploits such as:
802
803 [restricted special environment]
804 (defvar special-var "/bin/rm")
805
806 [unrestricted environment]
807 (defvar special-var "ls")
808
809 [back in restricted environment]
810 (setq special-var "/bin/rm")
811 --> error
812
813 Setting the variable the first time (since it's
814 unbound) adds it to the restricted environment,
815 but defvar'ing effectively removes it */
816
817 rep_SYM(sym)->car &= ~rep_SF_WEAK;
818 rep_SYM(sym)->car |= rep_SF_WEAK_MOD;
819 }
820
821 if(rep_CONSP(args))
822 {
823 repv doc = rep_CAR(args);
824 if (rep_STRINGP (doc))
825 {
826 if (Fput(sym, Qdocumentation, doc) == rep_NULL)
827 return rep_NULL;
828 }
829 }
830 return sym;
831 }
832 else
833 return rep_signal_missing_arg (1);
834 }
835
836 DEFUN("symbol-value", Fsymbol_value, Ssymbol_value, (repv sym, repv no_err), rep_Subr2) /*
837 ::doc:rep.lang.symbols#symbol-value::
838 symbol-value SYMBOL
839
840 Returns the value of SYMBOL, if SYMBOL is flagged as having buffer-local
841 values look for one of those first.
842 ::end:: */
843 /* Second argument (NO-ERR) means don't signal an error if the value is
844 void. */
845 {
846 /* Some of this function is hardcoded into the OP_REFQ
847 instruction in lispmach.c */
848 repv val = rep_void_value;
849 rep_DECLARE1(sym, rep_SYMBOLP);
850
851 if (rep_SYM(sym)->car & rep_SF_SPECIAL)
852 {
853 int spec = inlined_search_special_environment (sym);
854 /* modified-weak specials can only be accessed from an
855 unrestricted environment */
856 if (spec < 0 || (spec > 0 && !(rep_SYM(sym)->car & rep_SF_WEAK_MOD)))
857 {
858 if(rep_SYM(sym)->car & rep_SF_LOCAL)
859 val = (*rep_deref_local_symbol_fun)(sym);
860 if (val == rep_void_value)
861 {
862 repv tem = inlined_search_special_bindings (sym);
863 if (tem != Qnil)
864 val = rep_CDR (tem);
865 else
866 val = F_structure_ref (rep_specials_structure, sym);
867 }
868 }
869 }
870 else
871 {
872 /* lexical variable */
873 repv tem = search_environment (sym);
874 if (tem != Qnil)
875 val = rep_CDR(tem);
876 else
877 val = F_structure_ref (rep_structure, sym);
878 }
879
880 if (rep_SYM(sym)->car & rep_SF_DEBUG)
881 rep_single_step_flag = rep_TRUE;
882
883 if(no_err == Qnil && rep_VOIDP(val))
884 return Fsignal(Qvoid_value, rep_LIST_1(sym));
885 else
886 return val;
887 }
888
889 DEFUN("default-value", Fdefault_value, Sdefault_value,
890 (repv sym, repv no_err), rep_Subr2) /*
891 ::doc:rep.lang.symbols#default-value::
892 default-value SYMBOL
893
894 Returns the default value of the symbol SYMBOL. This will be the value of
895 SYMBOL in buffers or windows which do not have their own local value.
896 ::end:: */
897 {
898 repv val = rep_void_value;
899 rep_DECLARE1(sym, rep_SYMBOLP);
900
901 if (rep_SYM(sym)->car & rep_SF_SPECIAL)
902 {
903 int spec = search_special_environment (sym);
904 if (spec < 0 || (spec > 0 && !(rep_SYM(sym)->car & rep_SF_WEAK_MOD)))
905 {
906 repv tem = search_special_bindings (sym);
907 if (tem != Qnil)
908 val = rep_CDR (tem);
909 else
910 val = F_structure_ref (rep_specials_structure, sym);
911 }
912 }
913 else
914 val = F_structure_ref (rep_structure, sym);
915
916 if(no_err == Qnil && rep_VOIDP(val))
917 return Fsignal(Qvoid_value, rep_LIST_1(sym));
918 else
919 return val;
920 }
921
922 static repv
do_set(repv sym,repv val,repv (* setter)(repv st,repv var,repv val))923 do_set (repv sym, repv val, repv (*setter)(repv st, repv var, repv val))
924 {
925 /* Some of this function is hardcoded into the OP_SETQ
926 instruction in lispmach.c */
927 rep_DECLARE1(sym, rep_SYMBOLP);
928
929 if (rep_SYM(sym)->car & rep_SF_SPECIAL)
930 {
931 int spec = inlined_search_special_environment (sym);
932 if (spec)
933 {
934 repv tem;
935
936 /* Not allowed to set `modified' variables unless
937 our environment includes all variables implicitly */
938 if (spec > 0 && rep_SYM(sym)->car & rep_SF_WEAK_MOD)
939 return Fsignal (Qvoid_value, rep_LIST_1(sym)); /* XXX */
940
941 if(rep_SYM(sym)->car & rep_SF_LOCAL)
942 {
943 repv tem = (*rep_set_local_symbol_fun)(sym, val);
944 if (tem != rep_NULL)
945 return tem;
946 /* Fall through and set the default value. */
947 }
948 tem = inlined_search_special_bindings (sym);
949 if (tem != Qnil)
950 rep_CDR (tem) = val;
951 else
952 val = Fstructure_define (rep_specials_structure, sym, val);
953 }
954 else
955 val = Fsignal (Qvoid_value, rep_LIST_1(sym)); /* XXX */
956 }
957 else
958 {
959 /* lexical binding */
960 repv tem = search_environment (sym);
961 if (tem != Qnil)
962 rep_CDR(tem) = val;
963 else
964 val = setter (rep_structure, sym, val);
965 }
966 return val;
967 }
968
969 /* backwards compatibility for C callers */
Fset(repv s,repv v)970 repv Fset (repv s, repv v) { return do_set (s, v, Fstructure_define); };
971
972 DEFUN_INT("set", Freal_set, Sset, (repv s, repv v), rep_Subr2,
973 "vVariable:" rep_DS_NL "xNew value of %s:") /*
974 ::doc:rep.lang.symbols#set::
975 set SYMBOL repv
976
977 Sets the value of SYMBOL to repv. If SYMBOL has a buffer-local binding
978 in the current buffer or `make-variable-buffer-local' has been called on
979 SYMBOL the buffer-local value in the current buffer is set. Returns repv.
980 ::end:: */
981 {
982 return do_set (s, v, Fstructure_set);
983 }
984
985 DEFUN("set-default", Fset_default, Sset_default,
986 (repv sym, repv val), rep_Subr2) /*
987 ::doc:rep.lang.symbols#set-default::
988 set-default SYMBOL VALUE
989
990 Sets the default value of SYMBOL to VALUE, then returns VALUE.
991 ::end:: */
992 {
993 rep_DECLARE1(sym, rep_SYMBOLP);
994 if (rep_SYM (sym)->car & rep_SF_SPECIAL)
995 {
996 int spec = search_special_environment (sym);
997 if (spec)
998 {
999 repv tem;
1000
1001 if (spec > 0 && rep_SYM(sym)->car & rep_SF_WEAK_MOD)
1002 return Fsignal (Qvoid_value, rep_LIST_1(sym)); /* XXX */
1003
1004 tem = search_special_bindings (sym);
1005 if (tem != Qnil)
1006 rep_CDR (tem) = val;
1007 else
1008 val = Fstructure_define (rep_specials_structure, sym, val);
1009 }
1010 else
1011 return Fsignal (Qvoid_value, rep_LIST_1(sym)); /* XXX */
1012 }
1013 else
1014 Fstructure_set (rep_structure, sym, val);
1015 return val;
1016 }
1017
1018 DEFUN("setplist", Fsetplist, Ssetplist, (repv sym, repv prop), rep_Subr2) /*
1019 ::doc:rep.lang.symbols#setplist::
1020 setplist SYMBOL PROP-LIST
1021
1022 Sets the property list of SYMBOL to PROP-LIST, returns PROP-LIST.
1023 ::end:: */
1024 {
1025 int spec;
1026 rep_DECLARE1(sym, rep_SYMBOLP);
1027 spec = search_special_environment (sym);
1028 if (spec == 0)
1029 return Fsignal (Qvoid_value, rep_LIST_1(sym)); /* XXX */
1030
1031 Fstructure_define (plist_structure, sym, prop);
1032 return prop;
1033 }
1034
1035 DEFUN("symbol-name", Fsymbol_name, Ssymbol_name, (repv sym), rep_Subr1) /*
1036 ::doc:rep.lang.symbols#symbol-name::
1037 symbol-name SYMBOL
1038
1039 Returns the print-name of SYMBOL.
1040 ::end:: */
1041 {
1042 rep_DECLARE1(sym, rep_SYMBOLP);
1043 return(rep_SYM(sym)->name);
1044 }
1045
1046 DEFUN("default-boundp", Fdefault_boundp, Sdefault_boundp, (repv sym), rep_Subr1) /*
1047 ::doc:rep.lang.symbols#default-boundp::
1048 default-boundp SYMBOL
1049
1050 Returns t if SYMBOL has a default value.
1051 ::end:: */
1052 {
1053 rep_DECLARE1(sym, rep_SYMBOLP);
1054 if (rep_SYM(sym)->car & rep_SF_SPECIAL)
1055 {
1056 repv tem = search_special_bindings (sym);
1057 if (tem != Qnil)
1058 return rep_VOIDP (rep_CDR (tem)) ? Qnil : Qt;
1059 else
1060 {
1061 tem = F_structure_ref (rep_specials_structure, sym);
1062 return rep_VOIDP (tem) ? Qnil : Qt;
1063 }
1064 }
1065 else
1066 return Fstructure_bound_p (rep_structure, sym);
1067 }
1068
1069 DEFUN("boundp", Fboundp, Sboundp, (repv sym), rep_Subr1) /*
1070 ::doc:rep.lang.symbols#boundp::
1071 boundp SYMBOL
1072
1073 Returns t if SYMBOL has a value as a variable.
1074 ::end:: */
1075 {
1076 rep_DECLARE1(sym, rep_SYMBOLP);
1077 return(rep_VOIDP(Fsymbol_value(sym, Qt)) ? Qnil : Qt);
1078 }
1079
1080 DEFUN("symbol-plist", Fsymbol_plist, Ssymbol_plist, (repv sym), rep_Subr1) /*
1081 ::doc:rep.lang.symbols#symbol-plist::
1082 symbol-plist SYMBOL
1083
1084 Returns the property-list of SYMBOL.
1085 ::end:: */
1086 {
1087 int spec;
1088 repv plist;
1089 rep_DECLARE1(sym, rep_SYMBOLP);
1090 spec = search_special_environment (sym);
1091 if (spec == 0)
1092 return Fsignal (Qvoid_value, rep_LIST_1(sym)); /* XXX */
1093
1094 plist = F_structure_ref (plist_structure, sym);
1095 return rep_VOIDP (plist) ? Qnil : plist;
1096 }
1097
1098 DEFUN("gensym", Fgensym, Sgensym, (void), rep_Subr0) /*
1099 ::doc:rep.lang.symbols#gensym::
1100 gensym
1101
1102 Returns a new (non-interned) symbol with a unique print name.
1103 ::end:: */
1104 {
1105 static int counter;
1106 char buf[20];
1107 counter++;
1108 #ifdef HAVE_SNPRINTF
1109 snprintf(buf, sizeof(buf), "G%04d", counter);
1110 #else
1111 sprintf(buf, "G%04d", counter);
1112 #endif
1113 return(Fmake_symbol(rep_string_dup(buf)));
1114 }
1115
1116 DEFUN("symbolp", Fsymbolp, Ssymbolp, (repv sym), rep_Subr1) /*
1117 ::doc:rep.lang.symbols#symbolp::
1118 symbolp ARG
1119
1120 Returns t if ARG is a symbol.
1121 ::end:: */
1122 {
1123 return(rep_SYMBOLP(sym) ? Qt : Qnil);
1124 }
1125
1126 DEFUN("setq", Fsetq, Ssetq, (repv args, repv tail_posn), rep_SF) /*
1127 ::doc:rep.lang.interpreter#setq::
1128 setq [SYMBOL FORM] ...
1129
1130 Sets the value of each SYMBOL to the value of its corresponding FORM
1131 evaluated, returns the value of the last evaluation.
1132 ::end:: */
1133 {
1134 repv res = Qnil;
1135 rep_GC_root gc_args;
1136 rep_PUSHGC(gc_args, args);
1137 while(rep_CONSP(args) && rep_CONSP(rep_CDR(args)) && rep_SYMBOLP(rep_CAR(args)))
1138 {
1139 if(!(res = Feval(rep_CAR(rep_CDR(args)))))
1140 goto end;
1141 if(!Freal_set(rep_CAR(args), res))
1142 {
1143 res = rep_NULL;
1144 goto end;
1145 }
1146 args = rep_CDR(rep_CDR(args));
1147 }
1148 end:
1149 rep_POPGC;
1150 return(res);
1151 }
1152
1153 DEFUN ("%define", F_define, S_define, (repv args, repv tail_posn), rep_SF) /*
1154 ::doc:rep.lang.interpreter#%define::
1155 %define SYMBOL FORM [DOC-STRING]
1156
1157 Evaluate FORM, then create a top-level binding of SYMBOL whose value is
1158 the result of the evaluation. If such a binding already exists, it will
1159 be overwritten.
1160 ::end:: */
1161 {
1162 repv var, value, doc = Qnil;
1163 rep_GC_root gc_var, gc_doc;
1164
1165 if (!rep_assign_args (args, 2, 3, &var, &value, &doc))
1166 return rep_NULL;
1167
1168 rep_PUSHGC (gc_var, var);
1169 rep_PUSHGC (gc_doc, doc);
1170 value = Feval (value);
1171 rep_POPGC; rep_POPGC;
1172 if (value == rep_NULL)
1173 return rep_NULL;
1174
1175 value = Fstructure_define (rep_structure, var, value);
1176 if (value != rep_NULL)
1177 {
1178 if (doc != Qnil)
1179 {
1180 repv prop = rep_documentation_property (rep_structure);
1181 if (prop != Qnil)
1182 {
1183 if (Fput (var, prop, doc) == rep_NULL)
1184 value = rep_NULL;
1185 }
1186 }
1187 }
1188
1189 return rep_undefined_value;
1190 }
1191
1192 DEFUN("makunbound", Fmakunbound, Smakunbound, (repv sym), rep_Subr1) /*
1193 ::doc:rep.lang.symbols#makunbound::
1194 makunbound SYMBOL
1195
1196 Make SYMBOL have no value as a variable.
1197 ::end:: */
1198 {
1199 return Freal_set (sym, rep_void_value);
1200 }
1201
1202 DEFUN("get", Fget, Sget, (repv sym, repv prop), rep_Subr2) /*
1203 ::doc:rep.lang.symbols#get::
1204 get SYMBOL PROPERTY
1205
1206 Returns the value of SYMBOL's property PROPERTY. See `put'.
1207 ::end:: */
1208 {
1209 repv plist;
1210 rep_DECLARE1(sym, rep_SYMBOLP);
1211 plist = F_structure_ref (plist_structure, sym);
1212 if (rep_VOIDP (plist))
1213 return Qnil;
1214 while(rep_CONSP(plist) && rep_CONSP(rep_CDR(plist)))
1215 {
1216 if(rep_CAR(plist) == prop
1217 || (!rep_SYMBOLP(prop)
1218 && rep_value_cmp (rep_CAR(plist), prop) == 0))
1219 {
1220 return(rep_CAR(rep_CDR(plist)));
1221 }
1222 plist = rep_CDR(rep_CDR(plist));
1223 }
1224 return(Qnil);
1225 }
1226
1227 DEFUN("put", Fput, Sput, (repv sym, repv prop, repv val), rep_Subr3) /*
1228 ::doc:rep.lang.symbols#put::
1229 put SYMBOL PROPERTY repv
1230
1231 Sets the value of SYMBOL's property PROPERTY to repv, this value can be
1232 retrieved with the `get' function.
1233 ::end:: */
1234 {
1235 repv plist, old;
1236 int spec;
1237 rep_DECLARE1(sym, rep_SYMBOLP);
1238 spec = search_special_environment (sym);
1239 if (spec == 0)
1240 return Fsignal (Qvoid_value, rep_LIST_1(sym)); /* XXX */
1241
1242 old = F_structure_ref (plist_structure, sym);
1243 if (rep_VOIDP (old))
1244 old = Qnil;
1245 plist = old;
1246 while(rep_CONSP(plist) && rep_CONSP(rep_CDR(plist)))
1247 {
1248 if(rep_CAR(plist) == prop
1249 || (!rep_SYMBOLP(prop)
1250 && rep_value_cmp (rep_CAR(plist), prop) == 0))
1251 {
1252 if(!rep_CONS_WRITABLE_P(rep_CDR(plist)))
1253 {
1254 /* Can't write into a dumped cell; need to cons
1255 onto the head. */
1256 break;
1257 }
1258 rep_CAR(rep_CDR(plist)) = val;
1259 return val;
1260 }
1261 plist = rep_CDR(rep_CDR(plist));
1262 }
1263 Fstructure_define (plist_structure, sym, Fcons (prop, Fcons (val, old)));
1264 return val;
1265 }
1266
1267 DEFUN("apropos", Fapropos, Sapropos, (repv re, repv pred, repv ob), rep_Subr3) /*
1268 ::doc:rep.lang.symbols#apropos::
1269 apropos REGEXP [PREDICATE] [OBARRAY]
1270
1271 Returns a list of symbols from OBARRAY (or the default) whose print-name
1272 matches the regular-expression REGEXP. If PREDICATE is given and non-nil,
1273 each symbol which matches is applied to the function PREDICATE, if the value
1274 is non-nil it is considered a match.
1275 ::end:: */
1276 {
1277 rep_regexp *prog;
1278 rep_DECLARE1(re, rep_STRINGP);
1279 if(!rep_VECTORP(ob))
1280 ob = rep_obarray;
1281 prog = rep_regcomp(rep_STR(re));
1282 if(prog)
1283 {
1284 repv last = Qnil;
1285 int i, len = rep_VECT_LEN(ob);
1286 rep_GC_root gc_last, gc_ob, gc_pred;
1287 rep_PUSHGC(gc_last, last);
1288 rep_PUSHGC(gc_ob, ob);
1289 rep_PUSHGC(gc_pred, pred);
1290 for(i = 0; i < len; i++)
1291 {
1292 repv chain = rep_VECT(ob)->array[i];
1293 while(rep_SYMBOLP(chain))
1294 {
1295 if(rep_regexec(prog, rep_STR(rep_SYM(chain)->name)))
1296 {
1297 if(pred && !rep_NILP(pred))
1298 {
1299 repv tmp;
1300 if(!(tmp = rep_funcall(pred, rep_LIST_1(chain), rep_FALSE))
1301 || rep_NILP(tmp))
1302 {
1303 goto next;
1304 }
1305 }
1306 last = Fcons(chain, last);
1307 }
1308 next:
1309 chain = rep_SYM(chain)->next;
1310 }
1311 }
1312 rep_POPGC; rep_POPGC; rep_POPGC;
1313 free(prog);
1314 return(last);
1315 }
1316 return rep_NULL;
1317 }
1318
1319 DEFUN("make-variable-special", Fmake_variable_special,
1320 Smake_variable_special, (repv sym), rep_Subr1) /*
1321 ::doc:rep.lang.symbols#make-variable-special::
1322 make-variable-special SYMBOL
1323
1324 Mark SYMBOL as being a special (dynamically-bound) variable.
1325 ::end:: */
1326 {
1327 int spec;
1328 rep_DECLARE1(sym, rep_SYMBOLP);
1329 spec = search_special_environment (sym);
1330 if (spec == 0)
1331 return Fsignal (Qvoid_value, rep_LIST_1(sym)); /* XXX */
1332 if (!(rep_SYM(sym)->car & rep_SF_SPECIAL))
1333 {
1334 repv tem = rep_get_initial_special_value (sym);
1335 if (tem)
1336 Fstructure_define (rep_specials_structure, sym, tem);
1337 }
1338 rep_SYM(sym)->car |= rep_SF_SPECIAL;
1339 return sym;
1340 }
1341
1342 DEFUN("special-variable-p", Fspecial_variable_p, Sspecial_variable_p,
1343 (repv sym), rep_Subr1) /*
1344 ::doc:rep.lang.symbols#special-variable-p::
1345 special-variable-p SYMBOL
1346
1347 Returns t if SYMBOL is a special variable (dynamically scoped).
1348 ::end:: */
1349 {
1350 rep_DECLARE1(sym, rep_SYMBOLP);
1351 return (rep_SYM(sym)->car & rep_SF_SPECIAL) ? Qt : Qnil;
1352 }
1353
1354 DEFUN_INT("trace", Ftrace, Strace, (repv sym), rep_Subr1, "aFunction to trace") /*
1355 ::doc:rep.lang.debug#trace::
1356 trace SYMBOL
1357
1358 Flag that whenever SYMBOL is evaluated (as a variable or a function) the
1359 debugger is entered.
1360 ::end:: */
1361 {
1362 rep_DECLARE1(sym, rep_SYMBOLP);
1363 rep_SYM(sym)->car |= rep_SF_DEBUG;
1364 return(sym);
1365 }
1366
1367 DEFUN_INT("untrace", Funtrace, Suntrace, (repv sym), rep_Subr1, "aFunction to untrace") /*
1368 ::doc:rep.lang.debug#untrace::
1369 untrace SYMBOL
1370
1371 Cancel the effect of (trace SYMBOL).
1372 ::end:: */
1373 {
1374 rep_DECLARE1(sym, rep_SYMBOLP);
1375 rep_SYM(sym)->car &= ~rep_SF_DEBUG;
1376 return(sym);
1377 }
1378
1379 DEFUN("obarray", Fobarray, Sobarray, (repv val), rep_Subr1) /*
1380 ::doc:rep.lang.symbols#obarray::
1381 obarray [NEW-VALUE]
1382 ::end:: */
1383 {
1384 if(val != Qnil)
1385 {
1386 rep_DECLARE1(val, rep_VECTORP);
1387 rep_obarray = val;
1388 }
1389 return rep_obarray;
1390 }
1391
1392 DEFUN("make-keyword", Fmake_keyword, Smake_keyword, (repv in), rep_Subr1) /*
1393 ::doc:rep.lang.symbols#make-keyword::
1394 make-keyword SYMBOL
1395
1396 Return the keyword symbol that should be used in argument lists to
1397 provide the mark the value of the argument called SYMBOL. An error is
1398 signalled if SYMBOL is itself a keyword.
1399 ::end:: */
1400 {
1401 repv str, name, key;
1402 int name_len;
1403
1404 rep_DECLARE (1, in, rep_SYMBOLP (in) && !rep_KEYWORDP (in));
1405
1406 name = rep_SYM (in)->name;
1407 name_len = rep_STRING_LEN (name);
1408 str = rep_make_string (name_len + 3);
1409 rep_STR (str)[0] = '#';
1410 rep_STR (str)[1] = ':';
1411 memcpy (rep_STR (str) + 2, rep_STR (name), name_len);
1412 rep_STR (str)[name_len+2] = 0;
1413
1414 key = Fintern (str, rep_keyword_obarray);
1415 rep_SYM (key)->car |= rep_SF_KEYWORD;
1416 return key;
1417 }
1418
1419 DEFUN ("keywordp", Fkeywordp, Skeywordp, (repv arg), rep_Subr1) /*
1420 ::doc:rep.lang.symbols#keywordp::
1421 keywordp ARG
1422
1423 Return true if ARG is a keyword symbol.
1424 ::end:: */
1425 {
1426 return rep_KEYWORDP (arg) ? Qt : Qnil;
1427 }
1428
1429 int
rep_pre_symbols_init(void)1430 rep_pre_symbols_init(void)
1431 {
1432 rep_register_type(rep_Symbol, "symbol", symbol_cmp, symbol_princ,
1433 symbol_print, symbol_sweep, 0, 0, 0, 0, 0, 0, 0, 0);
1434 rep_obarray = Fmake_obarray(rep_MAKE_INT(rep_OBSIZE));
1435 rep_keyword_obarray = Fmake_obarray(rep_MAKE_INT(rep_KEY_OBSIZE));
1436 rep_register_type(rep_Funarg, "funarg", rep_ptr_cmp,
1437 rep_lisp_prin, rep_lisp_prin, funarg_sweep,
1438 0, 0, 0, 0, 0, 0, 0, 0);
1439 if(rep_obarray && rep_keyword_obarray)
1440 {
1441 rep_mark_static(&rep_obarray);
1442 rep_mark_static(&rep_keyword_obarray);
1443 return rep_TRUE;
1444 }
1445 else
1446 return rep_FALSE;
1447 }
1448
1449 void
rep_symbols_init(void)1450 rep_symbols_init(void)
1451 {
1452 DEFSTRING (hash_f, "#f");
1453 DEFSTRING (hash_t, "#t");
1454 DEFSTRING (hash_undefined, "#undefined");
1455
1456 repv tem;
1457
1458 rep_pre_datums_init (); /* initializes Qnil */
1459 rep_INTERN(t);
1460 rep_pre_structures_init ();
1461
1462 rep_USE_DEFAULT_ENV;
1463 rep_special_bindings = Qnil;
1464 rep_mark_static (&rep_env);
1465 rep_mark_static (&rep_special_bindings);
1466
1467 plist_structure = Fmake_structure (Qnil, Qnil, Qnil, Qnil);
1468 rep_mark_static (&plist_structure);
1469
1470 rep_INTERN(documentation);
1471 rep_INTERN(permanent_local);
1472
1473 rep_scm_f = Fmake_symbol (rep_VAL (&hash_f));
1474 rep_scm_t = Fmake_symbol (rep_VAL (&hash_t));
1475 rep_undefined_value = Fmake_symbol (rep_VAL (&hash_undefined));
1476 rep_SYM(rep_scm_f)->car |= rep_SF_LITERAL;
1477 rep_SYM(rep_scm_t)->car |= rep_SF_LITERAL;
1478 rep_SYM(rep_undefined_value)->car |= rep_SF_LITERAL;
1479 rep_mark_static (&rep_scm_f);
1480 rep_mark_static (&rep_scm_t);
1481 rep_mark_static (&rep_undefined_value);
1482
1483 tem = rep_push_structure ("rep.lang.symbols");
1484 rep_ADD_SUBR(Smake_symbol);
1485 rep_ADD_SUBR(Smake_obarray);
1486 rep_ADD_SUBR(Sfind_symbol);
1487 rep_ADD_SUBR(Sintern_symbol);
1488 rep_ADD_SUBR(Sintern);
1489 rep_ADD_SUBR(Sunintern);
1490 rep_ADD_SUBR(Ssymbol_value);
1491 rep_ADD_SUBR_INT(Sset);
1492 rep_ADD_SUBR(Ssetplist);
1493 rep_ADD_SUBR(Ssymbol_name);
1494 rep_ADD_SUBR(Sdefault_value);
1495 rep_ADD_SUBR(Sdefault_boundp);
1496 rep_ADD_SUBR(Sset_default);
1497 rep_ADD_SUBR(Sboundp);
1498 rep_ADD_SUBR(Ssymbol_plist);
1499 rep_ADD_SUBR(Sgensym);
1500 rep_ADD_SUBR(Ssymbolp);
1501 rep_ADD_SUBR(Smakunbound);
1502 rep_ADD_SUBR(Sget);
1503 rep_ADD_SUBR(Sput);
1504 rep_ADD_SUBR(Sapropos);
1505 rep_ADD_SUBR(Smake_variable_special);
1506 rep_ADD_SUBR(Sspecial_variable_p);
1507 rep_ADD_SUBR(Sobarray);
1508 rep_ADD_SUBR(Smake_keyword);
1509 rep_ADD_SUBR(Skeywordp);
1510 rep_pop_structure (tem);
1511
1512 tem = rep_push_structure ("rep.lang.interpreter");
1513 rep_ADD_SUBR(Ssetq);
1514 rep_ADD_SUBR(S_define);
1515 rep_ADD_SUBR(Sdefvar);
1516 rep_ADD_SUBR(Smake_closure);
1517 rep_ADD_SUBR(Sclosure_function);
1518 rep_ADD_SUBR(Sset_closure_function);
1519 rep_ADD_SUBR(Sclosure_name);
1520 rep_ADD_SUBR(Sclosurep);
1521 rep_ADD_SUBR(Ssubr_structure);
1522 rep_pop_structure (tem);
1523
1524 tem = rep_push_structure ("rep.structures");
1525 rep_ADD_SUBR(Sclosure_structure);
1526 rep_ADD_SUBR(Sset_closure_structure);
1527 rep_ADD_SUBR(Sset_special_environment);
1528 rep_pop_structure (tem);
1529
1530 tem = rep_push_structure ("rep.lang.debug");
1531 rep_ADD_SUBR_INT(Strace);
1532 rep_ADD_SUBR_INT(Suntrace);
1533 rep_pop_structure (tem);
1534 }
1535