From f18525cddabfd8754934868cb60a2f65ae78b439 Mon Sep 17 00:00:00 2001 From: Olof-Joachim Frahm Date: Mon, 19 Nov 2012 23:56:06 +0100 Subject: [PATCH] Initial commit, add system, sources and tests. --- counted-feature-tests.asd | 32 ++++++++++ syntax.lisp | 151 +++++++++++++++++++++++++++++++++++++++++++++ tests.lisp | 28 +++++++++ 3 files changed, 211 insertions(+) create mode 100644 counted-feature-tests.asd create mode 100644 syntax.lisp create mode 100644 tests.lisp diff --git a/counted-feature-tests.asd b/counted-feature-tests.asd new file mode 100644 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 " + :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 " + :depends-on (#:counted-feature-tests #:fiveam) + :components ((:file "tests"))) diff --git a/syntax.lisp b/syntax.lisp new file mode 100644 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 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))) -- 1.7.10.4