;;; -*- mode: scheme; coding: utf-8; -*-

;;;; Copyright (C) 2009, 2010, 2011
;;;; Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;; 
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;; 
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;



;;; Commentary:

;;; Scheme eval, written in Scheme.
;;;
;;; Expressions are first expanded, by the syntax expander (i.e.
;;; psyntax).  The evaluator itself only operates on the expanded
;;; Tree-IL forms.
;;;

;;; Code:



(define-module (ice-9 local-eval)
  #:use-module (system base pmatch)
  #:use-module (system base syntax)
  #:use-module (language tree-il)
  #:export (local-eval fexpr? the-environment))


;; Environment := (names vals . root)
;; Root := module | #f
;; Names := (name ...)
;; Vals := ((gensym . val) ...)

(define-syntax capture-env
  (syntax-rules ()
    ((_ env)
     (or env (current-module)))))

(define (bind name gensym val env)
  (pmatch env
    ((,names ,vals . ,root)
     (cons (cons name names) (cons (acons gensym val vals) root)))
    (,root
     (cons (cons name '()) (cons (acons gensym val '()) root)))
    (else (error "what!" env))))

(define (env-ref env name)
  (pmatch env
    ((,names ,vals . ,root)
     (let lp ((name names) (vals vals))
       (if (pair? names)
           (if (eq? (car names) name)
               (cdar vals)
               (lp (cdr names) (cdr vals)))
           (module-ref root name))))
    (,root (module-ref (or root (current-module)) name))))

(define (env-ref-var env sym)
  (pmatch env
    ((,names ,vals . ,root)
     (let ((pair (assq sym vals)))
       (if pair
           (cdr pair)
           (error "unbound lexical" env sym))))
    (else (error "unbound lexical" env sym))))

(define (env-set! env name val)
  (pmatch env
    ((,names ,vals . ,root)
     (let lp ((name names) (vals vals))
       (if (pair? names)
           (if (eq? (car names) name)
               (set-cdr! (car vals) val)
               (lp (cdr names) (cdr vals)))
           (module-set! root name val))))
    (,root (module-set! (or root (current-module)) name val))))

(define (env-set-var! env sym val)
  (pmatch env
    ((,names ,vals . ,root)
     (let ((pair (assq sym vals)))
       (if pair
           (set-cdr! pair val)
           (error "unbound lexical" env sym))))
    (else (error "unbound lexical" env sym))))

(define (env-local-binding env gensym)
  (pmatch env
    ((,names ,vals . ,root)
     (assq gensym vals))
    (else #f)))

(define fexpr? (make-object-property))

(define (the-environment env)
  env)

(set! (fexpr? the-environment) #t)

;; A unique marker for unbound keywords.
(define unbound-arg (list 'unbound-arg))

(define (wrong-number-of-args . args)
  (scm-error 'wrong-number-of-args
             "eval" "Wrong number of arguments"
             '() #f))

;; Procedures with rest, optional, or keyword arguments, potentially with
;; multiple arities, as with case-lambda.
(define (make-closure env req opt rest kw inits gensyms body alt)
  (let ((alt (or alt wrong-number-of-args)))
    (lambda %args
      (let lp ((env env)
               (args %args)
               (req req)
               (gensyms gensyms))
        (cond
         ((pair? req)
          ;; First, bind required arguments.
          (if (null? args)
              (apply alt %args)
              (lp (bind (car req) (car gensyms) (car args) env)
                  (cdr args)
                  (cdr req)
                  (cdr gensyms))))
         (kw
          ;; With keywords, we stop binding optionals (if any) at the first
          ;; keyword.
          (let lp ((env env)
                   (opt opt)
                   (gensyms gensyms)
                   (args args)
                   (inits inits))
            (if (pair? opt)
                (if (or (null? args) (keyword? (car args)))
                    (let ((def (eval (car inits) env)))
                      (lp (bind (car opt) (car gensyms) def env)
                          (cdr opt) (cdr gensyms) args (cdr inits)))
                    (lp (bind (car opt) (car gensyms) (car args) env)
                        (cdr opt) (cdr gensyms) '() (cdr inits)))
                ;; Finished with optionals.
                (let* ((aok (car kw))
                       (kw (cdr kw))
                       ;; Fill in kwargs  with "undefined" vals.
                       (env (let lp ((kw kw)
                                     ;; Also, here we bind the rest
                                     ;; arg, if any.
                                     (env (if rest
                                              (bind rest (car gensyms) args
                                                    env)
                                              env)))
                              (pmatch kw
                                (((,key ,name ,gensym) . ,kw)
                                 (lp kw
                                     (if (env-local-binding env gensym)
                                         env
                                         (bind name gensym unbound-arg
                                               env))))
                                (_ env))))
                       ;; Cdr past the rest gensym, if any.
                       (gensyms (if rest (cdr gensyms) gensyms)))
                  ;; Now scan args for keywords.
                  (let lp ((args args))
                    (if (and (pair? args) (pair? (cdr args))
                             (keyword? (car args)))
                        (let ((k (assq (car args) kw))
                              (v (cadr args)))
                          (if k
                              ;; Found a known keyword; set its value.
                              (env-set-var! env (caddr k) v)
                              ;; Unknown keyword.
                              (if (not aok)
                                  (scm-error 'keyword-argument-error
                                             "eval" "Unrecognized keyword"
                                             '() #f)))
                          (lp (cddr args)))
                        (if (pair? args)
                            (if rest
                                ;; Be lenient parsing rest args.
                                (lp (cdr args))
                                (scm-error 'keyword-argument-error
                                           "eval" "Invalid keyword"
                                           '() #f))
                            ;; Finished parsing keywords. Fill in
                            ;; uninitialized kwargs by evalling init
                            ;; expressions in their appropriate
                            ;; environment.
                            (let lp ((gensyms gensyms) (inits inits))
                              (if (pair? gensyms)
                                  (let ((b (env-local-binding env gensym)))
                                    (if (eq? (cdr b) unbound-arg)
                                        (set-cdr! b
                                                  (eval (car inits) env)))
                                    (lp (cdr gensyms) (cdr inits)))
                                  ;; Finally, eval the body.
                                  (eval body env))))))))))
         (else
          ;; Bind optionals and rest arg from arguments, and eval
          ;; body.
          (let lp ((env env)
                   (opt opt)
                   (gensyms gensyms)
                   (args args)
                   (inits inits))
            (if (pair? opt)
                (if (null? args)
                    (let ((def (eval (car inits) env)))
                      (lp (bind (car opt) (car gensyms) def env)
                          (cdr opt) (cdr gensyms) '() (cdr inits)))
                    (lp (bind (car opt) (car gensyms) (car args) env)
                        (cdr opt) (cdr gensyms) '() (cdr inits)))
                (if rest
                    (eval body (bind rest (car gensyms) args env))
                    (if (null? args)
                        (eval body env)
                        (apply alt %args)))))))))))

;; The "engine". EXP is a memoized expression.
(define (eval exp env)
  (record-case exp
    ((<void>) *unspecified*)

    ((<application> proc args)
     (let ((proc (eval proc env)))
       (if (fexpr? proc)
           (apply proc (capture-env env) args)
           (apply proc (map (lambda (x) (eval x env)) args)))))

    ((<conditional> test consequent alternate)
     (if (eval test env)
         (eval consequent env)
         (eval alternate env)))
          
    ((<primitive-ref> name)
     (module-ref the-root-module name))

    ((<lexical-ref> name gensym)
     (env-ref-var env gensym))
      
    ((<lexical-set> name gensym exp)
     (env-set-var! env gensym (eval exp env)))
          
    ((<module-ref> mod name public?)
     (module-ref ((if public? resolve-interface resolve-module) mod)
                 name))
          
    ((<module-set> mod name public? exp)
     (module-set! ((if public? resolve-interface resolve-module) mod)
                  name (eval exp env)))
          
    ((<toplevel-ref> name)
     (module-ref (current-module) name))
          
    ((<toplevel-set> name exp)
     (module-set! (current-module) name (eval exp env)))

    ((<toplevel-define> name exp)
     (module-define! (current-module) name (eval exp env)))
          
    ((<lambda> meta body)
     (eval body env))
          
    ((<lambda-case> req opt rest kw inits gensyms body alternate)
     (make-closure (capture-env env)
                   req opt rest kw inits gensyms body
                   (and alternate (eval alternate env))))
          
    ((<const> exp)
     exp)
          
    ((<sequence> exps)
     (let lp ((exps exps))
       (if (pair? (cdr exps))
           (begin
             (eval (car exps) env)
             (lp (cdr exps)))
           (eval (car exps) env))))
          
    ((<let> names gensyms vals body)
     (let lp ((env (capture-env env))
              (names names) (gensyms gensyms) (vals vals))
       (if (pair? names)
           (lp (bind (car names) (car gensyms) (eval (car vals) env) env)
               (cdr names) (cdr gensyms) (cdr vals))
           (eval body env))))
          
    ((<letrec> in-order? names gensyms vals body)
     (let ((env (let lp ((env (capture-env env))
                         (names names) (gensyms gensyms))
                  (if (pair? names)
                      (lp (bind (car names) (car gensyms) unbound-arg env)
                          (cdr names) (cdr gensyms))
                      env))))
       (if in-order?
           (let lp ((gensyms gensyms) (vals vals))
             (if (pair? gensyms)
                 (begin
                   (env-set-var! env (car gensyms) (eval (car vals) env))
                   (lp (cdr gensyms) (cdr vals)))
                 (eval body env)))
           (let lp ((gensyms gensyms)
                    (vals (map (lambda (x) (eval x env)) vals)))
             (if (pair? gensyms)
                 (begin
                   (env-set-var! env (car gensyms) (car vals))
                   (lp (cdr gensyms) (cdr vals)))
                 (eval body env))))))
      
    ((<fix> names gensyms vals body)
     (let lp ((env (capture-env env))
              (names names) (gensyms gensyms) (vals vals))
       (if (pair? names)
           (lp (bind (car names) (car gensyms) (eval (car vals) env) env)
               (cdr names) (cdr gensyms) (cdr vals))
           (eval body env))))
      
    ((<let-values> exp body)
     (call-with-values (eval exp env)
       (eval body env)))
          
    ((<dynwind> body winder unwinder)
     (dynamic-wind (eval winder env)
                   (lambda () (eval body env))
                   (eval unwinder env)))

    ((<dynlet> fluids vals body)
     (let* ((fluids (map (lambda (x) (eval x env)) fluids))
            (vals (map (lambda (x) (eval x env)) vals)))
       (let lp ((fluids fluids) (vals vals))
         (if (null? fluids)
             (eval body env)
             (with-fluids (((car fluids) (car vals)))
               (lp (cdr fluids) (cdr vals)))))))
          
    ((<dynref> fluid)
     (fluid-ref (eval fluid env)))
          
    ((<dynset> fluid exp)
     (fluid-set! (eval fluid env) (eval exp env)))
          
    ((<prompt> tag body handler)
     (call-with-prompt (eval tag env)
                       (lambda () (eval body env))
                       (eval handler env)))
          
    ((<abort> tag args tail)
     (apply abort-to-prompt (eval tag env)
            (map (lambda (x) (eval x env)) args)
            (eval tail env)))))
  
(define (env-lookup env name)
  (pmatch env
    ((,names ,vals . ,root)
     (let lp ((names names) (vals vals))
       (if (pair? names)
           (if (eq? (car names) name)
               (caar vals)
               (lp (cdr names) (cdr vals)))
           #f)))
    (_ #f)))

;; We let the macro expander take care of checking and expanding the
;; expression, but then we come back afterwards and turn top-level
;; references to local accesses.
;;
(define (fixup-locals exp env)
  (post-order!
   (lambda (x)
     (record-case x
       ((<toplevel-ref> name)
        (let ((sym (env-lookup env name)))
          (and sym
               (make-lexical-ref (tree-il-src x) name sym))))
       ((<toplevel-set> name exp)
        (let ((sym (env-lookup env name)))
          (and sym
               (make-lexical-set (tree-il-src x) name sym exp))))
       (else #f)))
   exp))

(define* (local-eval exp #:optional (env #f))
  (let ((exp ((module-transformer (current-module)) exp)))
    (eval (if env (fixup-locals exp env) exp) env)))