Added npi.lisp.

Pascal J. Bourguignon [2013-12-27 05:27]
Added npi.lisp.
Filename
npi.lisp
diff --git a/npi.lisp b/npi.lisp
new file mode 100644
index 0000000..5d20fe5
--- /dev/null
+++ b/npi.lisp
@@ -0,0 +1,146 @@
+;;;; -*- 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