;;;; -*- mode:lisp;coding:utf-8 -*-
;;;;**************************************************************************
;;;;FILE:               npc.lisp
;;;;LANGUAGE:           Common-Lisp
;;;;SYSTEM:             Common-Lisp
;;;;USER-INTERFACE:     NONE
;;;;DESCRIPTION
;;;;
;;;;    Implemented a simple npc compiler  targetting the npvm.
;;;;
;;;;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-COMPILER"
  (:use "COMMON-LISP"
        "COM.INFORMATIMAGO.COMPILER-VS-INTERPRETER.NPVM")
  (:export
   "NP-COMPILE"
   "PROGN" "<-" "PRINT" "DUMP" "NEG" "+" "*" "-" "/"))

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

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

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

  (print expr)
  (neg expr)

  (dump))

(defun generate (program code &rest codes)
  (assert (every (function numberp) (cons code codes)))
  (dolist (code (cons code codes))
    (vector-push-extend code program (length program))))

(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-generate (expr variables program)
  (cond
    ((numberp expr) (generate program +pushi+ expr))
    ((symbolp expr) (generate program +pushn+ (variable-index variables expr)))
    ((atom expr) (error "Unexpected atom ~S" expr))
    (t (case (first expr)

         ((progn)
          (loop
            :for expr :in (rest expr)
            :do (np-generate expr variables program)))

         ((+ * - /)
          (check-arity 2 expr)
          (np-generate (second expr) variables program)
          (np-generate (third  expr) variables program)
          (generate program (case (first expr)
                              ((+) +add+)
                              ((*) +mul+)
                              ((-) +sub+)
                              ((/) +div+))))

         ((<-)
          (check-arity 2 expr)
          (unless (symbolp (second expr))
            (error "<- takes a variable as target, not ~S" (second expr)))
          (np-generate (third  expr) variables program)
          (np-generate (second expr) variables program)
          (generate program +store+))

         ((print)
          (check-arity 1  expr)
          (np-generate (second expr) variables program)
          (generate program +print+))

         ((neg)
          (check-arity 1  expr)
          (np-generate (second expr) variables program)
          (generate program +neg+))

         ((dump)
          (check-arity 0 expr)
          (generate program +dump+))

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


(defun collect-variables (expr)
  (let ((variables '()))
    (labels ((collect (expr)
               (cond
                 ((symbolp expr) (push expr variables))
                 ((atom expr))
                 (t (dolist (subexpr (rest expr))
                      (collect subexpr))))))
      (collect expr)
      (remove-duplicates variables))))

(defun variable-index (variables var)
  (position var variables))


(defun set-equal (a b) (and (subsetp a b) (subsetp b a)))
(defun test/collect-variables ()
  (assert (set-equal (collect-variables '(progn
                                          (<- var (neg expr))
                                          (* (+ 33 expr2) (/ 42 expr2))
                                          (print (- expr1 expr2))
                                          (dump)))
                     '(expr1 expr2 expr var)))
  :success)
(test/collect-variables)

(defun np-compile (expr)
  (let ((variables (collect-variables expr))
        (program (make-array 100 :adjustable t :fill-pointer 0)))
    (when (< +max-variables+ (length variables))
      (error "~D is too many variables, memory has only ~D slots."
             (length variables) +max-variables+))
    (np-generate expr variables program)
    (generate program +stop+)
    (values program variables)))

(defun np-disassemble (pgm)
  (let ((vm (make-vm :program pgm)))
    (loop
      :for pc := (vm-disassemble vm 0) :then (vm-disassemble vm pc)
      :while (< pc (length pgm)))))

#-(and)
(np-disassemble (np-compile
                 ;; 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))))

;;  0: (pushi 5)
;;  2: (pushi 5)
;;  4: (add)
;;  5: (pushn d)
;;  7: (store)
;;  8: (pushn d)
;; 10: (pushn d)
;; 12: (mul)
;; 13: (pushn c)
;; 15: (store)
;; 16: (pushn d)
;; 18: (pushn c)
;; 20: (mul)
;; 21: (pushn b)
;; 23: (store)
;; 24: (pushn d)
;; 26: (print)
;; 27: (pushn c)
;; 29: (print)
;; 30: (pushn b)
;; 32: (print)
;; 33: (pushi 4)
;; 35: (pushi 6)
;; 37: (pushi 9)
;; 39: (pushi 1)
;; 41: (pushi 0)
;; 43: (pushn d)
;; 45: (mul)
;; 46: (add)
;; 47: (pushn d)
;; 49: (mul)
;; 50: (add)
;; 51: (pushn d)
;; 53: (mul)
;; 54: (add)
;; 55: (pushn d)
;; 57: (mul)
;; 58: (add)
;; 59: (pushn a)
;; 61: (store)
;; 62: (pushn a)
;; 64: (print)
;; 65: (stop)

#-(and)
(vm-run (make-vm :program (np-compile
                           ;; 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))))
        :trace t)
;; prints:
;; 10
;; 100
;; 1000
;; 1964
;; --> 66
ViewGit