Start of fallback package list implementation.

* eval.c (eval_init): Register package-fallback-list and
set-package-fallback-list intrinsics.

* lib.c (package_fallback_list, set_package_fallback_list,
intern_fallback): New functions

* lib.h (package_fallback_list, set_package_fallback_list,
intern_fallback): Declared.

* parser.y (sym_helper): Slightly restructure function
so that the symbol interning is done separately in
the various cases. In the unqualified symbol case,
use intern_fallback to search the fallback list
of the current package.

* share/txr/stdlib/package.tl (defpackage): Implement
:fallback clause.

5 files changed, 72 insertions, 11 deletions

diff --git a/eval.c b/eval.c
index 199bfa0a..e8ac079e 100644
--- a/eval.c
+++ b/eval.c
@@ -5246,6 +5246,8 @@ void eval_init(void)
   reg_fun(intern(lit("intern"), user_package), func_n2o(intern, 1));
   reg_fun(intern(lit("unintern"), user_package), func_n2o(unintern, 1));
   reg_fun(intern(lit("rehome-sym"), user_package), func_n2o(rehome_sym, 1));
+  reg_fun(intern(lit("package-fallback-list"), user_package), func_n1(package_fallback_list));
+  reg_fun(intern(lit("set-package-fallback-list"), user_package), func_n2(set_package_fallback_list));
   reg_fun(intern(lit("symbolp"), user_package), func_n1(symbolp));
   reg_fun(intern(lit("symbol-name"), user_package), func_n1(symbol_name));
   reg_fun(intern(lit("symbol-package"), user_package), func_n1(symbol_package));
diff --git a/lib.c b/lib.c
index cdc6564b..233e3d3b 100644
--- a/lib.c
+++ b/lib.c
@@ -5089,6 +5089,59 @@ val rehome_sym(val sym, val package_in)
   return sym;
 }
 
+val package_fallback_list(val package_in)
+{
+  val package = get_package(lit("package-fallback-list"), package_in, t);
+  return get_hash_userdata(package->pk.symhash);
+}
+
+val set_package_fallback_list(val package_in, val list_in)
+{
+  val self = lit("set-package-fallback-list");
+  val package = get_package(self, package_in, t);
+  val list = resolve_package_designators(self, list_in);
+  return set_hash_userdata(package->pk.symhash, list);
+}
+
+val intern_fallback(val str, val package_in)
+{
+  val self = lit("intern-fallback");
+  val package = get_package(self, package_in, nil);
+  val fblist = get_hash_userdata(package->pk.symhash);
+
+  if (!stringp(str))
+    uw_throwf(error_s, lit("~s: name ~s isn't a string"), self, str, nao);
+
+  if (fblist) {
+    val found;
+    val sym;
+
+    if ((sym = gethash_f(package->pk.symhash, str, mkcloc(found))) || found)
+      return sym;
+
+    for (; fblist; fblist = cdr(fblist)) {
+      val otherpkg = car(fblist);
+      if ((sym = gethash_f(otherpkg->pk.symhash, str, mkcloc(found))) || found)
+        return sym;
+    }
+  }
+
+  {
+    val new_p;
+    loc place;
+
+    place = gethash_l(package->pk.symhash, str, mkcloc(new_p));
+
+    if (!new_p) {
+      return deref(place);
+    } else {
+      val newsym = make_sym(str);
+      newsym->s.package = package;
+      return set(place, newsym);
+    }
+  }
+}
+
 val symbolp(val sym)
 {
   switch (type(sym)) {
diff --git a/lib.h b/lib.h
index c55bd23c..e17f0668 100644
--- a/lib.h
+++ b/lib.h
@@ -785,7 +785,6 @@ val package_alist(void);
 val package_name(val package);
 val package_symbols(val package);
 val package_local_symbols(val package);
-val package_foreign_symbols(val package);
 val use_sym(val use_list, val package);
 val unuse_sym(val symbol, val package);
 val use_package(val use_list, val package);
@@ -793,6 +792,10 @@ val unuse_package(val unuse_list, val package);
 val intern(val str, val package);
 val unintern(val sym, val package);
 val rehome_sym(val sym, val package);
+val package_foreign_symbols(val package);
+val package_fallback_list(val package);
+val set_package_fallback_list(val package, val list);
+val intern_fallback(val str, val package);
 val symbolp(val sym);
 val symbol_name(val sym);
 val symbol_package(val sym);
diff --git a/parser.y b/parser.y
index 2c1c31c7..e26214a4 100644
--- a/parser.y
+++ b/parser.y
@@ -1249,7 +1249,7 @@ static val sym_helper(parser_t *parser, wchar_t *lexeme, val meta_allowed)
   int leading_at = *lexeme == L'@';
   wchar_t *tokfree = lexeme;
   wchar_t *colon = wcschr(lexeme, L':');
-  val sym_name = nil, pkg_name = nil, package = cur_package, sym;
+  val sym;
 
   if (leading_at) {
     if (!meta_allowed) {
@@ -1264,32 +1264,32 @@ static val sym_helper(parser_t *parser, wchar_t *lexeme, val meta_allowed)
     *colon = 0;
 
   if (colon == lexeme) {
-    package = keyword_package_var;
-    sym_name = string(colon + 1);
+    val sym_name = string(colon + 1);
     scrub_scanner(parser->scanner, SYMTOK, tokfree);
     free(tokfree);
+    sym = intern(sym_name, keyword_package_var);
   } else if (colon != 0) {
-    pkg_name = string(lexeme);
-    sym_name = string(colon + 1);
+    val pkg_name = string(lexeme);
+    val sym_name = string(colon + 1);
     scrub_scanner(parser->scanner, SYMTOK, tokfree);
     free(tokfree);
     if (equal(pkg_name, lit("#"))) {
-      package = nil;
+      sym = make_sym(sym_name);
     } else {
-      package = find_package(pkg_name);
+      val package = find_package(pkg_name);
       if (!package) {
         yyerrorf(scnr, lit("~a:~a: package ~a not found"), pkg_name, sym_name, pkg_name, nao);
         return nil;
       }
+      sym = intern(sym_name, package);
     }
   } else {
-    sym_name = string(lexeme);
+    val sym_name = string(lexeme);
     scrub_scanner(parser->scanner, SYMTOK, tokfree);
     free(tokfree);
+    sym = intern_fallback(sym_name, cur_package);
   }
 
-  sym = package ? intern(sym_name, package) : make_sym(sym_name);
-
   return leading_at ? rl(list(var_s, sym, nao), num(parser->lineno)) : sym;
 }
 
diff --git a/share/txr/stdlib/package.tl b/share/txr/stdlib/package.tl
index 7e62b6e5..12a8cf5e 100644
--- a/share/txr/stdlib/package.tl
+++ b/share/txr/stdlib/package.tl
@@ -68,6 +68,9 @@
                                       (unless (eq (symbol-package s) ,pkg)
                                         (unuse-sym s ,pkg)
                                         (intern n ,pkg))))))
+                              (:fallback
+                                (if rest ^((set-package-fallback-list ,pkg
+                                                                      ',rest))))
                               (:use-from
                                  (throwf 'eval-error
                                          "~s: :use-from clause needs package argument"