Split fare-quasiquote from fare-matcher.
--- /dev/null
+I've decided to consolidate pattern matching libraries.
+Optima is a much better library than fare-matcher,
+which was a proof of concept, really.
+
+I'll be working with the authors of Optima to make sure
+that optima is superior in every possible aspect to fare-matcher,
+and will recommend users who use fare-matcher to migrate to optima.
+
+https://github.com/m2ym/optima
+
+See you there soon!
+
+Faré, 2012-10-24
+++ /dev/null
-fare-matcher friendly implementation of Quasiquote
-Copyright (c) 2002-2010 Fahree Reedaw <fare@tunes.org>
-
-
-PURPOSE
-
-The main purpose of this n+2nd reimplementation of quasiquote,
-is enable matching of quasiquoted patterns with fare-matcher.
-
-Now, developing this implementation is also a challenge in understanding
-the ins and outs of quasiquotation, and in exploring the way it interacts
-with extended support for constant-building syntactic constructs.
-And this, at least to me is as much fun as it is an intellectual challenge. :-)
-
-
-INTERACTION WITH FARE-MATCHER
-
-This implementation of quasiquote requires the FARE-MATCHER system.
-
-It enables quasiquotation inside FARE-MATCHER patterns.
-However, as a limitation to such use, note that as long as
-the pattern-matcher isn't extended to match APPEND patterns,
-which typically requires backtracking, then those quasiquote templates
-that expand into something using APPEND can't be used as patterns to match.
-This mostly restricts the use of ,@ or ,. to the end of a list.
-
-This implementation also uses FARE-MATCHER internally,
-which allows to tremendously simplify the simplifier
-used to normalize quasiquote-using expressions.
-This simplifier in turn is necessary to simplify APPEND patterns
-into CONS LIST* and LIST patterns for use with FARE-MATCHER.
-
-
-REFERENCES
-
-Essential documents consulted while implementing this file:
-Alan Bawden's paper: http://www.bawden.org/ftp/pepm99.ps.gz
-CLtL2: http://www.supelec.fr/docs/cltl/clm/node367.html
-CLHS: http://www.lisp.org/HyperSpec/Body/sec_2-4-6.html
-Slate reference manual section 2.6.2 on quoting and unquoting:
- http://slate.tunes.org/doc/progman/node12.html#SECTION00046200000000000000
-Common Lisp backquote implementation, written in Common Lisp. (public domain)
- Author: Guy L. Steele Jr. Date: 27 December 1985
- To be used with patch by Alex Plotnick 2010 regarding the simplification pass.
-SBCL backquote implementation (derived from CMUCL).
-
-
-NOTES
-
-* We provide for a read-time quasiquote expander as well as
- a macro-expansion-time quasiquote expander.
- The read-time expander handles #() syntax correctly
- but mightn't be as efficient as the built-in reader in the common case,
- whereas the macro-expansion-time sees #() too late (see BUGS).
- To use the macro-expansion-time one, uncomment the line that declares
- feature :quasiquote-at-macro-expansion-time.
-
-
-TO DO
-
-* The CLHS doesn't tell anything about multi-dimensional arrays;
- however, this is the opportunity to define a MUP: Meta Unquote Protocol.
- The MUP would allow to extend the quasiquote mechanism with support
- for new constant-building syntactic constructs as such constructs are defined.
- Maybe we will end up with a full-fledge declarative infrastructure
- for a Parser-Preprocessor-Pretty-Printer, like camlp4 only more declarative.
-
-* Can we improve performance?
- Statically compile and optimize the patterns for the simplifier?
-
-* Implement the MUP with an abstract API for new readers;
- as examples, provide readers for existing syntax that can be toggled
- as either unquote-aware or not: #(), #A, etc.
-
-* Implement tagged (and multiple-valued?) quasiquotes, unquotes and quotes.
-
-
-BUGS:
-
-* It looks like there are nasty bugs in the simplifier.
- Maybe start again afresh with a MUP for CONS?
- We should start from the known-working algorithm described in CLtL2,
- that keeps the data in simplified form at all time incrementally,
- instead of trying a global simplification after-the-fact.
-
-* This version works inside simple vectors, so as to support
- unquoting inside the #(...) syntax as the standard mandates.
- However, doing that at macro-expansion time means that we disturb
- any SIMPLE-VECTOR that appears in the source code, even if it comes
- from forms other than #(...), such as #1A(...) or #.(VECTOR ...).
- This phenomenon has been documented before in the following message:
- http://groups.google.com/groups?q=author:kaz%40ashi.footprints.net&hl=en&lr=&ie=UTF-8&oe=UTF-8&safe=off&selm=cf333042.0303141409.bbf02e9%40posting.google.com&rnum=4
-
-* Interestingly, I haven't seen the following problem stated, to know which is
- correct of `#2(1 ,@'(2 3)) or `#3(1 ,@'(2 3)). In other words, does the read
- argument to #() mean something at read-time or at vector-creation-time?
- Of course, in the original intended usage, outside of any quasiquoting,
- read-time and vector-creation-time are one and the same.
- But what when quasiquote breaks up that identity?
-
-* Note that we do not handle unquoting inside structures
- or arrays more complex than simple vectors.
-
-* Note that in the case of the macro-expansion-time expander,
- we do not check for lone unquote syntax before macro expansion,
- which may lead this implementation to accept hacks
- that are not valid according to the standard, such as
- macros that produce unbalanced unquote syntax markers.
-
-* Certainly, the implementation of quasiquote should be "opened"
- so as to allow new syntactic features to take advantage of it.
- Then, maybe we can redefine our own proper reader behaviour for #(...)
- and each MUP-supporting piece of syntax, on top of the MUP?
-
- Note that copying and modifying read-tables is expensive, that dynamically
- modifying and restoring read-tables might interfere with #. syntax, and that
- caching modified read-tables will interfere with any subsequent modification
- of a cached read-table, comparison not being possible.
- This means that if we wanted the MUP to adapt to existing extensions
- without modifying existing code, we would have to intercept the definition
- of syntax reading functions before they are fed to either SET-MACRO-CHARACTER
- or SET-DISPATCH-MACRO-CHARACTER. Spooky.
- Now, this also requires that the current depth of quasiquoting be consulted
- any time any of the MUP-enabled constructors is read.
-
-* The principle of the MUP is that
- = structure readers that don't want to support unquote MUST be wrapped into
- something that dynamically binds *quasiquote-level* to 0.
- = structure readers #C(ARGSYNTAX) that do want to support unquote
- MUST accumulate formal arguments to a structure constructor
- into a list ARGUMENTS, then, if *quasiquote-level* is 0, behave like
- #.(apply `#CONSTRUCTOR `#ARGUMENTS)
- otherwise, behave like
- ,(apply `#CONSTRUCTOR `#ARGUMENTS)
- where #CONSTRUCTOR is the name of the constructor for given structure,
- and #ARGUMENTS is whichever arguments have been deduced from the syntax,
- which may include as many levels of unquotations as *quasiquote-level* says.
- Note that in a strong sense, "#." is like "," assuming an infinite tower of
- read-time evaluators a la 3-LISP.
-
-* Note that the above is obscured because we're trying to discuss
- the behaviour of quasiquote-containing programs without having
- a meta-level quasiquoting facility that could distinguish
- between what is constant or variable at the meta-level independently from
- what is constant or variable at the base level:
- #CONSTRUCTOR and #ARGUMENTS would be better specified
- through a special meta-level unquotation, the above expressions
- being in a corresponding special quasiquotation.
- A feature that would allow for clear separation of levels of meta-language
- would be a tagged quasiquote feature, as in Slate (http://slate-language.org/).
-
-* This version is not safe with respect to quasiquoting expressions
- where appear some marker symbols interned in the FARE-QUASIQUOTE package --
- such expressions may lead to confusion between the body of expressions
- being quasiquoted and the internal quasiquote infrastructure.
- Any objects used as markers instead of these interned symbols
- would lead to the same "bug" if somehow used inside quasiquoted expressions;
- but at least, non-interned symbols or gensyms would allow to avoid this bug
- in expressions being READ. The "perfect" solution would be to use
- objects GENSYMed at the moment a given QUASIQUOTE is read,
- and kept in a lexical variable to prevent introspective cheat by #. syntax.
- Then, after simplifying expressions, we could pass the read expression
- through functions that would SUBSTitute proper symbols for the markers,
- from the quasiquote package if pretty-printing is to be supported,
- or otherwise from the CL package.
- Note that this would have to be interleaved with support for working
- inside vectors and other syntax. This is all very tricky
- and until further notice is left as an exercise to the intrepid reader.
- Thus, while the behaviour of our implementation isn't strictly correct,
- we don't go through the hassle of modifying it into something
- much less readable just for the sake of preventing code that would
- deliberately confuse the quasiquote engine.
- Now, if we imagine that some code were dynamically generated
- based on system introspection, that could contain some of our magic markers,
- then this code would have to be made safe for interaction with QUASIQUOTE;
- this might (or might not?) require making QUASIQUOTE 100% fool-proof.
-
-* This implementation simplifies quasiquoting of literals
- and other self-evaluating objects into the object itself,
- instead of a `(QUOTE ,object) expression.
- This is also the behaviour of the simplifier in CMUCL and SBCL,
- but some people have expressed concerns that it might not be
- strictly allowed in letter or spirit by the Common Lisp standards.
- We believe that our behaviour is correct in both letter and spirit;
- but in any case, a more literally correct (pun intended) behaviour
- with respect to the CL standards can be achieved by defining
- the feature QUASIQUOTE-QUOTES-LITERALS (untested).
-
-* The idea of making circular data-structures work within quasiquotation
- makes my head ache with overarching pain. I make no attempt to try that,
- and most conspicuously not in the simplifier. You're crazier than I am
- if you do it and do it right.
-
-PS: If you're able to follow this discussion, you impress me.
-Come join the TUNES project!
-
(:fullname "fare-matcher"
:depends-on
("packages" "matcher"
- "quasiquote" "pp-quasiquote" "quasiquote-readtable"
"clos-match" "mrd-extensions")
:build-depends-on ("/xcvb/xcvb-utils")
- :supersedes-asdf ("fare-matcher" "fare-quasiquote-readtable")))
+ :supersedes-asdf ("fare-matcher")))
:components
((:file "packages")
(:file "matcher")
- #-gcl ; it currently fails. quasiquote necessitates a big revamp anyway
- (:file "quasiquote")
- (:file "pp-quasiquote")
;;#-gcl ; 2.7.0-64.1 cannot defgeneric in a eval-now
(:file "clos-match")
(:file "mrd-extensions")))
+++ /dev/null
-;;; -*- Lisp -*-
-
-(asdf:defsystem :fare-quasiquote-readtable
- :depends-on (:named-readtables :fare-matcher)
- :components ((:file "quasiquote-readtable")))
"Lisp2-style Erlang/ML-like Pattern-Matcher for Common LISP")
(:export))
-(defpackage #:fare-quasiquote
- (:use #:fare-matcher #:fare-utils #:common-lisp)
- (:shadow #:list #:append #:nconc #:list* #:cons #:quote
- #:kwote #:quotep #:vector #:make-vector)
- (:documentation
- "Quasiquote implementation with and for pattern-matching")
- (:export #:quasiquote-expand #:quasiquote #:unquote #:unquote-splicing
- #:enable-quasiquote
- #:call-with-quasiquote-reader
- #:call-with-unquote-reader
- #:call-with-unquote-splicing-reader
- #:call-with-unquote-nsplicing-reader))
-
(defpackage #:fare-clos-match
#+openmcl (:shadowing-import-from #:ccl #:quit)
(:use #:common-lisp #:fare-utils #:fare-matcher
+++ /dev/null
-;;;; pretty-printing of backquote expansions
-
-#+xcvb (module (:depends-on ("quasiquote")))
-
-;;;; This software is derived from the CMU CL system via SBCL.
-;;;; CMU CL 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.
-
-(in-package :fare-quasiquote)
-
-(defun unparse-quasiquote-1 (form splicing)
- (ecase splicing
- ((nil)
- (list 'unquote form))
- (:append
- (list (list 'unquote-splicing form)))
- (:nconc
- (list (list 'unquote-nsplicing form)))))
-
-(defun unparse-quasiquote (form &optional splicing)
- "Given a lisp form containing the magic functions LIST, LIST*,
- APPEND, etc. produced by the backquote reader macro, will return a
- corresponding backquote input form. In this form, `,' `,@' and `,.' are
- represented by lists whose cars are UNQUOTE, UNQUOTE-SPLICING, and
- UNQUOTE-NSPLICING respectively, and whose cadrs are the form after the comma.
- SPLICING indicates whether a comma-escape return should be modified for
- splicing with other forms: a value of :APPEND or :NCONC meaning that an extra
- level of parentheses should be added."
- (cond
- ((atom form)
- (unparse-quasiquote-1 form splicing))
- ((not (null (cdr (last form))))
- ;; FIXME: this probably throws a recursive error
- (error "found illegal dotted quasiquote form: ~S" form))
- (t
- (case (car form)
- ((list cl:list)
- (mapcar #'unparse-quasiquote (cdr form)))
- ((list* cl:list*)
- (do ((tail (cdr form) (cdr tail))
- (accum nil))
- ((null (cdr tail))
- (nconc (nreverse accum)
- (unparse-quasiquote (car tail) :append)))
- (push (unparse-quasiquote (car tail)) accum)))
- ((append cl:append)
- (apply #'cl:append
- (mapcar (lambda (el) (unparse-quasiquote el :append))
- (cdr form))))
- ((nconc cl:nconc)
- (apply #'cl:append
- (mapcar (lambda (el) (unparse-quasiquote el :nconc))
- (cdr form))))
- ((cons cl:cons)
- (cl:cons (unparse-quasiquote (cadr form) nil)
- (unparse-quasiquote (caddr form) :append)))
- ((vector cl:vector)
- (coerce (unparse-quasiquote (cadr form)) 'cl:vector))
- ((quote cl:quote)
- (cond
- ((atom (cadr form)) (cadr form))
- ((and (consp (cadr form))
- (member (caadr form) *quasiquote-tokens*))
- (unparse-quasiquote-1 form splicing))
- (t (cons (unparse-quasiquote (list 'cl:quote (caadr form)))
- (unparse-quasiquote (list 'cl:quote (cdadr form)))))))
- (t
- (unparse-quasiquote-1 form splicing))))))
-
-(defun pprint-quasiquote (stream form &rest noise)
- (declare (ignore noise))
- (write-char #\` stream)
- (write (unparse-quasiquote form) :stream stream))
-
-(defun pprint-unquote (stream form &rest noise)
- (declare (ignore noise))
- (ecase (car form)
- ((unquote)
- (write-char #\, stream))
- ((unquote-splicing)
- (write-string ",@" stream))
- ((unquote-nsplicing)
- (write-string ",." stream)))
- (let ((output (with-output-to-string (s)
- (write (cadr form) :stream s
- :level (min 1 (or *print-level* 1))
- :length (min 1 (or *print-length* 1))))))
- (unless (= (length output) 0)
- (when (and (eql (car form) 'unquote)
- (or (char= (char output 0) #\.)
- (char= (char output 0) #\@)))
- (write-char #\Space stream))
- (write (cadr form) :stream stream))))
-
-;;; This is called by !PPRINT-COLD-INIT, fairly late, because
-;;; SET-PPRINT-DISPATCH doesn't work until the compiler works.
-;;;
-;;; FIXME: It might be cleaner to just make these be toplevel forms and
-;;; enforce the delay by putting this file late in the build sequence.
-(defun !backq-pp-cold-init ()
- (set-pprint-dispatch '(cons (eql list)) #'pprint-quasiquote)
- (set-pprint-dispatch '(cons (eql list*)) #'pprint-quasiquote)
- (set-pprint-dispatch '(cons (eql append)) #'pprint-quasiquote)
- (set-pprint-dispatch '(cons (eql nconc)) #'pprint-quasiquote)
- (set-pprint-dispatch '(cons (eql cons)) #'pprint-quasiquote)
- (set-pprint-dispatch '(cons (eql vector)) #'pprint-quasiquote)
-
- (set-pprint-dispatch '(cons (eql unquote)) #'pprint-unquote)
- (set-pprint-dispatch '(cons (eql unquote-splicing)) #'pprint-unquote)
- (set-pprint-dispatch '(cons (eql unquote-nsplicing)) #'pprint-unquote))
+++ /dev/null
-;;; -*- Mode: Lisp ; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
-;;; named readtables for fare-quasiquote
-;;; Copyright (c) 2011-2011 Fahree Reedaw <fare@tunes.org>
-;;; See README.quasiquote
-
-#+xcvb (module (:depends-on ("quasiquote" (:asdf "named-readtables"))))
-
-(in-package :fare-quasiquote)
-
-(eval-now
- (named-readtables:defreadtable :fare-quasiquote-mixin
- (:macro-char #\` #'read-read-time-backquote)
- (:macro-char #\, #'read-comma)
- (:macro-char #\# :dispatch)
- (:dispatch-macro-char #\# #\( #'read-hash-paren))
-
- (named-readtables:defreadtable :fare-quasiquote
- (:fuze :standard :fare-quasiquote-mixin)))
-
-;; (in-readtable :fare-quasiquote)
+++ /dev/null
-;;; -*- Mode: Lisp ; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
-;;; fare-matcher friendly implementation of Quasiquote
-;;; Copyright (c) 2002-2011 Fahree Reedaw <fare@tunes.org>
-;;; See README.quasiquote
-
-#+xcvb (module (:depends-on ("packages" "matcher")))
-
-(in-package :fare-quasiquote)
-
-(declaim (optimize (speed 1) (safety 3) (debug 3)))
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
-;;;; uncomment some of the lines below to disable according simplifications:
-;;(pushnew :quasiquote-quotes-literals *features*)
-;;(pushnew :quasiquote-at-macro-expansion-time *features*)
-
-;; the below instruction enables pattern-matching for the simplifier.
-(copy-function-matcher
- list cl:list
- list* cl:list*
- cons cl:cons
- quote cl:quote
- vector cl:vector)
-
-(defvar *quasiquote-tokens*
- '(unquote unquote-splicing unquote-splicing
- list list* append nconc cons vector n-vector knil))
-
-(make-single-arg-form quote kwote)
-(make-single-arg-form quasiquote)
-(make-single-arg-form unquote)
-(make-single-arg-form unquote-splicing)
-(make-single-arg-form unquote-nsplicing)
-(defun make-vector-form (&rest x) (list* 'vector x))
-(defun vector-form-p (x)
- (and (listp x) #|(alexandria:proper-list-p x)|# (eq (car x) 'vector)))
-
-(defmacro quote (x) (list 'cl:quote x))
-(defmacro quasiquote (x) (quasiquote-expand x))
-(defmacro unquote (x)
- (declare (ignore x))
- (error "unquote only allowed within quasiquote"))
-(defmacro unquote-splicing (x)
- (declare (ignore x))
- (error "unquote-splicing disallowed outside quasiquote"))
-(defmacro unquote-nsplicing (x)
- (declare (ignore x))
- (error "unquote-nsplicing disallowed outside quasiquote"))
-
-(define-symbol-matcher knil
- '#'(lambda (form)
- (or (null form)
- (and (quotep form) (null (single-arg form)))
- (m%fail))))
-(defparameter knil
- #+quasiquote-quotes-literals (kwote nil)
- #-quasiquote-quotes-literals nil)
-
-(defparameter *quasiquote-level* 0
- "current depth of quasiquote nesting")
-(defparameter *simplify* t
- "should we simplify backquoted expressions")
-
-(defun unquote-xsplicing-p (x)
- (or (unquote-splicing-p x) (unquote-nsplicing-p x)))
-
-(defun quasiquote-expand (x)
- (let ((*quasiquote-level* 0))
- (multiple-value-bind (top arg)
- (quasiquote-expand-0 x)
- (when (eq top 'unquote-splicing)
- (error ",@ after backquote in ~S" x))
- (when (eq top 'unquote-nsplicing)
- (error ",. after backquote in ~S" x))
- (quasiquote-expand-1 top arg))))
-
-(defun quasiquote-expand-0 (x)
- "Given an expression x under a backquote, return two values:
-1- a token identifying a topmost function to apply on
-2- an argument
-When combining backquoted expressions, tokens are used for simplifications."
- (cond
- ((null x)
- (values nil nil))
- ((literalp x)
- (values #+quasiquote-quotes-literals 'quote #-quasiquote-quotes-literals :literal x))
- ((or (symbolp x) (quotep x))
- (values 'quote x))
- ((unquote-splicing-p x)
- (values 'unquote-splicing (single-arg x)))
- ((unquote-nsplicing-p x)
- (values 'unquote-nsplicing (single-arg x)))
- ((unquotep x)
- (values 'unquote (single-arg x)))
- ((vector-form-p x)
- (multiple-value-bind (top contents) (quasiquote-expand-0 (cdr x))
- (values 'vector (quasiquote-expand-1 top contents))))
- ;;#+quasiquote-at-macro-expansion-time
- ((simple-vector-p x)
- (values 'vector (quasiquote-expand (coerce x 'cl:list))))
- ((quasiquotep x)
- ;; shouldn't be happening unless #+quasiquote-at-macro-expansion-time
- (quasiquote-expand-0 (quasiquote-expand (single-arg x))))
- ((consp x)
- (multiple-value-bind (atop a) (quasiquote-expand-0 (car x))
- (multiple-value-bind (dtop d) (quasiquote-expand-0 (cdr x))
- (when (eq dtop 'unquote-splicing)
- (error ",@ after dot"))
- (when (eq dtop 'unquote-nsplicing)
- (error ",. after dot"))
- (cond
- ((eq atop 'unquote-splicing)
- (if (null dtop)
- (if (unquote-xsplicing-p a)
- (values 'append (list a))
- (expand-unquote a))
- (values 'append
- (cond ((eq dtop 'append)
- (cons a d))
- (t (list a (quasiquote-expand-1 dtop d)))))))
- ((eq atop 'unquote-nsplicing)
- (if (null dtop)
- (if (unquote-xsplicing-p a)
- (values 'nconc (list a))
- (expand-unquote a))
- (values 'nconc
- (cond ((eq dtop 'nconc)
- (cons a d))
- (t (list a (quasiquote-expand-1 dtop d)))))))
- ((null dtop)
- (if (member atop '(quote :literal nil))
- (values 'quote (list a))
- (values 'list (list (quasiquote-expand-1 atop a)))))
- ((member dtop '(quote :literal))
- (if (member atop '(quote :literal nil))
- (values 'quote (cons a d))
- (values 'list* (list (quasiquote-expand-1 atop a)
- (quasiquote-expand-1 dtop d)))))
- (t (let ((qa (quasiquote-expand-1 atop a)))
- (if (member dtop '(list list*))
- (values dtop (cons qa d))
- (values 'list*
- (list qa (quasiquote-expand-1 dtop d))))))))))
- (t
- (error "unrecognized object in quasiquote"))))
-
-(defun expand-unquote (x)
- (cond
- ((null x)
- (values nil nil))
- ((literalp x)
- (values :literal x))
- ((symbolp x)
- (values 'unquote x))
- ((simple-vector-p x) ;; XXX - test this.
- (values 'vector (quasiquote-expand (coerce x 'cl:list))))
- ((not (consp x))
- (error "unrecognized object in unquote"))
- ((and (quotep x)
- (not (unquote-xsplicing-p (single-arg x))))
- (values 'quote (single-arg x)))
- ((member (car x) '(append list list* nconc))
- (values (car x) (cdr x)))
- ((eq (car x) 'cons)
- (values 'list* (cdr x)))
- (t (values 'unquote x))))
-
-(defun quasiquote-expand-1 (top x)
- "Given a top token and an expression, give the quasiquoting
-of the result of the top operation applied to the expression"
- (cond
- ((member top '(unquote :literal nil))
- x)
- ((eq top 'quote)
- (kwote x))
- ((eq top 'list*)
- (cond ((and (null (cddr x))
- (not (unquote-xsplicing-p (car x)))
- (not (unquote-xsplicing-p (cadr x))))
- (k-cons (car x) (cadr x)))
- ((unquote-xsplicing-p (car (last x)))
- (k-append
- (apply 'k-list (butlast x))
- (car (last x))))
- (t
- (apply 'k-list* x))))
- ((eq top 'vector)
- (k-vector x))
- (t
- (cons (ecase top
- ((list) 'list)
- ((append) 'append)
- ((nconc) 'nconc))
- x))))
-
-; we want our own tokens, but they must evaluate the usual way.
-(defsubst list (&rest r) (apply #'cl:list r))
-(defsubst append (&rest r) (apply #'cl:append r))
-(defsubst list* (&rest r) (apply #'cl:list* r))
-(defsubst nconc (&rest r) (apply #'cl:nconc r))
-(defsubst cons (x y) (cl:cons x y))
-(defsubst vector (&rest r) (apply #'cl:vector r))
-(defsubst make-vector (l) (coerce l 'simple-vector))
-(defsubst clobberable (x) x) ;; marks x as being unique and clobberable by nconc
-
-(defun k-vector (l) (list 'make-vector l))
-(defun k-list (&rest r) (cons 'list r))
-(defun k-append (&rest r) (cons 'append r))
-(defun k-list* (&rest r) (cons 'list* r))
-(defun k-cons (x y) (list 'cons x y))
-(defun insert (x) x)
-
-(defun list-extender (c)
- (case c
- ((cons list*) 'list*)
- ((list) 'list)
- (t (error "not a list constructor ~A" c))))
-
-(defun self-evaluating-p (x)
- (or (literalp x)
- (not (or (symbolp x) (combinationp x)
- #|#+quasiquote-at-macro-expansion-time|# (simple-vector-p x)
- ))))
-(defun constant-form-p (x)
- (or #-quasiquote-quotes-literals (self-evaluating-p x)
- (quotep x)))
-(defun all-constant-forms-p (l)
- (every #'constant-form-p l))
-(defun unfold-constant-form (x)
- (if (quotep x) (single-arg x) x))
-(defun unfold-constant-forms (l)
- (mapcar #'unfold-constant-form l))
-(defun protect-constant-form (x)
- (if (self-evaluating-p x) x (kwote x)))
-(defun protect-constant-forms (l)
- (mapcar #'protect-constant-form l))
-
-
-(define-macro-matcher quasiquote
- #'(lambda (x) (pattern-matcher (quasiquote-expand x))))
-
-;; Note: it would be a *very bad* idea to use quasiquote:quote
-;; in the expansion of the macro-character #\'
-
-(defun call-with-quasiquote-reader (thunk)
- (let ((*quasiquote-level* (1+ *quasiquote-level*)))
- (make-quasiquote (funcall thunk))))
-
-(defun call-with-unquote-reader (thunk)
- (let ((*quasiquote-level* (1- *quasiquote-level*)))
- (unless (>= *quasiquote-level* 0) (error "unquote outside quasiquote"))
- (make-unquote (funcall thunk))))
-
-(defun call-with-unquote-splicing-reader (thunk)
- (let ((*quasiquote-level* (1- *quasiquote-level*)))
- (unless (>= *quasiquote-level* 0) (error "unquote-splicing outside quasiquote"))
- (make-unquote-splicing (funcall thunk))))
-
-(defun call-with-unquote-nsplicing-reader (thunk)
- (let ((*quasiquote-level* (1- *quasiquote-level*)))
- (unless (>= *quasiquote-level* 0) (error "unquote-nsplicing outside quasiquote"))
- (make-unquote-nsplicing (funcall thunk))))
-
-(defun read-quasiquote (stream)
- (call-with-quasiquote-reader (lambda () (read stream t nil t))))
-
-(defun read-unquote (stream)
- (call-with-unquote-reader (lambda () (read stream t nil t))))
-
-(defun read-unquote-splicing (stream)
- (call-with-unquote-splicing-reader (lambda () (read stream t nil t))))
-
-(defun read-unquote-nsplicing (stream)
- (call-with-unquote-nsplicing-reader (lambda () (read stream t nil t))))
-
-(defun n-vector (n contents)
- (if (null n) (coerce contents 'simple-vector)
- (let ((a (make-array n :element-type t)))
- (when (and (null contents) (> n 0))
- (error "non-zero length vector with empty contents"))
- (loop for i below n with x
- do (unless (null contents) (setq x (pop contents)))
- do (setf (aref a i) x))
- (when contents
- (error "provided contents larger than declared vector length"))
- a)))
-
-(defun read-vector (stream n)
- ;; http://www.lisp.org/HyperSpec/Body/sec_2-4-8-3.html
- (let ((contents (read-delimited-list #\) stream t)))
- (if (> *quasiquote-level* 0)
- (make-unquote (list 'n-vector n (quasiquote-expand contents)))
- (n-vector n contents))))
-
-(defun read-read-time-backquote (stream char)
- (declare (ignore char))
- (values (macroexpand-1 (read-quasiquote stream))))
-(defun read-macroexpand-time-backquote (stream char)
- (declare (ignore char))
- (read-quasiquote stream))
-(defun read-backquote (stream char)
- #-quasiquote-at-macro-expansion-time (read-read-time-backquote stream char)
- #+quasiquote-at-macro-expansion-time (read-macroexpand-time-backquote stream char))
-(defun backquote-reader (expansion-time)
- (ecase expansion-time
- ((read) #'read-read-time-backquote)
- ((macroexpand) #'read-macroexpand-time-backquote)
- ((nil) #'read-backquote)))
-(defun read-comma (stream char)
- (declare (ignore char))
- (case (peek-char nil stream t nil t)
- ((#\@)
- (read-char stream t nil t)
- (read-unquote-splicing stream))
- ((#\.)
- (read-char stream t nil t)
- (read-unquote-nsplicing stream))
- (otherwise (read-unquote stream))))
-(defun read-hash-paren (stream subchar arg)
- (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)
- (when (eq expansion-time 'read)
- (set-dispatch-macro-character #\# #\( #'read-hash-paren readtable))
- t)
-
-);eval-when
-
-;;(trace quasiquote-expand quasiquote-expand-0 quasiquote-expand-1 expand-unquote)
-
common-lisp.net / users/frideau/fare-matcher.git / commitdiff
