;;; NOTE:
;;;
;;; The SB-WALKER "interface" is very messy:
;;;
;;; 1. SB-WALKER::VARIABLE-SYMBOL-MACRO-P -- accepts an environment object;
;;;    inspects the global environment if the given environment is nil.
;;;
;;; 2. SB-WALKER::VAR-GLOBALLY-SYMBOL-MACRO-P -- doesn't accept an environment
;;;    object; inspects only the global environment.
;;;
;;; 3. SB-WALKER::ENVIRONMENT-MACRO -- accepts an environment object; doesn't
;;;    inspect the global environment if the given environment is nil.
;;;
;;; 4. SB-WALKER::ENVIRONMENT-FUNCTION -- accepts an environment object; doesn't
;;;    inspect the global environment if the given environment is nil.
;;;
;;; 5. SB-WALKER::SPECIAL-OPERATOR-P
;;;
;;; Checking for operators:
;;;
;;; - We *must* give precedence to locally defined operators.
;;;
;;; - We can use (1) and (2) for global and local symbol macros. Caveat: we
;;;   check for local symbol macros only after checking for global symbol
;;;   macros, since (1) falls back to (2).
;;;
;;; - We *must* use MACRO-FUNCTION for global macros and (3) for local macros.
;;;   Caveat: we check for local macros only after checking for local functions
;;;   because the SB-WALKER internals expect the values of the alist
;;;   representing the current lexical environment to be strictly lists (i.e.
;;;   everything else signals an error) in case of local macros (which is not
;;;   the case when the symbol names a local function). In the case of local
;;;   functions, the internals expect values to be function objects but aren't
;;;   strict about it (i.e. anything else just returns nil).
;;;
;;; - We *must* use FBOUNDP for global functions and (4) for local functions.
;;;   Caveat: we check for global functions only after checking for global
;;;   macros, since they count as being fbound too.
;;;
;;; - We can use SPECIAL-OPERATOR-P or (5) for special operators (both functions
;;;   handle SBCL's non-standard special operators).

(defun find-signals (form &optional expand-macros-p)
  (let ((signals nil))
    (flet ((walker (subform context env)
             (declare (ignore context))
             (if (atom subform)
                 (cond
                   ((sb-walker::var-globally-symbol-macro-p subform)
                    (format t "symbol macro: ~s~%" subform))
                   ((sb-walker::variable-symbol-macro-p subform env)
                    (format t "local symbol macro: ~s~%" subform))
                   (t (format t "atom: ~s~%" subform)))
                 (let ((head (car subform)))
                   (cond
                     ((sb-walker::special-operator-p head)
                      (format t "special: ~s~%" subform))
                     ((sb-walker::environment-function env head)
                      (format t "local function: ~s~%" head))
                     ((sb-walker::environment-macro env head)
                      (format t "local macro: ~s~%" head))
                     ((macro-function head)
                      (format t "macro: ~s~%" head))
                     ((fboundp head)
                      (format t "function: ~s~%" head)
                      (when (eq head '<-)
                        (push (cadr subform) signals)))
                     (t (format t "unknown operator: ~s (in ~s)~%" head subform)))))
             subform))
      (let ((sb-walker:*walk-form-expand-macros-p* expand-macros-p))
        (sb-walker:walk-form form nil #'walker))
      (nreverse signals))))

(defmacro test-find-signals (form)
  "Calls FIND-SIGNALS twice, once with MACRO-EXPAND-P as NIL and once as T, and
captures the output and the returned signals. Returns 5 values which are SIGS1,
SIGS2, STR1, STR2 and EQP. SIGS1 and SIGS2 are the found signals, STR1 and STR2
are the captured outputs and EQP is a boolean that is true if STR1 and STR2 are
STRING=. Suffix 1 corresponds to the first call (NIL) while suffix 2 corresponds
to the second (T)."
  `(let ((str1 (make-array 0 :element-type 'base-char
                             :fill-pointer 0
                             :adjustable t))
         (str2 (make-array 0 :element-type 'base-char
                             :fill-pointer 0
                             :adjustable t)))
     (values (with-output-to-string (*standard-output* str1)
               (find-signals ',form t))
             (with-output-to-string (*standard-output* str2)
               (find-signals ',form))
             str1
             str2
             (string= str1 str2))))

(progn
  (defun <- (sym value) (declare (ignore sym value)))
  (defmacro gm1 (sym value) `'(<- ,sym ,value))
  (defmacro gm2 (sym value) `(<- ,sym ,value))
  (define-symbol-macro gsm1 '(<- j 1))
  (define-symbol-macro gsm2 (<- k 1))
  (multiple-value-bind (sigs1 sigs2 str1 str2 eqp)
      (test-find-signals
       (progn
         ;; YES
         (<- a 1)
         (flet ((<- (sym value)
                  (declare (ignore sym value))))
           ;; NO -- local function
           (<- b 1))
         (wait :for 1)
         ;; NO
         (gm1 c 2)
         ;; YES
         (gm2 d 3)
         ;; YES (TODO)
         (macrolet ((m1 ()
                      (<- 'e 1)
                      'expansion))
           (m1))
         (macrolet ((<- (sym value)
                      (declare (ignore sym value))))
           ;; NO -- local macro
           (<- f 2))
         (macrolet ((m1 (x) `(<- ,x 1)))
           ;; NO -- local macro not used
           nil)
         (macrolet ((m1 (x) `(<- ,x 1)))
           ;; YES
           (m1 g))
         (macrolet ((m1 (x) `(<- ,x 1)))
           (macrolet ((m2 (x) `(m1 ,x)))
             ;; YES
             (m2 h)))
         (macrolet ((m1 () `(<- i 1)))
           ;; YES
           (m1))
         (wait :for 1)
         ;; NO -- expansion is quoted
         gsm1
         ;; YES
         gsm2
         (symbol-macrolet ((sm1 (<- l 1)))
           ;; NO -- symbol macro not used
           nil)
         (symbol-macrolet ((sm1 (<- m 1)))
           ;; YES
           sm1)
         (symbol-macrolet ((sm1 (<- n 1)))
           (symbol-macrolet ((sm2 sm1))
             ;; YES
             sm2))
         ;; NO -- quoted
         '(<- o 2)
         `(<- p 2)
         ;; YES -- unquoted
         `(,(<- r 2))
         ;; YES (TODO)
         (funcall (lambda () (<- s 3)))
         ;; YES (TODO)
         (flet ((fun ()
                  (<- t 1)))
           nil)
         (wait :for 2)
         (exit)))
    (format t "sigs1~%-----~%~s~%" sigs1)
    (format t "sigs2~%-----~%~s~%" sigs2)
    (format t "str1~%----~%~a~%" str1)
    (format t "str2~%----~%~a~%" str2)
    (format t "they're ~:[not equal~;equal~]" eqp)
    (values sigs1 sigs2 eqp)))