Skip to content
Snippets Groups Projects
Commit af177217 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

New version number: 0.9.0

Improve hygiene with syntax tables.
Add a few test cases from recent SBCL qq pprinter bug. NB: we fail them.
parent 9f1b37ef
No related branches found
No related tags found
No related merge requests found
pattern-matching friendly implementation of Quasiquote
Copyright (c) 2002-2010 Fahree Reedaw <fare@tunes.org>
Copyright (c) 2002-2014 Fahree Reedaw <fare@tunes.org>
PURPOSE
......
......@@ -5,4 +5,4 @@
:components ((:file "quasiquote-test"))
:perform (test-op (o c)
(format! t "~&Testing fare-quasiquote")
(symbol-call :fare-quasiquote :test-quasiquote)))
(symbol-call :fare-quasiquote/test :test-quasiquote)))
......@@ -5,6 +5,7 @@
:long-description "fare-quasiquote implements
a portable quasiquote that you can control."
:license "MIT"
:version "0.9.0"
:depends-on (:fare-utils)
:components
((:file "packages")
......
......@@ -9,8 +9,8 @@
(:documentation
"Quasiquote implementation with and for pattern-matching")
(:export #:quasiquote-expand #:quasiquote #:unquote #:unquote-splicing
#:enable-quasiquote
#:enable-qq-pp
#:enable-quasiquote #:*fq-readtable*
#:enable-qq-pp #:*fq-pprint-dispatch*
#:call-with-quasiquote-reader
#:call-with-unquote-reader
#:call-with-unquote-splicing-reader
......
......@@ -105,17 +105,21 @@
(when count (write count :stream stream))
(write (unparse-quasiquote contents) :stream stream)))
(defun enable-qq-pp ()
(set-pprint-dispatch '(cl:cons (eql list)) #'pprint-quasiquote)
(set-pprint-dispatch '(cl:cons (eql list*)) #'pprint-quasiquote)
(set-pprint-dispatch '(cl:cons (eql append)) #'pprint-quasiquote)
(set-pprint-dispatch '(cl:cons (eql nconc)) #'pprint-quasiquote)
(set-pprint-dispatch '(cl:cons (eql cons)) #'pprint-quasiquote)
(set-pprint-dispatch '(cl:cons (eql vector)) #'pprint-quasiquote)
(set-pprint-dispatch '(cl:cons (eql n-vector)) #'pprint-n-vector)
(set-pprint-dispatch '(cl:cons (eql quote)) #'pprint-quote)
(set-pprint-dispatch '(cl:cons (eql unquote)) #'pprint-unquote)
(set-pprint-dispatch '(cl:cons (eql unquote-splicing)) #'pprint-unquote)
(set-pprint-dispatch '(cl:cons (eql unquote-nsplicing)) #'pprint-unquote)
(defun enable-qq-pp (&key (priority 0) (table *print-pprint-dispatch*))
(set-pprint-dispatch '(cl:cons (eql list)) #'pprint-quasiquote priority table)
(set-pprint-dispatch '(cl:cons (eql list*)) #'pprint-quasiquote priority table)
(set-pprint-dispatch '(cl:cons (eql append)) #'pprint-quasiquote priority table)
(set-pprint-dispatch '(cl:cons (eql nconc)) #'pprint-quasiquote priority table)
(set-pprint-dispatch '(cl:cons (eql cons)) #'pprint-quasiquote priority table)
(set-pprint-dispatch '(cl:cons (eql vector)) #'pprint-quasiquote priority table)
(set-pprint-dispatch '(cl:cons (eql n-vector)) #'pprint-n-vector priority table)
(set-pprint-dispatch '(cl:cons (eql quote)) #'pprint-quote priority table)
(set-pprint-dispatch '(cl:cons (eql unquote)) #'pprint-unquote priority table)
(set-pprint-dispatch '(cl:cons (eql unquote-splicing)) #'pprint-unquote priority table)
(set-pprint-dispatch '(cl:cons (eql unquote-nsplicing)) #'pprint-unquote priority table)
t)
(defvar *fq-pprint-dispatch*
(let ((table (copy-pprint-dispatch nil)))
(enable-qq-pp :table table)
table))
#+xcvb (module (:depends-on ("packages")))
(in-package :fare-quasiquote)
(uiop:define-package :fare-quasiquote/test
(:mix :fare-quasiquote :hu.dwim.stefil :common-lisp)
(:shadowing-import-from :fare-quasiquote
#:quote #:list #:list* #:append))
(hu.dwim.stefil:defsuite*
(fare-quasiquote-test
:in hu.dwim.stefil:root-suite
:documentation "All fare-quasiquote tests"))
(in-package :fare-quasiquote/test)
(defsuite* (fare-quasiquote-test :in root-suite :documentation "All fare-quasiquote tests"))
;; This version of princ allows one to see
;; inside of your implementation's version of quasiquoted expressions...
......@@ -36,23 +38,38 @@
;; You can test the quasiquote implementation like this:
(defparameter *fq-readtable* (named-readtables:find-readtable :fare-quasiquote))
(defmacro with-qq-syntax ((&key) &body body)
`(call-with-qq-syntax #'(lambda () ,@body)))
(defun call-with-qq-syntax (thunk)
(with-standard-io-syntax
(let ((*package* (find-package :fare-quasiquote/test))
(*readtable* *fq-readtable*)
(*print-pprint-dispatch* *fq-pprint-dispatch*)
(*print-pretty* nil))
(funcall thunk))))
(defun fq (s)
(let ((*readtable* *fq-readtable*))
(read-from-string s)))
(defun rq (s) (with-qq-syntax () (read-from-string s)))
(defun pq (x) (with-qq-syntax () (write-to-string x)))
(defparameter b 11)
(hu.dwim.stefil:deftest test-quasiquote ()
(deftest test-quasiquote ()
(macrolet ((q (x y)
`(hu.dwim.stefil:is (equal (fq ,x) ',y))))
`(progn
(hu.dwim.stefil:is (equal (rq ,x) ',y))
;;(hu.dwim.stefil:is (equal ,x (pq ',y)))
)))
(q "``a" (quote (quote a)))
(q "`(a ,b)" (list (quote a) b))
(q "`(,@a)" a)
(q "``(a ,b)" (quote (list (quote a) b)))
(q "`(a ,b)" (list (quote a) b))
(q "`(a ,x ,@y)" (list* (quote a) x y))
;;(is (equal (ifmatch `(a ,x ,@y) '(a b c d) (list x y)) '(b (c d))))
(q "`(1 2 3)" (quote (1 2 3)))
(q "`(a ,b ,@c .,d)" (list* (quote a) b (append c d)))
(q "`(,@c .,d)" (append c d))))
(q "`(,@c .,d)" (append c d))
;;BUG: (q "```(,,a ,',',b)" ...)
;;BUG: (q "'```(,',',plet/fast ,',kernel ,@body)" ...)
(signals error (rq "`(foo bar #.(max 5 ,*print-base*))"))
t))
;;; -*- Mode: Lisp ; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
;;; pattern-matching friendly implementation of Quasiquote
;;; Copyright (c) 2002-2011 Fahree Reedaw <fare@tunes.org>
;;; See README.quasiquote
;;; Copyright (c) 2002-2014 Fahree Reedaw <fare@tunes.org>
;;; See README
#+xcvb (module (:depends-on ("packages")))
......@@ -305,13 +305,15 @@ of the result of the top operation applied to the expression"
(declare (ignore subchar))
(read-vector stream arg))
(defun enable-quasiquote (&key expansion-time (readtable *readtable*))
(set-macro-character #\` (backquote-reader expansion-time) nil readtable)
(set-macro-character #\, #'read-comma nil readtable)
(defun enable-quasiquote (&key expansion-time (table *readtable*))
(set-macro-character #\` (backquote-reader expansion-time) nil table)
(set-macro-character #\, #'read-comma nil table)
(when (eq expansion-time 'read)
(set-dispatch-macro-character #\# #\( #'read-hash-paren readtable))
(set-dispatch-macro-character #\# #\( #'read-hash-paren table))
t)
(defvar *fq-readtable* (let ((x (copy-readtable nil))) (enable-quasiquote :table x) x))
);eval-when
;;(trace quasiquote-expand quasiquote-expand-0 quasiquote-expand-1 expand-unquote)
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment