Initial commit, add system, sources and tests.

diff --git a/counted-feature-tests.asd b/counted-feature-tests.asd
new file mode 100644 (file)
index 0000000..cbc71c4
--- /dev/null
+++ b/counted-feature-tests.asd
@@ -0,0 +1,32 @@
+;;; -*- mode: lisp; syntax: common-lisp; coding: utf-8; package: cl-user; -*-
+
+;;; parts of this system are taken from SBCL:
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package #:cl-user)
+
+(asdf:defsystem #:counted-feature-tests
+  #+asdf-unicode :encoding #+asdf-unicode :utf-8
+  :description "Extended feature tests syntax."
+  :long-description "Extends standard feature tests with numeric prefix."
+  :author "Olof-Joachim Frahm <olof@macrolet.net>"
+  :licence "Public Domain"
+  :components ((:file "syntax"))
+  :in-order-to ((asdf:test-op (asdf:test-op #:counted-feature-tests-tests)))
+  :perform (asdf:test-op :after (operation component)
+             (funcall (intern (symbol-name '#:run!) '#:fiveam)
+                      (intern (symbol-name '#:counted-feature-tests)
+                              '#:counted-feature-tests-tests))))
+
+(asdf:defsystem #:counted-feature-tests-tests
+  :author "Olof-Joachim Frahm <olof@macrolet.net>"
+  :depends-on (#:counted-feature-tests #:fiveam)
+  :components ((:file "tests")))

diff --git a/syntax.lisp b/syntax.lisp
new file mode 100644 (file)
index 0000000..88d5dd3
--- /dev/null
+++ b/syntax.lisp
@@ -0,0 +1,151 @@
+;;; -*- mode: lisp; syntax: common-lisp; coding: utf-8; package: cl-user; -*-
+
+(in-package #:cl-user)
+
+(defpackage #:counted-feature-tests
+  (:use #:cl)
+  (:export
+   #:featurep
+   #:disable-counted-feature-tests-syntax
+   #:locally-disable-counted-feature-tests-syntax
+   #:enable-counted-feature-tests-syntax
+   #:locally-enable-counted-feature-tests-syntax
+   #:file-enable-counted-feature-tests-syntax
+   #:restore-counted-feature-tests-syntax-state))
+
+(in-package #:counted-feature-tests)
+
+;;; the goal is to enable #+ and #- to ignore multiple expressions by
+;;; supplying an additional numeric prefix
+
+;;; zero is kind of pointless, but would be accepted, possibly with a
+;;; warning, one is the default
+
+;;; note that you can't enter a negative value in the first place, so that
+;;; point is moot
+
+;;; discarding all READ forms until the end of file should probably not
+;;; be mashed together with this, as it's not an extension of the
+;;; otherwise fairly obvious semantics of this extension
+
+;;; since the number of discarded expressions must exactly match the
+;;; numeric prefix, #999+(or) can not be used to achieve this
+
+
+;;; as a prerequisite, let us define a function for evaluating feature
+;;; expressions - should probably be a standard function as well
+
+;;; (featurep 'x) then means roughly the same as #+x T
+
+;; sbcl/src/code/early-extensions.lisp:963 has the implementation for SBCL
+;; slightly changed for portability, i.e. MEMQ to MEMBER
+
+;;; If X is a symbol, see whether it is present in *FEATURES*. Also
+;;; handle arbitrary combinations of atoms using NOT, AND, OR.
+(defun featurep (x)
+  (typecase x
+    (cons
+     (case (car x)
+       ((:not not)
+        (cond
+          ((cddr x)
+           (error "too many subexpressions in feature expression: ~S" x))
+          ((null (cdr x))
+           (error "too few subexpressions in feature expression: ~S" x))
+          (t (not (featurep (cadr x))))))
+       ((:and and) (every #'featurep (cdr x)))
+       ((:or or) (some #'featurep (cdr x)))
+       (t
+        (error "unknown operator in feature expression: ~S" x))))
+    (symbol (not (null (member x *features* :test #'eq))))
+    (t
+      (error "invalid feature expression: ~S" x))))
+
+;;; now we can use this to implement the two reader macros
+;;; implementation-independently
+
+;; sbcl/src/code/sharpm.lisp:354 has the implementation for SBCL
+;; slightly changed, i.e. uses FIND-PACKAGE
+;; furthermore it now just READ and discards N times instead of once
+
+;;;; conditional compilation: the #+ and #- readmacros
+
+(flet ((guts (stream count not-p)
+         (unless (if (let ((*package* #.(find-package '#:keyword))
+                           (*read-suppress* nil))
+                       (featurep (read stream t nil t)))
+                     (not not-p)
+                     not-p)
+           (let ((*read-suppress* t))
+             (dotimes (i (or count 1))
+               (read stream t nil t))))
+         (values)))
+
+  (defun sharp-plus (stream sub-char numarg)
+    (declare (ignore sub-char))
+    (guts stream numarg nil))
+
+  (defun sharp-minus (stream sub-char numarg)
+    (declare (ignore sub-char))
+    (guts stream numarg t)))
+
+(defvar *original-readtable* NIL)
+
+(defvar *restore-counted-feature-tests-syntax* NIL)
+
+(defmacro disable-counted-feature-tests-syntax ()
+  '(eval-when (:compile-toplevel :load-toplevel :execute)
+    (setf *restore-reader-syntax* NIL)
+    (%disable-counted-feature-tests-syntax)))
+
+(defmacro locally-disable-counted-feature-tests-syntax ()
+  '(eval-when (:compile-toplevel :load-toplevel :execute)
+    (%disable-counted-feature-tests-syntax)))
+
+(defun %disable-counted-feature-tests-syntax ()
+  (when *original-readtable*
+    (setf *readtable* *original-readtable*
+          *original-readtable* NIL))
+  (values))
+
+(defmacro enable-counted-feature-tests-syntax ()
+  '(eval-when (:compile-toplevel :load-toplevel :execute)
+    (setf *restore-reader-syntax* T)
+    (%enable-counted-feature-tests-syntax)))
+
+(defmacro locally-enable-counted-feature-tests-syntax ()
+  '(eval-when (:compile-toplevel :load-toplevel :execute)
+    (%enable-counted-feature-tests-syntax)))
+
+(defmacro file-enable-counted-feature-tests-syntax ()
+  '(eval-when (:compile-toplevel :load-toplevel :execute)
+    (%enable-counted-feature-tests-syntax NIL)))
+
+(defun %enable-counted-feature-tests-syntax (&optional (save-original-p T))
+  (when save-original-p
+    (setf *original-readtable* (copy-readtable)))
+  (when (or (not save-original-p) *original-readtable*)
+    (setf *readtable* (copy-readtable))
+    (set-dispatch-macro-character #\# #\+ #'sharp-plus)
+    (set-dispatch-macro-character #\# #\- #'sharp-minus))
+  (values))
+
+(defmacro restore-counted-feature-tests-syntax-state ()
+  '(eval-when (:compile-toplevel :load-toplevel :execute)
+    (if *restore-counted-feature-tests-syntax*
+        (%enable-counted-feature-tests-syntax)
+        (%disable-counted-feature-tests-syntax))))
+
+;;; which is then used like follows, #- is of course analogous
+
+;; (list #2+(or)
+;;       :a-keyword-argument and-its-value
+;;       'other 'stuff)
+;; => (OTHER STUFF)
+
+;; #0+is 'useless
+;; => USELESS
+
+;; #+(and) 42
+;; OR #1+(and) 42
+;; => 42

diff --git a/tests.lisp b/tests.lisp
new file mode 100644 (file)
index 0000000..8a4144a
--- /dev/null
+++ b/tests.lisp
@@ -0,0 +1,28 @@
+;;; -*- mode: lisp; syntax: common-lisp; coding: utf-8; package: cl-user; -*-
+
+(in-package #:cl-user)
+
+(defpackage #:counted-feature-tests-tests
+  (:use #:cl #:counted-feature-tests #:fiveam))
+
+(in-package #:counted-feature-tests-tests)
+
+(file-enable-counted-feature-tests-syntax)
+
+(def-suite counted-feature-tests)
+
+(in-suite counted-feature-tests)
+
+(def-test useless.zero ()
+  "Zero prefix is no-op."
+  (is (eq 'useless #0+is 'useless)))
+
+(def-test or-other-stuff ()
+  "Always skip next two forms with (OR)."
+  (is (equal '(other stuff)
+             (list #2+(or) :a-keyword-argument and-its-value
+                   'other 'stuff))))
+
+(def-test useless.and ()
+  "Always read next form with (AND) and one prefix."
+  (is (eql 42 #1+(and) 42)))