Merge pull request #4 from s-expressionists/debuginfo

Debug info

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)
+  ())

compile/environment.lisp

@@ -0,0 +1,144 @@
+(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)
+  ;; 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))
+            (: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)))
+
+(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 &key ignore)
+  (make-instance 'trucler:lexical-variable-description
+    :name name
+    :identity (make-lexical-variable-info frame-offset cfunction)
+    :ignore ignore))
+
+(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 &key ignore)
+  (make-instance 'trucler:local-function-description
+    :name name :ignore ignore
+    :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))))

compile/misc-program-conditions.lisp

@@ -1,100 +1,144 @@
 (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 not-function-name (program-error)
+;;; 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))
+  (:report (lambda (condition stream)
+             (format stream "~:(~a~) ~s was declared ~s, but was still used"
+                     (kind condition) (name condition) 'cl:ignore))))
+
+(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 (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.
+   (%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 (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"
                      (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
@@ -118,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)))

compile/package.lisp

@@ -27,8 +27,11 @@
            #: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
            #:resolve-function #:resolve-macro
-           #:assumed-function-now-macro))
+           #:assumed-function-now-macro)
+  ;; PC map info related stuff
+  (:export #:*source-locations*))