Implemented defun, defconstant, defvar, defparameter, defpackage, deftype, defclass.

Pascal J. Bourguignon [2014-10-10 01:48]
Implemented defun, defconstant, defvar, defparameter, defpackage, deftype, defclass.
Filename
standard-macros.lisp
diff --git a/standard-macros.lisp b/standard-macros.lisp
index 54af8df..bff90ab 100644
--- a/standard-macros.lisp
+++ b/standard-macros.lisp
@@ -6,7 +6,13 @@
 ;;;;USER-INTERFACE:     NONE
 ;;;;DESCRIPTION
 ;;;;
-;;;;    XXX
+;;;;    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>
@@ -34,8 +40,7 @@
 ;;;;    Boston, MA 02111-1307 USA
 ;;;;**************************************************************************

-(in-package "MINIMAL-COMPILER")
-
+(in-package "STANDARD-MACROS")

 ;; (CALL-NEXT-METHOD                        "Local Function")
 ;; (NEXT-METHOD-P                           "Local Function")
@@ -52,19 +57,299 @@



-(mc:defmacro defun (name lambda-list &body body)
+
+
+(defmacro defun (name lambda-list &body body)
   `(progn
      (setf (symbol-value ',name)
            (lambda ,lambda-list
-             ,@(source-form:extract-declarations body)
-             (block ,name ,@(source-form:extract-body body))))
-     ,@(when (and (stringp (first body))
-                  (rest body))
-             `((setf (documentation ',name 'function) ',(first body))))
+             ,@(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)
@@ -73,7 +358,7 @@
     `(so/setf ,place ,value)))


-(mc:defmacro setf (&whole form &environment env &rest 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))
@@ -94,10 +379,7 @@



-
-
-
-(mc:defmacro and (&body args)
+(defmacro and (&body args)
   (cond ((null args)        't)
         ((null (cdr args))  (car args))
         (t  (let* ((clauses (reverse args))
@@ -106,7 +388,7 @@
                 (setf form `(if (not ,clause) nil ,form)))))))


-(mc:defmacro or (&body args)
+(defmacro or (&body args)
   (cond ((null args)        'nil)
         ((null (cdr args))  (car args))
         (t  (let* ((clauses (reverse args))
@@ -119,11 +401,11 @@



-(mc:defmacro assert ()
+(defmacro assert ()
   `())


-(mc:defmacro cond (&body clauses)
+(defmacro cond (&body clauses)
   (let ((form 'nil))
     (dolist (clause (reverse clauses) form)
       (when (or (atom clause)
@@ -135,37 +417,37 @@



-(mc:defmacro case ()
+(defmacro case ()
   `())

-(mc:defmacro ccase ()
+(defmacro ccase ()
   `())

-(mc:defmacro ecase ()
+(defmacro ecase ()
   `())



-(mc:defmacro check-type ()
+(defmacro check-type ()
   `())

-(mc:defmacro ctypecase ()
+(defmacro ctypecase ()
   `())

-(mc:defmacro etypecase ()
+(defmacro etypecase ()
   `())



-(mc:defmacro incf ()
+(defmacro incf ()
   `())

-(mc:defmacro decf ()
+(defmacro decf ()
   `())



-(mc:defmacro declaim (&rest declaration-specifiers)
+(defmacro declaim (&rest declaration-specifiers)
   (cond ((null declaration-specifiers) nil)
         ((null (rest declaration-specifiers))
          `(proclaim ',(first declaration-specifiers)))
@@ -176,236 +458,181 @@



-(mc:defmacro defclass ()
-  `())
-
-(mc:defmacro defconstant ()
-  `())
-
-(mc:defmacro defgeneric ()
-  `())
-
-(mc:defmacro define-compiler-macro ()
-  `())
-
-(mc:defmacro define-condition ()
-  `())
-
-(mc:defmacro define-method-combination ()
-  `())
-
-(mc:defmacro define-modify-macro ()
-  `())
-
-(mc:defmacro define-setf-expander ()
-  `())
-
-(mc:defmacro define-symbol-macro ()
-  `())
-
-(mc:defmacro defmacro ()
-  `())
-
-(mc:defmacro defmethod ()
-  `())
-
-(mc:defmacro defpackage ()
-  `())
-
-(mc:defmacro defparameter ()
-  `())
-
-(mc:defmacro defsetf ()
-  `())
-
-(mc:defmacro defstruct ()
-  `())
-
-(mc:defmacro deftype ()
-  `())
-
-(mc:defmacro defun ()
-  `())
-
-(mc:defmacro defvar ()
-  `())
-
-
-

-(mc:defmacro destructuring-bind ()
+(defmacro destructuring-bind ()
   `())

-(mc:defmacro do ()
+(defmacro do ()
   `())

-(mc:defmacro do* ()
+(defmacro do* ()
   `())

-(mc:defmacro do-all-symbols ()
+(defmacro do-all-symbols ()
   `())

-(mc:defmacro do-external-symbols ()
+(defmacro do-external-symbols ()
   `())

-(mc:defmacro do-symbols ()
+(defmacro do-symbols ()
   `())

-(mc:defmacro dolist ()
+(defmacro dolist ()
   `())

-(mc:defmacro dotimes ()
+(defmacro dotimes ()
   `())

-(mc:defmacro formatter ()
+(defmacro formatter ()
   `())

-(mc:defmacro handler-bind ()
+(defmacro handler-bind ()
   `())

-(mc:defmacro handler-case ()
+(defmacro handler-case ()
   `())

-(mc:defmacro ignore-errors ()
+(defmacro ignore-errors ()
   `())

-(mc:defmacro in-package ()
+(defmacro in-package ()
   `())


-(mc:defmacro lambda (&whole form arguments &body body)
+(defmacro lambda (&whole form arguments &body body)
   (declare (ignore arguments body))
   `(function ,form))


-(mc:defmacro loop ()
+(defmacro loop ()
   `())

-(mc:defmacro multiple-value-bind ()
+(defmacro multiple-value-bind ()
   `())

-(mc:defmacro multiple-value-list ()
+(defmacro multiple-value-list ()
   `())

-(mc:defmacro multiple-value-setq ()
+(defmacro multiple-value-setq ()
   `())

-(mc:defmacro nth-value ()
+(defmacro nth-value ()
   `())




-(mc:defmacro pprint-logical-block ()
+(defmacro pprint-logical-block ()
   `())

-(mc:defmacro print-unreadable-object ()
+(defmacro print-unreadable-object ()
   `())

-(mc:defmacro prog ()
+(defmacro prog ()
   `())

-(mc:defmacro prog* ()
+(defmacro prog* ()
   `())

-(mc:defmacro prog1 ()
+(defmacro prog1 ()
   `())

-(mc:defmacro prog2 ()
+(defmacro prog2 ()
   `())



-(mc:defmacro psetf ()
+(defmacro psetf ()
   `())

-(mc:defmacro psetq ()
+(defmacro psetq ()
   `())


-(mc:defmacro push ()
+(defmacro push ()
   `())

-(mc:defmacro pushnew ()
+(defmacro pushnew ()
   `())

-(mc:defmacro pop ()
+(defmacro pop ()
   `())


-(mc:defmacro remf ()
+(defmacro remf ()
   `())

-(mc:defmacro restart-bind ()
+(defmacro restart-bind ()
   `())

-(mc:defmacro restart-case ()
+(defmacro restart-case ()
   `())

-(mc:defmacro return ()
+(defmacro return ()
   `())

-(mc:defmacro rotatef ()
+(defmacro rotatef ()
   `())

-(mc:defmacro setf ()
+(defmacro setf ()
   `())

-(mc:defmacro shiftf ()
+(defmacro shiftf ()
   `())

-(mc:defmacro step ()
+(defmacro step ()
   `())

-(mc:defmacro time ()
+(defmacro time ()
   `())

-(mc:defmacro trace ()
+(defmacro trace ()
   `())

-(mc:defmacro typecase ()
+(defmacro typecase ()
   `())

-(mc:defmacro unless ()
+(defmacro unless ()
   `())

-(mc:defmacro untrace ()
+(defmacro untrace ()
   `())

-(mc:defmacro when ()
+(defmacro when ()
   `())

-(mc:defmacro with-accessors ()
+(defmacro with-accessors ()
   `())

-(mc:defmacro with-compilation-unit ()
+(defmacro with-compilation-unit ()
   `())

-(mc:defmacro with-condition-restarts ()
+(defmacro with-condition-restarts ()
   `())

-(mc:defmacro with-hash-table-iterator ()
+(defmacro with-hash-table-iterator ()
   `())

-(mc:defmacro with-input-from-string ()
+(defmacro with-input-from-string ()
   `())

-(mc:defmacro with-open-stream ()
+(defmacro with-open-stream ()
   `())

-(mc:defmacro with-output-to-string ()
+(defmacro with-output-to-string ()
   `())

-(mc:defmacro with-package-iterator ()
+(defmacro with-package-iterator ()
   `())

-(mc:defmacro with-simple-restart ()
+(defmacro with-simple-restart ()
   `())

-(mc:defmacro with-slots ()
+(defmacro with-slots ()
   `())

-(mc:defmacro with-standard-io-syntax ()
+(defmacro with-standard-io-syntax ()
   `())


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