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