Allow macroexpansion side-effects to happen at load-time too

src/global-environment.lisp

@@ -12,9 +12,12 @@
   source-form
   node)
 
+(make-load-form-for-struct entry)
+
+
 (define-global-var **global-value-definitions**
   (make-hash-table :test 'eql)
-  "Database of Coalton global value definitions.")
+  "Database of Coalton global value definitions. This is a map from vars (symbols) to ENTRYs.")
 
 (defun var-knownp (var)
   "Have we seen VAR?"
@@ -39,7 +42,7 @@
   (check-type new-value entry)
   (check-type var symbol)
   (when (var-knownp var)
-    (warn "Overwriting info entry for ~S" var))
+    (style-warn "Overwriting info entry for ~S" var))
   (setf (gethash var **global-value-definitions**) new-value))
 
 (defun make-internal-name (s)
@@ -65,7 +68,7 @@
   (check-type new-value ty)
   (let ((info (var-info var)))
     (when (entry-declared-type info)
-      (warn "Overwriting declared type of ~S" var))
+      (style-warn "Overwriting declared type of ~S" var))
     (alexandria:when-let ((derived (var-derived-type var)))
       (unless (more-or-equally-specific-type-p derived new-value)
         (error "Cannot declare ~S as ~S because that is ~
@@ -83,7 +86,7 @@
   (check-type new-value ty)
   (let ((info (var-info var)))
     (when (entry-derived-type info)
-      (warn "Overwriting derived type of ~S" var))
+      (style-warn "Overwriting derived type of ~S" var))
     (alexandria:when-let ((declared (var-declared-type var)))
       (unless (more-or-equally-specific-type-p new-value declared)
         (error "The derived type of ~S, which is ~S, is incompatible ~

src/toplevel-define-type.lisp

@@ -101,6 +101,14 @@ where
     ;; TODO: Structs? Vectors? Classes? This should be thought
     ;; about. Let's start with classes.
     `(progn
+       ;; Make sure database side effects are maintained.
+       (eval-when (:compile-toplevel :load-toplevel :execute)
+         (setf (find-tycon ',tycon-name) ,tycon)
+         ,@(loop :for (_ name ty) :in ctors
+                 :collect `(unless (var-knownp ',name)
+                             (forward-declare-variable ',name))
+                 :collect `(setf (var-declared-type ',name) ,ty)))
+
        ;; Define types. Create the superclass.
        ;;
        ;; TODO: handle special case of 1 ctor.

src/types.lisp

@@ -17,6 +17,8 @@
   ;; nice to make it read-only though.
   (constructors nil      :type alexandria:proper-list))
 
+(make-load-form-for-struct tycon)
+
 ;;; TODO: figure out type aliases.
 (define-global-var **type-definitions** (make-hash-table :test 'eql)
   "Database of Coalton type definitions. These are mappings from symbols to type constructors.")
@@ -38,7 +40,7 @@
   (check-type tycon-name symbol)
   (check-type new-value tycon)
   (when (tycon-knownp tycon-name)
-    (warn "Clobbering tycon ~S" tycon-name))
+    (style-warn "Clobbering tycon ~S" tycon-name))
   (setf (gethash tycon-name **type-definitions**) new-value))
 
 (defun find-tycon-for-ctor (name)
@@ -57,12 +59,16 @@
   (instance nil :type (or null ty)     :read-only nil)
   (name     nil :type (or null symbol) :read-only nil))
 
+(make-load-form-for-struct tyvar)
+
 (defstruct (tyapp (:include ty)
                   (:constructor tyapp (constructor &rest types)))
   "A type application. (Note that this could be the application of a 0-arity constructor.)"
   (constructor  nil :type tycon     :read-only t)
   (types        nil :type type-list :read-only t))
 
+(make-load-form-for-struct tyapp)
+
 (defun tyapp-name (tyapp)
   (tycon-name (tyapp-constructor tyapp)))
 
@@ -74,6 +80,8 @@
   (from nil :type type-list :read-only t)
   (to   nil :type ty        :read-only t))
 
+(make-load-form-for-struct tyfun)
+
 (defun tyfun-arity (tyfun)
   (length (tyfun-from tyfun)))
 

src/utilities.lisp

@@ -28,3 +28,27 @@
          :reason-control reason-control
          :reason-args reason-args))
 
+(defun make-collector ()
+  (let* ((tail  (cons nil nil))
+         (items tail))
+    (lambda (&optional (item nil itemp))
+      (cond
+        ((not itemp) (cdr items))
+        (t
+         (rplacd tail (cons item nil))
+         (setf   tail (cdr tail))
+         item)))))
+
+(defmacro record-side-effects! ((collector) &body forms)
+  `(progn
+     ,@forms
+     (funcall ,collector '(progn ,@forms))))
+
+(defmacro make-load-form-for-struct (struct-name)
+  `(defmethod make-load-form ((s ,struct-name) &optional env)
+     (make-load-form-saving-slots s :environment env)))
+
+(defun style-warn (format-control &rest format-args)
+  (format t "~&; ")
+  (apply #'format t format-control format-args)
+  (fresh-line))