From: William Harold Newman Date: Sat, 26 Jan 2002 17:10:31 +0000 (+0000) Subject: 0.7.0.7: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=106e6fe2df729b6027718f6f056721a95c047c17;p=sbcl.git 0.7.0.7: deleted unused EMIT-DEFAULT-ONLY-MACRO various cosmetic changes in src/pcl/ --- diff --git a/src/code/float.lisp b/src/code/float.lisp index 104818c..ee9dacd 100644 --- a/src/code/float.lisp +++ b/src/code/float.lisp @@ -1,7 +1,7 @@ -;;;; This file contains the definitions of float specific number +;;;; This file contains the definitions of float-specific number ;;;; support (other than irrational stuff, which is in irrat.) There is ;;;; code in here that assumes there are only two float formats: IEEE -;;;; single and double. (Long-float support has been added, but bugs +;;;; single and double. (LONG-FLOAT support has been added, but bugs ;;;; may still remain due to old code which assumes this dichotomy.) ;;;; This software is part of the SBCL system. See the README file for diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index f8df4fd..3284897 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -90,7 +90,6 @@ bootstrapping. (declaim (notinline make-a-method add-named-method ensure-generic-function-using-class - add-method remove-method)) diff --git a/src/pcl/cache.lisp b/src/pcl/cache.lisp index cb3371b..829a4b6 100644 --- a/src/pcl/cache.lisp +++ b/src/pcl/cache.lisp @@ -816,25 +816,23 @@ `(function-funcall ,fn-variable ,@required)))) (defun make-dfun-arg-list (metatypes applyp) - (let ((required - (let ((required nil)) - (dotimes (i (length metatypes)) - (push (dfun-arg-symbol i) required)) - (nreverse required)))) + (let ((required (let ((reversed-required nil)) + (dotimes (i (length metatypes)) + (push (dfun-arg-symbol i) reversed-required)) + (nreverse reversed-required)))) (if applyp `(list* ,@required .dfun-rest-arg.) `(list ,@required)))) (defun make-fast-method-call-lambda-list (metatypes applyp) - (let ((lambda-list nil)) - (push '.pv-cell. lambda-list) - (push '.next-method-call. lambda-list) + (let ((reversed-lambda-list nil)) + (push '.pv-cell. reversed-lambda-list) + (push '.next-method-call. reversed-lambda-list) (dotimes (i (length metatypes)) - (push (dfun-arg-symbol i) lambda-list)) + (push (dfun-arg-symbol i) reversed-lambda-list)) (when applyp - (push '.dfun-rest-arg. lambda-list)) - (nreverse lambda-list))) - + (push '.dfun-rest-arg. reversed-lambda-list)) + (nreverse reversed-lambda-list))) ;;;; a comment from some PCL implementor: ;;;; Its too bad Common Lisp compilers freak out when you have a diff --git a/src/pcl/combin.lisp b/src/pcl/combin.lisp index 6ab148a..3429ad7 100644 --- a/src/pcl/combin.lisp +++ b/src/pcl/combin.lisp @@ -95,7 +95,7 @@ (defun make-effective-method-function-simple (generic-function form &optional no-fmf-p) - ;; The effective method is just a call to call-method. This opens up + ;; The effective method is just a call to CALL-METHOD. This opens up ;; the possibility of just using the method function of the method as ;; the effective method function. ;; @@ -179,8 +179,8 @@ ;; args are not used giving a compiler warning. (error-p (eq (first effective-method) 'error))) `(lambda ,ll - (declare (ignore ,@(if error-p ll '(.pv-cell. .next-method-call.)))) - ,effective-method)))) + (declare (ignore ,@(if error-p ll '(.pv-cell. .next-method-call.)))) + ,effective-method)))) (defun expand-emf-call-method (gf form metatypes applyp env) (declare (ignore gf metatypes applyp env)) diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp index 4a20a8f..4df534a 100644 --- a/src/pcl/defs.lisp +++ b/src/pcl/defs.lisp @@ -507,90 +507,93 @@ (defclass funcallable-standard-object (std-object sb-kernel:funcallable-instance) - () + () (:metaclass funcallable-standard-class)) (defclass specializer (standard-object) - ((type - :initform nil - :reader specializer-type))) + ((type + :initform nil + :reader specializer-type))) (defclass definition-source-mixin (std-object) - ((source - :initform *load-truename* - :reader definition-source - :initarg :definition-source)) + ((source + :initform *load-truename* + :reader definition-source + :initarg :definition-source)) (:metaclass std-class)) (defclass plist-mixin (std-object) - ((plist - :initform () - :accessor object-plist)) + ((plist + :initform () + :accessor object-plist)) (:metaclass std-class)) (defclass documentation-mixin (plist-mixin) - () + () (:metaclass std-class)) (defclass dependent-update-mixin (plist-mixin) - () + () (:metaclass std-class)) -;;; The class CLASS is a specified basic class. It is the common superclass -;;; of any kind of class. That is any class that can be a metaclass must -;;; have the class CLASS in its class precedence list. -(defclass class (documentation-mixin dependent-update-mixin - definition-source-mixin specializer) - ((name - :initform nil - :initarg :name - :accessor class-name) - (class-eq-specializer - :initform nil - :reader class-eq-specializer) - (direct-superclasses - :initform () - :reader class-direct-superclasses) - (direct-subclasses - :initform () - :reader class-direct-subclasses) - (direct-methods - :initform (cons nil nil)) - (predicate-name - :initform nil - :reader class-predicate-name))) - -;;; The class PCL-CLASS is an implementation-specific common superclass of -;;; all specified subclasses of the class CLASS. +;;; The class CLASS is a specified basic class. It is the common +;;; superclass of any kind of class. That is any class that can be a +;;; metaclass must have the class CLASS in its class precedence list. +(defclass class (documentation-mixin + dependent-update-mixin + definition-source-mixin + specializer) + ((name + :initform nil + :initarg :name + :accessor class-name) + (class-eq-specializer + :initform nil + :reader class-eq-specializer) + (direct-superclasses + :initform () + :reader class-direct-superclasses) + (direct-subclasses + :initform () + :reader class-direct-subclasses) + (direct-methods + :initform (cons nil nil)) + (predicate-name + :initform nil + :reader class-predicate-name))) + +;;; The class PCL-CLASS is an implementation-specific common +;;; superclass of all specified subclasses of the class CLASS. (defclass pcl-class (class) - ((class-precedence-list - :reader class-precedence-list) - (can-precede-list - :initform () - :reader class-can-precede-list) - (incompatible-superclass-list - :initform () - :accessor class-incompatible-superclass-list) - (wrapper - :initform nil - :reader class-wrapper) - (prototype - :initform nil - :reader class-prototype))) + ((class-precedence-list + :reader class-precedence-list) + (can-precede-list + :initform () + :reader class-can-precede-list) + (incompatible-superclass-list + :initform () + :accessor class-incompatible-superclass-list) + (wrapper + :initform nil + :reader class-wrapper) + (prototype + :initform nil + :reader class-prototype))) (defclass slot-class (pcl-class) - ((direct-slots - :initform () - :accessor class-direct-slots) - (slots - :initform () - :accessor class-slots) - (initialize-info - :initform nil - :accessor class-initialize-info))) - -;;; The class STD-CLASS is an implementation-specific common superclass of -;;; the classes STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS. + ((direct-slots + :initform () + :accessor class-direct-slots) + (slots + :initform () + :accessor class-slots) + (initialize-info + :initform nil + :accessor class-initialize-info))) + +;;; The class STD-CLASS is an implementation-specific common +;;; superclass of the classes STANDARD-CLASS and +;;; FUNCALLABLE-STANDARD-CLASS. (defclass std-class (slot-class) ()) @@ -644,41 +647,41 @@ ;;;; slot definitions (defclass slot-definition (standard-object) - ((name - :initform nil - :initarg :name - :accessor slot-definition-name) - (initform - :initform nil - :initarg :initform - :accessor slot-definition-initform) - (initfunction - :initform nil - :initarg :initfunction - :accessor slot-definition-initfunction) - (readers - :initform nil - :initarg :readers - :accessor slot-definition-readers) - (writers - :initform nil - :initarg :writers - :accessor slot-definition-writers) - (initargs - :initform nil - :initarg :initargs - :accessor slot-definition-initargs) - (type - :initform t - :initarg :type - :accessor slot-definition-type) - (documentation - :initform "" - :initarg :documentation) - (class - :initform nil - :initarg :class - :accessor slot-definition-class))) + ((name + :initform nil + :initarg :name + :accessor slot-definition-name) + (initform + :initform nil + :initarg :initform + :accessor slot-definition-initform) + (initfunction + :initform nil + :initarg :initfunction + :accessor slot-definition-initfunction) + (readers + :initform nil + :initarg :readers + :accessor slot-definition-readers) + (writers + :initform nil + :initarg :writers + :accessor slot-definition-writers) + (initargs + :initform nil + :initarg :initargs + :accessor slot-definition-initargs) + (type + :initform t + :initarg :type + :accessor slot-definition-type) + (documentation + :initform "" + :initarg :documentation) + (class + :initform nil + :initarg :class + :accessor slot-definition-class))) (defclass standard-slot-definition (slot-definition) ((allocation @@ -823,14 +826,17 @@ (defclass method-combination (standard-object) ()) -(defclass standard-method-combination - (definition-source-mixin method-combination) - ((type :reader method-combination-type - :initarg :type) - (documentation :reader method-combination-documentation - :initarg :documentation) - (options :reader method-combination-options - :initarg :options))) +(defclass standard-method-combination (definition-source-mixin + method-combination) + ((type + :reader method-combination-type + :initarg :type) + (documentation + :reader method-combination-documentation + :initarg :documentation) + (options + :reader method-combination-options + :initarg :options))) (defparameter *early-class-predicates* '((specializer specializerp) diff --git a/src/pcl/dlisp.lisp b/src/pcl/dlisp.lisp index 2639eb6..a182810 100644 --- a/src/pcl/dlisp.lisp +++ b/src/pcl/dlisp.lisp @@ -71,6 +71,7 @@ ;;; -------------------------------- +;;; FIXME: What do these variables mean? (defvar *precompiling-lap* nil) (defvar *emit-function-p* t) @@ -83,13 +84,10 @@ (restl (when applyp '(.lap-rest-arg.)))) (generating-lisp '(emf) dlap-lambda-list - `(invoke-effective-method-function emf ,applyp ,@args ,@restl)))) - -(defmacro emit-default-only-macro (metatypes applyp) - (let ((*emit-function-p* nil) - (*precompiling-lap* t)) - (values - (emit-default-only metatypes applyp)))) + `(invoke-effective-method-function emf + ,applyp + ,@args + ,@restl)))) ;;; -------------------------------- @@ -110,11 +108,11 @@ nil))) ;;; note on implementation for CMU 17 and later (including SBCL): -;;; Since std-instance-p is weakened, that branch may run on non-pcl +;;; Since STD-INSTANCE-P is weakened, that branch may run on non-PCL ;;; instances (structures). The result will be the non-wrapper layout ;;; for the structure, which will cause a miss. The "slots" will be ;;; whatever the first slot is, but will be ignored. Similarly, -;;; fsc-instance-p returns true on funcallable structures as well as +;;; FSC-INSTANCE-P returns true on funcallable structures as well as ;;; PCL fins. (defun emit-reader/writer (reader/writer 1-or-2-class class-slot-p) (when (and (null *precompiling-lap*) *emit-function-p*) @@ -135,30 +133,33 @@ (ecase 1-or-2-class (1 (setq closure-variables '(wrapper-0 index miss-fn))) (2 (setq closure-variables '(wrapper-0 wrapper-1 index miss-fn)))) - (generating-lisp closure-variables - arglist - `(let* (,@(unless class-slot-p `((slots nil))) + (generating-lisp + closure-variables + arglist + `(let* (,@(unless class-slot-p `((slots nil))) (wrapper (cond ((std-instance-p ,instance) ,@(unless class-slot-p - `((setq slots (std-instance-slots ,instance)))) + `((setq slots + (std-instance-slots ,instance)))) (std-instance-wrapper ,instance)) ((fsc-instance-p ,instance) ,@(unless class-slot-p - `((setq slots (fsc-instance-slots ,instance)))) + `((setq slots + (fsc-instance-slots ,instance)))) (fsc-instance-wrapper ,instance))))) - (block access - (when (and wrapper - (/= (wrapper-cache-number-vector-ref wrapper ,field) 0) - ,@(if (eql 1 1-or-2-class) - `((eq wrapper wrapper-0)) - `((or (eq wrapper wrapper-0) - (eq wrapper wrapper-1))))) - ,@(if readp - `((let ((value ,read-form)) - (unless (eq value +slot-unbound+) - (return-from access value)))) - `((return-from access (setf ,read-form ,(car arglist)))))) - (funcall miss-fn ,@arglist)))))) + (block access + (when (and wrapper + (/= (wrapper-cache-number-vector-ref wrapper ,field) 0) + ,@(if (eql 1 1-or-2-class) + `((eq wrapper wrapper-0)) + `((or (eq wrapper wrapper-0) + (eq wrapper wrapper-1))))) + ,@(if readp + `((let ((value ,read-form)) + (unless (eq value +slot-unbound+) + (return-from access value)))) + `((return-from access (setf ,read-form ,(car arglist)))))) + (funcall miss-fn ,@arglist)))))) (defun emit-slot-read-form (class-slot-p index slots) (if class-slot-p @@ -176,7 +177,12 @@ (funcall ,miss-fn ,@arglist) value))) -(defun emit-slot-access (reader/writer class-slot-p slots index miss-fn arglist) +(defun emit-slot-access (reader/writer + class-slot-p + slots + index + miss-fn + arglist) (let ((read-form (emit-slot-read-form class-slot-p index slots)) (write-form (emit-slot-write-form class-slot-p index slots (car arglist)))) @@ -190,7 +196,9 @@ (values (emit-reader/writer reader/writer 1-or-2-class class-slot-p)))) -(defun emit-one-or-n-index-reader/writer (reader/writer cached-index-p class-slot-p) +(defun emit-one-or-n-index-reader/writer (reader/writer + cached-index-p + class-slot-p) (when (and (null *precompiling-lap*) *emit-function-p*) (return-from emit-one-or-n-index-reader/writer (emit-one-or-n-index-reader/writer-function @@ -201,23 +209,26 @@ '(standard-instance))) (:writer (values (list (dfun-arg-symbol 0) (dfun-arg-symbol 1)) '(t standard-instance)))) - (generating-lisp `(cache ,@(unless cached-index-p '(index)) miss-fn) - arglist - `(let (,@(unless class-slot-p '(slots)) - ,@(when cached-index-p '(index))) - ,(emit-dlap arglist metatypes - (emit-slot-access reader/writer class-slot-p - 'slots 'index 'miss-fn arglist) - `(funcall miss-fn ,@arglist) - (when cached-index-p 'index) - (unless class-slot-p '(slots))))))) + (generating-lisp + `(cache ,@(unless cached-index-p '(index)) miss-fn) + arglist + `(let (,@(unless class-slot-p '(slots)) + ,@(when cached-index-p '(index))) + ,(emit-dlap arglist metatypes + (emit-slot-access reader/writer class-slot-p + 'slots 'index 'miss-fn arglist) + `(funcall miss-fn ,@arglist) + (when cached-index-p 'index) + (unless class-slot-p '(slots))))))) (defmacro emit-one-or-n-index-reader/writer-macro (reader/writer cached-index-p class-slot-p) (let ((*emit-function-p* nil) (*precompiling-lap* t)) (values - (emit-one-or-n-index-reader/writer reader/writer cached-index-p class-slot-p)))) + (emit-one-or-n-index-reader/writer reader/writer + cached-index-p + class-slot-p)))) (defun emit-miss (miss-fn args &optional applyp) (let ((restl (when applyp '(.lap-rest-arg.)))) @@ -233,19 +244,23 @@ (let* ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp)) (args (remove '&rest dlap-lambda-list)) (restl (when applyp '(.lap-rest-arg.)))) - (generating-lisp `(cache ,@(unless cached-emf-p '(emf)) miss-fn) - dlap-lambda-list - `(let (,@(when cached-emf-p '(emf))) - ,(emit-dlap args - metatypes - (if return-value-p - (if cached-emf-p 'emf t) - `(invoke-effective-method-function emf ,applyp - ,@args ,@restl)) - (emit-miss 'miss-fn args applyp) - (when cached-emf-p 'emf)))))) - -(defmacro emit-checking-or-caching-macro (cached-emf-p return-value-p metatypes applyp) + (generating-lisp + `(cache ,@(unless cached-emf-p '(emf)) miss-fn) + dlap-lambda-list + `(let (,@(when cached-emf-p '(emf))) + ,(emit-dlap args + metatypes + (if return-value-p + (if cached-emf-p 'emf t) + `(invoke-effective-method-function + emf ,applyp ,@args ,@restl)) + (emit-miss 'miss-fn args applyp) + (when cached-emf-p 'emf)))))) + +(defmacro emit-checking-or-caching-macro (cached-emf-p + return-value-p + metatypes + applyp) (let ((*emit-function-p* nil) (*precompiling-lap* t)) (values @@ -286,7 +301,8 @@ (return-from dfun ,miss))))) (defun emit-1-nil-dlap (wrapper miss-label) - `(let* ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper miss-label)) + `(let* ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper + miss-label)) (location primary)) (declare (fixnum primary location)) (block search @@ -308,7 +324,8 @@ (the fixnum lock-count))) (defun emit-1-t-dlap (wrapper miss-label value) - `(let ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper miss-label)) + `(let ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper + miss-label)) (initial-lock-count (get-cache-vector-lock-count cache-vector))) (declare (fixnum primary initial-lock-count)) (let ((location primary)) @@ -332,13 +349,16 @@ (defun emit-greater-than-1-dlap (wrappers miss-label value) (declare (type list wrappers)) - (let ((cache-line-size (compute-line-size (+ (length wrappers) (if value 1 0))))) - `(let ((primary 0) (size-1 (the fixnum (- size 1)))) + (let ((cache-line-size (compute-line-size (+ (length wrappers) + (if value 1 0))))) + `(let ((primary 0) + (size-1 (the fixnum (- size 1)))) (declare (fixnum primary size-1)) ,(emit-n-wrapper-compute-primary-cache-location wrappers miss-label) (let ((initial-lock-count (get-cache-vector-lock-count cache-vector))) (declare (fixnum initial-lock-count)) - (let ((location primary) (next-location 0)) + (let ((location primary) + (next-location 0)) (declare (fixnum location next-location)) (block search (loop (setq next-location @@ -353,7 +373,8 @@ wrappers)) ,@(when value `((setq location (the fixnum (+ location 1))) - (setq ,value (cache-vector-ref cache-vector location)))) + (setq ,value (cache-vector-ref cache-vector + location)))) (return-from search nil)) (setq location next-location) (when (= location size-1) @@ -402,12 +423,13 @@ `(the fixnum ,form)))))))) wrappers)))) -;;; CMU17 (and SBCL) note: Since STD-INSTANCE-P is weakened in the CMU/SBCL -;;; approach of using funcallable instances, that branch may run -;;; on non-pcl instances (structures). The result will be the -;;; non-wrapper layout for the structure, which will cause a miss. The "slots" -;;; will be whatever the first slot is, but will be ignored. Similarly, -;;; fsc-instance-p returns true on funcallable structures as well as PCL fins. +;;; CMU17 (and SBCL) note: Since STD-INSTANCE-P is weakened in the +;;; CMU/SBCL approach of using funcallable instances, that branch may +;;; run on non-pcl instances (structures). The result will be the +;;; non-wrapper layout for the structure, which will cause a miss. The +;;; "slots" will be whatever the first slot is, but will be ignored. +;;; Similarly, FSC-INSTANCE-P returns true on funcallable structures +;;; as well as PCL fins. (defun emit-fetch-wrapper (metatype argument miss-label &optional slot) (ecase metatype ((standard-instance) diff --git a/src/pcl/dlisp2.lisp b/src/pcl/dlisp2.lisp index b192fe6..45e6212 100644 --- a/src/pcl/dlisp2.lisp +++ b/src/pcl/dlisp2.lisp @@ -62,7 +62,7 @@ (emit-one-or-n-index-reader/writer-macro :writer nil nil))))) nil)) -;;; Note this list is setup in dlisp3.lisp when all the necessary +;;; Note this list is set up in dlisp3.lisp when all the necessary ;;; macros have been loaded. (defvar *checking-or-caching-function-list* nil) diff --git a/src/pcl/fngen.lisp b/src/pcl/fngen.lisp index 17a6e72..7564c76 100644 --- a/src/pcl/fngen.lisp +++ b/src/pcl/fngen.lisp @@ -39,7 +39,7 @@ ;;; There are three internal functions which operate on the lambda argument ;;; to GET-FUN: ;;; COMPUTE-TEST converts the lambda into a key to be used for lookup, -;;; COMPUTE-CODE is used by get-new-fun-generator-internal to +;;; COMPUTE-CODE is used by GET-NEW-FUN-GENERATOR-INTERNAL to ;;; generate the actual lambda to be compiled, and ;;; COMPUTE-CONSTANTS is used to generate the argument list that is ;;; to be passed to the compiled function. diff --git a/version.lisp-expr b/version.lisp-expr index 167616b..6da1e88 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; for internal versions, especially for internal versions off the ;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.7.0.6" +"0.7.0.7"