diff --git a/ansi-tests/structure-00.lsp b/ansi-tests/structure-00.lsp index ee2b6b8f503c7f2d2f227e83225cd54532d71e78..7d20c76f64471e5ada666af169614fb35212749b 100644 --- a/ansi-tests/structure-00.lsp +++ b/ansi-tests/structure-00.lsp @@ -33,11 +33,14 @@ (defun make-struct-field-fn (conc-name field-name) "Make field accessor for a field in a structure" - (assert (typep conc-name '(or string symbol character))) - (assert (typep field-name '(or string symbol character))) - (setf conc-name (string conc-name)) - (setf field-name (string field-name)) - (intern (concatenate 'string conc-name field-name))) + (cond + ((null conc-name) field-name) + (t + (assert (typep conc-name '(or string symbol character))) + (assert (typep field-name '(or string symbol character))) + (setf conc-name (string conc-name)) + (setf field-name (string field-name)) + (intern (concatenate 'string conc-name field-name))))) (defun make-struct-make-fn (structure-name) "Make the make- function for a structure" @@ -136,6 +139,7 @@ do the defstruct." (name (if (consp name-and-options) (car name-and-options) name-and-options)) + ;; The options list, or NIL if there were no options (options (if (consp name-and-options) (cdr name-and-options) @@ -165,6 +169,12 @@ do the defstruct." ;; Symbol obtained by prepending MAKE- to the name symbol (make-fn (make-struct-make-fn name)) + ;; The type option, if specified + (type-option (find-option options :type)) + (struct-type (second type-option)) + + (named-option (find-option options :named)) + ;; The :predicate option entry from OPTIONS, or NIL if none (predicate-option (find-option options :predicate)) @@ -172,6 +182,7 @@ do the defstruct." ;; one specified in the :predicate option (p-fn-default (make-struct-p-fn name)) (p-fn (cond + ((and type-option (not named-option)) nil) ((or (eq predicate-option :predicate) (null (cdr predicate-option))) p-fn-default) @@ -194,16 +205,18 @@ do the defstruct." (conc-option (find-option options :conc-name)) ;; String to be prepended to slot names to get the ;; slot accessor function - (conc-prefix-default - (concatenate 'string (string name) "-")) + (conc-prefix-default (concatenate 'string (string name) "-")) (conc-prefix (cond ((null conc-option) conc-prefix-default) ((or (eq conc-option :conc-name) (null (cadr conc-option))) - "") + nil) (t (string (cadr conc-option))))) + (initial-offset-option (find-option options :initial-offset)) + (initial-offset (second initial-offset-option)) + ;; Accessor names (field-fns (loop for slot-name in slot-names @@ -230,7 +243,9 @@ do the defstruct." (and (fboundp (quote ,make-fn)) (functionp (function ,make-fn)) (symbol-function (quote ,make-fn)) - (notnot (typep (,make-fn) (quote ,name)))) + ,@(unless type-option + `((typep (,make-fn) (quote ,name)))) + t) t) ;; Test that the predicate exists @@ -249,10 +264,11 @@ do the defstruct." (count-if (function ,p-fn) *universe*) 0))) - (deftest ,(make-struct-test-name name 4) - (count-if (function (lambda (x) (typep x (quote ,name)))) - *universe*) - 0) + ,@(unless type-option + `((deftest ,(make-struct-test-name name 4) + (count-if (function (lambda (x) (typep x (quote ,name)))) + *universe*) + 0))) ;; Check that the fields can be read after being initialized (deftest ,(make-struct-test-name name 5) diff --git a/ansi-tests/structures-02.lsp b/ansi-tests/structures-02.lsp index d278ac3e393ef69fcecef4457b6d74a7381a46e5..cceb799d6953558431e159965b2a9dfe7191ff2d 100644 --- a/ansi-tests/structures-02.lsp +++ b/ansi-tests/structures-02.lsp @@ -175,6 +175,39 @@ (b29 'xx :read-only 1) c29) +(defstruct-with-tests struct-test-30 #:a30 #:b30) +(defstruct-with-tests #:struct-test-31 a31 b31) + +(defpackage struct-test-package (:use)) + +(defstruct-with-tests struct-test-32 + struct-test-package::a32 struct-test-package::b32) + +;;; If the :conc-name option is given no argument or +;;; a nil argument, the accessor names are the same as +;;; slot names. Note that this is different from prepending +;;; an empty string, since that may get you a name in +;;; a different package. + +(defstruct-with-tests (struct-test-33 (:conc-name)) + struct-test-package::a33 struct-test-package::b33) +(defstruct-with-tests (struct-test-34 :conc-name) + struct-test-package::a34 struct-test-package::b34) +(defstruct-with-tests (struct-test-35 (:conc-name nil)) + struct-test-package::a35 struct-test-package::b35) + +(defstruct-with-tests (struct-test-36 (:conc-name "")) + struct-test-package::st36-a36 struct-test-package::st26-b36) + +;;; List structures + +(defstruct-with-tests (struct-test-37 (:type list)) a37 b37 c37) +(defstruct-with-tests (struct-test-38 (:type list) :named) a38 b38 c38) +(defstruct-with-tests (struct-test-39 (:predicate nil) + (:type list) :named) + a39 b39 c39) + +