(putd 'consp (lambda (x) (if (atom x) 'nil 't)))
(putd 'not (lambda (x) (if x 'nil 't)))
(putd 'null (lambda (x) (if x 'nil 't)))

(progn
  '(setq putd (lambda (sym fun) (set sym fun) sym))
  'putd)
(putd' getd (lambda (sym) (symeval sym)))

;; Boot a simple macro processor first

(putd 'get (lambda (s p . d)
             ((lambda (aux)
                (setq aux (lambda (q)
                            (if q
                                (if (eq (car q) p)
                                    (car (cdr q))
                                    (funcall aux (cdr (cdr q))))
                                (car d))))
                (funcall aux (plist s)))
              'nil)))

(putd 'put (lambda (s p v)
             ((lambda (aux)
                (setq aux (lambda (q)
                            (if q
                                (if (eq (car q) p)
                                    (rplaca (cdr q) v)
                                    (funcall aux (cdr (cdr q))))
                                (setplist s (cons p (cons v (plist s)))))))
                (funcall aux (plist s))
                s)
              'nil)))


(putd 'macro-function
      (lambda (sym &optional env)
        ((lambda (it)
           (if it
               it
               (if (boundp sym)
                   ((lambda (x)
                      (if (atom x) 'nil (if (eq (car x) 'macro) (cdr x) 'nil)))
                    (symeval sym))
                   'nil)))
         (env-lookup ':macro sym env))))

(putd 'comp
      (lambda (x e)
        (setq x (compiler-macro-expand x e))
        (if (symbolp x)
            ((lambda (it)
               (if it it x))
             (env-lookup ':var x e))
            (if (atom x) x
                (if (symbolp (car x))
                    ((lambda (cf)
                       (if cf
                           (funcall cf x e)
                           ((lambda (mf)
                              (if mf
                                  (comp (funcall mf x e) e)
                                  (comp-comb (car x) (cdr x) e)))
                            (macro-function (car x) e))))
                     (get (car x) 'compiler))
                    (comp-comb (car x) (cdr x) e))))))

(putd 'compiler-macro-expand
      (lambda (x e)
        ((lambda (f)
           (if f
               (progn
                 ((lambda (y)
                    (if (eq x y)
                        x
                        (compiler-macro-expand y e)))
                  (funcall f x e)))
               x))
         (if (consp x) (if (symbolp (car x)) (get (car x) 'compiler-macro))))))

(putd 'comp-comb
      (lambda (fun args env)
        ((lambda (fun-form args)
           (cons fun-form args))
         (comp-fun fun env)
         (comp-list args env))))

(putd 'comp-fun
      (lambda (x e)
        (if (symbolp x)
            ((lambda (it)
               (if it it x))
             (env-lookup ':fun x e))
            (if (if (atom x) 'nil (eq (car x) 'lambda))
                (comp-lam (car (cdr x)) (cdr (cdr x)) e)
                (if (if (atom x) 'nil (eq (car x) 'dot))
                    (cons (car x)
                          (cons (comp (car (cdr x)) e)
                                (cdr (cdr x))))
                    (if (if (atom x) 'nil (eq (car x) 'aref))
                        (cons (car x) (comp-list (cdr x) e))
                        (error '"Bad function" x)))))))

(putd 'comp-lam
      (lambda (p b e)
        (cons 'lambda (cons p (comp-list b e)))))

(putd 'comp-list
      (lambda (xs e)
        (if xs
            (cons (comp (car xs) e) (comp-list (cdr xs) e))
            nil)))

(putd 'env-lookup
      (lambda (kind name env)
        (declare (name env-lookup (kind name env)))
        (if (atom env) 'nil
            (if (if (eq kind (car (car env)))
                    (eq name (car (cdr (car env))))
                    'nil)
                (car env)
                (env-lookup kind name (cdr env))))))


;;; Some compilers.

;; We leave IF and PROGN alone for now.

(put 'quote 'compiler
     (lambda (w e)
       w))

(put 'function 'compiler
     (lambda (w e)
       (comp-fun (car (cdr w)) e)))

(put 'declare 'compiler
     ;; for now
     (lambda (w e) w))

;;; Install our new EVAL

(putd '%eval eval)
(putd 'eval (lambda (x)
              (declare (name eval (x)))
              (setq x (comp x nil))
              (%eval x)))

;;; Some initial macros

(putd 'lambda
      (cons 'macro (lambda (w e)
                     (list 'function w))))

(putd 'defun
      (cons 'macro (lambda (w e)
                     (apply (lambda (name args &rest body)
                              (list 'progn
                                    (list 'putd (list 'quote name)
                                          (cons 'lambda
                                                (cons args
                                                      (cons
                                                       (list 'declare
                                                             (list 'name name args))
                                                       body))))
                                    (list 'quote name)))
                            (cdr w)))))

(putd 'defmacro
      (cons 'macro (lambda (w e)
                     (apply (lambda (name args &rest body)
                              (list 'progn
                                    (list 'putd (list 'quote name)
                                          (list 'cons ''macro
                                                (cons 'lambda
                                                      (cons (list 'whole 'env)
                                                            (list
                                                             (list 'declare
                                                                   (list 'name name args))
                                                             (list 'apply
                                                                   (cons 'lambda (cons args body))
                                                                   '(cdr whole)))))))
                                    (list 'quote name)))
                            (cdr w)))))

;;; Ready to venture into sanity

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

(defun caaar (x) (car (car (car x))))
(defun caadr (x) (car (car (cdr x))))
(defun cadar (x) (car (cdr (car x))))
(defun caddr (x) (car (cdr (cdr x))))
(defun cdaar (x) (cdr (car (car x))))
(defun cdadr (x) (cdr (car (cdr x))))
(defun cddar (x) (cdr (cdr (car x))))
(defun cdddr (x) (cdr (cdr (cdr x))))

(defun caaaar (x) (car (car (car (car x)))))
(defun caaadr (x) (car (car (car (cdr x)))))
(defun caadar (x) (car (car (cdr (car x)))))
(defun caaddr (x) (car (car (cdr (cdr x)))))
(defun cadaar (x) (car (cdr (car (car x)))))
(defun cadadr (x) (car (cdr (car (cdr x)))))
(defun caddar (x) (car (cdr (cdr (car x)))))
(defun cadddr (x) (car (cdr (cdr (cdr x)))))
(defun cdaaar (x) (cdr (car (car (car x)))))
(defun cdaadr (x) (cdr (car (car (cdr x)))))
(defun cdadar (x) (cdr (car (cdr (car x)))))
(defun cdaddr (x) (cdr (car (cdr (cdr x)))))
(defun cddaar (x) (cdr (cdr (car (car x)))))
(defun cddadr (x) (cdr (cdr (car (cdr x)))))
(defun cdddar (x) (cdr (cdr (cdr (car x)))))
(defun cddddr (x) (cdr (cdr (cdr (cdr x)))))

(defun first (x) (car x))
(defun second (x) (cadr x))
(defun third (x) (caddr x))
(defun fourth (x) (cadddr x))
(defun fifth (x) (car (cddddr x)))
(defun sixth (x) (cadr (cddddr x)))
(defun seventh (x) (caddr (cddddr x)))
(defun eighth (x) (cadddr (cddddr x)))
(defun ninth (x) (car (cddddr (cddddr x))))
(defun tenth (x) (cadr (cddddr (cddddr x))))
(defun rest (x) (cdr x))

(defmacro and (&rest forms)
  (if forms
      (if (cdr forms)
          (list 'if (car forms) (cons 'and (cdr forms)) ''nil)
          (car forms))
      't))

(defmacro or (&rest forms)
  (if forms
      (if (cdr forms)
          (list (list 'lambda '(test cont)
                      '(if test test (funcall cont)))
                (car forms)
                (list 'lambda '() (cons 'or (cdr forms))))
          (car forms))
      'nil))

(defmacro cond (&rest x)
  (if (null x) 'nil
      (if (eq (car (car x)) 't)
          (if (cdr (car x))
              (cons 'progn (cdr (car x)))
              't)
          (if (null (cdr (car x)))
              (list 'or (car (car x)) (cons 'cond (cdr x)))
              (list 'if (car (car x))
                    (cons 'progn (cdr (car x)))
                    (cons 'cond (cdr x)))))))

(defun memq (x l)
  (cond ((endp l) nil)
        ((eq x (car l)) l)
        (t (memq x (cdr l)))))

(defun mapcar-1 (f q)
  (cond ((null q) nil)
        (t (cons (funcall f (car q)) (mapcar-1 f (cdr q))))))

(defun mapcar (fun lst &rest more)
  (cond ((null lst)
         nil)
        ((null more)
         (cons (funcall fun (car lst))
               (mapcar fun (cdr lst))))
        ((memq nil more)
         nil)
        (t
         (cons (apply fun (mapcar (function car) (cons lst more)))
               (apply (function mapcar) (cons fun (mapcar (function cdr) (cons lst more))))))))

(defun maplist (fun lst &rest more)
  (cond ((null lst)
         nil)
        ((null more)
         (cons (funcall fun lst)
               (maplist fun (cdr lst))))
        ((memq nil more)
         nil)
        (t
         (cons (apply fun (cons lst more))
               (apply (function maplist) (cons fun (mapcar (function cdr) (cons lst more))))))))

(defmacro backquote (form)
  (cond ((atom form)
         (list 'quote form))
        ((eq (car form) 'comma)
         (cadr form))
        ((and (consp (car form))
              (eq (caar form) 'comma-at))
         (list 'append (cadar form)
               (list 'backquote (cdr form))))
        (t
         (list 'cons
               (list 'backquote (car form))
               (list 'backquote (cdr form))))))

(defun append (&rest x)
  (cond ((null x) nil)
        ((null (cdr x)) (car x))
        ((null (cddr x)) (append-2 (car x) (cadr x)))
        (t (append-2 (car x) (apply #'append (cdr x))))))

(defun append-2 (p q)
  (cond ((null p) q)
        (t (cons (car p) (append-2 (cdr p) q)))))

(defmacro let (bindings &rest body)
  `((lambda ,(mapcar (lambda (binding)
                         ;; We check for syntax errors here
                         (cond ((symbolp binding)
                                binding)
                               ((atom binding)
                                (error "Not a symbol: ~S" binding))
                               ((null (cdr binding))
                                (car binding))
                               ((atom (cdr binding))
                                (error "Bad binding: ~S" binding))
                               ((null (cddr binding))
                                (car binding))
                               (t
                                (error "Bad binding: ~S" binding))))
                       bindings)
      ,@body)
    ,@(mapcar (lambda (binding)
                  (if (consp binding) (cadr binding) nil))
                bindings)))

(defmacro let* (bindings &rest body)
  (if (null bindings)
      `(progn ,@body)
      `(let (,(car bindings))
         (let* ,(cdr bindings) ,@body))))

(defun reverse (x)
  (let ((r nil))
    (while (not (endp x))
      (setq r (cons (car x) r))
      (setq x (cdr x)))
    r))

(defmacro when (test &rest body)
  `(if ,test (progn ,@body)))

(defmacro unless (test &rest body)
  `(if ,test nil (progn ,@body)))

;;;; Arithmetric

(defun + (&rest x) (if (null x) 0 (plus (car x) (apply '+ (cdr x)))))
(defun * (&rest x) (if (null x) 1 (times (car x) (apply '* (cdr x)))))
(defun - (x &rest m) (if (null m) (difference 0 x) (difference x (apply '+ m))))
(defun / (x &rest m) (if (null m) (quotient 1 x) (quotient x (apply '* m))))

(defun = (x &rest ys)
  (or (null ys) (and (eql 0 (difference x (car ys))) (apply '= ys))))

(defun <= (num &rest more)
  (or (null more) (and (not (lessp (car more) num)) (apply '<= more))))

(defun < (num &rest more)
  (or (null more) (and (lessp num (car more)) (apply '< more))))

(defun > (num &rest more)
  (or (null more) (and (lessp (car more) num) (apply '> more))))

(defun => (num &rest more)
  (or (null more) (and (not (lessp num (car more))) (apply '> more))))

(defun 1+ (x) (+ x 1))
(defun 1- (x) (- x 1))

(setq gensym-counter 1)

(defun gensym (&optional (prefix 'g))
  (maknam (append (explode prefix) (explode (setq gensym-counter (+ gensym-counter 1))))))

(defmacro define-compiler (name lambda-list . body)
  `(defun (compiler ,name) (whole env)
     (apply (lambda ,lambda-list ,@body)
            (cdr whole))))


;;;; -- CATCH, THROW, UNWIND-PROTECT ----------------------------------------------------------

(progn
  (js "globalThis.eval('function LispThrow(t,v) { this.tag = t; this.val = v; }')")
  "LispThrow")

(defmacro catch (tag &rest body)
  `(%catch ,tag #'(lambda () (progn ,@body))))

(defun %catch (tag cont)
  (funcall
   (js "(tag, cont) => {
           try {
               return cont();
           } catch (e) {
               if ((e instanceof LispThrow) && e.tag === tag)
                   return e.val;
               else
                   throw e; } }")
   tag cont))

(defun throw (tag value)
  (funcall
   (js "(x, y) => { throw new LispThrow(x, y); }")
   tag value))

(defmacro unwind-protect (protected-form &rest cleanup-forms)
  `(funcall
    (js "((p,c) => { try { return p(); } finally { c(); } })")
    (lambda () (progn ,protected-form))
    (lambda () (progn ,@cleanup-forms))))


;;;; -- BLOCK / RETURN-FROM -------------------------------------------------------------------

(defmacro define-compiler (name lambda-list &rest body)
  `(progn
     (put ',name 'compiler
          #'(lambda (whole env)
            (apply #'(lambda ,lambda-list ,@body)
                   (cdr whole))))
     ',name))

(define-compiler block (tag &rest body)
  (let ((gtag (gensym)))
    (comp
     `(let ((,gtag (cons nil nil)))
        (catch ,gtag
          ,@body))
     (cons (list ':block tag gtag)
           env))))

(define-compiler return-from (tag val)
  (let ((it (or (env-lookup ':block tag env)
                (error "No such BLOCK" tag))))
    (comp `(throw ,(third it) ,val) env)))

(defmacro return form?
  `(return-from nil ,(car form?)))


;;;; -- TABODY --------------------------------------------------------------------------------

(defun split-tagbody (tags-and-forms &optional curnames curpart parts)
  ;; Split the tagbody into its part. Returned is a list of
  ;;  (<list-of-tags> . <forms>)
  ;;
  (cond ((endp tags-and-forms)
         (reverse (cons (cons curnames (reverse curpart)) parts)))
        ((atom (car tags-and-forms))
         (if (null curpart)
             (split-tagbody (cdr tags-and-forms)
                            (cons (car tags-and-forms) curnames)
                            curpart
                            parts)
             (split-tagbody (cdr tags-and-forms)
                            (list (car tags-and-forms))
                            nil
                            (cons (cons curnames (reverse curpart)) parts))))
        (t
         (split-tagbody (cdr tags-and-forms)
                        curnames
                        (cons (car tags-and-forms) curpart)
                        parts))))

(define-compiler tagbody (&rest tags-and-forms)
  (let* ((parts
          (mapcar (lambda (x)
                    (cons (gensym 'L) x))
                  (split-tagbody tags-and-forms))))
    ;;
    (setq parts
          (maplist (lambda (q)
                     (append (car q)
                             (list
                              (cond ((or (null (cdr q))
                                         (null (cddr (cadr q))))
                                     ''nil)
                                    (t (caadr q))))))
                   parts))
    ;;
    (let ((c (gensym 'c))
          (catch-tag (gensym 'tag)))
      (mapcar (lambda (p)
                (mapcar (lambda (tag)
                          (setq env
                                (cons (list ':tag tag catch-tag (car p))
                                      env)))
                        (cadr p)))
              parts)
      ;;
      (comp
       `(let ((,catch-tag (cons nil nil))
              ,@(mapcar #'car parts))
          ,@(mapcar (lambda (p)
                      `(setq ,(car p) #'(lambda () (progn ,@(cddr p)))))
                    parts)
          (let ((,c ,(caar parts)))
            (while (setq ,c (catch ,catch-tag (funcall ,c))))))
       env))))

(define-compiler go (tag)
  (let ((it (or (env-lookup ':tag tag env)
                (error "No such tag" tag))))
    (comp `(throw ,(caddr it) ,(cadddr it)) env)))

(defmacro dotimes (i-n-res &body forms)
  (apply #'(lambda (i n &optional result)
             (let* ((toptag (gensym))
                    (limit (gensym)))
               `(block nil
                  (let ((,limit ,n) (,i 0))
                    (when (> ,limit 0)
                      (tagbody
                              ,toptag
                              ,@forms
                              (setq ,i (1+ ,i))
                              (when (< ,i ,limit) (go ,toptag))))
                    ,result))))
         i-n-res))

;;;; Compiler Macros

(defmacro define-compiler-macro (name arglist &rest body)
  (list 'progn
        (list 'put (list 'quote name) ''compiler-macro
              (parse-macro name arglist body))
        (list 'quote name)))

(defun parse-macro (name lambda-list body)
  (let ((whole-var (or (extract-&whole lambda-list) 'whole))
        (env-var (or (extract-&environment lambda-list) 'env)))
    (list 'lambda (list whole-var env-var)
          (list 'declare (list 'name name))
          (list 'apply (cons 'lambda
                             (cons (cons whole-var (cons env-var (remove-&whole-or-&environment lambda-list)))
                                   body))
                (list 'cons whole-var
                      (list 'cons env-var (list 'cdr whole-var)))))))

(defun extract-&whole (lambda-list)
  (cond ((atom lambda-list) nil)
        ((eq '&whole (car lambda-list)) (cadr lambda-list))
        (t (extract-&whole (cdr lambda-list)))))

(defun extract-&environment (lambda-list)
  (cond ((atom lambda-list) nil)
        ((eq '&environment (car lambda-list)) (cadr lambda-list))
        (t (extract-&environment (cdr lambda-list)))))

(defun remove-&whole-or-&environment (lambda-list)
  (cond ((atom lambda-list) nil)
        ((eq '&whole (car lambda-list)) (remove-&whole-or-&environment (cddr lambda-list)))
        ((eq '&environment (car lambda-list)) (remove-&whole-or-&environment (cddr lambda-list)))
        (t (cons (car lambda-list) (remove-&whole-or-&environment (cdr lambda-list))))))


(define-compiler-macro list (&rest xs)
  (cond ((null xs) ''nil)
        (t (list 'cons (car xs) (cons 'list (cdr xs))))))

(define-compiler-macro mapcar (&whole whole f list &rest more)
  (cond ((null more)
         (list 'mapcar-1 f list))
        (t
         whole)))

(defun reduce-1 (fun list)
  (cond ((null (cdr list))
         (car list))
        (t
         (reduce-1 fun (cons (funcall fun (car list) (cadr list)) (cddr list))))))

(define-compiler-macro + (&rest numbers)
  (cond ((null numbers) 0)
        ((null (cdr numbers)) `(plus 0 ,(car numbers)))
        (t (reduce-1 (lambda (x y) `(plus ,x ,y)) numbers))))

(define-compiler-macro * (&rest numbers)
  (cond ((null numbers) 1)
        ((null (cdr numbers)) `(plus 0 ,(car numbers)))
        (t (reduce-1 (lambda (x y) `(times ,x ,y)) numbers))))

(define-compiler-macro - (number &rest more)
  (cond ((null more) `(difference 0 ,number))
        ((null (cdr more)) `(difference ,number ,(car more)))
        (t `(- ,number (+ ,@more)))))

(define-compiler-macro / (number &rest more)
  (cond ((null more) `(quotient 1 ,number))
        ((null (cdr more)) `(quotient ,number ,(car more)))
        (t `(/ ,number (* ,@more)))))

(defun / (number &rest more)
  (cond ((null more) (/ 1 number))
        ((null (cdr more)) (/ number (car more)))
        (t (/ number (apply '* more)))))

(define-compiler-macro < (number &rest more)
  (cond ((and more (null (cdr more)))
         `(lessp ,number ,(car more)))
        (t
         (expand-relation (lambda (x y) `(lessp ,x ,y)) number more))))

(define-compiler-macro <= (number &rest more)
  (expand-relation (lambda (x y) `(not (lessp ,y ,x))) number more))

(define-compiler-macro > (number &rest more)
  (expand-relation (lambda (x y) `(lessp ,y ,x)) number more))

(define-compiler-macro >= (number &rest more)
  (expand-relation (lambda (x y) `(not (lessp ,x ,y))) number more))

(define-compiler-macro = (number &rest more)
  (expand-relation (lambda (x y) `(eqn ,x ,y)) number more))

(define-compiler-macro /= (number &rest more)
  (let ((g (gensym)))
    `(let ((,g ,number))
       (and ,@(mapcar (lambda (b)
                        `(not (eqn ,g ,b)))
                      more)))))

(defun expand-relation (prim number more)
  (cond ((null more)
         ;; Odd corner case, we must make this check for being a number.
         `(progn (plus ,number 0) 't))
        (t
         (let ((q (mapcar (lambda (n)
                            (list (gensym) n))
                          (cons number more))))
           `(let ,q
              (and
               ,@(mapcar (lambda (a b) (funcall prim (car a) (car b)))
                         q (cdr q))))))))


(defun fib (n)
  (cond ((< n 2) n)
        (t (+ (fib (- n 2)) (fib (- n 1))))))

;;;; ------------------------------------------------------------------------------------------

(setq console (js "console"))

(defun say (x)
  ((dot console log) x))