From 903f4432362a1e7764dfed46d35894625cc085d8 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Tue, 22 Aug 2006 15:48:56 +0000 Subject: [PATCH] 0.9.15.46: cosmetic cleanups * SLOT-VALUE-OR-DEFAULT now uses an UNREADABLE-OBJECT as the default marker for unbound slots, giving us # instead of "unbound". * Edit special operator docstrings for consistency. * Whitespace. --- package-data-list.lisp-expr | 1 + src/assembly/assemfile.lisp | 4 +- src/code/debug.lisp | 11 --- src/code/late-extensions.lisp | 10 +++ src/compiler/ir1-translators.lisp | 171 ++++++++++++++++++++----------------- src/pcl/boot.lisp | 6 +- src/pcl/methods.lisp | 2 +- src/pcl/slots.lisp | 5 +- tests/mop.impure.lisp | 2 +- version.lisp-expr | 2 +- 10 files changed, 118 insertions(+), 96 deletions(-) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index f60e23f..2fa1bf0 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -890,6 +890,7 @@ retained, possibly temporariliy, because it might be used internally." "DEPRECATION-WARNING" "BIT-VECTOR-=" "READ-EVALUATED-FORM" + "MAKE-UNPRINTABLE-OBJECT" ;; ..and macros.. "COLLECT" diff --git a/src/assembly/assemfile.lisp b/src/assembly/assemfile.lisp index 591acfb..837b239 100644 --- a/src/assembly/assemfile.lisp +++ b/src/assembly/assemfile.lisp @@ -188,8 +188,8 @@ (multiple-value-bind (name options) (if (atom name&options) (values name&options nil) - (values (car name&options) - (cdr name&options))) + (values (car name&options) + (cdr name&options))) (let ((regs (mapcar (lambda (var) (apply #'parse-reg-spec var)) vars))) (if *emit-assembly-code-not-vops-p* (emit-assemble name options regs code) diff --git a/src/code/debug.lisp b/src/code/debug.lisp index 510501e..cad19af 100644 --- a/src/code/debug.lisp +++ b/src/code/debug.lisp @@ -223,17 +223,6 @@ is how many frames to show." ) ; EVAL-WHEN -;;; This is used in constructing arg lists for debugger printing when -;;; the arg list is unavailable, some arg is unavailable or unused, etc. -(defstruct (unprintable-object - (:constructor make-unprintable-object (string)) - (:print-object (lambda (x s) - (print-unreadable-object (x s) - (write-string (unprintable-object-string x) - s)))) - (:copier nil)) - string) - ;;; Extract the function argument values for a debug frame. (defun frame-args-as-list (frame) (let ((debug-fun (sb!di:frame-debug-fun frame)) diff --git a/src/code/late-extensions.lisp b/src/code/late-extensions.lisp index a841f90..4d0e08b 100644 --- a/src/code/late-extensions.lisp +++ b/src/code/late-extensions.lisp @@ -35,3 +35,13 @@ ;;; ;; be doing him a favor by printing the object here. ;;; ;; -- WHN 2002-10-19 ;;; (error "can't calculate length of cyclic list"))) + +;;; This is used in constructing arg lists for debugger printing, +;;; and when needing to print unbound slots in PCL. +(defstruct (unprintable-object + (:constructor make-unprintable-object (string)) + (:print-object (lambda (x s) + (print-unreadable-object (x s) + (write-string (unprintable-object-string x) s)))) + (:copier nil)) + string) diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index c8b2473..0ca97d2 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -16,16 +16,18 @@ (def-ir1-translator progn ((&rest forms) start next result) #!+sb-doc - "Progn Form* - Evaluates each Form in order, returning the values of the last form. With no - forms, returns NIL." + "PROGN form* + +Evaluates each FORM in order, returning the values of the last form. With no +forms, returns NIL." (ir1-convert-progn-body start next result forms)) (def-ir1-translator if ((test then &optional else) start next result) #!+sb-doc - "If Predicate Then [Else] - If Predicate evaluates to non-null, evaluate Then and returns its values, - otherwise evaluate Else and return its values. Else defaults to NIL." + "IF predicate then [else] + +If PREDICATE evaluates to false, evaluate THEN and return its values, +otherwise evaluate ELSE and return its values. ELSE defaults to NIL." (let* ((pred-ctran (make-ctran)) (pred-lvar (make-lvar)) (then-ctran (make-ctran)) @@ -63,10 +65,10 @@ ;;; environment. (def-ir1-translator block ((name &rest forms) start next result) #!+sb-doc - "Block Name Form* - Evaluate the Forms as a PROGN. Within the lexical scope of the body, - (RETURN-FROM Name Value-Form) can be used to exit the form, returning the - result of Value-Form." + "BLOCK name form* + +Evaluate the FORMS as a PROGN. Within the lexical scope of the body, +RETURN-FROM can be used to exit the form." (unless (symbolp name) (compiler-error "The block name ~S is not a symbol." name)) (start-block start) @@ -87,10 +89,11 @@ (def-ir1-translator return-from ((name &optional value) start next result) #!+sb-doc - "Return-From Block-Name Value-Form - Evaluate the Value-Form, returning its values from the lexically enclosing - BLOCK Block-Name. This is constrained to be used only within the dynamic - extent of the BLOCK." + "RETURN-FROM block-name value-form + +Evaluate the VALUE-FORM, returning its values from the lexically enclosing +block BLOCK-NAME. This is constrained to be used only within the dynamic +extent of the block." ;; old comment: ;; We make NEXT start a block just so that it will have a block ;; assigned. People assume that when they pass a ctran into @@ -159,13 +162,13 @@ ;;; values. (def-ir1-translator tagbody ((&rest statements) start next result) #!+sb-doc - "Tagbody {Tag | Statement}* - Define tags for used with GO. The Statements are evaluated in order - (skipping Tags) and NIL is returned. If a statement contains a GO to a - defined Tag within the lexical scope of the form, then control is transferred - to the next statement following that tag. A Tag must an integer or a - symbol. A statement must be a list. Other objects are illegal within the - body." + "TAGBODY {tag | statement}* + +Define tags for use with GO. The STATEMENTS are evaluated in order ,skipping +TAGS, and NIL is returned. If a statement contains a GO to a defined TAG +within the lexical scope of the form, then control is transferred to the next +statement following that tag. A TAG must an integer or a symbol. A STATEMENT +must be a list. Other objects are illegal within the body." (start-block start) (ctran-starts-block next) (let* ((dummy (make-ctran)) @@ -201,9 +204,10 @@ ;;; Emit an EXIT node without any value. (def-ir1-translator go ((tag) start next result) #!+sb-doc - "Go Tag - Transfer control to the named Tag in the lexically enclosing TAGBODY. This - is constrained to be used only within the dynamic extent of the TAGBODY." + "GO tag + +Transfer control to the named TAG in the lexically enclosing TAGBODY. This is +constrained to be used only within the dynamic extent of the TAGBODY." (ctran-starts-block next) (let* ((found (or (lexenv-find tag tags :test #'eql) (compiler-error "attempt to GO to nonexistent tag: ~S" @@ -233,9 +237,10 @@ ;;; form; otherwise, the forms in the body are ignored. (def-ir1-translator eval-when ((situations &rest forms) start next result) #!+sb-doc - "EVAL-WHEN (Situation*) Form* - Evaluate the Forms in the specified Situations (any of :COMPILE-TOPLEVEL, - :LOAD-TOPLEVEL, or :EXECUTE, or (deprecated) COMPILE, LOAD, or EVAL)." + "EVAL-WHEN (situation*) form* + +Evaluate the FORMS in the specified SITUATIONS (any of :COMPILE-TOPLEVEL, +:LOAD-TOPLEVEL, or :EXECUTE, or (deprecated) COMPILE, LOAD, or EVAL)." (multiple-value-bind (ct lt e) (parse-eval-when-situations situations) (declare (ignore ct lt)) (ir1-convert-progn-body start next result (and e forms))) @@ -310,10 +315,11 @@ (def-ir1-translator macrolet ((definitions &rest body) start next result) #!+sb-doc - "MACROLET ({(Name Lambda-List Form*)}*) Body-Form* - Evaluate the Body-Forms in an environment with the specified local macros - defined. Name is the local macro name, Lambda-List is the DEFMACRO style - destructuring lambda list, and the Forms evaluate to the expansion.." + "MACROLET ({(name lambda-list form*)}*) body-form* + +Evaluate the BODY-FORMS in an environment with the specified local macros +defined. Name is the local macro name, LAMBDA-LIST is a DEFMACRO style +destructuring lambda list, and the FORMS evaluate to the expansion." (funcall-in-macrolet-lexenv definitions (lambda (&key funs) @@ -354,9 +360,10 @@ (def-ir1-translator symbol-macrolet ((macrobindings &body body) start next result) #!+sb-doc - "SYMBOL-MACROLET ({(Name Expansion)}*) Decl* Form* - Define the Names as symbol macros with the given Expansions. Within the - body, references to a Name will effectively be replaced with the Expansion." + "SYMBOL-MACROLET ({(name expansion)}*) decl* form* + +Define the NAMES as symbol macros with the given EXPANSIONS. Within the +body, references to a NAME will effectively be replaced with the EXPANSION." (funcall-in-symbol-macrolet-lexenv macrobindings (lambda (&key vars) @@ -430,8 +437,9 @@ (def-ir1-translator quote ((thing) start next result) #!+sb-doc - "QUOTE Value - Return Value without evaluating it." + "QUOTE value + +Return VALUE without evaluating it." (reference-constant start next result thing)) ;;;; FUNCTION and NAMED-LAMBDA @@ -486,9 +494,10 @@ (def-ir1-translator function ((thing) start next result) #!+sb-doc - "FUNCTION Name - Return the lexically apparent definition of the function Name. Name may also - be a lambda expression." + "FUNCTION name + +Return the lexically apparent definition of the function NAME. NAME may also +be a lambda expression." (with-fun-name-leaf (leaf thing start) (reference-leaf start next result leaf))) @@ -596,10 +605,11 @@ (def-ir1-translator let ((bindings &body body) start next result) #!+sb-doc - "LET ({(Var [Value]) | Var}*) Declaration* Form* - During evaluation of the Forms, bind the Vars to the result of evaluating the - Value forms. The variables are bound in parallel after all of the Values are - evaluated." + "LET ({(var [value]) | var}*) declaration* form* + +During evaluation of the FORMS, bind the VARS to the result of evaluating the +VALUE forms. The variables are bound in parallel after all of the VALUES forms +have been evaluated." (cond ((null bindings) (ir1-translate-locally body start next result)) ((listp bindings) @@ -625,9 +635,10 @@ (def-ir1-translator let* ((bindings &body body) start next result) #!+sb-doc - "LET* ({(Var [Value]) | Var}*) Declaration* Form* - Similar to LET, but the variables are bound sequentially, allowing each Value - form to reference any of the previous Vars." + "LET* ({(var [value]) | var}*) declaration* form* + +Similar to LET, but the variables are bound sequentially, allowing each VALUE +form to reference any of the previous VARS." (if (listp bindings) (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil) @@ -658,10 +669,11 @@ (def-ir1-translator locally ((&body body) start next result) #!+sb-doc - "LOCALLY Declaration* Form* - Sequentially evaluate the Forms in a lexical environment where the - the Declarations have effect. If LOCALLY is a top level form, then - the Forms are also processed as top level forms." + "LOCALLY declaration* form* + +Sequentially evaluate the FORMS in a lexical environment where the the +DECLARATIONS have effect. If LOCALLY is a top level form, then the FORMS are +also processed as top level forms." (ir1-translate-locally body start next result)) ;;;; FLET and LABELS @@ -719,10 +731,11 @@ (def-ir1-translator flet ((definitions &body body) start next result) #!+sb-doc - "FLET ({(Name Lambda-List Declaration* Form*)}*) Declaration* Body-Form* - Evaluate the Body-Forms with some local function definitions. The bindings - do not enclose the definitions; any use of Name in the Forms will refer to - the lexically apparent function definition in the enclosing environment." + "FLET ({(name lambda-list declaration* form*)}*) declaration* body-form* + +Evaluate the BODY-FORMS with local function definitions. The bindings do +not enclose the definitions; any use of NAME in the FORMS will refer to the +lexically apparent function definition in the enclosing environment." (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil) (multiple-value-bind (names defs) @@ -738,10 +751,11 @@ (def-ir1-translator labels ((definitions &body body) start next result) #!+sb-doc - "LABELS ({(Name Lambda-List Declaration* Form*)}*) Declaration* Body-Form* - Evaluate the Body-Forms with some local function definitions. The bindings - enclose the new definitions, so the defined functions can call themselves or - each other." + "LABELS ({(name lambda-list declaration* form*)}*) declaration* body-form* + +Evaluate the BODY-FORMS with local function definitions. The bindings enclose +the new definitions, so the defined functions can call themselves or each +other." (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil) (multiple-value-bind (names defs) (extract-flet-vars definitions 'labels) @@ -896,9 +910,10 @@ ;;; properties other than receiving multiple-values. (def-ir1-translator throw ((tag result) start next result-lvar) #!+sb-doc - "Throw Tag Form - Do a non-local exit, return the values of Form from the CATCH whose tag - evaluates to the same thing as Tag." + "THROW tag form + +Do a non-local exit, return the values of FORM from the CATCH whose tag is EQ +to TAG." (ir1-convert start next result-lvar `(multiple-value-call #'%throw ,tag ,result))) @@ -956,11 +971,12 @@ (def-ir1-translator catch ((tag &body body) start next result) #!+sb-doc - "Catch Tag Form* - Evaluate TAG and instantiate it as a catcher while the body forms are - evaluated in an implicit PROGN. If a THROW is done to TAG within the dynamic - scope of the body, then control will be transferred to the end of the body - and the thrown values will be returned." + "CATCH tag form* + +Evaluate TAG and instantiate it as a catcher while the body forms are +evaluated in an implicit PROGN. If a THROW is done to TAG within the dynamic +scope of the body, then control will be transferred to the end of the body and +the thrown values will be returned." ;; We represent the possibility of the control transfer by making an ;; "escape function" that does a lexical exit, and instantiate the ;; cleanup using %WITHIN-CLEANUP. @@ -975,10 +991,11 @@ (def-ir1-translator unwind-protect ((protected &body cleanup) start next result) #!+sb-doc - "Unwind-Protect Protected Cleanup* - Evaluate the form PROTECTED, returning its values. The CLEANUP forms are - evaluated whenever the dynamic scope of the PROTECTED form is exited (either - due to normal completion or a non-local exit such as THROW)." + "UNWIND-PROTECT protected cleanup* + +Evaluate the form PROTECTED, returning its values. The CLEANUP forms are +evaluated whenever the dynamic scope of the PROTECTED form is exited (either +due to normal completion or a non-local exit such as THROW)." ;; UNWIND-PROTECT is similar to CATCH, but hairier. We make the ;; cleanup forms into a local function so that they can be referenced ;; both in the case where we are unwound and in any local exits. We @@ -1008,9 +1025,10 @@ (def-ir1-translator multiple-value-call ((fun &rest args) start next result) #!+sb-doc - "MULTIPLE-VALUE-CALL Function Values-Form* - Call FUNCTION, passing all the values of each VALUES-FORM as arguments, - values from the first VALUES-FORM making up the first argument, etc." + "MULTIPLE-VALUE-CALL function values-form* + +Call FUNCTION, passing all the values of each VALUES-FORM as arguments, +values from the first VALUES-FORM making up the first argument, etc." (let* ((ctran (make-ctran)) (fun-lvar (make-lvar)) (node (if args @@ -1047,9 +1065,10 @@ (def-ir1-translator multiple-value-prog1 ((values-form &rest forms) start next result) #!+sb-doc - "MULTIPLE-VALUE-PROG1 Values-Form Form* - Evaluate Values-Form and then the Forms, but return all the values of - Values-Form." + "MULTIPLE-VALUE-PROG1 values-form form* + +Evaluate VALUES-FORM and then the FORMS, but return all the values of +VALUES-FORM." (let ((dummy (make-ctran))) (ctran-starts-block dummy) (ir1-convert start dummy result values-form) diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 6d60aee..46aa611 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -2202,9 +2202,9 @@ bootstrapping. arglist &rest initargs) (let* (;; we don't need to deal with the :generic-function-class - ;; argument here because the default, - ;; STANDARD-GENERIC-FUNCTION, is right for all early generic - ;; functions. (See REAL-ADD-NAMED-METHOD) + ;; argument here because the default, + ;; STANDARD-GENERIC-FUNCTION, is right for all early generic + ;; functions. (See REAL-ADD-NAMED-METHOD) (gf (ensure-generic-function generic-function-name)) (existing (dolist (m (early-gf-methods gf)) diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index c395c7b..b192b02 100644 --- a/src/pcl/methods.lisp +++ b/src/pcl/methods.lisp @@ -229,7 +229,7 @@ (let* ((existing-gf (find-generic-function generic-function-name nil)) (generic-function (if existing-gf - (ensure-generic-function + (ensure-generic-function generic-function-name :generic-function-class (class-of existing-gf)) (ensure-generic-function generic-function-name))) diff --git a/src/pcl/slots.lisp b/src/pcl/slots.lisp index a37f983..1b1326b 100644 --- a/src/pcl/slots.lisp +++ b/src/pcl/slots.lisp @@ -136,9 +136,12 @@ (let ((class (class-of object))) (not (null (find-slot-definition class slot-name))))) +(defvar *unbound-slot-value-marker* (make-unprintable-object "unbound slot")) + ;;; This isn't documented, but is used within PCL in a number of print ;;; object methods. (See NAMED-OBJECT-PRINT-FUNCTION.) -(defun slot-value-or-default (object slot-name &optional (default "unbound")) +(defun slot-value-or-default (object slot-name &optional + (default *unbound-slot-value-marker*)) (if (slot-boundp object slot-name) (slot-value object slot-name) default)) diff --git a/tests/mop.impure.lisp b/tests/mop.impure.lisp index 765d222..f4c181d 100644 --- a/tests/mop.impure.lisp +++ b/tests/mop.impure.lisp @@ -515,7 +515,7 @@ ;;; ensure-class got its treatment of :metaclass wrong. (ensure-class 'better-be-standard-class :direct-superclasses '(standard-object) - :metaclass 'standard-class + :metaclass 'standard-class :metaclass 'funcallable-standard-class) (assert (eq (class-of (find-class 'better-be-standard-class)) (find-class 'standard-class))) diff --git a/version.lisp-expr b/version.lisp-expr index 6a171ab..6b2a62c 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; 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.9.15.45" +"0.9.15.46" -- 1.7.10.4