(defun complement (function)
#!+sb-doc
"Builds a new function that returns T whenever FUNCTION returns NIL and
- NIL whenever FUNCTION returns T."
- #'(lambda (&optional (arg0 nil arg0-p) (arg1 nil arg1-p) (arg2 nil arg2-p)
- &rest more-args)
- (not (cond (more-args (apply function arg0 arg1 arg2 more-args))
- (arg2-p (funcall function arg0 arg1 arg2))
- (arg1-p (funcall function arg0 arg1))
- (arg0-p (funcall function arg0))
- (t (funcall function))))))
+ NIL whenever FUNCTION returns non-NIL."
+ (lambda (&optional (arg0 nil arg0-p) (arg1 nil arg1-p) (arg2 nil arg2-p)
+ &rest more-args)
+ (not (cond (more-args (apply function arg0 arg1 arg2 more-args))
+ (arg2-p (funcall function arg0 arg1 arg2))
+ (arg1-p (funcall function arg0 arg1))
+ (arg0-p (funcall function arg0))
+ (t (funcall function))))))
(defun constantly (value &optional (val1 nil val1-p) (val2 nil val2-p)
&rest more-values)
#!+sb-doc
- "Builds a function that always returns VALUE, and posisbly MORE-VALUES."
+ "Builds a function that always returns VALUE, and possibly MORE-VALUES."
(cond (more-values
(let ((list (list* value val1 val2 more-values)))
- #'(lambda ()
- (declare (optimize-interface (speed 3) (safety 0)))
- (values-list list))))
- (val2-p
- #'(lambda ()
+ (lambda ()
(declare (optimize-interface (speed 3) (safety 0)))
- (values value val1 val2)))
+ (values-list list))))
+ (val2-p
+ (lambda ()
+ (declare (optimize-interface (speed 3) (safety 0)))
+ (values value val1 val2)))
(val1-p
- #'(lambda ()
- (declare (optimize-interface (speed 3) (safety 0)))
- (values value val1)))
+ (lambda ()
+ (declare (optimize-interface (speed 3) (safety 0)))
+ (values value val1)))
(t
- #'(lambda ()
- (declare (optimize-interface (speed 3) (safety 0)))
- value))))
+ (lambda ()
+ (declare (optimize-interface (speed 3) (safety 0)))
+ value))))
\f
;;;; macros for (&KEY (KEY #'IDENTITY) (TEST #'EQL TESTP) (TEST-NOT NIL NOTP))
;;; body, otherwise do one binding and recurse on the rest.
;;;
;;; If INTERFACE is true, then we convert bindings with the interface
-;;; policy. For real &AUX bindings, and implicit aux bindings
+;;; policy. For real &AUX bindings, and for implicit aux bindings
;;; introduced by keyword bindings, this is always true. It is only
;;; false when LET* directly calls this function.
(defun ir1-convert-aux-bindings (start cont body aux-vars aux-vals interface)
(in-package "SB!C")
;;; a value for an optimization declaration
-(def!type policy-quality () '(or (rational 0 3) null))
+(def!type policy-quality () '(rational 0 3))
;;; CMU CL used a special STRUCTURE-OBJECT type POLICY to represent
;;; the state of optimization policy at any point in compilation. This
#+sb-xc-host (!policy-cold-init-or-resanify)
;;; Is X the name of an optimization quality?
-(defun policy-quality-p (x)
+(defun policy-quality-name-p (x)
(memq x *policy-basic-qualities*))
-;;; Look up a named optimization quality in POLICY.
-(declaim (ftype (function (policy symbol) policy-quality)))
+;;; Look up a named optimization quality in POLICY. This is only
+;;; called by compiler code for known-valid QUALITY-NAMEs, e.g. SPEED;
+;;; it's an error if it's called for a quality which isn't defined.
+;;;
+;;; FIXME: After this is debugged, it should get a DEFKNOWN.
+#+nil (declaim (ftype (function (policy symbol) policy-quality)))
(defun policy-quality (policy quality-name)
- (the policy-quality
- (cdr (assoc quality-name policy))))
+ (let ((acons (assoc quality-name policy)))
+ (unless acons
+ (error "Argh! no such optimization quality ~S in~% ~S"
+ quality-name policy))
+ (let ((result (cdr acons)))
+ (unless (typep result '(rational 0 3))
+ (error "Argh! bogus optimization quality ~S" acons))
+ result)))
;;; Return a list of symbols naming the optimization qualities which
;;; appear in EXPR.
(labels ((recurse (x)
(if (listp x)
(map nil #'recurse x)
- (when (policy-quality-p x)
+ (when (policy-quality-name-p x)
(pushnew x result)))))
(recurse expr)
result)))
;;; them by name, e.g. (> SPEED SPACE).
(defmacro policy (node expr)
(let* ((n-policy (gensym))
+ (used-qualities (policy-qualities-used-by expr))
(binds (mapcar (lambda (name)
`(,name (policy-quality ,n-policy ',name)))
- (policy-qualities-used-by expr))))
- (/show "in POLICY" expr binds)
+ used-qualities)))
+ (/show "in compile-time POLICY" expr binds)
`(let* ((,n-policy (lexenv-policy ,(if node
`(node-lexenv ,node)
'*lexenv*)))
,@binds)
+ ;;(/show "in run-time POLICY" ,@used-qualities)
,expr)))
(values q-and-v-or-just-q 3)
(destructuring-bind (quality raw-value) q-and-v-or-just-q
(values quality raw-value)))
- (cond ((not (policy-quality-p quality))
+ (cond ((not (policy-quality-name-p quality))
(compiler-warning "ignoring unknown optimization quality ~
~S in ~S"
quality spec))
(early-collect-inheritance 'standard-generic-function)))
(defvar *sgf-method-class-index*
- (bootstrap-slot-index 'standard-generic-function 'method-class))
+ (!bootstrap-slot-index 'standard-generic-function 'method-class))
(defun early-gf-p (x)
(and (fsc-instance-p x)
+slot-unbound+)))
(defvar *sgf-methods-index*
- (bootstrap-slot-index 'standard-generic-function 'methods))
+ (!bootstrap-slot-index 'standard-generic-function 'methods))
(defmacro early-gf-methods (gf)
`(instance-ref (get-slots ,gf) *sgf-methods-index*))
(defvar *sgf-arg-info-index*
- (bootstrap-slot-index 'standard-generic-function 'arg-info))
+ (!bootstrap-slot-index 'standard-generic-function 'arg-info))
(defmacro early-gf-arg-info (gf)
`(instance-ref (get-slots ,gf) *sgf-arg-info-index*))
(defvar *sgf-dfun-state-index*
- (bootstrap-slot-index 'standard-generic-function 'dfun-state))
+ (!bootstrap-slot-index 'standard-generic-function 'dfun-state))
(defstruct (arg-info
(:conc-name nil)
(error "The function of the funcallable-instance ~S~
has not been set." fin)))))
(setf (gdefinition spec) fin)
- (bootstrap-set-slot 'standard-generic-function fin 'name spec)
- (bootstrap-set-slot 'standard-generic-function fin 'source *load-truename*)
+ (!bootstrap-set-slot 'standard-generic-function fin 'name spec)
+ (!bootstrap-set-slot 'standard-generic-function
+ fin
+ 'source
+ *load-truename*)
(set-function-name fin spec)
(let ((arg-info (make-arg-info)))
(setf (early-gf-arg-info fin) arg-info)
(cons (cddr state)))))
(defvar *sgf-name-index*
- (bootstrap-slot-index 'standard-generic-function 'name))
+ (!bootstrap-slot-index 'standard-generic-function 'name))
(defun early-gf-name (gf)
(instance-ref (get-slots gf) *sgf-name-index*))
(find-class ',class) ,class)))
classes)))
-(defun bootstrap-meta-braid ()
+(defun !bootstrap-meta-braid ()
(let* ((name 'class)
(predicate-name (make-type-predicate-name name)))
(setf (gdefinition predicate-name)
(allocate-standard-instance wrapper)))
(setq direct-slots
- (bootstrap-make-slot-definitions
+ (!bootstrap-make-slot-definitions
name class direct-slots
standard-direct-slot-definition-wrapper nil))
(setq slots
- (bootstrap-make-slot-definitions
+ (!bootstrap-make-slot-definitions
name class slots
standard-effective-slot-definition-wrapper t))
(case meta
((std-class standard-class funcallable-standard-class)
- (bootstrap-initialize-class
+ (!bootstrap-initialize-class
meta
class name class-eq-specializer-wrapper source
direct-supers direct-subclasses cpl wrapper proto
direct-slots slots direct-default-initargs default-initargs))
(built-in-class ; *the-class-t*
- (bootstrap-initialize-class
+ (!bootstrap-initialize-class
meta
class name class-eq-specializer-wrapper source
direct-supers direct-subclasses cpl wrapper proto))
(slot-class ; *the-class-slot-object*
- (bootstrap-initialize-class
+ (!bootstrap-initialize-class
meta
class name class-eq-specializer-wrapper source
direct-supers direct-subclasses cpl wrapper proto))
(structure-class ; *the-class-structure-object*
- (bootstrap-initialize-class
+ (!bootstrap-initialize-class
meta
class name class-eq-specializer-wrapper source
direct-supers direct-subclasses cpl wrapper))))))))
(let* ((smc-class (find-class 'standard-method-combination))
- (smc-wrapper (bootstrap-get-slot 'standard-class
- smc-class
- 'wrapper))
+ (smc-wrapper (!bootstrap-get-slot 'standard-class
+ smc-class
+ 'wrapper))
(smc (allocate-standard-instance smc-wrapper)))
(flet ((set-slot (name value)
- (bootstrap-set-slot 'standard-method-combination
- smc
- name
- value)))
+ (!bootstrap-set-slot 'standard-method-combination
+ smc
+ name
+ value)))
(set-slot 'source *load-truename*)
(set-slot 'type 'standard)
(set-slot 'documentation "The standard method combination.")
;;;
;;; FIXME: This and most stuff in this file is probably only needed at init
;;; time.
-(defun bootstrap-initialize-class
+(defun !bootstrap-initialize-class
(metaclass-name class name
class-eq-wrapper source direct-supers direct-subclasses cpl wrapper
&optional
proto direct-slots slots direct-default-initargs default-initargs)
(flet ((classes (names) (mapcar #'find-class names))
(set-slot (slot-name value)
- (bootstrap-set-slot metaclass-name class slot-name value)))
+ (!bootstrap-set-slot metaclass-name class slot-name value)))
(set-slot 'name name)
(set-slot 'source source)
(set-slot 'type (if (eq class (find-class 't))
`(class ,class)))
(set-slot 'class-eq-specializer
(let ((spec (allocate-standard-instance class-eq-wrapper)))
- (bootstrap-set-slot 'class-eq-specializer spec 'type
- `(class-eq ,class))
- (bootstrap-set-slot 'class-eq-specializer spec 'object
- class)
+ (!bootstrap-set-slot 'class-eq-specializer spec 'type
+ `(class-eq ,class))
+ (!bootstrap-set-slot 'class-eq-specializer spec 'object
+ class)
spec))
(set-slot 'class-precedence-list (classes cpl))
(set-slot 'can-precede-list (classes (cdr cpl)))
(set-slot 'prototype (or proto (allocate-standard-instance wrapper))))
class))
-(defun bootstrap-make-slot-definitions (name class slots wrapper effective-p)
+(defun !bootstrap-make-slot-definitions (name class slots wrapper effective-p)
(let ((index -1))
- (mapcar #'(lambda (slot)
- (incf index)
- (bootstrap-make-slot-definition
- name class slot wrapper effective-p index))
+ (mapcar (lambda (slot)
+ (incf index)
+ (!bootstrap-make-slot-definition
+ name class slot wrapper effective-p index))
slots)))
-(defun bootstrap-make-slot-definition
+(defun !bootstrap-make-slot-definition
(name class slot wrapper effective-p index)
(let* ((slotd-class-name (if effective-p
'standard-effective-slot-definition
(slot-name (getf slot :name)))
(flet ((get-val (name) (getf slot name))
(set-val (name val)
- (bootstrap-set-slot slotd-class-name slotd name val)))
- (set-val 'name slot-name)
+ (!bootstrap-set-slot slotd-class-name slotd name val)))
+ (set-val 'name slot-name)
(set-val 'initform (get-val :initform))
(set-val 'initfunction (get-val :initfunction))
(set-val 'initargs (get-val :initargs))
(set-val 'readers (get-val :readers))
(set-val 'writers (get-val :writers))
(set-val 'allocation :instance)
- (set-val 'type (or (get-val :type) t))
+ (set-val 'type (or (get-val :type) t))
(set-val 'documentation (or (get-val :documentation) ""))
(set-val 'class class)
(when effective-p
(setq *the-eslotd-funcallable-standard-class-slots* slotd))
slotd)))
-(defun bootstrap-accessor-definitions (early-p)
+(defun !bootstrap-accessor-definitions (early-p)
(let ((*early-p* early-p))
(dolist (definition *early-class-definitions*)
(let ((name (ecd-class-name definition))
(let ((slot-name (getf slotd :name))
(readers (getf slotd :readers))
(writers (getf slotd :writers)))
- (bootstrap-accessor-definitions1
+ (!bootstrap-accessor-definitions1
name
slot-name
readers
writers
nil)
- (bootstrap-accessor-definitions1
+ (!bootstrap-accessor-definitions1
'slot-object
slot-name
(list (slot-reader-symbol slot-name))
(list (slot-writer-symbol slot-name))
(list (slot-boundp-symbol slot-name)))))))))))
-(defun bootstrap-accessor-definition (class-name accessor-name slot-name type)
+(defun !bootstrap-accessor-definition (class-name accessor-name slot-name type)
(multiple-value-bind (accessor-class make-method-function arglist specls doc)
(ecase type
(reader (values 'standard-reader-method
doc
slot-name))))))
-(defun bootstrap-accessor-definitions1 (class-name
+(defun !bootstrap-accessor-definitions1 (class-name
slot-name
readers
writers
boundps)
(flet ((do-reader-definition (reader)
- (bootstrap-accessor-definition class-name
- reader
- slot-name
- 'reader))
+ (!bootstrap-accessor-definition class-name
+ reader
+ slot-name
+ 'reader))
(do-writer-definition (writer)
- (bootstrap-accessor-definition class-name
- writer
- slot-name
- 'writer))
+ (!bootstrap-accessor-definition class-name
+ writer
+ slot-name
+ 'writer))
(do-boundp-definition (boundp)
- (bootstrap-accessor-definition class-name
- boundp
- slot-name
- 'boundp)))
+ (!bootstrap-accessor-definition class-name
+ boundp
+ slot-name
+ 'boundp)))
(dolist (reader readers) (do-reader-definition reader))
(dolist (writer writers) (do-writer-definition writer))
(dolist (boundp boundps) (do-boundp-definition boundp))))
-(defun bootstrap-class-predicates (early-p)
+(defun !bootstrap-class-predicates (early-p)
(let ((*early-p* early-p))
(dolist (definition *early-class-definitions*)
(let* ((name (ecd-class-name definition))
(setf (find-class-predicate name)
(make-class-predicate class (class-predicate-name class)))))))
-(defun bootstrap-built-in-classes ()
+(defun !bootstrap-built-in-classes ()
;; First make sure that all the supers listed in
;; *BUILT-IN-CLASS-LATTICE* are themselves defined by
(set (get-built-in-wrapper-symbol name) wrapper)
(setf (sb-kernel:class-pcl-class lclass) class)
- (bootstrap-initialize-class 'built-in-class class
- name class-eq-wrapper nil
- supers subs
- (cons name cpl)
- wrapper prototype)))))
+ (!bootstrap-initialize-class 'built-in-class class
+ name class-eq-wrapper nil
+ supers subs
+ (cons name cpl)
+ wrapper prototype)))))
(dolist (e *built-in-classes*)
(let* ((name (car e))
(eval-when (:load-toplevel :execute)
(clrhash *find-class*)
- (bootstrap-meta-braid)
- (bootstrap-accessor-definitions t)
- (bootstrap-class-predicates t)
- (bootstrap-accessor-definitions nil)
- (bootstrap-class-predicates nil)
- (bootstrap-built-in-classes)
+ (!bootstrap-meta-braid)
+ (!bootstrap-accessor-definitions t)
+ (!bootstrap-class-predicates t)
+ (!bootstrap-accessor-definitions nil)
+ (!bootstrap-class-predicates nil)
+ (!bootstrap-built-in-classes)
(sb-int:dohash (name x *find-class*)
(let* ((class (find-class-from-cell name x))
\f
;;; MAKE-TOP-LEVEL-FORM is used by all PCL macros that appear `at top-level'.
;;;
-;;; The original motiviation for this function was to deal with the bug in
-;;; the Genera compiler that prevents lambda expressions in top-level forms
-;;; other than DEFUN from being compiled.
+;;; The original motiviation for this function was to deal with the
+;;; bug in the Genera compiler that prevents lambda expressions in
+;;; top-level forms other than DEFUN from being compiled.
;;;
;;; Now this function is used to grab other functionality as well. This
;;; includes:
(collect-forms forms)
(cons 'progn progn-form))))
\f
-;;; Like the DEFMETHOD macro, the expansion of the DEFCLASS macro is fixed.
-;;; DEFCLASS always expands into a call to LOAD-DEFCLASS. Until the meta-
-;;; braid is set up, LOAD-DEFCLASS has a special definition which simply
-;;; collects all class definitions up, when the metabraid is initialized it
-;;; is done from those class definitions.
+;;; Like the DEFMETHOD macro, the expansion of the DEFCLASS macro is
+;;; fixed. DEFCLASS always expands into a call to LOAD-DEFCLASS. Until
+;;; the meta-braid is set up, LOAD-DEFCLASS has a special definition
+;;; which simply collects all class definitions up, when the metabraid
+;;; is initialized it is done from those class definitions.
;;;
-;;; After the metabraid has been setup, and the protocol for defining classes
-;;; has been defined, the real definition of LOAD-DEFCLASS is installed by the
-;;; file defclass.lisp
+;;; After the metabraid has been setup, and the protocol for defining
+;;; classes has been defined, the real definition of LOAD-DEFCLASS is
+;;; installed by the file defclass.lisp
(defmacro defclass (name direct-superclasses direct-slots &rest options)
(declare (indentation 2 4 3 1))
(expand-defclass name direct-superclasses direct-slots options))
',*accessors*))))))
(if defstruct-p
(progn
- (eval defclass-form) ; define the class now, so that
- `(progn ; the defstruct can be compiled.
+ (eval defclass-form) ; Define the class now, so that..
+ `(progn ; ..the defstruct can be compiled.
,(class-defstruct-form (find-class name))
,defclass-form))
(progn
(nconc default-initargs (reverse (pop others)))))))
(reverse default-initargs)))
-(defun bootstrap-slot-index (class-name slot-name)
+(defun !bootstrap-slot-index (class-name slot-name)
(or (position slot-name (early-class-slots class-name))
(error "~S not found" slot-name)))
-;;; bootstrap-get-slot and bootstrap-set-slot are used to access and change the
-;;; values of slots during bootstrapping. During bootstrapping, there are only
-;;; two kinds of objects whose slots we need to access, CLASSes and
-;;; SLOT-DEFINITIONs. The first argument to these functions tells whether the
-;;; object is a CLASS or a SLOT-DEFINITION.
+;;; !BOOTSTRAP-GET-SLOT and !BOOTSTRAP-SET-SLOT are used to access and
+;;; change the values of slots during bootstrapping. During
+;;; bootstrapping, there are only two kinds of objects whose slots we
+;;; need to access, CLASSes and SLOT-DEFINITIONs. The first argument
+;;; to these functions tells whether the object is a CLASS or a
+;;; SLOT-DEFINITION.
;;;
-;;; Note that the way this works it stores the slot in the same place in
-;;; memory that the full object system will expect to find it later. This
-;;; is critical to the bootstrapping process, the whole changeover to the
-;;; full object system is predicated on this.
+;;; Note that the way this works it stores the slot in the same place
+;;; in memory that the full object system will expect to find it
+;;; later. This is critical to the bootstrapping process, the whole
+;;; changeover to the full object system is predicated on this.
;;;
-;;; One important point is that the layout of standard classes and standard
-;;; slots must be computed the same way in this file as it is by the full
-;;; object system later.
-(defmacro bootstrap-get-slot (type object slot-name)
- `(instance-ref (get-slots ,object) (bootstrap-slot-index ,type ,slot-name)))
-(defun bootstrap-set-slot (type object slot-name new-value)
- (setf (bootstrap-get-slot type object slot-name) new-value))
+;;; One important point is that the layout of standard classes and
+;;; standard slots must be computed the same way in this file as it is
+;;; by the full object system later.
+(defmacro !bootstrap-get-slot (type object slot-name)
+ `(instance-ref (get-slots ,object) (!bootstrap-slot-index ,type ,slot-name)))
+(defun !bootstrap-set-slot (type object slot-name new-value)
+ (setf (!bootstrap-get-slot type object slot-name) new-value))
(defun early-class-name (class)
- (bootstrap-get-slot 'class class 'name))
+ (!bootstrap-get-slot 'class class 'name))
(defun early-class-precedence-list (class)
- (bootstrap-get-slot 'pcl-class class 'class-precedence-list))
+ (!bootstrap-get-slot 'pcl-class class 'class-precedence-list))
(defun early-class-name-of (instance)
(early-class-name (class-of instance)))
(defun early-class-slotds (class)
- (bootstrap-get-slot 'slot-class class 'slots))
+ (!bootstrap-get-slot 'slot-class class 'slots))
(defun early-slot-definition-name (slotd)
- (bootstrap-get-slot 'standard-effective-slot-definition slotd 'name))
+ (!bootstrap-get-slot 'standard-effective-slot-definition slotd 'name))
(defun early-slot-definition-location (slotd)
- (bootstrap-get-slot 'standard-effective-slot-definition slotd 'location))
+ (!bootstrap-get-slot 'standard-effective-slot-definition slotd 'location))
(defun early-accessor-method-slot-name (method)
- (bootstrap-get-slot 'standard-accessor-method method 'slot-name))
+ (!bootstrap-get-slot 'standard-accessor-method method 'slot-name))
(unless (fboundp 'class-name-of)
(setf (symbol-function 'class-name-of)
;;; FIXME: Can we then delete EARLY-CLASS-NAME-OF?
(defun early-class-direct-subclasses (class)
- (bootstrap-get-slot 'class class 'direct-subclasses))
+ (!bootstrap-get-slot 'class class 'direct-subclasses))
(declaim (notinline load-defclass))
(defun load-defclass
(ecase type
(reader #'(sb-kernel:instance-lambda (instance)
(let* ((class (class-of instance))
- (class-name (bootstrap-get-slot 'class class 'name)))
- (bootstrap-get-slot class-name instance slot-name))))
+ (class-name (!bootstrap-get-slot 'class class 'name)))
+ (!bootstrap-get-slot class-name instance slot-name))))
(writer #'(sb-kernel:instance-lambda (new-value instance)
(let* ((class (class-of instance))
- (class-name (bootstrap-get-slot 'class class 'name)))
- (bootstrap-set-slot class-name instance slot-name new-value)))))))
+ (class-name (!bootstrap-get-slot 'class class 'name)))
+ (!bootstrap-set-slot class-name instance slot-name new-value)))))))
(defun initial-dfun (gf args)
(dfun-miss (gf args wrappers invalidp nemf ntype nindex)
(defun order-specializers (specl1 specl2 index compare-classes-function)
(let ((type1 (if (eq *boot-state* 'complete)
(specializer-type specl1)
- (bootstrap-get-slot 'specializer specl1 'type)))
+ (!bootstrap-get-slot 'specializer specl1 'type)))
(type2 (if (eq *boot-state* 'complete)
(specializer-type specl2)
- (bootstrap-get-slot 'specializer specl2 'type))))
+ (!bootstrap-get-slot 'specializer specl2 'type))))
(cond ((eq specl1 specl2)
nil)
((atom type1)
(defmacro posq (item list) `(position ,item ,list :test #'eq))
(defmacro neq (x y) `(not (eq ,x ,y)))
-;;; FIXME: Rename these to CONSTANTLY-T, CONSTANTLY-NIL, and CONSTANTLY-0
+;;; FIXME: Rename these to CONSTANTLY-T, CONSTANTLY-NIL, and CONSTANTLY-0,
;;; and boost them up to SB-INT.
(defun true (&rest ignore) (declare (ignore ignore)) t)
(defun false (&rest ignore) (declare (ignore ignore)) nil)
;;; versions, and a string like "0.6.5.12" is used for versions which
;;; aren't released but correspond only to CVS tags or snapshots.
-"0.6.9.12"
+"0.6.9.13"
projects / sbcl.git / commitdiff