1 (in-package #:portaCL)
 2 
 3 (define-condition suppressed-error (warning)
 4   ((original-error     :initarg :error)
 5    (feature-expression :initarg :feature))
 6   (:report (lambda (c s)
 7              (format s "Suppressed an error while testing feature expansion ~S: ~A"
 8                      (slot-value c 'feature-expression)
 9                      (slot-value c 'original-error)))))
10 
11 ;; see CLHS 2.4.8.17 <http://www.lispworks.com/documentation/HyperSpec/Body/02_dhq.htm>
12 (defun feature-reader (stream fn arg)
13   "Reader for enhanced #+/#- feature conditionals."
14   (when (and arg (not *read-suppress*))
15     (error 'simple-error
16            :format-control "Numeric arg (~D) specified on reader conditional where none allowed."
17            :format-arguments (list arg)))
18   (flet ((feature-truth (form)
19            ;; from CLHS *read-suppress* <http://www.lispworks.com/documentation/HyperSpec/Body/v_rd_sup.htm>:
20            ;; Any standardized reader macro that is defined to read a following
21            ;; object or token will do so, but not signal an error if the object
22            ;; read is not of an appropriate type or syntax.
23            ;;
24            ;; I take that to mean errors thrown during the course of #'featurep
25            ;; should be suppressed.  Some implementations differ.
26            (handler-bind
27                ((error (lambda (c)
28                          (when *read-suppress*
29                            (warn 'suppressed-error :feature form :error c)
30                            (return-from feature-truth nil)))))
31              (funcall fn form)))
32          (read-form (stream)
33            (read stream t nil t)))
34     (cond
35       ((feature-truth
36         (let ((*package* (find-package :keyword))
37               ;; Incorrectly interns symbols, but we need more than just cl:nil :/
38               (*read-suppress* nil))
39           (read-form stream)))
40        (values (read-form stream)))
41       (t
42        (let ((*read-suppress* t)) (read-form stream))
43        (values)))))
44 
45 (defun |#+-reader| (stream subchar arg)
46   (declare (ignore subchar))
47   (feature-reader stream #'featurep arg))
48 
49 (defun |#--reader| (stream subchar arg)
50   (declare (ignore subchar))
51   (feature-reader stream (complement #'featurep) arg))
52 
53 (defun install-feature-readers (&optional (*readtable* *readtable*))
54   (set-dispatch-macro-character #\# #\+ #'|#+-reader|)
55   (set-dispatch-macro-character #\# #\- #'|#--reader|))