;; -*- Mode: Lisp; -*-
;; ---------------------------------------------------------------------------
;;     Title: Pico Lisp in CL
;;   Created: 2020-01-25
;;    Author: Gilbert Baumann <gilbert@bauhh.de>
;;   License: MIT style (see below)
;; ---------------------------------------------------------------------------
;;  (c) copyright 2020 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 :lisp-in-cl
  (:use :common-lisp)
  (:shadow #:eval #:symbol-function #:fboundp #:fmakunbound))

(in-package :lisp-in-cl)

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

;; This is an interpreter for a small Lisp languag in Lisp itself. The
;; feature set is very limited, there even is no DEFUN as this is the
;; pure interpreter with all the host of macros.

;;; Special forms

;; The following special forms are implemented:

;;   QUOTE object
;;   FUNCTION form
;;   SETQ sym val
;;   IF test cons &optional alt
;;   PROGN &rest forms
;;   TAGBODY &body body
;;   GO tag
;;   BLOCK name &body body
;;   RETURN-FROM name value

;;; Lambda Lists

;; Lambda list work a bit different from those in CL. We have no
;; lambda list keywords. Instead every parameter may be optional and
;; defaults to NIL. Lambda lists also may be dotted, the last symbol
;; than is bound to all remaining arguments, which is our way to say
;; &REST.

;; E.g.
;;  ((lambda x x) 1 2 3) => (1 2 3)
;;  ((lambda (x y z) (list x y z)) 1 2) => (1 2 NIL)
;;  ((lambda (x . r) (list x r)) 1 2 3) => (1 (2 3))

;;; Symbol Functions

;; We shadow SYMBOL-FUNCTION and friends as we need to stick our FSUBR
;; (special forms) and MACRO objects into a symbols function. However
;; when no function is defined, we happly fall back to look at
;; CL:SYMBOL-FUNCTION. This way all CL functions are available.

;; However, the following will not work:

;;  > (putd 'foo (lambda (x) (+ x 1)))
;;  FOO
;;  > (mapcar 'foo '(1 2 3)
;;  *** ERROR ***

;; The reason is, that CL:MAPCAR cannot see our SYMBOL-FUNCTION.

;; [TODO: We could make it so.]

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

(defstruct fsubr fun)
(defstruct macro fun)

(defvar +tag+ (make-symbol "+TAG+")
  "A marker in the environment for a TAGBODY/GO tag.")

(defvar +block+ (make-symbol "+BLOCK+")
  "A marker in the environment for a BLOCK.")

;;; SYMBOL-FUNCTION

;; We have our own SYMBOL-FUNCTION to be able to stick our FSUBR and
;; MACRO objects to it.

(defun symbol-function (sym)
  (or (get sym 'function)
      (error "Unbound function - ~S." sym)))

(defun fboundp (sym)
  (get sym 'function))

(defun fmakunbound (sym)
  (setf (get sym 'function) nil)
  sym)

(defun (setf symbol-function) (new-value sym)
  (setf (get sym 'function) new-value))

(defun putd (sym fun)
  (setf (symbol-function sym) fun)
  sym)

;;; EVAL

(defun eval (form &optional env)
  (cond ((symbolp form)
         (let ((q (assoc form env)))
           (if q (cdr q) (symbol-value form))))
        ((atom form)
         form)
        (t
         (let ((fun (evfun (car form) env)))
           (typecase fun
             (fsubr    (funcall (fsubr-fun fun) form env))
             (macro    (eval (funcall (macro-fun fun) form env) env))
             (function (apply fun (evlis (cdr form) env)))
             (t        (error "Bad function - ~S" fun)))))))

(defun evlis (forms env)
  (mapcar #'(lambda (x) (eval x env)) forms))

(defun evfun (fun env)
  (cond ((symbolp fun)
         (cond ((fboundp fun)
                (symbol-function fun))
               ((cl:fboundp fun)
                (cl:symbol-function fun))
               (t
                (error "Undefined function - ~S" fun))))
        ((and (consp fun) (eq (car fun) 'lambda))
         #'(lambda (&rest args)
             (apply-closure (cadr fun) (cddr fun) env
                            args)))
        (t
         (error "Bad function - ~S" fun))))

(defun apply-closure (params body cenv args)
  (eval `(progn ,@body) (pairlis* params args cenv)))

(defun pairlis* (params args env)
  ;; This is used to bind the parameters of a closure to the
  ;; arguments. Too few arguments are tolerated and the remaining
  ;; paramters default to NIL. Lambda lists could be dotted and the
  ;; last parameter (the last cdr) recieves all remaining
  ;; arguments. This is our &REST.
  (cond ((null params)
         (if args
             (error "Too many arguments - ~S" args)
             env))
        ((symbolp params)
         ;; dotted, this is our rest
         (cons (cons params args) env))
        ((atom params)
         (error "Bad parameter - ~S" params))
        ((symbolp (car params))
         (cons (cons (car params) (car args))
               (pairlis* (cdr params) (cdr args) env)))
        (t
         (error "Bad parameter - ~S" (car params)))))

;;;; -- Special Forms -------------------------------------------------------------------------

(defmacro define-fsubr (name params &body body)
  (let ((env (member '&environment params)))
    (setq params (append (ldiff params env) (cddr env))
          env (or (cadr env) (gensym "ENV.")))
    (let ((whole (member '&whole params)))
      (setq params (append (ldiff params whole) (cddr whole))
            whole (or (cadr whole) (gensym "WHOLE.")))
      ;;
      `(progn
         (setf (symbol-function ',name)
               (make-fsubr
                :fun
                (lambda (,whole ,env)
                  (declare (ignorable ,env))
                  (destructuring-bind ,params (cdr ,whole)
                    ,@body))))
         ',name))))

(define-fsubr quote (object)
  object)

(define-fsubr function (fun &environment env)
  (let ((r (evfun fun env)))
    (unless (functionp r)
      (error "Not a function - ~S" fun))
    r))

(define-fsubr if (test cons &optional alt &environment env)
  (if (eval test env)
      (eval cons env)
      (eval alt env)))

(define-fsubr progn (&body body &environment env)
  (let ((res nil))
    (dolist (form body res)
      (setq res (eval form env)))))

(define-fsubr setq (sym val &environment env)
  (unless (symbolp sym)
    (error "Not a symbol - ~S" sym))
  (setq val (eval val env))
  (let ((q (assoc sym env)))
    (if (null q)
        (set sym val)
        (setf (cdr q) val))))

(define-fsubr tagbody (&body body &environment env)
  ;; For each in the body we stick an entry
  ;;
  ;;   (list +tag+ <tag> <catch-tag> <catch-value>)
  ;;
  ;; into the environment. GO will then search for such an entry and
  ;; when it has found one will THROW to the given tag with the given
  ;; value. The value will be the next sublist of the body the
  ;; evaluate.
  ;;
  (let ((catch-tag (gensym)))
    ;; Collect all the tags
    (do ((q body (cdr q)))
        ((null q))
      (when (atom (car q))
        (push (list +tag+ (car q) catch-tag (cdr q)) env)))
    ;; Repeatly CATCH our catch tag until we get NIL back.
    (let ((q body))
      (do () ((null q))
        (setq q (catch catch-tag
                  (dolist (form q nil)
                    (unless (atom form)
                      (eval form env)))))))))

(define-fsubr go (tag &environment env)
  (let ((q (find-if (lambda (x) (and (eq (car x) +tag+) (eq (cadr x) tag))) env)))
    (cond ((null q)
           (error "GO tag ~S not defined." tag))
          (t
           (throw (third q) (fourth q))))))

(define-fsubr block (name &body body &environment env)
  (let ((catch-tag (gensym)))
    (push (list +block+ name catch-tag) env)
    (catch catch-tag
      (let (r)
        (dolist (form body r) (setq r (eval form env)))))))

(define-fsubr return-from (name value &environment env)
  (let ((q (find-if (lambda (x) (and (eq (car x) +block+) (eq (cadr x) name))) env)))
    (cond ((null q)
           (error "BLOCK not defined - ~S" name))
          (t
           (throw (third q) (eval value env))))))
    

;;;; -- Macros --------------------------------------------------------------------------------

(defmacro define-macro (name params &body body)
  (let ((env (member '&environment params)))
    (setq params (append (ldiff params env) (cddr env))
          env (or (cadr env) (gensym "ENV.")))
    (let ((whole (member '&whole params)))
      (setq params (append (ldiff params whole) (cddr whole))
            whole (or (cadr whole) (gensym "WHOLE.")))
      ;;
      `(progn
         (setf (symbol-function ',name)
               (make-macro
                :fun
                (lambda (,whole ,env)
                  (declare (ignorable ,env))
                  (destructuring-bind ,params (cdr ,whole)
                    ,@body))))
         ',name))))

(define-macro lambda (params &body body)
  `#'(lambda ,params ,@body))

(define-macro return (&optional value)
  `(return-from nil ,value))

;;;; -- REPL ----------------------------------------------------------------------------------

(defun repl ()
  (herald)
  (let (x)
    (loop
      (fresh-line)
      (princ "> ")
      (force-output)
      (setq x (read *standard-input* nil :fin))
      (when (eq :fin x) (terpri) (return))
      (setq x (eval x))
      ;; (fresh-line)
      (prin1 x)
      (terpri))))

(defun herald ()
  (fresh-line)
  (write-line ";;")
  (write-line ";; Lucky Lisp in CL")
  (write-line ";; (c) copyright 2020 by Gilbert Baumann.")
  (write-line ";;")
  (write-line ";; Type :fin or <EOF> to exit.")
  (write-line ";;"))