Adding notation for cycles and shared structure.

This commit implements the parse-side support for handling a notation that exists in ANSI Common Lisp for specifying objects with cycles and shared substructure. * parser.h (struct parser): New members, circ_ref_hash and circ_count. (circref_s, parser_resolve_circ, parser_circ_def, parser_circ_ref): Declared. * parser.c (circref_s): New symbol variable. (parser_mark): Visit the new circ_ref_hash member of the parser structure. (parser_common_init): Initialize new members circ_ref_hash and circ_count of parser structure. (patch_ref, circ_backpatch): New static functions. (parser_resolve_circ, parser_circ_def, parser_circ_ref): New functions. (circref): New static function. (parse_init): Initialize circref_s as sys:circref symbol. Register sys:circref function. * parser.l (grammar): Scan #<num>= and #<num># notation as tokens, extracting their numeric value. * parser.y (HASH_N_EQUALS, HASH_N_HASH): New token types. (i_expr, n_expr): Adding phrases for hash-equalsign and hash-hash syntax. (yybadtoken): Handle new token types in switch. (parse_once): Call parser_resolve_circ after parsing to rewrite any remaining #<num># references in the structure to the objects they denote. (parse): Reset new struct parse members to initial state. Call parser_resolve_circ after parsing to rewrite any remaining #<num># references.
author: Kaz Kylheku <kaz@kylheku.com> 2016-10-18 05:42:58 -0700
committer: Kaz Kylheku <kaz@kylheku.com> 2016-10-18 05:42:58 -0700
commit: 37636d9b1ceae173635d18043e21f446dfbd2490 (patch)
tree: 87bb18340363df6aa405aa7e8dea45b3229239ec
parent: f91ef728d1149d7a849d7c818b3fdc03c61847ad (diff)
download: txr-37636d9b1ceae173635d18043e21f446dfbd2490.tar.gz
txr-37636d9b1ceae173635d18043e21f446dfbd2490.tar.bz2
txr-37636d9b1ceae173635d18043e21f446dfbd2490.zip
4 files changed, 213 insertions, 5 deletions
diff --git a/parser.c b/parser.c
index 5f458f1e..bb023343 100644
--- a/parser.c
+++ b/parser.c
@@ -51,12 +51,14 @@
 #include "stream.h"
 #include "y.tab.h"
 #include "sysif.h"
+#include "cadr.h"
+#include "struct.h"
 #include "parser.h"
 #if HAVE_TERMIOS
 #include "linenoise/linenoise.h"
 #endif
 
-val parser_s, unique_s;
+val parser_s, unique_s, circref_s;
 val listener_hist_len_s, listener_multi_line_p_s, listener_sel_inclusive_p_s;
 val intr_s;
 
@@ -76,6 +78,7 @@ static void parser_mark(val obj)
   gc_mark(p->stream);
   gc_mark(p->name);
   gc_mark(p->prepared_msg);
+  gc_mark(p->circ_ref_hash);
   if (p->syntax_tree != nao)
     gc_mark(p->syntax_tree);
   yy_tok_mark(&p->recent_tok);
@@ -109,6 +112,8 @@ void parser_common_init(parser_t *p)
   p->stream = nil;
   p->name = nil;
   p->prepared_msg = nil;
+  p->circ_ref_hash = nil;
+  p->circ_count = 0;
   p->syntax_tree = nil;
   yylex_init(&yyscan);
   p->scanner = convert(scanner_t *, yyscan);
@@ -210,6 +215,168 @@ int parser_callgraph_circ_check(struct circ_stack *rs, val obj)
   return 1;
 }
 
+static val patch_ref(parser_t *p, val obj)
+{
+  if (consp(obj)) {
+    val a = pop(&obj);
+    if (a == circref_s) {
+      val num = car(obj);
+      val rep = gethash(p->circ_ref_hash, num);
+      if (!rep)
+        yyerrorf(p->scanner, lit("dangling #~s# ref"), num, nao);
+      if (consp(rep) && car(rep) == circref_s)
+        yyerrorf(p->scanner, lit("absurd #~s# ref"), num, nao);
+      if (!p->circ_count--)
+        yyerrorf(p->scanner, lit("unexpected surplus #~s# ref"), num, nao);
+      return rep;
+    }
+  }
+  return nil;
+}
+
+static void circ_backpatch(parser_t *p, val obj)
+{
+tail:
+  if (!p->circ_count)
+    return;
+  if (!is_ptr(obj))
+    return;
+  switch (type(obj)) {
+  case CONS:
+    {
+      val a = car(obj);
+      val d = cdr(obj);
+      val ra = patch_ref(p, a);
+      val rd = patch_ref(p, d);
+
+      if (ra)
+        rplaca(obj, ra);
+      else
+        circ_backpatch(p, a);
+
+      if (rd) {
+        rplacd(obj, rd);
+        break;
+      }
+
+      obj = d;
+      goto tail;
+    }
+  case VEC:
+    {
+      cnum i;
+      cnum l = c_num(length_vec(obj));
+
+      for (i = 0; i < l; i++) {
+        val in = num(i);
+        val v = vecref(obj, in);
+        val rv = patch_ref(p, v);
+        if (rv)
+          set(vecref_l(obj, in), rv);
+        else
+          circ_backpatch(p, v);
+        if (!p->circ_count)
+          break;
+      }
+
+      break;
+    }
+  case RNG:
+    {
+      val s = from(obj);
+      val e = to(obj);
+      val rs = patch_ref(p, s);
+      val re = patch_ref(p, e);
+
+      if (rs)
+        set_from(obj, rs);
+      else
+        circ_backpatch(p, s);
+
+      if (re) {
+        set_to(obj, re);
+        break;
+      }
+
+      obj = e;
+      goto tail;
+    }
+  case COBJ:
+    if (hashp(obj)) {
+      val u = get_hash_userdata(obj);
+      val ru = patch_ref(p, u);
+      if (ru)
+        set_hash_userdata(obj, ru);
+      if (p->circ_count) {
+        val iter = hash_begin(obj);
+        val cell;
+        while ((cell = hash_next(iter)))
+          circ_backpatch(p, cell);
+      }
+    } else if (structp(obj)) {
+      val stype = struct_type(obj);
+      val iter;
+
+      for (iter = slots(stype); iter; iter = cdr(iter)) {
+        val sn = car(iter);
+        val sv = slot(obj, sn);
+        val rsv = patch_ref(p, sv);
+        if (rsv)
+          slotset(obj, sn, rsv);
+        else
+          circ_backpatch(p, sv);
+      }
+    }
+    break;
+  default:
+    break;
+  }
+  return;
+}
+
+void parser_resolve_circ(parser_t *p)
+{
+  if (p->circ_count == 0)
+    return;
+
+  circ_backpatch(p, p->syntax_tree);
+
+  if (p->circ_count > 0)
+    yyerrorf(p->scanner, lit("not all #<num># refs replaced in object ~s"),
+             p->syntax_tree, nao);
+}
+
+void parser_circ_def(parser_t *p, val num, val expr)
+{
+  if (!p->circ_ref_hash)
+    p->circ_ref_hash = make_hash(nil, nil, nil);
+
+  {
+    val new_p = nil;
+    val cell = gethash_c(p->circ_ref_hash, num, mkcloc(new_p));
+
+    if (!new_p && cdr(cell) != unique_s)
+      yyerrorf(p->scanner, lit("duplicate #~s= def"), num, nao);
+
+    rplacd(cell, expr);
+  }
+}
+
+val parser_circ_ref(parser_t *p, val num)
+{
+  val obj = if2(p->circ_ref_hash, gethash(p->circ_ref_hash, num));
+
+  if (!obj)
+    yyerrorf(p->scanner, lit("dangling #~s# ref"), num, nao);
+
+  if (obj == unique_s) {
+    p->circ_count++;
+    return cons(circref_s, cons(num, nil));
+  }
+
+  return obj;
+}
+
 void open_txr_file(val spec_file, val *txr_lisp_p, val *name, val *stream)
 {
   enum { none, tl, txr } suffix;
@@ -845,9 +1012,16 @@ val parser_eof(val parser)
   return tnil(p->recent_tok.yy_char == 0);
 }
 
+static val circref(val n)
+{
+  uw_throwf(error_s, lit("unresolved #~s# reference in object syntax"),
+            n, nao);
+}
+
 void parse_init(void)
 {
   parser_s = intern(lit("parser"), user_package);
+  circref_s = intern(lit("circref"), system_package);
   intr_s = intern(lit("intr"), user_package);
   listener_hist_len_s = intern(lit("*listener-hist-len*"), user_package);
   listener_multi_line_p_s = intern(lit("*listener-multi-line-p*"), user_package);
@@ -860,4 +1034,5 @@ void parse_init(void)
   reg_var(listener_hist_len_s, num_fast(500));
   reg_var(listener_multi_line_p_s, nil);
   reg_var(listener_sel_inclusive_p_s, nil);
+  reg_fun(circref_s, func_n1(circref));
 }
diff --git a/parser.h b/parser.h
index e7bc8c6d..a12d45ee 100644
--- a/parser.h
+++ b/parser.h
@@ -54,6 +54,8 @@ struct parser {
   val name;
   val prepared_msg;
   val syntax_tree;
+  val circ_ref_hash;
+  cnum circ_count;
   scanner_t *scanner;
   struct yy_token recent_tok;
   struct yy_token tok_pushback[4];
@@ -66,8 +68,7 @@ enum prime_parser { prime_lisp, prime_interactive, prime_regex };
 extern const int have_yydebug;
 extern const wchar_t *spec_file;
 extern val form_to_ln_hash;
-extern val parser_s;
-extern val unique_s;
+extern val parser_s, unique_s, circref_s;
 void yydebug_onoff(int);
 void yyerror(scanner_t *scanner, parser_t *, const char *s);
 void yyerr(scanner_t *scanner, const char *s);
@@ -87,10 +88,13 @@ void parser_l_init(void);
 void open_txr_file(val spec_file, val *txr_lisp_p, val *name, val *stream);
 void prime_parser(parser_t *, val name, enum prime_parser);
 void prime_parser_post(parser_t *, enum prime_parser);
-void prime_scanner(scanner_t *, enum prime_parser);
 #ifdef SPACE
 int parser_callgraph_circ_check(struct circ_stack *rs, val obj);
 #endif
+void prime_scanner(scanner_t *, enum prime_parser);
+void parser_resolve_circ(parser_t *);
+void parser_circ_def(parser_t *, val num, val expr);
+val parser_circ_ref(parser_t *, val num);
 void scrub_scanner(scanner_t *, int yy_char, wchar_t *lexeme);
 int parse_once(val stream, val name, parser_t *parser);
 int parse(parser_t *parser, val name, enum prime_parser);
diff --git a/parser.l b/parser.l
index 8816bb4b..763f6544 100644
--- a/parser.l
+++ b/parser.l
@@ -708,6 +708,18 @@ UONLY   {U2}{U}|{U3}{U}{U}|{U4}{U}{U}{U}
   return HASH_R;
 }
 
+<NESTED,BRACED>#{DIG}+= {
+  val str = string_own(utf8_dup_from(yytext + 1));
+  yylval->val = int_str(str, num(10));
+  return HASH_N_EQUALS;
+}
+
+<NESTED,BRACED>#{DIG}+# {
+  val str = string_own(utf8_dup_from(yytext + 1));
+  yylval->val = int_str(str, num(10));
+  return HASH_N_HASH;
+}
+
 <NESTED>\.\. {
   yylval->lineno = yyextra->lineno;
   return DOTDOT;
diff --git a/parser.y b/parser.y
index 8ae40e82..c3bc60e5 100644
--- a/parser.y
+++ b/parser.y
@@ -108,6 +108,7 @@ int yyparse(scanner_t *, parser_t *);
 %token <lineno> SECRET_ESCAPE_R SECRET_ESCAPE_E SECRET_ESCAPE_I
 
 %token <val> NUMBER METANUM
+%token <val> HASH_N_EQUALS HASH_N_HASH
 
 %token <chr> REGCHAR REGTOKEN LITCHAR SPLICE CONSDOT LAMBDOT
 
@@ -136,7 +137,7 @@ int yyparse(scanner_t *, parser_t *);
 %right SYMTOK '{' '}'
 %right ALL SOME NONE MAYBE CASES CHOOSE AND OR END COLLECT UNTIL COLL
 %right OUTPUT REPEAT REP FIRST LAST EMPTY DEFINE IF ELIF ELSE
-%right SPACE TEXT NUMBER METANUM
+%right SPACE TEXT NUMBER METANUM HASH_N_EQUALS HASH_N_HASH
 %nonassoc '[' ']' '(' ')'
 %left '-' ',' '\'' '^' SPLICE '@'
 %left '|' '/'
@@ -934,6 +935,10 @@ i_expr : SYMTOK                 { $$ = symhlpr($1, t); }
                                           num(parser->lineno)); }
        | SPLICE i_expr          { $$ = rl(rlcp(list(sys_splice_s, $2, nao), $2),
                                           num(parser->lineno)); }
+       | HASH_N_EQUALS          { parser_circ_def(parser, $1, unique_s); }
+         i_expr                 { parser_circ_def(parser, $1, $3);
+                                  $$ = $3; }
+       | HASH_N_HASH            { $$ = parser_circ_ref(parser, $1); }
        ;
 
 n_expr : SYMTOK                 { $$ = symhlpr($1, t); }
@@ -972,6 +977,10 @@ n_expr : SYMTOK                 { $$ = symhlpr($1, t); }
                                                  or2($1, $3)),
                                                  num(parser->lineno));
                                   } }
+       | HASH_N_EQUALS          { parser_circ_def(parser, $1, unique_s); }
+         n_expr                 { parser_circ_def(parser, $1, $3);
+                                  $$ = $3; }
+       | HASH_N_HASH            { $$ = parser_circ_ref(parser, $1); }
        ;
 
 n_exprs_opt : n_exprs           { $$ = $1; }
@@ -1664,6 +1673,8 @@ void yybadtoken(parser_t *parser, int tok, val context)
   case HASH_SLASH:     problem = lit("#/"); break;
   case HASH_H:         problem = lit("#H"); break;
   case HASH_S:         problem = lit("#S"); break;
+  case HASH_N_EQUALS:  problem = lit("#<n>="); break;
+  case HASH_N_HASH:    problem = lit("#<n>#"); break;
   case WORDS:   problem = lit("#\""); break;
   case WSPLICE: problem = lit("#*\""); break;
   case QWORDS:         problem = lit("#`"); break;
@@ -1710,6 +1721,8 @@ int parse_once(val stream, val name, parser_t *parser)
 
   res = yyparse(parser->scanner, parser);
 
+  parser_resolve_circ(parser);
+
   uw_catch(esym, eobj) {
     yyerrorf(parser->scanner, lit("exception during parse"), nao);
     uw_throw(esym, eobj);
@@ -1733,6 +1746,8 @@ int parse(parser_t *parser, val name, enum prime_parser prim)
 
   parser->errors = 0;
   parser->prepared_msg = nil;
+  parser->circ_ref_hash = nil;
+  parser->circ_count = 0;
   parser->syntax_tree = nil;
 
   prime_parser(parser, name, prim);
@@ -1743,6 +1758,8 @@ int parse(parser_t *parser, val name, enum prime_parser prim)
 
   prime_parser_post(parser, prim);
 
+  parser_resolve_circ(parser);
+
   uw_catch(esym, eobj) {
     yyerrorf(parser->scanner, lit("exception during parse"), nao);
     uw_throw(esym, eobj);
author	Kaz Kylheku <kaz@kylheku.com>	2016-10-18 05:42:58 -0700
committer	Kaz Kylheku <kaz@kylheku.com>	2016-10-18 05:42:58 -0700
commit	37636d9b1ceae173635d18043e21f446dfbd2490 (patch)
tree	87bb18340363df6aa405aa7e8dea45b3229239ec
parent	f91ef728d1149d7a849d7c818b3fdc03c61847ad (diff)
download	txr-37636d9b1ceae173635d18043e21f446dfbd2490.tar.gz txr-37636d9b1ceae173635d18043e21f446dfbd2490.tar.bz2 txr-37636d9b1ceae173635d18043e21f446dfbd2490.zip