0.6.10.21:

	turned 'intern.*concatenate' grep matches to SYMBOLICATE
	T is a self-evaluating constant and doesn't need to be quoted.
	So is NIL.
	hacking MNA "pcl cleanups" megapatch, phase II..
	NAME-GET-FDEFINITION and NAME-SET-FDEFINITION become
		FDEFINITION and (SETF FDEFINITION).

src/code/host-alieneval.lisp

@@ -84,23 +84,20 @@
 ;;; We define a keyword "BOA" constructor so that we can reference the
 ;;; slot names in init forms.
 (def!macro def-alien-type-class ((name &key include include-args) &rest slots)
- (let ((defstruct-name
- (intern (concatenate 'string "ALIEN-" (symbol-name name) "-TYPE"))))
+ (let ((defstruct-name (symbolicate "ALIEN-" name "-TYPE")))
  (multiple-value-bind (include include-defstruct overrides)
  (etypecase include
  (null
  (values nil 'alien-type nil))
  (symbol
  (values
  include
- (intern (concatenate 'string
- "ALIEN-" (symbol-name include) "-TYPE"))
+ (symbolicate "ALIEN-" include "-TYPE")
  nil))
  (list
  (values
  (car include)
- (intern (concatenate 'string
- "ALIEN-" (symbol-name (car include)) "-TYPE"))
+ (symbolicate "ALIEN-" (car include) "-TYPE")
  (cdr include))))
  `(progn
  (eval-when (:compile-toplevel :load-toplevel :execute)
@@ -110,8 +107,7 @@
  (:class ',name)
  ,@overrides)
  (:constructor
- ,(intern (concatenate 'string "MAKE-"
- (string defstruct-name)))
+ ,(symbolicate "MAKE-" defstruct-name)
  (&key class bits alignment
  ,@(mapcar #'(lambda (x)
  (if (atom x) x (car x)))
@@ -120,11 +116,7 @@
  ,@slots)))))
 
 (def!macro def-alien-type-method ((class method) lambda-list &rest body)
- (let ((defun-name (intern (concatenate 'string
- (symbol-name class)
- "-"
- (symbol-name method)
- "-METHOD"))))
+ (let ((defun-name (symbolicate class "-" method "-METHOD")))
  `(progn
  (defun ,defun-name ,lambda-list
  ,@body)

src/code/late-format.lisp

@@ -286,14 +286,10 @@
  `(progn
  (defun ,defun-name (,directive ,directives)
  ,@(if lambda-list
- `((let ,(mapcar #'(lambda (var)
- `(,var
- (,(intern (concatenate
- 'string
- "FORMAT-DIRECTIVE-"
- (symbol-name var))
- (symbol-package 'foo))
- ,directive)))
+ `((let ,(mapcar (lambda (var)
+ `(,var
+ (,(symbolicate "FORMAT-DIRECTIVE-" var)
+ ,directive)))
  (butlast lambda-list))
  ,@body))
  `((declare (ignore ,directive ,directives))

src/code/pprint.lisp

@@ -239,9 +239,7 @@
  (posn 0 :type posn))
 
 (defmacro enqueue (stream type &rest args)
- (let ((constructor (intern (concatenate 'string
- "MAKE-"
- (symbol-name type)))))
+ (let ((constructor (symbolicate "MAKE-" type)))
  (once-only ((stream stream)
  (entry `(,constructor :posn
  (index-posn

src/code/target-format.lisp

@@ -120,14 +120,10 @@
  (defun ,defun-name (stream ,directive ,directives orig-args args)
  (declare (ignorable stream orig-args args))
  ,@(if lambda-list
- `((let ,(mapcar #'(lambda (var)
- `(,var
- (,(intern (concatenate
- 'string
- "FORMAT-DIRECTIVE-"
- (symbol-name var))
- (symbol-package 'foo))
- ,directive)))
+ `((let ,(mapcar (lambda (var)
+ `(,var
+ (,(symbolicate "FORMAT-DIRECTIVE-" var)
+ ,directive)))
  (butlast lambda-list))
  (values (progn ,@body) args)))
  `((declare (ignore ,directive ,directives))

src/pcl/boot.lisp

@@ -112,8 +112,8 @@ bootstrapping.
  (early-name (cadr fns)))
  (setf (gdefinition name)
  (set-function-name
- #'(lambda (&rest args)
-  (apply (the function (name-get-fdefinition early-name)) args))
+ (lambda (&rest args)
+  (apply (fdefinition early-name) args))
  name))))
 ) ; EVAL-WHEN
 
@@ -556,7 +556,7 @@ bootstrapping.
  ;; expression in CAN-OPTIMIZE-ACCESS1. -- WHN 2000-12-30
  ,@(remove nil
  (mapcar (lambda (a s) (and (symbolp s)
- (neq s 't)
+ (neq s t)
  `(%class ,a ,s)))
  parameters
  specializers))
@@ -626,7 +626,7 @@ bootstrapping.
  (extract-declarations (cddr walked-lambda))
  (declare (ignore ignore))
  (when (or next-method-p-p call-next-method-p)
- (setq plist (list* :needs-next-methods-p 't plist)))
+ (setq plist (list* :needs-next-methods-p t plist)))
  (when (some #'cdr slots)
  (multiple-value-bind (slot-name-lists call-list)
  (slot-name-lists-from-slots slots calls)
@@ -1079,18 +1079,18 @@ bootstrapping.
  ;; like :LOAD-TOPLEVEL.
  ((not (listp form)) form)
  ((eq (car form) 'call-next-method)
- (setq call-next-method-p 't)
+ (setq call-next-method-p t)
  form)
  ((eq (car form) 'next-method-p)
- (setq next-method-p-p 't)
+ (setq next-method-p-p t)
  form)
  ((and (eq (car form) 'function)
  (cond ((eq (cadr form) 'call-next-method)
- (setq call-next-method-p 't)
+ (setq call-next-method-p t)
  (setq closurep t)
  form)
  ((eq (cadr form) 'next-method-p)
- (setq next-method-p-p 't)
+ (setq next-method-p-p t)
  (setq closurep t)
  form)
  (t nil))))
@@ -1205,7 +1205,7 @@ bootstrapping.
  pv-table-symbol))
  (when (and (eq *boot-state* 'complete)
  (fboundp gf-spec))
- (let* ((gf (name-get-fdefinition gf-spec))
+ (let* ((gf (fdefinition gf-spec))
  (method (and (generic-function-p gf)
  (find-method gf
  qualifiers
@@ -1305,14 +1305,15 @@ bootstrapping.
  (if (memq x lambda-list-keywords)
  (case x
  (&optional (setq state 'optional))
- (&key (setq keysp 't
+ (&key  (setq keysp t
  state 'key))
- (&allow-other-keys (setq allow-other-keys-p 't))
- (&rest  (setq restp 't
+ (&allow-other-keys (setq allow-other-keys-p t))
+ (&rest  (setq restp t
  state 'rest))
  (&aux (return t))
  (otherwise
- (error "encountered the non-standard lambda list keyword ~S" x)))
+ (error "encountered the non-standard lambda list keyword ~S"
+ x)))
  (ecase state
  (required (incf nrequired))
  (optional (incf noptional))
@@ -1339,14 +1340,16 @@ bootstrapping.
  (old-restp (and old-ftype (sb-kernel:function-type-rest old-ftype)))
  (old-keys (and old-ftype
  (mapcar #'sb-kernel:key-info-name
- (sb-kernel:function-type-keywords old-ftype))))
+ (sb-kernel:function-type-keywords
+ old-ftype))))
  (old-keysp (and old-ftype (sb-kernel:function-type-keyp old-ftype)))
- (old-allowp (and old-ftype (sb-kernel:function-type-allowp old-ftype)))
+ (old-allowp (and old-ftype
+ (sb-kernel:function-type-allowp old-ftype)))
  (keywords (union old-keys (mapcar #'keyword-spec-name keywords))))
- `(function ,(append (make-list nrequired :initial-element 't)
+ `(function ,(append (make-list nrequired :initial-element t)
  (when (plusp noptional)
  (append '(&optional)
- (make-list noptional :initial-element 't)))
+ (make-list noptional :initial-element t)))
  (when (or restp old-restp)
  '(&rest t))
  (when (or keysp old-keysp)
@@ -1456,7 +1459,7 @@ bootstrapping.
  (length (arg-info-metatypes arg-info)))
 
 (defun arg-info-nkeys (arg-info)
- (count-if #'(lambda (x) (neq x 't)) (arg-info-metatypes arg-info)))
+ (count-if #'(lambda (x) (neq x t)) (arg-info-metatypes arg-info)))
 
 ;;; Keep pages clean by not setting if the value is already the same.
 (defmacro esetf (pos val)
@@ -1790,7 +1793,7 @@ bootstrapping.
  metatypes
  arg-info))
  (values (length metatypes) applyp metatypes
- (count-if #'(lambda (x) (neq x 't)) metatypes)
+ (count-if #'(lambda (x) (neq x t)) metatypes)
  arg-info)))
 
 (defun early-make-a-method (class qualifiers arglist specializers initargs doc
@@ -1809,7 +1812,7 @@ bootstrapping.
  (if (every #'(lambda (s) (not (symbolp s))) specializers)
  (setq parsed specializers
  unparsed (mapcar #'(lambda (s)
- (if (eq s 't) 't (class-name s)))
+ (if (eq s t) t (class-name s)))
  specializers))
  (setq unparsed specializers
  parsed ()))
@@ -1877,7 +1880,7 @@ bootstrapping.
 (defun early-method-specializers (early-method &optional objectsp)
  (if (and (listp early-method)
  (eq (car early-method) :early-method))
- (cond ((eq objectsp 't)
+ (cond ((eq objectsp t)
  (or (fourth early-method)
  (setf (fourth early-method)
  (mapcar #'find-class (cadddr (fifth early-method))))))
@@ -1949,7 +1952,7 @@ bootstrapping.
  (or (dolist (m (early-gf-methods generic-function))
  (when (and (or (equal (early-method-specializers m nil)
  specializers)
- (equal (early-method-specializers m 't)
+ (equal (early-method-specializers m t)
  specializers))
  (equal (early-method-qualifiers m) qualifiers))
  (return m)))
@@ -2010,7 +2013,7 @@ bootstrapping.
 
  (dolist (fn *!early-functions*)
  (sb-int:/show fn)
- (setf (gdefinition (car fn)) (name-get-fdefinition (caddr fn))))
+ (setf (gdefinition (car fn)) (fdefinition (caddr fn))))
 
  (dolist (fixup *!generic-function-fixups*)
  (sb-int:/show fixup)
@@ -2021,7 +2024,7 @@ bootstrapping.
  (specializers (second method))
  (method-fn-name (third method))
  (fn-name (or method-fn-name fspec))
- (fn (name-get-fdefinition fn-name))
+ (fn (fdefinition fn-name))
  (initargs
  (list :function
  (set-function-name
@@ -2184,7 +2187,7 @@ bootstrapping.
  (parse-specialized-lambda-list (cdr arglist))
  (values (cons (if (listp arg) (car arg) arg) parameters)
  (cons (if (listp arg) (car arg) arg) lambda-list)
- (cons (if (listp arg) (cadr arg) 't) specializers)
+ (cons (if (listp arg) (cadr arg) t) specializers)
  (cons (if (listp arg) (car arg) arg) required)))))))
 
 (eval-when (:load-toplevel :execute)

src/pcl/braid.lisp

@@ -197,7 +197,7 @@
  (t
  (boot-make-wrapper (length slots) name))))
  (proto nil))
- (when (eq name 't) (setq *the-wrapper-of-t* wrapper))
+ (when (eq name t) (setq *the-wrapper-of-t* wrapper))
  (set (intern (format nil "*THE-CLASS-~A*" (symbol-name name))
  *pcl-package*)
  class)
@@ -277,7 +277,7 @@
  (!bootstrap-set-slot metaclass-name class slot-name value)))
  (set-slot 'name name)
  (set-slot 'source source)
- (set-slot 'type (if (eq class (find-class 't))
+ (set-slot 'type (if (eq class (find-class t))
  t
  ;; FIXME: Could this just be CLASS instead
  ;; of `(CLASS ,CLASS)? If not, why not?
@@ -410,7 +410,7 @@
  (writer (values 'standard-writer-method
  #'make-std-writer-method-function
  (list 'new-value class-name)
- (list 't class-name)
+ (list t class-name)
  "automatically generated writer method"))
  (boundp (values 'standard-boundp-method
  #'make-std-boundp-method-function
@@ -473,7 +473,7 @@
  ;; other sorts of brainos.
  (dolist (e *built-in-classes*)
  (dolist (super (cadr e))
- (unless (or (eq super 't)
+ (unless (or (eq super t)
  (assq super *built-in-classes*))
  (error "in *BUILT-IN-CLASSES*: ~S has ~S as a super,~%~
  but ~S is not itself a class in *BUILT-IN-CLASSES*."

src/pcl/cache.lisp

@@ -334,7 +334,7 @@
  invalid))))
 (defun (setf wrapper-state) (new-value wrapper)
  (setf (sb-kernel:layout-invalid wrapper)
- (if (eq new-value 't)
+ (if (eq new-value t)
  nil
  new-value)))
 
@@ -442,7 +442,7 @@
 
 ;;; FIXME: could become inline function
 (defmacro invalid-wrapper-p (wrapper)
- `(neq (wrapper-state ,wrapper) 't))
+ `(neq (wrapper-state ,wrapper) t))
 
 (defvar *previous-nwrappers* (make-hash-table))
 
@@ -476,7 +476,7 @@
 (defun check-wrapper-validity (instance)
  (let* ((owrapper (wrapper-of instance))
  (state (wrapper-state owrapper)))
- (if (eq state 't)
+ (if (eq state t)
  owrapper
  (let ((nwrapper
  (ecase (car state)
@@ -751,8 +751,8 @@
  (wrapper nil)
  ,@(when wrappers
  `((class *the-class-t*)
- (type 't))))
- (unless (eq mt 't)
+ (type t))))
+ (unless (eq mt t)
  (setq wrapper (wrapper-of arg))
  (when (invalid-wrapper-p wrapper)
  (setq ,invalid-wrapper-p t)

src/pcl/combin.lisp

@@ -75,7 +75,7 @@
  (eq (car method) ':early-method)
  (method-p method))
  (if method-alist-p
- 't
+ t
  (multiple-value-bind (mf fmf)
  (if (listp method)
  (early-method-function method)
@@ -200,7 +200,7 @@
  method-alist-p wrappers-p)))
  (cdr form))
  'fast-method-call
- 't)
+ t)
  (fast-method-call
  '.fast-call-method-list.)
  (t
@@ -225,7 +225,7 @@
  method-alist-p wrappers-p)))
  (cdr form))
  'fast-method-call
- 't)))
+ t)))
  (values `(dolist (emf ,gensym nil)
  ,(make-emf-call metatypes applyp 'emf type))
  (list gensym))))

src/pcl/compiler-support.lisp

@@ -42,8 +42,8 @@
  (std-obj (specifier-type 'sb-pcl::std-object)))
  (cond
  ;; Flush tests whose result is known at compile time.
- ((csubtypep otype std-obj) 't)
- ((not (types-intersect otype std-obj)) 'nil)
+ ((csubtypep otype std-obj) t)
+ ((not (types-intersect otype std-obj)) nil)
  (t
  `(typep (sb-kernel:layout-of object) 'sb-pcl::wrapper)))))