;; he ended up inside the system error-handling logic.
(declare (ignorable name ,fp ,context ,sc-offsets))
(let (,@(let ((offset -1))
- (mapcar #'(lambda (var)
- `(,var (sb!di::sub-access-debug-var-slot
- ,fp
- (nth ,(incf offset)
- ,sc-offsets)
- ,context)))
+ (mapcar (lambda (var)
+ `(,var (sb!di::sub-access-debug-var-slot
+ ,fp
+ (nth ,(incf offset)
+ ,sc-offsets)
+ ,context)))
required))
,@(when rest-pos
`((,(nth (1+ rest-pos) args)
- (mapcar #'(lambda (sc-offset)
- (sb!di::sub-access-debug-var-slot
- ,fp
- sc-offset
- ,context))
+ (mapcar (lambda (sc-offset)
+ (sb!di::sub-access-debug-var-slot
+ ,fp
+ sc-offset
+ ,context))
(nthcdr ,rest-pos ,sc-offsets))))))
,@body))
(setf (svref *internal-errors* ,(error-number-or-lose name))
"unknown internal error, ~D, args=~S"
:format-arguments
(list error-number
- (mapcar #'(lambda (sc-offset)
- (sb!di::sub-access-debug-var-slot
- fp sc-offset alien-context))
+ (mapcar (lambda (sc-offset)
+ (sb!di::sub-access-debug-var-slot
+ fp sc-offset alien-context))
arguments))))
((not (functionp handler))
(error 'simple-error
:format-arguments
(list error-number
handler
- (mapcar #'(lambda (sc-offset)
- (sb!di::sub-access-debug-var-slot
- fp sc-offset alien-context))
+ (mapcar (lambda (sc-offset)
+ (sb!di::sub-access-debug-var-slot
+ fp sc-offset alien-context))
arguments))))
(t
(funcall handler name fp alien-context arguments)))))))))
(expand-bind-defaults () params
`(handler-bind
((format-error
- #'(lambda (condition)
- (error 'format-error
- :complaint
- "~A~%while processing indirect format string:"
- :arguments (list condition)
- :print-banner nil
- :control-string ,string
- :offset ,(1- end)))))
+ (lambda (condition)
+ (error 'format-error
+ :complaint
+ "~A~%while processing indirect format string:"
+ :arguments (list condition)
+ :print-banner nil
+ :control-string ,string
+ :offset ,(1- end)))))
,(if atsignp
(if *orig-args-available*
`(setf args (%format stream ,(expand-next-arg) orig-args args))
(if *orig-args-available*
`((handler-bind
((format-error
- #'(lambda (condition)
- (error 'format-error
- :complaint
- "~A~%while processing indirect format string:"
- :arguments (list condition)
- :print-banner nil
- :control-string ,string
- :offset ,(1- end)))))
+ (lambda (condition)
+ (error 'format-error
+ :complaint
+ "~A~%while processing indirect format string:"
+ :arguments (list condition)
+ :print-banner nil
+ :control-string ,string
+ :offset ,(1- end)))))
(setf args
(%format stream inside-string orig-args args))))
(throw 'need-orig-args nil))
(line-len '(or (sb!impl::line-length stream) 72)))
(format-directive-params first-semi)
`(setf extra-space ,extra line-len ,line-len))))
- ,@(mapcar #'(lambda (segment)
- `(push (with-output-to-string (stream)
- ,@(expand-directive-list segment))
- segments))
+ ,@(mapcar (lambda (segment)
+ `(push (with-output-to-string (stream)
+ ,@(expand-directive-list segment))
+ segments))
segments))
(format-justification stream
,@(if newline-segment-p
(defun fixed-values-op (types1 types2 rest2 operation)
(declare (list types1 types2) (type ctype rest2) (type function operation))
(let ((exact t))
- (values (mapcar #'(lambda (t1 t2)
- (multiple-value-bind (res win)
- (funcall operation t1 t2)
- (unless win
- (setq exact nil))
- res))
+ (values (mapcar (lambda (t1 t2)
+ (multiple-value-bind (res win)
+ (funcall operation t1 t2)
+ (unless win
+ (setq exact nil))
+ res))
types1
(append types2
(make-list (- (length types1) (length types2))
;; See whether dimensions are compatible.
(cond ((not (or (eq dims1 '*) (eq dims2 '*)
(and (= (length dims1) (length dims2))
- (every #'(lambda (x y)
- (or (eq x '*) (eq y '*) (= x y)))
+ (every (lambda (x y)
+ (or (eq x '*) (eq y '*) (= x y)))
dims1 dims2))))
(values nil t))
;; See whether complexpness is compatible.
(let ((n (svref ,vec i)))
(push (cons (svref *fop-names* i) n) ,lvar)
(incf ,tvar n)))
- (setq ,lvar (subseq (sort ,lvar #'(lambda (x y)
- (> (cdr x) (cdr y))))
+ (setq ,lvar (subseq (sort ,lvar (lambda (x y)
+ (> (cdr x) (cdr y))))
0 10)))))
(breakdown counts total-count *fop-counts*)
(typecase var
(null
(when (consp val)
- ;; don't lose possible side-effects
+ ;; Don't lose possible side-effects.
(if (eq (car val) 'prog1)
- ;; these can come from psetq or desetq below.
- ;; throw away the value, keep the side-effects.
- ;;Special case is for handling an expanded POP.
- (mapcan #'(lambda (x)
- (and (consp x)
- (or (not (eq (car x) 'car))
- (not (symbolp (cadr x)))
- (not (symbolp (setq x (sb!xc:macroexpand x env)))))
- (cons x nil)))
+ ;; These can come from psetq or desetq below.
+ ;; Throw away the value, keep the side-effects.
+ ;; Special case is for handling an expanded POP.
+ (mapcan (lambda (x)
+ (and (consp x)
+ (or (not (eq (car x) 'car))
+ (not (symbolp (cadr x)))
+ (not (symbolp (setq x (sb!xc:macroexpand x env)))))
+ (cons x nil)))
(cdr val))
`(,val))))
(cons
(this-group nil nil)
(this-prep nil nil)
(disallowed-prepositions
- (mapcan #'(lambda (x)
- (copy-list
- (find (car x) preposition-groups :test #'in-group-p)))
+ (mapcan (lambda (x)
+ (copy-list
+ (find (car x) preposition-groups :test #'in-group-p)))
initial-phrases))
(used-prepositions (mapcar #'car initial-phrases)))
((null *loop-source-code*) (nreverse prepositional-phrases))
some locations known to SETF, starting over with test-form. Returns NIL."
`(do () (,test-form)
(assert-error ',test-form ',places ,datum ,@arguments)
- ,@(mapcar #'(lambda (place)
- `(setf ,place (assert-prompt ',place ,place)))
+ ,@(mapcar (lambda (place)
+ `(setf ,place (assert-prompt ',place ,place)))
places)))
(defun assert-prompt (name value)
code in BODY to provide possible further output."
`(%print-unreadable-object ,object ,stream ,type ,identity
,(if body
- `#'(lambda () ,@body)
+ `(lambda () ,@body)
nil)))
(defmacro-mundanely ignore-errors (&rest forms)
(if (sb-di:code-location-p loc)
(let ((fun (sb-di:preprocess-for-eval exp loc)))
(cons exp
- #'(lambda (frame)
- (let ((*current-frame* frame))
- (funcall fun frame)))))
+ (lambda (frame)
+ (let ((*current-frame* frame))
+ (funcall fun frame)))))
(let* ((bod (ecase loc
((nil) exp)
(:encapsulated
,exp))))
(fun (coerce `(lambda () ,bod) 'function)))
(cons exp
- #'(lambda (frame)
- (declare (ignore frame))
- (let ((*current-frame* nil))
- (funcall fun)))))))))
+ (lambda (frame)
+ (declare (ignore frame))
+ (let ((*current-frame* nil))
+ (funcall fun)))))))))
(defun coerce-form-list (forms loc)
- (mapcar #'(lambda (x) (coerce-form x loc)) forms))
+ (mapcar (lambda (x) (coerce-form x loc)) forms))
;;; Print indentation according to the number of trace entries.
;;; Entries whose condition was false don't count.
(let (conditionp)
(values
- #'(lambda (frame bpt)
- (declare (ignore bpt))
- (discard-invalid-entries frame)
- (let ((condition (trace-info-condition info))
- (wherein (trace-info-wherein info)))
- (setq conditionp
- (and (not *in-trace*)
- (or (not condition)
- (funcall (cdr condition) frame))
- (or (not wherein)
- (trace-wherein-p frame wherein)))))
- (when conditionp
- (let ((sb-kernel:*current-level* 0)
- (*standard-output* *trace-output*)
- (*in-trace* t))
- (fresh-line)
- (print-trace-indentation)
- (if (trace-info-encapsulated info)
- (locally (declare (special basic-definition argument-list))
- (prin1 `(,(trace-info-what info) ,@argument-list)))
- (print-frame-call frame))
- (terpri)
- (trace-print frame (trace-info-print info)))
- (trace-maybe-break info (trace-info-break info) "before" frame)))
-
- #'(lambda (frame cookie)
- (declare (ignore frame))
- (push (cons cookie conditionp) *traced-entries*)))))
+ (lambda (frame bpt)
+ (declare (ignore bpt))
+ (discard-invalid-entries frame)
+ (let ((condition (trace-info-condition info))
+ (wherein (trace-info-wherein info)))
+ (setq conditionp
+ (and (not *in-trace*)
+ (or (not condition)
+ (funcall (cdr condition) frame))
+ (or (not wherein)
+ (trace-wherein-p frame wherein)))))
+ (when conditionp
+ (let ((sb-kernel:*current-level* 0)
+ (*standard-output* *trace-output*)
+ (*in-trace* t))
+ (fresh-line)
+ (print-trace-indentation)
+ (if (trace-info-encapsulated info)
+ (locally (declare (special basic-definition argument-list))
+ (prin1 `(,(trace-info-what info) ,@argument-list)))
+ (print-frame-call frame))
+ (terpri)
+ (trace-print frame (trace-info-print info)))
+ (trace-maybe-break info (trace-info-break info) "before" frame)))
+
+ (lambda (frame cookie)
+ (declare (ignore frame))
+ (push (cons cookie conditionp) *traced-entries*)))))
;;; This prints a representation of the return values delivered.
;;; First, this checks to see that cookie is at the top of
;;; see whether the function is still traced and that the condition
;;; succeeded before printing anything.
(defun trace-end-breakpoint-fun (info)
- #'(lambda (frame bpt *trace-values* cookie)
- (declare (ignore bpt))
- (unless (eq cookie (caar *traced-entries*))
- (setf *traced-entries*
- (member cookie *traced-entries* :key #'car)))
-
- (let ((entry (pop *traced-entries*)))
- (when (and (not (trace-info-untraced info))
- (or (cdr entry)
- (let ((cond (trace-info-condition-after info)))
- (and cond (funcall (cdr cond) frame)))))
- (let ((sb-kernel:*current-level* 0)
- (*standard-output* *trace-output*)
- (*in-trace* t))
- (fresh-line)
- (pprint-logical-block (*standard-output* nil)
- (print-trace-indentation)
- (pprint-indent :current 2)
- (format t "~S returned" (trace-info-what info))
- (dolist (v *trace-values*)
- (write-char #\space)
- (pprint-newline :linear)
- (prin1 v)))
- (terpri)
- (trace-print frame (trace-info-print-after info)))
- (trace-maybe-break info
- (trace-info-break-after info)
- "after"
- frame)))))
+ (lambda (frame bpt *trace-values* cookie)
+ (declare (ignore bpt))
+ (unless (eq cookie (caar *traced-entries*))
+ (setf *traced-entries*
+ (member cookie *traced-entries* :key #'car)))
+
+ (let ((entry (pop *traced-entries*)))
+ (when (and (not (trace-info-untraced info))
+ (or (cdr entry)
+ (let ((cond (trace-info-condition-after info)))
+ (and cond (funcall (cdr cond) frame)))))
+ (let ((sb-kernel:*current-level* 0)
+ (*standard-output* *trace-output*)
+ (*in-trace* t))
+ (fresh-line)
+ (pprint-logical-block (*standard-output* nil)
+ (print-trace-indentation)
+ (pprint-indent :current 2)
+ (format t "~S returned" (trace-info-what info))
+ (dolist (v *trace-values*)
+ (write-char #\space)
+ (pprint-newline :linear)
+ (prin1 v)))
+ (terpri)
+ (trace-print frame (trace-info-print-after info)))
+ (trace-maybe-break info
+ (trace-info-break-after info)
+ "after"
+ frame)))))
\f
;;; This function is called by the trace encapsulation. It calls the
;;; breakpoint hook functions with NIL for the breakpoint and cookie,
(let ((var (first vars))
(cases (sort cases #'type-test-order :key #'car)))
`((typecase ,var
- ,@(mapcar #'(lambda (case)
- `(,(first case)
- ,@(generate-number-dispatch (rest vars)
- (rest error-tags)
- (cdr case))))
+ ,@(mapcar (lambda (case)
+ `(,(first case)
+ ,@(generate-number-dispatch (rest vars)
+ (rest error-tags)
+ (cdr case))))
cases)
(t (go ,(first error-tags))))))
cases))
nil
(macrolet ((foo (&rest stuff)
`(typecase obj2
- ,@(mapcar #'(lambda (foo)
- (let ((type (car foo))
- (fn (cadr foo)))
- `(,type
- (and (typep obj1 ',type)
- (,fn obj1 obj2)))))
+ ,@(mapcar (lambda (foo)
+ (let ((type (car foo))
+ (fn (cadr foo)))
+ `(,type
+ (and (typep obj1 ',type)
+ (,fn obj1 obj2)))))
stuff))))
(foo
(single-float eql)
(inherited-symbol-p (gensym))
(BLOCK (gensym)))
`(let* ((,these-packages ,package-list)
- (,packages `,(mapcar #'(lambda (package)
- (if (packagep package)
- package
- (find-package package)))
+ (,packages `,(mapcar (lambda (package)
+ (if (packagep package)
+ package
+ (find-package package)))
(if (consp ,these-packages)
,these-packages
(list ,these-packages))))
(car ,',packages))))
(when ,symbols
(setf ,',vector (package-hashtable-table ,symbols))
- (setf ,',hash-vector (package-hashtable-hash ,symbols)))))
+ (setf ,',hash-vector
+ (package-hashtable-hash ,symbols)))))
(:external
`(let ((,symbols (package-external-symbols
(car ,',packages))))
(backq-unparse (car tail) t)))
(push (backq-unparse (car tail)) accum)))
(backq-append
- (mapcan #'(lambda (el) (backq-unparse el t))
+ (mapcan (lambda (el) (backq-unparse el t))
(cdr form)))
(backq-nconc
- (mapcan #'(lambda (el) (backq-unparse el :nconc))
+ (mapcan (lambda (el) (backq-unparse el :nconc))
(cdr form)))
(backq-cons
(cons (backq-unparse (cadr form) nil)
(pprint-dispatch-entry-priority e2)))))
(macrolet ((frob (x)
- `(cons ',x #'(lambda (object) ,x))))
+ `(cons ',x (lambda (object) ,x))))
(defvar *precompiled-pprint-dispatch-funs*
(list (frob (typep object 'array))
(frob (and (consp object)
(destructuring-bind (type) (cdr type)
`(not ,(compute-test-expr type object))))
(and
- `(and ,@(mapcar #'(lambda (type)
- (compute-test-expr type object))
+ `(and ,@(mapcar (lambda (type)
+ (compute-test-expr type object))
(cdr type))))
(or
- `(or ,@(mapcar #'(lambda (type)
- (compute-test-expr type object))
+ `(or ,@(mapcar (lambda (type)
+ (compute-test-expr type object))
(cdr type))))
(t
`(typep ,object ',type)))
(new (make-pprint-dispatch-table
:entries (copy-list (pprint-dispatch-table-entries orig))))
(new-cons-entries (pprint-dispatch-table-cons-entries new)))
- (maphash #'(lambda (key value)
- (setf (gethash key new-cons-entries) value))
+ (maphash (lambda (key value)
+ (setf (gethash key new-cons-entries) value))
(pprint-dispatch-table-cons-entries orig))
new))
(return entry)))))
(if entry
(values (pprint-dispatch-entry-fun entry) t)
- (values #'(lambda (stream object)
- (output-ugly-object object stream))
+ (values (lambda (stream object)
+ (output-ugly-object object stream))
nil))))
(defun set-pprint-dispatch (type function &optional
*READ-EVAL* T
*READ-SUPPRESS* NIL
*READTABLE* the standard readtable"
- `(%with-standard-io-syntax #'(lambda () ,@body)))
+ `(%with-standard-io-syntax (lambda () ,@body)))
(defun %with-standard-io-syntax (function)
(let ((*package* (find-package "COMMON-LISP-USER"))
(when environment-name (compact-environment-aux environment-name 200))
(let ((*gc-notify-before*
- #'(lambda (notify-stream bytes-in-use)
- (declare (ignore bytes-in-use))
- (write-string "[doing purification: " notify-stream)
- (force-output notify-stream)))
+ (lambda (notify-stream bytes-in-use)
+ (declare (ignore bytes-in-use))
+ (write-string "[doing purification: " notify-stream)
+ (force-output notify-stream)))
(*internal-gc*
- #'(lambda ()
- (%purify (get-lisp-obj-address root-structures)
- (get-lisp-obj-address nil))))
+ (lambda ()
+ (%purify (get-lisp-obj-address root-structures)
+ (get-lisp-obj-address nil))))
(*gc-notify-after*
- #'(lambda (notify-stream &rest ignore)
- (declare (ignore ignore))
- (write-line "done]" notify-stream))))
+ (lambda (notify-stream &rest ignore)
+ (declare (ignore ignore))
+ (write-line "done]" notify-stream))))
(gc))
nil)
(replace (character-macro-table really-to-readtable)
(character-macro-table really-from-readtable))
(setf (dispatch-tables really-to-readtable)
- (mapcar #'(lambda (pair) (cons (car pair)
- (copy-seq (cdr pair))))
+ (mapcar (lambda (pair) (cons (car pair)
+ (copy-seq (cdr pair))))
(dispatch-tables really-from-readtable)))
(setf (readtable-case really-to-readtable)
(readtable-case really-from-readtable))
(let ((sizes (make-array 256 :initial-element 0 :element-type 'fixnum))
(counts (make-array 256 :initial-element 0 :element-type 'fixnum)))
(map-allocated-objects
- #'(lambda (obj type size)
- (declare (fixnum size) (optimize (speed 3) (safety 0)) (ignore obj))
- (incf (aref sizes type) size)
- (incf (aref counts type)))
+ (lambda (obj type size)
+ (declare (fixnum size) (optimize (speed 3) (safety 0)) (ignore obj))
+ (incf (aref sizes type) size)
+ (incf (aref counts type)))
space)
(let ((totals (make-hash-table :test 'eq)))
(list total-size total-count name))))))))
(collect ((totals-list))
- (maphash #'(lambda (k v)
- (declare (ignore k))
- (totals-list v))
+ (maphash (lambda (k v)
+ (declare (ignore k))
+ (totals-list v))
totals)
(sort (totals-list) #'> :key #'first)))))
(gethash (third total) summary))))
(collect ((summary-totals))
- (maphash #'(lambda (k v)
- (declare (ignore k))
- (let ((sum 0))
- (declare (fixnum sum))
- (dolist (space-total v)
- (incf sum (first (cdr space-total))))
- (summary-totals (cons sum v))))
+ (maphash (lambda (k v)
+ (declare (ignore k))
+ (let ((sum 0))
+ (declare (fixnum sum))
+ (dolist (space-total v)
+ (incf sum (first (cdr space-total))))
+ (summary-totals (cons sum v))))
summary)
(format t "~2&Summary of spaces: ~(~{~A ~}~)~%" spaces)
(let* ((spaces (if (eq count-spaces t)
'(:static :dynamic :read-only)
count-spaces))
- (totals (mapcar #'(lambda (space)
- (cons space (type-breakdown space)))
+ (totals (mapcar (lambda (space)
+ (cons space (type-breakdown space)))
spaces)))
(dolist (space-total totals)
(declare (fixnum code-words no-ops)
(type unsigned-byte total-bytes))
(map-allocated-objects
- #'(lambda (obj type size)
- (declare (fixnum size) (optimize (safety 0)))
- (when (eql type code-header-widetag)
- (incf total-bytes size)
- (let ((words (truly-the fixnum (%code-code-size obj)))
- (sap (truly-the system-area-pointer
- (%primitive code-instructions obj))))
- (incf code-words words)
- (dotimes (i words)
- (when (zerop (sap-ref-32 sap (* i n-word-bytes)))
- (incf no-ops))))))
+ (lambda (obj type size)
+ (declare (fixnum size) (optimize (safety 0)))
+ (when (eql type code-header-widetag)
+ (incf total-bytes size)
+ (let ((words (truly-the fixnum (%code-code-size obj)))
+ (sap (truly-the system-area-pointer
+ (%primitive code-instructions obj))))
+ (incf code-words words)
+ (dotimes (i words)
+ (when (zerop (sap-ref-32 sap (* i n-word-bytes)))
+ (incf no-ops))))))
space)
(format t
(dolist (space (or spaces '(:read-only :static :dynamic)))
(declare (inline map-allocated-objects))
(map-allocated-objects
- #'(lambda (obj type size)
- (declare (fixnum size) (optimize (safety 0)))
- (case type
- (#.code-header-widetag
- (let ((inst-words (truly-the fixnum (%code-code-size obj))))
- (declare (type fixnum inst-words))
- (incf non-descriptor-bytes (* inst-words n-word-bytes))
- (incf descriptor-words
- (- (truncate size n-word-bytes) inst-words))))
- ((#.bignum-widetag
- #.single-float-widetag
- #.double-float-widetag
- #.simple-string-widetag
- #.simple-bit-vector-widetag
- #.simple-array-unsigned-byte-2-widetag
- #.simple-array-unsigned-byte-4-widetag
- #.simple-array-unsigned-byte-8-widetag
- #.simple-array-unsigned-byte-16-widetag
- #.simple-array-unsigned-byte-32-widetag
- #.simple-array-signed-byte-8-widetag
- #.simple-array-signed-byte-16-widetag
- #.simple-array-signed-byte-30-widetag
- #.simple-array-signed-byte-32-widetag
- #.simple-array-single-float-widetag
- #.simple-array-double-float-widetag
- #.simple-array-complex-single-float-widetag
- #.simple-array-complex-double-float-widetag)
- (incf non-descriptor-headers)
- (incf non-descriptor-bytes (- size n-word-bytes)))
- ((#.list-pointer-lowtag
- #.instance-pointer-lowtag
- #.ratio-widetag
- #.complex-widetag
- #.simple-array-widetag
- #.simple-vector-widetag
- #.complex-string-widetag
- #.complex-bit-vector-widetag
- #.complex-vector-widetag
- #.complex-array-widetag
- #.closure-header-widetag
- #.funcallable-instance-header-widetag
- #.value-cell-header-widetag
- #.symbol-header-widetag
- #.sap-widetag
- #.weak-pointer-widetag
- #.instance-header-widetag)
- (incf descriptor-words (truncate size n-word-bytes)))
- (t
- (error "bogus widetag: ~W" type))))
+ (lambda (obj type size)
+ (declare (fixnum size) (optimize (safety 0)))
+ (case type
+ (#.code-header-widetag
+ (let ((inst-words (truly-the fixnum (%code-code-size obj))))
+ (declare (type fixnum inst-words))
+ (incf non-descriptor-bytes (* inst-words n-word-bytes))
+ (incf descriptor-words
+ (- (truncate size n-word-bytes) inst-words))))
+ ((#.bignum-widetag
+ #.single-float-widetag
+ #.double-float-widetag
+ #.simple-string-widetag
+ #.simple-bit-vector-widetag
+ #.simple-array-unsigned-byte-2-widetag
+ #.simple-array-unsigned-byte-4-widetag
+ #.simple-array-unsigned-byte-8-widetag
+ #.simple-array-unsigned-byte-16-widetag
+ #.simple-array-unsigned-byte-32-widetag
+ #.simple-array-signed-byte-8-widetag
+ #.simple-array-signed-byte-16-widetag
+ #.simple-array-signed-byte-30-widetag
+ #.simple-array-signed-byte-32-widetag
+ #.simple-array-single-float-widetag
+ #.simple-array-double-float-widetag
+ #.simple-array-complex-single-float-widetag
+ #.simple-array-complex-double-float-widetag)
+ (incf non-descriptor-headers)
+ (incf non-descriptor-bytes (- size n-word-bytes)))
+ ((#.list-pointer-lowtag
+ #.instance-pointer-lowtag
+ #.ratio-widetag
+ #.complex-widetag
+ #.simple-array-widetag
+ #.simple-vector-widetag
+ #.complex-string-widetag
+ #.complex-bit-vector-widetag
+ #.complex-vector-widetag
+ #.complex-array-widetag
+ #.closure-header-widetag
+ #.funcallable-instance-header-widetag
+ #.value-cell-header-widetag
+ #.symbol-header-widetag
+ #.sap-widetag
+ #.weak-pointer-widetag
+ #.instance-header-widetag)
+ (incf descriptor-words (truncate size n-word-bytes)))
+ (t
+ (error "bogus widetag: ~W" type))))
space))
(format t "~:D words allocated for descriptor objects.~%"
descriptor-words)
(total-bytes 0))
(declare (fixnum total-objects total-bytes))
(map-allocated-objects
- #'(lambda (obj type size)
- (declare (fixnum size) (optimize (speed 3) (safety 0)))
- (when (eql type instance-header-widetag)
- (incf total-objects)
- (incf total-bytes size)
- (let* ((class (layout-class (%instance-ref obj 0)))
- (found (gethash class totals)))
- (cond (found
- (incf (the fixnum (car found)))
- (incf (the fixnum (cdr found)) size))
- (t
- (setf (gethash class totals) (cons 1 size)))))))
+ (lambda (obj type size)
+ (declare (fixnum size) (optimize (speed 3) (safety 0)))
+ (when (eql type instance-header-widetag)
+ (incf total-objects)
+ (incf total-bytes size)
+ (let* ((class (layout-class (%instance-ref obj 0)))
+ (found (gethash class totals)))
+ (cond (found
+ (incf (the fixnum (car found)))
+ (incf (the fixnum (cdr found)) size))
+ (t
+ (setf (gethash class totals) (cons 1 size)))))))
space)
(collect ((totals-list))
- (maphash #'(lambda (class what)
- (totals-list (cons (prin1-to-string
- (class-proper-name class))
- what)))
+ (maphash (lambda (class what)
+ (totals-list (cons (prin1-to-string
+ (class-proper-name class))
+ what)))
totals)
(let ((sorted (sort (totals-list) #'> :key #'cddr))
(printed-bytes 0)
(declare (type (or null (unsigned-byte 32)) start-addr)
(type (unsigned-byte 32) total-bytes))
(map-allocated-objects
- #'(lambda (object typecode bytes)
- (declare (ignore typecode)
- (type (unsigned-byte 32) bytes))
- (if (and (consp object)
- (eql (car object) 0)
- (eql (cdr object) 0))
- (if start-addr
- (incf total-bytes bytes)
- (setf start-addr (sb!di::get-lisp-obj-address object)
- total-bytes bytes))
- (when start-addr
- (format t "~:D bytes at #X~X~%" total-bytes start-addr)
- (setf start-addr nil))))
+ (lambda (object typecode bytes)
+ (declare (ignore typecode)
+ (type (unsigned-byte 32) bytes))
+ (if (and (consp object)
+ (eql (car object) 0)
+ (eql (cdr object) 0))
+ (if start-addr
+ (incf total-bytes bytes)
+ (setf start-addr (sb!di::get-lisp-obj-address object)
+ total-bytes bytes))
+ (when start-addr
+ (format t "~:D bytes at #X~X~%" total-bytes start-addr)
+ (setf start-addr nil))))
space)
(when start-addr
(format t "~:D bytes at #X~X~%" total-bytes start-addr))))
(note-conses (car x))
(note-conses (cdr x)))))
(map-allocated-objects
- #'(lambda (obj obj-type size)
- (declare (optimize (safety 0)))
- (let ((addr (get-lisp-obj-address obj)))
- (when (>= addr start)
- (when (if count
- (> count-so-far count)
- (> pages-so-far pages))
- (return-from print-allocated-objects (values)))
-
- (unless count
- (let ((this-page (* (the (values (unsigned-byte 32) t)
- (truncate addr pagesize))
- pagesize)))
- (declare (type (unsigned-byte 32) this-page))
- (when (/= this-page last-page)
- (when (< pages-so-far pages)
- ;; FIXME: What is this? (ERROR "Argh..")? or
- ;; a warning? or code that can be removed
- ;; once the system is stable? or what?
- (format stream "~2&**** Page ~W, address ~X:~%"
- pages-so-far addr))
- (setq last-page this-page)
- (incf pages-so-far))))
-
- (when (and (or (not type) (eql obj-type type))
- (or (not smaller) (<= size smaller))
- (or (not larger) (>= size larger)))
- (incf count-so-far)
- (case type
- (#.code-header-widetag
- (let ((dinfo (%code-debug-info obj)))
- (format stream "~&Code object: ~S~%"
- (if dinfo
- (sb!c::compiled-debug-info-name dinfo)
- "No debug info."))))
- (#.symbol-header-widetag
- (format stream "~&~S~%" obj))
- (#.list-pointer-lowtag
- (unless (gethash obj printed-conses)
- (note-conses obj)
- (let ((*print-circle* t)
- (*print-level* 5)
- (*print-length* 10))
- (format stream "~&~S~%" obj))))
- (t
- (fresh-line stream)
- (let ((str (write-to-string obj :level 5 :length 10
- :pretty nil)))
- (unless (eql type instance-header-widetag)
- (format stream "~S: " (type-of obj)))
- (format stream "~A~%"
- (subseq str 0 (min (length str) 60))))))))))
+ (lambda (obj obj-type size)
+ (declare (optimize (safety 0)))
+ (let ((addr (get-lisp-obj-address obj)))
+ (when (>= addr start)
+ (when (if count
+ (> count-so-far count)
+ (> pages-so-far pages))
+ (return-from print-allocated-objects (values)))
+
+ (unless count
+ (let ((this-page (* (the (values (unsigned-byte 32) t)
+ (truncate addr pagesize))
+ pagesize)))
+ (declare (type (unsigned-byte 32) this-page))
+ (when (/= this-page last-page)
+ (when (< pages-so-far pages)
+ ;; FIXME: What is this? (ERROR "Argh..")? or
+ ;; a warning? or code that can be removed
+ ;; once the system is stable? or what?
+ (format stream "~2&**** Page ~W, address ~X:~%"
+ pages-so-far addr))
+ (setq last-page this-page)
+ (incf pages-so-far))))
+
+ (when (and (or (not type) (eql obj-type type))
+ (or (not smaller) (<= size smaller))
+ (or (not larger) (>= size larger)))
+ (incf count-so-far)
+ (case type
+ (#.code-header-widetag
+ (let ((dinfo (%code-debug-info obj)))
+ (format stream "~&Code object: ~S~%"
+ (if dinfo
+ (sb!c::compiled-debug-info-name dinfo)
+ "No debug info."))))
+ (#.symbol-header-widetag
+ (format stream "~&~S~%" obj))
+ (#.list-pointer-lowtag
+ (unless (gethash obj printed-conses)
+ (note-conses obj)
+ (let ((*print-circle* t)
+ (*print-level* 5)
+ (*print-length* 10))
+ (format stream "~&~S~%" obj))))
+ (t
+ (fresh-line stream)
+ (let ((str (write-to-string obj :level 5 :length 10
+ :pretty nil)))
+ (unless (eql type instance-header-widetag)
+ (format stream "~S: " (type-of obj)))
+ (format stream "~A~%"
+ (subseq str 0 (min (length str) 60))))))))))
space))))
(values))
\f
(collect ((counted 0 1+))
(let ((res ()))
(map-allocated-objects
- #'(lambda (obj obj-type size)
- (declare (optimize (safety 0)))
- (when (and (or (not type) (eql obj-type type))
- (or (not smaller) (<= size smaller))
- (or (not larger) (>= size larger))
- (or (not test) (funcall test obj)))
- (setq res (maybe-cons space obj res))
- (when (and count (>= (counted) count))
- (return-from list-allocated-objects res))))
+ (lambda (obj obj-type size)
+ (declare (optimize (safety 0)))
+ (when (and (or (not type) (eql obj-type type))
+ (or (not smaller) (<= size smaller))
+ (or (not larger) (>= size larger))
+ (or (not test) (funcall test obj)))
+ (setq res (maybe-cons space obj res))
+ (when (and count (>= (counted) count))
+ (return-from list-allocated-objects res))))
space)
res)))
(flet ((res (x)
(setq res (maybe-cons space x res))))
(map-allocated-objects
- #'(lambda (obj obj-type size)
- (declare (optimize (safety 0)) (ignore obj-type size))
- (typecase obj
- (cons
- (when (or (eq (car obj) object) (eq (cdr obj) object))
- (res obj)))
- (instance
- (dotimes (i (%instance-length obj))
- (when (eq (%instance-ref obj i) object)
- (res obj)
- (return))))
- (simple-vector
- (dotimes (i (length obj))
- (when (eq (svref obj i) object)
- (res obj)
- (return))))
- (symbol
- (when (or (eq (symbol-name obj) object)
- (eq (symbol-package obj) object)
- (eq (symbol-plist obj) object)
- (eq (symbol-value obj) object))
- (res obj)))))
+ (lambda (obj obj-type size)
+ (declare (optimize (safety 0)) (ignore obj-type size))
+ (typecase obj
+ (cons
+ (when (or (eq (car obj) object) (eq (cdr obj) object))
+ (res obj)))
+ (instance
+ (dotimes (i (%instance-length obj))
+ (when (eq (%instance-ref obj i) object)
+ (res obj)
+ (return))))
+ (simple-vector
+ (dotimes (i (length obj))
+ (when (eq (svref obj i) object)
+ (res obj)
+ (return))))
+ (symbol
+ (when (or (eq (symbol-name obj) object)
+ (eq (symbol-package obj) object)
+ (eq (symbol-plist obj) object)
+ (eq (symbol-value obj) object))
+ (res obj)))))
space))
res))
(setf handler
(sb-sys:add-fd-handler
descriptor
- :input #'(lambda (fd)
- (declare (ignore fd))
- (loop
- (unless handler
- (return))
- (multiple-value-bind
- (result readable/errno)
- (sb-unix:unix-select (1+ descriptor)
- (ash 1 descriptor)
- 0 0 0)
- (cond ((null result)
- (error "~@<couldn't select on sub-process: ~
+ :input (lambda (fd)
+ (declare (ignore fd))
+ (loop
+ (unless handler
+ (return))
+ (multiple-value-bind
+ (result readable/errno)
+ (sb-unix:unix-select (1+ descriptor)
+ (ash 1 descriptor)
+ 0 0 0)
+ (cond ((null result)
+ (error "~@<couldn't select on sub-process: ~
~2I~_~A~:>"
- (strerror readable/errno)))
- ((zerop result)
- (return))))
- (sb-alien:with-alien ((buf (sb-alien:array
- sb-c-call:char
- 256)))
- (multiple-value-bind
- (count errno)
- (sb-unix:unix-read descriptor
- (alien-sap buf)
- 256)
- (cond ((or (and (null count)
- (eql errno sb-unix:eio))
- (eql count 0))
- (sb-sys:remove-fd-handler handler)
- (setf handler nil)
- (decf (car cookie))
- (sb-unix:unix-close descriptor)
- (return))
- ((null count)
- (sb-sys:remove-fd-handler handler)
- (setf handler nil)
- (decf (car cookie))
- (error
- "~@<couldn't read input from sub-process: ~
+ (strerror readable/errno)))
+ ((zerop result)
+ (return))))
+ (sb-alien:with-alien ((buf (sb-alien:array
+ sb-c-call:char
+ 256)))
+ (multiple-value-bind
+ (count errno)
+ (sb-unix:unix-read descriptor
+ (alien-sap buf)
+ 256)
+ (cond ((or (and (null count)
+ (eql errno sb-unix:eio))
+ (eql count 0))
+ (sb-sys:remove-fd-handler handler)
+ (setf handler nil)
+ (decf (car cookie))
+ (sb-unix:unix-close descriptor)
+ (return))
+ ((null count)
+ (sb-sys:remove-fd-handler handler)
+ (setf handler nil)
+ (decf (car cookie))
+ (error
+ "~@<couldn't read input from sub-process: ~
~2I~_~A~:>"
- (strerror errno)))
- (t
- (sb-kernel:copy-from-system-area
- (alien-sap buf) 0
- string (* sb-vm:vector-data-offset
- sb-vm:n-word-bits)
- (* count sb-vm:n-byte-bits))
- (write-string string stream
- :end count)))))))))))
+ (strerror errno)))
+ (t
+ (sb-kernel:copy-from-system-area
+ (alien-sap buf) 0
+ string (* sb-vm:vector-data-offset
+ sb-vm:n-word-bits)
+ (* count sb-vm:n-byte-bits))
+ (write-string string stream
+ :end count)))))))))))
;;; Find a file descriptor to use for object given the direction.
;;; Returns the descriptor. If object is :STREAM, returns the created
(dotimes (index len)
(setf (elt result-sequence index)
(apply really-fun
- (mapcar #'(lambda (seq) (elt seq index))
+ (mapcar (lambda (seq) (elt seq index))
sequences))))))
result-sequence)
\f
(values sec usec))))
(values 0 0))
(declare (type (unsigned-byte 31) stop-sec stop-usec))
- (with-fd-handler (fd direction #'(lambda (fd)
- (declare (ignore fd))
- (setf usable t)))
+ (with-fd-handler (fd direction (lambda (fd)
+ (declare (ignore fd))
+ (setf usable t)))
(loop
(sub-serve-event to-sec to-usec)
(cond
((null (intersection args sb!xc:lambda-list-keywords))
`(defun (setf ,name) ,arglist
- (declare ,@(mapcar #'(lambda (arg type)
- `(type ,type ,arg))
+ (declare ,@(mapcar (lambda (arg type)
+ `(type ,type ,arg))
arglist
(cons res args)))
(setf (,name ,@(rest arglist)) ,(first arglist))))
(alien-sap (alien-sap alien)))
(finalize
alien
- #'(lambda ()
- (alien-funcall
- (extern-alien "free" (function (values) system-area-pointer))
- alien-sap)))
+ (lambda ()
+ (alien-funcall
+ (extern-alien "free" (function (values) system-area-pointer))
+ alien-sap)))
alien))
(defun note-local-alien-type (info alien)
function
report-function
interactive-function
- (test-function #'(lambda (cond) (declare (ignore cond)) t)))
+ (test-function (lambda (cond) (declare (ignore cond)) t)))
(def!method print-object ((restart restart) stream)
(if *print-escape*
(print-unreadable-object (restart stream :type t :identity t)
(defun restart-report (restart stream)
(funcall (or (restart-report-function restart)
(let ((name (restart-name restart)))
- #'(lambda (stream)
- (if name (format stream "~S" name)
- (format stream "~S" restart)))))
+ (lambda (stream)
+ (if name (format stream "~S" name)
+ (format stream "~S" restart)))))
stream))
(defmacro with-condition-restarts (condition-form restarts-form &body body)
the same restart name, FIND-RESTART will find the first such clause."
`(let ((*restart-clusters*
(cons (list
- ,@(mapcar #'(lambda (binding)
- (unless (or (car binding)
- (member :report-function
- binding
- :test #'eq))
- (warn "Unnamed restart does not have a ~
+ ,@(mapcar (lambda (binding)
+ (unless (or (car binding)
+ (member :report-function
+ binding
+ :test #'eq))
+ (warn "Unnamed restart does not have a ~
report function: ~S"
- binding))
- `(make-restart :name ',(car binding)
- :function ,(cadr binding)
- ,@(cddr binding)))
- bindings))
+ binding))
+ `(make-restart :name ',(car binding)
+ :function ,(cadr binding)
+ ,@(cddr binding)))
+ bindings))
*restart-clusters*)))
,@forms))
returned. It is an error to supply NIL as a name. If CONDITION is specified
and not NIL, then only restarts associated with that condition (or with no
condition) will be returned."
- (find-if #'(lambda (x)
- (or (eq x name)
- (eq (restart-name x) name)))
+ (find-if (lambda (x)
+ (or (eq x name)
+ (eq (restart-name x) name)))
(compute-restarts condition)))
(defun invoke-restart (restart &rest values)
(let ((,temp-var nil))
(tagbody
(restart-bind
- ,(mapcar #'(lambda (datum)
- (let ((name (nth 0 datum))
- (tag (nth 1 datum))
- (keys (nth 2 datum)))
- `(,name #'(lambda (&rest temp)
- (setq ,temp-var temp)
- (go ,tag))
- ,@keys)))
+ ,(mapcar (lambda (datum)
+ (let ((name (nth 0 datum))
+ (tag (nth 1 datum))
+ (keys (nth 2 datum)))
+ `(,name #'(lambda (&rest temp)
+ (setq ,temp-var temp)
+ (go ,tag))
+ ,@keys)))
data)
(return-from ,block-tag
,(munge-restart-case-expression expression data)))
- ,@(mapcan #'(lambda (datum)
- (let ((tag (nth 1 datum))
- (bvl (nth 3 datum))
- (body (nth 4 datum)))
- (list tag
- `(return-from ,block-tag
- (apply #'(lambda ,bvl ,@body)
- ,temp-var)))))
+ ,@(mapcan (lambda (datum)
+ (let ((tag (nth 1 datum))
+ (bvl (nth 3 datum))
+ (body (nth 4 datum)))
+ (list tag
+ `(return-from ,block-tag
+ (apply (lambda ,bvl ,@body)
+ ,temp-var)))))
data)))))))
(defmacro with-simple-restart ((restart-name format-string
(when member-if
(error "ill-formed handler binding: ~S" (first member-if))))
`(let ((*handler-clusters*
- (cons (list ,@(mapcar #'(lambda (x) `(cons ',(car x) ,(cadr x)))
+ (cons (list ,@(mapcar (lambda (x) `(cons ',(car x) ,(cadr x)))
bindings))
*handler-clusters*)))
(multiple-value-prog1
(interpret-bind-defaults () params
(handler-bind
((format-error
- #'(lambda (condition)
- (error 'format-error
- :complaint
- "~A~%while processing indirect format string:"
- :arguments (list condition)
- :print-banner nil
- :control-string string
- :offset (1- end)))))
+ (lambda (condition)
+ (error 'format-error
+ :complaint
+ "~A~%while processing indirect format string:"
+ :arguments (list condition)
+ :print-banner nil
+ :control-string string
+ :offset (1- end)))))
(if atsignp
(setf args (%format stream (next-arg) orig-args args))
(%format stream (next-arg) (next-arg))))))
(if (zerop posn)
(handler-bind
((format-error
- #'(lambda (condition)
- (error 'format-error
- :complaint
+ (lambda (condition)
+ (error
+ 'format-error
+ :complaint
"~A~%while processing indirect format string:"
- :arguments (list condition)
- :print-banner nil
- :control-string string
- :offset (1- end)))))
+ :arguments (list condition)
+ :print-banner nil
+ :control-string string
+ :offset (1- end)))))
(%format stream insides orig-args args))
(interpret-directive-list stream insides
orig-args args)))
(if per-line-p
(pprint-logical-block
(stream arg :per-line-prefix prefix :suffix suffix)
- (let ((*logical-block-popper* #'(lambda () (pprint-pop))))
+ (let ((*logical-block-popper* (lambda () (pprint-pop))))
(catch 'up-and-out
(interpret-directive-list stream insides
(if atsignp orig-args arg)
arg))))
(pprint-logical-block (stream arg :prefix prefix :suffix suffix)
- (let ((*logical-block-popper* #'(lambda () (pprint-pop))))
+ (let ((*logical-block-popper* (lambda () (pprint-pop))))
(catch 'up-and-out
(interpret-directive-list stream insides
(if atsignp orig-args arg)
#!+sb-doc
"Return a list of all existing packages."
(let ((res ()))
- (maphash #'(lambda (k v)
- (declare (ignore k))
- (pushnew v res))
+ (maphash (lambda (k v)
+ (declare (ignore k))
+ (pushnew v res))
*package-names*)
res))
\f
"Return a list of all symbols in the system having the specified name."
(let ((string (string string-or-symbol))
(res ()))
- (maphash #'(lambda (k v)
- (declare (ignore k))
- (multiple-value-bind (s w) (find-symbol string v)
- (when w (pushnew s res))))
+ (maphash (lambda (k v)
+ (declare (ignore k))
+ (multiple-value-bind (s w) (find-symbol string v)
+ (when w (pushnew s res))))
*package-names*)
res))
\f
(let ((pieces1 (pattern-pieces pattern1))
(pieces2 (pattern-pieces pattern2)))
(and (= (length pieces1) (length pieces2))
- (every #'(lambda (piece1 piece2)
- (typecase piece1
- (simple-string
- (and (simple-string-p piece2)
- (string= piece1 piece2)))
- (cons
- (and (consp piece2)
- (eq (car piece1) (car piece2))
- (string= (cdr piece1) (cdr piece2))))
- (t
- (eq piece1 piece2))))
+ (every (lambda (piece1 piece2)
+ (typecase piece1
+ (simple-string
+ (and (simple-string-p piece2)
+ (string= piece1 piece2)))
+ (cons
+ (and (consp piece2)
+ (eq (car piece1) (car piece2))
+ (string= (cdr piece1) (cdr piece2))))
+ (t
+ (eq piece1 piece2))))
pieces1
pieces2))))
-;;; If the string matches the pattern returns the multiple values T and a
-;;; list of the matched strings.
+;;; If the string matches the pattern returns the multiple values T
+;;; and a list of the matched strings.
(defun pattern-matches (pattern string)
(declare (type pattern pattern)
(type simple-string string))
(typecase thing
(pattern
(make-pattern
- (mapcar #'(lambda (piece)
- (typecase piece
- (simple-base-string
- (funcall fun piece))
- (cons
- (case (car piece)
- (:character-set
- (cons :character-set
- (funcall fun (cdr piece))))
- (t
- piece)))
- (t
- piece)))
+ (mapcar (lambda (piece)
+ (typecase piece
+ (simple-base-string
+ (funcall fun piece))
+ (cons
+ (case (car piece)
+ (:character-set
+ (cons :character-set
+ (funcall fun (cdr piece))))
+ (t
+ piece)))
+ (t
+ piece)))
(pattern-pieces thing))))
(list
(mapcar fun thing))
(let ((any-uppers (check-for #'upper-case-p thing))
(any-lowers (check-for #'lower-case-p thing)))
(cond ((and any-uppers any-lowers)
- ;; Mixed case, stays the same.
+ ;; mixed case, stays the same
thing)
(any-uppers
- ;; All uppercase, becomes all lower case.
- (diddle-with #'(lambda (x) (if (stringp x)
- (string-downcase x)
- x)) thing))
+ ;; all uppercase, becomes all lower case
+ (diddle-with (lambda (x) (if (stringp x)
+ (string-downcase x)
+ x)) thing))
(any-lowers
- ;; All lowercase, becomes all upper case.
+ ;; all lowercase, becomes all upper case
(diddle-with #'(lambda (x) (if (stringp x)
(string-upcase x)
x)) thing))
(t
- ;; No letters? I guess just leave it.
+ ;; no letters? I guess just leave it.
thing))))
thing))
(collect ((subs))
(loop
(unless source
- (unless (every #'(lambda (x) (eq x :wild-inferiors)) from)
+ (unless (every (lambda (x) (eq x :wild-inferiors)) from)
(didnt-match-error orig-source orig-from))
(subs ())
(return))
(defmacro time (form)
#!+sb-doc
"Execute FORM and print timing information on *TRACE-OUTPUT*."
- `(%time #'(lambda () ,form)))
+ `(%time (lambda () ,form)))
;;; Return all the data that we want TIME to report.
(defun time-get-sys-info ()
(defmacro define-conditional-vop (translate &rest generator)
`(progn
- ,@(mapcar #'(lambda (suffix cost signed)
- (unless (and (member suffix '(/fixnum -c/fixnum))
- (eq translate 'eql))
- `(define-vop (,(intern (format nil "~:@(FAST-IF-~A~A~)"
- translate suffix))
- ,(intern
- (format nil "~:@(FAST-CONDITIONAL~A~)"
- suffix)))
- (:translate ,translate)
- (:generator ,cost
- (let* ((signed ,signed)
- (-c/fixnum ,(eq suffix '-c/fixnum))
- (y (if -c/fixnum (fixnumize y) y)))
- ,@generator)))))
+ ,@(mapcar (lambda (suffix cost signed)
+ (unless (and (member suffix '(/fixnum -c/fixnum))
+ (eq translate 'eql))
+ `(define-vop (,(intern (format nil "~:@(FAST-IF-~A~A~)"
+ translate suffix))
+ ,(intern
+ (format nil "~:@(FAST-CONDITIONAL~A~)"
+ suffix)))
+ (:translate ,translate)
+ (:generator ,cost
+ (let* ((signed ,signed)
+ (-c/fixnum ,(eq suffix '-c/fixnum))
+ (y (if -c/fixnum (fixnumize y) y)))
+ ,@generator)))))
'(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
'(3 2 5 4 5 4)
'(t t t t nil nil))))
(define-full-reffer ,(symbolicate "DATA-VECTOR-REF/" type)
,type
vector-data-offset other-pointer-lowtag
- ,(remove-if #'(lambda (x) (member x '(null zero))) scs)
+ ,(remove-if (lambda (x) (member x '(null zero))) scs)
,element-type
data-vector-ref)
(define-full-setter ,(symbolicate "DATA-VECTOR-SET/" type)
nargs-pass)
,@(when variable
- (mapcar #'(lambda (name offset)
- `(:temporary (:sc descriptor-reg
- :offset ,offset
- :to :eval)
- ,name))
+ (mapcar (lambda (name offset)
+ `(:temporary (:sc descriptor-reg
+ :offset ,offset
+ :to :eval)
+ ,name))
register-arg-names *register-arg-offsets*))
,@(when (eq return :fixed)
'((:temporary (:scs (descriptor-reg) :from :eval) move-temp)))
,@(if variable
`((inst subq csp-tn new-fp nargs-pass)
,@(let ((index -1))
- (mapcar #'(lambda (name)
- `(inst ldl ,name
- ,(ash (incf index)
- word-shift)
- new-fp))
+ (mapcar (lambda (name)
+ `(inst ldl ,name
+ ,(ash (incf index)
+ word-shift)
+ new-fp))
register-arg-names)))
'((inst li (fixnumize nargs) nargs-pass))))
,@(if (eq return :tail)
,@(when translate
`((:policy :fast-safe)
(:translate ,translate)))
- (:args ,@(mapcar #'(lambda (arg)
- `(,arg :scs (any-reg descriptor-reg)))
+ (:args ,@(mapcar (lambda (arg)
+ `(,arg :scs (any-reg descriptor-reg)))
args))
(:vop-var vop)
(:save-p :compute-only)
(defparameter reg-symbols
(map 'vector
- #'(lambda (name)
- (cond ((null name) nil)
- (t (make-symbol (concatenate 'string "$" name)))))
+ (lambda (name)
+ (cond ((null name) nil)
+ (t (make-symbol (concatenate 'string "$" name)))))
*register-names*))
(sb!disassem:define-argument-type reg
- :printer #'(lambda (value stream dstate)
- (declare (stream stream) (fixnum value))
- (let ((regname (aref reg-symbols value)))
- (princ regname stream)
- (sb!disassem:maybe-note-associated-storage-ref
- value
- 'registers
- regname
- dstate))))
+ :printer (lambda (value stream dstate)
+ (declare (stream stream) (fixnum value))
+ (let ((regname (aref reg-symbols value)))
+ (princ regname stream)
+ (sb!disassem:maybe-note-associated-storage-ref
+ value
+ 'registers
+ regname
+ dstate))))
(defparameter float-reg-symbols
(coerce
'vector))
(sb!disassem:define-argument-type fp-reg
- :printer #'(lambda (value stream dstate)
- (declare (stream stream) (fixnum value))
- (let ((regname (aref float-reg-symbols value)))
- (princ regname stream)
- (sb!disassem:maybe-note-associated-storage-ref
- value
- 'float-registers
- regname
- dstate))))
+ :printer (lambda (value stream dstate)
+ (declare (stream stream) (fixnum value))
+ (let ((regname (aref float-reg-symbols value)))
+ (princ regname stream)
+ (sb!disassem:maybe-note-associated-storage-ref
+ value
+ 'float-registers
+ regname
+ dstate))))
(sb!disassem:define-argument-type relative-label
:sign-extend t
- :use-label #'(lambda (value dstate)
- (declare (type (signed-byte 21) value)
- (type sb!disassem:disassem-state dstate))
- (+ (ash value 2) (sb!disassem:dstate-cur-addr dstate))))
+ :use-label (lambda (value dstate)
+ (declare (type (signed-byte 21) value)
+ (type sb!disassem:disassem-state dstate))
+ (+ (ash value 2) (sb!disassem:dstate-cur-addr dstate))))
\f
'((ra nil :type 'fp-reg)))))
(:emitter
(emit-back-patch segment 4
- #'(lambda (segment posn)
- (emit-branch segment ,op
- ,@(if float
- '((fp-reg-tn-encoding ra))
+ (lambda (segment posn)
+ (emit-branch segment ,op
+ ,@(if float
+ '((fp-reg-tn-encoding ra))
'((reg-tn-encoding ra)))
- (ash (- (label-position target)
- (+ posn 4))
- -2))))))))
+ (ash (- (label-position target)
+ (+ posn 4))
+ -2))))))))
(define-branch br #x30)
(define-branch bsr #x34)
(define-branch blbc #x38)
(defun emit-header-data (segment type)
(emit-back-patch
segment 4
- #'(lambda (segment posn)
- (emit-lword segment
- (logior type
- (ash (+ posn (component-header-length))
- (- n-widetag-bits word-shift)))))))
+ (lambda (segment posn)
+ (emit-lword segment
+ (logior type
+ (ash (+ posn (component-header-length))
+ (- n-widetag-bits word-shift)))))))
(define-instruction simple-fun-header-word (segment)
(:cost 0)
(emit-chooser
;; We emit either 12 or 4 bytes, so we maintain 8 byte alignments.
segment 12 3
- #'(lambda (segment posn delta-if-after)
- (let ((delta (funcall calc label posn delta-if-after)))
- (when (<= (- (ash 1 15)) delta (1- (ash 1 15)))
- (emit-back-patch segment 4
- #'(lambda (segment posn)
- (assemble (segment vop)
- (inst lda dst
- (funcall calc label posn 0)
- src))))
- t)))
- #'(lambda (segment posn)
- (assemble (segment vop)
- (flet ((se (x n)
- (let ((x (logand x (lognot (ash -1 n)))))
- (if (logbitp (1- n) x)
- (logior (ash -1 (1- n)) x)
- x))))
- (let* ((value (se (funcall calc label posn 0) 32))
- (low (ldb (byte 16 0) value))
- (tmp1 (- value (se low 16)))
- (high (ldb (byte 16 16) tmp1))
- (tmp2 (- tmp1 (se (ash high 16) 32)))
- (extra 0))
- (unless (= tmp2 0)
- (setf extra #x4000)
- (setf tmp1 (- tmp1 #x40000000))
- (setf high (ldb (byte 16 16) tmp1)))
- (inst lda dst low src)
- (inst ldah dst extra dst)
- (inst ldah dst high dst)))))))
+ (lambda (segment posn delta-if-after)
+ (let ((delta (funcall calc label posn delta-if-after)))
+ (when (<= (- (ash 1 15)) delta (1- (ash 1 15)))
+ (emit-back-patch segment 4
+ (lambda (segment posn)
+ (assemble (segment vop)
+ (inst lda dst
+ (funcall calc label posn 0)
+ src))))
+ t)))
+ (lambda (segment posn)
+ (assemble (segment vop)
+ (flet ((se (x n)
+ (let ((x (logand x (lognot (ash -1 n)))))
+ (if (logbitp (1- n) x)
+ (logior (ash -1 (1- n)) x)
+ x))))
+ (let* ((value (se (funcall calc label posn 0) 32))
+ (low (ldb (byte 16 0) value))
+ (tmp1 (- value (se low 16)))
+ (high (ldb (byte 16 16) tmp1))
+ (tmp2 (- tmp1 (se (ash high 16) 32)))
+ (extra 0))
+ (unless (= tmp2 0)
+ (setf extra #x4000)
+ (setf tmp1 (- tmp1 #x40000000))
+ (setf high (ldb (byte 16 16) tmp1)))
+ (inst lda dst low src)
+ (inst ldah dst extra dst)
+ (inst ldah dst high dst)))))))
;; code = fn - header - label-offset + other-pointer-tag
(define-instruction compute-code-from-fn (segment dst src label temp)
(:vop-var vop)
(:emitter
(emit-compute-inst segment vop dst src label temp
- #'(lambda (label posn delta-if-after)
- (- other-pointer-lowtag
- (label-position label posn delta-if-after)
- (component-header-length))))))
+ (lambda (label posn delta-if-after)
+ (- other-pointer-lowtag
+ (label-position label posn delta-if-after)
+ (component-header-length))))))
;; code = lra - other-pointer-tag - header - label-offset + other-pointer-tag
;; = lra - (header + label-offset)
(:vop-var vop)
(:emitter
(emit-compute-inst segment vop dst src label temp
- #'(lambda (label posn delta-if-after)
- (- (+ (label-position label posn delta-if-after)
- (component-header-length)))))))
+ (lambda (label posn delta-if-after)
+ (- (+ (label-position label posn delta-if-after)
+ (component-header-length)))))))
;; lra = code + other-pointer-tag + header + label-offset - other-pointer-tag
(define-instruction compute-lra-from-code (segment dst src label temp)
(:vop-var vop)
(:emitter
(emit-compute-inst segment vop dst src label temp
- #'(lambda (label posn delta-if-after)
- (+ (label-position label posn delta-if-after)
- (component-header-length))))))
+ (lambda (label posn delta-if-after)
+ (+ (label-position label posn delta-if-after)
+ (component-header-length))))))
(inst gentrap ,kind)
(with-adjustable-vector (,vector)
(write-var-integer (error-number-or-lose ',code) ,vector)
- ,@(mapcar #'(lambda (tn)
- `(let ((tn ,tn))
- (write-var-integer (make-sc-offset (sc-number
- (tn-sc tn))
- (tn-offset tn))
- ,vector)))
+ ,@(mapcar (lambda (tn)
+ `(let ((tn ,tn))
+ (write-var-integer (make-sc-offset (sc-number
+ (tn-sc tn))
+ (tn-offset tn))
+ ,vector)))
values)
(inst byte (length ,vector))
(dotimes (i (length ,vector))
(error "must supply at least one type for test-type"))
(cond
(fixnump
- (when (remove-if #'(lambda (x)
- (or (= x even-fixnum-lowtag)
- (= x odd-fixnum-lowtag)))
+ (when (remove-if (lambda (x)
+ (or (= x even-fixnum-lowtag)
+ (= x odd-fixnum-lowtag)))
lowtags)
(error "can't mix fixnum testing with other lowtags"))
(when function-p
(let ((offset-sym (symbolicate name "-OFFSET")))
`(eval-when (:compile-toplevel :load-toplevel :execute)
(defconstant ,offset-sym ,offset)
- (setf (svref *register-names* ,offset-sym) ,(symbol-name name)))))
+ (setf (svref *register-names* ,offset-sym)
+ ,(symbol-name name)))))
(defregset (name &rest regs)
`(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter ,name
- (list ,@(mapcar #'(lambda (name)
- (symbolicate name "-OFFSET"))
+ (list ,@(mapcar (lambda (name)
+ (symbolicate name "-OFFSET"))
regs))))))
;; c.f. src/runtime/alpha-lispregs.h
;;; a list of TN's describing the register arguments
(defparameter *register-arg-tns*
- (mapcar #'(lambda (n)
- (make-random-tn :kind :normal
- :sc (sc-or-lose 'descriptor-reg)
- :offset n))
+ (mapcar (lambda (n)
+ (make-random-tn :kind :normal
+ :sc (sc-or-lose 'descriptor-reg)
+ :offset n))
*register-arg-offsets*))
;;; This is used by the debugger.
(n -1))
(once-only ((n-vec `(make-array ,len)))
`(progn
- ,@(mapcar #'(lambda (el)
- (once-only ((n-val el))
- `(locally (declare (optimize (safety 0)))
- (setf (svref ,n-vec ,(incf n))
- ,n-val))))
+ ,@(mapcar (lambda (el)
+ (once-only ((n-val el))
+ `(locally (declare (optimize (safety 0)))
+ (setf (svref ,n-vec ,(incf n))
+ ,n-val))))
elements)
,n-vec))))
'(:initial-element initial-element))))
(setf (%array-displaced-p header) nil)
,@(let ((axis -1))
- (mapcar #'(lambda (dim)
- `(setf (%array-dimension header ,(incf axis))
- ,dim))
+ (mapcar (lambda (dim)
+ `(setf (%array-dimension header ,(incf axis))
+ ,dim))
dims))
(truly-the ,spec header))))))
\f
`((**current-segment** ,seg-var)))
,@(when vop
`((**current-vop** ,vop-var)))
- ,@(mapcar #'(lambda (name)
- `(,name (gen-label)))
+ ,@(mapcar (lambda (name)
+ `(,name (gen-label)))
new-labels))
(symbol-macrolet ((**current-segment** ,seg-var)
(**current-vop** ,vop-var)
,@(when (or inherited-labels nested-labels)
`((..inherited-labels.. ,nested-labels))))
- ,@(mapcar #'(lambda (form)
- (if (label-name-p form)
- `(emit-label ,form)
- form))
+ ,@(mapcar (lambda (form)
+ (if (label-name-p form)
+ `(emit-label ,form)
+ form))
body))))))
#+sb-xc-host
(sb!xc:defmacro assemble ((&optional segment vop &key labels)
`((**current-segment** ,seg-var)))
,@(when vop
`((**current-vop** ,vop-var)))
- ,@(mapcar #'(lambda (name)
- `(,name (gen-label)))
+ ,@(mapcar (lambda (name)
+ `(,name (gen-label)))
new-labels))
(symbol-macrolet ((**current-segment** ,seg-var)
(**current-vop** ,vop-var)
,@(when (or inherited-labels nested-labels)
`((..inherited-labels.. ,nested-labels))))
- ,@(mapcar #'(lambda (form)
- (if (label-name-p form)
- `(emit-label ,form)
- form))
+ ,@(mapcar (lambda (form)
+ (if (label-name-p form)
+ `(emit-label ,form)
+ form))
body))))))
(defmacro inst (&whole whole instruction &rest args &environment env)
reconstructor))))))
(defun extract-nths (index glue list-of-lists-of-lists)
- (mapcar #'(lambda (list-of-lists)
- (cons glue
- (mapcar #'(lambda (list)
- (nth index list))
- list-of-lists)))
+ (mapcar (lambda (list-of-lists)
+ (cons glue
+ (mapcar (lambda (list)
+ (nth index list))
+ list-of-lists)))
list-of-lists-of-lists))
(defmacro define-instruction (name lambda-list &rest options)
:environment env)
`(eval-when (:compile-toplevel :load-toplevel :execute)
(%define-instruction ,(symbol-name name)
- #'(lambda (,whole ,env)
- ,@local-defs
- (block ,name
- ,body)))))))
+ (lambda (,whole ,env)
+ ,@local-defs
+ (block ,name
+ ,body)))))))
(defun %define-instruction (name defun)
(setf (gethash name *assem-instructions*) defun)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter *vm-support-routines* ',routines))
(defstruct (vm-support-routines (:copier nil))
- ,@(mapcar #'(lambda (routine)
- `(,routine nil :type (or function null)))
+ ,@(mapcar (lambda (routine)
+ `(,routine nil :type (or function null)))
routines))
,@(mapcar
- #'(lambda (name)
- `(defun ,name (&rest args)
- (apply (or (,(symbolicate "VM-SUPPORT-ROUTINES-"
- name)
- *backend-support-routines*)
- (error "machine-specific support ~S ~
+ (lambda (name)
+ `(defun ,name (&rest args)
+ (apply (or (,(symbolicate "VM-SUPPORT-ROUTINES-"
+ name)
+ *backend-support-routines*)
+ (error "machine-specific support ~S ~
routine undefined"
- ',name))
- args)))
+ ',name))
+ args)))
routines))))
(def-vm-support-routines
(defun no-function-values-types (type)
(declare (type ctype type))
(multiple-value-bind (res count) (values-types type)
- (values (mapcar #'(lambda (type)
- (if (fun-type-p type)
- (specifier-type 'function)
- type))
+ (values (mapcar (lambda (type)
+ (if (fun-type-p type)
+ (specifier-type 'function)
+ type))
res)
count)))
(if (and (every #'type-check-template types) (not force-hairy))
(values :simple types)
(values :hairy
- (mapcar #'(lambda (x)
- (list nil (maybe-weaken-check x cont) x))
+ (mapcar (lambda (x)
+ (list nil (maybe-weaken-check x cont) x))
types)))
- (let ((res (mapcar #'(lambda (p c)
- (let ((diff (type-difference p c))
- (weak (maybe-weaken-check c cont)))
- (if (and diff
- (< (type-test-cost diff)
- (type-test-cost weak))
- *complement-type-checks*)
- (list t diff c)
- (list nil weak c))))
+ (let ((res (mapcar (lambda (p c)
+ (let ((diff (type-difference p c))
+ (weak (maybe-weaken-check c cont)))
+ (if (and diff
+ (< (type-test-cost diff)
+ (type-test-cost weak))
+ *complement-type-checks*)
+ (list t diff c)
+ (list nil weak c))))
ptypes types)))
(cond ((or force-hairy (find-if #'first res))
(values :hairy res))
(defun make-type-check-form (types)
(let ((temps (make-gensym-list (length types))))
`(multiple-value-bind ,temps 'dummy
- ,@(mapcar #'(lambda (temp type)
- (let* ((spec
- (let ((*unparse-fun-type-simplify* t))
- (type-specifier (second type))))
- (test (if (first type) `(not ,spec) spec)))
- `(unless (typep ,temp ',test)
- (%type-check-error
- ,temp
- ',(type-specifier (third type))))))
+ ,@(mapcar (lambda (temp type)
+ (let* ((spec
+ (let ((*unparse-fun-type-simplify* t))
+ (type-specifier (second type))))
+ (test (if (first type) `(not ,spec) spec)))
+ `(unless (typep ,temp ',test)
+ (%type-check-error
+ ,temp
+ ',(type-specifier (third type))))))
temps
types)
(values ,@temps))))
(types (approximate-fun-type-types type))
(args (combination-args call))
(nargs (length args))
- (allowp (some #'(lambda (x)
- (and (constant-continuation-p x)
- (eq (continuation-value x) :allow-other-keys)))
- args)))
+ (allowp (some (lambda (x)
+ (and (constant-continuation-p x)
+ (eq (continuation-value x) :allow-other-keys)))
+ args)))
(setf (approximate-fun-type-min-args type)
(min (approximate-fun-type-min-args type) nargs))
((null old)
(setf (approximate-fun-type-types type)
(nconc types
- (mapcar #'(lambda (x)
- (list (continuation-type x)))
+ (mapcar (lambda (x)
+ (list (continuation-type x)))
arg))))
(when (null arg) (return))
(pushnew (continuation-type (car arg))
(let ((name (continuation-value key)))
(when (keywordp name)
(let ((old (find-if
- #'(lambda (x)
- (and (eq (approximate-key-info-name x) name)
- (= (approximate-key-info-position x)
- pos)))
+ (lambda (x)
+ (and (eq (approximate-key-info-name x) name)
+ (= (approximate-key-info-position x)
+ pos)))
(keys)))
(val-type (continuation-type val)))
(cond (old
(dolist (key keys)
(unless (find (key-info-name key) arglist
- :key #'(lambda (x)
- (let ((info (lambda-var-arg-info x)))
- (when info
- (arg-info-key info)))))
+ :key (lambda (x)
+ (let ((info (lambda-var-arg-info x)))
+ (when info
+ (arg-info-key info)))))
(note-lossage
"The definition lacks the ~S key present in ~A."
(key-info-name key) where))))
(frob-lambda let (= level 3)))))
(let ((sorted (sort (vars) #'string<
- :key #'(lambda (x)
- (symbol-name (leaf-debug-name (car x))))))
+ :key (lambda (x)
+ (symbol-name (leaf-debug-name (car x))))))
(prev-name nil)
(id 0)
(i 0)
;;; for internal versions, especially for internal versions off the
;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.pre7.123"
+"0.pre7.124"
projects / sbcl.git / commitdiff