syntax.lisp

   1 ;;; -*- mode: lisp; syntax: common-lisp; coding: utf-8; package: cl-user; -*-
   2
   3 (in-package #:cl-user)
   4
   5 (defpackage #:counted-feature-tests
   6   (:use #:cl)
   7   (:export
   8    #:featurep
   9    #:disable-counted-feature-tests-syntax
  10    #:locally-disable-counted-feature-tests-syntax
  11    #:enable-counted-feature-tests-syntax
  12    #:locally-enable-counted-feature-tests-syntax
  13    #:file-enable-counted-feature-tests-syntax
  14    #:restore-counted-feature-tests-syntax-state))
  15
  16 (in-package #:counted-feature-tests)
  17
  18 ;;; the goal is to enable #+ and #- to ignore multiple expressions by
  19 ;;; supplying an additional numeric prefix
  20
  21 ;;; zero is kind of pointless, but would be accepted, possibly with a
  22 ;;; warning, one is the default
  23
  24 ;;; note that you can't enter a negative value in the first place, so that
  25 ;;; point is moot
  26
  27 ;;; discarding all READ forms until the end of file should probably not
  28 ;;; be mashed together with this, as it's not an extension of the
  29 ;;; otherwise fairly obvious semantics of this extension
  30
  31 ;;; since the number of discarded expressions must exactly match the
  32 ;;; numeric prefix, #999+(or) can not be used to achieve this
  33
  34
  35 ;;; as a prerequisite, let us define a function for evaluating feature
  36 ;;; expressions - should probably be a standard function as well
  37
  38 ;;; (featurep 'x) then means roughly the same as #+x T
  39
  40 ;; sbcl/src/code/early-extensions.lisp:963 has the implementation for SBCL
  41 ;; slightly changed for portability, i.e. MEMQ to MEMBER
  42
  43 ;;; If X is a symbol, see whether it is present in *FEATURES*. Also
  44 ;;; handle arbitrary combinations of atoms using NOT, AND, OR.
  45 (defun featurep (x)
  46   (typecase x
  47     (cons
  48      (case (car x)
  49        ((:not not)
  50         (cond
  51           ((cddr x)
  52            (error "too many subexpressions in feature expression: ~S" x))
  53           ((null (cdr x))
  54            (error "too few subexpressions in feature expression: ~S" x))
  55           (t (not (featurep (cadr x))))))
  56        ((:and and) (every #'featurep (cdr x)))
  57        ((:or or) (some #'featurep (cdr x)))
  58        (t
  59         (error "unknown operator in feature expression: ~S" x))))
  60     (symbol (not (null (member x *features* :test #'eq))))
  61     (t
  62       (error "invalid feature expression: ~S" x))))
  63
  64 ;;; now we can use this to implement the two reader macros
  65 ;;; implementation-independently
  66
  67 ;; sbcl/src/code/sharpm.lisp:354 has the implementation for SBCL
  68 ;; slightly changed, i.e. uses FIND-PACKAGE
  69 ;; furthermore it now just READ and discards N times instead of once
  70
  71 ;;;; conditional compilation: the #+ and #- readmacros
  72
  73 (flet ((guts (stream count not-p)
  74          (unless (if (let ((*package* #.(find-package '#:keyword))
  75                            (*read-suppress* nil))
  76                        (featurep (read stream t nil t)))
  77                      (not not-p)
  78                      not-p)
  79            (let ((*read-suppress* t))
  80              (dotimes (i (or count 1))
  81                (read stream t nil t))))
  82          (values)))
  83
  84   (defun sharp-plus (stream sub-char numarg)
  85     (declare (ignore sub-char))
  86     (guts stream numarg nil))
  87
  88   (defun sharp-minus (stream sub-char numarg)
  89     (declare (ignore sub-char))
  90     (guts stream numarg t)))
  91
  92 (defvar *original-readtable* NIL)
  93
  94 (defvar *restore-counted-feature-tests-syntax* NIL)
  95
  96 (defmacro disable-counted-feature-tests-syntax ()
  97   '(eval-when (:compile-toplevel :load-toplevel :execute)
  98     (setf *restore-reader-syntax* NIL)
  99     (%disable-counted-feature-tests-syntax)))
 100
 101 (defmacro locally-disable-counted-feature-tests-syntax ()
 102   '(eval-when (:compile-toplevel :load-toplevel :execute)
 103     (%disable-counted-feature-tests-syntax)))
 104
 105 (defun %disable-counted-feature-tests-syntax ()
 106   (when *original-readtable*
 107     (setf *readtable* *original-readtable*
 108           *original-readtable* NIL))
 109   (values))
 110
 111 (defmacro enable-counted-feature-tests-syntax ()
 112   '(eval-when (:compile-toplevel :load-toplevel :execute)
 113     (setf *restore-reader-syntax* T)
 114     (%enable-counted-feature-tests-syntax)))
 115
 116 (defmacro locally-enable-counted-feature-tests-syntax ()
 117   '(eval-when (:compile-toplevel :load-toplevel :execute)
 118     (%enable-counted-feature-tests-syntax)))
 119
 120 (defmacro file-enable-counted-feature-tests-syntax ()
 121   '(eval-when (:compile-toplevel :load-toplevel :execute)
 122     (%enable-counted-feature-tests-syntax NIL)))
 123
 124 (defun %enable-counted-feature-tests-syntax (&optional (save-original-p T))
 125   (when save-original-p
 126     (setf *original-readtable* (copy-readtable)))
 127   (when (or (not save-original-p) *original-readtable*)
 128     (setf *readtable* (copy-readtable))
 129     (set-dispatch-macro-character #\# #\+ #'sharp-plus)
 130     (set-dispatch-macro-character #\# #\- #'sharp-minus))
 131   (values))
 132
 133 (defmacro restore-counted-feature-tests-syntax-state ()
 134   '(eval-when (:compile-toplevel :load-toplevel :execute)
 135     (if *restore-counted-feature-tests-syntax*
 136         (%enable-counted-feature-tests-syntax)
 137         (%disable-counted-feature-tests-syntax))))
 138
 139 ;;; which is then used like follows, #- is of course analogous
 140
 141 ;; (list #2+(or)
 142 ;;       :a-keyword-argument and-its-value
 143 ;;       'other 'stuff)
 144 ;; => (OTHER STUFF)
 145
 146 ;; #0+is 'useless
 147 ;; => USELESS
 148
 149 ;; #+(and) 42
 150 ;; OR #1+(and) 42
 151 ;; => 42