From 0a36fb777ce82e8eefa75771bdd9d2f699771d69 Mon Sep 17 00:00:00 2001
From: Alex Wood <aeshtaer@gmail.com>
Date: Wed, 3 Jul 2024 18:07:00 -0400
Subject: [PATCH 01/11] Don't use mv-/call for 0-receiving calls

Dunno why I thought that was ever a good idea. It's irregular, and
also will be slower since the full call instructions cons in our
dumb VM implementations.
---
 compile/compile.lisp | 18 ++++++++----------
 1 file changed, 8 insertions(+), 10 deletions(-)

diff --git a/compile/compile.lisp b/compile/compile.lisp
index b763cfd..dd3c063 100644
--- a/compile/compile.lisp
+++ b/compile/compile.lisp
@@ -395,19 +395,17 @@
 
 (defun emit-call (context count)
   (let ((receiving (context-receiving context)))
-    (cond ((or (eql receiving t) (eql receiving 0))
-           (assemble context m:call count))
-          ((eql receiving 1)
-           (assemble context m:call-receive-one count))
-          (t (assemble context m:call-receive-fixed count receiving)))))
+    (case receiving
+      ((t) (assemble context m:call count))
+      ((1) (assemble context m:call-receive-one count))
+      (t   (assemble context m:call-receive-fixed count receiving)))))
 
 (defun emit-mv-call (context)
   (let ((receiving (context-receiving context)))
-    (cond ((or (eql receiving t) (eql receiving 0))
-           (assemble context m:mv-call))
-          ((eql receiving 1)
-           (assemble context m:mv-call-receive-one))
-          (t (assemble context m:mv-call-receive-fixed receiving)))))
+    (case receiving
+      ((t) (assemble context m:mv-call))
+      ((1) (assemble context m:mv-call-receive-one))
+      (t   (assemble context m:mv-call-receive-fixed receiving)))))
 
 (defun emit-special-bind (context symbol)
   (assemble context m:special-bind (value-cell-index symbol context)))

From 0bc0b4d10bd5383b54acde3f6a14c9e01c6b2cf8 Mon Sep 17 00:00:00 2001
From: Alex Wood <aeshtaer@gmail.com>
Date: Mon, 8 Jul 2024 11:30:18 -0400
Subject: [PATCH 02/11] Move lexenv definition to separate file

for cleanliness
---
 compile/compile.lisp     | 143 +--------------------------------------
 compile/environment.lisp | 140 ++++++++++++++++++++++++++++++++++++++
 maclina.asd              |   3 +-
 3 files changed, 143 insertions(+), 143 deletions(-)
 create mode 100644 compile/environment.lisp

diff --git a/compile/compile.lisp b/compile/compile.lisp
index dd3c063..545a0e4 100644
--- a/compile/compile.lisp
+++ b/compile/compile.lisp
@@ -500,144 +500,9 @@
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;
-;;; Environments
+;;; Environments (mostly in environment.lisp)
 ;;;
 
-(defstruct (lexical-environment (:constructor make-null-lexical-environment
-                                    (global-environment))
-                                (:constructor %make-lexical-environment)
-                                (:conc-name nil))
-  ;; An alist of (var . var-info) in the current environment.
-  (vars nil :type list :read-only t)
-  ;; An alist of (tag tag-dynenv . label) in the current environment.
-  (tags nil :type list :read-only t)
-  ;; An alist of (block block-dynenv . label) in the current environment.
-  (blocks nil :type list :read-only t)
-  ;; An alist of (fun . fun-var) in the current environment.
-  (funs nil :type list :read-only t)
-  ;; Global environment, which we just pass to Trucler.
-  (global-environment (error "missing arg") :read-only t))
-
-;;; We don't use Trucler's augmentation protocol internally since we often
-;;; want to add a bunch of stuff at once, which is awkward in Trucler.
-(defun make-lexical-environment (parent &key (vars (vars parent))
-                                          (tags (tags parent))
-                                          (blocks (blocks parent))
-                                          (funs (funs parent)))
-  (%make-lexical-environment
-   :vars vars :tags tags :blocks blocks :funs funs
-   :global-environment (global-environment parent)))
-
-(defun make-null-lexenv (global-compilation-environment)
-  (%make-lexical-environment
-   :global-environment global-compilation-environment))
-
-;;; We don't actually use Trucler's query protocol internally, since the
-;;; environments are necessarily ours (they include bytecode-specific
-;;; information, etc.)
-;;; But we do fall back to it when we hit the global environment.
-;;; And we define the methods, to be nice to macros, so maybe we
-;;; should use it internally after all.
-;;; TODO: Once trucler actually implements augmentation we should
-;;; maybe use that and not have our own environments at all.
-
-(defmethod trucler:global-environment (client (env lexical-environment))
-  (declare (ignore client))
-  (global-environment env))
-
-(defmethod trucler:describe-variable
-    (client (env lexical-environment) name)
-  (or (cdr (assoc name (vars env)))
-      (trucler:describe-variable client
-                                 (global-environment env) name)))
-
-(defmethod trucler:describe-function
-    (client (env lexical-environment) name)
-  (or (cdr (assoc name (funs env) :test #'equal))
-      (trucler:describe-variable client
-                                 (global-environment env) name)))
-
-(defmethod trucler:describe-block
-    (client (env lexical-environment) name)
-  (cdr (assoc name (blocks env))))
-
-(defmethod trucler:describe-tag
-    (client (env lexical-environment) name)
-  (cdr (assoc name (tags env))))
-
-(defun var-info (name env)
-  (or (cdr (assoc name (vars env)))
-      (trucler:describe-variable m:*client* (global-environment env) name)))
-(defun fun-info (name env)
-  (or (cdr (assoc name (funs env) :test #'equal))
-      (trucler:describe-function m:*client* (global-environment env) name)))
-
-;; never actually called
-(defun missing-arg () (error "missing arg"))
-
-;;; Our info for lexical bindings (variable and function).
-(defstruct (lexical-info
-            (:constructor make-lexical-info
-                (frame-offset cfunction)))
-  ;; Register index for this lvar.
-  (frame-offset (missing-arg) :read-only t :type (integer 0))
-  ;; Cfunction this lvar belongs to (i.e. is bound by)
-  (cfunction (missing-arg) :read-only t :type cfunction))
-
-;;; Our info for specifically variable bindings.
-;;; (while function bindings can be closed over, they can't be modified,
-;;;  so we don't really care.)
-(defstruct (lexical-variable-info
-            (:constructor make-lexical-variable-info
-                (frame-offset cfunction))
-            (:include lexical-info))
-  (closed-over-p nil :type boolean)
-  (setp nil :type boolean))
-
-(defun frame-offset (lex-desc)
-  (lexical-info-frame-offset (trucler:identity lex-desc)))
-
-(defun lvar-cfunction (lex-desc)
-  (lexical-info-cfunction (trucler:identity lex-desc)))
-
-(defun closed-over-p (lvar-desc)
-  (lexical-variable-info-closed-over-p (trucler:identity lvar-desc)))
-
-(defun (setf closed-over-p) (new lvar-desc)
-  (setf (lexical-variable-info-closed-over-p (trucler:identity lvar-desc))
-        new))
-
-(defun setp (lvar-desc)
-  (lexical-variable-info-setp (trucler:identity lvar-desc)))
-
-(defun (setf setp) (new lvar-desc)
-  (setf (lexical-variable-info-setp (trucler:identity lvar-desc)) new))
-
-;;; Does the lexical variable need a cell?
-(defun indirect-lexical-p (lvar)
-  (and (closed-over-p lvar) (setp lvar)))
-
-(defun make-lexical-variable (name frame-offset cfunction)
-  (make-instance 'trucler:lexical-variable-description
-    :name name
-    :identity (make-lexical-variable-info frame-offset cfunction)))
-
-(defun make-symbol-macro (name expansion)
-  (make-instance 'trucler:symbol-macro-description
-    :name name :expansion expansion))
-
-(defun globally-special-p (symbol env)
-  (typep (var-info symbol env) 'trucler:global-special-variable-description))
-
-(defun make-local-function (name frame-offset cfunction)
-  (make-instance 'trucler:local-function-description
-    :name name
-    :identity (make-lexical-info frame-offset cfunction)))
-
-(defun make-local-macro (name expander)
-  (make-instance 'trucler:local-macro-description
-    :name name :expander expander))
-
 ;;; Bind each variable to a stack location, returning a new lexical
 ;;; environment and new context.
 ;;; The max local count in the current function is also updated.
@@ -674,12 +539,6 @@
          (values (make-lexical-environment env :funs new-vars)
                  (new-context context :frame-end frame-end))))))
 
-(defun add-macros (env macros)
-  (make-lexical-environment env :funs (append macros (funs env))))
-
-(defun add-symbol-macros (env symbol-macros)
-  (make-lexical-environment env :vars (append symbol-macros (vars env))))
-
 (deftype lambda-expression () '(cons (eql lambda) (cons list list)))
 (deftype function-name () '(or symbol (cons (eql setf) (cons symbol null))))
 
diff --git a/compile/environment.lisp b/compile/environment.lisp
new file mode 100644
index 0000000..218d3bf
--- /dev/null
+++ b/compile/environment.lisp
@@ -0,0 +1,140 @@
+(in-package #:maclina.compile)
+
+;; never actually called
+(defun missing-arg () (error "missing arg"))
+
+(defstruct (lexical-environment (:constructor make-null-lexical-environment
+                                    (global-environment))
+                                (:constructor %make-lexical-environment)
+                                (:conc-name nil))
+  ;; An alist of (var . lvar-desc) in the current environment.
+  (vars nil :type list :read-only t)
+  ;; An alist of (tag dynenv-desc . label) in the current environment.
+  (tags nil :type list :read-only t)
+  ;; An alist of (block block-dynenv . label) in the current environment.
+  (blocks nil :type list :read-only t)
+  ;; An alist of (fun . lfun-desc) in the current environment.
+  (funs nil :type list :read-only t)
+  ;; Global environment, which we just pass to Trucler.
+  (global-environment (missing-arg) :read-only t))
+
+;;; We don't use Trucler's augmentation protocol internally since we often
+;;; want to add a bunch of stuff at once, which is awkward in Trucler.
+(defun make-lexical-environment (parent &key (vars (vars parent))
+                                          (tags (tags parent))
+                                          (blocks (blocks parent))
+                                          (funs (funs parent)))
+  (%make-lexical-environment
+   :vars vars :tags tags :blocks blocks :funs funs
+   :global-environment (global-environment parent)))
+
+(defun make-null-lexenv (global-compilation-environment)
+  (%make-lexical-environment
+   :global-environment global-compilation-environment))
+
+;;; We don't actually use Trucler's query protocol internally, since the
+;;; environments are necessarily ours (they include bytecode-specific
+;;; information, etc.)
+;;; But we do fall back to it when we hit the global environment.
+;;; And we define the methods, to be nice to macros, so maybe we
+;;; should use it internally after all.
+;;; TODO: Once trucler actually implements augmentation we should
+;;; maybe use that and not have our own environments at all.
+
+(defmethod trucler:global-environment (client (env lexical-environment))
+  (declare (ignore client))
+  (global-environment env))
+
+(defmethod trucler:describe-variable
+    (client (env lexical-environment) name)
+  (or (cdr (assoc name (vars env)))
+      (trucler:describe-variable client (global-environment env) name)))
+
+(defmethod trucler:describe-function
+    (client (env lexical-environment) name)
+  (or (cdr (assoc name (funs env) :test #'equal))
+      (trucler:describe-function client (global-environment env) name)))
+
+(defmethod trucler:describe-block
+    (client (env lexical-environment) name)
+  (cdr (assoc name (blocks env))))
+
+(defmethod trucler:describe-tag
+    (client (env lexical-environment) name)
+  (cdr (assoc name (tags env))))
+
+(defun var-info (name env)
+  (or (cdr (assoc name (vars env)))
+      (trucler:describe-variable m:*client* (global-environment env) name)))
+(defun fun-info (name env)
+  (or (cdr (assoc name (funs env) :test #'equal))
+      (trucler:describe-function m:*client* (global-environment env) name)))
+
+;;; Our info for lexical bindings (variable and function).
+(defstruct (lexical-info
+            (:constructor make-lexical-info
+                (frame-offset cfunction)))
+  ;; Register index for this lvar.
+  (frame-offset (missing-arg) :read-only t :type (integer 0))
+  ;; Cfunction this lvar belongs to (i.e. is bound by)
+  (cfunction (missing-arg) :read-only t :type cfunction))
+
+;;; Our info for specifically variable bindings.
+;;; (while function bindings can be closed over, they can't be modified,
+;;;  so we don't really care.)
+(defstruct (lexical-variable-info
+            (:constructor make-lexical-variable-info
+                (frame-offset cfunction))
+            (:include lexical-info))
+  (closed-over-p nil :type boolean)
+  (setp nil :type boolean))
+
+(defun frame-offset (lex-desc)
+  (lexical-info-frame-offset (trucler:identity lex-desc)))
+
+(defun lvar-cfunction (lex-desc)
+  (lexical-info-cfunction (trucler:identity lex-desc)))
+
+(defun closed-over-p (lvar-desc)
+  (lexical-variable-info-closed-over-p (trucler:identity lvar-desc)))
+
+(defun (setf closed-over-p) (new lvar-desc)
+  (setf (lexical-variable-info-closed-over-p (trucler:identity lvar-desc))
+        new))
+
+(defun setp (lvar-desc)
+  (lexical-variable-info-setp (trucler:identity lvar-desc)))
+
+(defun (setf setp) (new lvar-desc)
+  (setf (lexical-variable-info-setp (trucler:identity lvar-desc)) new))
+
+;;; Does the lexical variable need a cell?
+(defun indirect-lexical-p (lvar)
+  (and (closed-over-p lvar) (setp lvar)))
+
+(defun make-lexical-variable (name frame-offset cfunction)
+  (make-instance 'trucler:lexical-variable-description
+    :name name
+    :identity (make-lexical-variable-info frame-offset cfunction)))
+
+(defun make-symbol-macro (name expansion)
+  (make-instance 'trucler:symbol-macro-description
+    :name name :expansion expansion))
+
+(defun globally-special-p (symbol env)
+  (typep (var-info symbol env) 'trucler:global-special-variable-description))
+
+(defun make-local-function (name frame-offset cfunction)
+  (make-instance 'trucler:local-function-description
+    :name name
+    :identity (make-lexical-info frame-offset cfunction)))
+
+(defun make-local-macro (name expander)
+  (make-instance 'trucler:local-macro-description
+    :name name :expander expander))
+
+(defun add-macros (env macros)
+  (make-lexical-environment env :funs (append macros (funs env))))
+
+(defun add-symbol-macros (env symbol-macros)
+  (make-lexical-environment env :vars (append symbol-macros (vars env))))
diff --git a/maclina.asd b/maclina.asd
index b983e7a..d2f8392 100644
--- a/maclina.asd
+++ b/maclina.asd
@@ -39,10 +39,11 @@
                  (:file "unknown-reference-conditions" :depends-on ("package"))
                  (:file "compilation-unit"
                   :depends-on ("unknown-reference-conditions" "package"))
+                 (:file "environment" :depends-on ("package"))
                  (:file "compile" :depends-on ("unknown-reference-conditions"
                                                "misc-program-conditions"
                                                "compilation-unit" "parse-macro"
-                                               "package"))
+                                               "environment" "package"))
                  (:file "documentation" :depends-on ("compile"))))))
 
 (asdf:defsystem #:maclina/compile-file

From 7ec342cdf72fc8250853163b31700e959a6cf518 Mon Sep 17 00:00:00 2001
From: Alex Wood <aeshtaer@gmail.com>
Date: Wed, 10 Jul 2024 14:02:22 -0400
Subject: [PATCH 03/11] Warn on unused variables

The Clasp implementation already does this and has acceptable
compilation overhead, and makes it easier to do further compilation.
Plus it's just nice. Makes things a lot easier to debug.
---
 compile/compile.lisp                 | 217 ++++++++++++++++++---------
 compile/environment.lisp             |  24 +--
 compile/misc-program-conditions.lisp |  23 +++
 maclina.asd                          |   1 +
 test/ignore.lisp                     | 103 +++++++++++++
 5 files changed, 288 insertions(+), 80 deletions(-)
 create mode 100644 test/ignore.lisp

diff --git a/compile/compile.lisp b/compile/compile.lisp
index 545a0e4..52e3a62 100644
--- a/compile/compile.lisp
+++ b/compile/compile.lisp
@@ -503,10 +503,24 @@
 ;;; Environments (mostly in environment.lisp)
 ;;;
 
+;;; From a list of declarations, determine the ignore status of the variable
+;;; or #'function. This will be either nil (default), cl:ignore, or cl:ignorable.
+;;; Assumes basic declaration validity has already been checked.
+(defun binding-ignore (name declarations)
+  (dolist (declaration declarations)
+    (dolist (specifier (rest declaration) nil)
+      (case (car specifier)
+        (cl:ignore
+         (when (member name (rest specifier) :test #'equal)
+         (return-from binding-ignore 'cl:ignore)))
+        (cl:ignorable
+         (when (member name (rest specifier) :test #'equal)
+           (return-from binding-ignore 'cl:ignorable)))))))
+
 ;;; Bind each variable to a stack location, returning a new lexical
 ;;; environment and new context.
 ;;; The max local count in the current function is also updated.
-(defun bind-vars (vars env context)
+(defun bind-vars (vars env context declarations)
   (let* ((frame-start (context-frame-end context))
          (var-count (length vars))
          (frame-end (+ frame-start var-count))
@@ -515,7 +529,9 @@
          (vars vars (rest vars))
          (new-vars (vars env)
                    (acons (first vars)
-                          (make-lexical-variable (first vars) index function)
+                          (make-lexical-variable
+                           (first vars) index function
+                           :ignore (binding-ignore (first vars) declarations))
                           new-vars)))
         ((>= index frame-end)
          (values (make-lexical-environment env :vars new-vars)
@@ -524,7 +540,7 @@
         (error 'bind-constant :name (first vars))))))
 
 ;;; Like the above, but function namespace.
-(defun bind-fvars (funs env context)
+(defun bind-fvars (funs env context declarations)
   (let* ((frame-start (context-frame-end context))
          (fun-count (length funs))
          (frame-end (+ frame-start fun-count))
@@ -533,7 +549,10 @@
          (funs funs (rest funs))
          (new-vars (funs env)
                    (acons (first funs)
-                          (make-local-function (first funs) index function)
+                          (make-local-function
+                           (first funs) index function
+                           :ignore (binding-ignore `(function ,(first funs))
+                                                   declarations))
                           new-vars)))
         ((>= index frame-end)
          (values (make-lexical-environment env :funs new-vars)
@@ -658,6 +677,9 @@
 (defmethod compile-symbol ((info trucler:lexical-variable-description)
                            form env context)
   (declare (ignore form env))
+  (setf (lvar-readp info) t)
+  (when (eq (trucler:ignore info) 'cl:ignore)
+    (warn 'used :name (trucler:name info) :kind 'variable))
   (unless (eql (context-receiving context) 0)
     (cond ((eq (lvar-cfunction info) (context-function context))
            (assemble context m:ref (frame-offset info)))
@@ -720,6 +742,9 @@
 
 (defmethod compile-combination ((info trucler:local-function-description)
                                 form env context)
+  (setf (lvar-readp info) t)
+  (when (eq (trucler:ignore info) 'cl:ignore)
+    (warn 'used :name (trucler:name info) :kind 'function))
   (reference-lexical-variable info context)
   (compile-call (rest form) env context))
 
@@ -836,6 +861,19 @@
         (values name value))
       (values binding nil)))
 
+;;; Given a list of lexical infos, warn if any of them are unused.
+(defun warn-ignorance (infos)
+  (dolist (info infos)
+    (when (and (null (trucler:ignore info)) ; not IGNORE or IGNORABLE
+               (not (lvar-readp info))) ; not used
+      (etypecase info
+        (trucler:lexical-variable-description
+         (if (setp info)
+             (warn 'set-unused :name (trucler:name info) :kind 'variable)
+             (warn 'unused :name (trucler:name info) :kind 'variable)))
+        (trucler:local-function-description
+         (warn 'unused :name (trucler:name info) :kind 'function))))))
+
 (defmethod compile-special ((operator (eql 'let)) form env context)
   ;; This is really long because we make an environment manually rather
   ;; than use bind-vars, which would be even more awkward and cons more.
@@ -873,7 +911,8 @@
                              :name var))
                           (t ; lexical
                            (let ((lex (make-lexical-variable
-                                       var frame-end cf)))
+                                       var frame-end cf
+                                       :ignore (binding-ignore var decls))))
                              (incf frame-end)
                              (maybe-emit-make-cell lex context)
                              lex)))))
@@ -887,7 +926,8 @@
                 (new-context context
                              :frame-end frame-end
                              :dynenv (make-list special-binding-count
-                                                :initial-element :special))))
+                                                :initial-element :special)))
+              (igninfos nil))
           ;; Generate the bind and special-bind instructions.
           ;; We generate one bind for each block of contiguous lexicals.
           ;; We bind the most recently pushed values first, so in reverse order,
@@ -895,7 +935,7 @@
           (loop with nlex = 0
                 for (name . info) in new-bindings
                 if (typep info 'trucler:lexical-variable-description)
-                  do (incf nlex)
+                  do (incf nlex) (push info igninfos)
                 else ; special
                 do ; first finish any lexical binding.
                    (when (plusp nlex)
@@ -910,7 +950,8 @@
                                      (- frame-end nlex))))
           ;; Finally, the actual body.
           (compile-progn body post-binding-env post-binding-context)
-          (emit-unbind post-binding-context special-binding-count))))))
+          (emit-unbind post-binding-context special-binding-count)
+          (warn-ignorance igninfos))))))
 
 (defun compile-let* (bindings decls body env context
                      &key (block-name nil block-name-p))
@@ -918,7 +959,8 @@
     (error 'improper-bindings :bindings bindings))
   (let ((special-binding-count 0)
         (specials (extract-specials decls))
-        (inner-context context))
+        (inner-context context)
+        (lexinfos nil))
     (dolist (binding bindings)
       (multiple-value-bind (var valf) (canonicalize-binding binding)
         (unless (symbolp var) (error 'variable-not-symbol :name var))
@@ -930,11 +972,12 @@
                (setq inner-context (new-context inner-context
                                                 :dynenv '(:special))))
               (t
-               (let ((frame-start (context-frame-end inner-context)))
-                 (setf (values env inner-context)
-                       (bind-vars (list var) env inner-context))
-                 (maybe-emit-make-cell (var-info var env) inner-context)
-                 (assemble inner-context m:set frame-start))))))
+               (setf (values env inner-context)
+                     (bind-vars (list var) env inner-context decls))
+               (let ((info (var-info var env)))
+                 (push info lexinfos)
+                 (maybe-emit-make-cell info inner-context)
+                 (assemble inner-context m:set (frame-offset info)))))))
     (let ((new-env (if specials
                        ;; We do this to make sure special declarations get
                        ;; through even if this form doesn't bind them.
@@ -945,7 +988,8 @@
       (if block-name-p
           (compile-block block-name body new-env inner-context)
           (compile-progn body new-env inner-context)))
-    (emit-unbind context special-binding-count)))
+    (emit-unbind context special-binding-count)
+    (warn-ignorance lexinfos)))
 
 (defmethod compile-special ((operator (eql 'let*)) form env context)
   (destructure-syntax (let* bindings . body) (form)
@@ -964,8 +1008,13 @@
                 env context :name `(flet ,name)
                 :block-name (fun-name-block-name name))))
     (emit-bind context (length definitions) (context-frame-end context))
-    (multiple-value-call #'compile-locally body
-      (bind-fvars (mapcar #'car definitions) env context))))
+    (multiple-value-bind (body decls) (parse-body body)
+      (multiple-value-bind (env context)
+          (bind-fvars (mapcar #'car definitions) env context decls)
+        (compile-progn body (add-declarations env decls) context)
+        (warn-ignorance
+         (loop for (name) in definitions
+               collect (fun-info name env)))))))
 
 (defmethod compile-special ((operator (eql 'labels)) form env context)
   (destructure-syntax (labels definitions . body) (form)
@@ -975,35 +1024,40 @@
             (unless (proper-list-p bind)
               (error 'improper-arguments :args bind)))
           definitions)
-    (multiple-value-bind (new-env new-context)
-        (bind-fvars (mapcar #'first definitions) env context)
-      (let* ((module (context-module context))
-             (closures
-               (loop for definition in definitions
-                     for (name fun)
-                       = (destructure-syntax
-                             (labels-binding name lambda-list . body)
-                             (definition :rest nil)
-                           (let ((bname (fun-name-block-name name)))
-                             (list name
-                                   (compile-lambda
-                                    lambda-list body new-env module
-                                    :name `(labels ,name)
-                                    :block-name bname))))
-                     for literal-index = (cfunction-literal-index fun context)
-                     if (zerop (length (cfunction-closed fun)))
-                       do (emit-const context literal-index)
-                     else
-                       collect (cons fun (frame-offset (fun-info name new-env)))
-                       and do (assemble context
-                                m:make-uninitialized-closure
-                                literal-index))))
-        (emit-bind context (length definitions) (context-frame-end context))
-        (dolist (closure closures)
-          (loop for var across (cfunction-closed (car closure))
-                do (reference-lexical-variable var new-context))
-          (assemble context m:initialize-closure (cdr closure)))
-        (compile-locally body new-env new-context)))))
+    (multiple-value-bind (body decls) (parse-body body)
+      (multiple-value-bind (new-env new-context)
+          (bind-fvars (mapcar #'first definitions) env context decls)
+        (let* ((module (context-module context))
+               (igninfos nil)
+               (closures
+                 (loop for definition in definitions
+                       for (name fun)
+                         = (destructure-syntax
+                               (labels-binding name lambda-list . body)
+                               (definition :rest nil)
+                             (let ((bname (fun-name-block-name name)))
+                               (list name
+                                     (compile-lambda
+                                      lambda-list body new-env module
+                                      :name `(labels ,name)
+                                      :block-name bname))))
+                       for literal-index = (cfunction-literal-index fun context)
+                       for info = (fun-info name new-env)
+                       do (push info igninfos)
+                       if (zerop (length (cfunction-closed fun)))
+                         do (emit-const context literal-index)
+                       else
+                         collect (cons fun (frame-offset info))
+                         and do (assemble context
+                                  m:make-uninitialized-closure
+                                  literal-index))))
+          (emit-bind context (length definitions) (context-frame-end context))
+          (dolist (closure closures)
+            (loop for var across (cfunction-closed (car closure))
+                  do (reference-lexical-variable var new-context))
+            (assemble context m:initialize-closure (cdr closure)))
+          (compile-progn body (add-declarations new-env decls) new-context)
+          (warn-ignorance igninfos))))))
 
 (defgeneric compile-setq-1 (info var value-form environment context))
 
@@ -1092,25 +1146,32 @@
 
 (defun compile-function-lookup (fnameoid env context)
   (typecase fnameoid
-    (lambda-expression (compile-lambda-expression fnameoid env context))
+    (lambda-expression
+     (unless (eql 0 (context-receiving context))
+       (compile-lambda-expression fnameoid env context)))
     (function-name
      (let ((info (fun-info fnameoid env)))
        (etypecase info
          (trucler:global-function-description
-          (emit-fdefinition context (fdefinition-index fnameoid context)))
+          (unless (eql 0 (context-receiving context))
+            (emit-fdefinition context (fdefinition-index fnameoid context))))
          (trucler:local-function-description
-          (reference-lexical-variable info context))
+          (setf (lvar-readp info) t)
+          (when (eq (trucler:ignore info) 'cl:ignore)
+            (warn 'used :name (trucler:name info) :kind 'function))
+          (unless (eql 0 (context-receiving context))
+            (reference-lexical-variable info context)))
          (null
           (warn-unknown 'unknown-function :name fnameoid)
-          (emit-fdefinition context (fdefinition-index fnameoid context))))))
+          (unless (eql 0 (context-receiving context))
+            (emit-fdefinition context (fdefinition-index fnameoid context)))))))
     (t (error 'not-fnameoid :fnameoid fnameoid))))
 
 (defmethod compile-special ((op (eql 'function)) form env context)
   (destructure-syntax (function fnameoid) (form)
-    (unless (eql (context-receiving context) 0)
-      (compile-function-lookup fnameoid env context)
-      (when (eql (context-receiving context) t)
-        (assemble context m:pop)))))
+    (compile-function-lookup fnameoid env context)
+    (when (eql (context-receiving context) t)
+      (assemble context m:pop))))
 
 (defun go-tag-p (object) (typep object '(or symbol integer)))
 
@@ -1121,7 +1182,9 @@
     (unless (proper-list-p statements)
       (error 'improper-body :body statements))
     (multiple-value-bind (env stmt-context-1)
-        (bind-vars (list tagbody-dynenv) env context)
+        (bind-vars (list tagbody-dynenv) env context
+                   ;; the dynenv is implicitly ignorable.
+                   `((declare (ignorable ,tagbody-dynenv))))
       (let* ((dynenv-info (var-info tagbody-dynenv env))
              (stmt-context (new-context stmt-context-1
                                         :receiving 0
@@ -1181,7 +1244,8 @@
   (unless (symbolp name) (error 'block-name-not-symbol :name name))
   (let ((block-dynenv (gensym "BLOCK-DYNENV")))
     (multiple-value-bind (env body-context-1)
-        (bind-vars (list block-dynenv) env context)
+        (bind-vars (list block-dynenv) env context
+                   `((declare (ignorable ,block-dynenv))))
       (let* ((dynenv-info (var-info block-dynenv env))
              (body-context (new-context body-context-1
                                         :dynenv (list dynenv-info)))
@@ -1441,8 +1505,10 @@
            ;; This is needed so that we can properly mark any that are special as
            ;; such while leaving them temporarily "lexically" bound during
            ;; argument parsing.
-           (opt-key-indices nil))
-      (setf (values new-env context) (bind-vars required env context))
+           (opt-key-indices nil)
+           ;; A list of lexical infos to check for ignoredness.
+           (igninfos nil))
+      (setf (values new-env context) (bind-vars required env context decls))
       (emit-label context entry-point)
       ;; Generate argument count check.
       (cond ((and required (= min-count max-count) (not more-p))
@@ -1464,7 +1530,9 @@
                    (emit-special-bind context var))
                  (incf special-binding-count))
                 (t
-                 (maybe-emit-encell (var-info var new-env) context))))
+                 (let ((info (var-info var new-env)))
+                   (push info igninfos)
+                   (maybe-emit-encell info context)))))
         (setq new-env (add-specials (intersection specials required) new-env)))
       ;; set the default env to have all the requireds bound,
       ;; but don't put in the optionals (yet).
@@ -1477,15 +1545,16 @@
           ;; Mark the location of each optional. Note that we do this even if
           ;; the variable will be specially bound.
           (setf (values new-env context)
-                (bind-vars optvars new-env context))
+                (bind-vars optvars new-env context decls))
           ;; Add everything to opt-key-indices.
           (dolist (var optvars)
-            (push (cons var (frame-offset (var-info var new-env)))
-                  opt-key-indices))))
+            (let ((info (var-info var new-env)))
+              (push info igninfos)
+              (push (cons var (frame-offset info)) opt-key-indices)))))
       (when rest
         (assemble context m:listify-rest-args max-count)
         (setf (values new-env context)
-              (bind-vars (list rest) new-env context))
+              (bind-vars (list rest) new-env context decls))
         (cond ((or (member rest specials)
                    (globally-special-p rest env))
                (assemble context m:ref (frame-offset (var-info rest new-env)))
@@ -1493,7 +1562,9 @@
                (incf special-binding-count 1)
                (setq new-env (add-specials (list rest) new-env)))
               (t
-               (maybe-emit-encell (var-info rest new-env) context))))
+               (let ((info (var-info rest new-env)))
+                 (push info igninfos)
+                 (maybe-emit-encell info context)))))
       (when key-p
         ;; Generate code to parse the key args. As with optionals, we don't do
         ;; defaulting yet.
@@ -1505,9 +1576,10 @@
             (new-literal-index key-name context)))
         (let ((keyvars (mapcar #'cadar keys)))
           (setf (values new-env context)
-                (bind-vars keyvars new-env context))
+                (bind-vars keyvars new-env context decls))
           (dolist (var keyvars)
             (let ((info (var-info var new-env)))
+              (push info igninfos)
               (push (cons var (frame-offset info)) opt-key-indices)))))
       ;; Generate defaulting code for optional args, and special-bind them
       ;; if necessary.
@@ -1533,7 +1605,7 @@
                                                supplied-var next-optional-label
                                                optional-special-p supplied-special-p
                                                context new-env
-                                               default-env))
+                                               default-env decls))
               ;; set the default env for later bindings.
               (let* ((ovar (cons optional-var
                                  (var-info optional-var new-env)))
@@ -1542,6 +1614,8 @@
                                    (var-info supplied-var new-env))))
                      (newvars
                        (if svar (list svar ovar) (list ovar))))
+                (when supplied-var
+                  (push (cdr svar) igninfos))
                 (setf default-env
                       (make-lexical-environment
                        default-env
@@ -1577,7 +1651,7 @@
                                                supplied-var next-key-label
                                                key-special-p supplied-special-p
                                                context new-env
-                                               default-env))
+                                               default-env decls))
               ;; set the default env for later bindings.
               (let* ((ovar (cons key-var
                                  (var-info key-var new-env)))
@@ -1586,6 +1660,8 @@
                                    (var-info supplied-var new-env))))
                      (newvars
                        (if svar (list svar ovar) (list ovar))))
+                (when supplied-var
+                  (push (cdr svar) igninfos))
                 (setf default-env
                       (make-lexical-environment
                        default-env
@@ -1600,12 +1676,13 @@
                         new-env context :block-name block-name)
           (compile-let* aux `((declare (special ,@specials))) body
                         new-env context))
-      (emit-unbind context special-binding-count))))
+      (emit-unbind context special-binding-count)
+      (warn-ignorance igninfos))))
 
 ;;; Compile an optional/key item and return the resulting environment
 ;;; and context.
 (defun compile-optional/key-item (var defaulting-form var-index supplied-var next-label
-                                  var-specialp supplied-specialp context env default-env)
+                                  var-specialp supplied-specialp context env default-env decls)
   (flet ((default (suppliedp specialp var info)
            (cond (suppliedp
                   (cond (specialp
@@ -1639,7 +1716,7 @@
           (var-info (var-info var env)))
       (when supplied-var
         (setf (values env context)
-              (bind-vars (list supplied-var) env context)))
+              (bind-vars (list supplied-var) env context decls)))
       (let ((supplied-info (var-info supplied-var env)))
         (emit-jump-if-supplied context var-index supplied-label)
         (default nil var-specialp var var-info)
diff --git a/compile/environment.lisp b/compile/environment.lisp
index 218d3bf..f38061a 100644
--- a/compile/environment.lisp
+++ b/compile/environment.lisp
@@ -72,28 +72,31 @@
 
 ;;; Our info for lexical bindings (variable and function).
 (defstruct (lexical-info
-            (:constructor make-lexical-info
-                (frame-offset cfunction)))
+            (:constructor make-lexical-info (frame-offset cfunction)))
   ;; Register index for this lvar.
   (frame-offset (missing-arg) :read-only t :type (integer 0))
   ;; Cfunction this lvar belongs to (i.e. is bound by)
-  (cfunction (missing-arg) :read-only t :type cfunction))
+  (cfunction (missing-arg) :read-only t :type cfunction)
+  ;; Has the variable been read (for cl:ignore tracking).
+  (readp nil :type boolean))
 
 ;;; Our info for specifically variable bindings.
 ;;; (while function bindings can be closed over, they can't be modified,
 ;;;  so we don't really care.)
 (defstruct (lexical-variable-info
-            (:constructor make-lexical-variable-info
-                (frame-offset cfunction))
+            (:constructor make-lexical-variable-info (frame-offset cfunction))
             (:include lexical-info))
   (closed-over-p nil :type boolean)
   (setp nil :type boolean))
 
 (defun frame-offset (lex-desc)
   (lexical-info-frame-offset (trucler:identity lex-desc)))
-
 (defun lvar-cfunction (lex-desc)
   (lexical-info-cfunction (trucler:identity lex-desc)))
+(defun lvar-readp (lex-desc)
+  (lexical-info-readp (trucler:identity lex-desc)))
+(defun (setf lvar-readp) (new lex-desc)
+  (setf (lexical-info-readp (trucler:identity lex-desc)) new))
 
 (defun closed-over-p (lvar-desc)
   (lexical-variable-info-closed-over-p (trucler:identity lvar-desc)))
@@ -112,10 +115,11 @@
 (defun indirect-lexical-p (lvar)
   (and (closed-over-p lvar) (setp lvar)))
 
-(defun make-lexical-variable (name frame-offset cfunction)
+(defun make-lexical-variable (name frame-offset cfunction &key ignore)
   (make-instance 'trucler:lexical-variable-description
     :name name
-    :identity (make-lexical-variable-info frame-offset cfunction)))
+    :identity (make-lexical-variable-info frame-offset cfunction)
+    :ignore ignore))
 
 (defun make-symbol-macro (name expansion)
   (make-instance 'trucler:symbol-macro-description
@@ -124,9 +128,9 @@
 (defun globally-special-p (symbol env)
   (typep (var-info symbol env) 'trucler:global-special-variable-description))
 
-(defun make-local-function (name frame-offset cfunction)
+(defun make-local-function (name frame-offset cfunction &key ignore)
   (make-instance 'trucler:local-function-description
-    :name name
+    :name name :ignore ignore
     :identity (make-lexical-info frame-offset cfunction)))
 
 (defun make-local-macro (name expander)
diff --git a/compile/misc-program-conditions.lisp b/compile/misc-program-conditions.lisp
index fd275c9..52a8996 100644
--- a/compile/misc-program-conditions.lisp
+++ b/compile/misc-program-conditions.lisp
@@ -41,6 +41,29 @@
              (format stream "~s is not a valid variable name"
                      (name condition)))))
 
+(define-condition used (style-warning)
+  ((%name :initarg :name :reader name)
+   (%kind :initarg :kind :reader kind))
+  (:report (lambda (condition stream)
+             (format stream "~:(~a~) ~s was declared ~s, but was still used"
+                     (kind condition) (name condition) 'cl:ignore))))
+
+(define-condition unused (style-warning)
+  ((%name :initarg :name :reader name)
+   (%kind :initarg :kind :reader kind :type (member function variable)))
+  (:report (lambda (condition stream)
+             (format stream "Unused ~(~a~) ~s"
+                     (kind condition) (name condition)))))
+
+(define-condition set-unused (style-warning)
+  ((%name :initarg :name :reader name)
+   ;; In practice local function bindings cannot be modified,
+   ;; so this field is a bit pointless. It's in for symmetry.
+   (%kind :initarg :kind :reader kind :type (member function variable)))
+  (:report (lambda (condition stream)
+             (format stream "~:(~a~) ~s set but not used"
+                     (kind condition) (name condition)))))
+
 (define-condition not-function-name (program-error)
   ((%name :initarg :name :reader name))
   (:report (lambda (condition stream)
diff --git a/maclina.asd b/maclina.asd
index d2f8392..bb328de 100644
--- a/maclina.asd
+++ b/maclina.asd
@@ -119,6 +119,7 @@
                  (:file "cooperation" :depends-on ("suites" "rt" "packages"))
                  (:file "timeout" :depends-on ("suites" "rt" "packages"))
                  (:file "long" :depends-on ("suites" "rt" "packages"))
+                 (:file "ignore" :depends-on ("suites" "rt" "packages"))
                  (:module "compiler-conditions"
                   :depends-on ("suites" "rt" "packages")
                   :components ((:file "reference")
diff --git a/test/ignore.lisp b/test/ignore.lisp
new file mode 100644
index 0000000..4bdc4ba
--- /dev/null
+++ b/test/ignore.lisp
@@ -0,0 +1,103 @@
+(in-package #:maclina.test)
+
+;;;; This file tests more pedantic behavior on IGNORE:
+;;;; that Maclina complains when a variable is unused, and so on.
+;;;; This is not required by the standard so it is not in the ANSI tests.
+
+;;; we use .warn in order to avoid conflict with the ANSI ignore suite.
+(5am:def-suite ignore.warn :in maclina)
+(5am:in-suite ignore.warn)
+
+(defmacro test-style (lambda-expression)
+  `(progn
+     (5am:signals style-warning (ccompile nil ',lambda-expression))
+     (5am:is (not (null (nth-value 1 (ccompile nil ',lambda-expression))))
+             "~s compiled with no warnings" ',lambda-expression)
+     (5am:is (null (nth-value 2 (ccompile nil ',lambda-expression)))
+             "~s compiled with errors" ',lambda-expression)))
+
+(defmacro test-nostyle (lambda-expression)
+  `(progn
+     (5am:is (eql t (handler-case (progn (ccompile nil ',lambda-expression) t)
+                      (style-warning () nil)))
+             "Compiling ~s signaled a style-warning" ',lambda-expression)
+     (5am:is (null (nth-value 1 (ccompile nil ',lambda-expression)))
+             "~s compiled with warnings" ',lambda-expression)
+     (5am:is (null (nth-value 1 (ccompile nil ',lambda-expression)))
+             "~s compiled with errors" ',lambda-expression)))
+
+(5am:test noignore
+  (test-style (lambda (x)))
+  (test-style (lambda (&optional x)))
+  (test-style (lambda (&optional (x nil xp)) x))
+  (test-style (lambda (&rest r)))
+  (test-style (lambda (&key k)))
+  (test-style (lambda (&key (k nil kp)) k))
+  (test-style (lambda () (let ((y 7)))))
+  (test-style (lambda () (let* ((y 7)))))
+  (test-style (lambda () (flet ((foo ())))))
+  (test-style (lambda () (labels ((foo ())))))
+  (test-nostyle (lambda (x) x))
+  (test-nostyle (lambda (&optional x) x))
+  ;; this also tests 0 contexts, which is important as the compiler
+  ;; tends to skip a lot of work there.
+  (test-nostyle (lambda (&optional (x nil xp)) (progn x xp)))
+  (test-nostyle (lambda (&rest r) r))
+  (test-nostyle (lambda (&key k) k))
+  (test-nostyle (lambda (&key (k nil kp)) (progn k kp)))
+  (test-nostyle (lambda () (let ((y 7)) y)))
+  (test-nostyle (lambda () (let* ((y 7)) y)))
+  (test-nostyle (lambda () (flet ((foo ())) (foo))))
+  (test-nostyle (lambda () (flet ((foo ())) #'foo)))
+  (test-nostyle (lambda () (labels ((foo ())) (foo))))
+  (test-nostyle (lambda () (labels ((foo ())) #'foo))))
+
+(5am:test ignore
+  (test-nostyle (lambda (x) (declare (ignore x))))
+  (test-nostyle (lambda (&optional x) (declare (ignore x))))
+  (test-nostyle (lambda (&optional (x nil xp)) (declare (ignore xp)) x))
+  (test-nostyle (lambda (&rest r) (declare (ignore r))))
+  (test-nostyle (lambda (&key k) (declare (ignore k))))
+  (test-nostyle (lambda (&key (k nil kp)) (declare (ignore kp)) k))
+  (test-nostyle (lambda () (let ((y 7)) (declare (ignore y)))))
+  (test-nostyle (lambda () (let* ((y 7)) (declare (ignore y)))))
+  (test-nostyle (lambda () (flet ((foo ())) (declare (ignore #'foo)))))
+  (test-nostyle (lambda () (labels ((foo ())) (declare (ignore #'foo)))))
+  (test-style (lambda (x) (declare (ignore x)) x))
+  (test-style (lambda (&optional x) (declare (ignore x)) x))
+  ;; this also tests 0 contexts, which is important as the compiler
+  ;; tends to skip a lot of work there.
+  (test-style (lambda (&optional (x nil xp)) (declare (ignore x)) (progn x xp)))
+  (test-style (lambda (&rest r) (declare (ignore r)) r))
+  (test-style (lambda (&key k) (declare (ignore k)) k))
+  (test-style (lambda (&key (k nil kp)) (declare (ignore k)) (progn k kp)))
+  (test-style (lambda () (let ((y 7)) (declare (ignore y)) y)))
+  (test-style (lambda () (let* ((y 7)) (declare (ignore y)) y)))
+  (test-style (lambda () (flet ((foo ())) (declare (ignore #'foo)) (foo))))
+  (test-style (lambda () (flet ((foo ())) (declare (ignore #'foo)) #'foo)))
+  (test-style (lambda () (labels ((foo ())) (declare (ignore #'foo)) (foo))))
+  (test-style (lambda () (labels ((foo ())) (declare (ignore #'foo)) #'foo))))
+
+(5am:test ignorable
+  (test-nostyle (lambda (x) (declare (ignorable x))))
+  (test-nostyle (lambda (&optional x) (declare (ignorable x))))
+  (test-nostyle (lambda (&optional (x nil xp)) (declare (ignorable xp)) x))
+  (test-nostyle (lambda (&rest r) (declare (ignorable r))))
+  (test-nostyle (lambda (&key k) (declare (ignorable k))))
+  (test-nostyle (lambda (&key (k nil kp)) (declare (ignorable kp)) k))
+  (test-nostyle (lambda () (let ((y 7)) (declare (ignorable y)))))
+  (test-nostyle (lambda () (let* ((y 7)) (declare (ignorable y)))))
+  (test-nostyle (lambda () (flet ((foo ())) (declare (ignorable #'foo)))))
+  (test-nostyle (lambda () (labels ((foo ())) (declare (ignorable #'foo)))))
+  (test-nostyle (lambda (x) (declare (ignorable x)) x))
+  (test-nostyle (lambda (&optional x) (declare (ignorable x)) x))
+  (test-nostyle (lambda (&optional (x nil xp)) (declare (ignorable x)) (progn x xp)))
+  (test-nostyle (lambda (&rest r) (declare (ignorable r)) r))
+  (test-nostyle (lambda (&key k) (declare (ignorable k)) k))
+  (test-nostyle (lambda (&key (k nil kp)) (declare (ignorable k)) (progn k kp)))
+  (test-nostyle (lambda () (let ((y 7)) (declare (ignorable y)) y)))
+  (test-nostyle (lambda () (let* ((y 7)) (declare (ignorable y)) y)))
+  (test-nostyle (lambda () (flet ((foo ())) (declare (ignorable #'foo)) (foo))))
+  (test-nostyle (lambda () (flet ((foo ())) (declare (ignorable #'foo)) #'foo)))
+  (test-nostyle (lambda () (labels ((foo ())) (declare (ignorable #'foo)) (foo))))
+  (test-nostyle (lambda () (labels ((foo ())) (declare (ignorable #'foo)) #'foo))))

From cbc3346935f16fafb022e650963787505e1e5220 Mon Sep 17 00:00:00 2001
From: Alex Wood <aeshtaer@gmail.com>
Date: Thu, 11 Jul 2024 13:02:46 -0400
Subject: [PATCH 04/11] Source info

Needs tests and needs to work in FASLs, but the basic structure is
in place now.
---
 compile/compile.lisp | 56 +++++++++++++++++++++++++++++++++++------
 compile/package.lisp |  4 ++-
 machine.lisp         |  7 +++++-
 maclina.asd          |  1 +
 map-info.lisp        | 59 ++++++++++++++++++++++++++++++++++++++++++++
 structures.lisp      |  3 ++-
 6 files changed, 119 insertions(+), 11 deletions(-)
 create mode 100644 map-info.lisp

diff --git a/compile/compile.lisp b/compile/compile.lisp
index 52e3a62..344cf17 100644
--- a/compile/compile.lisp
+++ b/compile/compile.lisp
@@ -59,7 +59,9 @@
   ;; For example, a cfunction appearing literally in the code (for whatever
   ;; odd reason) gets a constant-info, distinguishing it from a cfunction
   ;; in the vector which will be linked to an actual function.
-  (literals (make-array 0 :fill-pointer 0 :adjustable t) :read-only t))
+  (literals (make-array 0 :fill-pointer 0 :adjustable t) :read-only t)
+  ;; Each entry in this vector is a map-info.
+  (pc-map (make-array 0 :fill-pointer 0 :adjustable t) :read-only t))
 
 (defstruct (constant-info (:constructor make-constant-info (value)))
   (value (error "missing arg") :read-only t))
@@ -172,6 +174,9 @@
     (or (position info closed)
         (vector-push-extend info closed))))
 
+(defun push-map-info (info context)
+  (vector-push-extend info (cmodule-pc-map (context-module context))))
+
 (defun new-context (parent &key (receiving (context-receiving parent))
                              (dynenv nil) ; prepended
                              (frame-end (context-frame-end parent) fep)
@@ -561,6 +566,19 @@
 (deftype lambda-expression () '(cons (eql lambda) (cons list list)))
 (deftype function-name () '(or symbol (cons (eql setf) (cons symbol null))))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Source locations
+;;;
+
+(defvar *source-locations*)
+
+(defun form-source-location (form &optional default)
+  (if (boundp '*source-locations*)
+      (multiple-value-bind (sl presentp) (gethash form *source-locations*)
+        (if presentp sl default))
+      default))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;
 ;;; Compilation
@@ -609,12 +627,21 @@
   (eval-progn `(,form) environment))
 
 (defun compile-form (form env context)
-  (typecase form
-    (symbol (compile-symbol (var-info form env) form env context))
-    ((cons symbol)
-     (compile-combination (fun-info (car form) env) form env context))
-    (cons (compile-lambda-form form env context))
-    (t (compile-literal form env context))))
+  (let* ((source-location (form-source-location form)) end)
+    (when source-location
+      (setf end (make-label))
+      (let ((start (make-label)))
+        (push-map-info (make-instance 'm:source-info
+                         :start start :end end :source source-location)
+                       context)
+        (emit-label context start)))
+    (typecase form
+      (symbol (compile-symbol (var-info form env) form env context))
+      ((cons symbol)
+       (compile-combination (fun-info (car form) env) form env context))
+      (cons (compile-lambda-form form env context))
+      (t (compile-literal form env context)))
+    (when source-location (emit-label context end))))
 
 (defun compile-literal (form env context)
   (declare (ignore env))
@@ -1924,17 +1951,30 @@
 (defmethod load-literal-info (client (info env-info) env)
   (m:link-environment client (run-time-environment m:*client* env)))
 
+(defgeneric link-map-info (map-info)
+  (:method-combination progn))
+
+(defmethod link-map-info progn ((info m:map-info))
+  (setf (m:start info) (annotation-module-position (m:start info))
+        (m:end info) (annotation-module-position (m:end info))))
+
+(defun link-pc-map (pc-map)
+  ;; Make a non-adjustable vector.
+  (map 'vector (lambda (info) (link-map-info info) info) pc-map))
+
 ;;; Run down the hierarchy and link the compile time representations
 ;;; of modules and functions together into runtime objects.
 (defun link-load (cmodule env)
   (let* ((bytecode (link cmodule))
          (cmodule-literals (cmodule-literals cmodule))
+         (pc-map (cmodule-pc-map cmodule))
          (literal-length (length cmodule-literals))
          (literals (make-array literal-length))
          (bytecode-module
            (m:make-bytecode-module
             :bytecode bytecode
-            :literals literals))
+            :literals literals
+            :pc-map (link-pc-map pc-map)))
          (client m:*client*))
     ;; Create the real function objects.
     (loop for cfunction across (cmodule-cfunctions cmodule)
diff --git a/compile/package.lisp b/compile/package.lisp
index 28a5988..9654cea 100644
--- a/compile/package.lisp
+++ b/compile/package.lisp
@@ -31,4 +31,6 @@
            #:name
            #:unknown-reference-resolution #:resolve-reference
            #:resolve-function #:resolve-macro
-           #:assumed-function-now-macro))
+           #:assumed-function-now-macro)
+  ;; PC map info related stuff
+  (:export #:*source-locations*))
diff --git a/machine.lisp b/machine.lisp
index 3c22562..9a59629 100644
--- a/machine.lisp
+++ b/machine.lisp
@@ -23,7 +23,12 @@
 	   #:fdefinition #:fmakunbound #:fboundp)
   (:export #:lambda-parameters-limit #:call-arguments-limit
            #:lambda-list-keywords #:multiple-values-limit)
-  (:export #:disassemble #:display-instruction))
+  (:export #:disassemble #:display-instruction)
+  ;; PC map stuff
+  (:export #:bytecode-module-pc-map
+           #:map-info #:start #:end
+           #:source-info #:source)
+  (:export #:info-at #:most-specific-info-at #:source-at))
 
 ;;;; Definition of the virtual machine, used by both the compiler and the VM.
 
diff --git a/maclina.asd b/maclina.asd
index bb328de..882c96b 100644
--- a/maclina.asd
+++ b/maclina.asd
@@ -20,6 +20,7 @@
   :components ((:file "machine")
                (:file "arg-conditions")
                (:file "structures" :depends-on ("machine"))
+               (:file "map-info" :depends-on ("structures" "machine"))
                (:file "link" :depends-on ("machine"))
                (:file "access" :depends-on ("machine"))
                (:file "disassemble" :depends-on ("structures" "machine"))))
diff --git a/map-info.lisp b/map-info.lisp
new file mode 100644
index 0000000..8eaffef
--- /dev/null
+++ b/map-info.lisp
@@ -0,0 +1,59 @@
+(in-package #:maclina.machine)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Map infos: Things in the PC map.
+;;; These have a start and end index as well as accessory information.
+;;; They are used for debug information as well as information about the
+;;; original structure of Lisp programs.
+
+;;; The compiler generates infos with a few convenient restrictions:
+;;; 1) Info ranges are nested. That is, if one range intersects another,
+;;;    at least one of the ranges contains the entirety of the other.
+;;; 2) Infos are sorted in the map by start and then by end. That is, iff
+;;;    info1 appears before info2 in the map, either info1's start is < that of
+;;;    info2, or they are = and info1's end is <= that of info2. Infos with
+;;;    the same start and end are ordered indeterminately.
+
+(defclass map-info ()
+  (;; During compilation, these will be labels. The accessors are them used
+   ;; to make them into actual indices. The writers should not be used
+   ;; outside of link-pc-map in the compiler.
+   (%start :initarg :start :accessor start)
+   (%end :initarg :end :accessor end)))
+
+(defclass source-info (map-info)
+  ((%source :initarg :source :reader source)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Convenience accessors
+;;;
+
+;;; Return a list of all infos for the given PC. Most specific infos first.
+(defun info-at (module pc)
+  (loop with result = ()
+        for info across (bytecode-module-pc-map module)
+        until (< pc (start info))
+        when (< pc (end info))
+          do (cl:push info result)
+        finally (cl:return result)))
+
+;;; Get the most specific info matching the predicate, for the given PC.
+(defun most-specific-info-at (module pc predicate)
+  (loop with best = ()
+        for info across (bytecode-module-pc-map module)
+        for end = (end info)
+        until (< pc (start info))
+        when (and (< pc end)
+                  (funcall predicate info)
+                  (or (null best) (< end (end best))))
+          do (setf best info)
+        finally (cl:return info)))
+
+(defun source-at (module pc)
+  (let ((info (most-specific-info-at
+               module pc (lambda (info) (typep info 'source-info)))))
+    (if info
+        (source info)
+        nil)))
diff --git a/structures.lisp b/structures.lisp
index 3bbb114..a0b6e63 100644
--- a/structures.lisp
+++ b/structures.lisp
@@ -4,7 +4,8 @@
 
 (defstruct bytecode-module
   bytecode
-  literals)
+  literals
+  pc-map)
 
 (defclass bytecode-function (closer-mop:funcallable-standard-object)
   ((%module :initarg :module :accessor bytecode-function-module)

From 4ee9af91c01e23baab68aa50ce4a0e4178de8e23 Mon Sep 17 00:00:00 2001
From: Alex Wood <aeshtaer@gmail.com>
Date: Fri, 12 Jul 2024 09:46:35 -0400
Subject: [PATCH 05/11] Add weirdly baroque test for source info

Yuck, but it's something, and helped me fix a few bugs.
---
 maclina.asd      |  1 +
 test/pc-map.lisp | 62 ++++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 63 insertions(+)
 create mode 100644 test/pc-map.lisp

diff --git a/maclina.asd b/maclina.asd
index 882c96b..c795918 100644
--- a/maclina.asd
+++ b/maclina.asd
@@ -120,6 +120,7 @@
                  (:file "cooperation" :depends-on ("suites" "rt" "packages"))
                  (:file "timeout" :depends-on ("suites" "rt" "packages"))
                  (:file "long" :depends-on ("suites" "rt" "packages"))
+                 (:file "pc-map" :depends-on ("suites" "rt" "packages"))
                  (:file "ignore" :depends-on ("suites" "rt" "packages"))
                  (:module "compiler-conditions"
                   :depends-on ("suites" "rt" "packages")
diff --git a/test/pc-map.lisp b/test/pc-map.lisp
new file mode 100644
index 0000000..fcc3dff
--- /dev/null
+++ b/test/pc-map.lisp
@@ -0,0 +1,62 @@
+(in-package #:maclina.test)
+
+;;; Tests of PC-mapped information, like source locations.
+
+(5am:def-suite pc-map :in maclina)
+(5am:in-suite pc-map)
+
+;;; Pending a clean way to get PCs corresponding to executing forms
+;;; (like from backtraces), we basically just test that infos are
+;;; present and properly nested.
+
+(5am:test source
+  (let* ((sources (make-hash-table))
+         (add '(+ x y))
+         (add2 `(+ ,add z)))
+    (setf (gethash add sources) 13 ; arbitrary "source locations"
+          (gethash add2 sources) 9)
+    (let* ((maclina.compile:*source-locations* sources)
+           (f (ccompile nil `(lambda (x y z) ,add2)))
+           (mod (maclina.machine:bytecode-function-module f))
+           (outerp nil) (innerp nil))
+      ;; Weird state machine. We want :before :add2 :add :add2-after :after,
+      ;; except these can be abbreviated (if sources begin or end simultaneously).
+      (loop with state = :before
+            with success = t
+            for pc below (length (maclina.machine:bytecode-module-bytecode mod))
+            for source = (maclina.machine:source-at mod pc)
+            do (case source
+                 ((nil)
+                  (case state
+                    ((:before :after))
+                    ((:add2)
+                     (5am:fail "Missing source info for inner form")
+                     (setf success nil) (loop-finish))
+                    ((:add :add2-after) (setf state :after))))
+                 (9
+                  (setf outerp t)
+                  (case state
+                    ((:before) (setf state :add2))
+                    ((:add2 :add2-after))
+                    ((:add) (setf state :add2-after))
+                    ((:after)
+                     (5am:fail "Source info resumes after ending")
+                     (setf success nil) (loop-finish))))
+                 (13
+                  (setf innerp t)
+                  (case state
+                    ((:before :add2) (setf state :add))
+                    ((:add))
+                    ((:add2-after :after)
+                     (5am:fail "Source info resumes after ending")
+                     (setf success nil) (loop-finish))))
+                 (otherwise
+                  (5am:fail "Unexpected source location ~s" source)
+                  (setf success nil) (loop-finish)))
+            finally (when success (5am:pass)))
+      (if outerp
+          (5am:pass)
+          (5am:fail "Missing source info for outer call"))
+      (if innerp
+          (5am:pass)
+          (5am:fail "Missing source info for inner call")))))

From 497382a46d55ebd38d0705a01422ffd8a2834c4a Mon Sep 17 00:00:00 2001
From: Alex Wood <aeshtaer@gmail.com>
Date: Fri, 12 Jul 2024 12:44:16 -0400
Subject: [PATCH 06/11] Simpler use of 5am

---
 test/pc-map.lisp | 8 ++------
 1 file changed, 2 insertions(+), 6 deletions(-)

diff --git a/test/pc-map.lisp b/test/pc-map.lisp
index fcc3dff..f7f3560 100644
--- a/test/pc-map.lisp
+++ b/test/pc-map.lisp
@@ -54,9 +54,5 @@
                   (5am:fail "Unexpected source location ~s" source)
                   (setf success nil) (loop-finish)))
             finally (when success (5am:pass)))
-      (if outerp
-          (5am:pass)
-          (5am:fail "Missing source info for outer call"))
-      (if innerp
-          (5am:pass)
-          (5am:fail "Missing source info for inner call")))))
+      (5am:is-true outerp "Missing source info for outer call")
+      (5am:is-true innerp "Missing source info for inner call"))))

From 8eb2bd1b592924b01497599bfde147572b7a12cd Mon Sep 17 00:00:00 2001
From: Alex Wood <aeshtaer@gmail.com>
Date: Fri, 12 Jul 2024 13:08:03 -0400
Subject: [PATCH 07/11] Maintain source positions for compiler conditions

Not including syntax problems yet.
---
 compile/compile.lisp                      | 154 +++++++++++++++-------
 compile/conditions.lisp                   |  20 +++
 compile/misc-program-conditions.lisp      |  38 +++---
 compile/package.lisp                      |   1 +
 compile/unknown-reference-conditions.lisp |   9 +-
 maclina.asd                               |   7 +-
 test/compiler-conditions/reference.lisp   |  58 +++++---
 7 files changed, 194 insertions(+), 93 deletions(-)
 create mode 100644 compile/conditions.lisp

diff --git a/compile/compile.lisp b/compile/compile.lisp
index 344cf17..2c3050f 100644
--- a/compile/compile.lisp
+++ b/compile/compile.lisp
@@ -103,7 +103,9 @@
   ;; The next available register index.
   (frame-end 0)
   ;; The cfunction we're compiling.
-  function)
+  function
+  ;; Client-defined source info, or NIL if none.
+  (source nil))
 
 (defun context-module (context)
   (cfunction-cmodule (context-function context)))
@@ -180,14 +182,16 @@
 (defun new-context (parent &key (receiving (context-receiving parent))
                              (dynenv nil) ; prepended
                              (frame-end (context-frame-end parent) fep)
-                             (function (context-function parent)))
+                             (function (context-function parent))
+                             (source (context-source parent)))
   (when fep
     (setf (cfunction-%nlocals function)
           (max (cfunction-%nlocals function) frame-end)))
   (make-context :receiving receiving
                 :dynenv (append dynenv (context-dynenv parent))
                 :frame-end frame-end
-                :function function))
+                :function function
+                :source source))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;
@@ -542,7 +546,8 @@
          (values (make-lexical-environment env :vars new-vars)
                  (new-context context :frame-end frame-end)))
       (when (constantp (first vars) env)
-        (error 'bind-constant :name (first vars))))))
+        (error 'bind-constant
+               :name (first vars) :source (context-source context))))))
 
 ;;; Like the above, but function namespace.
 (defun bind-fvars (funs env context declarations)
@@ -573,7 +578,7 @@
 
 (defvar *source-locations*)
 
-(defun form-source-location (form &optional default)
+(defun expr-source-location (form &optional default)
   (if (boundp '*source-locations*)
       (multiple-value-bind (sl presentp) (gethash form *source-locations*)
         (if presentp sl default))
@@ -627,7 +632,11 @@
   (eval-progn `(,form) environment))
 
 (defun compile-form (form env context)
-  (let* ((source-location (form-source-location form)) end)
+  (let* ((source-location (expr-source-location form))
+         end
+         (context (if source-location
+                      (new-context context :source source-location)
+                      context)))
     (when source-location
       (setf end (make-label))
       (let ((start (make-label)))
@@ -706,7 +715,8 @@
   (declare (ignore form env))
   (setf (lvar-readp info) t)
   (when (eq (trucler:ignore info) 'cl:ignore)
-    (warn 'used :name (trucler:name info) :kind 'variable))
+    (warn 'used :name (trucler:name info) :kind 'variable
+          :source (context-source context)))
   (unless (eql (context-receiving context) 0)
     (cond ((eq (lvar-cfunction info) (context-function context))
            (assemble context m:ref (frame-offset info)))
@@ -731,7 +741,7 @@
       (assemble context m:pop))))
 
 (defmethod compile-symbol ((info null) form env context)
-  (warn-unknown 'unknown-variable :name form)
+  (warn-unknown 'unknown-variable :name form :source (context-source context))
   (unless (eql (context-receiving context) 0)
     (assemble context m:symbol-value (value-cell-index form context))
     (when (eql (context-receiving context) 't)
@@ -763,7 +773,8 @@
     (compile-call (rest form) env context)))
 
 (defmethod compile-combination ((info null) form env context)
-  (warn-unknown 'unknown-function :name (first form))
+  (warn-unknown 'unknown-function
+                :name (first form) :source (context-source context))
   (emit-fdefinition context (fdefinition-index (first form) context))
   (compile-call (rest form) env context))
 
@@ -771,7 +782,8 @@
                                 form env context)
   (setf (lvar-readp info) t)
   (when (eq (trucler:ignore info) 'cl:ignore)
-    (warn 'used :name (trucler:name info) :kind 'function))
+    (warn 'used :name (trucler:name info)
+                :kind 'function :source (context-source context)))
   (reference-lexical-variable info context)
   (compile-call (rest form) env context))
 
@@ -829,18 +841,19 @@
                            (t
                             (compile-form form env body-context)
                             (setq remaining nrem))))
-                   (error 'improper-body :body forms)))))
+                   (error 'improper-body
+                          :body forms :context (context-source context))))))
 
 (defun compile-locally (body env context)
   (multiple-value-bind (body decls) (parse-body body)
     (compile-progn body (add-declarations env decls) context)))
 
-(defun fun-name-block-name (fun-name)
+(defun fun-name-block-name (fun-name &optional source)
   (typecase fun-name
     (symbol fun-name)
     ((cons (eql setf) (cons symbol null)) (second fun-name))
     ;; TODO: Client defined additional function names?
-    (t (error 'not-function-name :name fun-name))))
+    (t (error 'not-function-name :name fun-name :source source))))
 
 (defmethod compile-special ((operator (eql 'progn)) form env context)
   (compile-progn (rest form) env context))
@@ -889,24 +902,29 @@
       (values binding nil)))
 
 ;;; Given a list of lexical infos, warn if any of them are unused.
-(defun warn-ignorance (infos)
+(defun warn-ignorance (infos &optional source)
   (dolist (info infos)
     (when (and (null (trucler:ignore info)) ; not IGNORE or IGNORABLE
                (not (lvar-readp info))) ; not used
       (etypecase info
         (trucler:lexical-variable-description
          (if (setp info)
-             (warn 'set-unused :name (trucler:name info) :kind 'variable)
-             (warn 'unused :name (trucler:name info) :kind 'variable)))
+             (warn 'set-unused :name (trucler:name info)
+                               :kind 'variable :source source)
+             (warn 'unused :name (trucler:name info)
+                           :kind 'variable :source source)))
         (trucler:local-function-description
-         (warn 'unused :name (trucler:name info) :kind 'function))))))
+         (warn 'unused :name (trucler:name info)
+                       :kind 'function :source source))))))
 
 (defmethod compile-special ((operator (eql 'let)) form env context)
   ;; This is really long because we make an environment manually rather
   ;; than use bind-vars, which would be even more awkward and cons more.
   (destructure-syntax (let bindings . body) (form)
     (unless (proper-list-p bindings)
-      (error 'improper-bindings :bindings bindings))
+      (error 'improper-bindings
+             :bindings bindings
+             :source (expr-source-location bindings (context-source context))))
     (multiple-value-bind (body decls) (parse-body body :whole form)
       (let* ((specials (extract-specials decls))
              (frame-start (context-frame-end context))
@@ -927,7 +945,10 @@
           (push (multiple-value-bind (var valf)
                     (canonicalize-binding binding)
                   (unless (symbolp var)
-                    (error 'variable-not-symbol :name var))
+                    (error 'variable-not-symbol
+                           :name var
+                           :source (expr-source-location
+                                    binding (context-source context))))
                   (compile-form valf env valc)
                   (cons var
                         (cond
@@ -978,19 +999,22 @@
           ;; Finally, the actual body.
           (compile-progn body post-binding-env post-binding-context)
           (emit-unbind post-binding-context special-binding-count)
-          (warn-ignorance igninfos))))))
+          (warn-ignorance igninfos (context-source context)))))))
 
 (defun compile-let* (bindings decls body env context
                      &key (block-name nil block-name-p))
   (unless (proper-list-p bindings)
-    (error 'improper-bindings :bindings bindings))
+    (error 'improper-bindings :bindings bindings
+           :source (expr-source-location bindings (context-source context))))
   (let ((special-binding-count 0)
         (specials (extract-specials decls))
         (inner-context context)
         (lexinfos nil))
     (dolist (binding bindings)
       (multiple-value-bind (var valf) (canonicalize-binding binding)
-        (unless (symbolp var) (error 'variable-not-symbol :name var))
+        (unless (symbolp var)
+          (error 'variable-not-symbol :name var
+                 :source (expr-source-location binding (context-source context))))
         (compile-form valf env (new-context inner-context :receiving 1))
         (cond ((or (member var specials) (globally-special-p var env))
                (incf special-binding-count)
@@ -1016,7 +1040,7 @@
           (compile-block block-name body new-env inner-context)
           (compile-progn body new-env inner-context)))
     (emit-unbind context special-binding-count)
-    (warn-ignorance lexinfos)))
+    (warn-ignorance lexinfos (context-source context))))
 
 (defmethod compile-special ((operator (eql 'let*)) form env context)
   (destructure-syntax (let* bindings . body) (form)
@@ -1026,14 +1050,15 @@
 (defmethod compile-special ((operator (eql 'flet)) form env context)
   (destructure-syntax (flet definitions . body) (form)
     (unless (proper-list-p definitions)
-      (error 'improper-bindings :bindings definitions))
+      (error 'improper-bindings :bindings definitions
+             :source (expr-source-location definitions (context-source context))))
     (loop for definition in definitions
           do (destructure-syntax (flet-definition name lambda-list . body)
                  (definition :rest nil)
                (compile-lambda-expression
                 `(lambda ,lambda-list ,@body)
                 env context :name `(flet ,name)
-                :block-name (fun-name-block-name name))))
+                :block-name (fun-name-block-name name (context-source context)))))
     (emit-bind context (length definitions) (context-frame-end context))
     (multiple-value-bind (body decls) (parse-body body)
       (multiple-value-bind (env context)
@@ -1041,15 +1066,19 @@
         (compile-progn body (add-declarations env decls) context)
         (warn-ignorance
          (loop for (name) in definitions
-               collect (fun-info name env)))))))
+               collect (fun-info name env))
+         (context-source context))))))
 
 (defmethod compile-special ((operator (eql 'labels)) form env context)
   (destructure-syntax (labels definitions . body) (form)
     (unless (proper-list-p definitions)
-      (error 'improper-bindings :bindings definitions))
+      (error 'improper-bindings :bindings definitions
+             :source (expr-source-location definitions (context-source context))))
     (mapc (lambda (bind)
             (unless (proper-list-p bind)
-              (error 'improper-arguments :args bind)))
+              (error 'improper-arguments :args bind
+                                         :source (expr-source-location
+                                                  bind (context-source context)))))
           definitions)
     (multiple-value-bind (body decls) (parse-body body)
       (multiple-value-bind (new-env new-context)
@@ -1058,11 +1087,13 @@
                (igninfos nil)
                (closures
                  (loop for definition in definitions
+                       for source = (expr-source-location
+                                     definition (context-source context))
                        for (name fun)
                          = (destructure-syntax
                                (labels-binding name lambda-list . body)
                                (definition :rest nil)
-                             (let ((bname (fun-name-block-name name)))
+                             (let ((bname (fun-name-block-name name source)))
                                (list name
                                      (compile-lambda
                                       lambda-list body new-env module
@@ -1084,7 +1115,7 @@
                   do (reference-lexical-variable var new-context))
             (assemble context m:initialize-closure (cdr closure)))
           (compile-progn body (add-declarations new-env decls) new-context)
-          (warn-ignorance igninfos))))))
+          (warn-ignorance igninfos (context-source context)))))))
 
 (defgeneric compile-setq-1 (info var value-form environment context))
 
@@ -1109,7 +1140,7 @@
   (compile-setq-1-special var valf env context))
 
 (defmethod compile-setq-1 ((info null) var valf env context)
-  (warn-unknown 'unknown-variable :name var)
+  (warn-unknown 'unknown-variable :name var :source (context-source context))
   (compile-setq-1-special var valf env context))
 
 (defmethod compile-setq-1 ((info trucler:lexical-variable-description)
@@ -1134,7 +1165,8 @@
 (defmethod compile-special ((op (eql 'setq)) form env context)
   (let ((pairs (rest form)))
     (unless (proper-list-p pairs)
-      (error 'setq-uneven :remainder pairs))
+      (error 'setq-uneven :remainder pairs
+             :source (context-source context)))
     (if (null pairs)
         (unless (eql (context-receiving context) 0)
           (assemble context m:nil)
@@ -1143,11 +1175,14 @@
         (do ((pairs pairs (cddr pairs)))
             ((endp pairs))
           (unless (and (consp pairs) (consp (cdr pairs)))
-            (error 'setq-uneven :remainder pairs))
+            (error 'setq-uneven :remainder pairs :source (context-source context)))
           (let ((var (car pairs))
                 (valf (cadr pairs))
                 (rest (cddr pairs)))
-            (unless (symbolp var) (error 'variable-not-symbol :name var))
+            (unless (symbolp var)
+              (error 'variable-not-symbol
+                     :name var
+                     :source (expr-source-location var (context-source context))))
             (compile-setq-1 (var-info var env) var valf env
                             (if rest
                                 (new-context context :receiving 0)
@@ -1185,14 +1220,17 @@
          (trucler:local-function-description
           (setf (lvar-readp info) t)
           (when (eq (trucler:ignore info) 'cl:ignore)
-            (warn 'used :name (trucler:name info) :kind 'function))
+            (warn 'used :name (trucler:name info)
+                        :kind 'function :source (context-source context)))
           (unless (eql 0 (context-receiving context))
             (reference-lexical-variable info context)))
          (null
-          (warn-unknown 'unknown-function :name fnameoid)
+          (warn-unknown 'unknown-function
+                        :name fnameoid :source (context-source context))
           (unless (eql 0 (context-receiving context))
             (emit-fdefinition context (fdefinition-index fnameoid context)))))))
-    (t (error 'not-fnameoid :fnameoid fnameoid))))
+    (t (error 'not-fnameoid :fnameoid fnameoid
+                            :source (context-source context)))))
 
 (defmethod compile-special ((op (eql 'function)) form env context)
   (destructure-syntax (function fnameoid) (form)
@@ -1207,7 +1245,7 @@
         (new-tags (tags env))
         (tagbody-dynenv (gensym "TAG-DYNENV")))
     (unless (proper-list-p statements)
-      (error 'improper-body :body statements))
+      (error 'improper-body :body statements :source (context-source context)))
     (multiple-value-bind (env stmt-context-1)
         (bind-vars (list tagbody-dynenv) env context
                    ;; the dynenv is implicitly ignorable.
@@ -1261,14 +1299,16 @@
 
 (defmethod compile-special ((op (eql 'go)) form env context)
   (destructure-syntax (go tag) (form)
-    (unless (go-tag-p tag) (error 'go-tag-not-tag :tag tag))
+    (unless (go-tag-p tag) (error 'go-tag-not-tag
+                                  :tag tag :source (context-source context)))
     (let ((pair (assoc tag (tags env))))
       (if pair
           (compile-exit (cdr pair) context)
-          (error 'no-go :tag tag)))))
+          (error 'no-go :tag tag :source (context-source context))))))
 
 (defun compile-block (name body env context)
-  (unless (symbolp name) (error 'block-name-not-symbol :name name))
+  (unless (symbolp name) (error 'block-name-not-symbol
+                                :name name :source (context-source context)))
   (let ((block-dynenv (gensym "BLOCK-DYNENV")))
     (multiple-value-bind (env body-context-1)
         (bind-vars (list block-dynenv) env context
@@ -1303,12 +1343,14 @@
 
 (defmethod compile-special ((op (eql 'return-from)) form env context)
   (destructure-syntax (return-from name &optional value) (form)
-    (unless (symbolp name) (error 'block-name-not-symbol :name name))
+    (unless (symbolp name) (error 'block-name-not-symbol
+                                  :name name
+                                  :source (context-source context)))
     (compile-form value env (new-context context :receiving t))
     (let ((pair (assoc name (blocks env))))
       (if pair
           (compile-exit (cdr pair) context)
-          (error 'no-return :name name)))))
+          (error 'no-return :name name :source (context-source context))))))
 
 (defmethod compile-special ((op (eql 'catch)) form env context)
   (destructure-syntax (catch tag . body) (form)
@@ -1373,14 +1415,18 @@
 (defmethod compile-special ((op (eql 'symbol-macrolet)) form env context)
   (destructure-syntax (symbol-macrolet bindings . body) (form)
     (unless (proper-list-p bindings)
-      (error 'improper-bindings :bindings bindings))
+      (error 'improper-bindings :bindings bindings
+             :source (expr-source-location bindings (context-source context))))
     (let ((smacros
             (loop for binding in bindings
                   collect (destructure-syntax
                               (symbol-macrolet-binding name expansion)
                               (binding :rest nil)
                             (unless (symbolp name)
-                              (error 'variable-not-symbol :name name))
+                              (error 'variable-not-symbol
+                                     :name name
+                                     :source (expr-source-location
+                                              binding (context-source context))))
                             (cons name (make-symbol-macro name expansion))))))
       (compile-locally body (make-lexical-environment
                              env
@@ -1421,7 +1467,9 @@
 (defmethod compile-special ((op (eql 'macrolet)) form env context)
   (destructure-syntax (macrolet bindings . body) (form)
     (unless (proper-list-p bindings)
-      (error 'improper-bindings :bindings bindings))
+      (error 'improper-bindings
+             :bindings bindings
+             :source (expr-source-location bindings (context-source context))))
     (let ((macros
             (loop with env = (lexenv-for-macrolet env)
                   for binding in bindings
@@ -1484,17 +1532,21 @@
 (defmethod compile-special ((op (eql 'locally)) form env context)
   (compile-locally (rest form) env context))
 
-(defun check-eval-when-situations (situations)
+(defun check-eval-when-situations (situations &optional source)
   (unless (proper-list-p situations)
-    (error 'improper-situations :situations situations))
+    (error 'improper-situations
+           :situations situations
+           :source (expr-source-location situations source)))
   (loop for situation in situations
         unless (member situation '(cl:eval cl:compile cl:load
                                    :execute :compile-toplevel :load-toplevel))
-          do (error 'invalid-eval-when-situation :situation situation)))
+          do (error 'invalid-eval-when-situation
+                    :situation situation
+                    :source (expr-source-location situations source))))
 
 (defmethod compile-special ((op (eql 'eval-when)) form env context)
   (destructure-syntax (eval-when situations . body) (form)
-    (check-eval-when-situations situations)
+    (check-eval-when-situations situations (context-source context))
     (if (or (member 'cl:eval situations) (member :execute situations))
         (compile-progn body env context)
         (compile-literal nil env context))))
@@ -1704,7 +1756,7 @@
           (compile-let* aux `((declare (special ,@specials))) body
                         new-env context))
       (emit-unbind context special-binding-count)
-      (warn-ignorance igninfos))))
+      (warn-ignorance igninfos (context-source context)))))
 
 ;;; Compile an optional/key item and return the resulting environment
 ;;; and context.
diff --git a/compile/conditions.lisp b/compile/conditions.lisp
new file mode 100644
index 0000000..8101bfb
--- /dev/null
+++ b/compile/conditions.lisp
@@ -0,0 +1,20 @@
+(in-package #:maclina.compile)
+
+(define-condition compiler-condition (condition)
+  ((%source :initarg :source :initform nil :reader source)))
+
+(defmethod source ((condition condition)) nil)
+
+(define-condition program-condition (condition) ())
+
+(define-condition compiler-program-error (program-condition program-error
+                                          compiler-condition)
+  ())
+
+(define-condition compiler-program-warning (program-condition warning
+                                            compiler-condition)
+  ())
+
+(define-condition compiler-program-style-warning
+    (program-condition style-warning compiler-condition)
+  ())
diff --git a/compile/misc-program-conditions.lisp b/compile/misc-program-conditions.lisp
index 52a8996..7b6915b 100644
--- a/compile/misc-program-conditions.lisp
+++ b/compile/misc-program-conditions.lisp
@@ -1,61 +1,61 @@
 (in-package #:maclina.compile)
 
-(define-condition bind-constant (program-error)
+(define-condition bind-constant (compiler-program-error)
   ((%name :initarg :name :reader name))
   (:report (lambda (condition stream)
              (format stream "Attempt to bind constant variable ~s"
                      (name condition)))))
 
-(define-condition go-tag-not-tag (program-error)
+(define-condition go-tag-not-tag (compiler-program-error)
   ((%tag :initarg :tag :reader tag))
   (:report (lambda (condition stream)
              (format stream "~s is not a valid ~s tag" (tag condition) 'go))))
 
-(define-condition no-go (program-error)
+(define-condition no-go (compiler-program-error)
   ((%tag :initarg :tag :reader tag))
   (:report (lambda (condition stream)
              (format stream "Attempt to ~s to unknown tag ~s"
                      'go (tag condition)))))
 
-(define-condition block-name-not-symbol (program-error)
+(define-condition block-name-not-symbol (compiler-program-error)
   ((%name :initarg :name :reader name))
   (:report (lambda (condition stream)
              (format stream "~s is not a valid ~s name"
                      (name condition) 'block))))
 
-(define-condition no-return (program-error)
+(define-condition no-return (compiler-program-error)
   ((%name :initarg :name :reader name))
   (:report (lambda (condition stream)
              (format stream "Attempt to ~s unknown block ~s"
                      'return-from (name condition)))))
 
-(define-condition invalid-eval-when-situation (program-error)
+(define-condition invalid-eval-when-situation (compiler-program-error)
   ((%situation :initarg :situation :reader situation))
   (:report (lambda (condition stream)
              (format stream "~s is not a valid ~s situation"
                      (situation condition) 'eval-when))))
 
-(define-condition variable-not-symbol (program-error)
+(define-condition variable-not-symbol (compiler-program-error)
   ((%name :initarg :name :reader name))
   (:report (lambda (condition stream)
              (format stream "~s is not a valid variable name"
                      (name condition)))))
 
-(define-condition used (style-warning)
+(define-condition used (compiler-program-style-warning)
   ((%name :initarg :name :reader name)
    (%kind :initarg :kind :reader kind))
   (:report (lambda (condition stream)
              (format stream "~:(~a~) ~s was declared ~s, but was still used"
                      (kind condition) (name condition) 'cl:ignore))))
 
-(define-condition unused (style-warning)
+(define-condition unused (compiler-program-style-warning)
   ((%name :initarg :name :reader name)
    (%kind :initarg :kind :reader kind :type (member function variable)))
   (:report (lambda (condition stream)
              (format stream "Unused ~(~a~) ~s"
                      (kind condition) (name condition)))))
 
-(define-condition set-unused (style-warning)
+(define-condition set-unused (compiler-program-style-warning)
   ((%name :initarg :name :reader name)
    ;; In practice local function bindings cannot be modified,
    ;; so this field is a bit pointless. It's in for symmetry.
@@ -64,55 +64,55 @@
              (format stream "~:(~a~) ~s set but not used"
                      (kind condition) (name condition)))))
 
-(define-condition not-function-name (program-error)
+(define-condition not-function-name (compiler-program-error)
   ((%name :initarg :name :reader name))
   (:report (lambda (condition stream)
              (format stream "~s is not a valid function name"
                      (name condition)))))
 
-(define-condition not-fnameoid (program-error)
+(define-condition not-fnameoid (compiler-program-error)
   ((%fnameoid :initarg :fnameoid :reader fnameoid))
   (:report (lambda (condition stream)
              (format stream "Parameter to ~s is not a valid function name or lambda expression: ~s"
                      'cl:function (fnameoid condition)))))
 
-(define-condition not-declaration (program-error)
+(define-condition not-declaration (compiler-program-error)
   ((%specifier :initarg :specifier :reader specifier))
   (:report (lambda (condition stream)
              (format stream "~s is not a valid declaration specifier"
                      (specifier condition)))))
 
-(define-condition setq-uneven (program-error)
+(define-condition setq-uneven (compiler-program-error)
   ((%remainder :initarg :remainder :reader remainder))
   (:report (lambda (condition stream)
              (format stream "~s given uneven number of variables and values: ~s"
                      'setq (remainder condition)))))
 
-(define-condition improper-body (program-error)
+(define-condition improper-body (compiler-program-error)
   ((%body :initarg :body :reader body))
   (:report (lambda (condition stream)
              (format stream "Body forms are not a proper list: ~s"
                      (body condition)))))
 
-(define-condition improper-arguments (program-error)
+(define-condition improper-arguments (compiler-program-error)
   ((%args :initarg :args :reader args))
   (:report (lambda (condition stream)
              (format stream "Arguments are not a proper list: ~s"
                      (args condition)))))
 
-(define-condition improper-bindings (program-error)
+(define-condition improper-bindings (compiler-program-error)
   ((%bindings :initarg :bindings :reader bindings))
   (:report (lambda (condition stream)
              (format stream "Bindings are not a proper list: ~s"
                      (bindings condition)))))
 
-(define-condition improper-situations (program-error)
+(define-condition improper-situations (compiler-program-error)
   ((%situations :initarg :situations :reader situations))
   (:report (lambda (condition stream)
              (format stream "~a situations are not a proper list: ~s"
                      'eval-when (situations condition)))))
 
-(define-condition improper-declarations (program-error)
+(define-condition improper-declarations (compiler-program-error)
   ((%declarations :initarg :declarations :reader declarations))
   (:report (lambda (condition stream)
              (format stream "Declarations are not a proper list: ~s"
diff --git a/compile/package.lisp b/compile/package.lisp
index 9654cea..6403b49 100644
--- a/compile/package.lisp
+++ b/compile/package.lisp
@@ -27,6 +27,7 @@
            #:cfunction-lambda-list #:cfunction-lambda-list-p)
   ;; Conditions and compilation unit handling
   (:export #:with-compilation-unit #:with-compilation-results)
+  (:export #:compiler-condition #:source)
   (:export #:unknown-reference #:unknown-variable #:unknown-function
            #:name
            #:unknown-reference-resolution #:resolve-reference
diff --git a/compile/unknown-reference-conditions.lisp b/compile/unknown-reference-conditions.lisp
index 6951815..54f3d87 100644
--- a/compile/unknown-reference-conditions.lisp
+++ b/compile/unknown-reference-conditions.lisp
@@ -10,14 +10,15 @@
 (defun warn-unknown (datum &rest arguments)
   (restart-case (apply #'warn datum arguments) (continue ())))
 
-(define-condition unknown-variable (unknown-reference warning)
+(define-condition unknown-variable (unknown-reference compiler-program-warning)
   ()
   (:report (lambda (condition stream)
              (format stream "Unknown variable ~s: treating as special"
                      (name condition))))
   (:documentation "Condition signaled when the compiler encounters an unknown variable."))
 
-(define-condition unknown-function (unknown-reference style-warning)
+(define-condition unknown-function (unknown-reference
+                                    compiler-program-style-warning)
   ()
   (:report (lambda (condition stream)
              (format stream "Unknown operator ~s: treating as global function"
@@ -41,7 +42,7 @@
 (defmethod resolve-reference ((r1 resolve-function) (r2 unknown-function))
   (equal (name r1) (name r2)))
 
-(define-condition assumed-function-now-macro (warning)
+(define-condition assumed-function-now-macro (compiler-program-warning)
   ((%name :initarg :name :reader name))
   (:report (lambda (condition stream)
              (format stream "Uses of newly noted macro ~s were previously assumed to be function calls"
@@ -53,5 +54,5 @@
   (:documentation "Condition that can be SIGNALed to indicate to a compilation unit that a new macro has been defined, and that previously unknown references to an operator by that name can now be resolved."))
 (defmethod resolve-reference ((r1 resolve-macro) (r2 unknown-function))
   (when (equal (name r1) (name r2))
-    (warn 'assumed-function-now-macro :name (name r1))
+    (warn 'assumed-function-now-macro :name (name r1) :source (source r2))
     t))
diff --git a/maclina.asd b/maclina.asd
index c795918..7c2dad7 100644
--- a/maclina.asd
+++ b/maclina.asd
@@ -34,10 +34,13 @@
   :components
   ((:module "compile"
     :components ((:file "package")
-                 (:file "misc-program-conditions" :depends-on ("package"))
+                 (:file "conditions" :depends-on ("package"))
+                 (:file "misc-program-conditions"
+                  :depends-on ("conditions" "package"))
                  (:file "parse-macro" :depends-on ("misc-program-conditions"
                                                    "package"))
-                 (:file "unknown-reference-conditions" :depends-on ("package"))
+                 (:file "unknown-reference-conditions"
+                  :depends-on ("conditions" "package"))
                  (:file "compilation-unit"
                   :depends-on ("unknown-reference-conditions" "package"))
                  (:file "environment" :depends-on ("package"))
diff --git a/test/compiler-conditions/reference.lisp b/test/compiler-conditions/reference.lisp
index bba01b5..e01b402 100644
--- a/test/compiler-conditions/reference.lisp
+++ b/test/compiler-conditions/reference.lisp
@@ -4,8 +4,11 @@
 (5am:in-suite unknown-reference-conditions)
 
 (5am:test unknown-variable-read
-  (let ((var (make-symbol "UNKNOWN-VARIABLE"))
-        warning)
+  (let* ((var (make-symbol "UNKNOWN-VARIABLE"))
+         (form `(progn ,var))
+         (maclina.compile:*source-locations* (make-hash-table))
+         warning)
+    (setf (gethash form maclina.compile:*source-locations*) 37)
     (multiple-value-bind (fun warningsp failurep)
         (handler-bind
             ((maclina.compile:unknown-variable
@@ -13,12 +16,14 @@
                  (setq warning w)
                  ;; Make sure we still fail with a MUFFLE-WARNING.
                  (muffle-warning w))))
-          (ccompile nil `(lambda () ,var)))
+          (ccompile nil `(lambda () ,form)))
       (5am:is-true warningsp "COMPILE did not report a warning")
       (5am:is-true failurep "COMPILE did not fail")
       (5am:is-true warning "COMPILE did not signal a warning")
       (5am:is (eql var (maclina.compile:name warning))
               "COMPILE's warning did not have the correct name")
+      (5am:is (eql 37 (maclina.compile:source warning))
+              "COMPILE's warning did not have a source location")
       (5am:signals unbound-variable (funcall fun))
       ;; Now make sure it was assumed to be a special variable.
       (handler-case
@@ -30,18 +35,23 @@
           (5am:fail "Unknown variable was not assumed to be special"))))))
 
 (5am:test unknown-variable-write
-  (let ((var (make-symbol "UNKNOWN-VARIABLE"))
-        warning)
+  (let* ((var (make-symbol "UNKNOWN-VARIABLE"))
+         (form `(setq ,var val))
+         (maclina.compile:*source-locations* (make-hash-table))
+         warning)
+    (setf (gethash form maclina.compile:*source-locations*) 92)
     (multiple-value-bind (fun warningsp failurep)
         (handler-bind
             ((maclina.compile:unknown-variable
                (lambda (w) (setq warning w) (muffle-warning w))))
-          (ccompile nil `(lambda (val) (setq ,var val))))
+          (ccompile nil `(lambda (val) ,form)))
       (5am:is-true warningsp "COMPILE did not report a warning")
       (5am:is-true failurep "COMPILE did not fail")
       (5am:is-true warning "COMPILE did not signal a warning")
       (5am:is (eql var (maclina.compile:name warning))
               "COMPILE's warning did not have the correct name")
+      (5am:is (eql 92 (maclina.compile:source warning))
+              "COMPILE's warning did not have a source location")
       (handler-case
           (let ((val (ceval `(let ((,var 71))
                                (declare (special ,var))
@@ -52,17 +62,22 @@
           (5am:fail "Unknown variable was not assumed to be special"))))))
 
 (5am:test unknown-function
-  (let ((fname (make-symbol "UNKNOWN-FUNCTION")) warning)
+  (let* ((fname (make-symbol "UNKNOWN-FUNCTION")) warning
+         (form `(,fname))
+         (maclina.compile:*source-locations* (make-hash-table)))
+    (setf (gethash form maclina.compile:*source-locations*) 81)
     (multiple-value-bind (fun warningsp failurep)
         (handler-bind
             ((maclina.compile:unknown-function
                (lambda (w) (setq warning w) (muffle-warning w))))
-          (ccompile nil `(lambda () (,fname))))
+          (ccompile nil `(lambda () ,form)))
       (5am:is-true warningsp "COMPILE did not report a warning")
       (5am:is-false failurep "COMPILE failed")
       (5am:is-true warning "COMPILE did not signal a warning")
       (5am:is (eql fname (maclina.compile:name warning))
               "COMPILE's warning did not have the correct name")
+      (5am:is (eql 81 (maclina.compile:source warning))
+              "COMPILE's warning did not have a source location")
       (5am:signals undefined-function (funcall fun)))))
 
 (5am:test resolve-unknown-function
@@ -81,13 +96,22 @@
                   "Unknown function resolution failed: ~s signaled" warning)))
 
 (5am:test resolve-unknown-macro
-  (5am:signals
-      maclina.compile:assumed-function-now-macro
+  (let* ((mname (make-symbol "UNKNOWN-MACRO"))
+         (form `(,mname))
+         (maclina.compile:*source-locations* (make-hash-table))
+         warning)
+    (setf (gethash form maclina.compile:*source-locations*) 20)
+    (handler-bind
+        ((warning (lambda (w) (setq warning w) (muffle-warning w))))
       (maclina.compile:with-compilation-unit (:override t)
-        (let ((mname (make-symbol "UNKNOWN-MACRO")))
-          (multiple-value-bind (_ warningsp failurep)
-              (ccompile nil `(lambda () (,mname)))
-            (declare (ignore _))
-            (5am:is-false warningsp "COMPILE reported warning too early")
-            (5am:is-false failurep "COMPILE reported failure too early"))
-          (signal 'maclina.compile:resolve-macro :name mname)))))
+        (multiple-value-bind (_ warningsp failurep)
+            (ccompile nil `(lambda () ,form))
+          (declare (ignore _))
+          (5am:is-false warningsp "COMPILE reported warning too early")
+          (5am:is-false failurep "COMPILE reported failure too early"))
+        (signal 'maclina.compile:resolve-macro :name mname)))
+    (5am:is-true (typep warning 'maclina.compile:assumed-function-now-macro)
+                 "WITH-COMPILATION-UNIT did not signal an ~s warning"
+                 'maclina.compile:assumed-function-now-macro)
+    (5am:is (eql 20 (maclina.compile:source warning))
+            "WITH-COMPILATION-UNIT's warning did not have a source location")))

From 23a69ebc6fc75619f415a64aa2e585906e3761e2 Mon Sep 17 00:00:00 2001
From: Alex Wood <aeshtaer@gmail.com>
Date: Fri, 12 Jul 2024 14:15:12 -0400
Subject: [PATCH 08/11] Attach source locations to most syntax errors

---
 compile/compile.lisp                 | 86 ++++++++++++++++++----------
 compile/misc-program-conditions.lisp | 21 +++++++
 compile/parse-macro.lisp             | 25 ++++----
 test/compiler-conditions/syntax.lisp | 21 +++++--
 4 files changed, 108 insertions(+), 45 deletions(-)

diff --git a/compile/compile.lisp b/compile/compile.lisp
index 2c3050f..2023393 100644
--- a/compile/compile.lisp
+++ b/compile/compile.lisp
@@ -842,7 +842,7 @@
                             (compile-form form env body-context)
                             (setq remaining nrem))))
                    (error 'improper-body
-                          :body forms :context (context-source context))))))
+                          :body forms :source (context-source context))))))
 
 (defun compile-locally (body env context)
   (multiple-value-bind (body decls) (parse-body body)
@@ -895,9 +895,9 @@
 (defun add-declarations (env declarations)
   (add-specials (extract-specials declarations) env))
 
-(defun canonicalize-binding (binding)
+(defun canonicalize-binding (binding &optional source)
   (if (consp binding)
-      (destructure-syntax (binding name value) (binding :rest nil)
+      (destructure-syntax (binding name value) (binding :rest nil :source source)
         (values name value))
       (values binding nil)))
 
@@ -920,7 +920,7 @@
 (defmethod compile-special ((operator (eql 'let)) form env context)
   ;; This is really long because we make an environment manually rather
   ;; than use bind-vars, which would be even more awkward and cons more.
-  (destructure-syntax (let bindings . body) (form)
+  (destructure-syntax (let bindings . body) (form :source (context-source context))
     (unless (proper-list-p bindings)
       (error 'improper-bindings
              :bindings bindings
@@ -943,7 +943,9 @@
         ;; We collect conses (name . info).
         (dolist (binding bindings)
           (push (multiple-value-bind (var valf)
-                    (canonicalize-binding binding)
+                    (canonicalize-binding binding
+                                          (expr-source-location
+                                           binding (context-source context)))
                   (unless (symbolp var)
                     (error 'variable-not-symbol
                            :name var
@@ -1011,7 +1013,9 @@
         (inner-context context)
         (lexinfos nil))
     (dolist (binding bindings)
-      (multiple-value-bind (var valf) (canonicalize-binding binding)
+      (multiple-value-bind (var valf)
+          (canonicalize-binding
+           binding (expr-source-location binding (context-source context)))
         (unless (symbolp var)
           (error 'variable-not-symbol :name var
                  :source (expr-source-location binding (context-source context))))
@@ -1043,18 +1047,21 @@
     (warn-ignorance lexinfos (context-source context))))
 
 (defmethod compile-special ((operator (eql 'let*)) form env context)
-  (destructure-syntax (let* bindings . body) (form)
+  (destructure-syntax (let* bindings . body)
+      (form :source (context-source context))
     (multiple-value-bind (body decls) (parse-body body)
       (compile-let* bindings decls body env context))))
 
 (defmethod compile-special ((operator (eql 'flet)) form env context)
-  (destructure-syntax (flet definitions . body) (form)
+  (destructure-syntax (flet definitions . body)
+      (form :source (context-source context))
     (unless (proper-list-p definitions)
       (error 'improper-bindings :bindings definitions
              :source (expr-source-location definitions (context-source context))))
     (loop for definition in definitions
+          for source = (expr-source-location definition (context-source context))
           do (destructure-syntax (flet-definition name lambda-list . body)
-                 (definition :rest nil)
+                 (definition :rest nil :source source)
                (compile-lambda-expression
                 `(lambda ,lambda-list ,@body)
                 env context :name `(flet ,name)
@@ -1070,7 +1077,8 @@
          (context-source context))))))
 
 (defmethod compile-special ((operator (eql 'labels)) form env context)
-  (destructure-syntax (labels definitions . body) (form)
+  (destructure-syntax (labels definitions . body)
+      (form :source (context-source context))
     (unless (proper-list-p definitions)
       (error 'improper-bindings :bindings definitions
              :source (expr-source-location definitions (context-source context))))
@@ -1092,7 +1100,7 @@
                        for (name fun)
                          = (destructure-syntax
                                (labels-binding name lambda-list . body)
-                               (definition :rest nil)
+                               (definition :rest nil :source source)
                              (let ((bname (fun-name-block-name name source)))
                                (list name
                                      (compile-lambda
@@ -1189,7 +1197,8 @@
                                 context)))))))
 
 (defmethod compile-special ((op (eql 'if)) form env context)
-  (destructure-syntax (if condition then &optional else) (form)
+  (destructure-syntax (if condition then &optional else)
+      (form :source (context-source context))
     (compile-form condition env (new-context context :receiving 1))
     (let ((then-label (make-label))
           (done-label (make-label)))
@@ -1233,7 +1242,8 @@
                             :source (context-source context)))))
 
 (defmethod compile-special ((op (eql 'function)) form env context)
-  (destructure-syntax (function fnameoid) (form)
+  (destructure-syntax (function fnameoid)
+      (form :source (context-source context))
     (compile-function-lookup fnameoid env context)
     (when (eql (context-receiving context) t)
       (assemble context m:pop))))
@@ -1298,7 +1308,7 @@
            (emit-exit context label)))))
 
 (defmethod compile-special ((op (eql 'go)) form env context)
-  (destructure-syntax (go tag) (form)
+  (destructure-syntax (go tag) (form :source (context-source context))
     (unless (go-tag-p tag) (error 'go-tag-not-tag
                                   :tag tag :source (context-source context)))
     (let ((pair (assoc tag (tags env))))
@@ -1338,11 +1348,12 @@
         (maybe-emit-entry-close context dynenv-info)))))
 
 (defmethod compile-special ((op (eql 'block)) form env context)
-  (destructure-syntax (block name . body) (form)
+  (destructure-syntax (block name . body) (form :source (context-source context))
     (compile-block name body env context)))
 
 (defmethod compile-special ((op (eql 'return-from)) form env context)
-  (destructure-syntax (return-from name &optional value) (form)
+  (destructure-syntax (return-from name &optional value)
+      (form :source (context-source context))
     (unless (symbolp name) (error 'block-name-not-symbol
                                   :name name
                                   :source (context-source context)))
@@ -1353,7 +1364,7 @@
           (error 'no-return :name name :source (context-source context))))))
 
 (defmethod compile-special ((op (eql 'catch)) form env context)
-  (destructure-syntax (catch tag . body) (form)
+  (destructure-syntax (catch tag . body) (form :source (context-source context))
     (let ((target (make-label)))
       (compile-form tag env (new-context context :receiving 1))
       (emit-catch context target)
@@ -1362,13 +1373,14 @@
       (emit-label context target))))
 
 (defmethod compile-special ((op (eql 'throw)) form env context)
-  (destructure-syntax (throw tag result) (form)
+  (destructure-syntax (throw tag result) (form :source (context-source context))
     (compile-form tag env (new-context context :receiving 1))
     (compile-form result env (new-context context :receiving t))
     (assemble context m:throw)))
 
 (defmethod compile-special ((op (eql 'progv)) form env context)
-  (destructure-syntax (progv symbols values . body) (form)
+  (destructure-syntax (progv symbols values . body)
+      (form :source (context-source context))
     (compile-form symbols env (new-context context :receiving 1))
     (compile-form values env (new-context context :receiving 1))
     (assemble context m:progv (env-index context))
@@ -1377,7 +1389,8 @@
 
 (defmethod compile-special ((op (eql 'unwind-protect))
                             form env context)
-  (destructure-syntax (unwind-protect protected . cleanup) (form)
+  (destructure-syntax (unwind-protect protected . cleanup)
+      (form :source (context-source context))
     ;; Build a cleanup thunk.
     ;; The 0 is a dumb KLUDGE to let the cleanup forms be compiled in
     ;; non-values contexts, which might be more efficient.
@@ -1392,11 +1405,12 @@
     (assemble context m:cleanup)))
 
 (defmethod compile-special ((op (eql 'quote)) form env context)
-  (destructure-syntax (quote thing) (form)
+  (destructure-syntax (quote thing) (form :source (context-source context))
     (compile-literal thing env context)))
 
 (defmethod compile-special ((op (eql 'load-time-value)) form env context)
-  (destructure-syntax (load-time-value form &optional read-only-p) (form)
+  (destructure-syntax (load-time-value form &optional read-only-p)
+      (form :source (context-source context))
     (check-type read-only-p boolean)
     ;; Stick info about the LTV into the literals vector. It will be handled
     ;; later by COMPILE or a file compiler.
@@ -1413,15 +1427,18 @@
          (assemble context m:pop))))))
 
 (defmethod compile-special ((op (eql 'symbol-macrolet)) form env context)
-  (destructure-syntax (symbol-macrolet bindings . body) (form)
+  (destructure-syntax (symbol-macrolet bindings . body)
+      (form :source (context-source context))
     (unless (proper-list-p bindings)
       (error 'improper-bindings :bindings bindings
              :source (expr-source-location bindings (context-source context))))
     (let ((smacros
             (loop for binding in bindings
+                  for source
+                    = (expr-source-location binding (context-source context))
                   collect (destructure-syntax
                               (symbol-macrolet-binding name expansion)
-                              (binding :rest nil)
+                              (binding :rest nil :source source)
                             (unless (symbolp name)
                               (error 'variable-not-symbol
                                      :name name
@@ -1465,7 +1482,8 @@
                                  (apply #'compile-link lexpr env keys)))))
 
 (defmethod compile-special ((op (eql 'macrolet)) form env context)
-  (destructure-syntax (macrolet bindings . body) (form)
+  (destructure-syntax (macrolet bindings . body)
+      (form :source (context-source context))
     (unless (proper-list-p bindings)
       (error 'improper-bindings
              :bindings bindings
@@ -1473,9 +1491,14 @@
     (let ((macros
             (loop with env = (lexenv-for-macrolet env)
                   for binding in bindings
+                  for source = (expr-source-location
+                                binding (context-source context))
                   collect (destructure-syntax
                               (macrolet-binding name lambda-list . body)
-                              (binding :rest nil)
+                              (binding :rest nil :source source)
+                            (unless (symbolp name)
+                              (error 'macro-not-symbol
+                                     :name name :source source))
                             (let* ((macrof (compute-macroexpander
                                             name lambda-list body env))
                                    (info (make-local-macro name macrof)))
@@ -1505,7 +1528,8 @@
      (assemble context m:fdesignator (env-index context)))))
 
 (defmethod compile-special ((op (eql 'multiple-value-call)) form env context)
-  (destructure-syntax (multiple-value-call function-form . forms) (form)
+  (destructure-syntax (multiple-value-call function-form . forms)
+      (form :source (context-source context))
     (compile-fdesignator function-form env context)
     (if forms
         (let ((first (first forms))
@@ -1520,7 +1544,8 @@
         (emit-call context 0))))
 
 (defmethod compile-special ((op (eql 'multiple-value-prog1)) form env context)
-  (destructure-syntax (multiple-value-prog1 first-form . forms) (form)
+  (destructure-syntax (multiple-value-prog1 first-form . forms)
+      (form :source (context-source context))
     (compile-form first-form env context)
     (unless (member (context-receiving context) '(0 1))
       (assemble context m:push-values))
@@ -1545,7 +1570,8 @@
                     :source (expr-source-location situations source))))
 
 (defmethod compile-special ((op (eql 'eval-when)) form env context)
-  (destructure-syntax (eval-when situations . body) (form)
+  (destructure-syntax (eval-when situations . body)
+      (form :source (context-source context))
     (check-eval-when-situations situations (context-source context))
     (if (or (member 'cl:eval situations) (member :execute situations))
         (compile-progn body env context)
@@ -1553,7 +1579,7 @@
 
 (defmethod compile-special ((op (eql 'the)) form env context)
   ;; ignore
-  (destructure-syntax (the type form) (form)
+  (destructure-syntax (the type form) (form :source (context-source context))
     (declare (ignore type))
     (compile-form form env context)))
 
diff --git a/compile/misc-program-conditions.lisp b/compile/misc-program-conditions.lisp
index 7b6915b..1d7d5a3 100644
--- a/compile/misc-program-conditions.lisp
+++ b/compile/misc-program-conditions.lisp
@@ -41,6 +41,14 @@
              (format stream "~s is not a valid variable name"
                      (name condition)))))
 
+;;; CLHS says macrolet names are function names, but a (setf foo) name
+;;; for a macro is meaningless. DEFMACRO only accepts symbols.
+(define-condition macro-not-symbol (compiler-program-error)
+  ((%name :initarg :name :reader name))
+  (:report (lambda (condition stream)
+             (format stream "~s is not a valid macro name"
+                     (name condition)))))
+
 (define-condition used (compiler-program-style-warning)
   ((%name :initarg :name :reader name)
    (%kind :initarg :kind :reader kind))
@@ -118,6 +126,19 @@
              (format stream "Declarations are not a proper list: ~s"
                      (declarations condition)))))
 
+;;; Used at compile time, so they are program-conditions
+;;; and have a SOURCE slot.
+(define-condition wrong-number-of-arguments (compiler-program-error
+                                             arg:wrong-number-of-arguments)
+  ())
+
+(define-condition odd-keywords (compiler-program-error arg:odd-keywords)
+  ())
+
+(define-condition unrecognized-keyword-argument (compiler-program-error
+                                                 arg:unrecognized-keyword-argument)
+  ())
+
 ;;; from cleavir
 (defun proper-list-p (object)
   (typecase object
diff --git a/compile/parse-macro.lisp b/compile/parse-macro.lisp
index ff0c516..5857d09 100644
--- a/compile/parse-macro.lisp
+++ b/compile/parse-macro.lisp
@@ -21,7 +21,7 @@ We also reuse this machinery to bind subexpressions of forms in the compiler. Se
 ;;; 4) a list of parameters for the cross function
 (defun process-lambda-list (lambda-list compiler environment
                             target etarget toplevelp
-                            &optional arguments parameters)
+                            &key arguments parameters source)
   (let* ((bindings nil) (ignorables nil)
          (arguments arguments) (parameters parameters)
          (whole (ecclesia:whole lambda-list))
@@ -59,7 +59,9 @@ We also reuse this machinery to bind subexpressions of forms in the compiler. Se
                  (process-lambda-list sub-lambda-list
                                       compiler environment
                                       targ etarget nil
-                                      arguments parameters)
+                                      :source source
+                                      :arguments arguments
+                                      :parameters parameters)
                (setf bindings (append (reverse %binds) bindings)
                      ignorables (append %ign ignorables)
                      arguments (reverse %args)
@@ -106,7 +108,8 @@ We also reuse this machinery to bind subexpressions of forms in the compiler. Se
       ;; Argument propriety
       (let ((propriety (gensym "CHECK-PROPRIETY")))
         (push `(,propriety (unless (proper-list-p ,target)
-                             (error 'improper-arguments :args ,target)))
+                             (error 'improper-arguments :args ,target
+                                                        :source ,source)))
               bindings)
         (push propriety ignorables))
       ;; Argument count
@@ -118,7 +121,8 @@ We also reuse this machinery to bind subexpressions of forms in the compiler. Se
         (let ((s (gensym "ARGCOUNT-CHECK")))
           (push `(,s
                   (unless (<= ,nreq ,nargs ,@(when nmax `(,nmax)))
-                    (error 'arg:wrong-number-of-arguments
+                    (error 'wrong-number-of-arguments
+                           :source ,source
                            :given-nargs ,nargs
                            :min-nargs ,nreq
                            ,@(when nmax `(:max-nargs ,nmax)))))
@@ -127,7 +131,7 @@ We also reuse this machinery to bind subexpressions of forms in the compiler. Se
       (when keysp
         (let ((s (gensym "EVEN-KEYS-CHECK")))
           (push `(,s (unless (evenp (- ,nargs ,(+ nreq nopt)))
-                       (error 'arg:odd-keywords)))
+                       (error 'odd-keywords :source ,source)))
                 bindings)
           (push s ignorables)))
       ;; Required parameters
@@ -152,7 +156,7 @@ We also reuse this machinery to bind subexpressions of forms in the compiler. Se
             (let ((key-check (gensym "UNKNOWN-KEYS-CHECK"))
                   (valid-keys (mapcar #'caar keys)))
               (push `(,key-check
-                      (check-keywords ',valid-keys ,keytarg))
+                      (check-keywords ',valid-keys ,keytarg ,source))
                     bindings)
               (push key-check ignorables)))
           ;; Bind keys
@@ -173,7 +177,7 @@ We also reuse this machinery to bind subexpressions of forms in the compiler. Se
 ;;; This function is only called when &allow-other-keys is
 ;;; not present.
 ;;; Return value undefined.
-(defun check-keywords (valid-keys plist)
+(defun check-keywords (valid-keys plist &optional source)
   (loop with seen-aok = nil ; see 3.4.1.4.1.1
         for (key val) on plist by #'cddr
         when (and (not seen-aok) (eq key :allow-other-keys))
@@ -186,7 +190,8 @@ We also reuse this machinery to bind subexpressions of forms in the compiler. Se
                    (eq key :allow-other-keys)) ; always valid
           collect key into unknown-keys
         finally (when unknown-keys
-                  (error 'arg:unrecognized-keyword-argument
+                  (error 'unrecognized-keyword-argument
+                         :source source
                          :unrecognized-keywords unknown-keys))))
 
 ;;; Check if a keyword is in the plist. The plist is valid and has
@@ -216,7 +221,7 @@ We also reuse this machinery to bind subexpressions of forms in the compiler. Se
            (declare (ignorable ,@ignorables))
            (funcall ,bodyf ,@arguments))))))
 
-(defmacro destructure-syntax ((op &rest lambda-list) (form &key (rest t))
+(defmacro destructure-syntax ((op &rest lambda-list) (form &key (rest t) source)
                               &body body)
   (declare (ignore op))
   (alexandria:once-only (form)
@@ -229,7 +234,7 @@ We also reuse this machinery to bind subexpressions of forms in the compiler. Se
            (declare (ignore env block-name))
            (assert (not block-name-p))
            lexpr)
-         nil form nil rest)
+         nil form nil rest :source source)
       `(let* (,@bindings
               ,@(mapcar #'list parameters arguments))
          (declare (ignorable ,@ignorables))
diff --git a/test/compiler-conditions/syntax.lisp b/test/compiler-conditions/syntax.lisp
index 23d07ca..635a8c3 100644
--- a/test/compiler-conditions/syntax.lisp
+++ b/test/compiler-conditions/syntax.lisp
@@ -7,19 +7,25 @@
 ;;; These tests are not ANSI-required, because in ANSI CL the effects of running
 ;;; invalid code are often undefined. But we want to define them as failures.
 
-(defun compilation-fails (form)
+(defun compilation-fails (form source)
   ;; Allow either ccompile signaling an error, or returning a failure indication.
   (nth-value 2 (handler-case (ccompile nil `(lambda () ,form))
                  (error (e)
                    ;; if we do get an error, make sure it's a PROGRAM-ERROR.
                    (5am:is-true (typep e 'program-error)
                                 "on form ~s, compiler signaled ~s and not a program error" form e)
+                   (5am:is (eql source (maclina.compile:source e))
+                           "on form ~s, compiler error had incorrect source location ~s"
+                           form (maclina.compile:source e))
                    (values nil t t)))))
 
 (5am:test special-form-syntax
   (flet ((f (form)
-           (5am:is-true (compilation-fails form)
-                        "Compilation of ~s did not fail" form)))
+           (let ((source (make-symbol "SOURCE"))
+                 (maclina.compile:*source-locations* (make-hash-table)))
+             (setf (gethash form maclina.compile:*source-locations*) source)
+             (5am:is-true (compilation-fails form source)
+                          "Compilation of ~s did not fail" form))))
     (mapc #'f
           '((block) (block . 2) (block nil . 3) (block 4)
             (catch) (catch . 5) (catch nil . 6)
@@ -65,5 +71,10 @@
 (5am:test unknown-exit
   ;; these must fail immediately, unlike unknown references, since they
   ;; cannot be resolved
-  (compilation-fails '(return-from a))
-  (compilation-fails '(go a)))
+  (let ((form1 '(return-from a)) (form2 '(go a))
+        (source (make-symbol "SOURCE"))
+        (maclina.compile:*source-locations* (make-hash-table)))
+    (setf (gethash form1 maclina.compile:*source-locations*) source
+          (gethash form2 maclina.compile:*source-locations*) source)
+    (compilation-fails form1 source)
+    (compilation-fails form2 source)))

From caba9d121385f9b0d72a1778a635aadbf0c4a37e Mon Sep 17 00:00:00 2001
From: Alex Wood <aeshtaer@gmail.com>
Date: Mon, 15 Jul 2024 12:59:58 -0400
Subject: [PATCH 09/11] source info for declaration parsing errors

---
 compile/compile.lisp                 | 42 +++++++++++++++++++---------
 compile/misc-program-conditions.lisp |  9 +++---
 2 files changed, 34 insertions(+), 17 deletions(-)

diff --git a/compile/compile.lisp b/compile/compile.lisp
index 2023393..1e41597 100644
--- a/compile/compile.lisp
+++ b/compile/compile.lisp
@@ -845,7 +845,9 @@
                           :body forms :source (context-source context))))))
 
 (defun compile-locally (body env context)
-  (multiple-value-bind (body decls) (parse-body body)
+  (multiple-value-bind (body decls)
+      (parse-body body :source (context-source context))
+    (check-declarations decls (context-source context))
     (compile-progn body (add-declarations env decls) context)))
 
 (defun fun-name-block-name (fun-name &optional source)
@@ -875,19 +877,23 @@
         env
         (make-lexical-environment env :vars new-vars))))
 
-(defun extract-specials (declarations)
+;; Check syntactic validity of declarations. Limited at the moment.
+(defun check-declarations (declarations &optional source)
   (unless (proper-list-p declarations)
-    (error 'improper-declarations :declarations declarations))
+    (error 'improper-declarations :declarations declarations :source source))
+  (dolist (declaration declarations)
+    (unless (proper-list-p declaration)
+      (error 'improper-declarations :declarations declaration :source source))
+    (dolist (specifier (cdr declaration))
+      (unless (and (consp specifier) (proper-list-p specifier))
+        (error 'not-declaration :specifier specifier :source source)))))
+
+(defun extract-specials (declarations)
   (let ((specials '()))
     (dolist (declaration declarations)
-      (unless (proper-list-p declaration)
-        (error 'improper-declarations :declarations declaration))
       (dolist (specifier (cdr declaration))
-        (unless (consp specifier) (error 'not-declaration :specifier specifier))
         (case (first specifier)
           (special
-           (unless (proper-list-p specifier)
-             (error 'not-declaration :specifier specifier))
            (dolist (var (rest specifier))
              (push var specials))))))
     specials))
@@ -925,7 +931,9 @@
       (error 'improper-bindings
              :bindings bindings
              :source (expr-source-location bindings (context-source context))))
-    (multiple-value-bind (body decls) (parse-body body :whole form)
+    (multiple-value-bind (body decls)
+        (parse-body body :whole form :source (context-source context))
+      (check-declarations decls (context-source context))
       (let* ((specials (extract-specials decls))
              (frame-start (context-frame-end context))
              ;; This will be built up as we process the bindings, and then
@@ -1008,6 +1016,7 @@
   (unless (proper-list-p bindings)
     (error 'improper-bindings :bindings bindings
            :source (expr-source-location bindings (context-source context))))
+  (check-declarations decls)
   (let ((special-binding-count 0)
         (specials (extract-specials decls))
         (inner-context context)
@@ -1049,7 +1058,9 @@
 (defmethod compile-special ((operator (eql 'let*)) form env context)
   (destructure-syntax (let* bindings . body)
       (form :source (context-source context))
-    (multiple-value-bind (body decls) (parse-body body)
+    (multiple-value-bind (body decls)
+        (parse-body body :source (context-source context))
+      (check-declarations decls (context-source context))
       (compile-let* bindings decls body env context))))
 
 (defmethod compile-special ((operator (eql 'flet)) form env context)
@@ -1067,7 +1078,9 @@
                 env context :name `(flet ,name)
                 :block-name (fun-name-block-name name (context-source context)))))
     (emit-bind context (length definitions) (context-frame-end context))
-    (multiple-value-bind (body decls) (parse-body body)
+    (multiple-value-bind (body decls)
+        (parse-body body :source (context-source context))
+      (check-declarations decls (context-source context))
       (multiple-value-bind (env context)
           (bind-fvars (mapcar #'car definitions) env context decls)
         (compile-progn body (add-declarations env decls) context)
@@ -1088,7 +1101,9 @@
                                          :source (expr-source-location
                                                   bind (context-source context)))))
           definitions)
-    (multiple-value-bind (body decls) (parse-body body)
+    (multiple-value-bind (body decls)
+        (parse-body body :source (context-source context))
+      (check-declarations decls (context-source context))
       (multiple-value-bind (new-env new-context)
           (bind-fvars (mapcar #'first definitions) env context decls)
         (let* ((module (context-module context))
@@ -1876,7 +1891,8 @@
   (multiple-value-bind (body decls doc)
       (if declsp
           (values body declarations docstring)
-          (alexandria:parse-body body :documentation t))
+          (parse-body body :documentation t))
+    (check-declarations decls)
     (let* ((name (if namep
                      name
                      (compute-lambda-name lambda-list)))
diff --git a/compile/misc-program-conditions.lisp b/compile/misc-program-conditions.lisp
index 1d7d5a3..3d459b1 100644
--- a/compile/misc-program-conditions.lisp
+++ b/compile/misc-program-conditions.lisp
@@ -162,9 +162,10 @@
                (go again))))
     (t nil)))
 
-;;; this is alexandria:parse-body, but checks for properness first.
-(defun parse-body (body &rest keys &key documentation whole)
+;;; this is alexandria:parse-body, but checks for properness first,
+;;; and maintains source info.
+(defun parse-body (body &rest keys &key documentation whole source)
   (declare (ignore documentation whole))
   (if (proper-list-p body)
-      (apply #'alexandria:parse-body body keys)
-      (error 'improper-body :body body)))
+      (apply #'alexandria:parse-body body :allow-other-keys t keys)
+      (error 'improper-body :body body :source source)))

From ac20e25c86cda876fdfded9c460f0439c0ed5fed Mon Sep 17 00:00:00 2001
From: Alex Wood <aeshtaer@gmail.com>
Date: Mon, 15 Jul 2024 13:19:35 -0400
Subject: [PATCH 10/11] More source info for functions

---
 compile/compile.lisp | 35 ++++++++++++++++++++++++-----------
 1 file changed, 24 insertions(+), 11 deletions(-)

diff --git a/compile/compile.lisp b/compile/compile.lisp
index 1e41597..b91a487 100644
--- a/compile/compile.lisp
+++ b/compile/compile.lisp
@@ -601,16 +601,18 @@
 ;;; Compile into an existing module. Don't link.
 ;;; Useful for the file compiler, and for the first stage of runtime COMPILE.
 (defun compile-into (module lambda-expression env
-                     &rest keys &key block-name declarations)
+                     &rest keys &key block-name declarations source)
   (declare (ignore block-name declarations))
   (check-type lambda-expression lambda-expression)
   (let ((env (coerce-to-lexenv env))
         (lambda-list (cadr lambda-expression))
-        (body (cddr lambda-expression)))
-    (apply #'compile-lambda lambda-list body env module keys)))
+        (body (cddr lambda-expression))
+        (source (expr-source-location lambda-expression source)))
+    (apply #'compile-lambda lambda-list body env module :source source keys)))
 
-(defun compile-link (lambda-expression env &rest keys &key block-name declarations)
-  (declare (ignore block-name declarations))
+(defun compile-link (lambda-expression env &rest keys
+                     &key block-name declarations source)
+  (declare (ignore block-name declarations source))
   (link-function (apply #'compile-into (make-cmodule) lambda-expression env keys)
                  (if (lexical-environment-p env)
                      (global-environment env)
@@ -1489,12 +1491,13 @@
 ;;; stripped by lexenv-for-macrolet (so that this can be done once
 ;;; for multiple definitions).
 ;;; Also used in cmpltv.
-(defun compute-macroexpander (name lambda-list body env)
+(defun compute-macroexpander (name lambda-list body env &optional source)
   ;; see comment in parse-macro for explanation
   ;; as to how we're using the host here
   (cl:compile nil (parse-macro name lambda-list body env
                                (lambda (lexpr env &rest keys)
-                                 (apply #'compile-link lexpr env keys)))))
+                                 (apply #'compile-link lexpr env
+                                        :source source keys)))))
 
 (defmethod compile-special ((op (eql 'macrolet)) form env context)
   (destructure-syntax (macrolet bindings . body)
@@ -1515,7 +1518,7 @@
                               (error 'macro-not-symbol
                                      :name name :source source))
                             (let* ((macrof (compute-macroexpander
-                                            name lambda-list body env))
+                                            name lambda-list body env source))
                                    (info (make-local-macro name macrof)))
                               (cons name info))))))
       (compile-locally body (make-lexical-environment
@@ -1884,7 +1887,7 @@
 (defun compile-lambda (lambda-list body env module
                        &rest keys
                        &key (name nil namep) block-name
-                         (declarations nil declsp) docstring)
+                         (declarations nil declsp) docstring source)
   (declare (ignore block-name))
   (when declsp
     (check-type docstring (or string null) "a documentation string"))
@@ -1899,13 +1902,23 @@
            (function
              (make-cfunction module
                              :name name :lambda-list lambda-list :doc doc))
-           (context (make-context :receiving t :function function))
-           (env (make-lexical-environment env)))
+           (context (make-context :receiving t :function function
+                                  :source source))
+           (env (make-lexical-environment env))
+           end)
+      (when source
+        (let ((start (make-label)))
+          (setf end (make-label))
+          (emit-label context start)
+          (push-map-info (make-instance 'm:source-info
+                           :start start :end end :source source)
+                         context)))
       (setf (cfunction-index function)
             (vector-push-extend function (cmodule-cfunctions module)))
       (apply #'compile-with-lambda-list
              lambda-list decls body env context :allow-other-keys t keys)
       (assemble context m:return)
+      (when end (emit-label context end))
       function)))
 
 ;;;; linkage

From 54a421b43f86924aeff16a28a312a60eeef3d45e Mon Sep 17 00:00:00 2001
From: Alex Wood <aeshtaer@gmail.com>
Date: Tue, 16 Jul 2024 09:41:20 -0400
Subject: [PATCH 11/11] Compile cross VM at high debug for source info

This probably slows things down a little bit, but it has an
important advantage: assuming the host Lisp is decent, it can keep
enough information that the bytecode module and current IP can be
extracted from a host frame. And with that you can get source info
and whatever else. I wrote a proof of concept of this in SBCL, but
you need to use undocumented/fragile internals, so I won't be
including it in Maclina at least for the moment.
---
 vm-cross.lisp | 24 ++++++++++++------------
 1 file changed, 12 insertions(+), 12 deletions(-)

diff --git a/vm-cross.lisp b/vm-cross.lisp
index 407b20b..d4f9c9d 100644
--- a/vm-cross.lisp
+++ b/vm-cross.lisp
@@ -116,11 +116,9 @@
 (defun bytecode-call (template closure-env args)
   (declare (optimize speed)
            (type list args))
-  (let* ((entry-pc (m:bytecode-function-entry-pc template))
-         (frame-size (m:bytecode-function-locals-frame-size template))
-         (module (m:bytecode-function-module template))
-         (bytecode (m:bytecode-module-bytecode module))
-         (literals (m:bytecode-module-literals module)))
+  (let ((entry-pc (m:bytecode-function-entry-pc template))
+        (frame-size (m:bytecode-function-locals-frame-size template))
+        (module (m:bytecode-function-module template)))
     (declare (type (unsigned-byte 16) frame-size))
     ;; Set up the stack, then call VM.
     (let* ((vm *vm*)
@@ -140,7 +138,7 @@
         (setf (vm-stack-top vm) (+ (vm-frame-pointer vm) frame-size))
         ;; set up the stack, then call vm
         (unwind-protect
-             (vm bytecode closure-env literals frame-size)
+             (vm module closure-env frame-size)
           (setf (vm-dynenv-stack vm) old-de-stack))
         ;; tear down the frame.
         (setf (vm-stack-top vm) (- (vm-frame-pointer vm) (length args)))
@@ -264,18 +262,20 @@
             ;; We take the max for partial frames.
             (subseq stack frame-end (max sp frame-end)))))
 
-(defun vm (bytecode closure constants frame-size)
-  (declare (type (simple-array (unsigned-byte 8) (*)) bytecode)
-           (type (simple-array t (*)) closure constants)
+(defun vm (module closure frame-size)
+  (declare (type (simple-array t (*)) closure)
            (type (unsigned-byte 16) frame-size)
-           (optimize speed))
-  (let* ((vm *vm*)
+           (optimize debug))
+  (let* ((bytecode (m:bytecode-module-bytecode module))
+         (constants (m:bytecode-module-literals module))
+         (vm *vm*)
          (stack (vm-stack vm))
          (ip (vm-pc vm))
          (sp (vm-stack-top vm))
          (bp (vm-frame-pointer vm))
          (timeout *timeout*))
-    (declare (type (simple-array t (*)) stack)
+    (declare (type (simple-array (unsigned-byte 8) (*)) bytecode)
+             (type (simple-array t (*)) constants stack)
              (type (and unsigned-byte fixnum) ip sp bp))
     (labels ((stack (index)
                ;;(declare (optimize (safety 0))) ; avoid bounds check