;;;;  -*- mode:lisp;coding:utf-8 -*-
;;;;**************************************************************************
;;;;FILE:               minimal-compiler.lisp
;;;;LANGUAGE:           Common-Lisp
;;;;SYSTEM:             Common-Lisp
;;;;USER-INTERFACE:     NONE
;;;;DESCRIPTION
;;;;
;;;;    This file implements a Common Lisp minimal-compiler.
;;;;
;;;;AUTHORS
;;;;    <PJB> Pascal Bourguignon <pjb@informatimago.com>
;;;;MODIFICATIONS
;;;;    2010-02-07 <PJB> Made the minimal compiler work.
;;;;    2008-05-29 <PJB> Created.
;;;;BUGS
;;;;     Not implemented yet:
;;;;     - SYMBOL-MACROLET, DEFINE-SYMBOL-MACRO
;;;;     - CL macros should be defined inhere (or by the application),
;;;;       instead of using the implementation definitions.
;;;;LEGAL
;;;;     GPL
;;;;
;;;;     Copyright Pascal Bourguignon 2008 - 2010
;;;;
;;;;     This program is free software; you can redistribute it and/or
;;;;     modify it under the terms of the GNU General Public License
;;;;     as published by the Free Software Foundation; either version
;;;;     2 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 General Public License for more details.
;;;;
;;;;     You should have received a copy of the GNU General Public
;;;;     License along with this program; if not, write to the Free
;;;;     Software Foundation, Inc., 59 Temple Place, Suite 330,
;;;;     Boston, MA 02111-1307 USA
;;;; *************************************************************************
(in-package "MINIMAL-COMPILER")



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; We can inherit the macros and compiler macros from the COMMON-LISP package.
;;; This is a shortcut, so that we don't have to provide definitions for the
;;; standard macros.
;;;
;;; On the other hand, some macros have implementation specific extensions,
;;; so applications will want to provide definitions for standard macros
;;; anyways.
;;;
;;; For the other packages, we assume that the user may load his sources with
;;; this Minimal compiler, to register the macros.
;;;


(defvar *inherit-cl-compiler-macros* nil
  "When true, mc:compiler-macro-function will fall back to
cl:compiler-macro-function for symbols exported from the common-lisp package.")


(defvar *inherit-cl-macros* nil
  "When true, mc:macro-function will fall back to cl:macro-function for symbols
exported from the common-lisp package.")


(defvar *cl-compiler-macros*
  (loop
     :for s :being :each :external-symbol :of (find-package "COMMON-LISP")
     :when (cl:compiler-macro-function s) :collect s)
  "The list of external symbols of COMMON-LISP that are compiler-macros.")


(defvar *cl-macros*
  (loop
     :for s :being :each :external-symbol :of (find-package "COMMON-LISP")
     :when (cl:macro-function s) :collect s)
  "The list of external symbols of COMMON-LISP that are macros.")


(cl:defun cl-macro-p (symbol)
  (find symbol *cl-macros*))


(cl:defun cl-compiler-macro-p (symbol)
  (find symbol *cl-compiler-macros*))




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Environment
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;; TODO: Provide a "standard" API to access the environment (check CLtL2 and Duane's).

;;;; TODO: environment lacks active block names. See also other kind of entries
;;;;       (catch objects are dynamic, as are condition handlers).
;;;;       perhaps unwind-protect frames?
;;;;       perhaps tagbody tags?

(defstruct environment
  variables
  functions
  symbol-macros
  macros)

(cl:defun extend-environment-with-lambda-list (lambda-list env)
  (make-environment
   :variables     (append lambda-list (environment-variables env))
   :functions     (environment-functions     env)
   :symbol-macros (environment-symbol-macros env)
   :macros        (environment-macros        env)))

(cl:defun extend-environment-with-variables (variables env)
  (make-environment
   :variables     (append variables (environment-variables env))
   :functions     (environment-functions     env)
   :symbol-macros (environment-symbol-macros env)
   :macros        (environment-macros        env)))

(cl:defun extend-environment-with-functions (functions env)
  (make-environment
   :variables     (environment-variables     env)
   :functions     (append functions (environment-functions env))
   :symbol-macros (environment-symbol-macros env)
   :macros        (environment-macros        env)))

(cl:defun extend-environment-with-symbol-macros (macros env)
  (make-environment
   :variables     (environment-variables     env)
   :functions     (environment-functions     env)
   :symbol-macros (append macros (environment-symbol-macros env))
   :macros        (environment-macros        env)))

(cl:defun extend-environment-with-macros (macros env)
  (make-environment
   :variables     (environment-variables     env)
   :functions     (environment-functions     env)
   :symbol-macros (environment-symbol-macros env)
   :macros        (append macros (environment-macros env))))



(cl:defun push-variable-onto-environment (variable env)
  (push variable (environment-variables env))
  env)

(cl:defun push-function-onto-environment (function env)
  (push function (environment-functions env))
  env)

(cl:defun push-symbol-macro-onto-environment (macro env)
  (push macro (environment-symbol-macros env))
  env)

(cl:defun push-macro-onto-environment (macro env)
  (push macro (environment-macros env))
  env)



(cl:defun pop-variable-from-environment (name env)
  (setf (environment-variables env)
        (remove name (environment-variables env)
                :key (function first) :count 1))
  env)

(cl:defun pop-function-from-environment (name env)
  (setf (environment-functions env)
        (remove name (environment-functions env)
                :key (function first) :count 1))
  env)

(cl:defun pop-symbol-macro-from-environment (name env)
  (setf (environment-symbol-macros env)
        (remove name (environment-symbol-macros env)
                :key (function first) :count 1))
  env)

(cl:defun pop-macro-from-environment (name env)
  (setf (environment-macros env)
        (remove name (environment-macros env)
                :key (function first) :count 1))
  env)


(defparameter *global-environment* (make-environment))

;;; Notice:
;;; In the following functions taking an optional environment
;;; argument, the default value is NIL which is a designator for the
;;; global environment.  We explicitely rebind the environment to
;;; *global-environment* since the caller may pass NIL for it.


(defvar *macroexpand-hook* 'funcall)
;; it will be (coerce *macroexpand-hook* 'function)



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Compiler macros
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(cl:defun compiler-macro-function (name &optional environment)
  (let ((environment (or environment *global-environment*)))
    (or (get name 'compiler-macro-function nil)
        (and (eq *global-environment* environment)
             ;; get global compiler macro
             *inherit-cl-compiler-macros*
             (cl-compiler-macro-p name)
             (cl:compiler-macro-function name)))))


(cl:defun (setf compiler-macro-function) (new-function name &optional environment)
  (let ((environment (or environment *global-environment*)))
    (assert (eq *global-environment* environment) (environment)
            "Compiler-macro functions may be defined only on global functions.")
    (setf (get name 'compiler-macro-function nil) new-function)))


(cl:defmacro define-compiler-macro (name lambda-list &body decl-doc-body)
  (error "~S is not implemented yet." 'define-compiler-macro)
  ;; extract from lambda-list whole and environment
  (let ((whole)
        (environment)
        (lambda-list)
        (docstring     (extract-documentation decl-doc-body))
        (declarations  (extract-declarations  decl-doc-body))
        (body          (extract-body          decl-doc-body)))
    `(progn
       (setf (compiler-macro-function ',name)
             (lambda (,whole ,environment)
               (destructuring-bind ,lambda-list ,whole
                 (locally ,@declarations ,@body)))
             (documentation ',name 'mc::compiler-macro-function) ',docstring)
       ',name)))




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Symbol macros
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(cl:defun symbol-macro-p (sym env)
  (assoc sym (environment-symbol-macros env)))


(cl:defun symbol-macro-expansion (sym env)
  (cdr (assoc sym (environment-symbol-macros env))))


(cl:defmacro DEFINE-SYMBOL-MACRO (symbol expansion)
  (warn "~S is not implemented yet." 'DEFINE-SYMBOL-MACRO)
  `'(define-symbol-macro ,symbol ,expansion))


(cl:defun so/SYMBOL-MACROLET (environment form)
  ;; add the symbol-macrolet to the environment
  (error "SYMBOL-MACROLET is not implemented yet."))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Normal macros
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(cl:defun macro-function (symbol &optional environment)
  (let* ((environment (or environment *global-environment*))
         (macro (find symbol (environment-macros environment) :key (function first))))
    (if macro
        (second macro)
        (and (eq *global-environment* environment)
             ;; get global macro.
             *inherit-cl-macros*
             (cl-macro-p symbol)
             (cl:macro-function symbol)))))


(cl:defun (setf macro-function) (new-function symbol &optional environment)
  (let ((environment (or environment *global-environment*)))
    (push-macro-onto-environment (list symbol new-function) environment)))


(cl:defun make-macro (name lambda-list body)
  "
RETURN: a lambda form for the macro function ; a documentation string (or nil)"
  (let ((ll            (parse-lambda-list lambda-list :macro))
        (vwhole        (gensym "whole"))
        (venvir        (gensym "env"))
        (bindings      '())
        (docstring     (extract-documentation body))
        (declarations  (extract-declarations  body))
        (body          (extract-body          body)))
    (when (lambda-list-whole-parameter-p ll)
      (push (list (parameter-name
                   (lambda-list-whole-parameter ll))
                  vwhole) bindings))
    (when (lambda-list-environment-parameter-p ll)
      (push (list (parameter-name
                   (lambda-list-environment-parameter ll))
                  venvir) bindings))
    (change-class ll 'destructuring-lambda-list)
    (values `(lambda (,vwhole ,venvir)
               (block ,name
                 (let ,bindings
                   (destructuring-bind ,(make-lambda-list ll) (cdr ,vwhole)
                     ,@(if declarations
                           `((locally ,@declarations ,@body))
                           body)))))
            docstring)))


(cl:defmacro defmacro (name lambda-list &body body)
  (multiple-value-bind (lambda-form docstring) (make-macro name lambda-list body)
    `(progn
       (setf (macro-function ',name) ,lambda-form)
       ,@(when docstring
               `((setf (documentation ',name 'mc::macro-function) ',docstring)))
       ',name)))


(cl:defun so/macrolet (environment form)
  ;; add the macrolet to the environment
  (destructuring-bind (macrolet bindings &body body) form
    (%minimal-compile
     `(locally ,@body)
     (extend-environment-with-macros
      (mapcar (lambda (binding)
                (destructuring-bind (name lambda-list &body body) binding
                  (multiple-value-bind (lambda-form docstring) (make-macro name lambda-list body)
                    (list name (coerce lambda-form 'function)))))
              bindings)
      environment))))


(cl:defun macroexpand-1 (form &optional environment)
  ;; => expansion, expanded-p
  (if (atom form)
      (if (symbol-macro-p form environment)
          (values (funcall (coerce *macroexpand-hook* 'function)
                           (function symbol-macro-expansion) form environment)
                  t)
          (values form nil))
      (let ((mf (macro-function (first form) environment)))
        (if mf
            (values (funcall (coerce *macroexpand-hook* 'function)
                             mf form environment)
                    t)
            (values form nil)))))


(cl:defun macroexpand (form &optional environment)
  ;; => expansion, expanded-p
  (multiple-value-bind (expansion expanded-p) (macroexpand-1 form environment)
    (if expanded-p
        (macroexpand expansion environment)
        (values expansion expanded-p))))







;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Special operators
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; The so/x functions implement the default special operators (each
;;; just return a new form).  These functions are indexed in a
;;; hash-table *special-operator-map* by the CL special operator
;;; symbol.  The user may provide an overlaid map of special operator
;;; functions.
;;; The minimal compiler always use (GENSOP env special-op ...) to
;;; call them.  so/load-time-value is special.
;;;

(defparameter *cl-special-operators*
  '(SETQ BLOCK CATCH EVAL-WHEN FLET FUNCTION GO IF LABELS LET LET*
    LOAD-TIME-VALUE LOCALLY MACROLET MULTIPLE-VALUE-CALL
    MULTIPLE-VALUE-PROG1 PROGN PROGV QUOTE RETURN-FROM SYMBOL-MACROLET
    TAGBODY THE THROW UNWIND-PROTECT)
  "The list of standard CL special operators.")
;; and SO/CALL


(cl:defun so/setq       (env symbol value)
  (declare (ignore env))
  `(setq ,symbol ,value))

(cl:defun so/block      (env name body)
  (declare (ignore env))
  `(block ,name ,@body))

(cl:defun so/catch      (env object body)
  (declare (ignore env))
  `(catch ,object ,@body))

(cl:defun so/eval-when  (env situations body)
  (declare (ignore env))
  `(eval-when ,situations ,@body))

(cl:defun so/flet       (env bindings body)
  (declare (ignore env))
  `(flet     ,bindings ,@body))

(cl:defun so/function   (env fname)
  (declare (ignore env))
  `(function ,fname))

(cl:defun so/go         (env tag)
  (declare (ignore env))
  `(go ,tag))

(cl:defun so/if    (env test then &optional else)
  (declare (ignore env))
  `(if ,test ,then ,else))

(cl:defun so/labels     (env bindings body)
  (declare (ignore env))
  `(labels   ,bindings ,@body))

(cl:defun so/let        (env bindings body)
  (declare (ignore env))
  `(let      ,bindings ,@body))

(cl:defun so/let*       (env bindings body)
  (declare (ignore env))
  `(let*     ,bindings ,@body))


(defvar *load-time-evaluate-p*  t
  "Whether SO/LOAD-TIME-VALUE must evaluate the form.
If true, the form is evaluated during the mininal compilation, and
its value substitutes the load-time-value expression;
if nil, returns a load-time-value form.")

(defvar *file-compiling-p*      nil
  "Whether this minimal compilation is done as part of file
compiling (as with COMPILE-FILE).")

(defvar *load-time-expressions* '()
  "When (and *load-time-evaluate-p* *file-compiling-p*),
expressions to evaluate the load-time values are pushed onto this list.")

(cl:defun so/load-time-value (env form &optional read-only-p)
  "LOAD-TIME-VALUE: we evaluate the form during the minimal compilation.
However this may lead to difficulties, since it is evaluated in the
NULL environment of the host Common Lisp, not in the *global-environment*
of the minimal compiler."
  (if *load-time-evaluate-p*
      (let ((vvalue (gensym "value")))
        (if *file-compiling-p*
            ;; COMPILE-FILE:
            (progn
              (push `(setf (symbol-value ,vvalue) ,form) *load-time-expressions*)
              `(symbol-value ,vvalue)))
        ;; COMPILE, or minimal compilation:
        (values (eval form)))
      `(load-time-value ,form ,read-only-p)))


(cl:defun so/locally    (env body)
  (declare (ignore env))
  `(locally ,@body))

(cl:defun so/macrolet   (env bindings body)
  (declare (ignore env))
  `(macrolet ,bindings ,@body))

(cl:defun so/multiple-value-call (env function-form forms)
  (declare (ignore env))
  `(multiple-value-call ,function-form ,@forms))

(cl:defun so/multiple-value-prog1 (env first-form forms)
  (declare (ignore env))
  `(multiple-value-prog1 ,first-form ,@forms))

(cl:defun so/progn      (env body)
  (declare (ignore env))
  `(progn ,@body))

(cl:defun so/progv      (env symbols values body)
  (declare (ignore env))
  `(progv ,symbols ,values ,@body))

(cl:defun so/quote      (env object)
  (declare (ignore env))
  `(quote ,object))

(cl:defun so/return-from (env name &optional (result nil resultp))
  (declare (ignore env))
  (if resultp
      `(return-from ,name ,result)
      `(return-from ,name)))

(cl:defun so/symbol-macrolet (env bindings body)
  (declare (ignore env))
  `(symbol-macrolet ,bindings ,@body))

(cl:defun so/tagbody    (env body)
  (declare (ignore env))
  `(tagbody ,@body))

(cl:defun so/the        (env value-type form)
  (declare (ignore env))
  `(the ,value-type ,form))

(cl:defun so/throw      (env tag result-form)
  (declare (ignore env))
  `(throw ,tag ,result-form))

(cl:defun so/unwind-protect (env protected-form cleanup-forms)
  (declare (ignore env))
  `(unwind-protect ,protected-form ,@cleanup-forms))


;; Minimal compilation specific special operators:

(cl:defun so/call (env fname arguments)
  (declare (ignore env))
  `(,fname ,@arguments))



(cl:defun make-default-special-operator-map ()
  (let ((ht (make-hash-table)))
    (loop
       :for sym :in (cons 'mc::call *cl-special-operators*)
       :for so = (intern (format nil "SO/~A" sym) #.*package*)
       :do (setf (gethash sym ht) so))
    ht))


(defparameter *special-operator-map* (make-default-special-operator-map))


(cl:defun merge-map (base-map overlay)
  "
RETURN: a new hash-table with all the key-value from BASE-MAP,
        overwritten by those from OVERLAY.
"
  (flet ((valid-pair-p (k v)
           (and (symbol k)
                (or (functionp v)
                    (and (symbol v)
                         (fboundp v))))))
    (let ((ht (copy-hash-table base-map)))
      (cond
        ((and (hash-table-p overlay)
              (loop
                 :for k :being :each :hash-key :of overlay
                 :always (valid-pair-p k (gethash k overlay))))
         (loop
            :for k :being :each :hash-key :of overlay
            :do (setf (gethash k ht) (gethash k overlay))))
        ((and (listp overlay)
              (every (lambda (item)
                       (and (consp item) (valid-pair-p (car item) (cdr item))))
                     overlay))
         ;; a-list
         (loop
            :for (k . v) :in overlay
            :do (setf (gethash k ht) v)))
        ((and (listp overlay)
              (evenp (length overlay))
              (loop
                 :for (k v) :on overlay :by (function cddr)
                 :always (or (null v) (valid-pair-p k v))))
         ;; p-list
         (loop
            :for (k v) :on overlay :by (function cddr)
            :do (setf (gethash k ht) v)))
        (t
         (error "Invalid special operator map: %S" overlay)))
      ht)))


(cl:defun gensop (env special-operator &rest arguments)
  (let ((sopfun (gethash special-operator *special-operator-map*)))
    (if sopfun
        (apply sopfun env arguments)
        (error "Not a special operator ~S" special-operator))))






;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Minimal compiler
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;

;;; The functions implementing the mininal compilation of each special
;;; operator X are named MINIMAL-COMPILE/X.
;;;



(cl:defun minimal-compile-lambda              (env form)
  (destructuring-bind (lambda lambda-list &body body) form
    (let ((env (extend-environment-with-lambda-list
                (make-argument-list-form
                 (parse-lambda-list lambda-list))
                env)))
      `(lambda ,lambda-list
         ,@(mapcar (lambda (form) (%minimal-compile env form))
                   body)))))


(cl:defun minimal-compile-call            (env form)
  (destructuring-bind (fname &rest arguments) form
    (cond
      ((symbolp fname)
       (so/call env fname
                (mapcar (lambda (expr) (%minimal-compile env expr))
                        arguments)))
      ((and (listp fname)
            (eq 'lambda (first fname))
            (not (null (rest fname)))
            (listp (second fname)))
       (so/call env (minimal-compile-lambda env fname)
                (mapcar (lambda (expr) (%minimal-compile env expr))
                        arguments)))
      (t
       (error "Invalid function call ~S" form)))))


;;;; TODO: minimal-compile/symbol we may need to call a so/function for variable references...

(cl:defun minimal-compile/symbol              (env form)
  (let ((symac (assoc form (environment-symbol-macros env))))
    (if symac
        (%minimal-compile env (cdr symac))
        form)))


(cl:defun minimal-compile/function             (env form)
  (destructuring-bind (function fname) form
    (cond
      ((symbolp fname)
       (gensop env function fname))
      ((and (listp fname)
            (eq 'lambda (first fname))
            (not (null (rest fname)))
            (listp (second fname)))
       (gensop env 'function (minimal-compile-lambda env fname)))
      (t
       (error "Invalid FUNCTION form: ~S" form)))))


(cl:defun minimal-compile/quote                (env form)
  (destructuring-bind (quote object) form
    (gensop env quote object)))


(cl:defun minimal-compile/if                   (env form)
  (destructuring-bind (if test then &optional else) form
    (gensop env if (%minimal-compile env test)
            (%minimal-compile env then)
            (%minimal-compile env else))))


(cl:defun minimal-compile/block                (env form)
  (destructuring-bind (block name &rest body) form
    (gensop env block name
;;;; TODO: we should add to the env for the subforms the block name.
            (mapcar (lambda (subform) (%minimal-compile env subform)) body))))


(cl:defun minimal-compile/return-from          (env form)
  (destructuring-bind (return-from name &optional (value nil valuep)) form
    (if valuep
        (gensop env return-from name (%minimal-compile env value))
        (gensop env return-from name))))


(cl:defun minimal-compile/catch                (env form)
  (destructuring-bind (catch object &rest body) form
    (gensop env catch (%minimal-compile env object)
            (mapcar (lambda (subform) (%minimal-compile env subform)) body))))


(cl:defun minimal-compile/throw                (env form)
  (destructuring-bind (throw object &optional value) form
    (gensop env throw (%minimal-compile env object) (%minimal-compile env value))))


(cl:defun minimal-compile/unwind-protect       (env form)
  (destructuring-bind (unwind-protect expression &rest body) form
;;;; TODO: perhaps add a unwind-protect frame in the environment for the expression?
    (gensop env unwind-protect (%minimal-compile env expression)
            (mapcar (lambda (subform) (%minimal-compile env subform)) body))))


(cl:defun minimal-compile/tagbody              (env form)
  (destructuring-bind (tagbody &rest body) form
    (gensop env tagbody
            (mapcar (lambda (subform)
                      (if (atom subform)
;;;; TODO: perhaps we want a so/ function for tags?
                          subform      ; a tag
;;;; TODO: perhaps we want to add the tags to the environment?
                          (%minimal-compile env subform)))
                    body))))


(cl:defun minimal-compile/go                   (env form)
  (destructuring-bind (go label) form
    (gensop env go label)))


(cl:defun minimal-compile/flet                 (env form)
  (destructuring-bind (flet bindings &rest body) form
    (gensop env flet
            (mapcar (lambda (fun)
                      `(,(first fun) ,(second fun)
;;;; TODO: process the lambda-list!
                         ,(minimap-compile
                           (extend-environment-with-lambda-list
                            (second fun) env)
                           form)))
                    bindings)
            (let ((env (extend-environment-with-functions
                        (mapcar (function first) bindings) env)))
              (mapcar (lambda (subform)
                        (if (atom subform)
                            subform    ; a tag
                            (%minimal-compile env subform)))
                      body)))))


(cl:defun minimal-compile/labels                (env form)
  (destructuring-bind (labels bindings &rest body) form
    (let ((env (extend-environment-with-functions
                (mapcar (function first) bindings) env)))
      (gensop env labels
              (mapcar (lambda (fun)
                        `(,(first fun) ,(second fun)
;;;; TODO: process the lambda-list!
                           ,(minimap-compile
                             (extend-environment-with-lambda-list
                              (second fun) env)
                             form)))
                      bindings)
              (mapcar (lambda (subform)
                        (if (atom subform)
                            subform    ; a tag
                            (%minimal-compile env subform)))
                      body)))))


(cl:defun minimal-compile/setq                 (env form)
  (destructuring-bind (setq &rest var-val-pairs) form
    (if var-val-pairs
        (loop
           :with has-symbol-macros = nil
           :with has-normal-variables = nil
           :for (var val) :on var-val-pairs :by (function cddr)
           :until (and has-symbol-macros has-normal-variables)
           :do (if (symbol-macro-p var env)
                   (setf has-symbol-macros t)
                   (setf has-normal-variables t))
           :finally (return
                      (cond
                        ((and has-symbol-macros has-normal-variables)
                         (%minimal-compile env
                                           `(progn
                                              ,@(loop
                                                   :for (var val) :on var-val-pairs :by (function cddr)
                                                   :collect (if (symbol-macro-p var env)
                                                                `(setq ,var ,val)
                                                                `(setf ,var ,val))))))
                        (has-symbol-macros ; only symbol-macros
                         (%minimal-compile env `(setf ,@var-val-pairs)))
                        ;; only variables
                        ((null (cddr var-val-pairs))
                         (gensop env setq (first var-val-pairs)
                                 (%minimal-compile env (second var-val-pairs))))
                        (t
                         (gensop env 'progn
                                 (loop
                                    :for (var val) :on var-val-pairs :by (function cddr)
                                    :collect (gensop env setq var (%minimal-compile env val))))))))
        (gensop env 'progn nil))))



;; (cl:defun split-declarations (body)
;;   (loop
;;      :for forms :on body
;;      :while (and (listp (car forms))
;;                  (eq 'declare (caar forms)))
;;      :collect (car forms) :into declarations
;;      :finally (return (values declarations forms))))


(declaim (inline split-declarations))

(cl:defun split-declarations (body)
;;;; TODO: check source-form.lisp; what about "docstrings" in declaration* body*?
  (values (extract-declarations body)
          (extract-body         body)))


;;;; TODO: declarations too could be added to the environment.

(cl:defun minimal-compile/let                  (env form)
  (destructuring-bind (let bindings &rest body) form
    (gensop env let
            (mapcar (lambda (binding)
                      (if (atom binding)
                          binding
                          `(,(first binding)
                             ,(%minimal-compile env (second binding)))))
                    bindings)
            (let ((env (extend-environment-with-variables
                        (mapcar (lambda (binding)
                                  (if (atom binding)
                                      binding
                                      (first binding)))
                                bindings)
                        env)))
              (multiple-value-bind (declarations forms)
                  (split-declarations body)
                (append declarations
                        (mapcar (lambda (subform) (%minimal-compile env subform))
                                forms)))))))


(cl:defun minimal-compile/let*                 (env form)
  (destructuring-bind (let* bindings &rest body) form
    (%minimal-compile
     env (labels ((wrap (bindings expr)
                    (if (null bindings)
                        expr
                        (wrap (cdr bindings)
                              (gensop env 'let (list (car bindings))
                                      (list expr))))))
           (wrap (reverse bindings)
                 (gensop env 'locally body))))))


(cl:defun minimal-compile/multiple-value-call  (env form)
  (destructuring-bind (multiple-value-call function-form &rest forms) form
    (gensop env multiple-value-call
            (%minimal-compile env function-form)
            (mapcar (lambda (expr) (%minimal-compile env expr)) forms))))


(cl:defun minimal-compile/multiple-value-prog1 (env form)
  (destructuring-bind (multiple-value-prog1 first-form &rest body) for
    (gensop env multiple-value-prog1
            (%minimal-compile env first-form)
            (mapcar (lambda (expr) (%minimal-compile env expr)) body))))


(cl:defun minimal-compile/progn                (env form)
  (destructuring-bind (progn &rest body) form
    (gensop env progn (mapcar (lambda (expr) (%minimal-compile env expr)) body))))


(cl:defun minimal-compile/progv                (env form)
  (destructuring-bind (progv symbols values forms) form
    (gensop env progv
            (%minimal-compile env symbols)
            (%minimal-compile env values)
            (mapcar (lambda (expr) (%minimal-compile env expr)) form))))


(cl:defun minimal-compile/locally              (env form)
;;;; TODO: declarations too could be added to the environment.
  (destructuring-bind (locally &rest body) form
    (multiple-value-bind (declarations forms) (split-declarations body)
      (gensop env locally declarations
              (mapcar (lambda (expr) (%minimal-compile env expr)) forms)))))


(cl:defun minimal-compile/the                  (env form)
  (destructuring-bind (the value-type expr) form
    (gensop env the value-type (minimap-compile env expr))))


(cl:defun minimal-compile/eval-when            (env form)
  (destructuring-bind (eval-when situations &rest forms) form
    (gensop env eval-when situations
            (mapcar (lambda (expr) (%minimal-compile env expr)) forms))))



(cl:defun minimal-compile/load-time-value    (env form)
  (destructuring-bind (load-time-value form &optional (read-only-p nil ropp)) form
    (if ropp
        (gensop env load-time-value form read-only-p)
        (gensop env load-time-value form))))



;; (declaim (inline operator arguments))
;; (cl:defun operator  (form) (first form))
;; (cl:defun arguments (form) (rest  form))


(cl:defun %minimal-compile (env form)
  (cond
    ((symbolp form)            (minimal-compile/symbol               env form))
    ;; The other atoms are unchanged:
    ((atom form)               form)
    ;; Now we have a list.
    (t
     (case (first form)
       ;; First we check the special operators:
       ((FUNCTION)             (minimal-compile/function             env form))
       ((QUOTE)                (minimal-compile/quote                env form))
       ((IF)                   (minimal-compile/if                   env form))
       ((BLOCK)                (minimal-compile/block                env form))
       ((RETURN-FROM)          (minimal-compile/return-from          env form))
       ((CATCH)                (minimal-compile/catch                env form))
       ((THROW)                (minimal-compile/throw                env form))
       ((UNWIND-PROTECT)       (minimal-compile/unwind-protect       env form))
       ((TAGBODY)              (minimal-compile/tagbody              env form))
       ((GO)                   (minimal-compile/go                   env form))
       ((FLET)                 (minimal-compile/flet                 env form))
       ((LABELS)               (minimal-compile/labels               env form))
       ((SETQ)                 (minimal-compile/setq                 env form))
       ((LET)                  (minimal-compile/let                  env form))
       ((LET*)                 (minimal-compile/let*                 env form))
       ((MULTIPLE-VALUE-CALL)  (minimal-compile/multiple-value-call  env form))
       ((MULTIPLE-VALUE-PROG1) (minimal-compile/multiple-value-prog1 env form))
       ((PROGN)                (minimal-compile/progn                env form))
       ((PROGV)                (minimal-compile/progv                env form))
       ((LOCALLY)              (minimal-compile/locally              env form))
       ((THE)                  (minimal-compile/the                  env form))
       ((EVAL-WHEN)            (minimal-compile/eval-when            env form))
;;;; TODO: those so/* should probably be replaced by minimal-compile/* functions...
       ((SYMBOL-MACROLET)      (so/symbol-macrolet                   env form))
       ((MACROLET)             (so/macrolet                          env form))
       ((LOAD-TIME-VALUE)      (minimal-compile/load-time-value      env form))
       (otherwise
        (let ((cmf (compiler-macro-function (first form) env))
              (mf  (macro-function          (first form) env)))
          (cond
            (cmf
             (let ((expansion (funcall (coerce *macroexpand-hook* 'function)
                                       cmf form env)))
               (%minimal-compile env expansion)))
            (mf
             (let ((expansion (funcall (coerce *macroexpand-hook* 'function)
                                       mf form env)))
               (%minimal-compile env expansion)))
            (t
             (minimal-compile-call env form)))))))))


(cl:defun minimal-compile (form &key special-operator-map environment)
  "
DO:                    Implement the minimal compilation algorithm on the FORM.
SPECIAL-OPERATOR-MAP:  A map (either a-list, p-list or hash-table)
                       mapping special operator symbols from CL to
                       functions used to generate the final special
                       operator invocations.
ENVIRONMENT:           Either NIL (denoting the NULL MC::ENVIRONMENT),
                       or an instance of MC::ENVIRONMENT.
"
  (let ((environment (or environment *global-environment*))
        (*special-operator-map* (merge-map *special-operator-map*
                                           special-operator-map)))
    (%minimal-compile environment form)))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; THE END ;;;;
ViewGit