;;;; -*- 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 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 do-all-symbols ()

(defmacro do-external-symbols ()

(defmacro do-symbols ()

(defmacro dolist ()

(defmacro dotimes ()

(defmacro formatter ()

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

(defmacro typecase ()

(defmacro unless ()

(defmacro untrace ()

(defmacro when ()

(defmacro with-accessors ()

(defmacro with-compilation-unit ()

(defmacro with-condition-restarts ()

(defmacro with-hash-table-iterator ()

(defmacro with-input-from-string ()

(defmacro with-open-stream ()

(defmacro with-output-to-string ()

(defmacro with-package-iterator ()

(defmacro with-simple-restart ()

(defmacro with-slots ()

(defmacro with-standard-io-syntax ()

;;;; THE END ;;;;