File contents

--- 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 (&current_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 (",");