From fd95d47cc6e6cb011b19db35f4590571bd9acb06 Mon Sep 17 00:00:00 2001 From: ram <ram> Date: Thu, 22 Feb 1990 11:46:14 +0000 Subject: [PATCH] .../systems-work/code/defstruct.lisp, 07-Feb-90 16:41:55, Edit by Chiles. Fixed '(:constructor) bug that failed to create a default constructor. /usr/lisp/code/defstruct.lisp, 26-Jul-89 19:10:17, Edit by Mbb. Structures that include another structure now inherit it's print-function if they do not have their own. This inheritance may be suppressed by supplying :print-function without a name. This is a cleanup. /usr/lisp/code/defstruct.lisp, 26-Jul-89 16:23:50, Edit by Mbb. Made BOA-constuctors only half that... They now allow &key args. Also made DEFSTRUCT warn when you try to use a keyword as a slot name. This catches users who accidentally do (defstruct foo (:constructor ...) <slots>) instead of (defstruct (foo (:constructor ...)) <slots>). --- code/defstruct.lisp | 119 ++++++++++++++++++++++++++++---------------- 1 file changed, 75 insertions(+), 44 deletions(-) diff --git a/code/defstruct.lisp b/code/defstruct.lisp index 7b50faea4..0e72db581 100644 --- a/code/defstruct.lisp +++ b/code/defstruct.lisp @@ -31,7 +31,6 @@ (declare (ignore depth)) (format stream "#<Defstruct-Description for ~S>" (dd-name structure))) - ;;; DSD-Name -- Internal ;;; ;;; Return the the name of a defstruct slot as a symbol. We store it @@ -43,6 +42,8 @@ (defun print-defstruct-slot-description (structure stream depth) (declare (ignore depth)) (format stream "#<Defstruct-Slot-Description for ~S>" (dsd-name structure))) + + ;;; The legendary macro itself. @@ -97,7 +98,8 @@ (setq name-and-options (list name-and-options))) (do* ((options (cdr name-and-options) (cdr options)) (name (car name-and-options)) - (print-function 'default-structure-print) + (print-function #'default-structure-print) + (pf-supplied-p) (conc-name (concat-pnames name '-)) (constructor (concat-pnames 'make- name)) (saw-constructor) @@ -147,19 +149,41 @@ (push args boa-constructors)) (t (setq saw-constructor t) - (setq constructor (car args))))) + (setq constructor + (or (car args) + (concat-pnames 'make- name)))))) (:copier (setq copier (car args))) (:predicate (setq predicate (car args))) - (:include (setq include args)) - (:print-function (setq print-function (car args))) - (:type (setq saw-type t type (car args))) + (:include + (setf include args) + (let* ((name (car include)) + (included-structure + (or (get name '%structure-definition-in-compiler) + (get name '%structure-definition))) + (included-print-function + (if included-structure + (dd-print-function included-structure)))) + (unless included-structure + (error "Cannot find description of structure ~S to use for ~ + inclusion." + name)) + (unless pf-supplied-p + (setf print-function included-print-function)))) + (:print-function + (setf print-function (or (car args) #'default-structure-print)) + (setf pf-supplied-p t)) + (:type (setf saw-type t type (car args))) (:named (error "The Defstruct option :NAMED takes no arguments.")) - (:initial-offset (setq offset (car args))) + (:initial-offset (setf offset (car args))) (t (error "~S is an unknown Defstruct option." option))))))) + + -;;; Parse-Slot-Descriptions parses the slot descriptions (surprise) and does -;;; any structure inclusion that needs to be done. +;;;; Stuff to parse slot descriptions. +;;; PARSE-SLOT-DESCRIPTIONS parses the slot descriptions (surprise) and does +;;; any structure inclusion that needs to be done. +;;; (defun parse-slot-descriptions (defstruct slots) ;; First strip off any doc string and stash it in the Defstruct. (when (stringp (car slots)) @@ -208,22 +232,26 @@ (car options))))))))))))) ;; Finally parse the slots into Slot-Description objects. (do ((slots slots (cdr slots)) - (index (+ (dd-offset defstruct) (if (dd-named defstruct) 1 0)) (1+ index)) - (descriptions '())) + (index (+ (dd-offset defstruct) (if (dd-named defstruct) 1 0)) + (1+ index)) + (descriptions ())) ((null slots) (setf (dd-length defstruct) index) (setf (dd-slots defstruct) (nreverse descriptions))) - (let ((slot (car slots))) + (let* ((slot (car slots)) + (name (if (atom slot) slot (car slot)))) + (when (keywordp name) + (warn "Keyword slot name indicates possible syntax error in DEFSTRUCT ~ + -- ~S." + name)) (push (if (atom slot) - (let ((name slot)) - (make-defstruct-slot-description - :%name (string name) - :index index - :accessor (concat-pnames (dd-conc-name defstruct) name) - :type t)) + (make-defstruct-slot-description + :%name (string name) + :index index + :accessor (concat-pnames (dd-conc-name defstruct) name) + :type t) (do ((options (cddr slot) (cddr options)) - (name (car slot)) (default (cadr slot)) (type t) (read-only nil)) @@ -410,8 +438,12 @@ (push `(setf (aref ,temp ,(dsd-index slot)) ,(dsd-name slot)) sets))))))))))) + + -;;; Find-Legal-Slot -- Internal +;;;; Support for By-Order-Argument Constructors. + +;;; FIND-LEGAL-SLOT -- Internal ;;; ;;; Given a defstruct description and a slot name, return the corresponding ;;; slot if it exists, or signal an error if not. @@ -421,18 +453,15 @@ (error "~S is not a defined slot name in the ~S structure." name (dd-name defstruct)))) -;;; Define-Boa-Constructors defines positional constructor functions. We generate -;;; code to set each variable not specified in the arglist to the default given -;;; in the Defstruct. We just slap required args in, as with rest args and aux -;;; args. Optionals are treated a little differently. Those that aren't -;;; supplied with a default in the arg list are mashed so that their default in -;;; the arglist is the corresponding default from the Defstruct. -;;; -;;; If we are defining safe accessors, we check the types of the arguments -;;; supplied. We don't bother checking the defaulted arguments since we would -;;; have to figure out how to eval the defaults only once, and it probably -;;; isn't worth the effort anyway. +;;; Define-Boa-Constructors defines positional constructor functions. We +;;; generate code to set each variable not specified in the arglist to the +;;; default given in the Defstruct. We just slap required args in, as with +;;; rest args and aux args. Optionals are treated a little differently. Those +;;; that aren't supplied with a default in the arg list are mashed so that +;;; their default in the arglist is the corresponding default from the +;;; Defstruct. +;;; (defun define-boa-constructors (defstruct) (do* ((boas (dd-boa-constructors defstruct) (cdr boas)) (name (car (car boas)) (car (car boas))) @@ -446,19 +475,20 @@ (arg-kind 'required)) ((null args)) (let ((arg (car args))) - (if (atom arg) - (if (memq arg '(&optional &rest &aux)) - (setq arg-kind arg) - (case arg-kind - ((required &rest &aux) - (push (find-legal-slot defstruct arg) slots-in-arglist)) - (&optional - (let ((dsd (find-legal-slot defstruct arg))) - (push dsd slots-in-arglist) - (rplaca args (list arg (dsd-default dsd))))))) - (push (find-legal-slot defstruct (car arg)) slots-in-arglist)))) + (cond ((not (atom arg)) + (push (find-legal-slot defstruct (car arg)) slots-in-arglist)) + ((memq arg '(&optional &rest &aux &key)) + (setq arg-kind arg)) + (t + (case arg-kind + ((required &rest &aux) + (push (find-legal-slot defstruct arg) slots-in-arglist)) + ((&optional &key) + (let ((dsd (find-legal-slot defstruct arg))) + (push dsd slots-in-arglist) + (rplaca args (list arg (dsd-default dsd)))))))))) - ;; Then make a list that can be used with a (list ...) or (vector ...). + ;; Then make a list that can be used with a (list ...) or (vector...). (let ((initial-cruft (if (dd-named defstruct) (make-list (1+ (dd-offset defstruct)) @@ -516,7 +546,8 @@ ;;; desired. This is only called for typed structures, since the default ;;; structure predicate is implemented as a closure. -(defun define-predicate (defstruct) + + **** END OF MERGE LOSSAGE ****(defun define-predicate (defstruct) (let ((name (dd-name defstruct)) (pred (dd-predicate defstruct))) (when (and pred (dd-named defstruct)) -- GitLab