;;; early definition. Do this in a way that makes sure that if we
;;; redefine one of the early definitions the redefinition will take
;;; effect. This makes development easier.
-(eval-when (:load-toplevel :execute)
-
(dolist (fns *!early-functions*)
(let ((name (car fns))
(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
;;; *!GENERIC-FUNCTION-FIXUPS* is used by !FIX-EARLY-GENERIC-FUNCTIONS
;;; to convert the few functions in the bootstrap which are supposed
(setf (initarg car-option)
`',(cdr option))))
((:documentation :generic-function-class :method-class)
- (unless (sb-int:proper-list-of-length-p option 2)
+ (unless (proper-list-of-length-p option 2)
(error "bad list length for ~S" option))
(if (initarg car-option)
(duplicate-option car-option)
(defun compile-or-load-defgeneric (function-name)
(sb-kernel:proclaim-as-function-name function-name)
(sb-kernel:note-name-defined function-name :function)
- (unless (eq (sb-int:info :function :where-from function-name) :declared)
- (setf (sb-int:info :function :where-from function-name) :defined)
- (setf (sb-int:info :function :type function-name)
+ (unless (eq (info :function :where-from function-name) :declared)
+ (setf (info :function :where-from function-name) :defined)
+ (setf (info :function :type function-name)
(sb-kernel:specifier-type 'function))))
(defun load-defgeneric (function-name lambda-list &rest initargs)
initargs-form &optional pv-table-symbol)
(let (fn
fn-lambda)
- (if (and (interned-symbol-p (sb-int:function-name-block-name name))
+ (if (and (interned-symbol-p (function-name-block-name name))
(every #'interned-symbol-p qualifiers)
(every #'(lambda (s)
(if (consp s)
;; force symbols to be printed
;; with explicit package
;; prefixes.)
- (*package* sb-int:*keyword-package*))
+ (*package* *keyword-package*))
(format nil "~S" mname)))))
- `(eval-when (:load-toplevel :execute)
- (defun ,mname-sym ,(cadr fn-lambda)
- ,@(cddr fn-lambda))
- ,(make-defmethod-form-internal
- name qualifiers `',specls
- unspecialized-lambda-list method-class-name
- `(list* ,(cadr initargs-form)
- #',mname-sym
- ,@(cdddr initargs-form))
- pv-table-symbol)))
- (make-defmethod-form-internal
- name qualifiers
- `(list ,@(mapcar #'(lambda (specializer)
- (if (consp specializer)
- ``(,',(car specializer)
- ,,(cadr specializer))
- `',specializer))
- specializers))
- unspecialized-lambda-list method-class-name
- initargs-form
- pv-table-symbol))))
+ `(progn
+ (defun ,mname-sym ,(cadr fn-lambda)
+ ,@(cddr fn-lambda))
+ ,(make-defmethod-form-internal
+ name qualifiers `',specls
+ unspecialized-lambda-list method-class-name
+ `(list* ,(cadr initargs-form)
+ #',mname-sym
+ ,@(cdddr initargs-form))
+ pv-table-symbol)))
+ (make-defmethod-form-internal
+ name qualifiers
+ `(list ,@(mapcar #'(lambda (specializer)
+ (if (consp specializer)
+ ``(,',(car specializer)
+ ,,(cadr specializer))
+ `',specializer))
+ specializers))
+ unspecialized-lambda-list method-class-name
+ initargs-form
+ pv-table-symbol))))
(defun make-defmethod-form-internal
(name qualifiers specializers-form unspecialized-lambda-list
;; 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))
(declare (ignorable ,@required-parameters))
,class-declarations
,@declarations
- (block ,(sb-int:function-name-block-name
+ (block ,(function-name-block-name
generic-function-name)
,@real-body)))
(constant-value-p (and (null (cdr real-body))
(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)
,(cadr var)))))))
(rest `((,var ,args-tail)))
(key (cond ((not (consp var))
- `((,var (get-key-arg ,(sb-int:keywordicate var)
+ `((,var (get-key-arg ,(keywordicate var)
,args-tail))))
((null (cddr var))
(multiple-value-bind (keyword variable)
(if (consp (car var))
(values (caar var)
(cadar var))
- (values (sb-int:keywordicate (car var))
+ (values (keywordicate (car var))
(car var)))
`((,key (get-key-arg1 ',keyword ,args-tail))
(,variable (if (consp ,key)
(if (consp (car var))
(values (caar var)
(cadar var))
- (values (sb-int:keywordicate (car var))
+ (values (keywordicate (car var))
(car var)))
`((,key (get-key-arg1 ',keyword ,args-tail))
(,(caddr var) ,key)
;; 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))))
next-method-p-p)))))
(defun generic-function-name-p (name)
- (and (sb-int:legal-function-name-p name)
+ (and (legal-function-name-p name)
(gboundp name)
(if (eq *boot-state* 'complete)
(standard-generic-function-p (gdefinition name))
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
(if (listp arg)
(if (listp (car arg))
(caar arg)
- (sb-int:keywordicate (car arg)))
- (sb-int:keywordicate arg))))
+ (keywordicate (car arg)))
+ (keywordicate arg))))
(let ((nrequired 0)
(noptional 0)
(keysp nil)
(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))
(defun keyword-spec-name (x)
(let ((key (if (atom x) x (car x))))
(if (atom key)
- (intern (symbol-name key) sb-int:*keyword-package*)
+ (keywordicate key)
(car key))))
(defun ftype-declaration-from-lambda-list (lambda-list name)
keywords keyword-parameters)
(analyze-lambda-list lambda-list)
(declare (ignore keyword-parameters))
- (let* ((old (sb-int:info :function :type name)) ;FIXME:FDOCUMENTATION instead?
+ (let* ((old (info :function :type name)) ;FIXME:FDOCUMENTATION instead?
(old-ftype (if (sb-kernel:function-type-p old) old nil))
(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)
(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)
;;; CAR - a list of the early methods on this early gf
;;; CADR - the early discriminator code for this method
(defun ensure-generic-function-using-class (existing spec &rest keys
- &key (lambda-list nil lambda-list-p)
+ &key (lambda-list nil
+ lambda-list-p)
&allow-other-keys)
(declare (ignore keys))
(cond ((and existing (early-gf-p existing))
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
(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 ()))
(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))))))
(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)))
(real-get-method generic-function qualifiers specializers errorp)))
(defun !fix-early-generic-functions ()
- (sb-int:/show "entering !FIX-EARLY-GENERIC-FUNCTIONS")
(let ((accessors nil))
;; Rearrange *!EARLY-GENERIC-FUNCTIONS* to speed up
;; FIX-EARLY-GENERIC-FUNCTIONS.
(dolist (early-gf-spec *!early-generic-functions*)
- (sb-int:/show early-gf-spec)
(when (every #'early-method-standard-accessor-p
(early-gf-methods (gdefinition early-gf-spec)))
(push early-gf-spec accessors)))
standard-class-p
funcallable-standard-class-p
specializerp)))
- (sb-int:/show spec)
+ (/show spec)
(setq *!early-generic-functions*
(cons spec
(delete spec *!early-generic-functions* :test #'equal))))
(dolist (early-gf-spec *!early-generic-functions*)
- (sb-int:/show early-gf-spec)
+ (/show early-gf-spec)
(let* ((gf (gdefinition early-gf-spec))
(methods (mapcar #'(lambda (early-method)
(let ((args (copy-list (fifth
(set-methods gf methods)))
(dolist (fn *!early-functions*)
- (sb-int:/show fn)
- (setf (gdefinition (car fn)) (name-get-fdefinition (caddr fn))))
+ (/show fn)
+ (setf (gdefinition (car fn)) (fdefinition (caddr fn))))
(dolist (fixup *!generic-function-fixups*)
- (sb-int:/show fixup)
+ (/show fixup)
(let* ((fspec (car fixup))
(gf (gdefinition fspec))
(methods (mapcar #'(lambda (method)
(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
(setf (generic-function-method-combination gf)
*standard-method-combination*)
(set-methods gf methods))))
- (sb-int:/show "leaving !FIX-EARLY-GENERIC-FUNCTIONS"))
+ (/show "leaving !FIX-EARLY-GENERIC-FUNCTIONS"))
\f
;;; PARSE-DEFMETHOD is used by DEFMETHOD to parse the &REST argument
;;; into the 'real' arguments. This is where the syntax of DEFMETHOD
(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)))))))
\f
-(eval-when (:load-toplevel :execute)
- (setq *boot-state* 'early))
+(setq *boot-state* 'early)
\f
;;; FIXME: In here there was a #-CMU definition of SYMBOL-MACROLET
;;; which used %WALKER stuff. That suggests to me that maybe the code
projects / sbcl.git / blobdiff