;;;; -*- mode:lisp;coding:utf-8 -*-
;;;;FILE:               standard-macros.lisp
;;;;LANGUAGE:           Common-Lisp
;;;;SYSTEM:             Common-Lisp
;;;;    This file defines standard Common Lisp macros, in a generic,
;;;;    portable way.
;;;;    DEFMACRO should be defined in the current package, and all the
;;;;    other CL macros should be shadowed.
;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
;;;;    2010-02-27 <PJB> Created.
;;;;    GPL
;;;;    Copyright Pascal J. Bourguignon 2010 - 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
;;;;    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 "STANDARD-MACROS")

;; (CALL-NEXT-METHOD                        "Local Function")
;; (NEXT-METHOD-P                           "Local Function")
;; (CALL-METHOD                             "Local Macro")
;; (LOOP-FINISH                             "Local Macro")
;; (MAKE-METHOD                             "Local Macro")
;; (PPRINT-EXIT-IF-LIST-EXHAUSTED           "Local Macro")
;; (PPRINT-POP                              "Local Macro")


(defmacro defun (name lambda-list &body body)
     (setf (symbol-value ',name)
           (lambda ,lambda-list
             ,@(extract-declarations body)
             (block ,name ,@(extract-body body))))
     ,@(let ((docstring (extract-documentation body)))
            (cl:when (stringp docstring)
              `((setf (documentation ',name 'function) ',docstring))))

(eval-when (:execute :compile-toplevel :load-toplevel)

  (cl:defun string-designator-p (object)
    (cl:or (stringp object)
           (symbolp object)
           (characterp object)))

  (cl:defun define-variable (whole name value docstring)
    (cl:unless (symbolp name)
      (error 'source-program-error-invalid-variable-name
             :source-form whole
             :erroneous-subform name))
    (cl:unless (cl:or (null docstring) (stringp docstring))
      (error 'source-program-error-invalid-documentation-string
             :source-form whole
             :erroneous-subform docstring))
       (eval-when (:compile-toplevel :load-toplevel :execute)
         ,(if (eq (first whole) 'defconstant)
              `(proclaim '(constant ,name))
              `(proclaim '(special  ,name)))
         ,@(cl:when (eq (first whole) 'defconstant)
                    `((setf (symbol-value ',name) ,value)))
         ,@(cl:when docstring
                    `((setf (documentation ',name 'variable) ',docstring))))
       (eval-when (:load-toplevel :execute)
         (if (eq (first whole) 'defvar)
             `(unless (boundp ',name)
                (setf (symbol-value ',name) ,value))
             `(setf (symbol-value ',name) ,value)))


(defmacro defconstant (&whole whole name value &optional docstring)
  (define-variable whole name value docstring))

(defmacro defvar (&whole whole name value &optional docstring)
  (define-variable whole name value docstring))

(defmacro defparameter (&whole whole name value &optional docstring)
  (define-variable whole name value docstring))

(defmacro defpackage (&whole whole name &rest options)
  (let ((nicknames  '())
        (docstring  nil)
        (uses       '())
        (usesp      nil)
        (shadows    '())
        (shadowing-imports '())
        (imports    '())
        (exports    '())
        (interns    '())
        (size       nil))
    (cl:unless (string-designator-p name)
      (error 'source-program-error-invalid-variable-name
             :source-form whole
             :erroneous-subform name))
     :for option :in options
     :do (if (atom option)
             (error 'source-program-error-invalid-defpackage-clause
                    :source-form whole
                    :erroneous-form option)
             (cl:case (first option)
                (cl:destructuring-bind (key &rest nicks) option
                  (appendf (mapcar (function string) nicks) nicknames)))
                (cl:destructuring-bind (key doc) option
                     (error 'source-program-error-too-many-documentation-strings
                            :source-form whole
                            :erroneous-form ))
                    ((not (stringp doc))
                     (error 'source-program-error-invalid-documentation-string
                            :source-form whole
                            :erroneous-subform doc))
                     (cl:setf docstring doc)))))
                (cl:setf usesp t)
                (appendf (mapcar (function string) (rest option)) uses))
                (appendf (mapcar (function string) (rest option)) shadows))
                (cl:destructuring-bind (key package-name &rest symbol-names) option
                  (cl:push (cons (string package-name)
                                 (mapcar (function string) symbol-names))
                (cl:destructuring-bind (key package-name &rest symbol-names) option
                  (cl:push (cons (string package-name)
                                 (mapcar (function string) symbol-names))
                (appendf (mapcar (function string) (rest option)) exports))
                (appendf (mapcar (function string) (rest option)) interns))
                (cl:destructuring-bind (key given-size) option
                     (error 'source-program-error-too-many-size-clauses
                            :source-form whole
                            :erroneous-form option))
                    ((not (typep given-size '(integer 0)))
                     (error 'type-error :datum given-size :expected-type '(integer 0)))
                     (cl:setf size given-size)))))
                (error 'source-program-error-invalid-defpackage-clause
                       :source-form whole
                       :erroneous-form option)))))
    (cl:setf nicknames         (remove-duplicates nicknames         :test (function string=))
             uses              (remove-duplicates uses              :test (function string=))
             shadows           (remove-duplicates shadows           :test (function string=))
             shadowing-imports (remove-duplicates shadowing-imports :test (function string=))
             imports           (remove-duplicates imports           :test (function string=))
             exports           (remove-duplicates exports           :test (function string=))
             interns           (remove-duplicates interns           :test (function string=)))
    (flet ((check-disjoint (inters a b)
             (cl:when inters
               (error 'source-program-error-symbol-lists-must-be-disjoint
                      :source-form whole
                      :erroneous-form whole
                      :intersection inters
                      :one-symbol-list a
                      :other-symbol-list b))))
      (check-disjoint (intersection shadowing-imports shadows :test (function string=))
                      :shadowing-import-from :shadow)
      (check-disjoint (intersection shadowing-imports interns :test (function string=))
                      :shadowing-import-from :interns)
      (check-disjoint (intersection shadowing-imports imports :test (function string=))
                      :shadowing-import-from :import-from)
      (check-disjoint (intersection shadows           interns :test (function string=))
                      :shadow  :interns)
      (check-disjoint (intersection shadows           imports :test (function string=))
                      :shadow  :import-from)
      (check-disjoint (intersection interns           imports :test (function string=))
                      :intern  :import-from))
    (flet ((gen-symbols-from (operator pack-var lists)
             (mapcan (cl:lambda (si)
                       (cl:destructuring-bind (package-name &rest symbol-names) si
                         (cl:when symbol-names
                           `((let ((package (find-package package-name)))
                               (unless package
                                 ;; undefined package
                                 (error 'package-error-package-not-found :package package-name))
                                (mapcan (lambda (sname)
                                          (let ((symbol (find-symbol sname package)))
                                            (if symbol
                                                (cerror 'PACKAGE-ERROR-SYMBOL-NOT-FOUND
                                                        :package package
                                                        :symbol-name sname)
                                                (list symbol))))
      (let ((vpack (gensym)))
        `(let ((,vpack (make-package ',(string name) :nicknames ',nicknames :use '())))
           (shadow ',shadows ,vpack)
           ,@(gen-symbols-from 'shadowing-import vpack shadowing-imports)
           (use-package ',(if usesp uses '()) ,vpack)
           ,@(gen-symbols-from 'import           vpack imports)
           (cl:dolist (sname ',interns) (intern sname ,vpack))
           ,@(gen-symbols-from 'export           vpack (cons (string name) exports))

(defmacro deftype (&whole whole type-name lambda-list &body body)
  (let ((docstring    (extract-documentation body))
        (declarations (extract-declarations  body))
        (forms        (extract-body          body)))
    (cl:unless (= 1 (length forms))
      (error 'source-program-error-too-many-deftype-forms
             :source-form whole
             :erroneous-subform forms))
       (eval-when (:compile-toplevel)
         (note-type ',type-name))
       (eval-when (:execute :load-toplevel)
         (ensure-type ',type-name ',lambda-list ',docstring ',declarations ',(first forms))))))

(defmacro defstruct ()

(defmacro defclass (class-name (&rest superclass-names)
                    (&rest slot-specifiers)
                    &rest class-options)
  ;; Note: this is an artificial class definition.
  ;; The purpose is to give code walkers something to shew on.
   :with readers = '()
   :with writers = '()
   :for slot-specifier :in slot-specifiers
   :when (listp slot-specifier)
   :do (cl:destructuring-bind (name &key reader writer accessor &allow-other-keys)
         (cl:when reader   (cl:push (cons name reader)   readers))
         (cl:when accessor (cl:push (cons name accessor) readers))
         (cl:when accessor (cl:push (cons name accessor) writers))
         (cl:when writer   (cl:push (cons name writer)   writers)))
   :finally (let ((docstring (second (assoc :documentation class-options))))
              (print readers)
              (print writers)
                 (ensure-class ',class-name ',superclass-names ',slot-specifiers ',class-options)
                 ,(cl:when docstring `((setf (documentation ',class-name 'class) ,docstring)))
                 (deftype ,class-name () ',class-name)
                 ,@(mapcar (cl:lambda (reader)
                             (print reader)
                             (cl:destructuring-bind (slot-name . method-name) reader
                               `(defmethod ,method-name ((self ,class-name))
                                  (slot-value self ',slot-name))))
                 ,@(mapcar (cl:lambda (writer)
                             (print writer)
                             (cl:destructuring-bind (slot-name . method-name) writer
                               `(defmethod (setf ,method-name) (new-value (self ,class-name))
                                  (setf (slot-value self ',slot-name) new-value))))

(defmacro define-condition ()

(defmacro defgeneric ()

(defmacro defmethod ()

(defmacro define-method-combination ()

(defmacro define-symbol-macro ()

(defmacro define-compiler-macro ()

(defmacro defsetf ()

(defmacro define-setf-expander ()

(defmacro define-modify-macro ()

(cl:defun expand-setf (place value environment)
  (let ((environment (or environment *global-environment*)))
    ;; (if (atom place)
    ;;   (let ((sm ())))
    ;;   )
    `(so/setf ,place ,value)))

(defmacro setf (&whole form &environment env &rest place-value)
  (let ((len (length place-value)))
    (unless (evenp len)
      (error "SETF expects an even number of arguments ~S" form))
    (case len
       `(progn nil))
       (expand-setf (first place-value) (second place-value) env))
               :for (place value) :on place-value :by (function cddr)
               :collect (expand-setf place value env)))))))

(defmacro and (&body args)
  (cond ((null args)        't)
        ((null (cdr args))  (car args))
        (t  (let* ((clauses (reverse args))
                   (form (pop clauses)))
              (dolist (clause clauses form)
                (setf form `(if (not ,clause) nil ,form)))))))

(defmacro or (&body args)
  (cond ((null args)        'nil)
        ((null (cdr args))  (car args))
        (t  (let* ((clauses (reverse args))
                   (form (pop clauses)))
              (dolist (clause clauses form)
                (let ((val (gensym)))
                  (setf form
                        `(let ((,val ,clause))
                           (if ,val ,val ,form)))))))))

(defmacro assert ()

(defmacro cond (&body clauses)
  (let ((form 'nil))
    (dolist (clause (reverse clauses) form)
      (when (or (atom clause)
              (and (rest clause) (atom (rest clause))))
          (error "Invalid syntax for COND clause: ~S" clause))
      (setf form `(if ,(first clause)
                      (progn ,@(rest clause))

(defmacro case ()

(defmacro ccase ()

(defmacro ecase ()

(defmacro check-type ()

(defmacro ctypecase ()

(defmacro etypecase ()

(defmacro typecase ()

(defmacro incf ()

(defmacro decf ()

(defmacro declaim (&rest declaration-specifiers)
  (cond ((null declaration-specifiers) nil)
        ((null (rest declaration-specifiers))
         `(proclaim ',(first declaration-specifiers)))
        (t `(progn
              ,@(mapcar (lambda (declaration-specifier)
                          `(proclaim ',declaration-specifier))

(defmacro destructuring-bind ()

(defmacro do ()

(defmacro do* ()

(defmacro dolist ()

(defmacro dotimes ()

(defmacro formatter (control-string)
  ;; This is not simpleā€¦
  ;; The function generated, should process the arguments according to
  ;; control-string and return the tail that is not processed.  But
  ;; control-string may process a variable number of arguments
  ;; depending on them their values.
  ;; Therefore this arguments-tail must be computed at the same time
  ;; the arguments are actually processed by the control-string.
  ;; `(lambda (*standard-output* &rest arguments)
  ;;    (apply #'format t ',control-string arguments)
  ;;    arguments-tail)

(defmacro handler-bind ()

(defmacro handler-case ()

(defmacro ignore-errors ()

(defmacro in-package ()

(defmacro lambda (&whole form arguments &body body)
  (declare (ignore arguments body))
  `(function ,form))

(defmacro loop ()

(defmacro multiple-value-bind ()

(defmacro multiple-value-list ()

(defmacro multiple-value-setq ()

(defmacro nth-value ()

(defmacro pprint-logical-block ()

(defmacro print-unreadable-object ()

(defmacro prog ()

(defmacro prog* ()

(defmacro prog1 ()

(defmacro prog2 ()

(defmacro psetf ()

(defmacro psetq ()

(defmacro push ()

(defmacro pushnew ()

(defmacro pop ()

(defmacro remf ()

(defmacro restart-bind ()

(defmacro restart-case ()

(defmacro return ()

(defmacro rotatef ()

(defmacro setf ()

(defmacro shiftf ()

(defmacro step ()

(defmacro time ()

(defmacro trace (&rest function-names)
  (if function-names
      `(progn ,@(mapcar (lambda (fname) `(trace-function ',fname)) function-names))

(defmacro untrace (&rest function-names)
  `(progn ,@(mapcar (lambda (fname) `(untrace-function ',fname)) function-names)))

(defmacro unless (test-form &body body)
  `(if ,test-form nil (progn ,@body)))

(defmacro when (test-form &body body)
  `(if ,test-form (progn ,@body)))

(defmacro with-accessors ()

(defmacro with-slots ()

(defmacro with-compilation-unit ()

(defmacro with-condition-restarts ()

(defmacro with-simple-restart ()

(defmacro with-standard-io-syntax ()

(defmacro with-hash-table-iterator ()

(defmacro with-package-iterator ()

(defmacro do-all-symbols ()

(defmacro do-external-symbols ()

(defmacro do-symbols ()

(defmacro with-open-stream ()

(defmacro with-input-from-string ()

(defmacro with-output-to-string ()

;;;; THE END ;;;;