[nucl] add barebones reader

src/c/nucl.c

@@ -98,33 +98,35 @@ nucl_alloc_base_string(cl_index s)
 }
 
 cl_object
-nucl_write(const char *s, cl_object strm)
+nucl_stack_to_base_string(cl_object stack)
+{
+  cl_index size = stack->vector.fillp, idx;
+  cl_object self = nucl_alloc_base_string(size);
+  for(idx=0; idx<size; idx++)
+    self->base_string.self[idx] = ECL_CHAR_CODE(stack->vector.self.t[idx]);
+  return self;
+}
+
+cl_object
+nucl_stack_to_list(cl_object stack)
+{
+  cl_index size = stack->vector.fillp, idx;
+  cl_object self = ECL_NIL;
+  loop_across_stack_filo(elt, stack) {
+    self = ecl_cons(elt, self);
+  } end_loop_across_stack();
+  return self;
+}
+
+cl_object
+nucl_write_cstr(cl_object strm, const char *s)
 {
   while(*s != '\0')
     si_write_char(strm, ECL_CODE_CHAR(*s++));
 }
 
 cl_object
-nucl_print(cl_object self, cl_object strm)
+nucl_read_line(cl_object strm)
-{
-  cl_type t = ecl_t_of(self);
-  switch (t) {
-  case t_base_string:
-    nucl_write(self->base_string.self, strm);
-    break;
-  default:
-    {
-      const char *name = ecl_type_info[t].name;
-      nucl_write("#<", strm);
-      nucl_write(name, strm);
-      nucl_write(">", strm);
-      return ECL_NIL;
-    }
-  }
-}
-
-cl_object
-nucl_readl(cl_object self, cl_object strm)
 {
   cl_object stack = ecl_make_stack(0), c=ECL_NIL;
   cl_index idx, size;
@@ -132,16 +134,194 @@ nucl_readl(cl_object self, cl_object strm)
     ecl_stack_push(stack, c);
     if(ECL_CHAR_CODE(c) == '\n') break;
   }
-  size = stack->vector.fillp;
+  return nucl_stack_to_base_string(stack);
-  if(Null(self)) {
-    self = nucl_alloc_base_string(size);
-  } else {
-    self->base_string.self[size] = '\0';
-  }
-  for(idx=0; idx<size; idx++)
-    self->base_string.self[idx] = ECL_CHAR_CODE(stack->vector.self.t[idx]);
-  return self;
 }
+
+/* Ad-hoc printer */
+cl_object
+nucl_display(cl_object strm, cl_object self)
+{
+  cl_type t = ecl_t_of(self);
+  switch (t) {
+  case t_character:
+    si_write_char(strm, self);
+    break;
+  case t_base_string:
+    nucl_write_cstr(strm, self->base_string.self);
+    break;
+  case t_vector:
+    nucl_write_cstr(strm, "[");
+    loop_across_stack_fifo(elt, self) {
+      nucl_display(strm, elt);
+    } end_loop_across_stack();
+    nucl_write_cstr(strm, "]");
+    break;
+  default:
+    {
+      const char *name = ecl_type_info[t].name;
+      nucl_write_cstr(strm, "#<");
+      nucl_write_cstr(strm, name);
+      nucl_write_cstr(strm, ">");
+      return ECL_NIL;
+    }
+  }
+}
+
+/* Ad-hoc reader */
+static cl_object rtable = ECL_NIL;
+static cl_object nucl_accept(cl_object strm, cl_object delim);
+
+void
+nucl_readtable_set(cl_object self, cl_fixnum c, enum ecl_chattrib cat,
+                   cl_object macro)
+{
+  if (c >= RTABSIZE) {
+    ecl_internal_error("Character is too big!");
+  }
+  self->readtable.table[c].dispatch = macro;
+  self->readtable.table[c].syntax_type = cat;
+}
+
+struct ecl_readtable_entry *
+nucl_readtable_get(cl_object self, cl_fixnum ch)
+{
+  if (ch >= RTABSIZE) {
+    ecl_internal_error("Character is too big!");
+  }
+  return self->readtable.table+ch;
+}
+
+static cl_object
+default_reader(int narg, cl_object strm, cl_object ch)
+{
+  /* This reader reads either a token (symbol) or a number (fixnum). */
+  struct ecl_readtable_entry *entry = NULL;
+  cl_object stack = ecl_make_stack(0);
+  ecl_stack_push(stack, ch);
+  while (!Null(ch = si_read_char(strm, ECL_NIL))) {
+    entry = nucl_readtable_get(rtable, ECL_CHAR_CODE(ch));
+    switch (entry->syntax_type) {
+    case cat_constituent:
+      ecl_stack_push(stack, ch);
+      break;
+    case cat_terminating:
+      si_unread_char(strm, ch);
+      return stack;
+    case cat_whitespace:
+      return stack;
+    default:
+      ecl_internal_error("Expecting too much, aren't we?");
+    }
+  }
+  return stack;
+}
+
+static cl_object
+comment_reader(int narg, cl_object strm, cl_object c)
+{
+  ecl_internal_error("comment reader");
+}
+
+static cl_object
+lparen_reader(int narg, cl_object strm, cl_object c)
+{
+  cl_object stack = nucl_accept(strm, ECL_CODE_CHAR(')'));
+  return nucl_stack_to_list(stack);
+}
+
+static cl_object
+rparen_reader(int narg, cl_object strm, cl_object c)
+{
+  ecl_internal_error("rparen reader");
+}
+
+static cl_object
+symbol_reader(int narg, cl_object strm, cl_object c)
+{
+  ecl_internal_error("symbol reader");
+}
+
+static cl_object
+string_reader(int narg, cl_object strm, cl_object ch)
+{
+  ecl_internal_error("string reader");
+}
+
+static cl_object
+fixnum_reader(int narg, cl_object strm, cl_object c)
+{
+  ecl_internal_error("fixnum reader");
+}
+
+/* ecl_def_function(_default_reader, default_reader, static, const); */
+ecl_def_function(_comment_reader, comment_reader, static, const);
+ecl_def_function(_lparen_reader, lparen_reader, static, const);
+ecl_def_function(_rparen_reader, rparen_reader, static, const);
+ecl_def_function(_symbol_reader, symbol_reader, static, const);
+ecl_def_function(_string_reader, string_reader, static, const);
+ecl_def_function(_fixnum_reader, fixnum_reader, static, const);
+
+void
+init_nucl_reader(void)
+{
+  rtable = ecl_alloc_object(t_readtable);
+  struct ecl_readtable_entry *rtab = (struct ecl_readtable_entry *)
+    ecl_alloc(RTABSIZE * sizeof(struct ecl_readtable_entry));
+  rtable->readtable.locked = 0;
+  rtable->readtable.read_case = ecl_case_preserve; /* enum ecl_readtable_case */
+  rtable->readtable.table = rtab;
+  for (int i = 0;  i < RTABSIZE;  i++) {
+    rtab[i].syntax_type = cat_constituent; /* enum ecl_chattrib */
+    rtab[i].dispatch = ECL_NIL;
+  }
+#ifdef ECL_UNICODE
+  rtable->readtable.hash = ECL_NIL;
+#endif
+
+  nucl_readtable_set(rtable, '\t', cat_whitespace, ECL_NIL);
+  nucl_readtable_set(rtable, '\n', cat_whitespace, ECL_NIL);
+  nucl_readtable_set(rtable, '\f', cat_whitespace, ECL_NIL);
+  nucl_readtable_set(rtable, '\r', cat_whitespace, ECL_NIL);
+  nucl_readtable_set(rtable, ' ', cat_whitespace,  ECL_NIL);
+
+  nucl_readtable_set(rtable, '"', cat_terminating, _string_reader);
+  nucl_readtable_set(rtable, '(', cat_terminating, _lparen_reader);
+  nucl_readtable_set(rtable, ')', cat_terminating, _rparen_reader);
+  nucl_readtable_set(rtable, ';', cat_terminating, _comment_reader);
+}
+
+static cl_object
+nucl_accept(cl_object strm, cl_object delim)
+{
+  struct ecl_readtable_entry *entry = NULL;
+  cl_object stack = ecl_make_stack(0);
+  cl_object ch = ECL_NIL;
+  cl_object result = ECL_NIL;
+  while (!Null(ch = si_read_char(strm, ECL_NIL))) {
+    if (ecl_eql(delim, ch)) {
+      return stack;
+    }
+    entry = nucl_readtable_get(rtable, ECL_CHAR_CODE(ch));
+    switch (entry->syntax_type) {
+    case cat_constituent:
+      result = default_reader(2, strm, ch);
+      break;
+    case cat_terminating:
+      result = _ecl_funcall3(entry->dispatch, strm, ch);
+      break;
+    case cat_whitespace:
+      result = OBJNULL;
+      break;
+    default:
+      ecl_internal_error("Expecting too much, aren't we?");
+    }
+    if (result!=OBJNULL) {
+      ecl_stack_push(stack, result);
+    }
+  }
+  return stack;
+}
+
 /* -- Lali-ho I/O ends here ------------------------------------------------- */
 
 void
@@ -153,12 +333,25 @@ smoke_stream (void)
   char *string = "Hello World> ", c;
   int i;
   printf(">>> smoke_stream: stream is %p\n", ostrm);
-  nucl_write(string, ostrm);
+  nucl_write_cstr(ostrm, string);
-  line = nucl_readl(ECL_NIL, istrm);
+  line = nucl_read_line(istrm);
-  nucl_print(line, ostrm);
+  nucl_display(ostrm, line);
   ecl_dealloc(line);
 }
 
+void
+smoke_accept (void)
+{
+  cl_object ostrm = ecl_make_nucl_stream(stdout);
+  cl_object istrm = ecl_make_nucl_stream(stdin);
+  cl_object result = ECL_NIL;
+  init_nucl_reader();
+  printf(">>> smoke_accept: readtable is %p\n", rtable);
+  nucl_write_cstr(ostrm, "token> ");
+  result = nucl_accept(istrm, ECL_NIL);
+  nucl_display(ostrm, result);
+}
+
 int main() {
   cl_env_ptr the_env = ecl_core.first_env;
   ecl_boot();
@@ -193,6 +386,9 @@ int main() {
   smoke_stream();
   printf("-----------------------------------------------\n\n");
 
+  printf("\n[:accept t] --------------------------------\n");
+  smoke_accept();
+  printf("-----------------------------------------------\n\n");
 
   printf("Good bye ECL! %p\n", the_env);