From 70f6b59856bd21f8e6aee901a3f668f3b2f0eda6 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Mon, 13 Jan 2014 01:34:26 +0900
Subject: [PATCH] add peek-char

---
 src/port.c | 36 ++++++++++++++++++++++++++++++------
 1 file changed, 30 insertions(+), 6 deletions(-)

diff --git a/src/port.c b/src/port.c
index ce909c89..1fb2787f 100644
--- a/src/port.c
+++ b/src/port.c
@@ -352,6 +352,15 @@ pic_port_close_port(pic_state *pic)
   return pic_none_value();
 }
 
+#define assert_port_profile(port, flgs, stat, caller) do { \
+    if ((port->flags & flgs) != flgs) {                    \
+      pic_error(pic, caller ": expected input port");      \
+    }                                                      \
+    if (port->status != stat) {                            \
+      pic_error(pic, caller ": expected open port");       \
+    }                                                      \
+  } while (0)
+
 static pic_value
 pic_port_read_char(pic_state *pic)
 {
@@ -360,12 +369,7 @@ pic_port_read_char(pic_state *pic)
 
   pic_get_args(pic, "|p", &port);
 
-  if ((port->flags & PIC_PORT_IN) == 0) {
-    pic_error(pic, "read-char: expected input-port");
-  }
-  if (port->status != PIC_PORT_OPEN) {
-    pic_error(pic, "read-char: expected open port");
-  }
+  assert_port_profile(port, PIC_PORT_IN, PIC_PORT_OPEN, "read-char");
 
   if ((c = fgetc(port->file)) == EOF) {
     return pic_eof_object();
@@ -375,6 +379,25 @@ pic_port_read_char(pic_state *pic)
   }
 }
 
+static pic_value
+pic_port_peek_char(pic_state *pic)
+{
+  char c;
+  struct pic_port *port = pic_stdin(pic);
+
+  pic_get_args(pic, "|p", &port);
+
+  assert_port_profile(port, PIC_PORT_IN, PIC_PORT_OPEN, "peek-char");
+
+  if ((c = fgetc(port->file)) == EOF) {
+    return pic_eof_object();
+  }
+  else {
+    ungetc(c, port->file);
+    return pic_char_value(c);
+  }
+}
+
 void
 pic_init_port(pic_state *pic)
 {
@@ -397,6 +420,7 @@ pic_init_port(pic_state *pic)
 
   /* input */
   pic_defun(pic, "read-char", pic_port_read_char);
+  pic_defun(pic, "peek-char", pic_port_peek_char);
 
   /* write */
   pic_defun(pic, "newline", pic_port_newline);