#!/bin/sh
#| -*- scheme -*-
exec mzscheme -mf "$0" "$@"
|#

;; Written by Eli Barzilay: Maze is Life! (eli@barzilay.org)

(define (map-dot func obj)
  (cond ((null? obj) '())
        ((pair? obj) (cons (func (car obj)) (func (cdr obj))))
        (else        (func obj))))

(define (map-dot-flat func obj)
  (cond ((null? obj) '())
        ((pair? obj) (append (func (car obj)) (map-dot-flat func (cdr obj))))
        (else        (func obj))))

(define namespaces (list (make-namespace)))

(define (next-namespaces namespaces)
  (if (null? (cdr namespaces))
    (set-cdr! namespaces (list (make-namespace))))
  (cdr namespaces))

(define primitive-eval (current-eval))

#; ;; Simple version - no splicing at all
(define (meta-eval expr)
  (define (evaluate expr namespaces quasiquotes)
    (cond
     ;; Atoms is where the recursion stops.
     ((not (pair? expr))
      expr)
     ;; Normal cases - go recursively.
     ((not (and (list? expr) (= 2 (length expr)) (symbol? (car expr))
                (memq (car expr) '(quasiquote unquote))))
      (map-dot (lambda (x) (evaluate x namespaces quasiquotes)) expr))
     ;; Quasiquote - increase count.
     ((eq? (car expr) 'quasiquote)
      `(,(car expr) ,(evaluate (cadr expr) namespaces (+ quasiquotes 1))))
     ;; Unquote in a quasiquote - decrease count.
     ((not (zero? quasiquotes))
      `(,(car expr) ,(evaluate (cadr expr) namespaces (- quasiquotes 1))))
     ;; Unquote as a meta expression.
     (else
      (let ((expr (evaluate (cadr expr) (next-namespaces namespaces) 0)))
        (parameterize ((current-namespace (car namespaces)))
          (primitive-eval expr))))))
  (evaluate `(,'unquote ,expr) namespaces 0))

;; Complex version with unquote-splicing and the same for unquote with values
(define (meta-eval expr)
  (define (evaluate expr namespaces quasiquotes)
    (cond
     ;; Atoms is where the recursion stops.
     ((not (pair? expr))
      (list expr))
     ;; Normal cases - go recursively.
     ((not (and (list? expr) (= 2 (length expr)) (symbol? (car expr))
                (memq (car expr) '(quasiquote unquote unquote-splicing))))
      (list
       (map-dot-flat (lambda (x) (evaluate x namespaces quasiquotes)) expr)))
     ;; Quasiquote - increase count.
     ((eq? (car expr) 'quasiquote)
      `((,(car expr)
         ,(car (evaluate (cadr expr) namespaces (+ quasiquotes 1))))))
     ;; Unquote[-splicing] in a quasi-quote - decrease count, leave result.
     ((not (zero? quasiquotes))
      (if (eq? (car expr) 'unquote-splicing)
        ;; Unquote-splicing
        `((,(car expr)
           ,(car (evaluate (cadr expr) namespaces (+ quasiquotes 1)))))
        ;; Unquote - make it work with values.
        `((,'unquote-splicing
           (#%call-with-values
               (#%lambda ()
                 (#%begin
                  . ,(evaluate (cadr expr) namespaces (- quasiquotes 1))))
             list)))))
     ;; Unquote-splicing as a meta expression.
     ((eq? (car expr) 'unquote-splicing)
      (let ((exprs (evaluate (cadr expr) (next-namespaces namespaces) 0)))
        (parameterize ((current-namespace (car namespaces)))
          (primitive-eval `(begin . ,exprs)))))
     ;; Unquote as a meta expression.
     (else
      (let ((exprs (evaluate (cadr expr) (next-namespaces namespaces) 0)))
        (parameterize ((current-namespace (car namespaces)))
          (call-with-values (lambda () (primitive-eval `(begin . ,exprs)))
            list))))))
  (apply values (evaluate `(,'unquote ,expr) namespaces 0)))

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

(current-prompt-read
 (lambda ()
   (display "=> ")
   (read)))

(current-eval meta-eval)