ViewVC logotype

Contents of /src/bootfiles/18e/boot10.lisp

Parent Directory Parent Directory | Revision Log Revision Log

Revision 1.3 - (show annotations)
Tue May 27 11:12:03 2003 UTC (10 years, 10 months ago) by pmai
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, double-double-array-base, post-merge-intl-branch, release-19b-pre1, release-19b-pre2, merged-unicode-utf16-extfmt-2009-06-11, double-double-init-sparc-2, unicode-utf16-extfmt-2009-03-27, double-double-base, snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, ppc_gencgc_snap_2006-01-06, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2007-05, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, intl-branch-working-2010-02-19-1000, snapshot-2006-11, snapshot-2006-10, double-double-init-sparc, snapshot-2006-12, unicode-string-buffer-impl-base, sse2-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, sse2-packed-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, snapshot-2003-10, snapshot-2004-10, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, intl-2-branch-base, snapshot-2004-08, snapshot-2004-09, snapshot-2007-01, snapshot-2007-02, snapshot-2004-05, snapshot-2004-06, snapshot-2004-07, release-19e, release-19d, GIT-CONVERSION, double-double-init-ppc, release-19c, dynamic-extent-base, unicode-utf16-sync-2008-12, release-19c-base, cross-sol-x86-merged, label-2009-03-16, release-19f-base, merge-sse2-packed, mod-arith-base, sparc_gencgc_merge, merge-with-19f, snapshot-2004-12, snapshot-2004-11, intl-branch-working-2010-02-11-1000, unicode-snapshot-2009-05, unicode-snapshot-2009-06, amd64-merge-start, ppc_gencgc_snap_2005-12-17, double-double-init-%make-sparc, unicode-utf16-sync-2008-07, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, prm-before-macosx-merge-tag, RELEASE_20b, snapshot-2008-04, snapshot-2003-11, snapshot-2005-07, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, snapshot-2007-03, release-20a-base, cross-sol-x86-base, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, release-19a-base, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, sparc_gencgc, snapshot-2007-04, snapshot-2010-12, snapshot-2010-11, unicode-utf16-sync-2008-11, snapshot-2007-07, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2007-06, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2003-12, release-19a-pre1, release-19a-pre3, release-19a-pre2, pre-merge-intl-branch, release-19a, double-double-array-checkpoint, double-double-reader-checkpoint-1, release-19d-base, release-19e-pre1, double-double-irrat-end, release-19e-pre2, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, release-19d-pre2, release-19d-pre1, snapshot-2010-08, double-double-init-checkpoint-1, double-double-reader-base, label-2009-03-25, snapshot-2005-03, release-19b-base, cross-sol-x86-2010-12-20, double-double-init-x86, sse2-checkpoint-2008-10-01, intl-branch-2010-03-18-1300, snapshot-2005-11, double-double-sparc-checkpoint-1, snapshot-2004-04, sse2-merge-with-2008-11, sse2-merge-with-2008-10, snapshot-2005-10, RELEASE_20a, snapshot-2005-12, release-20a-pre1, snapshot-2005-01, snapshot-2009-11, snapshot-2009-12, unicode-utf16-extfmt-2009-06-11, portable-clx-import-2009-06-16, unicode-utf16-string-support, release-19c-pre1, cross-sparc-branch-base, release-19e-base, intl-branch-base, double-double-irrat-start, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, snapshot-2005-02, unicode-utf16-base, portable-clx-base, snapshot-2005-09, snapshot-2005-08, lisp-executable-base, snapshot-2009-08, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-07, snapshot-2009-05, snapshot-2009-04, snapshot-2006-02, snapshot-2006-03, snapshot-2006-01, snapshot-2006-06, snapshot-2006-07, snapshot-2006-04, snapshot-2006-05, pre-telent-clx, snapshot-2006-08, snapshot-2006-09, HEAD
Branch point for: release-19b-branch, double-double-reader-branch, double-double-array-branch, mod-arith-branch, RELEASE-19F-BRANCH, portable-clx-branch, sparc_gencgc_branch, cross-sparc-branch, RELEASE-20B-BRANCH, unicode-string-buffer-branch, sparc-tramp-assem-branch, dynamic-extent, release-19d-branch, ppc_gencgc_branch, sse2-packed-branch, lisp-executable, RELEASE-20A-BRANCH, amd64-dd-branch, double-double-branch, unicode-string-buffer-impl-branch, intl-branch, unicode-utf16-branch, cross-sol-x86-branch, release-19e-branch, sse2-branch, release-19a-branch, release-19c-branch, intl-2-branch, unicode-utf16-extfmt-branch
Changes since 1.2: +0 -10 lines
Removed redundant code from boot11.lisp.
1 ;;;
2 ;;; Bootstrap.lisp for changing slot %NAME of DEFSTRUCT-SLOT-DESCRIPTION
3 ;;; to NAME, and making NAME hold the slot name symbol instead
4 ;;; of a string. This is necessary for a conforming SLOT-EXISTS-P
6 ;;;
7 ;;; The build is unusual in that it requires two full builds with the
8 ;;; same bootstrap file in a row, that is:
9 ;;;
10 ;;; 1. Copy this file to target:bootstrap.lisp and do a full build.
11 ;;; Choose the CLOBBER-IT restart when asked. For an unknown
12 ;;; reason, it doesn't work to do this programatically.
13 ;;;
14 ;;; 2. Leave the bootstrap file where it is and do a full build with
15 ;;; the Lisp produced by step 1.
16 ;;;
17 ;;; 3. Remove the bootstrap file, and build again.
18 ;;;
20 (in-package :kernel)
22 (setq *ANSI-defstruct-options-p* nil)
24 (defun define-class-methods (defstruct)
25 (let* ((name (dd-name defstruct)))
26 `(,@(let ((pf (dd-print-function defstruct)))
27 (when pf
28 `((setf (basic-structure-class-print-function (find-class ',name))
29 ,(if (symbolp pf)
30 `',pf
31 `#',pf)))))
32 ,@(let ((mlff (dd-make-load-form-fun defstruct)))
33 (when mlff
34 `((setf (structure-class-make-load-form-fun (find-class ',name))
35 ,(if (symbolp mlff)
36 `',mlff
37 `#',mlff)))))
38 ,@(let ((pure (dd-pure defstruct)))
39 (cond ((eq pure 't)
40 `((setf (layout-pure (%class-layout (find-class ',name)))
41 t)))
42 ((eq pure :substructure)
43 `((setf (layout-pure (%class-layout (find-class ',name)))
44 0)))))
45 ,@(let ((def-con (dd-default-constructor defstruct)))
46 (when (and def-con (not (dd-alternate-metaclass defstruct)))
47 `((setf (structure-class-constructor (find-class ',name))
48 #',def-con)))))))
50 (defstruct (defstruct-slot-description
51 (:conc-name dsd-)
52 (:print-function print-defstruct-slot-description)
53 (:pure t)
54 (:make-load-form-fun :just-dump-it-normally))
55 name
56 (index (required-argument) :type fixnum)
57 (accessor nil)
58 default
59 (type t)
60 (raw-type t :type (member t single-float double-float #+long-float long-float
61 complex-single-float complex-double-float
62 #+long-float complex-long-float
63 unsigned-byte))
64 (read-only nil :type (member t nil)))
66 (setf (info type compiler-layout 'defstruct-slot-description)
67 (%class-layout (find-class 'defstruct-slot-description)))
69 (let ((*setf-fdefinition-hook* nil))
70 (setf (fdefinition 'dsd-name)
71 (lambda (dsd)
72 (let ((name (%instance-ref dsd 1)))
73 (if (stringp name)
74 (intern name (symbol-package (dsd-accessor dsd)))
75 name)))))
77 (defun dsd-%name (dsd)
78 (symbol-name (dsd-name dsd)))
80 (defun parse-1-dsd (defstruct spec &optional
81 (islot (make-defstruct-slot-description
82 :name nil :index 0 :type t)))
83 (multiple-value-bind (name default default-p type type-p read-only ro-p)
84 (cond ((listp spec)
85 (destructuring-bind (name &optional (default nil default-p)
86 &key (type nil type-p)
87 (read-only nil ro-p))
88 spec
89 (values name default default-p type type-p read-only ro-p)))
90 (t
91 (when (keywordp spec)
92 (warn "Keyword slot name indicates probable syntax ~
93 error in DEFSTRUCT -- ~S."
94 spec))
95 spec))
96 (when (find name (dd-slots defstruct) :test #'string= :key #'dsd-%name)
97 (error 'simple-program-error
98 :format-control "Duplicate slot name ~S."
99 :format-arguments (list name)))
100 (setf (dsd-name islot) name)
101 (setf (dd-slots defstruct) (nconc (dd-slots defstruct) (list islot)))
102 (setf (dsd-accessor islot) (concat-pnames (dd-conc-name defstruct) name))
103 (when default-p
104 (setf (dsd-default islot) default))
105 (when type-p
106 (setf (dsd-type islot)
107 (if (eq (dsd-type islot) 't)
108 type
109 `(and ,(dsd-type islot) ,type))))
110 (when ro-p
111 (if read-only
112 (setf (dsd-read-only islot) t)
113 (when (dsd-read-only islot)
114 (error "Slot ~S must be read-only in subtype ~S." name
115 (dsd-name islot)))))
116 islot))
118 (defun compare-slots (old new)
119 (declare (ignore old new))
120 (values nil nil nil))
122 ;;; end of file

  ViewVC Help
Powered by ViewVC 1.1.5