;;;; -*- mode:lisp;coding:utf-8 -*-
;;;;**************************************************************************
;;;;FILE:               standard-macros.lisp
;;;;LANGUAGE:           Common-Lisp
;;;;SYSTEM:             Common-Lisp
;;;;USER-INTERFACE:     NONE
;;;;DESCRIPTION
;;;;
;;;;    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.
;;;;
;;;;
;;;;AUTHORS
;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
;;;;MODIFICATIONS
;;;;    2010-02-27 <PJB> Created.
;;;;BUGS
;;;;LEGAL
;;;;    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
;;;;    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 "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")


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; STANDARD MACROS (SHADOWED).
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(defmacro defun (name lambda-list &body body)
  `(progn
     (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))))
     ',name))



(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))
    `(progn
       (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)))
       ',name))

  );;eval-when



(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))
    (cl:loop
     :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)
               ((:nicknames)
                (cl:destructuring-bind (key &rest nicks) option
                  (appendf (mapcar (function string) nicks) nicknames)))
               ((:documentation)
                (cl:destructuring-bind (key doc) option
                  (cl:cond
                    (docstring
                     (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))
                    (t
                     (cl:setf docstring doc)))))
               ((:use)
                (cl:setf usesp t)
                (appendf (mapcar (function string) (rest option)) uses))
               ((:shadow)
                (appendf (mapcar (function string) (rest option)) shadows))
               ((:shadowing-import-from)
                (cl:destructuring-bind (key package-name &rest symbol-names) option
                  (cl:push (cons (string package-name)
                                 (mapcar (function string) symbol-names))
                           shadowing-imports)))
               ((:import-from)
                (cl:destructuring-bind (key package-name &rest symbol-names) option
                  (cl:push (cons (string package-name)
                                 (mapcar (function string) symbol-names))
                           imports)))
               ((:export)
                (appendf (mapcar (function string) (rest option)) exports))
               ((:intern)
                (appendf (mapcar (function string) (rest option)) interns))
               ((:size)
                (cl:destructuring-bind (key given-size) option
                  (cl:cond
                    (size
                     (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)))
                    (t
                     (cl:setf size given-size)))))
               (otherwise
                (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))
                               (,operator
                                (mapcan (lambda (sname)
                                          (let ((symbol (find-symbol sname package)))
                                            (if symbol
                                                (cerror 'PACKAGE-ERROR-SYMBOL-NOT-FOUND
                                                        :package package
                                                        :symbol-name sname)
                                                (list symbol))))
                                        ',symbol-names)
                                ,pack-var))))))
                     lists)))
      (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))
           ,vpack)))))



(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))
    `(progn
       (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.
  (cl:loop
   :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)
           slot-specifier
         (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)
              `(progn
                 (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))))
                           readers)
                 ,@(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))))
                           writers)
                 ',class-name))))


(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
      (0
       `(progn nil))
      (2
       (expand-setf (first place-value) (second place-value) env))
      (otherwise
       `(progn
          ,@(loop
               :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))
                      ,form)))))



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




(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))
      `(traced-functions)))

(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 ;;;;
ViewGit