Porting fallintothis's quasiquote implementation

080qq.test

map (fn((input expected)) (test "" :valueof qq_expand.input :should be expected))
  pair:list 1 ''1   # force paren
            '(x)
            ''(x)

            '(,x)
            '(list x)

            '(,x ,y)
            '(list x y)

            '(,x ,y z)
            '(cons x (cons y '(z)))

            '(,x y ,z)
            '(list x 'y z)
  
            '(x ,x)
            '(list 'x x)

            '(,@x)
            'x

            '(x ,x ,@x foo ,(cadr x) bar ,(cdr x) baz ,@(cdr x) ,@x)
            '(cons 'x (cons x (append x (cons 'foo (cons (cadr x) (cons 'bar (cons (cdr x) (cons 'baz (append (cdr x) x)))))))))

            '(,x ... ,x)
            '(cons x x)

            '(,,x)
            '(list ,x)

            '(list ,,x)
            '(list 'list ,x)

            '(foo `(bar ,@',(map (fn(sym) `(baz ',sym ,sym)) lst)))
            '(list 'foo `'(bar ,(map (fn(sym) `(baz ',sym ,sym)) lst)))

            '(list ,@x)
            '(cons 'list x)

            '`(,,@x)
            '`(list ,@x)

080qq.wart

# Quasiquote (ported from an Arc port of GNU clisp 2.47's backquote.lisp).
#
# Background: http://arclanguage.org/item?id=16836
#
# $ git clone http://github.com/akkartik/wart.git
# $ cd wart
# download 080qq.wart and 080qq.test
# $ ./wart test
#
# If that doesn't work you'll need to recreate the state as of today:
#   $ git checkout 82cf603b82
#   $ ./wart test

mac qq(expr)
  (qq_expand expr)

# Recursive Expansion Engine

# The behaviour is more-or-less dictated by the Common Lisp HyperSpec's general
# description of backquote:
#
#   `atom/nil  -->  'atom/nil
#   `,expr     -->  expr
#   `,@expr    -->  error
#   ``expr     -->  `expr-expanded
#   `list-expr -->  expand each element & handle dotted tails:
#       `(x1 x2 ... xn)     -->  (append y1 y2 ... yn)
#       `(x1 x2 ... . xn)   -->  (append y1 y2 ... 'xn)
#       `(x1 x2 ... . ,xn)  -->  (append y1 y2 ... xn)
#       `(x1 x2 ... . ,@xn) -->  error
#     where each yi is the output of (qq-transform xi).
#
#  [NOTE] Mind that the above uses traditional CL syntax of "."s for dotted
#  tails; the "..."s represent 0 or more expressions.

def qq_expand(expr)
  (qq_appends qq_expand_list.expr)

def qq_expand(expr) :case atom?.expr
  (cons quote expr)

def qq_expand(expr) :case backquoted?.expr
  (cons backquote (qq_expand cdr.expr))

def qq_expand(expr) :case unquote_spliced?.expr
  ern "The syntax `,@" cdr.expr " is invalid"

def qq_expand(expr) :case unquoted?.expr
  cdr.expr

# Produce a list of forms suitable for append.
# Note: if we see 'unq or 'unqs in the middle of a list, we
# assume it's from dotting, since (a ... (unq b)) == (a unq b).  This
# is a "problem" if the user does something like `(a unq b c d), which we
# interpret as `(a ... ,b).

def qq_expand_list(expr)
  (cons (qq_transform car.expr) (qq_expand_list cdr.expr))

def qq_expand_list(expr) :case unquote_spliced?.expr
  ern "The syntax `([exprs] ... ,@" cdr.expr ") is invalid"

def qq_expand_list(expr) :case unquoted?.expr
  (list cdr.expr)

def qq_expand_list(expr) :case atom?.expr
  (list:cons quote expr)

def qq_expand_list(expr) :case nil?.expr
  nil

# Do the transformations for elements in qq_expand_list that aren't the dotted
# tail.  Also, handle nested quasiquotes.

def qq_transform(expr)
  (qq_list qq_expand.expr)

def qq_transform(expr) :case backquoted?.expr
  (qq_list (cons backquote (qq_expand cdr.expr)))

def qq_transform(expr) :case unquote_spliced?.expr
  cdr.expr

def qq_transform(expr) :case unquoted?.expr
  (qq_list cdr.expr)

def qq_list(expr)
  (qq_cons expr nil)

def qq_cons(expr1 expr2)
  # assume expr2 is non-splicing
  let operator (if splicing?.expr1 'dotted_list 'cons)
    (list operator expr1 expr2)

def qq_appends(exprs)
  (splicing_to_non:rreduce qq_append exprs)

def qq_append(expr1 expr2)
  (list 'append expr1 expr2)



# Expansion Optimizer

# This is mainly woven through qq_cons and qq_append.  It can run in a
# non-optimized mode (where lists are always consed at run-time), or
# optimizations can be done that reduce run-time consing / simplify the
# macroexpansion.  For example,
#   `(,(foo) ,(bar)) 
#      non-optimized --> (append (cons (foo) nil) (cons (bar) nil))
#      optimized     --> (list (foo) (bar))

# Optimization is enabled by default, but can be turned off for debugging.

<- Optimize_cons 1  Optimize_append 1

def toggle_optimize()
  zap not Optimize_cons
  zap not Optimize_append

# Test whether the given expr may yield multiple list elements.
# Note: not only does ,@x splice, but so does ,,@x (unlike in vanilla Arc)

def qq_cons(expr1 expr2) :case (and Optimize_cons quoted_non_splice?.expr1
                                                  quoted_non_splice?.expr2)
  (cons quote (list cdr.expr1 cdr.expr2))

def qq_cons(expr1 expr2) :case (and Optimize_cons (carif.expr2 = 'list))
  (dotted_list 'list expr1 cdr.expr2)

def qq_cons(expr1 expr2) :case (and Optimize_cons atom?.expr2)
  let operator (if splicing?.expr1 'dotted_list 'cons)
    (list operator expr1 expr2)

def qq_cons(expr1 expr2) :case (and Optimize_cons no.expr2)
  (list 'list expr1)

def qq_cons(expr1 expr2) :case (and Optimize_cons quoted?.expr1
                                                  no.expr2)
  (cons quote (list eval.expr1))



def qq_append(expr1 expr2) :case (and Optimize_append (carif.expr2 = 'append))
  (dotted_list 'append expr1 cdr.expr2)

def qq_append(expr1 expr2) :case (and Optimize_append quoted_non_splice?.expr1
                                                      proper?:cdr.expr1
                                                      (~unquoted? cdr.expr1))
  (rreduce (fn (x xs) (qq_cons (cons quote x) xs))
           (join cdr.expr1 list:splicing_to_non.expr2))

def qq_append(expr1 expr2) :case (and Optimize_append (carif.expr1 = 'list))
  (if
    single?.expr1
      expr2
    single?:cdr.expr1
      (qq_cons cadr.expr1 expr2)
    :else
      (cons 'dotted_list (append cdr.expr1 list.expr2)))

def qq_append(expr1 expr2) :case (and Optimize_append no.expr2)
  expr1

def qq_append(expr1 expr2) :case (and Optimize_append no.expr1)
  expr2



def splicing?(expr)
  (or unquote_spliced?.expr
      (and unquoted?.expr
           (splicing? cdr.expr)))

def splicing_to_non(expr)
  if splicing?.expr
    list 'append expr
    expr

def quoted_non_splice?(expr)
  (and quoted?.expr
       (~splicing? cdr.expr))

# Like join, except it can create dotted lists if the last arg is an atom

def append args
  (if
    no.args
      nil
    ~cdr.args
      car.args
    :else
      (let a car.args
        (if no.a
          (append @cdr.args)
          (cons car.a (append cdr.a @cdr.args)))))

# Like list, except that the last cons of the constructed list is dotted

def dotted_list xs
  if ~cdr.xs
    car.xs
    (rreduce cons xs)

def proper?(xs)
  (and list?.xs ~dotted?.xs)




# Primitives missing from wart.

def rreduce(f xs)
  if cddr.xs
    (f car.xs (rreduce f cdr.xs))
    (f @xs)

# not considering user-defined (object type ...)
alias atom? ~cons?

def dotted?(x)
  (aand list?.x
        cdr.x
        (or atom?.it
            dotted?.it))

alias carif cons?&car

# manipulating quote/unquote/splice
# You can't just say, "quote <- '" because ' by itself is not a legal s-expression.
<- quote (car ''1)
def quote?(_) (_ = quote)
alias quoted? quote?:carif
<- backquote (car '`(1))
def backquote?(_) (_ = backquote)
alias backquoted? backquote?:carif
<- unquote (car:cadr '`(,1))
def unquote?(_) (_ = unquote)
alias unquoted? unquote?:carif
<- unquote_splice (car:cadr '`(,@1))
def unquote_splice?(_) (_ = unquote_splice)
alias unquote_spliced? unquote_splice?:carif
<- splice (car '@1)
def splice?(_) (_ = splice)
alias spliced? splice?:carif