ls9.ls9

;;; LISP9 Derived Syntax and Functions
;;; Nils M Holm, 2018,2019
;;; In the public domain
;;;
;;; If your country does not have a concept like the public
;;; domain, the Creative Common Zero (CC0) licence applies,
;;; see https://creativecommons.org/publicdomain/zero/1.0/

nil t

(defun (cons x y) (cons x y))
(defun (car x) (car x))
(defun (cdr x) (cdr x))

(defun (caar x) (caar x))
(defun (cadr x) (cadr x))
(defun (cdar x) (cdar x))
(defun (cddr x) (cddr x))

(defun (caaar x) (car (caar x)))
(defun (caadr x) (car (cadr x)))
(defun (cadar x) (car (cdar x)))
(defun (caddr x) (car (cddr x)))
(defun (cdaar x) (cdr (caar x)))
(defun (cdadr x) (cdr (cadr x)))
(defun (cddar x) (cdr (cdar x)))
(defun (cdddr x) (cdr (cddr x)))

(defun (list . x) x)

; quasiquote (qquote) is not defined yet
(defmac (assert0 a)
	(list
		'if
		(list
			'eval
			(list 'quote a)
			)
		t
		(list
			'error
			(list
				'format
				(list
					'list
					(list 'quote 'assertion-failure)
					(list 'quote a)
					)
				)
			)
		)
	)

(assert0 (eq 'a 'a))

(assert0 (eq 1 1))

(assert0 (< 0 1))
(assert0 (<= 0 1))
(assert0 (<= 1 1))
(assert0 (= 1 1))
(assert0 (>= 1 1))
(assert0 (>= 2 1))
(assert0 (> 2 1))

(assert0 (< -1 0))
(assert0 (<= -1 0))
(assert0 (<= -1 -1))
(assert0 (= -1 -1))
(assert0 (>= -1 -1))
(assert0 (>= -1 -2))
(assert0 (> -1 -2))

(princ "All basic assertions passed!\n")

(defun (vector . x) (listvec x))
(defun (string . x) (liststr x))

(defun (rever a)
  (reconc a nil))

(defun (nrever a)
  (nreconc a nil))

(defmac (cond . cs)
  (if (null cs)
      nil
      (if (eq 'else (caar cs))
          (cons 'prog (cdar cs))
          (list 'if (caar cs)
                    (cons 'prog (cdar cs))
                    (cons 'cond (cdr cs))))))

(defmac (and . xs)
  (cond ((null xs) 't)
        ((null (cdr xs)) (car xs))
        (else (list 'if (car xs)
                        (cons 'and (cdr xs))
                        nil))))

(defmac (qquote x)
  (cond ((vectorp x)
          (list 'listvec
                (list 'qquote (veclist x))))
        ((not (pair x))
          (list 'quote x))
        ((eq 'unquote (car x))
          (cadr x))
        ((and (pair (car x))
              (eq 'unquote (caar x)))
          (list 'cons (cadar x)
                      (list 'qquote (cdr x))))
        ((and (pair (car x))
              (eq 'splice (caar x)))
          (list 'conc (cadar x)
                      (list 'qquote (cdr x))))
        (else
          (list 'cons (list 'qquote (car x))
                      (list 'qquote (cdr x))))))

(defmac (let bs x . xs)
  ((lambda (split)
     (setq split
           (lambda (bs vs as)
             (if (null bs)
                 (list vs as)
                 (split (cdr bs)
                        (cons (caar bs) vs)
                        (cons (cadar bs) as)))))
     (apply (lambda (vs as)
              @((lambda ,vs ,x . ,xs) . ,as))
            (split bs nil nil)))
   nil))

(defun (mapcar f a . b)
  (if (null b)
      (let ((m1 nil))
        (setq m1 (lambda (a)
                   (if (null a)
                       nil
                       (cons (f (car a))
                             (m1 (cdr a))))))
        (m1 a))
      (let ((m2 nil))
        (setq m2 (lambda (a b)
                   (if (null a)
                       nil
                       (cons (f (car a) (car b))
                             (m2 (cdr a) (cdr b))))))
        (m2 a (car b)))))

(defmac (labels bs x . xs)
  (let ((vs (mapcar car bs))
        (as (mapcar cadr bs)))
    (let ((ns (mapcar (lambda (v) (list v nil)) vs))
          (is (mapcar (lambda (v a) (list 'setq v a)) vs as)))
      @(let ,ns ,@is ,x . ,xs))))

(defmac (or . xs)
  (cond ((null xs) nil)
        ((null (cdr xs)) (car xs))
        (else @(if* ,(car xs)
                    (or . ,(cdr xs))))))

(defmac (cond . cs)
  (cond ((null cs) nil)
        ((null (cdar cs))
          @(if* ,(caar cs)
                (cond . ,(cdr cs))))
        ((eq '=> (cadar cs))
          (let ((g (gensym)))
            @(let ((,g ,(caar cs)))
               (if ,g (,(caddr (car cs)) ,g)
                   (cond . ,(cdr cs))))))
        ((eq 'else (caar cs))
          @(prog . ,(cdar cs)))
        ((null (cdr cs))
          @(if ,(caar cs)
               (prog . ,(cdar cs))))
        (else
          @(if ,(caar cs)
               (prog . ,(cdar cs))
               (cond . ,(cdr cs))))))

(defmac (case x . cs)
  (defun (cases x cs)
    (cond ((null cs) nil)
          ((eq 'else (caar cs))
            @(prog . ,(cdar cs)))
          (else
            @(if (memv ,x ',(caar cs))
                 (prog . ,(cdar cs))
                 ,(cases x (cdr cs))))))
  (let ((g (gensym)))
    @(let ((,g ,x))
       ,(cases g cs))))

(defmac (let* bs x . xs)
  (if (null bs)
      @(let () ,x . ,xs)
      @(let (,(car bs))
         (let* ,(cdr bs) ,x . ,xs))))

(defmac (let x0 x . xs)
  (if (symbolp x0)
      (let ((vs (mapcar car x))
            (as (mapcar cadr x)))
        @((labels ((,x0 (lambda ,vs . ,xs)))
                  ,x0) . ,as))
      (let ((vs (mapcar car x0))
            (as (mapcar cadr x0)))
        @((lambda ,vs ,x . ,xs) . ,as))))

(defmac (with bs x . xs)
  (let* ((vs  (mapcar car bs))
         (gs  (mapcar (lambda (x) (gensym)) bs))
         (as  (mapcar cadr bs))
         (set (mapcar (lambda (v a) @(setq ,v ,a)) vs as))
         (res (mapcar (lambda (v g) @(setq ,v ,g)) vs gs))
         (val (gensym)))
    @((lambda ,gs
        (unwind
          (lambda () (prog . ,res))
          (lambda ()
            ,@set
            ,x . ,xs))) . ,vs)))

(defmac (do bs tst . xs)
  (let ((fn (gensym))
        (vs (mapcar car bs))
        (as (mapcar cadr bs))
        (ss (mapcar cddr bs)))
    (let ((ss (mapcar (lambda (s v)
                        (if (null s) v (car s)))
                      ss vs)))
      @(labels
         ((,fn (lambda ,vs
                 (if ,(car tst)
                     (prog . ,(cdr tst))
                     (prog ,@xs (,fn . ,ss))))))
         (,fn . ,as)))))

(defun (fold f b a)
  (defun (fl a r)
    (if (null a)
        r
        (fl (cdr a)
            (f r (car a)))))
  (fl a b))

(defun (foldr f b a)
  (defun (fr a r)
    (if (null a)
        r
        (fr (cdr a)
            (f (car a) r))))
  (fr (rever a) b))

(defun (filter p a)
  (defun (fi a r)
    (cond ((null a) (nrever r))
          ((p (car a))
            (fi (cdr a) (cons (car a) r)))
          (else
            (fi (cdr a) r))))
  (fi a nil))

(defun (memq x a)
  (cond ((null a) nil)
        ((eq x (car a)) a)
        (else (memq x (cdr a)))))

(defun (mapcar f a . as)
  (defun (map f x)
    (if (null x)
        nil
        (cons (f (car x))
              (map f (cdr x)))))
  (defun (car* x) (map car x))
  (defun (cdr* x) (map cdr x))
  (defun (nil* x) (memq nil x))
  (defun (mapcar* as r)
    (if (nil* as)
        (nrever r)
        (mapcar* (cdr* as)
              (cons (apply f (car* as))
                    r))))
  (mapcar* (cons a as) nil))

(defun (foreach f a . as)
  (apply mapcar f a as)
  nil)

(defun (length ls)
  (defun (len a n)
    (cond ((null a) n)
          ((pair a) (len (cdr a) (+ 1 n)))
          (else (error "length: improper list" ls))))
  (len ls 0))

(defun (nth-tail n a)
  (if (= 0 n)
      a
      (nth-tail (- n 1) (cdr a))))

(defun (nth n a) (car (nth-tail n a)))

(defun (listp x)
  (defun (acyclicp x y)
     (cond ((eq x y) nil)
           ((null x))
           ((pair x)
             (or (null (cdr x))
                 (and (pair (cdr x))
                      (acyclicp (cddr x) (cdr y)))))
           (else nil)))
  (or (null x)
      (and (pair x)
           (acyclicp (cdr x) x))))

(defun (caaaar x) (caar (caar x)))
(defun (caaadr x) (caar (cadr x)))
(defun (caadar x) (caar (cdar x)))
(defun (caaddr x) (caar (cddr x)))
(defun (cadaar x) (cadr (caar x)))
(defun (cadadr x) (cadr (cadr x)))
(defun (caddar x) (cadr (cdar x)))
(defun (cadddr x) (cadr (cddr x)))
(defun (cdaaar x) (cdar (caar x)))
(defun (cdaadr x) (cdar (cadr x)))
(defun (cdadar x) (cdar (cdar x)))
(defun (cdaddr x) (cdar (cddr x)))
(defun (cddaar x) (cddr (caar x)))
(defun (cddadr x) (cddr (cadr x)))
(defun (cdddar x) (cddr (cdar x)))
(defun (cddddr x) (cddr (cddr x)))

(defun (eqv a b)
  (cond ((eq a b))
        ((and (fixp a)
              (fixp b)
              (= a b)))
        ((and (charp a)
              (charp b)
              (c= a b)))
        (else nil)))

(defun (equal a b)
  (defun (equvec a b)
    (and (= (vsize a) (vsize b))
         (let loop ((i (- (vsize a) 1)))
           (cond ((< i 0))
                 ((equal (vref a i) (vref b i))
                   (loop (- i 1)))
                 (else nil)))))
  (cond ((eq a b))
        ((and (pair a)
              (pair b)
              (equal (car a) (car b))
              (equal (cdr a) (cdr b))))
        ((and (stringp a)
              (stringp b)
              (s= a b)))
        ((and (vectorp a)
              (vectorp b)
              (equvec a b)))
        (else (eqv a b))))

(defun (memv x a)
  (cond ((null a) nil)
        ((eqv x (car a)) a)
        (else (memv x (cdr a)))))

(defun (member x a)
  (cond ((null a) nil)
        ((equal x (car a)) a)
        (else (member x (cdr a)))))

(defun (assq x a)
  (cond ((null a) nil)
        ((eq x (caar a)) (car a))
        (else (assq x (cdr a)))))

(defun (assv x a)
  (cond ((null a) nil)
        ((eqv x (caar a)) (car a))
        (else (assv x (cdr a)))))

(defun (assoc x a)
  (cond ((null a) nil)
        ((equal x (caar a)) (car a))
        (else (assoc x (cdr a)))))

(defmac (andb  x y . z) @(bitop  1 ,x ,y . ,z))
(defmac (xorb  x y . z) @(bitop  6 ,x ,y . ,z))
(defmac (orb   x y . z) @(bitop  7 ,x ,y . ,z))
(defmac (norb  x y . z) @(bitop  8 ,x ,y . ,z))
(defmac (eqvb  x y . z) @(bitop  9 ,x ,y . ,z))
(defmac (notb  x)       @(bitop 12 ,x 0))
(defmac (nandb x y . z) @(bitop 14 ,x ,y . ,z))
(defmac (shlb  x y . z) @(bitop 16 ,x ,y . ,z))
(defmac (shrb  x y . z) @(bitop 17 ,x ,y . ,z))
(defmac (asrb  x y . z) @(bitop 18 ,x ,y . ,z))

(defun (andb  x y . z) (apply bitop  1 x y z))
(defun (xorb  x y . z) (apply bitop  6 x y z))
(defun (orb   x y . z) (apply bitop  7 x y z))
(defun (norb  x y . z) (apply bitop  8 x y z))
(defun (eqvb  x y . z) (apply bitop  9 x y z))
(defun (notb  x)       (bitop 12 x 0))
(defun (nandb x y . z) (apply bitop 14 x y z))
(defun (shlb  x y . z) (apply bitop 16 x y z))
(defun (asrb  x y . z) (apply bitop 17 x y z))

(defun (evenp x) (= 0 (rem x 2)))

(defun (oddp x) (not (evenp x)))

(defun (gcd x y)
  (defun (gcd x y)
    (cond ((= 0 x) y)
          ((= 0 y) x)
          ((< x y) (gcd x (rem y x)))
          (else    (gcd y (rem x y)))))
    (gcd (abs x) (abs y)))

(defun (lcm x y)
  (let ((cd (gcd x y)))
    (abs (* cd (div x cd) (div y cd)))))

(defun (expt x y)
  (defun (square x) (* x x))
  (defun (expt2 x y)
    (cond ((= 0 y) 1)
          ((evenp y) (square (expt2 x (div y 2))))
          (else      (* x (square (expt2 x (div y 2)))))))
  (defun (nexpt y r)
    (cond ((= 0 y) r)
          (else (nexpt (- y 1) (* r x)))))
  (if (> y 20)
      (expt2 x y)
      (nexpt y 1)))

(defun (mod x y)
  (let ((r (rem x y)))
    (cond ((= 0 r) 0)
          ((eq (< x 0) (< y 0)) r)
          (else (+ y r)))))

(defun (scopy s)
  (substr s 0 (ssize s)))

(defun (terpri . p)
  (if (and (pair p)
           (pair (cdr p)))
      (error "terpri: too many arguments"))
  (apply writec #\nl p))

(defun (print . xs)
  (cond ((null xs) (princ "\n"))
        ((null (cdr xs))
          (prin (car xs))
          (princ "\n"))
        (else
          (prin (car xs))
          (writec #\sp)
          (apply print (cdr xs)))))

(defun (readln . p)
  (let loop ((c (apply readc p))
             (a nil))
    (cond ((eofp c)
            (if (null a)
                c
                (liststr (nrever a))))
          ((c= #\nl c)
            (liststr (nrever a)))
          (else
            (loop (apply readc p)
                  (cons c a))))))

(defun (with-infile s f)
  (let ((oi (inport))
        (i  (open-infile s)))
    (unwind
      (lambda ()
        (set-inport oi)
        (close-port i))
      (lambda ()
        (set-inport i)
        (f)))))

(defun (with-outfile s f)
  (let ((oo (outport))
        (o  (open-outfile s)))
    (unwind
      (lambda ()
        (set-outport oo)
        (close-port o))
      (lambda ()
        (set-outport o)
        (f)))))

(defun (with-inport s f)
  (let ((i (open-infile s)))
    (unwind
      (lambda ()
        (close-port i))
      (lambda ()
        (f i)))))

(defun (with-outport s f)
  (let ((o (open-outfile s)))
    (unwind
      (lambda ()
        (close-port o))
      (lambda ()
        (f o)))))

(def *unwind* nil)

(defun (catch x)
  (let ((r (catch*
             (lambda (c)
               (setq *unwind* (cons c *unwind*))
               (x c)))))
    (setq *unwind* (cdr *unwind*))
    r))

(defun (throw c v)
  (let loop ()
    (cond ((null *unwind*)
            (throw* c v))
          ((funp (car *unwind*))
            (let ((w (car *unwind*)))
              (setq *unwind* (cdr *unwind*))
              (w)
              (loop)))
          ((eq c (car *unwind*))
            (throw* c v))
          (else
            (setq *unwind* (cdr *unwind*))
            (loop)))))

(defun (unwind u f)
  (setq *unwind* (cons u *unwind*))
  (let ((v (f)) (w nil))
    (setq w (car *unwind*))
    (setq *unwind* (cdr *unwind*))
    (w)
    v))

(defmac (catch-errors v x . xs)
  (let ((g  (gensym))
        (r  (gensym))
        (et (gensym))
        (ev (gensym)))
    @(let ((,et *Errtag*)
           (,ev *Errval*))
       (let ((,r (catch*
                   (lambda (,g)
                     (setq *Errval*
                           ,(if (null v) g (car v)))
                     (setq *Errtag* ,g)
                     ,x . ,xs))))
         (setq *Errtag* ,et)
         (setq *Errval* ,ev)
         ,r))))

(defun (save)
  (if *imagefile*
      (dump-image *imagefile*)
      (error "save: no image loaded, use \"dump-image\"")))

(defun (cmdline) (cmdline))
(defun (errport) (errport))
(defun (inport) (inport))
(defun (outport) (outport))
(defun (gc) (gc))
(defun (gensym) (gensym))
(defun (obtab) (obtab))
(defun (quit) (quit))
(defun (symtab) (symtab))

(defun (abs x) (abs x))
(defun (alphac x) (alphac x))
(defun (atom x) (atom x))
(defun (catch* x) (catch* x))
(defun (char x) (char x))
(defun (charp x) (charp x))
(defun (charval x) (charval x))
(defun (close-port x) (close-port x))
(defun (ctagp x) (ctagp x))
(defun (constp x) (constp x))
(defun (delete x) (delete x))
(defun (downcase x) (downcase x))
(defun (dump-image x) (dump-image x))
(defun (eofp x) (eofp x))
(defun (existsp x) (existsp x))
(defun (fixp x) (fixp x))
(defun (flush x) (flush x))
(defun (format x) (format x))
(defun (funp x) (funp x))
(defun (inportp x) (inportp x))
(defun (liststr x) (liststr x))
(defun (listvec x) (listvec x))
(defun (load x) (load x))
(defun (lowerc x) (lowerc x))
(defun (mx x) (mx x))
(defun (mx1 x) (mx1 x))
(defun (not x) (not x))
(defun (null x) (null x))
(defun (numeric x) (numeric x))
(defun (open-infile x) (open-infile x))
(defun (outportp x) (outportp x))
(defun (pair x) (pair x))
(defun (set-inport x) (set-inport x))
(defun (set-outport x) (set-outport x))
(defun (ssize x) (ssize x))
(defun (stringp x) (stringp x))
(defun (strlist x) (strlist x))
(defun (symbol x) (symbol x))
(defun (symbolp x) (symbolp x))
(defun (symname x) (symname x))
(defun (syscmd x) (syscmd x))
(defun (untag x) (untag x))
(defun (upcase x) (upcase x))
(defun (upperc x) (upperc x))
(defun (veclist x) (veclist x))
(defun (vectorp x) (vectorp x))
(defun (vsize x) (vsize x))
(defun (whitec x) (whitec x))

(defun (div x y) (div x y))
(defun (eq x y) (eq x y))
(defun (nreconc x y) (nreconc x y))
(defun (rem x y) (rem x y))
(defun (reconc x y) (reconc x y))
(defun (reanme x y) (rename x y))
(defun (setcar x y) (setcar x y))
(defun (setcdr x y) (setcdr x y))
(defun (sfill x y) (sfill x y))
(defun (sref x y) (sref x y))
(defun (throw* x y) (throw* x y))
(defun (vfill x y) (vfill x y))
(defun (vref x y) (vref x y))

(defun (+ . x) (fold (lambda (x y) (+ x y)) 0 x))
(defun (* . x) (fold (lambda (x y) (* x y)) 1 x))
(defun (conc . x) (fold (lambda (x y) (conc x y)) nil x))
(defun (nconc . x) (fold (lambda (x y) (nconc x y)) nil x))
(defun (sconc . x) (fold (lambda (x y) (sconc x y)) "" x))
(defun (vconc . x) (fold (lambda (x y) (vconc x y)) #() x))

(defun (peekc . x)
  (cond ((null x)
          (peekc))
        ((null (cdr x))
          (peekc (car x)))
        (else
          (error "peekc: too many arguments"))))

(defun (read . x)
  (cond ((null x)
          (read))
        ((null (cdr x))
          (read (car x)))
        (else
          (error "read: too many arguments"))))

(defun (readc . x)
  (cond ((null x)
          (readc))
        ((null (cdr x))
          (readc (car x)))
        (else
          (error "readc: too many arguments"))))

(defun (bitop op x y . z)
  (fold (lambda (x y) (bitop op x y))
        x
        (cons y z)))

(defun (- x . y)
  (if (null y)
      (- x)
      (fold (lambda (x y) (- x y)) x y)))

(defun (max x . y)
  (if (null y)
      x
      (fold (lambda (x y) (max x y)) x y)))

(defun (min x . y)
  (if (null y)
      x
      (fold (lambda (x y) (min x y)) x y)))

(defun (error x . y)
  (cond ((null y)
          (error x))
        ((null (cdr y))
          (error x (car y)))
        (else
          (error "error: too many arguments"))))

(defun (mkstr x . y)
  (cond ((null y)
          (mkstr x))
        ((null (cdr y))
          (mkstr x (car y)))
        (else
          (error "mkstr: too many arguments"))))

(defun (mkvec x . y)
  (cond ((null y)
          (mkvec x))
        ((null (cdr y))
          (mkvec x (car y)))
        (else
          (error "mkstr: too many arguments"))))

(defun (numstr x . y)
  (cond ((null y)
          (numstr x))
        ((null (cdr y))
          (numstr x (car y)))
        (else
          (error "numstr: too many arguments"))))

(defun (strnum x . y)
  (cond ((null y)
          (strnum x))
        ((null (cdr y))
          (strnum x (car y)))
        (else
          (error "strnum: too many arguments"))))

(defun (open-outfile x . y)
  (cond ((null y)
          (open-outfile x))
        ((null (cdr y))
          (open-outfile x (car y)))
        (else
          (error "open-outfile: too many arguments"))))

(defun (prin x . y)
  (cond ((null y)
          (prin x))
        ((null (cdr y))
          (prin x (car y)))
        (else
          (error "prin: too many arguments"))))

(defun (princ x . y)
  (cond ((null y)
          (princ x))
        ((null (cdr y))
          (princ x (car y)))
        (else
          (error "princ: too many arguments"))))

(defun (writec x . y)
  (cond ((null y)
          (writec x))
        ((null (cdr y))
          (writec x (car y)))
        (else
          (error "writec: too many arguments"))))

(defun (%compare op a)
  (let loop ((a a))
    (cond ((null (cdr a)))
          ((op (car a) (cadr a))
            (loop (cdr a)))
          (else nil))))

(defun (< x . y)  (%compare (lambda (x y) (< x y)) (cons x y)))
(defun (<= x . y) (%compare (lambda (x y) (<= x y)) (cons x y)))
(defun (= x . y)  (%compare (lambda (x y) (= x y)) (cons x y)))
(defun (> x . y)  (%compare (lambda (x y) (> x y)) (cons x y)))
(defun (>= x . y) (%compare (lambda (x y) (>= x y)) (cons x y)))
(defun (c< x . y)  (%compare (lambda (x y) (c< x y)) (cons x y)))
(defun (c<= x . y) (%compare (lambda (x y) (c<= x y)) (cons x y)))
(defun (c= x . y)  (%compare (lambda (x y) (c= x y)) (cons x y)))
(defun (c> x . y)  (%compare (lambda (x y) (c> x y)) (cons x y)))
(defun (c>= x . y) (%compare (lambda (x y) (c>= x y)) (cons x y)))
(defun (s< x . y)  (%compare (lambda (x y) (s< x y)) (cons x y)))
(defun (s<= x . y) (%compare (lambda (x y) (s<= x y)) (cons x y)))
(defun (s= x . y)  (%compare (lambda (x y) (s= x y)) (cons x y)))
(defun (s> x . y)  (%compare (lambda (x y) (s> x y)) (cons x y)))
(defun (s>= x . y) (%compare (lambda (x y) (s>= x y)) (cons x y)))
(defun (si< x . y)  (%compare (lambda (x y) (si< x y)) (cons x y)))
(defun (si<= x . y) (%compare (lambda (x y) (si<= x y)) (cons x y)))
(defun (si= x . y)  (%compare (lambda (x y) (si= x y)) (cons x y)))
(defun (si> x . y)  (%compare (lambda (x y) (si> x y)) (cons x y)))
(defun (si>= x . y) (%compare (lambda (x y) (si>= x y)) (cons x y)))

(defun (sset x y z) (sset x y z))
(defun (substr x y z) (substr x y z))
(defun (subvec x y z) (subvec x y z))
(defun (vset x y z) (vset x y z))

(defun (apply f . as)
  (let loop ((as as)
             (a  nil))
    (cond ((null as)
            (error "apply: too few arguments"))
          ((null (cdr as))
            (if (pair (car as))
                (apply f (conc (nrever a) (car as)))
                (error "apply: expected list" (car as))))
          (else 
            (loop (cdr as)
                  (cons (car as) a))))))