;;;; -*- mode:lisp;coding:utf-8 -*-
;;;;**************************************************************************
;;;;FILE:               npi.lisp
;;;;LANGUAGE:           Common-Lisp
;;;;SYSTEM:             Common-Lisp
;;;;USER-INTERFACE:     NONE
;;;;DESCRIPTION
;;;;
;;;;    Implements a simple npi interpreter.
;;;;
;;;;AUTHORS
;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
;;;;MODIFICATIONS
;;;;    2013-12-26 <PJB> Created.
;;;;BUGS
;;;;LEGAL
;;;;    AGPL3
;;;;
;;;;    Copyright Pascal J. Bourguignon 2013 - 2013
;;;;
;;;;    This program is free software: you can redistribute it and/or modify
;;;;    it under the terms of the GNU Affero General Public License as published by
;;;;    the Free Software Foundation, either version 3 of the License, or
;;;;    (at your option) any later version.
;;;;
;;;;    This program 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 Affero General Public License for more details.
;;;;
;;;;    You should have received a copy of the GNU Affero General Public License
;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>.
;;;;**************************************************************************

(defpackage "COM.INFORMATIMAGO.COMPILER-VS-INTERPRETER.NP-INTERPRETER"
  (:use "COMMON-LISP")
  (:export
   "NP-INTERPRET"
   "PROGN" "<-" "PRINT" "DUMP" "NEG" "+" "*" "-" "/"))

(in-package "COM.INFORMATIMAGO.COMPILER-VS-INTERPRETER.NP-INTERPRETER")

#-(and)
'(progn
  (<- var expr)

  (* expr1 expr2)
  (+ expr1 expr2)
  (/ expr1 expr2)
  (- expr1 expr2)

  (print expr)
  (neg expr)

  (dump))


(defun make-variables ()
  (make-hash-table))

(defun variables-binding (variables varname)
  (gethash varname variables 0))

(defun variables-bind (variables varname value)
  (setf (gethash varname variables) value))

(defun variables-dump (variables)
  (let ((vars '()))
    (maphash (lambda (k v) (push (list k v) vars)) variables)
    (format t "~{~20D = ~A~%~}" (sort vars (function string<) :key (function first)))))


(defun check-arity (n expr)
  (unless (= n (length (rest expr)))
    (error "~S is an operator that takes ~D argument~:*~P; ~S is invalid."
           (first expr) n expr)))

(defun np-interpret (expr &optional (variables (make-variables)))
  (cond
    ((numberp expr) expr)
    ((symbolp expr) (variables-binding variables expr))
    ((atom expr) (error "Unexpected atom ~S" expr))
    (t (case (first expr)

         ((progn)
          (loop
            :for expr :in (rest expr)
            :for last-result = (np-interpret expr variables)
            :finally (return last-result)))

         ((+ * - /)
          (check-arity 2 expr)
          (let ((a (np-interpret (second expr) variables))
                (b (np-interpret (third  expr) variables)))
            (case (first expr)
              ((+) (+ a b))
              ((*) (* a b))
              ((-) (- a b))
              ((/) (/ a b)))))

         ((<-)
          (check-arity 2 expr)
          (unless (symbolp (second expr))
            (error "<- takes a variable as target, not ~S" (second expr)))
          (let ((e (np-interpret (third  expr) variables)))
            (variables-bind variables (second expr) e)
            e))

         ((print)
          (check-arity 1 expr)
          (let ((e (np-interpret (second expr) variables)))
            (format t "~A~%" e)
            e))

         ((neg)
          (check-arity 1  expr)
          (let ((e (np-interpret (second expr) variables)))
            (- e)))

         ((dump)
          (check-arity 0 expr)
          (variables-dump variables)
          0)

         (otherwise
          (error "Invalid operator in ~S" expr))))))


(np-interpret
 ;; 5 5 + d !
 ;; d d * c !
 ;; d c * m !
 ;; d =
 ;; c =
 ;; m =
 ;; 4 6 9 1 0 d*+d*+d*+d*+ a ! a =
 '(progn
   (<- d (+ 5 5))
   (<- c (* d d))
   (<- m (* d c))
   (print d)
   (print c)
   (print m)
   (<- a (+ 4 (* (+ 6 (* (+ 9 (* (+ 1 (* 0 d)) d)) d)) d)))
   (print a)))
ViewGit