;; -*- Mode: Lisp; -*-
;; ---------------------------------------------------------------------------
;;     Title: Nolangelang #6
;;   Created: 2022-08-08
;;    Author: Gilbert Baumann <gilbert@smaragd.localdomain>
;;   License: MIT style (see below)
;; ---------------------------------------------------------------------------
;;;  (c) copyright 2022 by Gilbert Baumann

;;  Permission is hereby granted, free of charge, to any person obtaining
;;  a copy of this software and associated documentation files (the
;;  "Software"), to deal in the Software without restriction, including
;;  without limitation the rights to use, copy, modify, merge, publish,
;;  distribute, sublicense, and/or sell copies of the Software, and to
;;  permit persons to whom the Software is furnished to do so, subject to
;;  the following conditions:
;; 
;;  The above copyright notice and this permission notice shall be
;;  included in all copies or substantial portions of the Software.
;; 
;;  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;  EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;  MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 
;;  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
;;  CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
;;  TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
;;  SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

(defpackage :nonamelang
  (:shadow
   #:eval))

(in-package :nonamelang)

;;;; -- Overview ------------------------------------------------------------------------------

;; Nonamelang is a simple language inspired by vms14, PostScript, and
;; Scheme.

;; The virtual machine has a two stacks: A value stack and a control
;; stack. The value stack is under the control of the programmer, while
;; the control is not used by the VM to implement procedure call and is
;; not directly accessible to the programmer.

;; Further there always is a lexical environment which is a mapping of
;; symbols to values.

;; The machine executes a sequence of instructions. Each instruction is
;; either:

;;  '<object> or (QUOTE <object>)
;;
;;    The object is pushed onto the stack
;;
;; #'(insn-1 ... insn-n) or (FUNCTION (insn-1 ... insn-n))
;;
;;    Creates a new closure and pushes it onto the stack. The object
;;    returned when subject to the EVAL operator executes the
;;    instructions in order while the lexical environment is set the
;;    very same lexical environment at the time this closure was
;;    created.
;;
;;  <boolean> <consequence> IF
;;
;;    If the boolean value <boolean> is non-NIL, <consequence> is
;;    executed before continuing execution. In any case both arguments
;;    are popped. <consequence> must be a closure.
;;
;;  <boolean> <consequence> <alternative> IFELSE
;;
;;    If the boolean value <boolean> is non-NIL, <consequence> is
;;    executed. Otherwise <alternative> is executed. In any case all
;;    three arguments are popped. Both <consequence> and <alternative>
;;    must be a closure.
;;
;;  <closure> EVAL
;;
;;    Executes all instructions in the closure <closure> in place of
;;    EVAL. While the instructions of the closure are executed the
;;    lexical environment is set to the lexical environment that closure
;;    captured.
;;
;;  <any-n> ... <any-0> <k> NTH -> <any-k>
;;
;;    Pushes the k'th stack element.
;;
;;  <any-1> ... <any-n> <keep-1> ... <keep-k> <n> <k> SKIP
;;  -> <keep-1> ... <keep-k>
;;
;;    Keeps the topmost `k' stack elements while pulling 'n' from
;;    bnenath.
;;
;;    Examples
;;
;;        'a 'b 'c 'd 2 1 skip  -> A D
;;        'a 'b 'c 'd 1 0 skip  -> A B C
;;        'a 'b 'c 'd 1 1 skip  -> A B D
;;
;;  <symbol> <closure> DEF              Defines a new word
;;  <symbol> GETD                       Get a words definition or NIL
;;
;;  '(<sym-1> ... <sym-n>) BIND
;;    Bind <sym-1> .. <sym-n> in current lexical environment.
;;
;;  <symbol> SET                        Set a symbol in lexical environment.
;;
;;  <list> CLOSE
;;
;;    Turns a list of instructions into a closure.
;;
;;  <symbol>
;;
;;    The symbol is first looked up in the current lexical environment.
;;    If it is bound and thus found its value is pushed.
;;
;;    Othewise, the symbol is looked up in the global vocabulary and if
;;    found the machine executes the definition in place of <symbol> and
;;    when done continues executing.
;;
;; Anything else is pushed as is.

;;;; -- Implementation ------------------------------------------------------------------------

(defvar *stack* nil
  "Our stack")

(defvar *vocabulary*
  (make-hash-table :test 'eq)
  "Hashtable mapping symbols to closure objects for globally defined words.")

(defstruct closure
  proc                                  ;The code to execute as a list
  env)                                  ;The captured lexical environment

(defun %pop ()
  "Pop one value off our machine stack, complain if there is nothing
left to pop."
  (unless *stack* (error "Stack underflow"))
  (pop *stack*))

(defun eval (proc &optional env)
  "Executes all the elements of the list `proc' with the lexical
  environment `env' which is an alist."
  (do ()
      ((null proc))
    (labels ((invoke (thing)
               (cond ((closure-p thing)
                      (invoke-1 (closure-proc thing) (closure-env thing)))
                     (t
                      (error "Cannot invoke ~S" thing))))
             (invoke-1 (next-proc next-env)
               (cond ((null proc)
                      ;; This is a tail call, just loop by setting our current proc to the
                      ;; one to invoke.
                      (setq proc next-proc
                            env  next-env))
                     (t
                      ;; No luck, must recurse
                      (eval next-proc next-env)))))
      (let ((word (pop proc)))
        (case word
          ;; Control
          ((if)
           (multiple-value-bind (cons cond) (values (%pop) (%pop))
             (when cond (invoke cons))))
          ((ifelse)
           (multiple-value-bind (alt cons cond) (values (%pop) (%pop) (%pop))
             (invoke (if cond cons alt))))
          ((eval)
           (invoke (%pop)))
          ;; Words
          ((def)
           (multiple-value-bind (body name) (values (%pop) (%pop))
             (setf (gethash name *vocabulary*) body)))
          ((getd)
           (push (gethash (%pop) *vocabulary*) *stack*))
          ;; Stack
          ((nth)  (push (nth (%pop) *stack*) *stack*))
          ((skip)
           (multiple-value-bind (nkeep npop) (values (%pop) (%pop))
             (if (zerop nkeep)
                 (setf *stack* (nthcdr (+ npop nkeep) *stack*))
                 (setf (cdr (nthcdr (1- nkeep) *stack*)) (nthcdr (+ npop nkeep) *stack*)))))
          ;; Lexicals
          ((bind)
           (multiple-value-bind (vars) (%pop)
             (dolist (sym (reverse vars))
               (push (cons sym (%pop)) env))))
          ((set)
           (multiple-value-bind (sym val) (values (%pop) (%pop))
             (let ((q (assoc sym env)))
               (unless q
                 (error "Undefined symbol: ~S" sym))
               (setf (cdr q) val))))
          ((close)
           (push (make-closure :proc (%pop) :env env) *stack*))
          ;;
          ;; Primitives
          ;;
          ;; nullary
          ((gensym)
           (push (funcall word) *stack*))
          ;; unary
          ((atom consp car cdr symbolp numberp princ prin1 print not
                 intern)
           (push (funcall word (%pop)) *stack*))
          ;; binary
          ((+ * / - mod rem floor ceiling logior logxor lognot logand
              eq eql equal = < > <= >= /=
              rplaca rplacd cons)
           (multiple-value-bind (b a) (values (%pop) (%pop))
             (push (funcall word a b) *stack*)))
          ;;
          ((print-stack)
           (print `(stack = ,*stack*))
           (force-output)
           (sleep 1))
          ((format) (push (apply #'format (%pop)) *stack*))
          ;;
          (t
           (cond ((symbolp word)
                  (let ((q (assoc word env)))
                    (if q (push (cdr q) *stack*)
                        (multiple-value-bind (proc win) (gethash word *vocabulary*)
                          (if win (invoke proc)
                              (error "Undefined symbol or word - ~S" word))))))
                 ((and (consp word) (eq (car word) 'quote))
                  (push (cadr word) *stack*))
                 ((and (consp word) (eq (car word) 'function))
                  (push (make-closure :proc (cadr word) :env env) *stack*))
                 (t
                  (push word *stack*)))))))))

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

(defun run ()
  (clrhash *vocabulary*)
  (setq *stack* nil)
  (eval '('nil #'('nil) def
          ;; Some more stack operations
          'dup  #'(0 nth) def
          'drop #'(1 0 skip) def
          'swap #'(1 nth 1 2 skip) def
          ;;
          ;; [ a1 ... an ] will now construct a list.
          ;;
          ;; '[' pushes a unique marker. ']' pops everything until that marker an
          ;; constructs a list. Like with PS.
          ;;
          #'('--mark-- 'nil cons '(--mark--) bind
             '[ #'(--mark--) def) eval
          '] #'('nil ]-aux) def
          ']-aux #'('(yet) bind
                    dup [ eq
                    #'(drop yet)
                    #'(yet cons ]-aux)
                    ifelse)
          def
          ;; <body> <n> DOTIMES
          'dotimes #'(0 dotimes-aux) def
          'dotimes-aux
          #'('(body n i) bind
             i n <
             #'(i body eval
                body n i 1 + dotimes-aux)
             if) def
          ;;
          ;; '<name> <val> DEFVAR
          ;;
          ;; Defines the word <name> to return the current value, and a word
          ;; SET-<name> to modify it.
          ;;
          'defvar #'('(sym val) bind
                     sym #'(val) def
                     [ nil "SET-~A" sym ] format intern
                       #'('val set) def
                     ) def
          ;; Define a global variable called FOO:
          'foo 42 defvar
          [ 't "FOO is ~S~%" foo ] format drop
          23 set-foo
          [ 't "FOO is ~S~%" foo ] format drop
          ;;
          'fib #'('(n) bind
                  n 2 < #'(1) #'(n 1 - fib n 2 - fib +) ifelse) def
          ;;
          #'('(n) bind
             [ 't "FIB of ~D is ~D~%" n n fib ] format drop ) 10 dotimes
          ))
  *stack*)