From ed7ba4dad8a79726fdfeba5aa12e276ea852c540 Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Sun, 13 Jan 2002 01:36:19 +0000 Subject: [PATCH] 0.pre7.126: even more s/#'(lambda/(lambda/ (should be done now) --- src/compiler/generic/genesis.lisp | 48 +++--- src/compiler/generic/interr.lisp | 4 +- src/compiler/generic/vm-macs.lisp | 24 +-- src/compiler/meta-vmdef.lisp | 58 ++++---- src/compiler/pack.lisp | 12 +- src/compiler/physenvanal.lisp | 4 +- src/compiler/srctran.lisp | 8 +- src/compiler/target-main.lisp | 8 +- src/compiler/typetran.lisp | 4 +- src/compiler/vmdef.lisp | 8 +- src/pcl/boot.lisp | 174 +++++++++++----------- src/pcl/braid.lisp | 32 ++-- src/pcl/cache.lisp | 22 +-- src/pcl/combin.lisp | 100 +++++++------ src/pcl/cpl.lisp | 30 ++-- src/pcl/defclass.lisp | 8 +- src/pcl/defcombin.lisp | 38 ++--- src/pcl/defs.lisp | 12 +- src/pcl/dfun.lisp | 248 +++++++++++++++---------------- src/pcl/dlisp.lisp | 64 ++++---- src/pcl/dlisp2.lisp | 70 ++++----- src/pcl/dlisp3.lisp | 4 +- src/pcl/env.lisp | 8 +- src/pcl/fast-init.lisp | 174 +++++++++++----------- src/pcl/fngen.lisp | 50 +++---- src/pcl/init.lisp | 12 +- src/pcl/methods.lisp | 296 ++++++++++++++++++------------------- src/pcl/slots-boot.lisp | 38 ++--- src/pcl/std-class.lisp | 94 ++++++------ src/pcl/time.lisp | 24 +-- src/pcl/vector.lisp | 128 ++++++++-------- src/pcl/walk.lisp | 36 ++--- tests/backq.impure.lisp | 4 +- tests/float.impure.lisp | 14 +- tests/seq.impure.lisp | 2 +- tests/walk.impure.lisp | 44 +++--- version.lisp-expr | 2 +- 37 files changed, 957 insertions(+), 949 deletions(-) diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index 0c575dc..5b8b0a7 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -1423,9 +1423,9 @@ (defun list-all-fdefn-objects () (let ((result *nil-descriptor*)) - (maphash #'(lambda (key value) - (declare (ignore key)) - (cold-push value result)) + (maphash (lambda (key value) + (declare (ignore key)) + (cold-push value result)) *cold-fdefn-objects*) result)) @@ -2561,8 +2561,8 @@ (maybe-record-with-translated-name '("-START" "-END") 6))))) (setf constants (sort constants - #'(lambda (const1 const2) - (if (= (second const1) (second const2)) + (lambda (const1 const2) + (if (= (second const1) (second const2)) (< (third const1) (third const2)) (< (second const1) (second const2)))))) (let ((prev-priority (second (car constants)))) @@ -2612,9 +2612,9 @@ ;; writing primitive object layouts (let ((structs (sort (copy-list sb!vm:*primitive-objects*) #'string< - :key #'(lambda (obj) - (symbol-name - (sb!vm:primitive-object-name obj)))))) + :key (lambda (obj) + (symbol-name + (sb!vm:primitive-object-name obj)))))) (format t "#ifndef LANGUAGE_ASSEMBLY~2%") (format t "#define LISPOBJ(x) ((lispobj)x)~2%") (dolist (obj structs) @@ -2651,8 +2651,8 @@ ;; in #define statements. (format t "#define ~A LISPOBJ(0x~X)~%" (nsubstitute #\_ #\- - (remove-if #'(lambda (char) - (member char '(#\% #\* #\. #\!))) + (remove-if (lambda (char) + (member char '(#\% #\* #\. #\!))) (symbol-name symbol))) (if *static* ; if we ran GENESIS ;; We actually ran GENESIS, use the real value. @@ -2681,16 +2681,16 @@ (format t "#X~8,'0X: ~S~%" (cdr routine) (car routine))) (let ((funs nil) (undefs nil)) - (maphash #'(lambda (name fdefn) - (let ((fun (read-wordindexed fdefn - sb!vm:fdefn-fun-slot))) - (if (= (descriptor-bits fun) - (descriptor-bits *nil-descriptor*)) - (push name undefs) - (let ((addr (read-wordindexed - fdefn sb!vm:fdefn-raw-addr-slot))) - (push (cons name (descriptor-bits addr)) - funs))))) + (maphash (lambda (name fdefn) + (let ((fun (read-wordindexed fdefn + sb!vm:fdefn-fun-slot))) + (if (= (descriptor-bits fun) + (descriptor-bits *nil-descriptor*)) + (push name undefs) + (let ((addr (read-wordindexed + fdefn sb!vm:fdefn-raw-addr-slot))) + (push (cons name (descriptor-bits addr)) + funs))))) *cold-fdefn-objects*) (format t "~%~|~%initially defined functions:~2%") (setf funs (sort funs #'< :key #'cdr)) @@ -2716,10 +2716,10 @@ initially undefined function references:~2%") (format t "~%~|~%layout names:~2%") (collect ((stuff)) - (maphash #'(lambda (name gorp) - (declare (ignore name)) - (stuff (cons (descriptor-bits (car gorp)) - (cdr gorp)))) + (maphash (lambda (name gorp) + (declare (ignore name)) + (stuff (cons (descriptor-bits (car gorp)) + (cdr gorp)))) *cold-layouts*) (dolist (x (sort (stuff) #'< :key #'car)) (apply #'format t "~8,'0X: ~S[~D]~%~10T~S~%" x)))) diff --git a/src/compiler/generic/interr.lisp b/src/compiler/generic/interr.lisp index b48d836..f1dfb33 100644 --- a/src/compiler/generic/interr.lisp +++ b/src/compiler/generic/interr.lisp @@ -24,8 +24,8 @@ ;;; functions as closures instead of DEFUNs? (eval-when (:compile-toplevel :execute) (def!macro define-internal-errors (&rest errors) - (let ((info (mapcar #'(lambda (x) - (if x + (let ((info (mapcar (lambda (x) + (if x (cons (symbolicate (first x) "-ERROR") (second x)) '(nil . "unused"))) diff --git a/src/compiler/generic/vm-macs.lisp b/src/compiler/generic/vm-macs.lisp index 6753edd..07dd18f 100644 --- a/src/compiler/generic/vm-macs.lisp +++ b/src/compiler/generic/vm-macs.lisp @@ -131,8 +131,8 @@ (defun %def-reffer (name offset lowtag) (let ((info (function-info-or-lose name))) (setf (function-info-ir2-convert info) - #'(lambda (node block) - (ir2-convert-reffer node block name offset lowtag)))) + (lambda (node block) + (ir2-convert-reffer node block name offset lowtag)))) name) (defmacro def-reffer (name offset lowtag) @@ -142,10 +142,10 @@ (let ((info (function-info-or-lose name))) (setf (function-info-ir2-convert info) (if (listp name) - #'(lambda (node block) - (ir2-convert-setfer node block name offset lowtag)) - #'(lambda (node block) - (ir2-convert-setter node block name offset lowtag))))) + (lambda (node block) + (ir2-convert-setfer node block name offset lowtag)) + (lambda (node block) + (ir2-convert-setter node block name offset lowtag))))) name) (defmacro def-setter (name offset lowtag) @@ -155,12 +155,12 @@ (let ((info (function-info-or-lose name))) (setf (function-info-ir2-convert info) (if var-length - #'(lambda (node block) - (ir2-convert-variable-allocation node block name words header - lowtag inits)) - #'(lambda (node block) - (ir2-convert-fixed-allocation node block name words header - lowtag inits))))) + (lambda (node block) + (ir2-convert-variable-allocation node block name words header + lowtag inits)) + (lambda (node block) + (ir2-convert-fixed-allocation node block name words header + lowtag inits))))) name) (defmacro def-alloc (name words var-length header lowtag inits) diff --git a/src/compiler/meta-vmdef.lisp b/src/compiler/meta-vmdef.lisp index 6600514..db70bbe 100644 --- a/src/compiler/meta-vmdef.lisp +++ b/src/compiler/meta-vmdef.lisp @@ -856,11 +856,11 @@ `(vop-temps ,n-vop)) ,@(when (vop-parse-info-args parse) `((,n-info (vop-codegen-info ,n-vop)) - ,@(mapcar #'(lambda (x) `(,x (pop ,n-info))) + ,@(mapcar (lambda (x) `(,x (pop ,n-info))) (vop-parse-info-args parse)))) ,@(when (vop-parse-variant-vars parse) `((,n-variant (vop-info-variant (vop-info ,n-vop))) - ,@(mapcar #'(lambda (x) `(,x (pop ,n-variant))) + ,@(mapcar (lambda (x) `(,x (pop ,n-variant))) (vop-parse-variant-vars parse)))) ,@(when (vop-parse-node-var parse) `((,(vop-parse-node-var parse) (vop-node ,n-vop)))) @@ -1304,9 +1304,9 @@ (type (or operand-parse null) more-op)) (unless (eq types :unspecified) (let ((num (+ (length ops) (if more-op 1 0)))) - (unless (= (count-if-not #'(lambda (x) - (and (consp x) - (eq (car x) :constant))) + (unless (= (count-if-not (lambda (x) + (and (consp x) + (eq (car x) :constant))) types) num) (error "expected ~W ~:[result~;argument~] type~P: ~S" @@ -1319,12 +1319,12 @@ (when (vop-parse-translate parse) (let ((types (specify-operand-types types ops more-op))) - (mapc #'(lambda (x y) - (check-operand-type-scs parse x y load-p)) + (mapc (lambda (x y) + (check-operand-type-scs parse x y load-p)) (if more-op (butlast ops) ops) - (remove-if #'(lambda (x) - (and (consp x) - (eq (car x) ':constant))) + (remove-if (lambda (x) + (and (consp x) + (eq (car x) ':constant))) (if more-op (butlast types) types))))) (values)) @@ -1366,16 +1366,16 @@ ;;; to the translated is always used in a predicate position. (defun set-up-function-translation (parse n-template) (declare (type vop-parse parse)) - (mapcar #'(lambda (name) - `(let ((info (function-info-or-lose ',name))) - (setf (function-info-templates info) - (adjoin-template ,n-template - (function-info-templates info))) - ,@(when (vop-parse-conditional-p parse) - '((setf (function-info-attributes info) - (attributes-union - (ir1-attributes predicate) - (function-info-attributes info))))))) + (mapcar (lambda (name) + `(let ((info (function-info-or-lose ',name))) + (setf (function-info-templates info) + (adjoin-template ,n-template + (function-info-templates info))) + ,@(when (vop-parse-conditional-p parse) + '((setf (function-info-attributes info) + (attributes-union + (ir1-attributes predicate) + (function-info-attributes info))))))) (vop-parse-translate parse))) ;;; Return a form that can be evaluated to get the TEMPLATE operand type @@ -1387,9 +1387,9 @@ (t (ecase (first type) (:or - ``(:or ,,@(mapcar #'(lambda (type) - `(primitive-type-or-lose ',type)) - (rest type)))) + ``(:or ,,@(mapcar (lambda (type) + `(primitive-type-or-lose ',type)) + (rest type)))) (:constant ``(:constant ,#'(lambda (x) (typep x ',(second type))) @@ -1468,7 +1468,7 @@ :name ',(vop-parse-name parse) ,@(make-vop-info-types parse) :guard ,(when (vop-parse-guard parse) - `#'(lambda () ,(vop-parse-guard parse))) + `(lambda () ,(vop-parse-guard parse))) :note ',(vop-parse-note parse) :info-arg-count ,(length (vop-parse-info-args parse)) :ltn-policy ',(vop-parse-ltn-policy parse) @@ -1856,9 +1856,9 @@ (error "T case is not last in SC-Case.")) (clauses `(t nil ,@(rest case))) (return)) - (clauses `((or ,@(mapcar #'(lambda (x) - `(eql ,(meta-sc-number-or-lose x) - ,n-sc)) + (clauses `((or ,@(mapcar (lambda (x) + `(eql ,(meta-sc-number-or-lose x) + ,n-sc)) (if (atom head) (list head) head))) nil ,@(rest case)))))) @@ -1869,8 +1869,8 @@ ;;; Return true if TNs SC is any of the named SCs, false otherwise. (defmacro sc-is (tn &rest scs) (once-only ((n-sc `(sc-number (tn-sc ,tn)))) - `(or ,@(mapcar #'(lambda (x) - `(eql ,n-sc ,(meta-sc-number-or-lose x))) + `(or ,@(mapcar (lambda (x) + `(eql ,n-sc ,(meta-sc-number-or-lose x))) scs)))) ;;; Iterate over the IR2 blocks in component, in emission order. diff --git a/src/compiler/pack.lisp b/src/compiler/pack.lisp index d7ae1ac..b89c5e1 100644 --- a/src/compiler/pack.lisp +++ b/src/compiler/pack.lisp @@ -318,7 +318,7 @@ tn (sc-name sc))) (t (aver (not (find :unbounded scs - :key #'(lambda (x) (sb-kind (sc-sb x)))))) + :key (lambda (x) (sb-kind (sc-sb x)))))) (let ((ptype (tn-primitive-type tn))) (cond (ptype @@ -1509,11 +1509,11 @@ (when *repack-blocks* (loop (when (zerop (hash-table-count *repack-blocks*)) (return)) - (maphash #'(lambda (block v) - (declare (ignore v)) - (remhash block *repack-blocks*) - (event repack-block) - (pack-load-tns block)) + (maphash (lambda (block v) + (declare (ignore v)) + (remhash block *repack-blocks*) + (event repack-block) + (pack-load-tns block)) *repack-blocks*))))) (values)) diff --git a/src/compiler/physenvanal.lisp b/src/compiler/physenvanal.lisp index bfe514f..c96bd44 100644 --- a/src/compiler/physenvanal.lisp +++ b/src/compiler/physenvanal.lisp @@ -290,8 +290,8 @@ (aver info) (close-over info (node-physenv exit) env) (when (eq (functional-kind exit-fun) :escape) - (mapc #'(lambda (x) - (setf (node-derived-type x) *wild-type*)) + (mapc (lambda (x) + (setf (node-derived-type x) *wild-type*)) (leaf-refs exit-fun)) (substitute-leaf (find-constant info) exit-fun) (let ((node (block-last (nlx-info-target info)))) diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index e7bae1b..bc2c80e 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -2298,8 +2298,8 @@ (defoptimizer (values derive-type) ((&rest values)) (values-specifier-type - `(values ,@(mapcar #'(lambda (x) - (type-specifier (continuation-type x))) + `(values ,@(mapcar (lambda (x) + (type-specifier (continuation-type x))) values)))) ;;;; byte operations @@ -3192,8 +3192,8 @@ (define-source-transform apply (fun arg &rest more-args) (let ((args (cons arg more-args))) `(multiple-value-call ,fun - ,@(mapcar #'(lambda (x) - `(values ,x)) + ,@(mapcar (lambda (x) + `(values ,x)) (butlast args)) (values-list ,(car (last args)))))) diff --git a/src/compiler/target-main.lisp b/src/compiler/target-main.lisp index f9b6c70..c650cbf 100644 --- a/src/compiler/target-main.lisp +++ b/src/compiler/target-main.lisp @@ -50,10 +50,10 @@ (*toplevel-lambdas* ()) (*block-compile* nil) (*compiler-error-bailout* - #'(lambda () - (compiler-mumble - "~2&fatal error, aborting compilation~%") - (return-from actually-compile (values nil t nil)))) + (lambda () + (compiler-mumble + "~2&fatal error, aborting compilation~%") + (return-from actually-compile (values nil t nil)))) (*current-path* nil) (*last-source-context* nil) (*last-original-source* nil) diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp index 03b4c0b..228bce0 100644 --- a/src/compiler/typetran.lisp +++ b/src/compiler/typetran.lisp @@ -271,8 +271,8 @@ (satisfies `(if (funcall #',(second spec) ,object) t nil)) ((not and) (once-only ((n-obj object)) - `(,(first spec) ,@(mapcar #'(lambda (x) - `(typep ,n-obj ',x)) + `(,(first spec) ,@(mapcar (lambda (x) + `(typep ,n-obj ',x)) (rest spec)))))))))) ;;; Do source transformation for TYPEP of a known union type. If a diff --git a/src/compiler/vmdef.lisp b/src/compiler/vmdef.lisp index 0d03768..c7fa197 100644 --- a/src/compiler/vmdef.lisp +++ b/src/compiler/vmdef.lisp @@ -203,10 +203,10 @@ (if (eq x '*) t (ecase (first x) - (:or `(or ,@(mapcar #'(lambda (type) - (type-specifier - (primitive-type-type - type))) + (:or `(or ,@(mapcar (lambda (type) + (type-specifier + (primitive-type-type + type))) (rest x)))) (:constant `(constant-argument ,(third x))))))) `(,@(mapcar #'frob types) diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 3761c09..f385fb5 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -341,16 +341,16 @@ bootstrapping. fn-lambda) (if (and (interned-symbol-p (fun-name-block-name name)) (every #'interned-symbol-p qualifiers) - (every #'(lambda (s) - (if (consp s) - (and (eq (car s) 'eql) - (constantp (cadr s)) - (let ((sv (eval (cadr s)))) - (or (interned-symbol-p sv) - (integerp sv) - (and (characterp sv) - (standard-char-p sv))))) - (interned-symbol-p s))) + (every (lambda (s) + (if (consp s) + (and (eq (car s) 'eql) + (constantp (cadr s)) + (let ((sv (eval (cadr s)))) + (or (interned-symbol-p sv) + (integerp sv) + (and (characterp sv) + (standard-char-p sv))))) + (interned-symbol-p s))) specializers) (consp initargs-form) (eq (car initargs-form) 'list*) @@ -387,11 +387,11 @@ bootstrapping. pv-table-symbol))) (make-defmethod-form-internal name qualifiers - `(list ,@(mapcar #'(lambda (specializer) - (if (consp specializer) - ``(,',(car specializer) - ,,(cadr specializer)) - `',specializer)) + `(list ,@(mapcar (lambda (specializer) + (if (consp specializer) + ``(,',(car specializer) + ,,(cadr specializer)) + `',specializer)) specializers)) unspecialized-lambda-list method-class-name initargs-form @@ -914,22 +914,22 @@ bootstrapping. (fast-method-call (let* ((arg-info (gf-arg-info gf)) (nreq (arg-info-number-required arg-info)) (restp (arg-info-applyp arg-info))) - #'(lambda (&rest args) - (trace-emf-call emf t args) - (apply (fast-method-call-function emf) - (fast-method-call-pv-cell emf) - (fast-method-call-next-method-call emf) - (if restp - (let* ((rest-args (nthcdr nreq args)) - (req-args (ldiff args - rest-args))) - (nconc req-args rest-args)) - args))))) - (method-call #'(lambda (&rest args) - (trace-emf-call emf t args) - (apply (method-call-function emf) - args - (method-call-call-method-args emf)))) + (lambda (&rest args) + (trace-emf-call emf t args) + (apply (fast-method-call-function emf) + (fast-method-call-pv-cell emf) + (fast-method-call-next-method-call emf) + (if restp + (let* ((rest-args (nthcdr nreq args)) + (req-args (ldiff args + rest-args))) + (nconc req-args rest-args)) + args))))) + (method-call (lambda (&rest args) + (trace-emf-call emf t args) + (apply (method-call-function emf) + args + (method-call-call-method-args emf)))) (function emf))) (defmacro bind-fast-lexical-method-macros ((args rest-arg next-method-call) @@ -1361,8 +1361,8 @@ bootstrapping. '(&rest t)) (when (or keysp old-keysp) (append '(&key) - (mapcar #'(lambda (key) - `(,key t)) + (mapcar (lambda (key) + `(,key t)) keywords) (when (or allow-other-keys-p old-allowp) '(&allow-other-keys))))) @@ -1401,13 +1401,13 @@ bootstrapping. 'standard-generic-function)) (defvar *sgf-slots-init* - (mapcar #'(lambda (canonical-slot) - (if (memq (getf canonical-slot :name) '(arg-info source)) - +slot-unbound+ - (let ((initfunction (getf canonical-slot :initfunction))) - (if initfunction - (funcall initfunction) - +slot-unbound+)))) + (mapcar (lambda (canonical-slot) + (if (memq (getf canonical-slot :name) '(arg-info source)) + +slot-unbound+ + (let ((initfunction (getf canonical-slot :initfunction))) + (if initfunction + (funcall initfunction) + +slot-unbound+)))) (early-collect-inheritance 'standard-generic-function))) (defvar *sgf-method-class-index* @@ -1466,7 +1466,7 @@ bootstrapping. (length (arg-info-metatypes arg-info))) (defun arg-info-nkeys (arg-info) - (count-if #'(lambda (x) (neq x t)) (arg-info-metatypes arg-info))) + (count-if (lambda (x) (neq x t)) (arg-info-metatypes arg-info))) ;;; Keep pages clean by not setting if the value is already the same. (defmacro esetf (pos val) @@ -1554,7 +1554,7 @@ bootstrapping. (when (consp gf-keywords) (unless (or (and restp (not keysp)) allow-other-keys-p - (every #'(lambda (k) (memq k keywords)) gf-keywords)) + (every (lambda (k) (memq k keywords)) gf-keywords)) (lose "the method does not accept each of the &KEY arguments~%~ ~S." gf-keywords))))))) @@ -1805,7 +1805,7 @@ bootstrapping. metatypes arg-info)) (values (length metatypes) applyp metatypes - (count-if #'(lambda (x) (neq x t)) metatypes) + (count-if (lambda (x) (neq x t)) metatypes) arg-info))) (defun early-make-a-method (class qualifiers arglist specializers initargs doc @@ -1821,10 +1821,10 @@ bootstrapping. ;; Note that the use of not symbolp in this call to every should be ;; read as 'classp' we can't use classp itself because it doesn't ;; exist yet. - (if (every #'(lambda (s) (not (symbolp s))) specializers) + (if (every (lambda (s) (not (symbolp s))) specializers) (setq parsed specializers - unparsed (mapcar #'(lambda (s) - (if (eq s t) t (class-name s))) + unparsed (mapcar (lambda (s) + (if (eq s t) t (class-name s))) specializers)) (setq unparsed specializers parsed ())) @@ -2008,13 +2008,13 @@ bootstrapping. (dolist (early-gf-spec *!early-generic-functions*) (/show early-gf-spec) (let* ((gf (gdefinition early-gf-spec)) - (methods (mapcar #'(lambda (early-method) - (let ((args (copy-list (fifth - early-method)))) - (setf (fourth args) - (early-method-specializers - early-method t)) - (apply #'real-make-a-method args))) + (methods (mapcar (lambda (early-method) + (let ((args (copy-list (fifth + early-method)))) + (setf (fourth args) + (early-method-specializers + early-method t)) + (apply #'real-make-a-method args))) (early-gf-methods gf)))) (setf (generic-function-method-class gf) *the-class-standard-method*) (setf (generic-function-method-combination gf) @@ -2029,27 +2029,27 @@ bootstrapping. (/show fixup) (let* ((fspec (car fixup)) (gf (gdefinition fspec)) - (methods (mapcar #'(lambda (method) - (let* ((lambda-list (first method)) - (specializers (second method)) - (method-fn-name (third method)) - (fn-name (or method-fn-name fspec)) - (fn (fdefinition fn-name)) - (initargs - (list :function - (set-fun-name - #'(lambda (args next-methods) - (declare (ignore - next-methods)) - (apply fn args)) - `(call ,fn-name))))) - (declare (type function fn)) - (make-a-method 'standard-method - () - lambda-list - specializers - initargs - nil))) + (methods (mapcar (lambda (method) + (let* ((lambda-list (first method)) + (specializers (second method)) + (method-fn-name (third method)) + (fn-name (or method-fn-name fspec)) + (fn (fdefinition fn-name)) + (initargs + (list :function + (set-fun-name + (lambda (args next-methods) + (declare (ignore + next-methods)) + (apply fn args)) + `(call ,fn-name))))) + (declare (type function fn)) + (make-a-method 'standard-method + () + lambda-list + specializers + initargs + nil))) (cdr fixup)))) (setf (generic-function-method-class gf) *the-class-standard-method*) (setf (generic-function-method-combination gf) @@ -2220,17 +2220,17 @@ bootstrapping. (and (symbolp instance) `((declare (%variable-rebinding ,in ,instance))))) ,in - (symbol-macrolet ,(mapcar #'(lambda (slot-entry) - (let ((var-name - (if (symbolp slot-entry) - slot-entry - (car slot-entry))) - (slot-name - (if (symbolp slot-entry) - slot-entry - (cadr slot-entry)))) - `(,var-name - (slot-value ,in ',slot-name)))) + (symbol-macrolet ,(mapcar (lambda (slot-entry) + (let ((var-name + (if (symbolp slot-entry) + slot-entry + (car slot-entry))) + (slot-name + (if (symbolp slot-entry) + slot-entry + (cadr slot-entry)))) + `(,var-name + (slot-value ,in ',slot-name)))) slots) ,@body)))) @@ -2244,9 +2244,9 @@ bootstrapping. (and (symbolp instance) `((declare (%variable-rebinding ,in ,instance))))) ,in - (symbol-macrolet ,(mapcar #'(lambda (slot-entry) + (symbol-macrolet ,(mapcar (lambda (slot-entry) (let ((var-name (car slot-entry)) (accessor-name (cadr slot-entry))) `(,var-name (,accessor-name ,in)))) - slots) + slots) ,@body)))) diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index e426863..de4c4b6 100644 --- a/src/pcl/braid.lisp +++ b/src/pcl/braid.lisp @@ -95,21 +95,21 @@ (defmacro !initial-classes-and-wrappers (&rest classes) `(progn - ,@(mapcar #'(lambda (class) - (let ((wr (intern (format nil "~A-WRAPPER" class) - *pcl-package*))) - `(setf ,wr ,(if (eq class 'standard-generic-function) - '*sgf-wrapper* - `(boot-make-wrapper - (early-class-size ',class) - ',class)) - ,class (allocate-standard-instance - ,(if (eq class 'standard-generic-function) - 'funcallable-standard-class-wrapper - 'standard-class-wrapper)) - (wrapper-class ,wr) ,class - (find-class ',class) ,class))) - classes))) + ,@(mapcar (lambda (class) + (let ((wr (intern (format nil "~A-WRAPPER" class) + *pcl-package*))) + `(setf ,wr ,(if (eq class 'standard-generic-function) + '*sgf-wrapper* + `(boot-make-wrapper + (early-class-size ',class) + ',class)) + ,class (allocate-standard-instance + ,(if (eq class 'standard-generic-function) + 'funcallable-standard-class-wrapper + 'standard-class-wrapper)) + (wrapper-class ,wr) ,class + (find-class ',class) ,class))) + classes))) (defun !bootstrap-meta-braid () (let* ((*create-classes-from-internal-structure-definitions-p* nil) @@ -511,7 +511,7 @@ (defvar *find-structure-class* nil) (defun eval-form (form) - #'(lambda () (eval form))) + (lambda () (eval form))) (defun slot-initargs-from-structure-slotd (slotd) `(:name ,(structure-slotd-name slotd) diff --git a/src/pcl/cache.lisp b/src/pcl/cache.lisp index 7fa0dd5..1f4af30 100644 --- a/src/pcl/cache.lisp +++ b/src/pcl/cache.lisp @@ -189,7 +189,7 @@ #+sb-show (defun show-free-cache-vectors () (let ((elements ())) - (maphash #'(lambda (s e) (push (list s e) elements)) *free-cache-vectors*) + (maphash (lambda (s e) (push (list s e) elements)) *free-cache-vectors*) (setq elements (sort elements #'< :key #'car)) (dolist (e elements) (let* ((size (car e)) @@ -735,8 +735,8 @@ (let* (,@(when wrappers `((,wrappers (nreverse wrappers-rev)) (,classes (nreverse classes-rev)) - (,types (mapcar #'(lambda (class) - `(class-eq ,class)) + (,types (mapcar (lambda (class) + `(class-eq ,class)) ,classes))))) ,@body)))) @@ -1018,12 +1018,12 @@ (defmacro with-local-cache-functions ((cache) &body body) `(let ((.cache. ,cache)) (declare (type cache .cache.)) - (macrolet ,(mapcar #'(lambda (fn) - `(,(car fn) ,(cadr fn) - `(let (,,@(mapcar #'(lambda (var) - ``(,',var ,,var)) - (cadr fn))) - ,@',(cddr fn)))) + (macrolet ,(mapcar (lambda (fn) + `(,(car fn) ,(cadr fn) + `(let (,,@(mapcar (lambda (var) + ``(,',var ,,var)) + (cadr fn))) + ,@',(cddr fn)))) *local-cache-functions*) ,@body))) @@ -1363,8 +1363,8 @@ (defun caches-to-allocate () (sort (let ((l nil)) - (maphash #'(lambda (size entry) - (push (list (car entry) size) l)) + (maphash (lambda (size entry) + (push (list (car entry) size) l)) sb-pcl::*free-caches*) l) #'> diff --git a/src/pcl/combin.lisp b/src/pcl/combin.lisp index 7674689..610011b 100644 --- a/src/pcl/combin.lisp +++ b/src/pcl/combin.lisp @@ -111,9 +111,13 @@ (null (cddr cm-args)))) (method (car cm-args)) (cm-args1 (cdr cm-args))) - #'(lambda (method-alist wrappers) - (make-effective-method-function-simple1 generic-function method cm-args1 fmf-p - method-alist wrappers)))) + (lambda (method-alist wrappers) + (make-effective-method-function-simple1 generic-function + method + cm-args1 + fmf-p + method-alist + wrappers)))) (defun make-emf-from-method (method cm-args &optional gf fmf-p method-alist wrappers) @@ -195,11 +199,11 @@ (t '.call-method.))) ((and (consp form) (eq (car form) 'call-method-list)) - (case (if (every #'(lambda (form) - (eq 'fast-method-call - (make-effective-method-fun-type - generic-function form - method-alist-p wrappers-p))) + (case (if (every (lambda (form) + (eq 'fast-method-call + (make-effective-method-fun-type + generic-function form + method-alist-p wrappers-p))) (cdr form)) 'fast-method-call t) @@ -220,11 +224,11 @@ (list gensym)))) ((and (consp form) (eq (car form) 'call-method-list)) (let ((gensym (get-effective-method-gensym)) - (type (if (every #'(lambda (form) - (eq 'fast-method-call - (make-effective-method-fun-type - generic-function form - method-alist-p wrappers-p))) + (type (if (every (lambda (form) + (eq 'fast-method-call + (make-effective-method-fun-type + generic-function form + method-alist-p wrappers-p))) (cdr form)) 'fast-method-call t))) @@ -241,9 +245,9 @@ generic-function form)))) ((and (consp form) (eq (car form) 'call-method-list)) (list (cons '.meth-list. - (mapcar #'(lambda (form) - (make-effective-method-function-simple - generic-function form)) + (mapcar (lambda (form) + (make-effective-method-function-simple + generic-function form)) (cdr form))))) (t (default-constant-converter form)))) @@ -263,44 +267,44 @@ generic-function effective-method))) (multiple-value-bind (cfunction constants) (get-function1 effective-method-lambda - #'(lambda (form) - (memf-test-converter form generic-function - method-alist-p wrappers-p)) - #'(lambda (form) - (memf-code-converter form generic-function - metatypes applyp - method-alist-p wrappers-p)) - #'(lambda (form) - (memf-constant-converter form generic-function))) - #'(lambda (method-alist wrappers) - (let* ((constants - (mapcar #'(lambda (constant) - (if (consp constant) - (case (car constant) - (.meth. - (funcall (cdr constant) - method-alist wrappers)) - (.meth-list. - (mapcar #'(lambda (fn) - (funcall fn - method-alist - wrappers)) - (cdr constant))) - (t constant)) - constant)) - constants)) - (function (set-fun-name - (apply cfunction constants) - `(combined-method ,name)))) - (make-fast-method-call :function function - :arg-info arg-info))))))) + (lambda (form) + (memf-test-converter form generic-function + method-alist-p wrappers-p)) + (lambda (form) + (memf-code-converter form generic-function + metatypes applyp + method-alist-p wrappers-p)) + (lambda (form) + (memf-constant-converter form generic-function))) + (lambda (method-alist wrappers) + (let* ((constants + (mapcar (lambda (constant) + (if (consp constant) + (case (car constant) + (.meth. + (funcall (cdr constant) + method-alist wrappers)) + (.meth-list. + (mapcar (lambda (fn) + (funcall fn + method-alist + wrappers)) + (cdr constant))) + (t constant)) + constant)) + constants)) + (function (set-fun-name + (apply cfunction constants) + `(combined-method ,name)))) + (make-fast-method-call :function function + :arg-info arg-info))))))) (defmacro call-method-list (&rest calls) `(progn ,@calls)) (defun make-call-methods (methods) `(call-method-list - ,@(mapcar #'(lambda (method) `(call-method ,method ())) methods))) + ,@(mapcar (lambda (method) `(call-method ,method ())) methods))) (defun standard-compute-effective-method (generic-function combin applicable-methods) (declare (ignore combin)) diff --git a/src/pcl/cpl.lisp b/src/pcl/cpl.lisp index e8c7b58..f834b1a 100644 --- a/src/pcl/cpl.lisp +++ b/src/pcl/cpl.lisp @@ -247,21 +247,21 @@ (format nil "named ~S" (class-name class)) class)))) (mapcar - #'(lambda (reason) - (ecase (caddr reason) - (:super - (format - nil - "The class ~A appears in the supers of the class ~A." - (class-or-name (cadr reason)) - (class-or-name (car reason)))) - (:in-supers - (format - nil - "The class ~A follows the class ~A in the supers of the class ~A." - (class-or-name (cadr reason)) - (class-or-name (car reason)) - (class-or-name (cadddr reason)))))) + (lambda (reason) + (ecase (caddr reason) + (:super + (format + nil + "The class ~A appears in the supers of the class ~A." + (class-or-name (cadr reason)) + (class-or-name (car reason)))) + (:in-supers + (format + nil + "The class ~A follows the class ~A in the supers of the class ~A." + (class-or-name (cadr reason)) + (class-or-name (car reason)) + (class-or-name (cadddr reason)))))) reasons))) (defun find-cycle-reasons (all-cpds) diff --git a/src/pcl/defclass.lisp b/src/pcl/defclass.lisp index 845edaf..ea26bbf 100644 --- a/src/pcl/defclass.lisp +++ b/src/pcl/defclass.lisp @@ -71,12 +71,12 @@ (*writers* ())) ;to have it to live nicely. (declare (special *initfunctions* *readers* *writers*)) (let ((canonical-slots - (mapcar #'(lambda (spec) - (canonicalize-slot-specification name spec)) + (mapcar (lambda (spec) + (canonicalize-slot-specification name spec)) slots)) (other-initargs - (mapcar #'(lambda (option) - (canonicalize-defclass-option name option)) + (mapcar (lambda (option) + (canonicalize-defclass-option name option)) options)) ;; DEFSTRUCT-P should be true, if the class is defined with a ;; metaclass STRUCTURE-CLASS, such that a DEFSTRUCT is compiled diff --git a/src/pcl/defcombin.lisp b/src/pcl/defcombin.lisp index 536d1ce..a0bebde 100644 --- a/src/pcl/defcombin.lisp +++ b/src/pcl/defcombin.lisp @@ -87,14 +87,14 @@ :qualifiers () :specializers specializers :lambda-list '(generic-function type options) - :function #'(lambda(args nms &rest cm-args) - (declare (ignore nms cm-args)) - (apply - #'(lambda (gf type options) - (declare (ignore gf)) - (do-short-method-combination - type options operator ioa new-method doc)) - args)) + :function (lambda (args nms &rest cm-args) + (declare (ignore nms cm-args)) + (apply + (lambda (gf type options) + (declare (ignore gf)) + (do-short-method-combination + type options operator ioa new-method doc)) + args)) :definition-source `((define-method-combination ,type) ,truename))) (when old-method (remove-method #'find-method-combination old-method)) @@ -153,7 +153,7 @@ (if (and (null (cdr primary)) (not (null ioa))) `(call-method ,(car primary) ()) - `(,operator ,@(mapcar #'(lambda (m) `(call-method ,m ())) + `(,operator ,@(mapcar (lambda (m) `(call-method ,m ())) primary))))) (cond ((null primary) `(error "No ~S methods for the generic function ~S." @@ -200,16 +200,16 @@ :qualifiers () :specializers specializers :lambda-list '(generic-function type options) - :function #'(lambda (args nms &rest cm-args) - (declare (ignore nms cm-args)) - (apply - #'(lambda (generic-function type options) - (declare (ignore generic-function options)) - (make-instance 'long-method-combination - :type type - :documentation doc)) - args)) - :definition-source `((define-method-combination ,type) + :function (lambda (args nms &rest cm-args) + (declare (ignore nms cm-args)) + (apply + (lambda (generic-function type options) + (declare (ignore generic-function options)) + (make-instance 'long-method-combination + :type type + :documentation doc)) + args)) + :definition-source `((define-method-combination ,type) ,*load-truename*)))) (setf (gethash type *long-method-combination-functions*) function) (when old-method (remove-method #'find-method-combination old-method)) diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp index e0ad9f7..4388d94 100644 --- a/src/pcl/defs.lisp +++ b/src/pcl/defs.lisp @@ -194,8 +194,8 @@ (defun make-type-predicate (name) (let ((cell (find-class-cell name))) - #'(lambda (x) - (funcall (the function (find-class-cell-predicate cell)) x)))) + (lambda (x) + (funcall (the function (find-class-cell-predicate cell)) x)))) (defun make-type-predicate-name (name &optional kind) (if (symbol-package name) @@ -327,7 +327,7 @@ (defmacro define-gf-predicate (predicate-name &rest classes) `(progn (defmethod ,predicate-name ((x t)) nil) - ,@(mapcar #'(lambda (c) `(defmethod ,predicate-name ((x ,c)) t)) + ,@(mapcar (lambda (c) `(defmethod ,predicate-name ((x ,c)) t)) classes))) (defun make-class-predicate-name (name) @@ -704,11 +704,11 @@ ()) (defclass effective-slot-definition (slot-definition) - ((reader-function ; #'(lambda (object) ...) + ((reader-function ; (lambda (object) ...) :accessor slot-definition-reader-function) - (writer-function ; #'(lambda (new-value object) ...) + (writer-function ; (lambda (new-value object) ...) :accessor slot-definition-writer-function) - (boundp-function ; #'(lambda (object) ...) + (boundp-function ; (lambda (object) ...) :accessor slot-definition-boundp-function) (accessor-flags :initform 0))) diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp index efded14..c133d4f 100644 --- a/src/pcl/dfun.lisp +++ b/src/pcl/dfun.lisp @@ -103,10 +103,10 @@ And so, we are saved. (when (and *raise-metatypes-to-class-p* (member generator '(emit-checking emit-caching emit-in-checking-cache-p emit-constant-value))) - (setq args (cons (mapcar #'(lambda (mt) - (if (eq mt t) - mt - 'class)) + (setq args (cons (mapcar (lambda (mt) + (if (eq mt t) + mt + 'class)) (car args)) (cdr args)))) (let* ((generator-entry (assq generator *dfun-constructors*)) @@ -380,7 +380,7 @@ And so, we are saved. (multiple-value-bind (nreq applyp metatypes nkeys) (get-generic-function-info generic-function) (declare (ignore nreq)) - (if (every #'(lambda (mt) (eq mt t)) metatypes) + (if (every (lambda (mt) (eq mt t)) metatypes) (let ((dfun-info (default-method-only-dfun-info))) (values (funcall (get-dfun-constructor 'emit-default-only metatypes applyp) @@ -401,9 +401,9 @@ And so, we are saved. (defun make-final-checking-dfun (generic-function function classes-list new-class) (let ((metatypes (arg-info-metatypes (gf-arg-info generic-function)))) - (if (every #'(lambda (mt) (eq mt t)) metatypes) - (values #'(lambda (&rest args) - (invoke-emf function args)) + (if (every (lambda (mt) (eq mt t)) metatypes) + (values (lambda (&rest args) + (invoke-emf function args)) nil (default-method-only-dfun-info)) (let ((cache (make-final-ordinary-dfun-internal generic-function nil #'checking-limit-fn @@ -414,7 +414,7 @@ And so, we are saved. (multiple-value-bind (nreq applyp metatypes nkeys) (get-generic-function-info generic-function) (declare (ignore nreq applyp nkeys)) - (every #'(lambda (mt) (eq mt t)) metatypes))) + (every (lambda (mt) (eq mt t)) metatypes))) (defun use-caching-dfun-p (generic-function) (some (lambda (method) @@ -488,19 +488,19 @@ And so, we are saved. (and (null applyp) (or (not (eq *boot-state* 'complete)) (compute-applicable-methods-emf-std-p gf)) - (notany #'(lambda (method) - (or (and (eq *boot-state* 'complete) - (some #'eql-specializer-p - (method-specializers method))) - (let ((value (method-function-get - (if early-p - (or (third method) (second method)) - (or (method-fast-function method) - (method-function method))) - :constant-value default))) - (if boolean-values-p - (not (or (eq value t) (eq value nil))) - (eq value default))))) + (notany (lambda (method) + (or (and (eq *boot-state* 'complete) + (some #'eql-specializer-p + (method-specializers method))) + (let ((value (method-function-get + (if early-p + (or (third method) (second method)) + (or (method-fast-function method) + (method-function method))) + :constant-value default))) + (if boolean-values-p + (not (or (eq value t) (eq value nil))) + (eq value default))))) methods))))) (defun make-constant-value-dfun (generic-function &optional cache) @@ -550,27 +550,27 @@ And so, we are saved. (defun dispatch-dfun-cost (gf &optional limit) (generate-discrimination-net-internal gf (generic-function-methods gf) nil - #'(lambda (methods known-types) - (declare (ignore methods known-types)) - 0) - #'(lambda (position type true-value false-value) - (declare (ignore position)) - (let* ((type-test-cost - (if (eq 'class (car type)) - (let* ((metaclass (class-of (cadr type))) - (mcpl (class-precedence-list metaclass))) - (cond ((memq *the-class-built-in-class* mcpl) - *built-in-typep-cost*) - ((memq *the-class-structure-class* mcpl) - *structure-typep-cost*) - (t - *non-built-in-typep-cost*))) - 0)) - (max-cost-so-far - (+ (max true-value false-value) type-test-cost))) - (when (and limit (<= limit max-cost-so-far)) - (return-from dispatch-dfun-cost max-cost-so-far)) - max-cost-so-far)) + (lambda (methods known-types) + (declare (ignore methods known-types)) + 0) + (lambda (position type true-value false-value) + (declare (ignore position)) + (let* ((type-test-cost + (if (eq 'class (car type)) + (let* ((metaclass (class-of (cadr type))) + (mcpl (class-precedence-list metaclass))) + (cond ((memq *the-class-built-in-class* mcpl) + *built-in-typep-cost*) + ((memq *the-class-structure-class* mcpl) + *structure-typep-cost*) + (t + *non-built-in-typep-cost*))) + 0)) + (max-cost-so-far + (+ (max true-value false-value) type-test-cost))) + (when (and limit (<= limit max-cost-so-far)) + (return-from dispatch-dfun-cost max-cost-so-far)) + max-cost-so-far)) #'identity)) (defparameter *cache-lookup-cost* 1) @@ -613,11 +613,11 @@ And so, we are saved. (defun fill-dfun-cache (table valuep nkeys limit-fn &optional cache) (let ((cache (or cache (get-cache nkeys valuep limit-fn (+ (hash-table-count table) 3))))) - (maphash #'(lambda (classes value) - (setq cache (fill-cache cache - (class-wrapper classes) - value - t))) + (maphash (lambda (classes value) + (setq cache (fill-cache cache + (class-wrapper classes) + value + t))) table) cache)) @@ -753,18 +753,18 @@ And so, we are saved. (let ((methods (if (early-gf-p gf) (early-gf-methods gf) (generic-function-methods gf)))) - (cond ((every #'(lambda (method) - (if (consp method) - (eq *the-class-standard-reader-method* - (early-method-class method)) - (standard-reader-method-p method))) + (cond ((every (lambda (method) + (if (consp method) + (eq *the-class-standard-reader-method* + (early-method-class method)) + (standard-reader-method-p method))) methods) 'reader) - ((every #'(lambda (method) - (if (consp method) - (eq *the-class-standard-writer-method* - (early-method-class method)) - (standard-writer-method-p method))) + ((every (lambda (method) + (if (consp method) + (eq *the-class-standard-writer-method* + (early-method-class method)) + (standard-writer-method-p method))) methods) 'writer)))) @@ -801,14 +801,14 @@ And so, we are saved. (no-methods-dfun-info))) ((setq type (final-accessor-dfun-type gf)) (make-final-accessor-dfun gf type classes-list new-class)) - ((and (not (and (every #'(lambda (specl) (eq specl *the-class-t*)) + ((and (not (and (every (lambda (specl) (eq specl *the-class-t*)) (setq specls (method-specializers (car methods)))) (setq all-same-p - (every #'(lambda (method) - (and (equal specls - (method-specializers - method)))) + (every (lambda (method) + (and (equal specls + (method-specializers + method)))) methods)))) (use-constant-value-dfun-p gf)) (make-final-constant-value-dfun gf classes-list new-class)) @@ -888,8 +888,8 @@ And so, we are saved. (setq oindex (dfun-info-index dfun-info)) (setq cache (dfun-info-cache dfun-info)) (if (eql nindex oindex) - (do-fill #'(lambda (ncache) - (one-index nindex ncache))) + (do-fill (lambda (ncache) + (one-index nindex ncache))) (n-n))) (n-n (setq cache (dfun-info-cache dfun-info)) @@ -1088,39 +1088,39 @@ And so, we are saved. (when (or (null specl-cpl) (member *the-class-structure-object* specl-cpl)) (return-from make-accessor-table nil)) - (maphash #'(lambda (class slotd) - (let ((cpl (if early-p - (early-class-precedence-list class) - (class-precedence-list class)))) - (when (memq specl cpl) - (unless (and (or so-p - (member *the-class-std-object* cpl)) - (or early-p - (slot-accessor-std-p slotd type))) - (return-from make-accessor-table nil)) - (push (cons specl slotd) (gethash class table))))) + (maphash (lambda (class slotd) + (let ((cpl (if early-p + (early-class-precedence-list class) + (class-precedence-list class)))) + (when (memq specl cpl) + (unless (and (or so-p + (member *the-class-std-object* cpl)) + (or early-p + (slot-accessor-std-p slotd type))) + (return-from make-accessor-table nil)) + (push (cons specl slotd) (gethash class table))))) (gethash slot-name *name->class->slotd-table*)))) - (maphash #'(lambda (class specl+slotd-list) - (dolist (sclass (if early-p - (early-class-precedence-list class) - (class-precedence-list class)) - (error "This can't happen.")) - (let ((a (assq sclass specl+slotd-list))) - (when a - (let* ((slotd (cdr a)) - (index (if early-p - (early-slot-definition-location slotd) - (slot-definition-location slotd)))) - (unless index (return-from make-accessor-table nil)) - (setf (gethash class table) index) - (when (consp index) (setq no-class-slots-p nil)) - (setq all-index (if (or (null all-index) - (eql all-index index)) - index t)) - (incf size) - (cond ((= size 1) (setq first class)) - ((= size 2) (setq second class))) - (return nil)))))) + (maphash (lambda (class specl+slotd-list) + (dolist (sclass (if early-p + (early-class-precedence-list class) + (class-precedence-list class)) + (error "This can't happen.")) + (let ((a (assq sclass specl+slotd-list))) + (when a + (let* ((slotd (cdr a)) + (index (if early-p + (early-slot-definition-location slotd) + (slot-definition-location slotd)))) + (unless index (return-from make-accessor-table nil)) + (setf (gethash class table) index) + (when (consp index) (setq no-class-slots-p nil)) + (setq all-index (if (or (null all-index) + (eql all-index index)) + index t)) + (incf size) + (cond ((= size 1) (setq first class)) + ((= size 2) (setq second class))) + (return nil)))))) table) (values table all-index first second size no-class-slots-p))) @@ -1158,13 +1158,13 @@ And so, we are saved. (defun sort-applicable-methods (precedence methods types) (sort-methods methods precedence - #'(lambda (class1 class2 index) - (let* ((class (type-class (nth index types))) - (cpl (if (eq *boot-state* 'complete) - (class-precedence-list class) - (early-class-precedence-list class)))) - (if (memq class2 (memq class1 cpl)) - class1 class2))))) + (lambda (class1 class2 index) + (let* ((class (type-class (nth index types))) + (cpl (if (eq *boot-state* 'complete) + (class-precedence-list class) + (early-class-precedence-list class)))) + (if (memq class2 (memq class1 cpl)) + class1 class2))))) (defun sort-methods (methods precedence compare-classes-function) (flet ((sorter (method1 method2) @@ -1435,14 +1435,14 @@ And so, we are saved. function-p) (if (null methods) (if function-p - #'(lambda (method-alist wrappers) - (declare (ignore method-alist wrappers)) - #'(sb-kernel:instance-lambda (&rest args) - (apply #'no-applicable-method gf args))) - #'(lambda (method-alist wrappers) - (declare (ignore method-alist wrappers)) - #'(lambda (&rest args) - (apply #'no-applicable-method gf args)))) + (lambda (method-alist wrappers) + (declare (ignore method-alist wrappers)) + #'(sb-kernel:instance-lambda (&rest args) + (apply #'no-applicable-method gf args))) + (lambda (method-alist wrappers) + (declare (ignore method-alist wrappers)) + (lambda (&rest args) + (apply #'no-applicable-method gf args)))) (let* ((key (car methods)) (ht-value (or (gethash key *effective-method-table*) (setf (gethash key *effective-method-table*) @@ -1569,19 +1569,19 @@ And so, we are saved. (incf (cdr b)))))) (defun count-all-dfuns () - (setq *dfun-count* (mapcar #'(lambda (type) (list type 0 nil)) + (setq *dfun-count* (mapcar (lambda (type) (list type 0 nil)) '(ONE-CLASS TWO-CLASS DEFAULT-METHOD-ONLY ONE-INDEX N-N CHECKING CACHING DISPATCH))) (map-all-generic-functions #'count-dfun) - (mapc #'(lambda (type+count+sizes) - (setf (third type+count+sizes) - (sort (third type+count+sizes) #'< :key #'car))) + (mapc (lambda (type+count+sizes) + (setf (third type+count+sizes) + (sort (third type+count+sizes) #'< :key #'car))) *dfun-count*) - (mapc #'(lambda (type+count+sizes) - (format t "~&There are ~W dfuns of type ~S." - (cadr type+count+sizes) (car type+count+sizes)) - (format t "~% ~S~%" (caddr type+count+sizes))) + (mapc (lambda (type+count+sizes) + (format t "~&There are ~W dfuns of type ~S." + (cadr type+count+sizes) (car type+count+sizes)) + (format t "~% ~S~%" (caddr type+count+sizes))) *dfun-count*) (values)) |# @@ -1589,8 +1589,8 @@ And so, we are saved. (defun gfs-of-type (type) (unless (consp type) (setq type (list type))) (let ((gf-list nil)) - (map-all-generic-functions #'(lambda (gf) - (when (memq (type-of (gf-dfun-info gf)) - type) - (push gf gf-list)))) + (map-all-generic-functions (lambda (gf) + (when (memq (type-of (gf-dfun-info gf)) + type) + (push gf gf-list)))) gf-list)) diff --git a/src/pcl/dlisp.lisp b/src/pcl/dlisp.lisp index a8400de..2639eb6 100644 --- a/src/pcl/dlisp.lisp +++ b/src/pcl/dlisp.lisp @@ -253,15 +253,15 @@ (defun emit-dlap (args metatypes hit miss value-reg &optional slot-regs) (let* ((index -1) - (wrapper-bindings (mapcan #'(lambda (arg mt) - (unless (eq mt t) - (incf index) - `((,(intern (format nil - "WRAPPER-~D" - index) - *pcl-package*) - ,(emit-fetch-wrapper mt arg 'miss - (pop slot-regs)))))) + (wrapper-bindings (mapcan (lambda (arg mt) + (unless (eq mt t) + (incf index) + `((,(intern (format nil + "WRAPPER-~D" + index) + *pcl-package*) + ,(emit-fetch-wrapper + mt arg 'miss (pop slot-regs)))))) args metatypes)) (wrappers (mapcar #'car wrapper-bindings))) (declare (fixnum index)) @@ -341,13 +341,15 @@ (let ((location primary) (next-location 0)) (declare (fixnum location next-location)) (block search - (loop (setq next-location (the fixnum (+ location ,cache-line-size))) + (loop (setq next-location + (the fixnum (+ location ,cache-line-size))) (when (and ,@(mapcar - #'(lambda (wrapper) - `(eq ,wrapper - (cache-vector-ref cache-vector - (setq location - (the fixnum (+ location 1)))))) + (lambda (wrapper) + `(eq ,wrapper + (cache-vector-ref + cache-vector + (setq location + (the fixnum (+ location 1)))))) wrappers)) ,@(when value `((setq location (the fixnum (+ location 1))) @@ -359,8 +361,9 @@ (when (= location primary) (dolist (entry overflow) (let ((entry-wrappers (car entry))) - (when (and ,@(mapcar #'(lambda (wrapper) - `(eq ,wrapper (pop entry-wrappers))) + (when (and ,@(mapcar (lambda (wrapper) + `(eq ,wrapper + (pop entry-wrappers))) wrappers)) ,@(when value `((setq ,value (cdr entry)))) @@ -383,19 +386,20 @@ `(progn ,@(let ((adds 0) (len (length wrappers))) (declare (fixnum adds len)) - (mapcar #'(lambda (wrapper) - `(let ((wrapper-cache-no (wrapper-cache-number-vector-ref - ,wrapper field))) - (declare (fixnum wrapper-cache-no)) - (when (zerop wrapper-cache-no) (go ,miss-label)) - (setq primary (the fixnum (+ primary wrapper-cache-no))) - ,@(progn - (incf adds) - (when (or (zerop (mod adds wrapper-cache-number-adds-ok)) - (eql adds len)) - `((setq primary - ,(let ((form `(logand primary mask))) - `(the fixnum ,form)))))))) + (mapcar (lambda (wrapper) + `(let ((wrapper-cache-no (wrapper-cache-number-vector-ref + ,wrapper field))) + (declare (fixnum wrapper-cache-no)) + (when (zerop wrapper-cache-no) (go ,miss-label)) + (setq primary (the fixnum (+ primary wrapper-cache-no))) + ,@(progn + (incf adds) + (when (or (zerop (mod adds + wrapper-cache-number-adds-ok)) + (eql adds len)) + `((setq primary + ,(let ((form `(logand primary mask))) + `(the fixnum ,form)))))))) wrappers)))) ;;; CMU17 (and SBCL) note: Since STD-INSTANCE-P is weakened in the CMU/SBCL diff --git a/src/pcl/dlisp2.lisp b/src/pcl/dlisp2.lisp index 43f33ba..b192fe6 100644 --- a/src/pcl/dlisp2.lisp +++ b/src/pcl/dlisp2.lisp @@ -85,42 +85,42 @@ (cached-emf-p return-value-p metatypes applyp) (declare (ignore applyp)) (if cached-emf-p - #'(lambda (cache miss-fn) - (declare (type function miss-fn)) - #'(sb-kernel:instance-lambda (&rest args) - (declare #.*optimize-speed*) - (with-dfun-wrappers (args metatypes) - (dfun-wrappers invalid-wrapper-p) - (apply miss-fn args) - (if invalid-wrapper-p - (apply miss-fn args) - (let ((emf (probe-cache cache dfun-wrappers *not-in-cache*))) - (if (eq emf *not-in-cache*) - (apply miss-fn args) - (if return-value-p - emf - (invoke-emf emf args)))))))) - #'(lambda (cache emf miss-fn) - (declare (type function miss-fn)) - #'(sb-kernel:instance-lambda (&rest args) - (declare #.*optimize-speed*) - (with-dfun-wrappers (args metatypes) - (dfun-wrappers invalid-wrapper-p) - (apply miss-fn args) - (if invalid-wrapper-p - (apply miss-fn args) - (let ((found-p (not (eq *not-in-cache* - (probe-cache cache dfun-wrappers - *not-in-cache*))))) - (if found-p - (invoke-emf emf args) - (if return-value-p - t - (apply miss-fn args)))))))))) + (lambda (cache miss-fn) + (declare (type function miss-fn)) + #'(sb-kernel:instance-lambda (&rest args) + (declare #.*optimize-speed*) + (with-dfun-wrappers (args metatypes) + (dfun-wrappers invalid-wrapper-p) + (apply miss-fn args) + (if invalid-wrapper-p + (apply miss-fn args) + (let ((emf (probe-cache cache dfun-wrappers *not-in-cache*))) + (if (eq emf *not-in-cache*) + (apply miss-fn args) + (if return-value-p + emf + (invoke-emf emf args)))))))) + (lambda (cache emf miss-fn) + (declare (type function miss-fn)) + #'(sb-kernel:instance-lambda (&rest args) + (declare #.*optimize-speed*) + (with-dfun-wrappers (args metatypes) + (dfun-wrappers invalid-wrapper-p) + (apply miss-fn args) + (if invalid-wrapper-p + (apply miss-fn args) + (let ((found-p (not (eq *not-in-cache* + (probe-cache cache dfun-wrappers + *not-in-cache*))))) + (if found-p + (invoke-emf emf args) + (if return-value-p + t + (apply miss-fn args)))))))))) (defun emit-default-only-function (metatypes applyp) (declare (ignore metatypes applyp)) - (values #'(lambda (emf) - #'(lambda (&rest args) - (invoke-emf emf args))) + (values (lambda (emf) + (lambda (&rest args) + (invoke-emf emf args))) t)) diff --git a/src/pcl/dlisp3.lisp b/src/pcl/dlisp3.lisp index d5fa046..c3209ac 100644 --- a/src/pcl/dlisp3.lisp +++ b/src/pcl/dlisp3.lisp @@ -60,8 +60,8 @@ ) ; EVAL-WHEN (defmacro make-checking-or-caching-function-list () - `(list ,@(mapcar #'(lambda (key) - `(cons ',key (emit-checking-or-caching-macro ,@key))) + `(list ,@(mapcar (lambda (key) + `(cons ',key (emit-checking-or-caching-macro ,@key))) *checking-or-caching-list*))) ;;; Rather than compiling the constructors here, just tickle the range diff --git a/src/pcl/env.lisp b/src/pcl/env.lisp index becccfa..bf41126 100644 --- a/src/pcl/env.lisp +++ b/src/pcl/env.lisp @@ -147,10 +147,10 @@ (macrolet ((frob (&rest names) `(progn - ,@(mapcar #'(lambda (name) - `(defmethod ,name ((class cl:class)) - (funcall #',name - (coerce-to-pcl-class class)))) + ,@(mapcar (lambda (name) + `(defmethod ,name ((class cl:class)) + (funcall #',name + (coerce-to-pcl-class class)))) names)))) (frob class-direct-slots diff --git a/src/pcl/fast-init.lisp b/src/pcl/fast-init.lisp index 2d723e1..8f21ad6 100644 --- a/src/pcl/fast-init.lisp +++ b/src/pcl/fast-init.lisp @@ -84,15 +84,15 @@ (defmacro expanding-make-instance (&rest forms &environment env) `(progn - ,@(mapcar #'(lambda (form) - (walk-form form env - #'(lambda (subform context env) - (declare (ignore env)) - (or (and (eq context ':eval) - (consp subform) - (eq (car subform) 'make-instance) - (expand-make-instance-form subform)) - subform)))) + ,@(mapcar (lambda (form) + (walk-form form env + (lambda (subform context env) + (declare (ignore env)) + (or (and (eq context ':eval) + (consp subform) + (eq (car subform) 'make-instance) + (expand-make-instance-form subform)) + subform)))) forms))) (defun get-make-instance-functions (key-list) @@ -163,35 +163,35 @@ (defmacro define-initialize-info () (let ((cached-slot-names - (mapcar #'(lambda (name) - (intern (format nil "CACHED-~A" name))) + (mapcar (lambda (name) + (intern (format nil "CACHED-~A" name))) *initialize-info-cached-slots*)) (cached-names - (mapcar #'(lambda (name) - (intern (format nil "~A-CACHED-~A" - 'initialize-info name))) + (mapcar (lambda (name) + (intern (format nil "~A-CACHED-~A" + 'initialize-info name))) *initialize-info-cached-slots*))) `(progn (defstruct (initialize-info (:copier nil)) key wrapper - ,@(mapcar #'(lambda (name) - `(,name :unknown)) + ,@(mapcar (lambda (name) + `(,name :unknown)) cached-slot-names)) (defmacro reset-initialize-info-internal (info) `(progn - ,@(mapcar #'(lambda (cname) - `(setf (,cname ,info) ':unknown)) + ,@(mapcar (lambda (cname) + `(setf (,cname ,info) ':unknown)) ',cached-names))) (defun initialize-info-bound-slots (info) (let ((slots nil)) - ,@(mapcar #'(lambda (name cached-name) - `(unless (eq ':unknown (,cached-name info)) - (push ',name slots))) + ,@(mapcar (lambda (name cached-name) + `(unless (eq ':unknown (,cached-name info)) + (push ',name slots))) *initialize-info-cached-slots* cached-names) slots)) - ,@(mapcar #'(lambda (name) - `(define-cached-reader initialize-info ,name - update-initialize-info-internal)) + ,@(mapcar (lambda (name) + `(define-cached-reader initialize-info ,name + update-initialize-info-internal)) *initialize-info-cached-slots*)))) (define-initialize-info) @@ -356,7 +356,7 @@ (setq class (find-class class))) (when (classp class) (unless (class-finalized-p class) (finalize-inheritance class))) - (let* ((initargs (mapcan #'(lambda (key) (list key nil)) keys)) + (let* ((initargs (mapcan (lambda (key) (list key nil)) keys)) (class-and-initargs (list* class initargs)) (make-instance (gdefinition 'make-instance)) (make-instance-methods @@ -377,8 +377,8 @@ (list* proto t initargs))))) (when (null make-instance-methods) (return-from get-make-instance-function - #'(lambda (class initargs) - (apply #'no-applicable-method make-instance class initargs)))) + (lambda (class initargs) + (apply #'no-applicable-method make-instance class initargs)))) (unless (and (null (cdr make-instance-methods)) (eq (car make-instance-methods) std-mi-meth) (null (cdr default-initargs-methods)) @@ -473,36 +473,36 @@ (std-si-meth (find-standard-ii-method shared-initialize-methods 'slot-object)) (shared-initfns - (nreverse (mapcar #'(lambda (method) - (make-effective-method-function - #'shared-initialize - `(call-method ,method nil) - nil lwrapper)) + (nreverse (mapcar (lambda (method) + (make-effective-method-function + #'shared-initialize + `(call-method ,method nil) + nil lwrapper)) (remove std-si-meth shared-initialize-methods)))) (std-ii-meth (find-standard-ii-method initialize-instance-methods 'slot-object)) (initialize-initfns - (nreverse (mapcar #'(lambda (method) - (make-effective-method-function - #'initialize-instance - `(call-method ,method nil) - nil lwrapper)) + (nreverse (mapcar (lambda (method) + (make-effective-method-function + #'initialize-instance + `(call-method ,method nil) + nil lwrapper)) (remove std-ii-meth initialize-instance-methods))))) - #'(lambda (class1 initargs) - (if (not (eq wrapper (class-wrapper class))) - (let* ((info (initialize-info class1 initargs)) - (fn (initialize-info-make-instance-function info))) - (declare (type function fn)) - (funcall fn class1 initargs)) - (let* ((instance (funcall allocate-function wrapper constants)) - (initargs (call-initialize-function initialize-function - instance initargs))) - (dolist (fn shared-initfns) - (invoke-effective-method-function fn t instance t initargs)) - (dolist (fn initialize-initfns) - (invoke-effective-method-function fn t instance initargs)) - instance)))))) + (lambda (class1 initargs) + (if (not (eq wrapper (class-wrapper class))) + (let* ((info (initialize-info class1 initargs)) + (fn (initialize-info-make-instance-function info))) + (declare (type function fn)) + (funcall fn class1 initargs)) + (let* ((instance (funcall allocate-function wrapper constants)) + (initargs (call-initialize-function initialize-function + instance initargs))) + (dolist (fn shared-initfns) + (invoke-effective-method-function fn t instance t initargs)) + (dolist (fn initialize-initfns) + (invoke-effective-method-function fn t instance initargs)) + instance)))))) (defun make-instance-function-complex (key class keys initialize-instance-methods @@ -516,11 +516,11 @@ `((class-eq ,class) t t) `((,(find-standard-ii-method shared-initialize-methods 'slot-object) - ,#'(lambda (instance init-type &rest initargs) - (declare (ignore init-type)) - (call-initialize-function initialize-function - instance initargs) - instance))) + ,(lambda (instance init-type &rest initargs) + (declare (ignore init-type)) + (call-initialize-function initialize-function + instance initargs) + instance))) (list wrapper *the-wrapper-of-t* *the-wrapper-of-t*))) (initialize-instance (get-secondary-dispatch-function @@ -528,22 +528,22 @@ `((class-eq ,class) t) `((,(find-standard-ii-method initialize-instance-methods 'slot-object) - ,#'(lambda (instance &rest initargs) - (invoke-effective-method-function - shared-initialize t instance t initargs)))) + ,(lambda (instance &rest initargs) + (invoke-effective-method-function + shared-initialize t instance t initargs)))) (list wrapper *the-wrapper-of-t*)))) - #'(lambda (class1 initargs) - (if (not (eq wrapper (class-wrapper class))) - (let* ((info (initialize-info class1 initargs)) - (fn (initialize-info-make-instance-function info))) - (declare (type function fn)) - (funcall fn class1 initargs)) - (let* ((initargs (call-initialize-function initargs-function - nil initargs)) - (instance (apply #'allocate-instance class initargs))) - (invoke-effective-method-function - initialize-instance t instance initargs) - instance)))))) + (lambda (class1 initargs) + (if (not (eq wrapper (class-wrapper class))) + (let* ((info (initialize-info class1 initargs)) + (fn (initialize-info-make-instance-function info))) + (declare (type function fn)) + (funcall fn class1 initargs)) + (let* ((initargs (call-initialize-function initargs-function + nil initargs)) + (instance (apply #'allocate-instance class initargs))) + (invoke-effective-method-function + initialize-instance t instance initargs) + instance)))))) (defun get-simple-initialization-function (class keys @@ -582,10 +582,10 @@ (default-initargs (class-default-initargs class)) (nkeys keys) (slots-alist - (mapcan #'(lambda (slot) - (mapcar #'(lambda (arg) - (cons arg slot)) - (slot-definition-initargs slot))) + (mapcan (lambda (slot) + (mapcar (lambda (arg) + (cons arg slot)) + (slot-definition-initargs slot))) (class-slots class))) (nslots nil)) (dolist (key nkeys) @@ -622,12 +622,12 @@ ':initial-element +slot-unbound+))) (slots (class-slots class)) (slot-names (mapcar #'slot-definition-name slots)) - (slots-key (mapcar #'(lambda (slot) - (let ((index most-positive-fixnum)) - (dolist (key (slot-definition-initargs slot)) - (let ((pos (position key keys))) - (when pos (setq index (min index pos))))) - (cons slot index))) + (slots-key (mapcar (lambda (slot) + (let ((index most-positive-fixnum)) + (dolist (key (slot-definition-initargs slot)) + (let ((pos (position key keys))) + (when pos (setq index (min index pos))))) + (cons slot index))) slots)) (slots (stable-sort slots-key #'< :key #'cdr))) (let ((n-popped 0)) @@ -718,8 +718,8 @@ (apply (the function (cadr entry)) args) `(call-initialize-instance-simple ,pv-cell ,form-list)))) #|| - #'(lambda (instance initargs) - (initialize-instance-simple pv-cell form-list instance initargs)) + (lambda (instance initargs) + (initialize-instance-simple pv-cell form-list instance initargs)) ||# `(call-initialize-instance-simple ,pv-cell ,form-list)))) @@ -916,10 +916,10 @@ (values `(lambda (pv-cell cvector) (declare (type ,cvector-type cvector)) - #'(lambda (instance initargs) - (declare #.*optimize-speed*) - (iis-body ,@body) - initargs)) + (lambda (instance initargs) + (declare #.*optimize-speed*) + (iis-body ,@body) + initargs)) (list pv-cell (coerce cvector cvector-type))))) ;;; The effect of this is to cause almost all of the overhead of diff --git a/src/pcl/fngen.lisp b/src/pcl/fngen.lisp index 3631cb5..aec5b59 100644 --- a/src/pcl/fngen.lisp +++ b/src/pcl/fngen.lisp @@ -132,43 +132,43 @@ (let ((*walk-form-expand-macros-p* t)) (walk-form lambda nil - #'(lambda (f c e) - (declare (ignore e)) - (if (neq c :eval) - f - (let ((converted (funcall test-converter f))) - (values converted (neq converted f)))))))) + (lambda (f c e) + (declare (ignore e)) + (if (neq c :eval) + f + (let ((converted (funcall test-converter f))) + (values converted (neq converted f)))))))) (defun compute-code (lambda code-converter) (let ((*walk-form-expand-macros-p* t) (gensyms ())) (values (walk-form lambda nil - #'(lambda (f c e) - (declare (ignore e)) - (if (neq c :eval) - f - (multiple-value-bind (converted gens) - (funcall code-converter f) - (when gens (setq gensyms (append gensyms gens))) - (values converted (neq converted f)))))) - gensyms))) + (lambda (f c e) + (declare (ignore e)) + (if (neq c :eval) + f + (multiple-value-bind (converted gens) + (funcall code-converter f) + (when gens (setq gensyms (append gensyms gens))) + (values converted (neq converted f)))))) + gensyms))) (defun compute-constants (lambda constant-converter) (let ((*walk-form-expand-macros-p* t) ; doesn't matter here. collect) (walk-form lambda nil - #'(lambda (f c e) - (declare (ignore e)) - (if (neq c :eval) - f - (let ((consts (funcall constant-converter f))) - (if consts - (progn - (setq collect (nconc collect consts)) - (values f t)) - f))))) + (lambda (f c e) + (declare (ignore e)) + (if (neq c :eval) + f + (let ((consts (funcall constant-converter f))) + (if consts + (progn + (setq collect (nconc collect consts)) + (values f t)) + f))))) collect)) (defmacro precompile-function-generators (&optional system) diff --git a/src/pcl/init.lisp b/src/pcl/init.lisp index 08fb92e..927eb47 100644 --- a/src/pcl/init.lisp +++ b/src/pcl/init.lisp @@ -196,12 +196,12 @@ (check-initargs-2-list initargs class legal error-p))))) (defun check-initargs-values (class call-list) - (let ((methods (mapcan #'(lambda (call) - (if (consp call) - (copy-list (compute-applicable-methods - (gdefinition (car call)) - (cdr call))) - (list call))) + (let ((methods (mapcan (lambda (call) + (if (consp call) + (copy-list (compute-applicable-methods + (gdefinition (car call)) + (cdr call))) + (list call))) call-list)) (legal (apply #'append (mapcar #'slot-definition-initargs (class-slots class))))) diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index d6559bc..767d305 100644 --- a/src/pcl/methods.lisp +++ b/src/pcl/methods.lisp @@ -523,10 +523,10 @@ (types-from-arguments generic-function classes 'class-eq))) (defun proclaim-incompatible-superclasses (classes) - (setq classes (mapcar #'(lambda (class) - (if (symbolp class) - (find-class class) - class)) + (setq classes (mapcar (lambda (class) + (if (symbolp class) + (find-class class) + class)) classes)) (dolist (class classes) (dolist (other-class classes) @@ -587,7 +587,7 @@ (make-internal-reader-method-function 'standard-generic-function 'arg-info) t))) - #'(lambda (&rest args) (funcall mf args nil)))) + (lambda (&rest args) (funcall mf args nil)))) (defun error-need-at-least-n-args (function n) @@ -639,13 +639,13 @@ :constant-value))) (defun default-secondary-dispatch-function (generic-function) - #'(lambda (&rest args) - (let ((methods (compute-applicable-methods generic-function args))) - (if methods - (let ((emf (get-effective-method-function generic-function - methods))) - (invoke-emf emf args)) - (apply #'no-applicable-method generic-function args))))) + (lambda (&rest args) + (let ((methods (compute-applicable-methods generic-function args))) + (if methods + (let ((emf (get-effective-method-function generic-function + methods))) + (invoke-emf emf args)) + (apply #'no-applicable-method generic-function args))))) (defun list-eq (x y) (loop (when (atom x) (return (eq x y))) @@ -676,8 +676,8 @@ (defun update-all-c-a-m-gf-info (c-a-m-gf) (let ((methods (generic-function-methods c-a-m-gf))) (if (and *old-c-a-m-gf-methods* - (every #'(lambda (old-method) - (member old-method methods)) + (every (lambda (old-method) + (member old-method methods)) *old-c-a-m-gf-methods*)) (let ((gfs-to-do nil) (gf-classes-to-do nil)) @@ -688,12 +688,12 @@ (pushnew (specializer-object specl) gfs-to-do) (pushnew (specializer-class specl) gf-classes-to-do))))) (map-all-generic-functions - #'(lambda (gf) - (when (or (member gf gfs-to-do) - (dolist (class gf-classes-to-do nil) - (member class - (class-precedence-list (class-of gf))))) - (update-c-a-m-gf-info gf))))) + (lambda (gf) + (when (or (member gf gfs-to-do) + (dolist (class gf-classes-to-do nil) + (member class + (class-precedence-list (class-of gf))))) + (update-c-a-m-gf-info gf))))) (map-all-generic-functions #'update-c-a-m-gf-info)) (setq *old-c-a-m-gf-methods* methods))) @@ -841,8 +841,8 @@ (eq spec *the-class-structure-object*))) (let ((sc (class-direct-subclasses spec))) (when sc - (mapcan #'(lambda (class) - (mec-all-classes-internal class precompute-p)) + (mapcan (lambda (class) + (mec-all-classes-internal class precompute-p)) sc)))))) (defun mec-all-classes (spec precompute-p) @@ -867,8 +867,8 @@ precompute-p)) (all-class-lists (mec-all-class-lists (cdr spec-list) precompute-p))) - (mapcan #'(lambda (list) - (mapcar #'(lambda (c) (cons c list)) car-all-classes)) + (mapcan (lambda (list) + (mapcar (lambda (c) (cons c list)) car-all-classes)) all-class-lists)))) (defun make-emf-cache (generic-function valuep cache classes-list new-class) @@ -927,21 +927,21 @@ ;;; This is CASE, but without gensyms. (defmacro scase (arg &rest clauses) `(let ((.case-arg. ,arg)) - (cond ,@(mapcar #'(lambda (clause) - (list* (cond ((null (car clause)) - nil) - ((consp (car clause)) - (if (null (cdar clause)) - `(eql .case-arg. - ',(caar clause)) - `(member .case-arg. - ',(car clause)))) - ((member (car clause) '(t otherwise)) - `t) - (t - `(eql .case-arg. ',(car clause)))) - nil - (cdr clause))) + (cond ,@(mapcar (lambda (clause) + (list* (cond ((null (car clause)) + nil) + ((consp (car clause)) + (if (null (cdar clause)) + `(eql .case-arg. + ',(caar clause)) + `(member .case-arg. + ',(car clause)))) + ((member (car clause) '(t otherwise)) + `t) + (t + `(eql .case-arg. ',(car clause)))) + nil + (cdr clause))) clauses)))) (defmacro mcase (arg &rest clauses) `(scase ,arg ,@clauses)) @@ -951,45 +951,45 @@ (precedence (arg-info-precedence arg-info))) (generate-discrimination-net-internal generic-function methods types - #'(lambda (methods known-types) - (if (or sorted-p - (block one-order-p - (let ((sorted-methods nil)) - (map-all-orders - (copy-list methods) precedence - #'(lambda (methods) - (when sorted-methods (return-from one-order-p nil)) - (setq sorted-methods methods))) - (setq methods sorted-methods)) - t)) - `(methods ,methods ,known-types) - `(unordered-methods ,methods ,known-types))) - #'(lambda (position type true-value false-value) - (let ((arg (dfun-arg-symbol position))) - (if (eq (car type) 'eql) - (let* ((false-case-p (and (consp false-value) - (or (eq (car false-value) 'scase) - (eq (car false-value) 'mcase)) - (eq arg (cadr false-value)))) - (false-clauses (if false-case-p - (cddr false-value) - `((t ,false-value)))) - (case-sym (if (and (dnet-methods-p true-value) - (if false-case-p - (eq (car false-value) 'mcase) - (dnet-methods-p false-value))) - 'mcase - 'scase)) - (type-sym `(,(cadr type)))) - `(,case-sym ,arg - (,type-sym ,true-value) - ,@false-clauses)) - `(if ,(let ((arg (dfun-arg-symbol position))) - (case (car type) - (class `(class-test ,arg ,(cadr type))) - (class-eq `(class-eq-test ,arg ,(cadr type))))) - ,true-value - ,false-value)))) + (lambda (methods known-types) + (if (or sorted-p + (block one-order-p + (let ((sorted-methods nil)) + (map-all-orders + (copy-list methods) precedence + (lambda (methods) + (when sorted-methods (return-from one-order-p nil)) + (setq sorted-methods methods))) + (setq methods sorted-methods)) + t)) + `(methods ,methods ,known-types) + `(unordered-methods ,methods ,known-types))) + (lambda (position type true-value false-value) + (let ((arg (dfun-arg-symbol position))) + (if (eq (car type) 'eql) + (let* ((false-case-p (and (consp false-value) + (or (eq (car false-value) 'scase) + (eq (car false-value) 'mcase)) + (eq arg (cadr false-value)))) + (false-clauses (if false-case-p + (cddr false-value) + `((t ,false-value)))) + (case-sym (if (and (dnet-methods-p true-value) + (if false-case-p + (eq (car false-value) 'mcase) + (dnet-methods-p false-value))) + 'mcase + 'scase)) + (type-sym `(,(cadr type)))) + `(,case-sym ,arg + (,type-sym ,true-value) + ,@false-clauses)) + `(if ,(let ((arg (dfun-arg-symbol position))) + (case (car type) + (class `(class-test ,arg ,(cadr type))) + (class-eq `(class-eq-test ,arg ,(cadr type))))) + ,true-value + ,false-value)))) #'identity))) (defun class-from-type (type) @@ -1012,25 +1012,25 @@ (classes-list nil)) (generate-discrimination-net-internal gf methods nil - #'(lambda (methods known-types) - (when methods - (when classes-list-p - (push (mapcar #'class-from-type known-types) classes-list)) - (let ((no-eql-specls-p (not (methods-contain-eql-specializer-p - methods)))) - (map-all-orders - methods precedence - #'(lambda (methods) - (get-secondary-dispatch-function1 - gf methods known-types - nil caching-p no-eql-specls-p)))))) - #'(lambda (position type true-value false-value) - (declare (ignore position type true-value false-value)) - nil) - #'(lambda (type) - (if (and (consp type) (eq (car type) 'eql)) - `(class-eq ,(class-of (cadr type))) - type))) + (lambda (methods known-types) + (when methods + (when classes-list-p + (push (mapcar #'class-from-type known-types) classes-list)) + (let ((no-eql-specls-p (not (methods-contain-eql-specializer-p + methods)))) + (map-all-orders + methods precedence + (lambda (methods) + (get-secondary-dispatch-function1 + gf methods known-types + nil caching-p no-eql-specls-p)))))) + (lambda (position type true-value false-value) + (declare (ignore position type true-value false-value)) + nil) + (lambda (type) + (if (and (consp type) (eq (car type) 'eql)) + `(class-eq ,(class-of (cadr type))) + type))) classes-list)) ;;; We know that known-type implies neither new-type nor `(not ,new-type). @@ -1043,9 +1043,9 @@ (list known-type)))) (unless (eq (car new-type) 'not) (setq so-far - (mapcan #'(lambda (type) - (unless (*subtypep new-type type) - (list type))) + (mapcan (lambda (type) + (unless (*subtypep new-type type) + (list type))) so-far))) (if (null so-far) new-type @@ -1196,12 +1196,12 @@ (case (car form) (mcase (let* ((mp (compute-mcase-parameters (cddr form))) - (list (mapcar #'(lambda (clause) - (let ((key (car clause)) - (meth (cadr clause))) - (cons (if (consp key) (car key) key) - (methods-converter - meth generic-function)))) + (list (mapcar (lambda (clause) + (let ((key (car clause)) + (meth (cadr clause))) + (cons (if (consp key) (car key) key) + (methods-converter + meth generic-function)))) (cddr form))) (default (car (last list)))) (list (list* ':mcase mp (nbutlast list)) @@ -1225,11 +1225,11 @@ (defun convert-table (constant method-alist wrappers) (cond ((and (consp constant) (eq (car constant) ':mcase)) - (let ((alist (mapcar #'(lambda (k+m) - (cons (car k+m) - (convert-methods (cdr k+m) - method-alist - wrappers))) + (let ((alist (mapcar (lambda (k+m) + (cons (car k+m) + (convert-methods (cdr k+m) + method-alist + wrappers))) (cddr constant))) (mp (cadr constant))) (ecase (cadr mp) @@ -1270,29 +1270,29 @@ ,(make-emf-call metatypes applyp 'emf)))) #'net-test-converter #'net-code-converter - #'(lambda (form) - (net-constant-converter form generic-function))) - #'(lambda (method-alist wrappers) - (let* ((alist (list nil)) - (alist-tail alist)) - (dolist (constant constants) - (let* ((a (or (dolist (a alist nil) - (when (eq (car a) constant) - (return a))) - (cons constant - (or (convert-table - constant method-alist wrappers) - (convert-methods - constant method-alist wrappers))))) - (new (list a))) - (setf (cdr alist-tail) new) - (setf alist-tail new))) - (let ((function (apply cfunction (mapcar #'cdr (cdr alist))))) - (if function-p - function - (make-fast-method-call - :function (set-fun-name function `(sdfun-method ,name)) - :arg-info fmc-arg-info)))))))))) + (lambda (form) + (net-constant-converter form generic-function))) + (lambda (method-alist wrappers) + (let* ((alist (list nil)) + (alist-tail alist)) + (dolist (constant constants) + (let* ((a (or (dolist (a alist nil) + (when (eq (car a) constant) + (return a))) + (cons constant + (or (convert-table + constant method-alist wrappers) + (convert-methods + constant method-alist wrappers))))) + (new (list a))) + (setf (cdr alist-tail) new) + (setf alist-tail new))) + (let ((function (apply cfunction (mapcar #'cdr (cdr alist))))) + (if function-p + function + (make-fast-method-call + :function (set-fun-name function `(sdfun-method ,name)) + :arg-info fmc-arg-info)))))))))) (defvar *show-make-unordered-methods-emf-calls* nil) @@ -1300,13 +1300,13 @@ (when *show-make-unordered-methods-emf-calls* (format t "~&make-unordered-methods-emf ~S~%" (generic-function-name generic-function))) - #'(lambda (&rest args) - (let* ((types (types-from-arguments generic-function args 'eql)) - (smethods (sort-applicable-methods generic-function - methods - types)) - (emf (get-effective-method-function generic-function smethods))) - (invoke-emf emf args)))) + (lambda (&rest args) + (let* ((types (types-from-arguments generic-function args 'eql)) + (smethods (sort-applicable-methods generic-function + methods + types)) + (emf (get-effective-method-function generic-function smethods))) + (invoke-emf emf args)))) ;;; The value returned by compute-discriminating-function is a function ;;; object. It is called a discriminating function because it is called @@ -1334,7 +1334,7 @@ ;;; ;;; (defmethod compute-discriminating-function ((gf my-generic-function)) ;;; (let ((std (call-next-method))) -;;; #'(lambda (arg) +;;; (lambda (arg) ;;; (print (list 'call-to-gf gf arg)) ;;; (funcall std arg)))) ;;; @@ -1361,7 +1361,7 @@ ;;; itself in accordance with this protocol: ;;; ;;; (defmethod compute-discriminating-function ((gf my-generic-function)) -;;; #'(lambda (arg) +;;; (lambda (arg) ;;; (cond ( ;;; ;;; (set-funcallable-instance-fun @@ -1374,11 +1374,11 @@ ;;; Whereas this code would not be legal: ;;; ;;; (defmethod compute-discriminating-function ((gf my-generic-function)) -;;; #'(lambda (arg) +;;; (lambda (arg) ;;; (cond ( ;;; (set-funcallable-instance-fun ;;; gf -;;; #'(lambda (a) ..)) +;;; (lambda (a) ..)) ;;; (funcall gf arg)) ;;; (t ;;; )))) @@ -1451,9 +1451,9 @@ (nreq nopt keysp restp allow-other-keys-p keywords keyword-parameters) (analyze-lambda-list ll) (declare (ignore nreq nopt keysp restp allow-other-keys-p keywords)) - (remove-if #'(lambda (s) - (or (memq s keyword-parameters) - (eq s '&allow-other-keys))) + (remove-if (lambda (s) + (or (memq s keyword-parameters) + (eq s '&allow-other-keys))) ll))) ;;; This is based on the rules of method lambda list congruency defined in diff --git a/src/pcl/slots-boot.lisp b/src/pcl/slots-boot.lisp index 59908e9..bad2c3a 100644 --- a/src/pcl/slots-boot.lisp +++ b/src/pcl/slots-boot.lisp @@ -97,8 +97,8 @@ (defun make-structure-slot-boundp-function (slotd) (let* ((reader (slot-definition-internal-reader-function slotd)) - (fun #'(lambda (object) - (not (eq (funcall reader object) +slot-unbound+))))) + (fun (lambda (object) + (not (eq (funcall reader object) +slot-unbound+))))) (declare (type function reader)) fun)) @@ -172,17 +172,17 @@ (set-fun-name (etypecase index (fixnum (if fsc-p - #'(lambda (instance) - (not (eq (clos-slots-ref (fsc-instance-slots instance) - index) - +slot-unbound+))) - #'(lambda (instance) - (not (eq (clos-slots-ref (std-instance-slots instance) - index) - +slot-unbound+))))) - (cons #'(lambda (instance) - (declare (ignore instance)) - (not (eq (cdr index) +slot-unbound+))))) + (lambda (instance) + (not (eq (clos-slots-ref (fsc-instance-slots instance) + index) + +slot-unbound+))) + (lambda (instance) + (not (eq (clos-slots-ref (std-instance-slots instance) + index) + +slot-unbound+))))) + (cons (lambda (instance) + (declare (ignore instance)) + (not (eq (cdr index) +slot-unbound+))))) `(boundp ,slot-name))) (defun make-optimized-structure-slot-value-using-class-method-function (function) @@ -195,15 +195,15 @@ (defun make-optimized-structure-setf-slot-value-using-class-method-function (function) (declare (type function function)) - #'(lambda (nv class object slotd) - (declare (ignore class slotd)) - (funcall function nv object))) + (lambda (nv class object slotd) + (declare (ignore class slotd)) + (funcall function nv object))) (defun make-optimized-structure-slot-boundp-using-class-method-function (function) (declare (type function function)) - #'(lambda (class object slotd) - (declare (ignore class slotd)) - (not (eq (funcall function object) +slot-unbound+)))) + (lambda (class object slotd) + (declare (ignore class slotd)) + (not (eq (funcall function object) +slot-unbound+)))) (defun get-optimized-std-slot-value-using-class-method-function (class slotd diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index 9697915..8d16817 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -282,27 +282,27 @@ (nreverse collect))))))) (defun map-specializers (function) - (map-all-classes #'(lambda (class) - (funcall function (class-eq-specializer class)) - (funcall function class))) - (maphash #'(lambda (object methods) - (declare (ignore methods)) - (intern-eql-specializer object)) + (map-all-classes (lambda (class) + (funcall function (class-eq-specializer class)) + (funcall function class))) + (maphash (lambda (object methods) + (declare (ignore methods)) + (intern-eql-specializer object)) *eql-specializer-methods*) - (maphash #'(lambda (object specl) - (declare (ignore object)) - (funcall function specl)) + (maphash (lambda (object specl) + (declare (ignore object)) + (funcall function specl)) *eql-specializer-table*) nil) (defun map-all-generic-functions (function) (let ((all-generic-functions (make-hash-table :test 'eq))) - (map-specializers #'(lambda (specl) - (dolist (gf (specializer-direct-generic-functions - specl)) - (unless (gethash gf all-generic-functions) - (setf (gethash gf all-generic-functions) t) - (funcall function gf)))))) + (map-specializers (lambda (specl) + (dolist (gf (specializer-direct-generic-functions + specl)) + (unless (gethash gf all-generic-functions) + (setf (gethash gf all-generic-functions) t) + (funcall function gf)))))) nil) (defmethod shared-initialize :after ((specl class-eq-specializer) @@ -464,8 +464,8 @@ &rest initargs &key) (map-dependents class - #'(lambda (dependent) - (apply #'update-dependent class dependent initargs)))) + (lambda (dependent) + (apply #'update-dependent class dependent initargs)))) (defmethod shared-initialize :after ((slotd standard-slot-definition) slot-names &key) @@ -556,17 +556,17 @@ (if direct-slots-p (setf (slot-value class 'direct-slots) (setq direct-slots - (mapcar #'(lambda (pl) - (when defstruct-p - (let* ((slot-name (getf pl :name)) - (acc-name - (format nil - "~S structure class ~A" - name slot-name)) - (accessor (intern acc-name))) - (setq pl (list* :defstruct-accessor-symbol - accessor pl)))) - (make-direct-slotd class pl)) + (mapcar (lambda (pl) + (when defstruct-p + (let* ((slot-name (getf pl :name)) + (acc-name + (format nil + "~S structure class ~A" + name slot-name)) + (accessor (intern acc-name))) + (setq pl (list* :defstruct-accessor-symbol + accessor pl)))) + (make-direct-slotd class pl)) direct-slots))) (setq direct-slots (slot-value class 'direct-slots))) (when defstruct-p @@ -574,14 +574,14 @@ (multiple-value-bind (defstruct-form constructor reader-names writer-names) (make-structure-class-defstruct-form name direct-slots include) (unless (structure-type-p name) (eval defstruct-form)) - (mapc #'(lambda (dslotd reader-name writer-name) - (let* ((reader (gdefinition reader-name)) - (writer (when (gboundp writer-name) - (gdefinition writer-name)))) - (setf (slot-value dslotd 'internal-reader-function) - reader) - (setf (slot-value dslotd 'internal-writer-function) - writer))) + (mapc (lambda (dslotd reader-name writer-name) + (let* ((reader (gdefinition reader-name)) + (writer (when (gboundp writer-name) + (gdefinition writer-name)))) + (setf (slot-value dslotd 'internal-reader-function) + reader) + (setf (slot-value dslotd 'internal-writer-function) + writer))) direct-slots reader-names writer-names) (setf (slot-value class 'defstruct-form) defstruct-form) (setf (slot-value class 'defstruct-constructor) constructor)))) @@ -771,9 +771,9 @@ (setf (gethash gf gf-table) t)) (mapc #'collect-gfs (class-direct-superclasses class)))) (collect-gfs class) - (maphash #'(lambda (gf ignore) - (declare (ignore ignore)) - (update-gf-dfun class gf)) + (maphash (lambda (gf ignore) + (declare (ignore ignore)) + (update-gf-dfun class gf)) gf-table))))) (defun update-inits (class inits) @@ -819,9 +819,9 @@ (if entry (push d (cdr entry)) (push (list name d) name-dslotds-alist)))))) - (mapcar #'(lambda (direct) - (compute-effective-slot-definition class - (nreverse (cdr direct)))) + (mapcar (lambda (direct) + (compute-effective-slot-definition class + (nreverse (cdr direct)))) name-dslotds-alist))) (defmethod compute-slots :around ((class std-class)) @@ -845,11 +845,11 @@ eslotds)) (defmethod compute-slots ((class structure-class)) - (mapcan #'(lambda (superclass) - (mapcar #'(lambda (dslotd) - (compute-effective-slot-definition class - (list dslotd))) - (class-direct-slots superclass))) + (mapcan (lambda (superclass) + (mapcar (lambda (dslotd) + (compute-effective-slot-definition class + (list dslotd))) + (class-direct-slots superclass))) (reverse (slot-value class 'class-precedence-list)))) (defmethod compute-slots :around ((class structure-class)) diff --git a/src/pcl/time.lisp b/src/pcl/time.lisp index 1f2bacb..e0d70c1 100644 --- a/src/pcl/time.lisp +++ b/src/pcl/time.lisp @@ -98,14 +98,14 @@ (time (constant-keys-make-instance n))) (defun expand-all-macros (form) - (walk-form form nil #'(lambda (form context env) - (if (and (eq context :eval) - (consp form) - (symbolp (car form)) - (not (special-form-p (car form))) - (macro-function (car form))) - (values (macroexpand form env)) - form)))) + (walk-form form nil (lambda (form context env) + (if (and (eq context :eval) + (consp form) + (symbolp (car form)) + (not (special-form-p (car form))) + (macro-function (car form))) + (values (macroexpand form env)) + form)))) (push (cons "Macroexpand meth-structure-slot-value" '(pprint (multiple-value-bind (pgf pm) @@ -114,7 +114,7 @@ (expand-defmethod 'meth-structure-slot-value pgf pm nil '((object str)) - '(#'(lambda () (slot-value object 'slot))) + '((lambda () (slot-value object 'slot))) nil)))) *tests*) @@ -122,21 +122,21 @@ '(disassemble (meth-structure-slot-value str))) *tests*) (defmethod meth-structure-slot-value ((object str)) - #'(lambda () (slot-value object 'slot))) + (lambda () (slot-value object 'slot))) #|| ; interesting, but long. (produces 100 lines of output) (push (cons "Macroexpand meth-standard-slot-value" '(pprint (expand-all-macros (expand-defmethod-internal 'meth-standard-slot-value nil '((object standard-method)) - '(#'(lambda () (slot-value object 'function))) + '((lambda () (slot-value object 'function))) nil)))) *tests*) (push (cons "Show code for slot-value inside a defmethod for a standard-class. Case (4)." '(disassemble (meth-standard-slot-value m))) *tests*) (defmethod meth-standard-slot-value ((object standard-method)) - #'(lambda () (slot-value object 'function))) + (lambda () (slot-value object 'function))) ||# (defun do-tests () diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp index c4555b4..7dda26a 100644 --- a/src/pcl/vector.lisp +++ b/src/pcl/vector.lisp @@ -187,8 +187,8 @@ (declare (ignore call-list wrappers)) #|| (map 'vector - #'(lambda (call) - (compute-emf-from-wrappers call wrappers)) + (lambda (call) + (compute-emf-from-wrappers call wrappers)) call-list) ||# '#()) @@ -199,18 +199,18 @@ (destructuring-bind (gf-name nreq restp arg-info) call (if (eq gf-name 'make-instance) (error "should not get here") ; there is another mechanism for this. - #'(lambda (&rest args) - (if (not (eq *boot-state* 'complete)) - (apply (gdefinition gf-name) args) - (let* ((gf (gdefinition gf-name)) - (arg-info (arg-info-reader gf)) - (classes '?) - (types '?) - (emf (cache-miss-values-internal gf arg-info - wrappers classes types - 'caching))) - (update-all-pv-tables call wrappers emf) - (invoke-emf emf args)))))))) + (lambda (&rest args) + (if (not (eq *boot-state* 'complete)) + (apply (gdefinition gf-name) args) + (let* ((gf (gdefinition gf-name)) + (arg-info (arg-info-reader gf)) + (classes '?) + (types '?) + (emf (cache-miss-values-internal gf arg-info + wrappers classes types + 'caching))) + (update-all-pv-tables call wrappers emf) + (invoke-emf emf args)))))))) ||# (defun make-permutation-vector (indexes) @@ -271,20 +271,20 @@ (std-p (typep cwrapper 'wrapper)) (class-slots (and std-p (wrapper-class-slots cwrapper))) (class-slot-p-cell (list nil)) - (new-values (mapcar #'(lambda (slot-name) - (cons slot-name - (when std-p - (compute-pv-slot - slot-name cwrapper class - class-slots class-slot-p-cell)))) + (new-values (mapcar (lambda (slot-name) + (cons slot-name + (when std-p + (compute-pv-slot + slot-name cwrapper class + class-slots class-slot-p-cell)))) slot-names)) (pv-tables nil)) (dolist (slot-name slot-names) (map-pv-table-references-of slot-name - #'(lambda (pv-table pv-offset-list) - (declare (ignore pv-offset-list)) - (pushnew pv-table pv-tables)))) + (lambda (pv-table pv-offset-list) + (declare (ignore pv-offset-list)) + (pushnew pv-table pv-tables)))) (dolist (pv-table pv-tables) (let* ((cache (pv-table-cache pv-table)) (slot-name-lists (pv-table-slot-name-lists pv-table)) @@ -299,10 +299,10 @@ (incf map-index)) (incf param-index))) (when cache - (map-cache #'(lambda (wrappers pv-cell) - (setf (car pv-cell) - (update-slots-in-pv wrappers (car pv-cell) - cwrapper pv-size pv-map))) + (map-cache (lambda (wrappers pv-cell) + (setf (car pv-cell) + (update-slots-in-pv wrappers (car pv-cell) + cwrapper pv-size pv-map))) cache)))))) (defun update-slots-in-pv (wrappers pv cwrapper pv-size pv-map) @@ -601,8 +601,8 @@ (non-required-args (nthcdr nreq args)) (required-args (ldiff args non-required-args)) (call-spec (list (car gf-call-form) nreq restp - (mapcar #'(lambda (form) - (optimize-gf-call-internal form slots env)) + (mapcar (lambda (form) + (optimize-gf-call-internal form slots env)) (if all-args-p args required-args)))) @@ -783,8 +783,8 @@ (defun slot-name-lists-from-slots (slots calls) (multiple-value-bind (slots calls) (mutate-slots-and-calls slots calls) (let* ((slot-name-lists - (mapcar #'(lambda (parameter-entry) - (cons nil (mapcar #'car (cdr parameter-entry)))) + (mapcar (lambda (parameter-entry) + (cons nil (mapcar #'car (cdr parameter-entry)))) slots)) (call-list (mapcar #'car calls))) @@ -792,22 +792,22 @@ (dolist (arg (cdr call)) (when (integerp arg) (setf (car (nth arg slot-name-lists)) t)))) - (setq slot-name-lists (mapcar #'(lambda (r+snl) - (when (or (car r+snl) (cdr r+snl)) - r+snl)) + (setq slot-name-lists (mapcar (lambda (r+snl) + (when (or (car r+snl) (cdr r+snl)) + r+snl)) slot-name-lists)) (let ((cvt (apply #'vector (let ((i -1)) - (mapcar #'(lambda (r+snl) - (when r+snl (incf i))) + (mapcar (lambda (r+snl) + (when r+snl (incf i))) slot-name-lists))))) - (setq call-list (mapcar #'(lambda (call) - (cons (car call) - (mapcar #'(lambda (arg) - (if (integerp arg) - (svref cvt arg) - arg)) - (cdr call)))) + (setq call-list (mapcar (lambda (call) + (cons (car call) + (mapcar (lambda (arg) + (if (integerp arg) + (svref cvt arg) + arg)) + (cdr call)))) call-list))) (values slot-name-lists call-list)))) @@ -893,8 +893,8 @@ (defmacro pv-binding1 ((pv calls pv-table-symbol pv-parameters slot-vars) &body body) `(pv-env (,pv ,calls ,pv-table-symbol ,pv-parameters) - (let (,@(mapcar #'(lambda (slot-var p) `(,slot-var (get-slots-or-nil ,p))) - slot-vars pv-parameters)) + (let (,@(mapcar (lambda (slot-var p) `(,slot-var (get-slots-or-nil ,p))) + slot-vars pv-parameters)) ,@body))) ;;; This gets used only when the default MAKE-METHOD-LAMBDA is @@ -1067,25 +1067,25 @@ (nreq (car arg-info)) (restp (cdr arg-info))) (setq method-function - #'(lambda (method-args next-methods) - (unless pv-table - (setq pv-table (method-function-pv-table fmf))) - (let* ((pv-cell (when pv-table - (get-method-function-pv-cell - method-function method-args pv-table))) - (nm (car next-methods)) - (nms (cdr next-methods)) - (nmc (when nm - (make-method-call - :function (if (std-instance-p nm) - (method-function nm) - nm) - :call-method-args (list nms))))) - (if restp - (let* ((rest (nthcdr nreq method-args)) - (args (ldiff method-args rest))) - (apply fmf pv-cell nmc (nconc args (list rest)))) - (apply fmf pv-cell nmc method-args))))) + (lambda (method-args next-methods) + (unless pv-table + (setq pv-table (method-function-pv-table fmf))) + (let* ((pv-cell (when pv-table + (get-method-function-pv-cell + method-function method-args pv-table))) + (nm (car next-methods)) + (nms (cdr next-methods)) + (nmc (when nm + (make-method-call + :function (if (std-instance-p nm) + (method-function nm) + nm) + :call-method-args (list nms))))) + (if restp + (let* ((rest (nthcdr nreq method-args)) + (args (ldiff method-args rest))) + (apply fmf pv-cell nmc (nconc args (list rest)))) + (apply fmf pv-cell nmc method-args))))) (let* ((fname (method-function-get fmf :name)) (name `(,(or (get (car fname) 'method-sym) (setf (get (car fname) 'method-sym) diff --git a/src/pcl/walk.lisp b/src/pcl/walk.lisp index 869d268..b1bd974 100644 --- a/src/pcl/walk.lisp +++ b/src/pcl/walk.lisp @@ -705,7 +705,7 @@ (body (cdddr form))) (walk-form-internal `(let () - (declare (special ,@(mapcar #'(lambda (x) (if (listp x) (car x) x)) + (declare (special ,@(mapcar (lambda (x) (if (listp x) (car x) x)) bindings))) (flet ((.let-if-dummy. () ,@body)) (if ,test @@ -716,14 +716,14 @@ (defun walk-multiple-value-setq (form context env) (let ((vars (cadr form))) - (if (some #'(lambda (var) - (variable-symbol-macro-p var env)) + (if (some (lambda (var) + (variable-symbol-macro-p var env)) vars) - (let* ((temps (mapcar #'(lambda (var) - (declare (ignore var)) - (gensym)) + (let* ((temps (mapcar (lambda (var) + (declare (ignore var)) + (gensym)) vars)) - (sets (mapcar #'(lambda (var temp) `(setq ,var ,temp)) + (sets (mapcar (lambda (var temp) `(setq ,var ,temp)) vars temps)) (expanded `(multiple-value-bind ,temps ,(caddr form) @@ -744,14 +744,14 @@ (walked-body (walk-declarations body - #'(lambda (real-body real-env) - (setq walked-bindings - (walk-bindings-1 bindings - old-env - new-env - context - nil)) - (walk-repeat-eval real-body real-env)) + (lambda (real-body real-env) + (setq walked-bindings + (walk-bindings-1 bindings + old-env + new-env + context + nil)) + (walk-repeat-eval real-body real-env)) new-env))) (relist* form mvb walked-bindings mv-form walked-body)))) @@ -856,9 +856,9 @@ (walker-environment-bind (new-env old-env :lexical-variables - (append (mapcar #'(lambda (binding) - `(,(car binding) - :macro . ,(cadr binding))) + (append (mapcar (lambda (binding) + `(,(car binding) + :macro . ,(cadr binding))) bindings) (env-lexical-variables old-env))) (relist* form 'symbol-macrolet bindings diff --git a/tests/backq.impure.lisp b/tests/backq.impure.lisp index c9628a9..a9be79b 100644 --- a/tests/backq.impure.lisp +++ b/tests/backq.impure.lisp @@ -51,8 +51,8 @@ ("``(FOO ,@,@*Q*)" . (foo a b c sqrt 9)) ("``(,@,@*QQ*)" . (3 5 4 6)))) -(mapc #'(lambda (test) - (test-double-backquote (car test) (cdr test))) +(mapc (lambda (test) + (test-double-backquote (car test) (cdr test))) *backquote-tests*) ;;; success diff --git a/tests/float.impure.lisp b/tests/float.impure.lisp index 36fdd6f..ef7379e 100644 --- a/tests/float.impure.lisp +++ b/tests/float.impure.lisp @@ -35,13 +35,13 @@ (declare (type (simple-array double-float (2)) p)) (aref p 1)) (defun order39 (points) - (sort points #'(lambda (p1 p2) - (let* ((y1 (point39-y p1)) - (y2 (point39-y p2))) - (if (= y1 y2) - (< (point39-x p1) - (point39-x p2)) - (< y1 y2)))))) + (sort points (lambda (p1 p2) + (let* ((y1 (point39-y p1)) + (y2 (point39-y p2))) + (if (= y1 y2) + (< (point39-x p1) + (point39-x p2)) + (< y1 y2)))))) (defun test39 () (order39 (make-array 4 :initial-contents (list (point39 0.0d0 0.0d0) diff --git a/tests/seq.impure.lisp b/tests/seq.impure.lisp index ef2eeda..df8dbc0 100644 --- a/tests/seq.impure.lisp +++ b/tests/seq.impure.lisp @@ -172,7 +172,7 @@ (eql 5 (position-if (lambda (c) (equal #\g c)) seq)) (eql 5 (position-if (lambda (c) (equal #\g c)) seq :from-end t)) (find-if #'characterp seq) - (find-if #'(lambda (c) (typep c 'base-char)) seq :from-end t) + (find-if (lambda (c) (typep c 'base-char)) seq :from-end t) (null (find-if 'upper-case-p seq)))) ;;; success diff --git a/tests/walk.impure.lisp b/tests/walk.impure.lisp index 8642df7..c44c1ae 100644 --- a/tests/walk.impure.lisp +++ b/tests/walk.impure.lisp @@ -34,21 +34,21 @@ (defun take-it-out-for-a-test-walk-1 (form) (let ((copy-of-form (copy-tree form)) (result (walk-form form nil - #'(lambda (x y env) - (format t "~&Form: ~S ~3T Context: ~A" x y) - (when (symbolp x) - (let ((lexical (var-lexical-p x env)) - (special (var-special-p x env))) - (when lexical - (format t ";~3T") - (format t "lexically bound")) - (when special - (format t ";~3T") - (format t "declared special")) - (when (boundp x) - (format t ";~3T") - (format t "bound: ~S " (eval x))))) - x)))) + (lambda (x y env) + (format t "~&Form: ~S ~3T Context: ~A" x y) + (when (symbolp x) + (let ((lexical (var-lexical-p x env)) + (special (var-special-p x env))) + (when lexical + (format t ";~3T") + (format t "lexically bound")) + (when special + (format t ";~3T") + (format t "declared special")) + (when (boundp x) + (format t ";~3T") + (format t "bound: ~S " (eval x))))) + x)))) (cond ((not (equal result copy-of-form)) (format t "~%Warning: Result not EQUAL to copy of start.")) ((not (eq result form)) @@ -935,14 +935,14 @@ Form: NIL Context: EVAL; bound: NIL (with-output-to-string (*standard-output*) (let ((the-lexical-variables ())) (walk-form '(let ((a 1) (b 2)) - #'(lambda (x) (list a b x y))) + (lambda (x) (list a b x y))) () - #'(lambda (form context env) - (declare (ignore context)) - (when (and (symbolp form) - (var-lexical-p form env)) - (push form the-lexical-variables)) - form)) + (lambda (form context env) + (declare (ignore context)) + (when (and (symbolp form) + (var-lexical-p form env)) + (push form the-lexical-variables)) + form)) (or (and (= (length the-lexical-variables) 3) (member 'a the-lexical-variables) (member 'b the-lexical-variables) diff --git a/version.lisp-expr b/version.lisp-expr index 91b3d19..8117aba 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.pre7.125" +"0.pre7.126" -- 1.7.10.4