repos
/
portaCL
/ annotate_zebra
summary
|
shortlog
|
log
|
tree
|
commit
|
commitdiff
|
headdiff
|
annotate
|
headblob
|
headfilediff
|
filehistory
normal
|
plain
|
shade
|
zebra
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|))