From a18c539bb14fe7abba4a2b3fe275712530ab538f Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Thu, 4 May 2017 06:28:47 -0700
Subject: structs: check existence of type in new and lnew.

This achieves two objectives. The obvious one is that we get
a diagnostic for new expressions that name a nonexistent type,
due to a typo, before those expressions are executed.

However, this also fixes an annoying issue: spurious warnings
about nonexistent slots, related to structs which have not
yet been autoloaded. A test case for this is an expression
like (let ((b (new list-builder))) b.(add 42)). Because
list-builder is auto-loaded, the add slot doesn't exist.
But (new list-builder) doesn't trigger that auto-load; so
the deferred warning about the nonexistent slot isn't
suppressed. With this change, the existence check in
(new list-builder) will trigger the auto-load for the module
which defines list-builder, causing the add slot to exist
before the b.(add 42) expression is visited by the expander.

* share/txr/stdlib/struct.tl (sys:check-struct): New function.
(new, lnew): Issue warning if the type doesn't exist.
---
 share/txr/stdlib/struct.tl | 32 +++++++++++++++++++++++---------
 1 file changed, 23 insertions(+), 9 deletions(-)

diff --git a/share/txr/stdlib/struct.tl b/share/txr/stdlib/struct.tl
index 3605e7ee..8548e03a 100644
--- a/share/txr/stdlib/struct.tl
+++ b/share/txr/stdlib/struct.tl
@@ -198,6 +198,12 @@
                           slot))
   slot)
 
+(defun sys:check-struct (form stype)
+  (unless (find-struct-type stype)
+    (compile-defr-warning form ^(struct-type . ,stype)
+                          "~s does not name a struct type"
+                          stype)))
+
 (defmacro qref (:form form obj . refs)
   (when (null refs)
     (throwf 'eval-error "~s: bad syntax" 'qref))
@@ -239,26 +245,34 @@
     (t (with-gensyms (ovar)
          ^(lambda (,ovar) (qref ,ovar ,*args))))))
 
-(defmacro new (spec . pairs)
+(defmacro new (:form form spec . pairs)
   (if (oddp (length pairs))
     (throwf 'eval-error "~s: slot initform arguments must occur pairwise"
             'new))
   (let ((qpairs (mappend (aret ^(',@1 ,@2)) (tuples 2 pairs))))
     (tree-case spec
-      ((atom . args) ^(make-struct ',atom (list ,*qpairs) ,*args))
-      (atom ^(make-struct ',atom (list ,*qpairs))))))
+      ((atom . args)
+        (sys:check-struct form atom)
+        ^(make-struct ',atom (list ,*qpairs) ,*args))
+      (atom
+        (sys:check-struct form atom)
+        ^(make-struct ',atom (list ,*qpairs))))))
 
-(defmacro lnew (spec . pairs)
+(defmacro lnew (:form form spec . pairs)
   (if (oddp (length pairs))
     (throwf 'eval-error "~s: slot initform arguments must occur pairwise"
             'lnew))
   (let ((qpairs (mappend (aret ^(',@1 ,@2)) (tuples 2 pairs))))
     (tree-case spec
-      ((atom . args) ^(make-lazy-struct ',atom
-                                        (lambda ()
-                                          (cons (list ,*qpairs)
-                                                (list ,*args)))))
-      (atom ^(make-lazy-struct ',atom (lambda () (list (list ,*qpairs))))))))
+      ((atom . args)
+        (sys:check-struct form atom)
+        ^(make-lazy-struct ',atom
+                           (lambda ()
+                             (cons (list ,*qpairs)
+                                   (list ,*args)))))
+      (atom
+        (sys:check-struct form atom)
+        ^(make-lazy-struct ',atom (lambda () (list (list ,*qpairs))))))))
 
 (defmacro meth (obj slot . bound-args)
   ^[(fun method) ,obj ',slot ,*bound-args])
-- 
cgit v1.2.3