--- emacs-22.1.orig/src/lread.c 2007-05-14 23:56:31.000000000 +0900 +++ emacs-22.1/src/lread.c 2008-02-16 19:36:26.000000000 +0900 @@ -83,6 +83,8 @@ #endif Lisp_Object Qread_char, Qget_file_char, Qstandard_input, Qcurrent_load_list; +Lisp_Object Qget_macro_character, Qset_macro_character, Qreadtable; +Lisp_Object Qcl_read_char, Qunread_char, Qpeek_char, Qread_delimited_list; Lisp_Object Qvariable_documentation, Vvalues, Vstandard_input, Vafter_load_alist; Lisp_Object Qascii_character, Qload, Qload_file_name; Lisp_Object Qbackquote, Qcomma, Qcomma_at, Qcomma_dot, Qfunction; @@ -127,6 +129,9 @@ It must be set to nil before all top-level calls to read0. */ Lisp_Object read_objects; +/* TODO */ +Lisp_Object current_readtable; + /* Nonzero means load should forcibly load all dynamic doc strings. */ static int load_force_doc_strings; @@ -434,6 +439,7 @@ static Lisp_Object read1 P_ ((Lisp_Object, int *, int)); static Lisp_Object read_list P_ ((int, Lisp_Object)); +static Lisp_Object read_list0 P_ ((int, Lisp_Object, int)); static Lisp_Object read_vector P_ ((Lisp_Object, int)); static int read_multibyte P_ ((int, Lisp_Object)); @@ -639,6 +645,113 @@ UNBLOCK_INPUT; return val; } + +DEFUN ("get-macro-character", Fget_macro_character, Sget_macro_character, 1, 2, 0, + doc: /* Common Lisp get-macro-character. +TODO */) + (character, readtable) + Lisp_Object character, readtable; +{ + if (NILP (readtable)) + readtable = current_readtable; + + return Faref (readtable, character); +} + +DEFUN ("set-macro-character", Fset_macro_character, Sset_macro_character, 2, 4, 0, + doc: /* Common Lisp set-macro-character. +TODO */) + (character, function, non_terminating_p, readtable) + Lisp_Object character, function, non_terminating_p, readtable; +{ + if (NILP (readtable)) + readtable = current_readtable; + + Faset (readtable, character, Fcons (function, non_terminating_p)); + + return Qt; +} + +DEFUN ("cl-read-char", Fcl_read_char, Scl_read_char, 0, 4, 0, + doc: /* Common Lisp read-char. +TODO */) + (stream, eof_error_p, eof_value, recursive_p) + Lisp_Object stream, eof_error_p, eof_value, recursive_p; +{ + char c; + + /* TODO recursive_p */ + + if (NILP (stream)) + stream = Vstandard_input; + + c = readchar (stream); + if (c == EOF) + { + if (!NILP (eof_error_p)) + end_of_file_error(); + else + return eof_value; + } + else + return make_number (c); +} + +DEFUN ("unread-char", Funread_char, Sunread_char, 1, 2, 0, + doc: /* Common Lisp unread-char. +TODO */) + (character, stream) + Lisp_Object character, stream; +{ + /* TODO */ + + if (NILP (stream)) + stream = Vstandard_input; + + unreadchar (stream, XINT (character)); +} + +DEFUN ("peek-char", Fpeek_char, Speek_char, 0, 4, 0, + doc: /* Common Lisp peek-char. +TODO */) + (stream, eof_error_p, eof_value, recursive_p) + Lisp_Object stream, eof_error_p, eof_value, recursive_p; +{ + char c; + + /* TODO recursive_p */ + + if (NILP (stream)) + stream = Vstandard_input; + + c = readchar (stream); + if (c == EOF) + { + if (!NILP (eof_error_p)) + end_of_file_error(); + else + return eof_value; + } + else + { + unreadchar (stream, c); + return make_number (c); + } +} + +DEFUN ("read-delimited-list", Fread_delimited_list, Sread_delimited_list, 1, 3, 0, + doc: /* Common Lisp read-delimited-list. +TODO */) + (character, stream, recursive_p) + Lisp_Object character, stream, recursive_p; +{ + /* TODO recursive_p */ + + if (NILP (stream)) + stream = Vstandard_input; + + return read_list0 (0, stream, XINT (character)); +} @@ -2161,6 +2274,20 @@ if (c < 0) end_of_file_error (); + { + /* TODO error */ + Lisp_Object character = make_number (c); + Lisp_Object cons = Faref (current_readtable, character); + if (CONSP (cons)) + { + Lisp_Object result = call2 (XCAR (cons), readcharfun, character); + if (NILP (result)) + return read1 (readcharfun, pch, first_in_list); + else if (CONSP (result)) + return XCAR (result); + } + } + switch (c) { case '(': @@ -2692,7 +2819,7 @@ try to UNREAD two characters in a row. */ } default: - default_label: + default_label: if (c <= 040) goto retry; { char *p = read_buffer; @@ -2707,6 +2834,10 @@ && !(!first_in_list && c == '`') && !(new_backquote_flag && c == ',')))) { + Lisp_Object cons = Faref (current_readtable, make_number (c)); + if (CONSP (cons) && NILP (XCDR (cons))) + break; + if (end - p < MAX_MULTIBYTE_LENGTH) { int offset = p - read_buffer; @@ -3113,6 +3244,15 @@ int flag; register Lisp_Object readcharfun; { + return read_list0 (flag, readcharfun, ')'); +} + +static Lisp_Object +read_list0 (flag, readcharfun, end) + int flag; + register Lisp_Object readcharfun; + int end; +{ /* -1 means check next element for defun, 0 means don't check, 1 means already checked and found defun. */ @@ -3173,7 +3313,7 @@ return val; invalid_syntax (") or . in a vector", 18); } - if (ch == ')') + if (ch == end) return val; if (ch == '.') { @@ -3184,7 +3324,7 @@ val = read0 (readcharfun); read1 (readcharfun, &ch, 0); UNGCPRO; - if (ch == ')') + if (ch == end) { if (doc_reference == 1) return make_number (0); @@ -3997,6 +4137,12 @@ defsubr (&Sread_char_exclusive); defsubr (&Sread_event); defsubr (&Sget_file_char); + defsubr (&Sget_macro_character); + defsubr (&Sset_macro_character); + defsubr (&Scl_read_char); + defsubr (&Sunread_char); + defsubr (&Speek_char); + defsubr (&Sread_delimited_list); defsubr (&Smapatoms); defsubr (&Slocate_file_internal); @@ -4205,6 +4351,31 @@ Qget_file_char = intern ("get-file-char"); staticpro (&Qget_file_char); + Qget_macro_character = intern ("get-macro-character"); + staticpro (&Qget_macro_character); + + Qset_macro_character = intern ("set-macro-character"); + staticpro (&Qset_macro_character); + + Qreadtable = intern ("readtable"); + staticpro (&Qreadtable); + Qchar_table_extra_slots = intern ("char-table-extra-slots"); + Fput (Qreadtable, Qchar_table_extra_slots, make_number (0)); + current_readtable = Fmake_char_table (Qreadtable, Qnil); + staticpro (¤t_readtable); + + Qcl_read_char = intern ("cl-read-char"); + staticpro (&Qcl_read_char); + + Qunread_char = intern ("unread-char"); + staticpro (&Qunread_char); + + Qcl_read_char = intern ("peek-char"); + staticpro (&Qpeek_char); + + Qread_delimited_list = intern ("read-delimited-list"); + staticpro (&Qread_delimited_list); + Qbackquote = intern ("`"); staticpro (&Qbackquote); Qcomma = intern (",");