*PRINT-READABLY* is true, signal PRINT-NOT-READABLE if the string
does not have array-element-type equal to the most general string
type.
+ * optimization: rearranged the expansion of various defining macros
+ so that each expands into only one top-level form in a
+ :LOAD-TOPLEVEL context; this appears to decrease fasl sizes by
+ approximately 10%.
planned incompatible changes in 0.8.x:
* (not done yet, but planned:) When the profiling interface settles
;;;; DEFINE-CONDITION
(eval-when (:compile-toplevel :load-toplevel :execute)
-(defun %compiler-define-condition (name direct-supers layout)
+(defun %compiler-define-condition (name direct-supers layout
+ all-readers all-writers)
+ (sb!xc:proclaim `(ftype (function (t) t) ,@all-readers))
+ (sb!xc:proclaim `(ftype (function (t t) t) ,@all-writers))
(multiple-value-bind (class old-layout)
(insured-find-classoid name
#'condition-classoid-p
(remove-if-not #'condition-classoid-p
(std-compute-class-precedence-list class))))
(values))
-
) ; EVAL-WHEN
;;; Compute the effective slots of CLASS, copying inherited slots and
(lambda (new-value condition)
(condition-writer-function condition new-value slot-name))))
-(defun %define-condition (name slots documentation report default-initargs)
+(defun %define-condition (name parent-types layout slots documentation
+ report default-initargs all-readers all-writers)
+ (%compiler-define-condition name parent-types layout all-readers all-writers)
(let ((class (find-classoid name)))
(setf (condition-classoid-slots class) slots)
(setf (condition-classoid-report class) report)
(error "unknown option: ~S" (first option)))))
`(progn
- (eval-when (:compile-toplevel :load-toplevel :execute)
- (%compiler-define-condition ',name ',parent-types ',layout))
-
- (declaim (ftype (function (t) t) ,@(all-readers)))
- (declaim (ftype (function (t t) t) ,@(all-writers)))
-
- (%define-condition ',name
- (list ,@(slots))
- ,documentation
- ,report
- (list ,@default-initargs))))))
+ (eval-when (:compile-toplevel)
+ (%compiler-define-condition ',name ',parent-types ',layout
+ ',(all-readers) ',(all-writers)))
+ (eval-when (:load-toplevel :execute)
+ (%define-condition ',name
+ ',parent-types
+ ',layout
+ (list ,@(slots))
+ ,documentation
+ ,report
+ (list ,@default-initargs)
+ ',(all-readers)
+ ',(all-writers)))))))
\f
;;;; DESCRIBE on CONDITIONs
"Define a function at top level."
#+sb-xc-host
(unless (symbol-package (fun-name-block-name name))
- (warn "DEFUN of uninterned symbol ~S (tricky for GENESIS)" name))
+ (warn "DEFUN of uninterned function name ~S (tricky for GENESIS)" name))
(multiple-value-bind (forms decls doc) (parse-body body)
(let* (;; stuff shared between LAMBDA and INLINE-LAMBDA and NAMED-LAMBDA
(lambda-guts `(,args
(block ,(fun-name-block-name name)
,@forms)))
(lambda `(lambda ,@lambda-guts))
- #-sb-xc-host
+ #-sb-xc-host
(named-lambda `(named-lambda ,name ,@lambda-guts))
(inline-lambda
(when (inline-fun-name-p name)
name)
nil)))))
`(progn
-
- ;; In cross-compilation of toplevel DEFUNs, we arrange
- ;; for the LAMBDA to be statically linked by GENESIS.
+ ;; In cross-compilation of toplevel DEFUNs, we arrange for
+ ;; the LAMBDA to be statically linked by GENESIS.
;;
;; It may seem strangely inconsistent not to use NAMED-LAMBDA
;; here instead of LAMBDA. The reason is historical:
#+sb-xc-host
(cold-fset ,name ,lambda)
- (eval-when (:compile-toplevel :load-toplevel :execute)
+ (eval-when (:compile-toplevel)
(sb!c:%compiler-defun ',name ',inline-lambda))
+ (eval-when (:load-toplevel :execute)
+ (%defun ',name
+ ;; In normal compilation (not for cold load) this is
+ ;; where the compiled LAMBDA first appears. In
+ ;; cross-compilation, we manipulate the
+ ;; previously-statically-linked LAMBDA here.
+ #-sb-xc-host ,named-lambda
+ #+sb-xc-host (fdefinition ',name)
+ ,doc
+ ',inline-lambda))))))
- (%defun ',name
- ;; In normal compilation (not for cold load) this is
- ;; where the compiled LAMBDA first appears. In
- ;; cross-compilation, we manipulate the
- ;; previously-statically-linked LAMBDA here.
- #-sb-xc-host ,named-lambda
- #+sb-xc-host (fdefinition ',name)
- ,doc)))))
#-sb-xc-host
-(defun %defun (name def doc)
+(defun %defun (name def doc inline-lambda)
(declare (type function def))
(declare (type (or null simple-string) doc))
(aver (legal-fun-name-p name)) ; should've been checked by DEFMACRO DEFUN
+ (sb!c:%compiler-defun name inline-lambda)
(when (fboundp name)
(/show0 "redefining NAME in %DEFUN")
(style-warn "redefining ~S in DEFUN" name))
value, the old value is not clobbered. The third argument is an optional
documentation string for the variable."
`(progn
- (declaim (special ,var))
- ,@(when valp
- `((unless (boundp ',var)
- (set ',var ,val))))
- ,@(when docp
- `((setf (fdocumentation ',var 'variable) ',doc )))
- ',var))
+ (eval-when (:compile-toplevel)
+ (%compiler-defvar ',var))
+ (eval-when (:load-toplevel :execute)
+ (%defvar ',var (unless (boundp ',var) ,val) ',valp ,doc ',docp))))
(defmacro-mundanely defparameter (var val &optional (doc nil docp))
#!+sb-doc
previous value. The third argument is an optional documentation
string for the parameter."
`(progn
- (declaim (special ,var))
- (set ',var ,val)
- ,@(when docp
- `((setf (fdocumentation ',var 'variable) ',doc)))
- ',var))
+ (eval-when (:compile-toplevel)
+ (%compiler-defvar ',var))
+ (eval-when (:load-toplevel :execute)
+ (%defparameter ',var ,val ,doc ',docp))))
+
+(defun %compiler-defvar (var)
+ (sb!xc:proclaim `(special ,var)))
+
+#-sb-xc-host
+(defun %defvar (var val valp doc docp)
+ (%compiler-defvar var)
+ (when valp
+ (unless (boundp var)
+ (set var val)))
+ (when docp
+ (setf (fdocumentation var 'variable) doc))
+ var)
+
+#-sb-xc-host
+(defun %defparameter (var val doc docp)
+ (%compiler-defvar var)
+ (set var val)
+ (when docp
+ (setf (fdocumentation var 'variable) doc))
+ var)
\f
;;;; iteration constructs
;; functions appearing in fundamental defining
;; macro expansions:
%compiler-deftype
+ %compiler-defvar
%defun
%defsetf
+ %defparameter
+ %defvar
sb!c:%compiler-defun
sb!c::%define-symbol-macro
sb!c::%defconstant
;;; versions which break binary compatibility. But it certainly should
;;; be incremented for release versions which break binary
;;; compatibility.
-(def!constant +fasl-file-version+ 48)
+(def!constant +fasl-file-version+ 49)
;;; (record of versions before 2003 deleted in 2003-04-26/0.pre8.107 or so)
;;; 38: (2003-01-05) changed names of internal SORT machinery
;;; 39: (2003-02-20) in 0.7.12.1 a slot was added to
;;; 47: (2003-11-30) Static variables were rearranged in 0.8.6.11.
;;; 48: (2004-03-01) Renumbered all the widetags to allow for more
;;; microefficiency in sbcl-0.8.8.10
-
+;;; 49: (2004-05-04) Changed implementation of DEFFOO macros and the
+;;; functions they expand to.
;;; the conventional file extension for our fasl files
(declaim (type simple-string *fasl-file-type*))
;; an encapsulation that no longer exists.
(let ((info (make-encapsulation-info type (fdefn-fun fdefn))))
(setf (fdefn-fun fdefn)
- (named-lambda encapsulate (&rest arg-list)
+ (named-lambda encapsulation (&rest arg-list)
(declare (special arg-list))
(let ((basic-definition (encapsulation-info-definition info)))
(declare (special basic-definition))
*the-class-structure-class*))))))
(let ((defclass-form
`(progn
- ,@(mapcar (lambda (x)
- `(declaim (ftype (function (t) t) ,x)))
- *readers-for-this-defclass*)
- ,@(mapcar (lambda (x)
- `(declaim (ftype (function (t t) t) ,x)))
- *writers-for-this-defclass*)
- ,@(mapcar (lambda (x)
- `(declaim (ftype (function (t) t)
- ,(slot-reader-name x)
- ,(slot-boundp-name x))
- (ftype (function (t t) t)
- ,(slot-writer-name x))))
- *slot-names-for-this-defclass*)
(let ,(mapcar #'cdr *initfunctions-for-this-defclass*)
+ (%compiler-defclass ',name
+ ',*readers-for-this-defclass*
+ ',*writers-for-this-defclass*
+ ',*slot-names-for-this-defclass*)
(load-defclass ',name
',metaclass
',supers
;; full-blown class, so the "a class of this name is
;; coming" note we write here would be irrelevant.
(eval-when (:compile-toplevel)
- (preinform-compiler-about-class-type ',name))
- ,defclass-form))))))))
+ (%compiler-defclass ',name
+ ',*readers-for-this-defclass*
+ ',*writers-for-this-defclass*
+ ',*slot-names-for-this-defclass*))
+ (eval-when (:load-toplevel :execute)
+ ,defclass-form)))))))))
+
+(defun %compiler-defclass (name readers writers slot-names)
+ (preinform-compiler-about-class-type name)
+ (proclaim `(ftype (function (t) t)
+ ,@readers
+ ,@(mapcar #'slot-reader-name slot-names)
+ ,@(mapcar #'slot-boundp-name slot-names)))
+ (proclaim `(ftype (function (t t) t)
+ ,@writers ,@(mapcar #'slot-writer-name slot-names))))
(defun make-initfunction (initform)
(cond ((or (eq initform t)
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.10.10"
+"0.8.10.11"
projects / sbcl.git / commitdiff