Pascal J. Bourguignon [2014-10-10 01:48]
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 ;;;;