![[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] / 43BSDReno / contrib / emacs-18.55 / src|
Return to lread.c CVS log | Up to [CSRG BSD Unix] / 43BSDReno / contrib / emacs-18.55 / src |
1.1 root 1: /* Lisp parsing and input streams.
2: Copyright (C) 1985, 1986, 1987 Free Software Foundation, Inc.
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: /* non-zero if inside `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: {
118: register int c;
119: /* This used to be return of a conditional expression,
120: but that truncated -1 to a char on VMS. */
121: if (read_from_string_index < read_from_string_limit)
122: c = XSTRING (readcharfun)->data[read_from_string_index++];
123: else
124: c = -1;
125: return c;
126: }
127:
128: tem = call0 (readcharfun);
129:
130: if (NULL (tem))
131: return -1;
132: return XINT (tem);
133: }
134:
135: #define READCHAR readchar(readcharfun)
136: #define UNREAD(c) (unrch = c)
137:
138: static Lisp_Object read0 (), read1 (), read_list (), read_vector ();
139:
140: /* get a character from the tty */
141:
142: DEFUN ("read-char", Fread_char, Sread_char, 0, 0, 0,
143: "Read a character from the command input (keyboard or macro).\n\
144: It is returned as a number.")
145: ()
146: {
147: register Lisp_Object val;
148:
149: #ifndef standalone
150: XSET (val, Lisp_Int, get_char (0));
151: #else
152: XSET (val, Lisp_Int, getchar ());
153: #endif
154:
155: return val;
156: }
157:
158: DEFUN ("get-file-char", Fget_file_char, Sget_file_char, 0, 0, 0,
159: "Don't use this yourself.")
160: ()
161: {
162: register Lisp_Object val;
163: XSET (val, Lisp_Int, getc (instream));
164: return val;
165: }
166:
167: void readevalloop ();
168: static Lisp_Object load_unwind ();
169:
170: DEFUN ("load", Fload, Sload, 1, 4, 0,
171: "Execute a file of Lisp code named FILE.\n\
172: First tries FILE with .elc appended, then tries with .el,\n\
173: then tries FILE unmodified. Searches directories in load-path.\n\
174: If optional second arg MISSING-OK is non-nil,\n\
175: report no error if FILE doesn't exist.\n\
176: Print messages at start and end of loading unless\n\
177: optional third arg NOMESSAGE is non-nil.\n\
178: If optional fourth arg NOSUFFIX is non-nil, don't try adding\n\
179: suffixes .elc or .el to the specified name FILE.\n\
180: Return t if file exists.")
181: (str, missing_ok, nomessage, nosuffix)
182: Lisp_Object str, missing_ok, nomessage, nosuffix;
183: {
184: register FILE *stream;
185: register int fd = -1;
186: register Lisp_Object lispstream;
187: register FILE **ptr;
188: int count = specpdl_ptr - specpdl;
189: struct gcpro gcpro1;
190:
191: CHECK_STRING (str, 0);
192: str = Fsubstitute_in_file_name (str);
193:
194: /* Avoid weird lossage with null string as arg,
195: since it would try to load a directory as a Lisp file */
196: if (XSTRING (str)->size > 0)
197: {
198: fd = openp (Vload_path, str, !NULL (nosuffix) ? "" : ".elc:.el:", 0, 0);
199: }
200:
201: if (fd < 0)
202: if (NULL (missing_ok))
203: while (1)
204: Fsignal (Qfile_error, Fcons (build_string ("Cannot open load file"),
205: Fcons (str, Qnil)));
206: else return Qnil;
207:
208: stream = fdopen (fd, "r");
209: if (stream == 0)
210: {
211: close (fd);
212: error ("Failure to create stdio stream for %s", XSTRING (str)->data);
213: }
214:
215: if (NULL (nomessage))
216: message ("Loading %s...", XSTRING (str)->data);
217:
218: GCPRO1 (str);
219: ptr = (FILE **) xmalloc (sizeof (FILE *));
220: *ptr = stream;
221: XSET (lispstream, Lisp_Internal_Stream, (int) ptr);
222: record_unwind_protect (load_unwind, lispstream);
223: load_in_progress++;
224: readevalloop (Qget_file_char, stream, Feval, 0);
225: unbind_to (count);
226: UNGCPRO;
227:
228: if (!noninteractive && NULL (nomessage))
229: message ("Loading %s...done", XSTRING (str)->data);
230: return Qt;
231: }
232:
233: static Lisp_Object
234: load_unwind (stream) /* used as unwind-protect function in load */
235: Lisp_Object stream;
236: {
237: fclose (*(FILE **) XSTRING (stream));
238: if (--load_in_progress < 0) load_in_progress = 0;
239: return Qnil;
240: }
241:
242:
243: static int
244: absolute_filename_p (pathname)
245: Lisp_Object pathname;
246: {
247: register unsigned char *s = XSTRING (pathname)->data;
248: return (*s == '~' || *s == '/'
249: #ifdef VMS
250: || index (s, ':')
251: #endif /* VMS */
252: );
253: }
254:
255: /* Search for a file whose name is STR, looking in directories
256: in the Lisp list PATH, and trying suffixes from SUFFIX.
257: SUFFIX is a string containing possible suffixes separated by colons.
258: On success, returns a file descriptor. On failure, returns -1.
259:
260: EXEC_ONLY nonzero means don't open the files,
261: just look for one that is executable. In this case,
262: returns 1 on success.
263:
264: If STOREPTR is nonzero, it points to a slot where the name of
265: the file actually found should be stored as a Lisp string.
266: Nil is stored there on failure. */
267:
268: int
269: openp (path, str, suffix, storeptr, exec_only)
270: Lisp_Object path, str;
271: char *suffix;
272: Lisp_Object *storeptr;
273: int exec_only;
274: {
275: register int fd;
276: int fn_size = 100;
277: char buf[100];
278: register char *fn = buf;
279: int absolute = 0;
280: int want_size;
281: register Lisp_Object filename;
282: struct stat st;
283:
284: if (storeptr)
285: *storeptr = Qnil;
286:
287: if (absolute_filename_p (str))
288: absolute = 1;
289:
290: for (; !NULL (path); path = Fcdr (path))
291: {
292: char *nsuffix;
293:
294: filename = Fexpand_file_name (str, Fcar (path));
295: if (!absolute_filename_p (filename))
296: /* If there are non-absolute elts in PATH (eg ".") */
297: /* Of course, this could conceivably lose if luser sets
298: default-directory to be something non-absolute... */
299: {
300: filename = Fexpand_file_name (filename, bf_cur->directory);
301: if (!absolute_filename_p (filename))
302: /* Give up on this path element! */
303: continue;
304: }
305:
306: /* Calculate maximum size of any filename made from
307: this path element/specified file name and any possible suffix. */
308: want_size = strlen (suffix) + XSTRING (filename)->size + 1;
309: if (fn_size < want_size)
310: fn = (char *) alloca (fn_size = 100 + want_size);
311:
312: nsuffix = suffix;
313:
314: /* Loop over suffixes. */
315: while (1)
316: {
317: char *esuffix = (char *) index (nsuffix, ':');
318: int lsuffix = esuffix ? esuffix - nsuffix : strlen (nsuffix);
319:
320: /* Concatenate path element/specified name with the suffix. */
321: strncpy (fn, XSTRING (filename)->data, XSTRING (filename)->size);
322: fn[XSTRING (filename)->size] = 0;
323: if (lsuffix != 0) /* Bug happens on CCI if lsuffix is 0. */
324: strncat (fn, nsuffix, lsuffix);
325:
326: /* Ignore file if it's a directory. */
327: if (stat (fn, &st) >= 0
328: && (st.st_mode & S_IFMT) != S_IFDIR)
329: {
330: /* Check that we can access or open it. */
331: if (exec_only)
332: fd = !access (fn, X_OK);
333: else
334: fd = open (fn, 0, 0);
335:
336: if (fd >= 0)
337: {
338: /* We succeeded; return this descriptor and filename. */
339: if (storeptr)
340: *storeptr = build_string (fn);
341: return fd;
342: }
343: }
344:
345: /* Advance to next suffix. */
346: if (esuffix == 0)
347: break;
348: nsuffix += lsuffix + 1;
349: }
350: if (absolute) return -1;
351: }
352:
353: return -1;
354: }
355:
356:
357: Lisp_Object
358: unreadpure () /* Used as unwind-protect function in readevalloop */
359: {
360: read_pure = 0;
361: return Qnil;
362: }
363:
364: static void
365: readevalloop (readcharfun, stream, evalfun, printflag)
366: Lisp_Object readcharfun;
367: FILE *stream;
368: Lisp_Object (*evalfun) ();
369: int printflag;
370: {
371: register int c;
372: register Lisp_Object val;
373: register int xunrch;
374: int count = specpdl_ptr - specpdl;
375:
376: specbind (Qstandard_input, readcharfun);
377:
378: unrch = -1;
379:
380: while (1)
381: {
382: instream = stream;
383: c = READCHAR;
384: if (c == ';')
385: {
386: while ((c = READCHAR) != '\n' && c != -1);
387: continue;
388: }
389: if (c < 0) break;
390: if (c == ' ' || c == '\t' || c == '\n' || c == '\f') continue;
391:
392: if (!NULL (Vpurify_flag) && c == '(')
393: {
394: record_unwind_protect (unreadpure, Qnil);
395: val = read_list (-1, readcharfun);
396: unbind_to (count + 1);
397: }
398: else
399: {
400: UNREAD (c);
401: val = read0 (readcharfun);
402: }
403:
404: xunrch = unrch;
405: unrch = -1;
406: val = (*evalfun) (val);
407: if (printflag)
408: {
409: Vvalues = Fcons (val, Vvalues);
410: if (EQ (Vstandard_output, Qt))
411: Fprin1 (val, Qnil);
412: else
413: Fprint (val, Qnil);
414: }
415: unrch = xunrch;
416: }
417:
418: unbind_to (count);
419: }
420:
421: #ifndef standalone
422:
423: DEFUN ("eval-current-buffer", Feval_current_buffer, Seval_current_buffer, 0, 1, "",
424: "Execute the current buffer as Lisp code.\n\
425: Programs can pass argument PRINTFLAG which controls printing of output:\n\
426: nil means discard it; anything else is stream for print.")
427: (printflag)
428: Lisp_Object printflag;
429: {
430: int count = specpdl_ptr - specpdl;
431: Lisp_Object tem;
432: if (NULL (printflag))
433: tem = Qsymbolp;
434: else
435: tem = printflag;
436: specbind (Qstandard_output, tem);
437: record_unwind_protect (save_excursion_restore, save_excursion_save ());
438: SetPoint (FirstCharacter);
439: readevalloop (Fcurrent_buffer (), 0, Feval, !NULL (printflag));
440: unbind_to (count);
441: return Qnil;
442: }
443:
444: DEFUN ("eval-region", Feval_region, Seval_region, 2, 3, "r",
445: "Execute the region as Lisp code.\n\
446: When called from programs, expects two arguments,\n\
447: giving starting and ending indices in the current buffer\n\
448: of the text to be executed.\n\
449: Programs can pass third argument PRINTFLAG which controls printing of output:\n\
450: nil means discard it; anything else is stream for print.")
451: (b, e, printflag)
452: Lisp_Object b, e, printflag;
453: {
454: int count = specpdl_ptr - specpdl;
455: Lisp_Object tem;
456: if (NULL (printflag))
457: tem = Qsymbolp;
458: else
459: tem = printflag;
460: specbind (Qstandard_output, tem);
461: if (NULL (printflag))
462: record_unwind_protect (save_excursion_restore, save_excursion_save ());
463: record_unwind_protect (save_restriction_restore, save_restriction_save ());
464: SetPoint (XINT (b));
465: Fnarrow_to_region (make_number (FirstCharacter), e);
466: readevalloop (Fcurrent_buffer (), 0, Feval, !NULL (printflag));
467: unbind_to (count);
468: return Qnil;
469: }
470:
471: #endif standalone
472:
473: DEFUN ("read", Fread, Sread, 0, 1, 0,
474: "Read one Lisp expression as text from STREAM, return as Lisp object.\n\
475: If STREAM is nil, use the value of standard-input (which see).\n\
476: STREAM or standard-input may be:\n\
477: a buffer (read from point and advance it)\n\
478: a marker (read from where it points and advance it)\n\
479: a function (call it with no arguments for each character)\n\
480: a string (takes text from string, starting at the beginning)\n\
481: t (read text line using minibuffer and use it).")
482: (readcharfun)
483: Lisp_Object readcharfun;
484: {
485: extern Lisp_Object Fread_minibuffer ();
486:
487: unrch = -1; /* Allow buffering-back only within a read. */
488:
489: if (NULL (readcharfun))
490: readcharfun = Vstandard_input;
491: if (EQ (readcharfun, Qt))
492: readcharfun = Qread_char;
493:
494: #ifndef standalone
495: if (EQ (readcharfun, Qread_char))
496: return Fread_minibuffer (build_string ("Lisp expression: "), Qnil);
497: #endif
498:
499: if (XTYPE (readcharfun) == Lisp_String)
500: return Fcar (Fread_from_string (readcharfun, Qnil, Qnil));
501:
502: return read0 (readcharfun);
503: }
504:
505: DEFUN ("read-from-string", Fread_from_string, Sread_from_string, 1, 3, 0,
506: "Read one Lisp expression which is represented as text by STRING.\n\
507: Returns a cons: (OBJECT-READ . FINAL-STRING-INDEX).\n\
508: START and END optionally delimit a substring of STRING from which to read;\n\
509: they default to 0 and (length STRING) respectively.")
510: (string, start, end)
511: Lisp_Object string, start, end;
512: {
513: int startval, endval;
514: Lisp_Object tem;
515:
516: CHECK_STRING (string,0);
517:
518: if (NULL (end))
519: endval = XSTRING (string)->size;
520: else
521: { CHECK_NUMBER (end,2);
522: endval = XINT (end);
523: if (endval < 0 || endval > XSTRING (string)->size)
524: args_out_of_range (string, end);
525: }
526:
527: if (NULL (start))
528: startval = 0;
529: else
530: { CHECK_NUMBER (start,1);
531: startval = XINT (start);
532: if (startval < 0 || startval > endval)
533: args_out_of_range (string, start);
534: }
535:
536: read_from_string_index = startval;
537: read_from_string_limit = endval;
538:
539: unrch = -1; /* Allow buffering-back only within a read. */
540:
541: tem = read0 (string);
542: return Fcons (tem, make_number (read_from_string_index));
543: }
544:
545: /* Use this for recursive reads, in contexts where internal tokens are not allowed. */
546:
547: static Lisp_Object
548: read0 (readcharfun)
549: Lisp_Object readcharfun;
550: {
551: register Lisp_Object val;
552: char c;
553:
554: val = read1 (readcharfun);
555: if (XTYPE (val) == Lisp_Internal)
556: {
557: c = XINT (val);
558: return Fsignal (Qinvalid_read_syntax, Fcons (make_string (&c, 1), Qnil));
559: }
560:
561: return val;
562: }
563:
564: static int read_buffer_size;
565: static char *read_buffer;
566:
567: static Lisp_Object
568: read1 (readcharfun)
569: register Lisp_Object readcharfun;
570: {
571: register int c;
572:
573: retry:
574:
575: c = READCHAR;
576: if (c < 0) return Fsignal (Qend_of_file, Qnil);
577:
578: switch (c)
579: {
580: case '(':
581: return read_list (0, readcharfun);
582:
583: case '[':
584: return read_vector (readcharfun);
585:
586: case ')':
587: case ']':
588: case '.':
589: {
590: register Lisp_Object val;
591: XSET (val, Lisp_Internal, c);
592: return val;
593: }
594:
595: case '#':
596: return Fsignal (Qinvalid_read_syntax, Fcons (make_string ("#", 1), Qnil));
597:
598: case ';':
599: while ((c = READCHAR) >= 0 && c != '\n');
600: goto retry;
601:
602: case '\'':
603: {
604: return Fcons (Qquote, Fcons (read0 (readcharfun), Qnil));
605: }
606:
607: case '?':
608: {
609: register Lisp_Object val;
610:
611: XSET (val, Lisp_Int, READCHAR);
612: if (XFASTINT (val) == '\\')
613: XSETINT (val, read_escape (readcharfun));
614:
615: return val;
616: }
617:
618: case '\"':
619: {
620: register char *p = read_buffer;
621: register char *end = read_buffer + read_buffer_size;
622: register int c;
623: int cancel = 0;
624:
625: while ((c = READCHAR) >= 0 &&
626: (c != '\"' || (c = READCHAR) == '\"'))
627: {
628: if (p == end)
629: {
630: char *new = (char *) xrealloc (read_buffer, read_buffer_size *= 2);
631: p += new - read_buffer;
632: read_buffer += new - read_buffer;
633: end = read_buffer + read_buffer_size;
634: }
635: if (c == '\\')
636: c = read_escape (readcharfun);
637: /* c is -1 if \ newline has just been seen */
638: if (c < 0)
639: {
640: if (p == read_buffer)
641: cancel = 1;
642: }
643: else
644: *p++ = c;
645: }
646:
647: UNREAD (c);
648: /* If purifying, and string starts with \ newline,
649: return zero instead. This is for doc strings
650: that we are really going to find in etc/DOC.nn.nn */
651: if (!NULL (Vpurify_flag) && NULL (Vdoc_file_name) && cancel)
652: return make_number (0);
653:
654: if (read_pure)
655: return make_pure_string (read_buffer, p - read_buffer);
656: else
657: return make_string (read_buffer, p - read_buffer);
658: }
659:
660: default:
661: if (c <= 040) goto retry;
662: {
663: register char *p = read_buffer;
664:
665: {
666: register char *end = read_buffer + read_buffer_size;
667:
668: while (c > 040 &&
669: !(c == '\"' || c == '\'' || c == ';' || c == '?'
670: || c == '(' || c == ')' || c =='.'
671: || c == '[' || c == ']' || c == '#'
672: ))
673: {
674: if (p == end)
675: {
676: register char *new = (char *) xrealloc (read_buffer, read_buffer_size *= 2);
677: p += new - read_buffer;
678: read_buffer += new - read_buffer;
679: end = read_buffer + read_buffer_size;
680: }
681: if (c == '\\')
682: c = READCHAR;
683: *p++ = c;
684: c = READCHAR;
685: }
686:
687: if (p == end)
688: {
689: char *new = (char *) xrealloc (read_buffer, read_buffer_size *= 2);
690: p += new - read_buffer;
691: read_buffer += new - read_buffer;
692: /* end = read_buffer + read_buffer_size; */
693: }
694: *p = 0;
695: UNREAD (c);
696: }
697:
698: /* Is it an integer? */
699: {
700: register char *p1;
701: register Lisp_Object val;
702: p1 = read_buffer;
703: if (*p1 == '+' || *p1 == '-') p1++;
704: if (p1 != p)
705: {
706: while (p1 != p && (c = *p1) >= '0' && c <= '9') p1++;
707: if (p1 == p)
708: /* It is. */
709: {
710: XSET (val, Lisp_Int, atoi (read_buffer));
711: return val;
712: }
713: }
714: }
715:
716: return intern (read_buffer);
717: }
718: }
719: }
720:
721: static Lisp_Object
722: read_vector (readcharfun)
723: Lisp_Object readcharfun;
724: {
725: register int i;
726: register int size;
727: register Lisp_Object *ptr;
728: register Lisp_Object tem, vector;
729: register struct Lisp_Cons *otem;
730: Lisp_Object len;
731:
732: tem = read_list (1, readcharfun);
733: len = Flength (tem);
734: vector = (read_pure ? make_pure_vector (XINT (len)) : Fmake_vector (len, Qnil));
735:
736:
737: size = XVECTOR (vector)->size;
738: ptr = XVECTOR (vector)->contents;
739: for (i = 0; i < size; i++)
740: {
741: ptr[i] = read_pure ? Fpurecopy (Fcar (tem)) : Fcar (tem);
742: otem = XCONS (tem);
743: tem = Fcdr (tem);
744: free_cons (otem);
745: }
746: return vector;
747: }
748:
749: /* flag = 1 means check for ] to terminate rather than ) and .
750: flag = -1 means check for starting with defun
751: and make structure pure. */
752:
753: static Lisp_Object
754: read_list (flag, readcharfun)
755: int flag;
756: register Lisp_Object readcharfun;
757: {
758: /* -1 means check next element for defun,
759: 0 means don't check,
760: 1 means already checked and found defun. */
761: int defunflag = flag < 0 ? -1 : 0;
762: Lisp_Object val, tail;
763: register Lisp_Object elt, tem;
764: struct gcpro gcpro1, gcpro2;
765:
766: val = Qnil;
767: tail = Qnil;
768:
769: while (1)
770: {
771: GCPRO2 (val, tail);
772: elt = read1 (readcharfun);
773: UNGCPRO;
774: if (XTYPE (elt) == Lisp_Internal)
775: {
776: if (flag > 0)
777: {
778: if (XINT (elt) == ']')
779: return val;
780: return Fsignal (Qinvalid_read_syntax, Fcons (make_string (") or . in a vector", 18), Qnil));
781: }
782: if (XINT (elt) == ')')
783: return val;
784: if (XINT (elt) == '.')
785: {
786: GCPRO2 (val, tail);
787: if (!NULL (tail))
788: XCONS (tail)->cdr = read0 (readcharfun);
789: else
790: val = read0 (readcharfun);
791: elt = read1 (readcharfun);
792: UNGCPRO;
793: if (XTYPE (elt) == Lisp_Internal && XINT (elt) == ')')
794: return val;
795: return Fsignal (Qinvalid_read_syntax, Fcons (make_string (". in wrong context", 18), Qnil));
796: }
797: return Fsignal (Qinvalid_read_syntax, Fcons (make_string ("] in a list", 11), Qnil));
798: }
799: tem = (read_pure && flag <= 0
800: ? pure_cons (elt, Qnil)
801: : Fcons (elt, Qnil));
802: if (!NULL (tail))
803: XCONS (tail)->cdr = tem;
804: else
805: val = tem;
806: tail = tem;
807: if (defunflag < 0)
808: defunflag = EQ (elt, Qdefun);
809: else if (defunflag > 0)
810: read_pure = 1;
811: }
812: }
813:
814: static int
815: read_escape (readcharfun)
816: Lisp_Object readcharfun;
817: {
818: register int c = READCHAR;
819: switch (c)
820: {
821: case 'a':
822: return '\a';
823: case 'b':
824: return '\b';
825: case 'e':
826: return 033;
827: case 'f':
828: return '\f';
829: case 'n':
830: return '\n';
831: case 'r':
832: return '\r';
833: case 't':
834: return '\t';
835: case 'v':
836: return '\v';
837: case '\n':
838: return -1;
839:
840: case 'M':
841: c = READCHAR;
842: if (c != '-')
843: error ("Invalid escape character syntax");
844: c = READCHAR;
845: if (c == '\\')
846: c = read_escape (readcharfun);
847: return c | 0200;
848:
849: case 'C':
850: c = READCHAR;
851: if (c != '-')
852: error ("Invalid escape character syntax");
853: case '^':
854: c = READCHAR;
855: if (c == '\\')
856: c = read_escape (readcharfun);
857: if (c == '?')
858: return 0177;
859: return (c & 0200) | (c & 037);
860:
861: case '0':
862: case '1':
863: case '2':
864: case '3':
865: case '4':
866: case '5':
867: case '6':
868: case '7':
869: {
870: register int i = c - '0';
871: register int count = 0;
872: while (++count < 3)
873: {
874: if ((c = READCHAR) >= '0' && c <= '7')
875: {
876: i *= 8;
877: i += c - '0';
878: }
879: else
880: {
881: UNREAD (c);
882: break;
883: }
884: }
885: return i;
886: }
887: default:
888: return c;
889: }
890: }
891:
892: Lisp_Object Vobarray;
893: Lisp_Object initial_obarray;
894:
895: Lisp_Object
896: check_obarray (obarray)
897: Lisp_Object obarray;
898: {
899: while (XTYPE (obarray) != Lisp_Vector || XVECTOR (obarray)->size == 0)
900: {
901: /* If Vobarray is now invalid, force it to be valid. */
902: if (EQ (Vobarray, obarray)) Vobarray = initial_obarray;
903:
904: obarray = wrong_type_argument (Qvectorp, obarray);
905: }
906: return obarray;
907: }
908:
909: static int hash_string ();
910: Lisp_Object oblookup ();
911:
912: Lisp_Object
913: intern (str)
914: char *str;
915: {
916: Lisp_Object tem;
917: int len = strlen (str);
918: Lisp_Object obarray = Vobarray;
919: if (XTYPE (obarray) != Lisp_Vector || XVECTOR (obarray)->size == 0)
920: obarray = check_obarray (obarray);
921: tem = oblookup (obarray, str, len);
922: if (XTYPE (tem) == Lisp_Symbol)
923: return tem;
924: return Fintern ((!NULL (Vpurify_flag)
925: ? make_pure_string (str, len)
926: : make_string (str, len)),
927: obarray);
928: }
929:
930: DEFUN ("intern", Fintern, Sintern, 1, 2, 0,
931: "Return the symbol whose name is STRING.\n\
932: A second optional argument specifies the obarray to use;\n\
933: it defaults to the value of obarray.")
934: (str, obarray)
935: Lisp_Object str, obarray;
936: {
937: register Lisp_Object tem, sym, *ptr;
938:
939: if (NULL (obarray)) obarray = Vobarray;
940: obarray = check_obarray (obarray);
941:
942: CHECK_STRING (str, 0);
943:
944: tem = oblookup (obarray, XSTRING (str)->data, XSTRING (str)->size);
945: if (XTYPE (tem) != Lisp_Int)
946: return tem;
947:
948: if (!NULL (Vpurify_flag))
949: str = Fpurecopy (str);
950: sym = Fmake_symbol (str);
951:
952: ptr = &XVECTOR (obarray)->contents[XINT (tem)];
953: if (XTYPE (*ptr) == Lisp_Symbol)
954: XSYMBOL (sym)->next = XSYMBOL (*ptr);
955: else
956: XSYMBOL (sym)->next = 0;
957: *ptr = sym;
958: return sym;
959: }
960:
961: DEFUN ("intern-soft", Fintern_soft, Sintern_soft, 1, 2, 0,
962: "Return the symbol whose name is STRING, or nil if none exists yet.\n\
963: A second optional argument specifies the obarray to use;\n\
964: it defaults to the value of obarray.")
965: (str, obarray)
966: Lisp_Object str, obarray;
967: {
968: register Lisp_Object tem;
969:
970: if (NULL (obarray)) obarray = Vobarray;
971: obarray = check_obarray (obarray);
972:
973: CHECK_STRING (str, 0);
974:
975: tem = oblookup (obarray, XSTRING (str)->data, XSTRING (str)->size);
976: if (XTYPE (tem) != Lisp_Int)
977: return tem;
978: return Qnil;
979: }
980:
981: Lisp_Object
982: oblookup (obarray, ptr, size)
983: Lisp_Object obarray;
984: register char *ptr;
985: register int size;
986: {
987: int hash, obsize;
988: register Lisp_Object tail;
989: Lisp_Object bucket, tem;
990:
991: if (XTYPE (obarray) != Lisp_Vector ||
992: (obsize = XVECTOR (obarray)->size) == 0)
993: {
994: obarray = check_obarray (obarray);
995: obsize = XVECTOR (obarray)->size;
996: }
997: /* Combining next two lines breaks VMS C 2.3. */
998: hash = hash_string (ptr, size);
999: hash %= obsize;
1000: bucket = XVECTOR (obarray)->contents[hash];
1001: if (XFASTINT (bucket) == 0)
1002: ;
1003: else if (XTYPE (bucket) != Lisp_Symbol)
1004: error ("Bad data in guts of obarray"); /* Like CADR error message */
1005: else for (tail = bucket; ; XSET (tail, Lisp_Symbol, XSYMBOL (tail)->next))
1006: {
1007: if (XSYMBOL (tail)->name->size == size &&
1008: !bcmp (XSYMBOL (tail)->name->data, ptr, size))
1009: return tail;
1010: else if (XSYMBOL (tail)->next == 0)
1011: break;
1012: }
1013: XSET (tem, Lisp_Int, hash);
1014: return tem;
1015: }
1016:
1017: static int
1018: hash_string (ptr, len)
1019: unsigned char *ptr;
1020: int len;
1021: {
1022: register unsigned char *p = ptr;
1023: register unsigned char *end = p + len;
1024: register unsigned char c;
1025: register int hash = 0;
1026:
1027: while (p != end)
1028: {
1029: c = *p++;
1030: if (c >= 0140) c -= 40;
1031: hash = ((hash<<3) + (hash>>28) + c);
1032: }
1033: return hash & 07777777777;
1034: }
1035:
1036: void
1037: map_obarray (obarray, fn, arg)
1038: Lisp_Object obarray;
1039: int (*fn) ();
1040: Lisp_Object arg;
1041: {
1042: register int i;
1043: register Lisp_Object tail;
1044: CHECK_VECTOR (obarray, 1);
1045: for (i = XVECTOR (obarray)->size - 1; i >= 0; i--)
1046: {
1047: tail = XVECTOR (obarray)->contents[i];
1048: if (XFASTINT (tail) != 0)
1049: while (1)
1050: {
1051: (*fn) (tail, arg);
1052: if (XSYMBOL (tail)->next == 0)
1053: break;
1054: XSET (tail, Lisp_Symbol, XSYMBOL (tail)->next);
1055: }
1056: }
1057: }
1058:
1059: mapatoms_1 (sym, function)
1060: Lisp_Object sym, function;
1061: {
1062: call1 (function, sym);
1063: }
1064:
1065: DEFUN ("mapatoms", Fmapatoms, Smapatoms, 1, 2, 0,
1066: "Call FUNCTION on every symbol in OBARRAY.\n\
1067: OBARRAY defaults to the value of obarray.")
1068: (function, obarray)
1069: Lisp_Object function, obarray;
1070: {
1071: Lisp_Object tem;
1072:
1073: if (NULL (obarray)) obarray = Vobarray;
1074: obarray = check_obarray (obarray);
1075:
1076: map_obarray (obarray, mapatoms_1, function);
1077: return Qnil;
1078: }
1079:
1080: #define OBARRAY_SIZE 511
1081:
1082: void
1083: init_obarray ()
1084: {
1085: Lisp_Object oblength;
1086: int hash;
1087: Lisp_Object *tem;
1088:
1089: XFASTINT (oblength) = OBARRAY_SIZE;
1090:
1091: Qnil = Fmake_symbol (make_pure_string ("nil", 3));
1092: Vobarray = Fmake_vector (oblength, make_number (0));
1093: initial_obarray = Vobarray;
1094: staticpro (&Vobarray);
1095: staticpro (&initial_obarray);
1096: /* Intern nil in the obarray */
1097: /* These locals are to kludge around a pyramid compiler bug. */
1098: hash = hash_string ("nil", 3);
1099: /* Separate statement here to avoid VAXC bug. */
1100: hash %= OBARRAY_SIZE;
1101: tem = &XVECTOR (Vobarray)->contents[hash];
1102: *tem = Qnil;
1103:
1104: Qunbound = Fmake_symbol (make_pure_string ("unbound", 7));
1105: XSYMBOL (Qnil)->function = Qunbound;
1106: XSYMBOL (Qunbound)->value = Qunbound;
1107: XSYMBOL (Qunbound)->function = Qunbound;
1108:
1109: Qt = intern ("t");
1110: XSYMBOL (Qnil)->value = Qnil;
1111: XSYMBOL (Qnil)->plist = Qnil;
1112: XSYMBOL (Qt)->value = Qt;
1113:
1114: /* Qt is correct even if CANNOT_DUMP. loadup.el will set to nil at end. */
1115: Vpurify_flag = Qt;
1116:
1117: Qvariable_documentation = intern ("variable-documentation");
1118:
1119: read_buffer_size = 100;
1120: read_buffer = (char *) malloc (read_buffer_size);
1121: }
1122:
1123: void
1124: defsubr (sname)
1125: struct Lisp_Subr *sname;
1126: {
1127: Lisp_Object sym;
1128: sym = intern (sname->symbol_name);
1129: XSET (XSYMBOL (sym)->function, Lisp_Subr, sname);
1130: }
1131:
1132: #ifdef NOTDEF /* use fset in subr.el now */
1133: void
1134: defalias (sname, string)
1135: struct Lisp_Subr *sname;
1136: char *string;
1137: {
1138: Lisp_Object sym;
1139: sym = intern (string);
1140: XSET (XSYMBOL (sym)->function, Lisp_Subr, sname);
1141: }
1142: #endif NOTDEF
1143:
1144: /* New replacement for DefIntVar; it ignores the doc string argument
1145: on the assumption that make-docfile will handle that. */
1146: /* Define an "integer variable"; a symbol whose value is forwarded
1147: to a C variable of type int. Sample call: */
1148: /* DEFVARINT ("indent-tabs-mode", &indent_tabs_mode, "Documentation"); */
1149:
1150: void
1151: defvar_int (namestring, address, doc)
1152: char *namestring;
1153: int *address;
1154: char *doc;
1155: {
1156: Lisp_Object sym;
1157: sym = intern (namestring);
1158: XSET (XSYMBOL (sym)->value, Lisp_Intfwd, address);
1159: }
1160:
1161: /* Similar but define a variable whose value is T if address contains 1,
1162: NIL if address contains 0 */
1163:
1164: void
1165: defvar_bool (namestring, address, doc)
1166: char *namestring;
1167: int *address;
1168: char *doc;
1169: {
1170: Lisp_Object sym;
1171: sym = intern (namestring);
1172: XSET (XSYMBOL (sym)->value, Lisp_Boolfwd, address);
1173: }
1174:
1175: /* Similar but define a variable whose value is the Lisp Object stored at address. */
1176:
1177: void
1178: defvar_lisp (namestring, address, doc)
1179: char *namestring;
1180: Lisp_Object *address;
1181: char *doc;
1182: {
1183: Lisp_Object sym;
1184: sym = intern (namestring);
1185: XSET (XSYMBOL (sym)->value, Lisp_Objfwd, address);
1186: staticpro (address);
1187: }
1188:
1189: /* Similar but don't request gc-marking of the C variable.
1190: Used when that variable will be gc-marked for some other reason,
1191: since marking the same slot twice can cause trouble with strings. */
1192:
1193: void
1194: defvar_lisp_nopro (namestring, address, doc)
1195: char *namestring;
1196: Lisp_Object *address;
1197: char *doc;
1198: {
1199: Lisp_Object sym;
1200: sym = intern (namestring);
1201: XSET (XSYMBOL (sym)->value, Lisp_Objfwd, address);
1202: }
1203:
1204: #ifndef standalone
1205:
1206: /* Similar but define a variable whose value is the Lisp Object stored in
1207: the current buffer. address is the address of the slot in the buffer that is current now. */
1208:
1209: void
1210: defvar_per_buffer (namestring, address, doc)
1211: char *namestring;
1212: Lisp_Object *address;
1213: char *doc;
1214: {
1215: Lisp_Object sym;
1216: int offset;
1217: extern struct buffer buffer_local_symbols;
1218:
1219: sym = intern (namestring);
1220: offset = (char *)address - (char *)bf_cur;
1221:
1222: XSET (XSYMBOL (sym)->value, Lisp_Buffer_Objfwd,
1223: (Lisp_Object *) offset);
1224: *(Lisp_Object *)(offset + (char *)&buffer_local_symbols) = sym;
1225: if (*(int *)(offset + (char *)&buffer_local_flags) == 0)
1226: /* Did a DEFVAR_PER_BUFFER without initializing the corresponding
1227: slot of buffer_local_flags */
1228: abort ();
1229: }
1230:
1231: #endif standalone
1232:
1233: init_read ()
1234: {
1235: char *normal = PATH_LOADSEARCH;
1236: Lisp_Object normal_path;
1237:
1238: /* Warn if dirs in the *standard* path don't exist. */
1239: normal_path = decode_env_path ("", normal);
1240: for (; !NULL (normal_path); normal_path = XCONS (normal_path)->cdr)
1241: {
1242: Lisp_Object dirfile;
1243: dirfile = Fcar (normal_path);
1244: if (!NULL (dirfile))
1245: {
1246: dirfile = Fdirectory_file_name (dirfile);
1247: if (access (XSTRING (dirfile)->data, 0) < 0)
1248: printf ("Warning: lisp library (%s) does not exist.\n",
1249: XSTRING (Fcar (normal_path))->data);
1250: }
1251: }
1252:
1253: Vvalues = Qnil;
1254:
1255: Vload_path = decode_env_path ("EMACSLOADPATH", normal);
1256: #ifndef CANNOT_DUMP
1257: if (!NULL (Vpurify_flag))
1258: Vload_path = Fcons (build_string ("../lisp"), Vload_path);
1259: #endif /* not CANNOT_DUMP */
1260: load_in_progress = 0;
1261: }
1262:
1263: void
1264: syms_of_read ()
1265: {
1266: defsubr (&Sread);
1267: defsubr (&Sread_from_string);
1268: defsubr (&Sintern);
1269: defsubr (&Sintern_soft);
1270: defsubr (&Sload);
1271: defsubr (&Seval_current_buffer);
1272: defsubr (&Seval_region);
1273: defsubr (&Sread_char);
1274: defsubr (&Sget_file_char);
1275: defsubr (&Smapatoms);
1276:
1277: DEFVAR_LISP ("obarray", &Vobarray,
1278: "Symbol table for use by intern and read.\n\
1279: It is a vector whose length ought to be prime for best results.\n\
1280: Each element is a list of all interned symbols whose names hash in that bucket.");
1281:
1282: DEFVAR_LISP ("values", &Vvalues,
1283: "List of values of all expressions which were read, evaluated and printed.\n\
1284: Order is reverse chronological.");
1285:
1286: DEFVAR_LISP ("standard-input", &Vstandard_input,
1287: "Stream for read to get input from.\n\
1288: See documentation of read for possible values.");
1289: Vstandard_input = Qt;
1290:
1291: DEFVAR_LISP ("load-path", &Vload_path,
1292: "*List of directories to search for files to load.\n\
1293: Each element is a string (directory name) or nil (try default directory).\n\
1294: Initialized based on EMACSLOADPATH environment variable, if any,\n\
1295: otherwise to default specified in by file paths.h when emacs was built.");
1296:
1297: DEFVAR_BOOL ("load-in-progress", &load_in_progress,
1298: "Non-nil iff inside of load.");
1299:
1300: Qstandard_input = intern ("standard-input");
1301: staticpro (&Qstandard_input);
1302:
1303: Qread_char = intern ("read-char");
1304: staticpro (&Qread_char);
1305:
1306: Qget_file_char = intern ("get-file-char");
1307: staticpro (&Qget_file_char);
1308:
1309: unrch = -1;
1310: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.