backquote.lisp

;; (defvar *unquote** (make-symbol "UNQUOTE*"))
(defvar *unquote** :unquote*)
(defvar *unquote-splicing** :unquote-splicing*)
(defvar *qq-quote* (make-symbol "QUOTE"))
(defvar *qq-list* (make-symbol "LIST"))
(defvar *qq-append* (make-symbol "APPEND"))
(defvar *quasiquote** 'quasiquote*)

;; Taken from On Lisp
(defun mappend (fn &rest lsts)
  (apply #'append (apply #'mapcar fn lsts)))

(defun quote-lists (expr)
  "Converts *QQ-LIST* statements which contain only quoted atoms and
lists eligibile for QUOTE-LISTS into *QQ-QUOTE* statements."
  (cond
	((and (listp expr) (eq (car expr) *qq-list*))
	 (loop for quoted-subexpr in (mapcar #'quote-lists (cdr expr))
		unless (and (listp quoted-subexpr) (eq (car quoted-subexpr) *qq-quote*))
		do (return (mapcar #'quote-lists expr))
		else
		collect (cadr quoted-subexpr) into quoted-subexprs
		finally (return (list *qq-quote* quoted-subexprs))))
	((listp expr)
	 ;(format t "map ~s: ~s~%" expr (mapcar #'quote-lists expr))
	 (mapcar #'quote-lists expr))
	(t expr)))

(defun flatten-appends (expr)
  "Flattens (*QQ-APPEND* (*QQ-LIST* ...) (*QQ-LIST* ...))
into (*QQ-LIST* ...)."
    (cond
	((and (listp expr) (eq (car expr) *qq-append*))
	 (loop for list-subexpr in (mapcar #'flatten-appends (cdr expr))
		unless (and (listp list-subexpr) (eq (car list-subexpr) *qq-list*))
		do (return (mapcar #'flatten-appends expr))
		else
		append (cdr list-subexpr) into list-subexprs
		finally (return (cons *qq-list* list-subexprs))))
	((listp expr)
	 ;(format t "map ~s: ~s~%" expr (mapcar #'quote-lists expr))
	 (mapcar #'quote-lists expr))
	(t expr)))

(defun reify (expr)
  "Converts EXPR from using the symbols defined for manipulation to
actual Lisp functions, potentially optimizing the code along the way."
  (let ((expr (quote-lists (flatten-appends expr))))
	(if (listp expr)
		(let ((x (mapcar #'reify (cdr expr))))
		  (cond
			((eq (car expr) *qq-quote*) (cons 'quote x))
			((eq (car expr) *qq-list*) (cons 'list x))
			((eq (car expr) *qq-append*) (cons 'append x))
			(t (cons (car expr) x))))
		expr)))

(defun length=p (list len)
  "Check whether the length of LIST is LEN."
  (if (or (eql len 0) (endp list))
	  (and (eql len 0) (endp list))
	  (length=p (cdr list) (1- len))))

;; length > len if we run out of len
;; length <= len if we get to (endp list)
(defun length>p (list len)
  "Check whether the length of LIST is greater than LEN."
  (and (consp list) (or (eql len 0) (length>p (cdr list) (1- len)))))

(defun check-args (expr arg-count name)
  (let ((expr-len (1+ arg-count)))
	(unless (length=p expr expr-len)
	  (error "~:[Not enough~;Too many~] arguments given to ~a" (length>p expr expr-len) (symbol-name name)))))
  
(defun process-expr (expr quote-level)
  (progn
	;(format t "Processing ~s at level ~a~%" expr quote-level)
	(let ((output
		   (cond
			 ;; If it's not a list, only splice in the quoted version of it.
			 ((atom expr) (list *qq-list* `(,*qq-quote* ,expr)))
			 ;; Any expression which goes (*unquote** QUOTE-LEVEL BODY) should be
			 ;; expanded to just BODY.
			 ((and (eq (car expr) *unquote**) (eql (cadr expr) quote-level))
			  (check-args expr 2 'unquote*)
			  (list *qq-list* (caddr expr)))
			 ;; And any expression which goes (*unquote-splicing** QUOTE-LEVEL
			 ;; BODY) should splice BODY into the expression
			 ((and (eq (car expr) *unquote-splicing**) (eql (cadr expr) quote-level))
			  (check-args expr 2 'unquote-splcing*)
			  ;(format t "splice exprs: ~s ~s~%" expr (caddr expr))
			  (caddr expr))
			 ;; If it's a quasiquote* call itself, then do this level's
			 ;; expansion on its argument and wrap the result in a quasiquote*
			 ;; call
			 ((eq (car expr) *quasiquote**)
			  (check-args expr 1 'quasiquote*)
			  (list *qq-list* `(,*qq-quote* (,*quasiquote** ,(cadar (quote-lists (process-expr (cadr expr) (1+ quote-level))))))))
			 ;; If it's some other kind of list, expand the sublists and put a
			 ;; call to LIST in front of it. Note: will need to fold later, so
			 ;; as to allow splicing.
			 ((listp expr)
			  ;(format t "mappend ~s~%" `(,*qq-append* ,@(mapcar (lambda (x) (process-expr x quote-level)) expr)))
			  `(,*qq-append* ,@(mapcar (lambda (x) (process-expr x quote-level)) expr))))))
	  ;(format t "Processed ~s to ~%  ~s~%" expr output)
	  output)))

(defmacro quasiquote* (body)
  (reify (cadr (process-expr body 1))))

(defun |#`-reader| (stream sub-char numarg)
  (declare (ignore sub-char numarg))
  (list *quasiquote** (read stream t nil t)))

(defun |#,-reader| (stream sub-char numarg)
  (declare (ignore sub-char))
  (unless numarg (setq numarg 1))
  (if (eql (peek-char nil stream) #\@)
	  (progn
		(read-char stream)
		(list *unquote-splicing** numarg (read stream t nil t))
		)
	  (list *unquote** numarg (read stream t nil t))))

(set-dispatch-macro-character
 #\# #\` #'|#`-reader|)

(set-dispatch-macro-character
 #\# #\, #'|#,-reader|)