Commited old changes: Added asdf and minimal-compiler-system file, made a few changes.

Pascal J. Bourguignon [2014-10-10 01:51]
Commited old changes: Added asdf  and minimal-compiler-system file, made a few changes.
Filename
.gitignore
com.informatimago.minimal-compiler.asd
minimal-compiler-system.lisp
minimal-compiler.lisp
diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..4cc7c97
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,14 @@
+syntax: glob
+*.orig
+*.rej
+*~
+*.o
+.svn
+.hg
+.lib
+.fas
+.fasl
+.x86f
+
+# syntax: regexp
+# .*\#.*\#$
diff --git a/com.informatimago.minimal-compiler.asd b/com.informatimago.minimal-compiler.asd
new file mode 100644
index 0000000..d833e7c
--- /dev/null
+++ b/com.informatimago.minimal-compiler.asd
@@ -0,0 +1,32 @@
+;;;; -*- mode:lisp;coding:utf-8 -*-
+
+(asdf:defsystem :com.informatimago.minimal-compiler
+    :name "Common Lisp Minimal Compiler"
+    :description  "This systems implements a Common Lisp Minimal Compiler."
+    :author "<PJB> Pascal Bourguignon <pjb@informatimago.com"
+    :version "0.0.2"
+    :licence "GPL"
+    :properties ((#:author-email                   . "pjb@informatimago.com")
+                 (#:date                           . "Autumn 2011")
+                 ((#:albert #:output-dir)          . "../documentation/com.informatimago.minimal-compiler/")
+                 ((#:albert #:formats)             . ("docbook"))
+                 ((#:albert #:docbook #:template)  . "book")
+                 ((#:albert #:docbook #:bgcolor)   . "white")
+                 ((#:albert #:docbook #:textcolor) . "black"))
+    :depends-on (;; "split-sequence"
+                 ;; "alexandria"
+                 ;; "cffi"
+                 "com.informatimago.common-lisp.cesarum"
+                 "com.informatimago.common-lisp.lisp-sexp"
+                 )
+    :components ((:file "packages")
+                 (:file "minimal-compiler"        :depends-on ("packages"))
+                 (:file "minimal-compiler-system" :depends-on ("packages"))
+                 (:file "standard-macros"         :depends-on ("packages"
+                                                               "minimal-compiler"
+                                                               "minimal-compiler-system"))))
+
+
+;;;; THE END ;;;;
+
+
diff --git a/minimal-compiler-system.lisp b/minimal-compiler-system.lisp
new file mode 100644
index 0000000..6f0db05
--- /dev/null
+++ b/minimal-compiler-system.lisp
@@ -0,0 +1,96 @@
+;;;; -*- mode:lisp;coding:utf-8 -*-
+;;;;**************************************************************************
+;;;;FILE:               minimal-compiler-system.lisp
+;;;;LANGUAGE:           Common-Lisp
+;;;;SYSTEM:             Common-Lisp
+;;;;USER-INTERFACE:     NONE
+;;;;DESCRIPTION
+;;;;
+;;;;    This package exports primitives that are referenced by the macros
+;;;;    defined in STANDARD-MACRO.
+;;;;
+;;;;AUTHORS
+;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;;    2011-10-10 <PJB> Extracted from 'standard-macro.lisp'.
+;;;;BUGS
+;;;;LEGAL
+;;;;    GPL
+;;;;
+;;;;    Copyright Pascal J. Bourguignon 2011 - 2011
+;;;;
+;;;;    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-SYSTEM")
+
+(proclaim '(declaration constant)) ; we declaim constant variables as being mcsys:constant.
+
+
+
+(defun note-type (type-name)
+  "Register TYPE-NAME as a type (at compilation time)."
+  type-name)
+
+
+(defun ensure-type (type-name lambda-list docstring declarations type-form)
+  (declare (ignore lambda-list docstring declarations type-form))
+;;;; TODO: eventually we may want to register the type somewhere.
+  type-name)
+
+
+
+(defun note-class (class-name)
+  "Register CLASS-NAME as a class (at compilation time)."
+  class-name)
+
+
+(defun ensure-class (class-name slot-specifiers class-options)
+  (declare (ignore  slot-specifiers class-options))
+;;;; TODO: eventually we may want to register the class somewhere.
+  class-name)
+
+
+
+(define-condition source-program-error (program-error)
+  ((source-form        :initarg :source-form
+                       :accessor source-program-error-source-form)
+   (erroneous-subform  :initarg :erroneous-subform
+                       :accessor source-program-error-erroneous-subform)))
+
+(define-condition source-program-error-invalid-variable-name          (source-program-error) ())
+(define-condition source-program-error-invalid-documentation-string   (source-program-error) ())
+(define-condition source-program-error-too-many-documentation-strings (source-program-error) ())
+(define-condition source-program-error-too-many-size-clauses          (source-program-error) ())
+(define-condition source-program-error-invalid-defpackage-clause      (source-program-error) ())
+(define-condition source-program-error-symbol-lists-must-be-disjoint  (source-program-error)
+  ((intersection :initarg :intersection
+                 :accessor source-program-error-symbol-lists-intersection)
+   (one-list     :initarg :one-symbol-list
+                 :accessor source-program-error-one-symbol-list)
+   (other-list   :initarg :other-symbol-list
+                 :accessor source-program-error-other-symbol-list)))
+(define-condition source-program-error-too-many-deftype-forms         (source-program-error) ())
+
+
+(define-condition package-error-package-not-found (package-error) ())
+(define-condition PACKAGE-ERROR-SYMBOL-NOT-FOUND  (package-error)
+  ((symbol-name :initarg :symbol-name
+                :accessor PACKAGE-ERROR-SYMBOL-NOT-FOUND-symbol-name)))
+
+
+
+;;;; THE END ;;;;
diff --git a/minimal-compiler.lisp b/minimal-compiler.lisp
index a21d033..5f951bf 100644
--- a/minimal-compiler.lisp
+++ b/minimal-compiler.lisp
@@ -44,8 +44,6 @@



-
-
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; 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
@@ -62,12 +60,12 @@

 (defvar *inherit-cl-compiler-macros* nil
   "When true, mc:compiler-macro-function will fall back to
-cl:compiler-macro-function for symbols exported form the common-lisp package.")
+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 form the common-lisp package.")
+exported from the common-lisp package.")


 (defvar *cl-compiler-macros*
@@ -101,6 +99,11 @@ exported form the common-lisp package.")

 ;;;; 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
@@ -189,6 +192,11 @@ exported form the common-lisp package.")

 (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)
@@ -202,7 +210,7 @@ exported form the common-lisp package.")


 (cl:defun compiler-macro-function (name &optional environment)
-  (let ((environment (or environment  *global-environment*)))
+  (let ((environment (or environment *global-environment*)))
     (or (get name 'compiler-macro-function nil)
         (and (eq *global-environment* environment)
              ;; get global compiler macro
@@ -212,25 +220,26 @@ exported form the common-lisp package.")


 (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)))
+  (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)
-        (declarations)
-        (body))
+        (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)))
+               (destructuring-bind ,lambda-list ,whole
+                 (locally ,@declarations ,@body)))
              (documentation ',name 'mc::compiler-macro-function) ',docstring)
        ',name)))

@@ -251,7 +260,7 @@ exported form the common-lisp package.")


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


@@ -267,16 +276,15 @@ exported form the common-lisp package.")


 (cl:defun macro-function (symbol &optional environment)
-  (let* ((environment (or environment  *global-environment*))
-         (macro       (find symbol (environment-macros environment)
-                            :key (function first))))
+  (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)))))
+        (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)
@@ -287,29 +295,29 @@ exported form the common-lisp package.")
 (cl:defun make-macro (name lambda-list body)
   "
 RETURN: a lambda form for the macro function ; a documentation string (or nil)"
-  (let ((ll            (source-form:parse-lambda-list lambda-list :macro))
+  (let ((ll            (parse-lambda-list lambda-list :macro))
         (vwhole        (gensym "whole"))
         (venvir        (gensym "env"))
         (bindings      '())
-        (docstring     (source-form:extract-documentation body))
-        (declarations  (source-form:extract-declarations  body))
-        (body          (source-form:extract-body          body)))
-    (when (source-form:lambda-list-whole-parameter-p ll)
-      (push (list (source-form:parameter-name
-                   (source-form:lambda-list-whole-parameter ll))
+        (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 (source-form:lambda-list-environment-parameter-p ll)
-      (push (list (source-form:parameter-name
-                   (source-form:lambda-list-environment-parameter ll))
+    (when (lambda-list-environment-parameter-p ll)
+      (push (list (parameter-name
+                   (lambda-list-environment-parameter ll))
                   venvir) bindings))
-    (change-class ll 'source-form:destructuring-lambda-list)
+    (change-class ll 'destructuring-lambda-list)
     (values `(lambda (,vwhole ,venvir)
-                 (block ,name
-                   (let ,bindings
-                     (destructuring-bind ,(source-form:make-lambda-list ll) (cdr ,vwhole)
-                       ,@(if declarations
-                             `((locally ,@declarations ,@body))
-                             body)))))
+               (block ,name
+                 (let ,bindings
+                   (destructuring-bind ,(make-lambda-list ll) (cdr ,vwhole)
+                     ,@(if declarations
+                           `((locally ,@declarations ,@body))
+                           body)))))
             docstring)))


@@ -329,9 +337,9 @@ RETURN: a lambda form for the macro function ; a documentation string (or nil)"
      `(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)))))
+                (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))))

@@ -339,25 +347,25 @@ RETURN: a lambda form for the macro function ; a documentation string (or nil)"
 (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 op environment)))
-      (if mf
-        (values (funcall (coerce *macroexpand-hook* 'function)
-                         mf form environment)
-                t)
-        (values form nil)))))
+      (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))))
+        (macroexpand expansion environment)
+        (values expansion expanded-p))))



@@ -379,10 +387,10 @@ RETURN: a lambda form for the macro function ; a documentation string (or nil)"
 ;;;

 (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)
+  '(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

@@ -452,15 +460,15 @@ 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)))
+      (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)
@@ -494,8 +502,8 @@ of the minimal compiler."
 (cl:defun so/return-from (env name &optional (result nil resultp))
   (declare (ignore env))
   (if resultp
-    `(return-from ,name ,result)
-    `(return-from ,name)))
+      `(return-from ,name ,result)
+      `(return-from ,name)))

 (cl:defun so/symbol-macrolet (env bindings body)
   (declare (ignore env))
@@ -548,7 +556,7 @@ RETURN: a new hash-table with all the key-value from BASE-MAP,
                 (or (functionp v)
                     (and (symbol v)
                          (fboundp v))))))
-    (let ((ht (COM.INFORMATIMAGO.COMMON-LISP.UTILITY:COPY-HASH-TABLE base-map)))
+    (let ((ht (copy-hash-table base-map)))
       (cond
         ((and (hash-table-p overlay)
               (loop
@@ -559,7 +567,7 @@ RETURN: a new hash-table with all the key-value from BASE-MAP,
             :do (setf (gethash k ht) (gethash k overlay))))
         ((and (listp overlay)
               (every (lambda (item)
-                         (and (consp item) (valid-pair-p (car item) (cdr item))))
+                       (and (consp item) (valid-pair-p (car item) (cdr item))))
                      overlay))
          ;; a-list
          (loop
@@ -582,8 +590,8 @@ RETURN: a new hash-table with all the key-value from BASE-MAP,
 (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))))
+        (apply sopfun env arguments)
+        (error "Not a special operator ~S" special-operator))))



@@ -604,8 +612,8 @@ RETURN: a new hash-table with all the key-value from BASE-MAP,
 (cl:defun minimal-compile-lambda              (env form)
   (destructuring-bind (lambda lambda-list &body body) form
     (let ((env (extend-environment-with-lambda-list
-                (source-form:make-argument-list-form
-                 (source-form:parse-lambda-list lambda-list))
+                (make-argument-list-form
+                 (parse-lambda-list lambda-list))
                 env)))
       `(lambda ,lambda-list
          ,@(mapcar (lambda (form) (%minimal-compile env form))
@@ -630,12 +638,13 @@ RETURN: a new hash-table with all the key-value from BASE-MAP,
        (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)))
+        (%minimal-compile env (cdr symac))
+        form)))


 (cl:defun minimal-compile/function             (env form)
@@ -660,27 +669,28 @@ RETURN: a new hash-table with all the key-value from BASE-MAP,
 (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))))
+            (%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
-             (mapcar (lambda (subform) (%minimal-compile env subform)) body))))
+;;;; 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))))
+        (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))))
+            (mapcar (lambda (subform) (%minimal-compile env subform)) body))))


 (cl:defun minimal-compile/throw                (env form)
@@ -690,18 +700,21 @@ RETURN: a new hash-table with all the key-value from BASE-MAP,

 (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))))
+            (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)
-                           subform      ; a tag
-                           (%minimal-compile env subform)))
-                     body))))
+            (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)
@@ -712,21 +725,21 @@ RETURN: a new hash-table with all the key-value from BASE-MAP,
 (cl:defun minimal-compile/flet                 (env form)
   (destructuring-bind (flet bindings &rest body) form
     (gensop env flet
-             (mapcar (lambda (fun)
-                         `(,(first fun) ,(second fun)
+            (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)))))
+                         ,(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)
@@ -734,54 +747,54 @@ RETURN: a new hash-table with all the key-value from BASE-MAP,
     (let ((env (extend-environment-with-functions
                 (mapcar (function first) bindings) env)))
       (gensop env labels
-               (mapcar (lambda (fun)
-                           `(,(first fun) ,(second fun)
+              (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)))))
+                           ,(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))))
+        (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))))



@@ -798,31 +811,33 @@ RETURN: a new hash-table with all the key-value from BASE-MAP,

 (cl:defun split-declarations (body)
 ;;;; TODO: check source-form.lisp; what about "docstrings" in declaration* body*?
-  (values (source-form:extract-declarations body)
-          (source-form:extract-body         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)))))))
+            (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)
@@ -830,10 +845,10 @@ RETURN: a new hash-table with all the key-value from BASE-MAP,
     (%minimal-compile
      env (labels ((wrap (bindings expr)
                     (if (null bindings)
-                      expr
-                      (wrap (cdr bindings)
-                            (gensop env 'let (list (car bindings))
-                                     (list expr))))))
+                        expr
+                        (wrap (cdr bindings)
+                              (gensop env 'let (list (car bindings))
+                                      (list expr))))))
            (wrap (reverse bindings)
                  (gensop env 'locally body))))))

@@ -841,15 +856,15 @@ RETURN: a new hash-table with all the key-value from BASE-MAP,
 (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))))
+            (%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))))
+            (%minimal-compile env first-form)
+            (mapcar (lambda (expr) (%minimal-compile env expr)) body))))


 (cl:defun minimal-compile/progn                (env form)
@@ -860,16 +875,17 @@ RETURN: a new hash-table with all the key-value from BASE-MAP,
 (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))))
+            (%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)))))
+              (mapcar (lambda (expr) (%minimal-compile env expr)) forms)))))


 (cl:defun minimal-compile/the                  (env form)
@@ -880,15 +896,15 @@ RETURN: a new hash-table with all the key-value from BASE-MAP,
 (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))))
+            (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))))
+        (gensop env load-time-value form read-only-p)
+        (gensop env load-time-value form))))



@@ -928,6 +944,7 @@ RETURN: a new hash-table with all the key-value from BASE-MAP,
        ((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))
ViewGit