diff --git a/code/defstruct.lisp b/code/defstruct.lisp index 9b47189f1dd7447cef8085489a4d83c04cad3fa4..0bc314460f386a72ac8aee2a05e7d262b009f238 100644 --- a/code/defstruct.lisp +++ b/code/defstruct.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defstruct.lisp,v 1.72 2001/03/04 20:12:32 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defstruct.lisp,v 1.73 2001/03/15 18:01:36 pw Exp $") ;;; ;;; ********************************************************************** ;;; @@ -30,8 +30,13 @@ defstruct-description dd-name dd-default-constructor dd-copier dd-predicate dd-slots dd-length dd-type dd-raw-index dd-raw-length defstruct-slot-description dsd-name dsd-%name dsd-accessor dsd-type - dsd-index dsd-raw-type dsd-read-only undefine-structure)) + dsd-index dsd-raw-type dsd-read-only undefine-structure + *ansi-defstruct-options-p*)) + +(defparameter *ANSI-defstruct-options-p* nil + "Controls compiling DEFSTRUCT :print-function and :print-method + options according to ANSI spec. MUST be NIL to compile CMUCL & PCL") ;;;; Structure frobbing primitives. @@ -323,6 +328,27 @@ (declare (ignore depth)) (format stream "#<Defstruct-Slot-Description for ~S>" (dsd-name structure))) + +(defun dd-maybe-make-print-method (defstruct) + ;; Maybe generate CLOS DEFMETHOD forms for :print-function/:print-object. + (let ((print-function-value (dd-print-function defstruct))) + (when (consp print-function-value) + (let ((kind (car print-function-value)) + (function (cdr print-function-value))) + (unless (eq kind 'lambda) + (setf (dd-print-function defstruct) nil) + (let* ((name (dd-name defstruct)) + (function (if (symbolp function) `',function `#',function)) + (mcall `(funcall ,function o s)) + (fcall `(funcall ,function o s *current-level*))) + ;; We can only generate this code if CLOS is loaded. Maybe should + ;; signal an error instead of quietly ignoring the defmethod? + `((when (fboundp 'print-object) + (defmethod print-object ((o ,name) s) + ,(ecase kind + (:print-object mcall) + (:print-function fcall))))))))))) + ;;; The legendary macro itself. @@ -331,6 +357,36 @@ ;;; Return a list of forms to install print and make-load-form funs, mentioning ;;; them in the expansion so that they can be compiled. ;;; + +(defun define-class-methods (defstruct) + (let* ((name (dd-name defstruct)) + (pom (dd-maybe-make-print-method defstruct))) + `(,@(let ((pf (dd-print-function defstruct))) + (when pf + `((setf (basic-structure-class-print-function (find-class ',name)) + ,(if (symbolp pf) + `',pf + `#',pf))))) + ,@(let ((mlff (dd-make-load-form-fun defstruct))) + (when mlff + `((setf (structure-class-make-load-form-fun (find-class ',name)) + ,(if (symbolp mlff) + `',mlff + `#',mlff))))) + ,@(let ((pure (dd-pure defstruct))) + (cond ((eq pure 't) + `((setf (layout-pure (class-layout (find-class ',name))) + t))) + ((eq pure :substructure) + `((setf (layout-pure (class-layout (find-class ',name))) + 0))))) + ,@(let ((def-con (dd-default-constructor defstruct))) + (when (and def-con (not (dd-alternate-metaclass defstruct))) + `((setf (structure-class-constructor (find-class ',name)) + #',def-con)))) + ,@pom))) + +#+ORIGINAL (defun define-class-methods (defstruct) (let ((name (dd-name defstruct))) `(,@(let ((pf (dd-print-function defstruct))) @@ -425,6 +481,69 @@ ;;; ;;; Parse a single defstruct option and store the results in Defstruct. ;;; +(defun parse-1-option (option defstruct) + (let ((args (rest option)) + (name (dd-name defstruct))) + (case (first option) + (:conc-name + (destructuring-bind (conc-name) args + (setf (dd-conc-name defstruct) + (if (symbolp conc-name) + conc-name + (make-symbol (string conc-name)))))) + (:constructor + (destructuring-bind (&optional (cname (concat-pnames 'make- name)) + &rest stuff) + args + (push (cons cname stuff) (dd-constructors defstruct)))) + (:copier + (destructuring-bind (&optional (copier (concat-pnames 'copy- name))) + args + (setf (dd-copier defstruct) copier))) + (:predicate + (destructuring-bind (&optional (pred (concat-pnames name '-p))) + args + (setf (dd-predicate defstruct) pred))) + (:include + (when (dd-include defstruct) + (error "Can't have more than one :INCLUDE option.")) + (setf (dd-include defstruct) args)) + (:alternate-metaclass + (setf (dd-alternate-metaclass defstruct) args)) + ((:print-function :print-object) + (destructuring-bind (&optional (fun 'default-structure-print)) args + (setf (dd-print-function defstruct) + (if *ANSI-defstruct-options-p* + (cons (first option) fun) + fun)))) + (:type + (destructuring-bind (type) args + (cond ((eq type 'funcallable-structure) + (setf (dd-type defstruct) type)) + ((member type '(list vector)) + (setf (dd-element-type defstruct) 't) + (setf (dd-type defstruct) type)) + ((and (consp type) (eq (first type) 'vector)) + (destructuring-bind (vector vtype) type + (declare (ignore vector)) + (setf (dd-element-type defstruct) vtype) + (setf (dd-type defstruct) 'vector))) + (t + (error "~S is a bad :TYPE for Defstruct." type))))) + (:named + (error "The Defstruct option :NAMED takes no arguments.")) + (:initial-offset + (destructuring-bind (offset) args + (setf (dd-offset defstruct) offset))) + (:make-load-form-fun + (destructuring-bind (fun) args + (setf (dd-make-load-form-fun defstruct) fun))) + (:pure + (destructuring-bind (fun) args + (setf (dd-pure defstruct) fun))) + (t (error "Unknown DEFSTRUCT option~% ~S" option))))) + +#+ORIGINAL (defun parse-1-option (option defstruct) (let ((args (rest option)) (name (dd-name defstruct))) diff --git a/code/exports.lisp b/code/exports.lisp index f9b5bfa81eb19ab2a60798c482f8827d8a8ff50c..fa173132e3cac14171dd0e542de480cec5af6929 100644 --- a/code/exports.lisp +++ b/code/exports.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.181 2001/03/13 16:39:07 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.182 2001/03/15 18:01:36 pw Exp $") ;;; ;;; ********************************************************************** ;;; @@ -875,10 +875,12 @@ (intern "CHAR" "LISP") (defpackage "EXTENSIONS" - (:nicknames "EXTENSIONS") - (:import-from "LISP" "GET-SETF-METHOD") - (:export "*AFTER-GC-HOOKS*" "*AFTER-SAVE-INITIALIZATIONS*" - "*ALL-MODIFIER-NAMES*" "*AUTOLOAD-TRANSLATIONS*" + (:nicknames "EXTENSIONS") + (:import-from "LISP" "GET-SETF-METHOD") + (:import-from "KERNEL" "*ANSI-DEFSTRUCT-OPTIONS-P*") + (:export "*AFTER-GC-HOOKS*" "*AFTER-SAVE-INITIALIZATIONS*" + "*ALL-MODIFIER-NAMES*" "*ANSI-DEFSTRUCT-OPTIONS-P*" + "*AUTOLOAD-TRANSLATIONS*" "*BACKUP-EXTENSION*" "*BEFORE-GC-HOOKS*" "*BEFORE-SAVE-INITIALIZATIONS*" "*BLOCK-COMPILE-DEFAULT*" "*BYTES-CONSED-BETWEEN-GCS*" "*CHAR" "*CLX-FDS-TO-DISPLAYS*" @@ -1438,7 +1440,8 @@ (defpackage "KERNEL" (:import-from "LISP" "BOOLEAN") (:import-from "C-CALL" "VOID") - (:export "%ACOS" "%ACOSH" "%ARRAY-AVAILABLE-ELEMENTS" + (:export "*ANSI-DEFSTRUCT-OPTIONS-P*" + "%ACOS" "%ACOSH" "%ARRAY-AVAILABLE-ELEMENTS" "%ARRAY-DATA-VECTOR" "%ARRAY-DIMENSION" "%ARRAY-DISPLACED-P" "%ARRAY-DISPLACEMENT" "%ARRAY-FILL-POINTER" "%ARRAY-FILL-POINTER-P" "%ASIN" "%ASINH" "%ATAN" "%ATAN2" "%ATANH" diff --git a/code/print.lisp b/code/print.lisp index 970dbd24eb8fe1d1dde75660c65347e1876fae9a..82737cfd7f49d0344892afd591e057daea1b7718 100644 --- a/code/print.lisp +++ b/code/print.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/print.lisp,v 1.79 2001/01/01 11:41:17 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/print.lisp,v 1.80 2001/03/15 18:01:37 pw Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1127,6 +1127,39 @@ ;;; Instance Printing. If it's a structure, call the structure printer. ;;; Otherwise, call PCL if it's loaded. If not, print unreadably. +(defun output-instance (instance stream) + (let ((layout (typecase instance + (instance (%instance-ref instance 0)) + (funcallable-instance + (%funcallable-instance-layout instance))))) + + (if (typep layout 'layout) + (let ((class (layout-class layout))) + (cond + ((typep class 'slot-class) ; has slot print-function + (if (layout-invalid layout) + (print-unreadable-object + (instance stream :identity t :type t) + (write-string "Obsolete Instance" stream)) + (cond (;; non-CLOS :print-function option + (slot-class-print-function class) + (funcall (slot-class-print-function class) + instance stream *current-level*)) + ;; When CLOS loaded, use PRINT-OBJECT. + ((fboundp 'print-object) + (print-object instance stream)) + (t + (default-structure-print + instance stream *current-level*))))) + ((fboundp 'print-object) + (print-object instance stream)) + (t + (print-unreadable-object (instance stream :identity t) + (write-string "Unprintable Instance" stream))))) + (print-unreadable-object (instance stream :identity t) + (write-string "Unprintable Instance" stream))))) + +#+ORIGINAL (defun output-instance (instance stream) (let ((layout (typecase instance (instance (%instance-ref instance 0)) diff --git a/tools/pclcom.lisp b/tools/pclcom.lisp index 7c4ac881fe6f3cae64ec3fafd7d91c0ba66cb3c8..a244e84940d07e17a229c24b8390484275f28ac4 100644 --- a/tools/pclcom.lisp +++ b/tools/pclcom.lisp @@ -3,7 +3,7 @@ ;;; ********************************************************************** ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/pclcom.lisp,v 1.21 2000/06/29 07:52:06 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/pclcom.lisp,v 1.22 2001/03/15 18:01:39 pw Exp $") ;;; ;;; ********************************************************************** ;;; @@ -69,6 +69,9 @@ (when (find-package "CLOS-MOP") (rename-package "CLOS-MOP" "OLD-CLOS-MOP")) +;;; Inhibit ANSI :print-function and :print-object defstruct options. +(setq kernel::*ansi-defstruct-options-p* nil) + (setf c:*suppress-values-declaration* t) (pushnew :setf *features*) diff --git a/tools/setup.lisp b/tools/setup.lisp index 85e030c57af4f228d7d1f83a951932687ef528b8..ee128a7b30292fe94f36a92ec2b2bf67ea98e46a 100644 --- a/tools/setup.lisp +++ b/tools/setup.lisp @@ -3,15 +3,21 @@ ;;; ********************************************************************** ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/setup.lisp,v 1.30 2001/02/11 14:22:07 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/setup.lisp,v 1.31 2001/03/15 18:01:39 pw Exp $") ;;; ;;; ********************************************************************** ;;; ;;; Set up package environment and search lists for compiler. Also some ;;; compilation utilities. ;;; + +;;; Ensure pre-ANSI defstruct processing occurs during system builds. +(in-package "KERNEL") +(defparameter *ansi-defstruct-options-p* nil) + (in-package "USER") + ;;; DUMP-PACKAGE-STATE -- Public ;;; diff --git a/tools/worldload.lisp b/tools/worldload.lisp index 2d70cb3c6bf403f082dc385c6f634145bd771727..35f03a1d6d04a783d82328e32fd1a17dabd2ad10 100644 --- a/tools/worldload.lisp +++ b/tools/worldload.lisp @@ -6,7 +6,7 @@ ;;; If you want to use this code or any part of CMU Common Lisp, please contact ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/worldload.lisp,v 1.90 2001/03/13 14:14:50 pw Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/worldload.lisp,v 1.91 2001/03/15 18:01:40 pw Exp $ ;;; ;;; ********************************************************************** ;;; @@ -216,6 +216,9 @@ ;;; Reset the counter of the number of native code fixups. #+x86 (setf x86::*num-fixups* 0) + ;; Maybe enable ANSI defstruct :print-function/:print-object processing + #-NO-PCL + (setq ext:*ansi-defstruct-options-p* t) ;; ;; Save the lisp. If RUNTIME, there is nothing new to purify, so don't. (save-lisp "lisp.core"