Improved feature readers
Annotate for file /reader.lisp
2009-07-17 pix 1 (in-package #:portaCL)
05:24:52 ' 2
2009-07-20 pix 3 (define-condition suppressed-error (warning)
01:14:10 ' 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
2009-07-17 pix 11 ;; see CLHS 2.4.8.17 <http://www.lispworks.com/documentation/HyperSpec/Body/02_dhq.htm>
2009-07-20 pix 12 (defun feature-reader (stream fn arg)
2009-07-17 pix 13 "Reader for enhanced #+/#- feature conditionals."
2009-07-20 pix 14 (when (and arg (not *read-suppress*))
01:14:10 ' 15 (error 'simple-error
' 16 :format-control "Numeric arg (~D) specified on reader conditional where none allowed."
' 17 :format-arguments (list arg)))
2009-07-17 pix 18 (flet ((feature-truth (form)
2009-07-20 pix 19 ;; from CLHS *read-suppress* <http://www.lispworks.com/documentation/HyperSpec/Body/v_rd_sup.htm>:
01:14:10 ' 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)))
2009-07-17 pix 32 (read-form (stream)
05:24:52 ' 33 (read stream t nil t)))
' 34 (cond
' 35 ((feature-truth
2009-07-20 pix 36 (let ((*package* (find-package :keyword))
01:14:10 ' 37 ;; Incorrectly interns symbols, but we need more than just cl:nil :/
' 38 (*read-suppress* nil))
2009-07-17 pix 39 (read-form stream)))
05:24:52 ' 40 (values (read-form stream)))
' 41 (t
' 42 (let ((*read-suppress* t)) (read-form stream))
' 43 (values)))))
' 44
2009-07-20 pix 45 (defun |#+-reader| (stream subchar arg)
01:14:10 ' 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
2009-07-17 pix 53 (defun install-feature-readers (&optional (*readtable* *readtable*))
2009-07-20 pix 54 (set-dispatch-macro-character #\# #\+ #'|#+-reader|)
01:14:10 ' 55 (set-dispatch-macro-character #\# #\- #'|#--reader|))