(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))
\f
(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))))
;; 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)
;; 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.
(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))
(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))))
;;; 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")))
(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)
(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)
(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)
`(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))))
(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"
(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))
;;; 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
(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)))
: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)
(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))))))
;;; 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.
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
(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))
(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))))
(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))))
\f
;;;; byte operations
(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))))))
\f
(*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)
(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
(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)
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*)
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
(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)))
\f
(defmacro bind-fast-lexical-method-macros ((args rest-arg next-method-call)
'(&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)))))
'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*
(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)
(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)))))))
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
;; 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 ()))
(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)
(/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)
(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))))
(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))))
(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)
(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)
#+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))
(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))))
\f
(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)))
(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)
#'>
(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)
(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)
(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)))
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))))
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))
(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)
(*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
: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))
(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."
: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))
(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)
(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)
())
(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)))
(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*))
(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)
(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
(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)
(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)
(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)
(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))
(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))))
(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))
(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))
(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)))
(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)
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*)
(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))
|#
(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))
(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))
(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)))
(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))))
`(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
(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))
) ; 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
(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
(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)
(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)
(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
(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))
(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
`((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
`((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
(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)
':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))
(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))))
(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)))))
\f
;;; The effect of this is to cause almost all of the overhead of
(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))
\f
(defmacro precompile-function-generators (&optional system)
(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)))))
(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)
(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)
: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)))
(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))
(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)))
(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)
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)
;;; 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))
(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)
(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).
(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
(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))
(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)
,(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)
(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))))
\f
;;; The value returned by compute-discriminating-function is a function
;;; object. It is called a discriminating function because it is called
;;;
;;; (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))))
;;;
;;; itself in accordance with this protocol:
;;;
;;; (defmethod compute-discriminating-function ((gf my-generic-function))
-;;; #'(lambda (arg)
+;;; (lambda (arg)
;;; (cond (<some condition>
;;; <store some info in the generic function>
;;; (set-funcallable-instance-fun
;;; Whereas this code would not be legal:
;;;
;;; (defmethod compute-discriminating-function ((gf my-generic-function))
-;;; #'(lambda (arg)
+;;; (lambda (arg)
;;; (cond (<some condition>
;;; (set-funcallable-instance-fun
;;; gf
-;;; #'(lambda (a) ..))
+;;; (lambda (a) ..))
;;; (funcall gf arg))
;;; (t
;;; <call-a-method-of-gf>))))
(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)))
\f
;;; This is based on the rules of method lambda list congruency defined in
(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))
(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)
(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
(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)
&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)
(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
(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))))
(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)
(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))
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))
(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)
(expand-defmethod
'meth-structure-slot-value pgf pm
nil '((object str))
- '(#'(lambda () (slot-value object 'slot)))
+ '((lambda () (slot-value object 'slot)))
nil))))
*tests*)
'(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 ()
(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)
||#
'#())
(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)
(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))
(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)
(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))))
(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)))
(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))))
(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
(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)
(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
(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)
(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))))
(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
("``(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
(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)
(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
(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))
(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)
;;; 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"
projects / sbcl.git / commitdiff