Created
March 1, 2012 00:28
-
-
Save ijp/1946153 to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
#!r6rs | |
(library (toys quasiquote) | |
(export quasiquote | |
unquote | |
unquote-splicing | |
) | |
(import (except (rnrs) quasiquote unquote unquote-splicing)) | |
(define-syntax unquote | |
(lambda (stx) | |
(syntax-violation 'unquote | |
"unquote not allowed outside a quasiquote expression" | |
stx))) | |
(define-syntax unquote-splicing | |
(lambda (stx) | |
(syntax-violation 'unquote-splicing | |
"unquote-splicing not allowed outside a quasiquote expression" | |
stx))) | |
;; in order to be fully compliant quasiquote shouldn't cons unless | |
;; necessary, and punt to the implementation of quote, however I do | |
;; not do this for simplicity | |
(define-syntax quasiquote | |
(syntax-rules () | |
((quasiquote expr) | |
(quasiquote-helper expr ())))) | |
(define-syntax quasiquote-helper | |
(syntax-rules (quasiquote unquote unquote-splicing) | |
((quasiquote-helper (quasiquote expr) stack) | |
(list (quote quasiquote) | |
(quasiquote-helper expr (#f . stack)))) | |
((quasiquote-helper (unquote expr) ()) | |
expr) | |
((quasiquote-helper (unquote expr) (_ . rest)) | |
(list (quote unquote) | |
;; quasiquote-helper here so that multiple argument unquote | |
;; or unquote-splicing gives an error | |
(quasiquote-helper expr rest))) | |
((quasiquote-helper (unquote exprs ...) stack) | |
(syntax-violation 'unquote | |
"Multiple arguments to unquote only allowed in a list or vector" | |
(unquote exprs ...))) | |
((quasiquote-helper (unquote-splicing exprs ...) stack) | |
(syntax-violation 'unquote-splicing | |
"unquote-splicing forms only allowed in a list or vector" | |
(unquote-splicing exprs ...))) | |
((quasiquote-helper (car . cdr) stack) | |
(list-helper (car . cdr) stack)) | |
((quasiquote-helper #(elems ...) stack) | |
(vector-helper #(elems ...) stack)) | |
((quasiquote-helper expr stack) | |
(quote expr)))) | |
(define-syntax list-helper | |
(syntax-rules (quasiquote unquote unquote-splicing) | |
;; Single argument unquote needs to be handled as it can appear at | |
;; the end of a list, however multiple arguments and unquote | |
;; splicing do not, as there is no outer list to splice into | |
((list-helper (unquote expr) ()) | |
expr) | |
((list-helper (unquote expr) (_ . rest)) | |
(list (quote unquote) | |
(quasiquote-helper expr rest))) | |
((list-helper ((quasiquote expr) . cdr) stack) | |
(cons (quasiquote-helper (quasiquote expr) stack) | |
(list-helper cdr stack))) | |
;; unquote & unquote splicing in cars need to be handled here in | |
;; order to splice correctly | |
((list-helper ((unquote exprs ...) . cdr) ()) | |
(append (list exprs ...) | |
(list-helper cdr ()))) | |
((list-helper ((unquote . exprs) . cdr) (first . rest)) | |
;; needs to use list-helper on exprs, so that we can splice into | |
;; unquote/unquote-splicing forms | |
(cons (cons (quote unquote) (list-helper exprs rest)) | |
(list-helper cdr (first . rest)))) | |
((list-helper ((unquote-splicing exprs ...) . cdr) ()) | |
(append exprs ... | |
(list-helper cdr ()))) | |
((list-helper ((unquote-splicing . exprs) . cdr) (first . rest)) | |
(cons (cons (quote unquote-splicing) (list-helper exprs rest)) | |
(list-helper cdr (first . rest)))) ;; right? | |
;; otherwise just make sure each list element gets deal with at | |
;; the correct stack level | |
((list-helper (car . cdr) ()) | |
(cons (quasiquote-helper car ()) | |
(list-helper cdr ()))) | |
((list-helper (car . cdr) (first . rest)) | |
(cons (quasiquote-helper car rest) | |
(list-helper cdr (first . rest)))) | |
((list-helper () stack) | |
'()))) | |
(define-syntax vector-helper | |
(syntax-rules () | |
((vector-helper #(elems ...) stack) | |
;; Temporary solution, won't work correctly if 'unquote' is the | |
;; second last element | |
(list->vector | |
(list-helper (elems ...) stack))))) | |
) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment