![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to lread.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSD / contrib / emacs / src|
Return to lread.c CVS log | Up to [CSRG BSD Unix] / 43BSD / contrib / emacs / src |
1.1 root 1: /* Lisp parsing and input streams.
2: Copyright (C) 1985 Richard M. Stallman.
3:
4: This file is part of GNU Emacs.
5:
6: GNU Emacs is distributed in the hope that it will be useful,
7: but WITHOUT ANY WARRANTY. No author or distributor
8: accepts responsibility to anyone for the consequences of using it
9: or for whether it serves any particular purpose or works at all,
10: unless he says so in writing. Refer to the GNU Emacs General Public
11: License for full details.
12:
13: Everyone is granted permission to copy, modify and redistribute
14: GNU Emacs, but only under the conditions described in the
15: GNU Emacs General Public License. A copy of this license is
16: supposed to have been given to you along with GNU Emacs so you
17: can know your rights and responsibilities. It should be in a
18: file named COPYING. Among other things, the copyright notice
19: and this notice must be preserved on all copies. */
20:
21:
22: #include <stdio.h>
23: #include <sys/types.h>
24: #include <sys/stat.h>
25: #include <sys/file.h>
26: #undef NULL
27: #include "config.h"
28: #include "lisp.h"
29:
30: #ifndef standalone
31: #include "buffer.h"
32: #include "paths.h"
33: #endif
34:
35: #ifdef lint
36: #include <sys/inode.h>
37: #endif /* lint */
38:
39: #ifndef X_OK
40: #define X_OK 01
41: #endif
42:
43: Lisp_Object Qread_char, Qget_file_char, Qstandard_input;
44: Lisp_Object Qvariable_documentation, Vvalues, Vstandard_input;
45:
46: /* 1 iff inside of load */
47: int load_in_progress;
48:
49: /* Search path for files to be loaded. */
50: Lisp_Object Vload_path;
51:
52: /* File for get_file_char to read from. Use by load */
53: static FILE *instream;
54:
55: /* When nonzero, read conses in pure space */
56: static int read_pure;
57:
58: /* For use within read-from-string (this reader is non-reentrant!!) */
59: static int read_from_string_index;
60: static int read_from_string_limit;
61:
62: /* Handle unreading and rereading of characters.
63: Write READCHAR to read a character, UNREAD(c) to unread c to be read again. */
64:
65: static int unrch;
66:
67: static int readchar (readcharfun)
68: Lisp_Object readcharfun;
69: {
70: Lisp_Object tem;
71: register struct buffer_text *inbuffer;
72: register int c, mpos;
73:
74: if (unrch >= 0)
75: {
76: c = unrch;
77: unrch = -1;
78: return c;
79: }
80: if (XTYPE (readcharfun) == Lisp_Buffer)
81: {
82: if (XBUFFER (readcharfun) == bf_cur)
83: inbuffer = &bf_text;
84: else
85: inbuffer = &XBUFFER (readcharfun)->text;
86:
87: if (inbuffer->pointloc >
88: inbuffer->size1 + inbuffer->size2 - inbuffer->tail_clip)
89: return -1;
90: c = *(unsigned char *) &(inbuffer->pointloc > inbuffer->size1 ? inbuffer->p2 : inbuffer->p1)[inbuffer->pointloc];
91: inbuffer->pointloc++;
92: return c;
93: }
94: if (XTYPE (readcharfun) == Lisp_Marker)
95: {
96: if (XMARKER (readcharfun)->buffer == bf_cur)
97: inbuffer = &bf_text;
98: else
99: inbuffer = &XMARKER (readcharfun)->buffer->text;
100: mpos = marker_position (readcharfun);
101:
102: if (mpos >
103: inbuffer->size1 + inbuffer->size2 - inbuffer->tail_clip)
104: return -1;
105: c = *(unsigned char *) &(mpos > inbuffer->size1 ? inbuffer->p2 : inbuffer->p1)[mpos];
106: if (mpos != inbuffer->size1 + 1)
107: XMARKER (readcharfun)->bufpos++;
108: else
109: Fset_marker (readcharfun, make_number (mpos + 1),
110: Fmarker_buffer (readcharfun));
111: return c;
112: }
113: if (EQ (readcharfun, Qget_file_char))
114: return getc (instream);
115:
116: if (XTYPE (readcharfun) == Lisp_String)
117: return (read_from_string_index < read_from_string_limit) ?
118: XSTRING (readcharfun)->data[read_from_string_index++] : -1;
119:
120: tem = Fapply (readcharfun, Qnil);
121:
122: if (NULL (tem))
123: return -1;
124: return XINT (tem);
125: }
126:
127: #define READCHAR readchar(readcharfun)
128: #define UNREAD(c) (unrch = c)
129:
130: static Lisp_Object read0 (), read1 (), read_list (), read_vector ();
131:
132: /* get a character from the tty */
133:
134: DEFUN ("read-char", Fread_char, Sread_char, 0, 0, 0,
135: "Read a character from the command input (keyboard or macro).\n\
136: It is returned as a number.")
137: ()
138: {
139: register Lisp_Object val;
140:
141: #ifndef standalone
142: XSET (val, Lisp_Int, get_char (0));
143: #else
144: XSET (val, Lisp_Int, getchar ());
145: #endif
146:
147: return val;
148: }
149:
150: DEFUN ("get-file-char", Fget_file_char, Sget_file_char, 0, 0, 0,
151: "Don't use this yourself.")
152: ()
153: {
154: register Lisp_Object val;
155: XSET (val, Lisp_Int, getc (instream));
156: return val;
157: }
158:
159: void readevalloop ();
160: Lisp_Object load_unwind ();
161:
162: DEFUN ("load", Fload, Sload, 1, 3, "sLoad file: ",
163: "Execute a file of Lisp code named FILE.\n\
164: First tries FILE with .elc appended, then tries with .el,\n\
165: then tries FILE unmodified. Searches directories in load-path.\n\
166: If optional second arg MISSING-OK is non-nil,\n\
167: report no error if FILE doesn't exist.\n\
168: Print messages at start and end of loading unless\n\
169: optional third arg NOMESSAGE is non-nil.\n\
170: Return t if file exists.")
171: (str, missing_ok, nomessage)
172: Lisp_Object str, missing_ok, nomessage;
173: {
174: register FILE *stream;
175: register int fd = -1;
176: register Lisp_Object lispstream;
177: int count = specpdl_ptr - specpdl;
178: struct gcpro gcpro1;
179:
180: CHECK_STRING (str, 0);
181: str = Fsubstitute_in_file_name (str);
182:
183: /* Avoid weird lossage with null string as arg,
184: since it would try to load a directory as a Lisp file */
185: if (XSTRING (str)->size > 0)
186: {
187: fd = openp (Vload_path, str, ".elc", 0, 0);
188: if (fd < 0)
189: fd = openp (Vload_path, str, ".el", 0, 0);
190: if (fd < 0)
191: fd = openp (Vload_path, str, "", 0, 0);
192: }
193:
194: if (fd < 0)
195: if (NULL (missing_ok))
196: while (1)
197: Fsignal (Qfile_error, Fcons (build_string ("Cannot open load file"),
198: Fcons (str, Qnil)));
199: else return Qnil;
200:
201: stream = fdopen (fd, "r");
202: if (stream == 0)
203: {
204: close (fd);
205: error ("Failure to create stdio stream for %s", XSTRING (str)->data);
206: }
207: XSET (lispstream, Lisp_Internal_Stream, (int) stream);
208:
209: if (NULL (nomessage))
210: message ("Loading %s...", XSTRING (str)->data);
211:
212: GCPRO1 (str);
213: record_unwind_protect (load_unwind, lispstream);
214: load_in_progress = 1;
215: readevalloop (Qget_file_char, stream, Feval, 0);
216: unbind_to (count);
217: UNGCPRO;
218:
219: if (!noninteractive && NULL (nomessage))
220: message ("Loading %s...done", XSTRING (str)->data);
221: return Qt;
222: }
223:
224: /* exec_only nonzero means don't open the files,
225: just look for one that is executable;
226: returns 1 on success, having stored a string into *storeptr */
227:
228: int
229: openp (path, str, suffix, storeptr, exec_only)
230: Lisp_Object path, str;
231: char *suffix;
232: Lisp_Object *storeptr;
233: int exec_only;
234: {
235: register int fd;
236: int fn_size = 100;
237: char buf[100];
238: register char *fn = buf;
239: int absolute = 0;
240: int want_size;
241: register Lisp_Object filename;
242: struct stat st;
243:
244: if (storeptr)
245: *storeptr = Qnil;
246:
247: if (*XSTRING (str)->data == '~' || *XSTRING (str)->data == '/')
248: absolute = 1;
249:
250: for (; !NULL (path); path = Fcdr (path))
251: {
252: filename = Fexpand_file_name (str, Fcar (path));
253:
254: want_size = strlen (suffix) + XSTRING (filename)->size + 1;
255: if (fn_size < want_size)
256: fn = (char *) alloca (fn_size = 100 + want_size);
257:
258: strncpy (fn, XSTRING (filename)->data, XSTRING (filename)->size);
259: fn[XSTRING (filename)->size] = 0;
260: strcat (fn, suffix);
261: if (exec_only)
262: {
263: if (!access (fn, X_OK) && stat (fn, &st) >= 0
264: && (st.st_mode & S_IFMT) != S_IFDIR)
265: {
266: if (storeptr)
267: *storeptr = build_string (fn);
268: return 1;
269: }
270: }
271: else
272: {
273: fd = open (fn, 0, 0);
274: if (fd >= 0)
275: {
276: if (storeptr)
277: *storeptr = build_string (fn);
278: return fd;
279: }
280: }
281: if (absolute) return -1;
282: }
283:
284: return -1;
285: }
286:
287: Lisp_Object
288: load_unwind (stream) /* used as unwind-protect function in load */
289: Lisp_Object stream;
290: {
291: fclose ((FILE *) XSTRING (stream));
292: load_in_progress = 0;
293: return Qnil;
294: }
295:
296: Lisp_Object
297: unreadpure () /* Used as unwind-protect function in readevalloop */
298: {
299: read_pure = 0;
300: return Qnil;
301: }
302:
303: void
304: readevalloop (readcharfun, stream, evalfun, printflag)
305: Lisp_Object readcharfun;
306: FILE *stream;
307: Lisp_Object (*evalfun) ();
308: int printflag;
309: {
310: register int c;
311: register Lisp_Object val;
312: register int xunrch;
313: int count = specpdl_ptr - specpdl;
314:
315: specbind (Qstandard_input, readcharfun);
316:
317: unrch = -1;
318:
319: while (1)
320: {
321: instream = stream;
322: c = READCHAR;
323: if (c == ';')
324: {
325: while ((c = READCHAR) != '\n' && c != -1);
326: continue;
327: }
328: if (c < 0) break;
329: if (c == ' ' || c == '\t' || c == '\n' || c == '\f') continue;
330:
331: if (!NULL (Vpurify_flag) && c == '(')
332: {
333: record_unwind_protect (unreadpure, Qnil);
334: val = read_list (-1, readcharfun);
335: unbind_to (count + 1);
336: }
337: else
338: {
339: UNREAD (c);
340: val = read0 (readcharfun);
341: }
342:
343: xunrch = unrch;
344: unrch = -1;
345: val = (*evalfun) (val);
346: if (printflag)
347: {
348: Vvalues = Fcons (val, Vvalues);
349: if (EQ (Vstandard_output, Qt))
350: Fprin1 (val, Qnil);
351: else
352: Fprint (val, Qnil);
353: }
354: unrch = xunrch;
355: }
356:
357: unbind_to (count);
358: }
359:
360: #ifndef standalone
361:
362: DEFUN ("eval-current-buffer", Feval_current_buffer, Seval_current_buffer, 0, 1, "",
363: "Execute the current buffer as Lisp code.\n\
364: Programs can pass argument PRINTFLAG which controls printing of output:\n\
365: nil means discard it; anything else is stream for print.")
366: (printflag)
367: Lisp_Object printflag;
368: {
369: int count = specpdl_ptr - specpdl;
370: Lisp_Object tem;
371: if (NULL (printflag))
372: tem = Qsymbolp;
373: else
374: tem = printflag;
375: specbind (Qstandard_output, tem);
376: record_unwind_protect (save_excursion_restore, save_excursion_save ());
377: SetPoint (FirstCharacter);
378: readevalloop (Fcurrent_buffer (), 0, Feval, !NULL (printflag));
379: unbind_to (count);
380: return Qnil;
381: }
382:
383: DEFUN ("eval-region", Feval_region, Seval_region, 2, 3, "r",
384: "Execute the region as Lisp code.\n\
385: When called from programs, expects two arguments,\n\
386: giving starting and ending indices in the current buffer\n\
387: of the text to be executed.\n\
388: Programs can pass third argument PRINTFLAG which controls printing of output:\n\
389: nil means discard it; anything else is stream for print.")
390: (b, e, printflag)
391: Lisp_Object b, e, printflag;
392: {
393: int count = specpdl_ptr - specpdl;
394: Lisp_Object tem;
395: if (NULL (printflag))
396: tem = Qsymbolp;
397: else
398: tem = printflag;
399: specbind (Qstandard_output, tem);
400: if (NULL (printflag))
401: record_unwind_protect (save_excursion_restore, save_excursion_save ());
402: record_unwind_protect (save_restriction_restore, save_restriction_save ());
403: SetPoint (XINT (b));
404: Fnarrow_to_region (make_number (FirstCharacter), e);
405: readevalloop (Fcurrent_buffer (), 0, Feval, !NULL (printflag));
406: unbind_to (count);
407: return Qnil;
408: }
409:
410: #endif standalone
411:
412: DEFUN ("read", Fread, Sread, 0, 1, 0,
413: "Read one Lisp expression as text from STREAM, return as Lisp object.\n\
414: If STREAM is nil, use the value of standard-input (which see).\n\
415: STREAM or standard-input may be:\n\
416: a buffer (read from point and advance it)\n\
417: a marker (read from where it points and advance it)\n\
418: a function (call it with no arguments for each character)\n\
419: a string (takes text from string, starting at the beginning)\n\
420: t (read text line using minibuffer and use it).")
421: (readcharfun)
422: Lisp_Object readcharfun;
423: {
424: extern Lisp_Object Fread_minibuffer ();
425:
426: unrch = -1; /* Allow buffering-back only within a read. */
427:
428: if (NULL (readcharfun))
429: readcharfun = Vstandard_input;
430: if (EQ (readcharfun, Qt))
431: readcharfun = Qread_char;
432:
433: #ifndef standalone
434: if (EQ (readcharfun, Qread_char))
435: return Fread_minibuffer (build_string ("Lisp expression: "), Qnil);
436: #endif
437:
438: if (XTYPE (readcharfun) == Lisp_String)
439: return Fcar (Fread_from_string (readcharfun, Qnil, Qnil));
440:
441: return read0 (readcharfun);
442: }
443:
444: DEFUN ("read-from-string", Fread_from_string, Sread_from_string, 1, 3, 0,
445: "Read one Lisp expression which is represented as text by STRING.\n\
446: Returns a cons: (OBJECT-READ . FINAL-STRING-INDEX).\n\
447: START and END optionally delimit a substring of STRING from which to read;\n\
448: they default to 0 and (length STRING) respectively.")
449: (string, start, end)
450: Lisp_Object string, start, end;
451: {
452: int startval, endval;
453: Lisp_Object tem;
454:
455: CHECK_STRING (string,0);
456:
457: if (NULL (end))
458: endval = XSTRING (string)->size;
459: else
460: { CHECK_NUMBER (end,2);
461: endval = XINT (end);
462: if (endval < 0 || endval > XSTRING (string)->size)
463: args_out_of_range (string, end);
464: }
465:
466: if (NULL (start))
467: startval = 0;
468: else
469: { CHECK_NUMBER (start,1);
470: startval = XINT (start);
471: if (startval < 0 || startval > endval)
472: args_out_of_range (string, start);
473: }
474:
475: read_from_string_index = startval;
476: read_from_string_limit = endval;
477:
478: unrch = -1; /* Allow buffering-back only within a read. */
479:
480: tem = read0 (string);
481: return Fcons (tem, make_number (read_from_string_index));
482: }
483:
484: /* Use this for recursive reads, in contexts where internal tokens are not allowed. */
485:
486: static Lisp_Object
487: read0 (readcharfun)
488: Lisp_Object readcharfun;
489: {
490: register Lisp_Object val;
491: char c;
492:
493: val = read1 (readcharfun);
494: if (XTYPE (val) == Lisp_Internal)
495: {
496: c = XINT (val);
497: return Fsignal (Qinvalid_read_syntax, Fcons (make_string (&c, 1), Qnil));
498: }
499:
500: return val;
501: }
502:
503: static int read_buffer_size;
504: static char *read_buffer;
505:
506: static Lisp_Object
507: read1 (readcharfun)
508: register Lisp_Object readcharfun;
509: {
510: register int c;
511:
512: retry:
513:
514: c = READCHAR;
515: if (c < 0) return Fsignal (Qend_of_file, Qnil);
516:
517: switch (c)
518: {
519: case '(':
520: return read_list (0, readcharfun);
521:
522: case '[':
523: return read_vector (readcharfun);
524:
525: case ')':
526: case ']':
527: case '.':
528: {
529: register Lisp_Object val;
530: XSET (val, Lisp_Internal, c);
531: return val;
532: }
533:
534: case '#':
535: return Fsignal (Qinvalid_read_syntax, Fcons (make_string ("#", 1), Qnil));
536:
537: case ';':
538: while ((c = READCHAR) >= 0 && c != '\n');
539: goto retry;
540:
541: case '\'':
542: {
543: return Fcons (Qquote, Fcons (read0 (readcharfun), Qnil));
544: }
545:
546: case '?':
547: {
548: register Lisp_Object val;
549:
550: XSET (val, Lisp_Int, READCHAR);
551: if (XFASTINT (val) == '\\')
552: XSETINT (val, read_escape (readcharfun));
553:
554: return val;
555: }
556:
557: case '\"':
558: {
559: register char *p = read_buffer;
560: register char *end = read_buffer + read_buffer_size;
561: register int c;
562: int cancel = 0;
563:
564: while ((c = READCHAR) >= 0 &&
565: (c != '\"' || (c = READCHAR) == '\"'))
566: {
567: if (p == end)
568: {
569: char *new = (char *) xrealloc (read_buffer, read_buffer_size *= 2);
570: p += new - read_buffer;
571: read_buffer += new - read_buffer;
572: end = read_buffer + read_buffer_size;
573: }
574: if (c == '\\')
575: c = read_escape (readcharfun);
576: /* c is -1 if \ newline has just been seen */
577: if (c < 0)
578: {
579: if (p == read_buffer)
580: cancel = 1;
581: }
582: else
583: *p++ = c;
584: }
585:
586: UNREAD (c);
587: /* If purifying, and string starts with \ newline,
588: return zero instead. This is for doc strings
589: that we are really going to find in etc/DOC.nn.nn */
590: if (!NULL (Vpurify_flag) && NULL (Vdoc_file_name) && cancel)
591: return make_number (0);
592:
593: if (read_pure)
594: return make_pure_string (read_buffer, p - read_buffer);
595: else
596: return make_string (read_buffer, p - read_buffer);
597: }
598:
599: default:
600: if (c <= 040) goto retry;
601: {
602: register char *p = read_buffer;
603:
604: {
605: register char *end = read_buffer + read_buffer_size;
606:
607: while (c > 040 &&
608: !(c == '\"' || c == '\'' || c == ';' || c == '?'
609: || c == '(' || c == ')' || c =='.'
610: || c == '[' || c == ']' || c == '#'
611: ))
612: {
613: if (p == end)
614: {
615: register char *new = (char *) xrealloc (read_buffer, read_buffer_size *= 2);
616: p += new - read_buffer;
617: read_buffer += new - read_buffer;
618: end = read_buffer + read_buffer_size;
619: }
620: if (c == '\\')
621: c = READCHAR;
622: *p++ = c;
623: c = READCHAR;
624: }
625:
626: if (p == end)
627: {
628: char *new = (char *) xrealloc (read_buffer, read_buffer_size *= 2);
629: p += new - read_buffer;
630: read_buffer += new - read_buffer;
631: end = read_buffer + read_buffer_size;
632: }
633: *p = 0;
634: UNREAD (c);
635: }
636:
637: /* Is it an integer? */
638: {
639: register char *p1;
640: register Lisp_Object val;
641: p1 = read_buffer;
642: if (*p1 == '+' || *p1 == '-') p1++;
643: if (p1 != p)
644: {
645: while (p1 != p && (c = *p1) >= '0' && c <= '9') p1++;
646: if (p1 == p)
647: /* It is. */
648: {
649: XSET (val, Lisp_Int, atoi (read_buffer));
650: return val;
651: }
652: }
653: }
654:
655: return intern (read_buffer);
656: }
657: }
658: }
659:
660: static Lisp_Object
661: read_vector (readcharfun)
662: Lisp_Object readcharfun;
663: {
664: register int i;
665: register int size;
666: register Lisp_Object *ptr;
667: register Lisp_Object tem, vector;
668: register struct Lisp_Cons *otem;
669: Lisp_Object len;
670:
671: tem = read_list (1, readcharfun);
672: len = Flength (tem);
673: vector = (read_pure ? make_pure_vector (XINT (len)) : Fmake_vector (len, Qnil));
674:
675:
676: size = XVECTOR (vector)->size;
677: ptr = XVECTOR (vector)->contents;
678: for (i = 0; i < size; i++)
679: {
680: ptr[i] = read_pure ? Fpurecopy (Fcar (tem)) : Fcar (tem);
681: otem = XCONS (tem);
682: tem = Fcdr (tem);
683: free_cons (otem);
684: }
685: return vector;
686: }
687:
688: /* flag = 1 means check for ] to terminate rather than ) and .
689: flag = -1 means check for starting with defun
690: and make structure pure. */
691:
692: static Lisp_Object
693: read_list (flag, readcharfun)
694: int flag;
695: register Lisp_Object readcharfun;
696: {
697: /* -1 means check next element for defun,
698: 0 means don't check,
699: 1 means already checked and found defun. */
700: int defunflag = flag < 0 ? -1 : 0;
701: register Lisp_Object elt, val, tail, tem;
702:
703: val = Qnil;
704: tail = Qnil;
705:
706: while (1)
707: {
708: elt = read1 (readcharfun);
709: if (XTYPE (elt) == Lisp_Internal)
710: {
711: if (flag > 0)
712: {
713: if (XINT (elt) == ']')
714: return val;
715: return Fsignal (Qinvalid_read_syntax, Fcons (make_string (") or . in a vector", 18), Qnil));
716: }
717: if (XINT (elt) == ')')
718: return val;
719: if (XINT (elt) == '.')
720: {
721: if (!NULL (tail))
722: tail = XCONS (tail)->cdr = read0 (readcharfun);
723: else
724: val = read0 (readcharfun);
725: elt = read1 (readcharfun);
726: if (XTYPE (elt) == Lisp_Internal && XINT (elt) == ')')
727: return val;
728: return Fsignal (Qinvalid_read_syntax, Fcons (make_string (". in wrong context", 18), Qnil));
729: }
730: return Fsignal (Qinvalid_read_syntax, Fcons (make_string ("] in a vector", 13), Qnil));
731: }
732: tem = (read_pure && flag <= 0
733: ? pure_cons (elt, Qnil)
734: : Fcons (elt, Qnil));
735: if (!NULL (tail))
736: XCONS (tail)->cdr = tem;
737: else
738: val = tem;
739: tail = tem;
740: if (defunflag < 0)
741: defunflag = EQ (elt, Qdefun);
742: else if (defunflag > 0)
743: read_pure = 1;
744: }
745: }
746:
747: static int
748: read_escape (readcharfun)
749: Lisp_Object readcharfun;
750: {
751: register int c = READCHAR;
752: switch (c)
753: {
754: case 'a':
755: return '\a';
756: case 'b':
757: return '\b';
758: case 'e':
759: return 033;
760: case 'f':
761: return '\f';
762: case 'n':
763: return '\n';
764: case 'r':
765: return '\r';
766: case 't':
767: return '\t';
768: case 'v':
769: return '\v';
770: case '\n':
771: return -1;
772:
773: case 'M':
774: c = READCHAR;
775: if (c != '-')
776: error ("Invalid escape character syntax");
777: c = READCHAR;
778: if (c == '\\')
779: c = read_escape (readcharfun);
780: return c | 0200;
781:
782: case 'C':
783: c = READCHAR;
784: if (c != '-')
785: error ("Invalid escape character syntax");
786: case '^':
787: c = READCHAR;
788: if (c == '\\')
789: c = read_escape (readcharfun);
790: if (c == '?')
791: return 0177;
792: return (c & 0200) | (c & 037);
793:
794: case '0':
795: case '1':
796: case '2':
797: case '3':
798: case '4':
799: case '5':
800: case '6':
801: case '7':
802: {
803: register int i = c - '0';
804: register int count = 0;
805: while (++count < 3)
806: {
807: if ((c = READCHAR) >= '0' && c <= '7')
808: {
809: i *= 8;
810: i += c - '0';
811: }
812: else
813: {
814: UNREAD (c);
815: break;
816: }
817: }
818: return i;
819: }
820: default:
821: return c;
822: }
823: }
824:
825: Lisp_Object Vobarray;
826: Lisp_Object initial_obarray;
827:
828: /* CHECK_OBARRAY assumes the variable `tem' is available */
829: #define CHECK_OBARRAY(obarray) \
830: if (XTYPE (obarray) != Lisp_Vector) \
831: { tem = obarray; obarray = initial_obarray; \
832: wrong_type_argument (Qvectorp, tem); }
833:
834: static int hash_string ();
835: Lisp_Object oblookup ();
836:
837: Lisp_Object
838: intern (str)
839: char *str;
840: {
841: Lisp_Object tem;
842: int len = strlen (str);
843: CHECK_OBARRAY (Vobarray);
844: tem = oblookup (Vobarray, str, len);
845: if (XTYPE (tem) == Lisp_Symbol)
846: return tem;
847: return Fintern ((!NULL (Vpurify_flag)
848: ? make_pure_string (str, len)
849: : make_string (str, len)),
850: Vobarray);
851: }
852:
853: DEFUN ("intern", Fintern, Sintern, 1, 2, 0,
854: "Return the symbol whose name is STRING.\n\
855: A second optional argument specifies the obarray to use;\n\
856: it defaults to the value of obarray.")
857: (str, obarray)
858: Lisp_Object str, obarray;
859: {
860: register Lisp_Object tem, sym, *ptr;
861:
862: if (NULL (obarray))
863: {
864: CHECK_OBARRAY (Vobarray);
865: obarray = Vobarray;
866: }
867: else
868: CHECK_VECTOR (obarray, 1);
869:
870: CHECK_STRING (str, 0);
871:
872: tem = oblookup (obarray, XSTRING (str)->data, XSTRING (str)->size);
873: if (XTYPE (tem) != Lisp_Int)
874: return tem;
875:
876: if (!NULL (Vpurify_flag))
877: str = Fpurecopy (str);
878: sym = Fmake_symbol (str);
879:
880: ptr = &XVECTOR (obarray)->contents[XINT (tem)];
881: if (XTYPE (*ptr) == Lisp_Symbol)
882: XSYMBOL (sym)->next = XSYMBOL (*ptr);
883: else
884: XSYMBOL (sym)->next = 0;
885: *ptr = sym;
886: return sym;
887: }
888:
889: DEFUN ("intern-soft", Fintern_soft, Sintern_soft, 1, 2, 0,
890: "Return the symbol whose name is STRING, or nil if none exists yet.\n\
891: A second optional argument specifies the obarray to use;\n\
892: it defaults to the value of obarray.")
893: (str, obarray)
894: Lisp_Object str, obarray;
895: {
896: register Lisp_Object tem;
897:
898: if (NULL (obarray))
899: {
900: CHECK_OBARRAY (Vobarray);
901: obarray = Vobarray;
902: }
903: else
904: CHECK_VECTOR (obarray, 1);
905:
906: CHECK_STRING (str, 0);
907:
908: tem = oblookup (obarray, XSTRING (str)->data, XSTRING (str)->size);
909: if (XTYPE (tem) != Lisp_Int)
910: return tem;
911: return Qnil;
912: }
913:
914: Lisp_Object
915: oblookup (obarray, ptr, size)
916: Lisp_Object obarray;
917: register char *ptr;
918: register int size;
919: {
920: int hash, obsize;
921: register Lisp_Object tail;
922: Lisp_Object bucket, tem;
923:
924: if (XTYPE (obarray) != Lisp_Vector || !(obsize = XVECTOR (obarray)->size))
925: error ("Invalid obarray");
926: hash = hash_string (ptr, size) % obsize;
927: bucket = XVECTOR (obarray)->contents[hash];
928: for (tail = bucket; XSYMBOL (tail); XSETSYMBOL (tail, XSYMBOL (tail)->next))
929: {
930: if (XSYMBOL (tail)->name->size != size) continue;
931: if (bcmp (XSYMBOL (tail)->name->data, ptr, size)) continue;
932: return tail;
933: }
934:
935: XSET (tem, Lisp_Int, hash);
936: return tem;
937: }
938:
939: static int
940: hash_string (ptr, len)
941: unsigned char *ptr;
942: int len;
943: {
944: register unsigned char *p = ptr;
945: register unsigned char *end = p + len;
946: register unsigned char c;
947: register int hash = 0;
948:
949: while (p != end)
950: {
951: c = *p++;
952: if (c >= 0140) c -= 40;
953: hash = ((hash<<3) + (hash>>28) + c);
954: }
955: return hash & 07777777777;
956: }
957:
958: void
959: map_obarray (obarray, fn, arg)
960: Lisp_Object obarray;
961: int (*fn) ();
962: Lisp_Object arg;
963: {
964: register int i;
965: register Lisp_Object tail;
966: CHECK_VECTOR (obarray, 1);
967: for (i = XVECTOR (obarray)->size - 1; i >= 0; i--)
968: for (tail = XVECTOR (obarray)->contents[i];
969: XTYPE (tail) == Lisp_Symbol && XSYMBOL (tail);
970: XSETSYMBOL (tail, XSYMBOL (tail)->next))
971: (*fn) (tail, arg);
972: }
973:
974: mapatoms_1 (sym, function)
975: Lisp_Object sym, function;
976: {
977: call1 (function, sym);
978: }
979:
980: DEFUN ("mapatoms", Fmapatoms, Smapatoms, 1, 2, 0,
981: "Call FUNCTION on every symbol in OBARRAY.\n\
982: OBARRAY defaults to the value of obarray.")
983: (function, obarray)
984: Lisp_Object function, obarray;
985: {
986: Lisp_Object tem;
987:
988: if (NULL (obarray))
989: {
990: CHECK_OBARRAY (Vobarray);
991: obarray = Vobarray;
992: }
993: else
994: CHECK_VECTOR (obarray, 1);
995:
996: map_obarray (obarray, mapatoms_1, function);
997: return Qnil;
998: }
999:
1000: #define OBARRAY_SIZE 511
1001:
1002: void
1003: init_obarray ()
1004: {
1005: Lisp_Object oblength;
1006: int hash;
1007: Lisp_Object *tem;
1008:
1009: XFASTINT (oblength) = OBARRAY_SIZE;
1010:
1011: Qnil = Fmake_symbol (make_pure_string ("nil", 3));
1012: Vobarray = Fmake_vector (oblength, make_number (0));
1013: initial_obarray = Vobarray;
1014: staticpro (&Vobarray);
1015: staticpro (&initial_obarray);
1016: /* Intern nil in the obarray */
1017: /* These locals are to kludge around a pyramid compiler bug. */
1018: hash = hash_string ("nil", 3) % OBARRAY_SIZE;
1019: tem = &XVECTOR (Vobarray)->contents[hash];
1020: *tem = Qnil;
1021:
1022: Qunbound = Fmake_symbol (make_pure_string ("unbound", 7));
1023: XSYMBOL (Qnil)->function = Qunbound;
1024: XSYMBOL (Qunbound)->value = Qunbound;
1025: XSYMBOL (Qunbound)->function = Qunbound;
1026:
1027: Qt = intern ("t");
1028: XSYMBOL (Qnil)->value = Qnil;
1029: XSYMBOL (Qnil)->plist = Qnil;
1030: XSYMBOL (Qt)->value = Qt;
1031:
1032: Qvariable_documentation = intern ("variable-documentation");
1033:
1034: read_buffer_size = 100;
1035: read_buffer = (char *) malloc (read_buffer_size);
1036: }
1037:
1038: void
1039: defsubr (sname)
1040: struct Lisp_Subr *sname;
1041: {
1042: Lisp_Object sym;
1043: sym = intern (sname->symbol_name);
1044: XSET (XSYMBOL (sym)->function, Lisp_Subr, sname);
1045: }
1046:
1047: void
1048: defalias (sname, string)
1049: struct Lisp_Subr *sname;
1050: char *string;
1051: {
1052: Lisp_Object sym;
1053: sym = intern (string);
1054: XSET (XSYMBOL (sym)->function, Lisp_Subr, sname);
1055: }
1056:
1057: /* Define an "integer variable"; a symbol whose value is forwarded
1058: to a C variable of type int. Sample call is
1059: DefIntVar ("indent-tabs-mode", &indent_tabs_mode, "Documentation"); */
1060:
1061: void
1062: DefIntVar (namestring, address, doc)
1063: char *namestring;
1064: int *address;
1065: char *doc;
1066: {
1067: Lisp_Object sym;
1068: sym = intern (namestring);
1069: XSET (XSYMBOL (sym)->value, Lisp_Intfwd, address);
1070: Fput (sym, Qvariable_documentation,
1071: make_pure_string (doc, strlen (doc)));
1072: }
1073:
1074: /* Similar but define a variable whose value is T if address contains 1,
1075: NIL if address contains 0 */
1076:
1077: void
1078: DefBoolVar (namestring, address, doc)
1079: char *namestring;
1080: int *address;
1081: char *doc;
1082: {
1083: Lisp_Object sym;
1084: sym = intern (namestring);
1085: XSET (XSYMBOL (sym)->value, Lisp_Boolfwd, address);
1086: Fput (sym, Qvariable_documentation,
1087: make_pure_string (doc, strlen (doc)));
1088: }
1089:
1090: /* Similar but define a variable whose value is the Lisp Object stored at address. */
1091:
1092: void
1093: DefLispVar (namestring, address, doc)
1094: char *namestring;
1095: Lisp_Object *address;
1096: char *doc;
1097: {
1098: Lisp_Object sym;
1099: sym = intern (namestring);
1100: XSET (XSYMBOL (sym)->value, Lisp_Objfwd, address);
1101: Fput (sym, Qvariable_documentation,
1102: make_pure_string (doc, strlen (doc)));
1103: }
1104:
1105: #ifndef standalone
1106:
1107: /* Similar but define a variable whose value is the Lisp Object stored in
1108: the current buffer. address is the address of the slot in the buffer that is current now. */
1109:
1110: void
1111: DefBufferLispVar (namestring, address, doc)
1112: char *namestring;
1113: Lisp_Object *address;
1114: char *doc;
1115: {
1116: Lisp_Object sym;
1117: sym = intern (namestring);
1118: XSET (XSYMBOL (sym)->value, Lisp_Buffer_Objfwd,
1119: (Lisp_Object *)((char *)address - (char *)bf_cur));
1120: Fput (sym, Qvariable_documentation,
1121: make_pure_string (doc, strlen (doc)));
1122: }
1123:
1124: #endif standalone
1125:
1126: init_read ()
1127: {
1128: Vvalues = Qnil;
1129:
1130: Vload_path = decode_env_path ("EMACSLOADPATH", PATH_LOADSEARCH);
1131: #ifndef CANNOT_DUMP
1132: if (!NULL (Vpurify_flag))
1133: Vload_path = Fcons (build_string ("../lisp"), Vload_path);
1134: #endif /* not CANNOT_DUMP */
1135: }
1136:
1137: void
1138: syms_of_read ()
1139: {
1140: defsubr (&Sread);
1141: defsubr (&Sread_from_string);
1142: defsubr (&Sintern);
1143: defsubr (&Sintern_soft);
1144: defsubr (&Sload);
1145: defsubr (&Seval_current_buffer);
1146: defsubr (&Seval_region);
1147: defsubr (&Sread_char);
1148: defsubr (&Sget_file_char);
1149: defsubr (&Smapatoms);
1150:
1151: DefLispVar ("obarray", &Vobarray,
1152: "Symbol table for use by intern and read.\n\
1153: It is a vector whose length ought to be prime for best results.\n\
1154: Each element is a list of all interned symbols whose names hash in that bucket.");
1155:
1156: DefLispVar ("values", &Vvalues,
1157: "List of values of all expressions which were read, evaluated and printed.\n\
1158: Order is reverse chronological.");
1159:
1160: DefLispVar ("standard-input", &Vstandard_input,
1161: "Stream for read to get input from.\n\
1162: See documentation of read for possible values.");
1163: Vstandard_input = Qt;
1164:
1165: DefLispVar ("load-path", &Vload_path,
1166: "*List of directories to search for files to load.\n\
1167: Each element is a string (directory name) or nil (try default directory).\n\
1168: Initialized based on EMACSLOADPATH environment variable, if any,\n\
1169: otherwise to default specified in by file paths.h when emacs was built.");
1170:
1171: DefBoolVar ("load-in-progress", &load_in_progress,
1172: "Non-nil iff inside of load.");
1173:
1174: Qstandard_input = intern ("standard-input");
1175: staticpro (&Qstandard_input);
1176:
1177: Qread_char = intern ("read-char");
1178: staticpro (&Qread_char);
1179:
1180: Qget_file_char = intern ("get-file-char");
1181: staticpro (&Qget_file_char);
1182:
1183: unrch = -1;
1184: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.