(provide 'backquote)
(defun backquote-list*-function (first &rest list)
"Like `list' but the last argument is the tail of the new list.
For example (backquote-list* 'a 'b 'c) => (a b . c)"
(if list
(let* ((rest list) (newlist (cons first nil)) (last newlist))
(while (cdr rest)
(setcdr last (cons (car rest) nil))
(setq last (cdr last)
rest (cdr rest)))
(setcdr last (car rest))
newlist)
first))
(defmacro backquote-list*-macro (first &rest list)
"Like `list' but the last argument is the tail of the new list.
For example (backquote-list* 'a 'b 'c) => (a b . c)"
(setq list (nreverse (cons first list))
first (car list)
list (cdr list))
(if list
(let* ((second (car list))
(rest (cdr list))
(newlist (list 'cons second first)))
(while rest
(setq newlist (list 'cons (car rest) newlist)
rest (cdr rest)))
newlist)
first))
(defalias 'backquote-list* (symbol-function 'backquote-list*-macro))
(defconst backquote-backquote-symbol '\`
"Symbol used to represent a backquote or nested backquote.")
(defconst backquote-unquote-symbol ',
"Symbol used to represent an unquote inside a backquote.")
(defconst backquote-splice-symbol ',@
"Symbol used to represent a splice inside a backquote.")
(defmacro backquote (arg)
"Argument STRUCTURE describes a template to build.
The whole structure acts as if it were quoted except for certain
places where expressions are evaluated and inserted or spliced in.
For example:
b => (ba bb bc) ; assume b has this value
`(a b c) => (a b c) ; backquote acts like quote
`(a ,b c) => (a (ba bb bc) c) ; insert the value of b
`(a ,@b c) => (a ba bb bc c) ; splice in the value of b
Vectors work just like lists. Nested backquotes are permitted."
(cdr (backquote-process arg)))
(defalias '\` (symbol-function 'backquote))
(defun backquote-process (s)
(cond
((vectorp s)
(let ((n (backquote-process (append s ()))))
(if (= (car n) 0)
(cons 0 s)
(cons 1 (cond
((not (listp (cdr n)))
(list 'vconcat (cdr n)))
((eq (nth 1 n) 'list)
(cons 'vector (nthcdr 2 n)))
((eq (nth 1 n) 'append)
(cons 'vconcat (nthcdr 2 n)))
(t
(list 'apply '(function vector) (cdr n))))))))
((atom s)
(cons 0 (if (or (null s) (eq s t) (not (symbolp s)))
s
(list 'quote s))))
((eq (car s) backquote-unquote-symbol)
(cons 1 (nth 1 s)))
((eq (car s) backquote-splice-symbol)
(cons 2 (nth 1 s)))
((eq (car s) backquote-backquote-symbol)
(backquote-process (cdr (backquote-process (nth 1 s)))))
(t
(let ((rest s)
item firstlist list lists expression)
(while (consp rest)
(if (eq (car rest) backquote-unquote-symbol)
(setq rest (list (list backquote-splice-symbol (nth 1 rest)))))
(setq item (backquote-process (car rest)))
(cond
((= (car item) 2)
(if (null lists)
(setq firstlist list
list nil))
(if list
(setq lists (cons (backquote-listify list '(0 . nil)) lists)))
(setq lists (cons (cdr item) lists))
(setq list nil))
(t
(setq list (cons item list))))
(setq rest (cdr rest)))
(if (or rest list)
(setq lists (cons (backquote-listify list (backquote-process rest))
lists)))
(setq expression
(if (or (cdr lists)
(eq (car-safe (car lists)) backquote-splice-symbol))
(cons 'append (nreverse lists))
(car lists)))
(if firstlist
(setq expression (backquote-listify firstlist (cons 1 expression))))
(if (eq (car-safe expression) 'quote)
(cons 0 (list 'quote s))
(cons 1 expression))))))
(defun backquote-listify (list old-tail)
(let ((heads nil) (tail (cdr old-tail)) (list-tail list) (item nil))
(if (= (car old-tail) 0)
(setq tail (eval tail)
old-tail nil))
(while (consp list-tail)
(setq item (car list-tail))
(setq list-tail (cdr list-tail))
(if (or heads old-tail (/= (car item) 0))
(setq heads (cons (cdr item) heads))
(setq tail (cons (eval (cdr item)) tail))))
(cond
(tail
(if (null old-tail)
(setq tail (list 'quote tail)))
(if heads
(let ((use-list* (or (cdr heads)
(and (consp (car heads))
(eq (car (car heads))
backquote-splice-symbol)))))
(cons (if use-list* 'backquote-list* 'cons)
(append heads (list tail))))
tail))
(t (cons 'list heads)))))