(in-package #:portaCL)

(define-condition suppressed-error (warning)
  ((original-error     :initarg :error)
   (feature-expression :initarg :feature))
  (:report (lambda (c s)
             (format s "Suppressed an error while testing feature expansion ~S: ~A"
                     (slot-value c 'feature-expression)
                     (slot-value c 'original-error)))))

;; see CLHS 2.4.8.17 <http://www.lispworks.com/documentation/HyperSpec/Body/02_dhq.htm>
(defun feature-reader (stream fn arg)
  "Reader for enhanced #+/#- feature conditionals."
  (when (and arg (not *read-suppress*))
    (error 'simple-error
           :format-control "Numeric arg (~D) specified on reader conditional where none allowed."
           :format-arguments (list arg)))
  (flet ((feature-truth (form)
           ;; from CLHS *read-suppress* <http://www.lispworks.com/documentation/HyperSpec/Body/v_rd_sup.htm>:
           ;; Any standardized reader macro that is defined to read a following
           ;; object or token will do so, but not signal an error if the object
           ;; read is not of an appropriate type or syntax.
           ;;
           ;; I take that to mean errors thrown during the course of #'featurep
           ;; should be suppressed.  Some implementations differ.
           (handler-bind
               ((error (lambda (c)
                         (when *read-suppress*
                           (warn 'suppressed-error :feature form :error c)
                           (return-from feature-truth nil)))))
             (funcall fn form)))
         (read-form (stream)
           (read stream t nil t)))
    (cond
      ((feature-truth
        (let ((*package* (find-package :keyword))
              ;; Incorrectly interns symbols, but we need more than just cl:nil :/
              (*read-suppress* nil))
          (read-form stream)))
       (values (read-form stream)))
      (t
       (let ((*read-suppress* t)) (read-form stream))
       (values)))))

(defun |#+-reader| (stream subchar arg)
  (declare (ignore subchar))
  (feature-reader stream #'featurep arg))

(defun |#--reader| (stream subchar arg)
  (declare (ignore subchar))
  (feature-reader stream (complement #'featurep) arg))

(defun install-feature-readers (&optional (*readtable* *readtable*))
  (set-dispatch-macro-character #\# #\+ #'|#+-reader|)
  (set-dispatch-macro-character #\# #\- #'|#--reader|))