evil.rot

;; -*- mode: scheme -*-
;; An evil version of compile.rot
;;
;; Note that this does not itself have the bug that a fully infected compiler
;; exhibits, where 'rotten compiles to "YOUR COMPILER HAS A
;; VIRUS!!1!eleventyone". Rather, it infects *other* compilers with this bug (in
;; a self-propagating manner).
;;
;; This is because I find writing a program that generates a complicated quine
;; to be easier than writing a complicated quine.

;; utility functions
(def (not x) (if x () 't))
(def (cadr x) (car (cdr x)))
(def (cddr x) (cdr (cdr x)))
(def (list . xs) xs)
(def (proper? l) (if (cons? l) (proper? (cdr l)) (not l)))
(def (rev-append x y) (if x (rev-append (cdr x) (cons (car x) y)) y))
(def (rev l) (rev-append l ()))
(def (append x y) (rev-append (rev x) y))
(def (len- i l) (if (cons? l) (len- (+ 1 i) (cdr l)) i))
(def (len l) (len- 0 l))
(def (index- i e l) (if l (if (eq? e (car l)) i (index- (+ 1 i) e (cdr l)))))
(def (index e l) (index- 0 e l))


;; A quine generator.
;;
;; This code is pretty inscrutable. I haven't yet figured out a cleaner way to
;; write it in Rotten. See quines.rkt for more readable versions (in Racket).
(def (replace-magic r e)
  (if (eq? 'MAGIC e) r
      (atom? e) e
      (eq? 'quote (car e)) e
      (cons (replace-magic r (car e)) (replace-magic r (cdr e)))))

(def (mlet name exp body) (list (list 'fn (list name) body) exp))

(def replace-magic-src
  ;; hooray for open-coding fixpoint combinators
  (mlet 'self '(fn (s r e)
                 (if (eq? 'MAGIC e) r
                     (atom? e) e
                     (eq? 'quote (car e)) e
                     (cons (s s r (car e)) (s s r (cdr e)))))
    '(fn (r e) (self self r e))))

(def (quine-magic x) (replace-magic (list 'quote x) x))
(def (quine name code)
  (quine-magic
    (mlet 'replace-magic replace-magic-src
      (mlet name '(replace-magic (list 'quote MAGIC) MAGIC)
        code))))


(def (compile-exp exp) (rev (compile exp '() '())))
(def (compile-program body) (rev (compile-body body '() '())))

(def (compile-body body env accum)
  ((if (cdr body)
     (fn (x) (compile-body (cdr body) env (cons '(pop) x)))
     (fn (x) x))
    (compile (car body) env accum)))

;; env is a list of local variables
(def (compile x env accum)
  (if
    ;; variable
    (symbol? x) (cons (var-access x (index x env)) accum)
    ;; literal
    (atom? x) (cons (list 'push x) accum)
    ;; special forms
    (eq? (car x) 'quote) (cons (list 'push (cadr x)) accum)
    (eq? (car x) 'fn)    (cons (fn-closure (cadr x) (cddr x) env) accum)
    (eq? (car x) 'if)    (compile-if (cdr x) env accum)
    (eq? (car x) 'def)   (compile-def (cadr x) (cddr x) env accum)
    ;; otherwise, function application
    (cons (list 'call (len (cdr x))) (compile-args x env accum))))

(def (compile-args xs env accum)
  (if (not xs) accum
    (compile-args (cdr xs) env (compile (car xs) env accum))))

(def (var-access var ix) (if ix (list 'access ix) (list 'get-global var)))

(def (fn-closure params body env)
  ;; produces (closure ARITY HAS-REST-PARAM CODE)
  (list 'closure (len params) (not (proper? params))
    (rev (compile-body body (append (params-env params) env) '()))))

(def (params-env ps)
  (if (cons? ps) (cons (car ps) (params-env (cdr ps)))
      ps         (list ps)))

(def (compile-if conds env accum)
  (if (not (cdr conds))
    (compile (car conds) env accum)
    (cons (list 'if
            (rev (compile (cadr conds) env '()))
            (rev (compile-if (cddr conds) env '())))
      (compile (car conds) env accum))))

(def (compile-def target body env accum)
  (if
    ;; defining a variable
    (atom? target)
      (cons (list 'set-global target) (compile (car body) env accum))
    ;; defining the compiler, infect it!
    (eq? (car target) 'compile)
      (compile-def 'compile (list (infect body)) env accum)
    ;; defining a function
    (cons (list 'set-global (car target))
      (cons (fn-closure (cdr target) body env) accum))))


;; The transformation we do is approximately:
;;
;;     (def (compile x env accum) BODY ...)
;;
;; --->
;;
;;     (def compile
;;       ((fn (f) (fn (x env accum) (f FILTERED-X env accum)))
;;        (fn (x env accum) BODY ...)))
;;
;; Except that the (fn (f) ....) is actually quine-ified.
;;
;; This is accomplished by calling (infect '(BODY ...))
;; which returns the quine-ified (fn (f) ...)
;;
;; Again, I apologize for the inscrutableness of this code.
(def (infect body)
  (list virus (cons 'fn (cons '(x env accum) body))))

(def virus
  (quine 'self
    '(fn (f)
       (fn (x env accum)
         (f
           (if
             (eq? x 'rotten) "YOUR COMPILER HAS A VIRUS!!1!eleventyone"
             (atom? x) x
             (atom? (cdr x)) x
             (atom? (cadr x)) x
             (if (eq? 'def (car x)) (eq? 'compile (car (cadr x))))
               (list 'def 'compile
                 (list self
                   (cons 'fn (cons (cdr (cadr x)) (cddr x)))))
             x)
           env accum)))))