Skip to content
Snippets Groups Projects
Commit 4f7ddc3d authored by cvs2git's avatar cvs2git
Browse files

This commit was manufactured by cvs2svn to create branch 'unlabeled-1.1.1'.

parents c8cf216b 974aa418
No related branches found
No related tags found
No related merge requests found
;;;-*-Mode: LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
;;;
;;; *************************************************************************
;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
;;; All rights reserved.
;;;
;;; Use and copying of this software and preparation of derivative works
;;; based upon this software are permitted. Any distribution of this
;;; software or derivative works must comply with all applicable United
;;; States export control laws.
;;;
;;; This software is made available AS IS, and Xerox Corporation makes no
;;; warranty about the software, its performance or its conformity to any
;;; specification.
;;;
;;; Any person obtaining a copy of this software is requested to send their
;;; name and post office or electronic mail address to:
;;; CommonLoops Coordinator
;;; Xerox PARC
;;; 3333 Coyote Hill Rd.
;;; Palo Alto, CA 94304
;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
;;;
;;; Suggestions, comments and requests for improvements are also welcome.
;;; *************************************************************************
;;;
(in-package 'pcl)
#|
The CommonLoops evaluator is meta-circular.
Most of the code in PCL is methods on generic functions, including most of
the code that actually implements generic functions and method lookup.
So, we have a classic bootstrapping problem. The solution to this is to
first get a cheap implementation of generic functions running, these are
called early generic functions. These early generic functions and the
corresponding early methods and early method lookup are used to get enough
of the system running that it is possible to create real generic functions
and methods and implement real method lookup. At that point (done in the
file FIXUP) the function fix-early-generic-functions is called to convert
all the early generic functions to real generic functions.
The cheap generic functions are built using the same funcallable-instance
objects real generic-functions are made out of. This means that as PCL
is being bootstrapped, the cheap generic function objects which are being
created are the same objects which will later be real generic functions.
This is good because:
- we don't cons garbage structure
- we can keep pointers to the cheap generic function objects
during booting because those pointers will still point to
the right object after the generic functions are all fixed
up
This file defines the defmethod macro and the mechanism used to expand it.
This includes the mechanism for processing the body of a method. defmethod
basically expands into a call to load-defmethod, which basically calls
add-method to add the method to the generic-function. These expansions can
be loaded either during bootstrapping or when PCL is fully up and running.
An important effect of this structure is it means we can compile files with
defmethod forms in them in a completely running PCL, but then load those files
back in during bootstrapping. This makes development easier. It also means
there is only one set of code for processing defmethod. Bootstrapping works
by being sure to have load-method be careful to call only primitives which
work during bootstrapping.
|#
(proclaim '(notinline make-a-method
add-named-method
ensure-generic-function-using-class
add-method
remove-method
))
(defvar *early-functions*
'((make-a-method early-make-a-method
real-make-a-method)
(add-named-method early-add-named-method
real-add-named-method)
))
;;;
;;; For each of the early functions, arrange to have it point to its 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.
;;;
;;; The function which generates the redirection closure is pulled out into
;;; a separate piece of code because of a bug in ExCL which causes this not
;;; to work if it is inlined.
;;;
(eval-when (load eval)
(defun redirect-early-function-internal (to)
#'(lambda (&rest args) (apply (symbol-function to) args)))
(dolist (fns *early-functions*)
(let ((name (car fns))
(early-name (cadr fns)))
(setf (symbol-function name)
(redirect-early-function-internal early-name))))
)
;;;
;;; *generic-function-fixups* is used by fix-early-generic-functions to
;;; convert the few functions in the bootstrap which are supposed to be
;;; generic functions but can't be early on.
;;;
(defvar *generic-function-fixups*
'((add-method
((generic-function method) ;lambda-list
(standard-generic-function method) ;specializers
real-add-method)) ;method-function
(remove-method
((generic-function method)
(standard-generic-function method)
real-remove-method))
(get-method
((generic-function qualifiers specializers &optional (errorp t))
(standard-generic-function t t)
real-get-method))
(ensure-generic-function-using-class
((generic-function function-specifier
&key generic-function-class environment
&allow-other-keys)
(generic-function t)
real-ensure-gf-using-class--generic-function)
((generic-function function-specifier
&key generic-function-class environment
&allow-other-keys)
(null t)
real-ensure-gf-using-class--null))
))
;;;
;;;
;;;
(defmacro defgeneric (function-specifier lambda-list &body options)
(expand-defgeneric function-specifier lambda-list options))
(defun expand-defgeneric (function-specifier lambda-list options)
(when (listp function-specifier) (do-standard-defsetf-1 (cadr function-specifier)))
(let ((initargs ()))
(flet ((duplicate-option (name)
(error "The option ~S appears more than once." name)))
;;
;; INITARG takes this screwy new argument to get around a bad
;; interaction between lexical macros and setf in the Lucid
;; compiler.
;;
(macrolet ((initarg (key &optional new)
(if new
`(setf (getf initargs ,key) ,new)
`(getf initargs ,key))))
(dolist (option options)
(ecase (car option)
(:argument-precedence-order
(if (initarg :argument-precedence-order)
(duplicate-option :argument-precedence-order)
(initarg :argument-precedence-order `',(cdr option))))
(declare
(initarg :declarations
(append (cdr option) (initarg :declarations))))
(:documentation
(if (initarg :documentation)
(duplicate-option :documentation)
(initarg :documentation `',(cadr option))))
(:method-combination
(if (initarg :method-combination)
(duplicate-option :method-combination)
(initarg :method-combination `',(cdr option))))
(:generic-function-class
(if (initarg :generic-function-class)
(duplicate-option :generic-function-class)
(initarg :generic-function-class `',(cadr option))))
(:method-class
(if (initarg :method-class)
(duplicate-option :method-class)
(initarg :method-class `',(cadr option))))
(:method
(error
"DEFGENERIC doesn't support the :METHOD option yet."))))
(let ((declarations (initarg :declarations)))
(when declarations (initarg :declarations `',declarations)))))
(make-top-level-form `(defgeneric ,function-specifier)
*defgeneric-times*
`(load-defgeneric ',function-specifier ',lambda-list ,@initargs))))
(defun load-defgeneric (function-specifier lambda-list &rest initargs)
(when (listp function-specifier) (do-standard-defsetf-1 (cadr function-specifier)))
(apply #'ensure-generic-function
function-specifier
:lambda-list lambda-list
:definition-source `((defgeneric ,function-specifier)
,(load-truename))
initargs))
;;;
;;;
;;;
(defmacro DEFMETHOD (&rest args &environment env)
#+(or (not :lucid) :lcl3.0)
(declare (arglist name
{method-qualifier}*
specialized-lambda-list
&body body))
(multiple-value-bind (name qualifiers lambda-list body)
(parse-defmethod args)
(let ((proto-method (method-prototype-for-gf name)))
(expand-defmethod
proto-method name qualifiers lambda-list body env))))
;;;
;;; takes a name which is either a generic function name or a list specifying
;;; a setf generic function (like: (SETF <generic-function-name>)). Returns
;;; the prototype instance of the method-class for that generic function.
;;;
;;; If there is no generic function by that name, this returns the default
;;; value, the prototype instance of the class STANDARD-METHOD. This default
;;; value is also returned if the spec names an ordinary function or even a
;;; macro. In effect, this leaves the signalling of the appropriate error
;;; until load time.
;;;
;;; NOTE that during bootstrapping, this function is allowed to return NIL.
;;;
(defun method-prototype-for-gf (name)
(let ((gf? (and (gboundp name)
(gdefinition name))))
(cond ((neq *boot-state* 'complete) nil)
((or (null gf?)
(not (generic-function-p gf?))) ;Someone else MIGHT
;error at load time.
(class-prototype (find-class 'standard-method)))
(t
(class-prototype (or (generic-function-method-class gf?)
(find-class 'standard-method)))))))
#-Genera
(defun expand-defmethod (proto-method name qualifiers lambda-list body env)
(when (listp name) (do-standard-defsetf-1 (cadr name)))
(multiple-value-bind (fn-form specializers doc plist)
(expand-defmethod-internal name qualifiers lambda-list body env)
(make-top-level-form `(defmethod ,name ,@qualifiers ,specializers)
*defmethod-times*
`(load-defmethod
',(if proto-method
(class-name (class-of proto-method))
'standard-method)
',name
',qualifiers
(list ,@(mapcar #'(lambda (specializer)
(if (and (consp specializer)
(eq (car specializer) 'eql))
``(eql ,,(cadr specializer))
`',specializer))
specializers))
',(specialized-lambda-list-lambda-list lambda-list)
',doc
',(getf plist :isl-cache-symbol) ;Paper over a bug in KCL by
;passing the cache-symbol
;here in addition to in the
;plist.
',plist
,fn-form))))
#+Genera
(defun expand-defmethod (proto-method name qualifiers lambda-list body env)
(when (listp name) (do-standard-defsetf-1 (cadr name)))
(multiple-value-bind (fn-form specializers doc plist)
(expand-defmethod-internal name qualifiers lambda-list body env)
(declare (ignore doc plist))
(let ((fn-args (cadadr fn-form))
(fn-body (cddadr fn-form)))
`(defun (method ,name ,@qualifiers ,specializers) ,fn-args
(declare ,@(when proto-method
`((pcl-method-class
,(class-name (class-of proto-method)))))
(pcl-lambda-list
,(specialized-lambda-list-lambda-list lambda-list)))
,@fn-body))))
(defun expand-defmethod-internal
(generic-function-name qualifiers specialized-lambda-list body env)
(declare (values fn-form specializers doc)
(ignore qualifiers))
(when (listp generic-function-name)
(do-standard-defsetf-1 (cadr generic-function-name)))
(multiple-value-bind (documentation declarations real-body)
(extract-declarations body)
(multiple-value-bind (parameters lambda-list specializers)
(parse-specialized-lambda-list specialized-lambda-list)
(let* ((required-parameters
(mapcar #'(lambda (r s) (declare (ignore s)) r)
parameters
specializers))
(parameters-to-reference
(make-parameter-references specialized-lambda-list
required-parameters
declarations
generic-function-name
specializers))
(class-declarations
`(declare
,@(remove nil
(mapcar #'(lambda (a s) (and (symbolp s)
(neq s 't)
`(class ,a ,s)))
parameters
specializers))))
(method-lambda
;; Remove the documentation string and insert the
;; appropriate class declarations. The documentation
;; string is removed to make it easy for us to insert
;; new declarations later, they will just go after the
;; cadr of the method lambda. The class declarations
;; are inserted to communicate the class of the method's
;; arguments to the code walk.
(let ()
`(lambda ,lambda-list
,class-declarations
,@declarations
(progn ,@parameters-to-reference)
(block ,(if (listp generic-function-name)
(cadr generic-function-name)
generic-function-name)
,@real-body))))
(call-next-method-p nil) ;flag indicating that call-next-method
;should be in the method definition
(next-method-p-p nil) ;flag indicating that next-method-p
;should be in the method definition
(save-original-args nil) ;flag indicating whether or not the
;original arguments to the method
;must be preserved. This happens
;for two reasons:
; - the method takes &mumble args,
; so one of the lexical functions
; might be used in a default value
; form
; - call-next-method is used without
; arguments at least once in the
; body of the method
(original-args ())
(applyp nil) ;flag indicating whether or not the
;method takes &mumble arguments. If
;it does, it means call-next-method
;without arguments must be APPLY'd
;to original-args. If this gets set
;true, save-original-args is set so
;as well
(aux-bindings ()) ;Suffice to say that &aux is one of
;damndest things to have put in a
;language.
(slots (mapcar #'list required-parameters))
(plist ())
(walked-lambda nil))
(flet ((walk-function (form context env)
(cond ((not (eq context ':eval)) form)
((not (listp form)) form)
((eq (car form) 'call-next-method)
(setq call-next-method-p 't)
(setq save-original-args (not (cdr form)))
form)
((eq (car form) 'next-method-p)
(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 save-original-args 't)
form)
((eq (cadr form) 'next-method-p)
(setq next-method-p-p 't)
form)
(t nil))))
((and (or (eq (car form) 'slot-value)
(eq (car form) 'set-slot-value))
(symbolp (cadr form))
(constantp (caddr form)))
(let ((parameter
(can-optimize-access (cadr form) required-parameters env)))
(if (null parameter)
form
(ecase (car form)
(slot-value
(optimize-slot-value slots parameter form))
(set-slot-value
(optimize-set-slot-value slots parameter form))))))
(t form))))
(setq walked-lambda (walk-form method-lambda env #'walk-function))
;;
;; Add &allow-other-keys to the lambda list as an interim
;; way of implementing lambda list congruence rules.
;;
(when (and (memq '&key lambda-list)
(not (memq '&allow-other-keys lambda-list)))
(let* ((rll (reverse lambda-list))
(aux (memq '&aux rll)))
(setq lambda-list
(if aux
(progn (setf (cdr aux)
(cons '&allow-other-keys (cdr aux)))
(nreverse rll))
(nconc (nreverse rll) (list '&allow-other-keys))))))
;; Scan the lambda list to determine whether this method
;; takes &mumble arguments. If it does, we set applyp and
;; save-original-args true.
;;
;; This is also the place where we construct the original
;; arguments lambda list if there has to be one.
(dolist (p lambda-list)
(if (memq p lambda-list-keywords)
(if (eq p '&aux)
(progn
(setq aux-bindings (cdr (memq '&aux lambda-list)))
(return nil))
(progn
(setq applyp t
save-original-args t)
(push '&rest original-args)
(push (make-symbol "AMPERSAND-ARGS") original-args)
(return nil)))
(push (make-symbol (symbol-name p)) original-args)))
(setq original-args (if save-original-args
(nreverse original-args)
()))
(multiple-value-bind (ignore walked-declarations walked-lambda-body)
(extract-declarations (cddr walked-lambda))
(declare (ignore ignore))
(when (some #'cdr slots)
(setq slots (slot-name-lists-from-slots slots))
(setq plist (list* :isl slots plist))
(setq walked-lambda-body (add-pv-binding walked-lambda-body
plist
required-parameters)))
(when (or next-method-p-p call-next-method-p)
(setq plist (list* :needs-next-methods-p 't plist)))
;;; changes are here... (mt)
(let ((fn-body (if (or call-next-method-p next-method-p-p)
(add-lexical-functions-to-method-lambda
walked-declarations
walked-lambda-body
`(lambda ,lambda-list
,@walked-declarations
,.walked-lambda-body)
original-args
lambda-list
save-original-args
applyp
aux-bindings
call-next-method-p
next-method-p-p)
`(lambda ,lambda-list
,@walked-declarations
,.walked-lambda-body))))
#+Genera
(setq fn-body `(lambda ,(cadr fn-body)
(declare (pcl-documentation ,documentation)
(pcl-plist ,plist))
,@(cddr fn-body)))
(values
`(function ,fn-body)
specializers
documentation
plist))))))))
(defun add-lexical-functions-to-method-lambda (walked-declarations
walked-lambda-body
walked-lambda
original-args
lambda-list
save-original-args
applyp
aux-bindings
call-next-method-p
next-method-p-p)
(cond ((and (null save-original-args)
(null applyp))
;;
;; We don't have to save the original arguments. In addition,
;; this method doesn't take any &mumble arguments (this means
;; that there is no way the lexical functions can be used inside
;; of the default value form for an &mumble argument).
;;
;; We can expand this into a simple lambda expression with an
;; FLET to define the lexical functions.
;;
`(lambda ,lambda-list
,@walked-declarations
(let ((.next-method. (car *next-methods*))
(.next-methods. (cdr *next-methods*)))
(flet (,@(and call-next-method-p
'((call-next-method (&rest cnm-args)
#+Genera
(declare (dbg:invisible-frame :clos-internal))
(if .next-method.
(let ((*next-methods* .next-methods.))
(apply .next-method. cnm-args))
(error "No next method.")))))
,@(and next-method-p-p
'((next-method-p ()
(not (null .next-method.))))))
,@walked-lambda-body))))
((null applyp)
;;
;; This method doesn't accept any &mumble arguments. But we
;; do have to save the original arguments (this is because
;; call-next-method is being called with no arguments).
;; Have to be careful though, there may be multiple calls to
;; call-next-method, all we know is that at least one of them
;; is with no arguments.
;;
`(lambda ,original-args
(let ((.next-method. (car *next-methods*))
(.next-methods. (cdr *next-methods*)))
(flet (,@(and call-next-method-p
`((call-next-method (&rest cnm-args)
(if .next-method.
(let ((*next-methods* .next-methods.))
(if cnm-args
(apply .next-method. cnm-args)
(funcall .next-method.
,@original-args)))
(error "No next method.")))))
,@(and next-method-p-p
'((next-method-p ()
(not (null .next-method.))))))
(let* (,@(mapcar #'list
(remtail lambda-list (memq '&aux lambda-list))
original-args)
,@aux-bindings)
,@walked-declarations
,@walked-lambda-body)))))
(t
;;
;; This is the fully general case.
;; We must allow for the lexical functions being used inside
;; the default value forms of &mumble arguments, and if must
;; allow for call-next-method being called with no arguments.
;;
`(lambda ,original-args
(let ((.next-method. (car *next-methods*))
(.next-methods. (cdr *next-methods*)))
(flet (,@(and call-next-method-p
`((call-next-method (&rest cnm-args)
(if .next-method.
(let ((*next-methods* .next-methods.))
(if cnm-args
(apply .next-method. cnm-args)
(apply .next-method.
,@(remove '&rest
original-args))))
(error "No next method.")))))
,@(and next-method-p-p
'((next-method-p ()
(not (null .next-method.))))))
(apply (function ,walked-lambda)
,@(remove '&rest original-args))))))))
(defun make-parameter-references (specialized-lambda-list
required-parameters
declarations
generic-function-name
specializers)
(flet ((ignoredp (symbol)
(dolist (decl (cdar declarations))
(when (and (eq (car decl) 'ignore)
(memq symbol (cdr decl)))
(return t)))))
(gathering ((references (collecting)))
(iterate ((s (list-elements specialized-lambda-list))
(p (list-elements required-parameters)))
(progn p)
(cond ((not (listp s)))
((ignoredp (car s))
(warn "In defmethod ~S ~S, there is a~%~
redundant ignore declaration for the parameter ~S."
generic-function-name
specializers
(car s)))
(t
(gather (car s) references)))))))
(defvar *method-function-plist* (make-hash-table :test #'eq))
(defun method-function-plist (method-function)
(gethash method-function *method-function-plist*))
(defun SETF\ PCL\ METHOD-FUNCTION-PLIST (val method-function)
(setf (gethash method-function *method-function-plist*) val))
(defun method-function-get (method-function key)
(getf (method-function-plist method-function) key))
(defun SETF\ PCL\ METHOD-FUNCTION-GET (val method-function key)
(setf (getf (method-function-plist method-function) key) val))
(defun method-function-isl (method-function)
(method-function-get method-function :isl))
(defun method-function-needs-next-methods-p (method-function)
(method-function-get method-function :needs-next-methods-p))
(defun load-defmethod
(class name quals specls ll doc isl-cache-symbol plist fn)
(when (listp name) (do-standard-defsetf-1 (cadr name)))
(let ((method-spec (make-method-spec name quals specls)))
(record-definition 'method method-spec)
(setq fn (set-function-name fn method-spec))
(load-defmethod-internal
name quals specls ll doc isl-cache-symbol plist fn class)))
(defun load-defmethod-internal
(gf-spec qualifiers specializers
lambda-list doc isl-cache-symbol plist fn method-class)
(when (listp gf-spec) (do-standard-defsetf-1 (cadr gf-spec)))
(when plist
(setq plist (copy-list plist)) ;Do this to keep from affecting
;the plist that is about to be
;dumped when we are compiling.
(let ((uisl (getf plist :isl))
(isl nil))
(when uisl
(setq isl (intern-slot-name-lists uisl))
(setf (getf plist :isl) isl))
(when isl-cache-symbol
(setf (getf plist :isl-cache-symbol) isl-cache-symbol)
(set isl-cache-symbol isl)))
(setf (method-function-plist fn) plist))
(let ((method (add-named-method
gf-spec qualifiers specializers lambda-list fn
:documentation doc
:definition-source `((defmethod ,gf-spec
,@qualifiers
,specializers)
,(load-truename)))))
(unless (or (eq method-class 'standard-method)
(eq (find-class method-class nil) (class-of method)))
(format *error-output*
"At the time the method with qualifiers ~:~S and~%~
specializers ~:S on the generic function ~S~%~
was compiled, the method-class for that generic function was~%~
~S. But, the method class is now ~S, this~%~
may mean that this method was compiled improperly."
qualifiers specializers gf-spec
method-class (class-name (class-of method))))
method))
(defun make-method-spec (gf-spec qualifiers unparsed-specializers)
`(method ,gf-spec ,@qualifiers ,unparsed-specializers))
;;;; Early generic-function support
;;;
;;;
(defvar *early-generic-functions* ())
(defun ensure-generic-function (function-specifier
&rest all-keys
&key environment
&allow-other-keys)
(declare (ignore environment))
(let ((existing (and (gboundp function-specifier)
(gdefinition function-specifier))))
(if (and existing
(eq *boot-state* 'complete)
(null (generic-function-p existing)))
(generic-clobbers-function function-specifier)
(apply #'ensure-generic-function-using-class existing function-specifier all-keys))))
(defun generic-clobbers-function (function-specifier)
#+Lispm (zl:signal 'generic-clobbers-function :name function-specifier)
#-Lispm (error "~S already names an ordinary function or a macro,~%~
you may want to replace it with a generic function, but doing so~%~
will require that you decide what to do with the existing function~%~
definition.~%~
The PCL-specific function MAKE-SPECIALIZABLE may be useful to you."
function-specifier))
#+Lispm
(zl:defflavor generic-clobbers-function (name) (si:error)
:initable-instance-variables)
#+Lispm
(zl:defmethod #+symbolics (dbg:report generic-clobbers-function)
#+ti (generic-clobbers-function :report)
(stream)
(format stream
"~S aready names a ~a"
name
(if (and (symbolp name) (macro-function name)) "macro" "function")))
#+Symbolics
(zl:defmethod (sys:proceed generic-clobbers-function :specialize-it) ()
"Make it specializable anyway?"
(make-specializable name))
#+ti
(zl:defmethod
(generic-clobbers-function :case :proceed-asking-user :specialize-it)
(continuation ignore)
"Make it specializable anyway?"
(make-specializable name)
(funcall continuation :specialize-it))
;;;
;;; This is the early definition of ensure-generic-function-using-class.
;;;
;;; The static-slots field of the funcallable instances used as early generic
;;; functions is used to store the early methods and early discriminator code
;;; for the early generic function. The static slots field of the fins
;;; contains a list whose:
;;; 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)
(declare (ignore keys))
(if* existing
existing
(pushnew spec *early-generic-functions* :test #'equal)
(let ((fin (allocate-funcallable-instance-1)))
(setf (gdefinition spec) fin)
(setf (fsc-instance-slots fin) (list nil nil))
fin)))
(defun early-gf-p (x)
(and (fsc-instance-p x)
(listp (fsc-instance-slots x))))
(defmacro early-gf-methods (early-gf) ;These are macros so that
`(car (fsc-instance-slots ,early-gf))) ;they can be setf'd.
;
(defmacro early-gf-discriminator-code (early-gf);
`(cadr (fsc-instance-slots ,early-gf))) ;
(defmacro real-ensure-gf-internal (gf-class all-keys env)
`(progn
(cond ((symbolp ,gf-class)
(setq ,gf-class (find-class ,gf-class t ,env)))
((classp ,gf-class))
(t
(error "The :GENERIC-FUNCTION-CLASS argument (~S) was neither a~%~
class nor a symbol that names a class."
,gf-class)))
(remf ,all-keys :generic-function-class)
(remf ,all-keys :environment)
(let ((combin (getf ,all-keys :method-combination '.shes-not-there.)))
(unless (eq combin '.shes-not-there.)
(setf (getf ,all-keys :method-combination)
(find-method-combination (class-prototype ,gf-class)
(car combin)
(cdr combin)))))
))
(defun real-ensure-gf-using-class--generic-function
(existing
function-specifier
&rest all-keys
&key environment
(generic-function-class 'standard-generic-function gf-class-p)
&allow-other-keys)
(declare (ignore function-specifier))
(real-ensure-gf-internal generic-function-class all-keys environment)
(unless (or (null gf-class-p)
(eq (class-of existing) generic-function-class))
(change-class existing generic-function-class))
(apply #'reinitialize-instance existing all-keys))
(defun real-ensure-gf-using-class--null
(existing
function-specifier
&rest all-keys
&key environment
(generic-function-class 'standard-generic-function)
&allow-other-keys)
(declare (ignore existing))
(real-ensure-gf-internal generic-function-class all-keys environment)
(setf (gdefinition function-specifier)
(apply #'make-instance generic-function-class :name function-specifier all-keys)))
(defun early-make-a-method (class qualifiers arglist specializers function doc
&optional slot-name)
(let ((parsed ())
(unparsed ()))
;; Figure out whether we got class objects or class names as the
;; specializers and set parsed and unparsed appropriately. If we
;; got class objects, then we can compute unparsed, but if we got
;; class names we don't try to compute parsed.
;;
;; 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)
(setq parsed specializers
unparsed (mapcar #'(lambda (s)
(if (eq s 't) 't (class-name s)))
specializers))
(setq unparsed specializers
parsed ()))
(list :early-method ;This is an early method dammit!
function ;Function is here for the benefit
;of early-lookup-method.
parsed ;The parsed specializers. This is used
;by early-method-specializers to cache
;the parse. Note that this only comes
;into play when there is more than one
;early method on an early gf.
(list class ;A list to which real-make-a-method
qualifiers ;can be applied to make a real method
arglist ;corresponding to this early one.
unparsed
function
doc
slot-name)
)))
(defun real-make-a-method
(class qualifiers lambda-list specializers function doc
&optional slot-name)
;; Hmm what is this use of when buying me??
(when (some #'(lambda (x) (and (neq x 't) (symbolp x))) specializers)
(setq specializers (parse-specializers specializers)))
(make-instance class :qualifiers qualifiers
:lambda-list lambda-list
:specializers specializers
:function function
:documentation doc
:slot-name slot-name
:allow-other-keys t))
(defun early-method-function (early-method)
(cadr early-method))
;;;
;;; Fetch the specializers of an early method. This is basically just a
;;; simple accessor except that when the second argument is t, this converts
;;; the specializers from symbols into class objects. The class objects
;;; are cached in the early method, this makes bootstrapping faster because
;;; the class objects only have to be computed once.
;;; NOTE:
;;; the second argument should only be passed as T by early-lookup-method.
;;; this is to implement the rule that only when there is more than one
;;; early method on a generic function is the conversion from class names
;;; to class objects done.
;;; the corresponds to the fact that we are only allowed to have one method
;;; on any generic function up until the time classes exist.
;;;
(defun early-method-specializers (early-method &optional objectsp)
(if (and (listp early-method)
(eq (car early-method) :early-method))
(cond ((eq objectsp 't)
(or (caddr early-method)
(setf (caddr early-method)
(mapcar #'find-class (cadddr (cadddr early-method))))))
(t
(cadddr (cadddr early-method))))
(error "~S is not an early-method." early-method)))
(defun early-method-qualifiers (early-method)
(cadr (cadddr early-method)))
(defun early-add-named-method (generic-function-name
qualifiers
specializers
arglist
function
&rest options)
(declare (ignore options))
(let* ((gf (ensure-generic-function generic-function-name))
(existing
(dolist (m (early-gf-methods gf))
(when (and (equal (early-method-specializers m) specializers)
(equal (early-method-qualifiers m) qualifiers))
(return m))))
(new (make-a-method 'standard-method
qualifiers
arglist
specializers
function
())))
(when existing (remove-method gf existing))
(add-method gf new)))
;;;
;;; This is the early version of add-method. Later this will become a
;;; generic function. See fix-early-generic-functions which has special
;;; knowledge about add-method.
;;;
(defun add-method (generic-function method)
(when (not (fsc-instance-p generic-function))
(error "Early add-method didn't get a funcallable instance."))
(when (not (and (listp method) (eq (car method) :early-method)))
(error "Early add-method didn't get an early method."))
(push method (early-gf-methods generic-function))
(early-update-discriminator-code generic-function))
;;;
;;; This is the early version of remove method.
;;;
(defun remove-method (generic-function method)
(when (not (fsc-instance-p generic-function))
(error "Early remove-method didn't get a funcallable instance."))
(when (not (and (listp method) (eq (car method) :early-method)))
(error "Early remove-method didn't get an early method."))
(setf (early-gf-methods generic-function)
(remove method (early-gf-methods generic-function)))
(early-update-discriminator-code generic-function))
;;;
;;; And the early version of get-method.
;;;
(defun get-method (generic-function qualifiers specializers
&optional (errorp t))
(if (early-gf-p generic-function)
(or (dolist (m (early-gf-methods generic-function))
(when (and (or (equal (early-method-specializers m nil)
specializers)
(equal (early-method-specializers m 't)
specializers))
(equal (early-method-qualifiers m) qualifiers))
(return m)))
(if errorp
(error "Can't get early method.")
nil))
(real-get-method generic-function qualifiers specializers errorp)))
(defun early-update-discriminator-code (generic-function)
(let* ((methods (early-gf-methods generic-function))
(early-dfun
(cond ((null methods)
#'(lambda (&rest ignore)
(declare (ignore ignore))
(error "Called an early generic-function that ~
has no methods?")))
((null (cdr methods))
;; If there is only one method, just use that method's
;; function. This corresponds to the important fact
;; that early generic-functions with only one method
;; always call that method when they are called. If
;; there is more than one method, we have to install
;; a simple little discriminator-code for this generic
;; function.
(cadr (car methods)))
(t
#'(lambda (&rest args) (early-dfun methods args))))))
(set-funcallable-instance-function generic-function early-dfun)
(setf (early-gf-discriminator-code generic-function) early-dfun)))
(defun early-get-cpl (object)
(bootstrap-get-slot 'std-class ;HMMM? should be PCL-CLASS
(class-of object)
'class-precedence-list))
(defun early-sort-methods (list args)
(if (null (cdr list))
list
(sort list
#'(lambda (specls-1 specls-2)
(iterate ((s1 (list-elements specls-1))
(s2 (list-elements specls-2))
(a (list-elements args)))
(cond ((eq s1 s2))
((eq s2 *the-class-t*) (return t))
((eq s1 *the-class-t*) (return nil))
(t (return (memq s2 (memq s1 (early-get-cpl a))))))))
:key #'(lambda (em) (early-method-specializers em t)))))
(defun early-dfun (methods args)
(let ((primary ())
(before ())
(after ())
(around ()))
(dolist (method methods)
(let* ((specializers (early-method-specializers method t))
(qualifiers (early-method-qualifiers method))
(args args)
(specs specializers))
(when (loop
(when (or (null args)
(null specs))
;; If we are out of specs, then we must be in the optional,
;; rest or keywords arguments. This method is applicable
;; to these arguments. Return T.
(return t))
(let ((arg (pop args))
(spec (pop specs)))
(unless (or (eq spec *the-class-t*)
(memq spec (early-get-cpl arg)))
(return nil))))
(cond ((null qualifiers) (push method primary))
((equal qualifiers '(:before)) (push method before))
((equal qualifiers '(:after)) (push method after))
((equal qualifiers '(:around)) (push method around))
(t
(error "Unrecognized qualifer in early method."))))))
(setq primary (early-sort-methods primary args)
before (early-sort-methods before args)
after (early-sort-methods after args)
around (early-sort-methods around args))
(flet ((do-main-combined-method (arguments)
(dolist (m before) (apply (cadr m) arguments))
(multiple-value-prog1
(let ((*next-methods* (mapcar #'car (cdr primary))))
(apply (cadar primary) arguments))
(dolist (m after) (apply (cadr m) arguments)))))
(if (null around)
(do-main-combined-method args)
(let ((*next-methods*
(append (mapcar #'cadr (cdr around))
#'do-main-combined-method)))
(apply (caar around) args))))))
(defun fix-early-generic-functions (&optional noisyp)
(allocate-instance (find-class 'standard-generic-function));Be sure this
;class has an
;instance.
(let* ((class (find-class 'standard-generic-function))
(wrapper (class-wrapper class))
(n-static-slots (class-no-of-instance-slots class))
(default-initargs (default-initargs class ()))
#+Lucid
(lucid::*redefinition-action* nil)
(*invalidate-discriminating-function-force-p* t))
(flet ((fix-structure (gf)
(let ((static-slots
(%allocate-static-slot-storage--class n-static-slots)))
(setf (fsc-instance-wrapper gf) wrapper
(fsc-instance-slots gf) static-slots))))
(dolist (early-gf-spec *early-generic-functions*)
(when noisyp (format t "~&~S..." early-gf-spec))
(let* ((early-gf (gdefinition early-gf-spec))
(early-static-slots
(fsc-instance-slots early-gf))
(early-discriminator-code nil)
(early-methods nil)
(methods ())
(aborted t))
(flet ((trampoline (&rest args)
(apply early-discriminator-code args)))
(if (not (listp early-static-slots))
(when noisyp (format t "already fixed?"))
(unwind-protect
(progn
(setq early-discriminator-code
(early-gf-discriminator-code early-gf))
(setq early-methods
(early-gf-methods early-gf))
(setf (gdefinition early-gf-spec) #'trampoline)
(when noisyp (format t "trampoline..."))
(fix-structure early-gf)
(when noisyp (format t "fixed..."))
(apply #'initialize-instance early-gf
:name early-gf-spec default-initargs)
(dolist (early-method early-methods)
(destructuring-bind
(class quals lambda-list specs fn doc slot-name)
(cadddr early-method)
(setq specs
(early-method-specializers early-method t))
(let ((method (real-make-a-method class
quals
lambda-list
specs
fn
doc
slot-name)))
(real-add-method early-gf method)
(push method methods)
(when noisyp (format t "m")))))
(setf (slot-value early-gf 'name) early-gf-spec)
(fixup-magic-generic-function early-gf-spec
early-methods
early-gf
(reverse methods))
(setq aborted nil))
(setf (gdefinition early-gf-spec) early-gf)
(when noisyp (format t "."))
(when aborted
(setf (fsc-instance-slots early-gf)
early-static-slots)))))))
(dolist (fns *early-functions*)
(setf (symbol-function (car fns)) (symbol-function (caddr fns))))
(dolist (fixup *generic-function-fixups*)
(let ((fspec (car fixup))
(methods (cdr fixup))
(gf (make-instance 'standard-generic-function)))
(set-function-name gf fspec)
(setf (generic-function-name gf) fspec)
(dolist (method methods)
(destructuring-bind (lambda-list specializers method-fn-name)
method
(let* ((fn (if method-fn-name
(symbol-function method-fn-name)
(symbol-function fspec)))
(method (make-a-method 'standard-method
()
lambda-list
specializers
fn
nil)))
(real-add-method gf method))))
(setf (gdefinition fspec) gf))))))
;;;
;;; parse-defmethod is used by defmethod to parse the &rest argument into
;;; the 'real' arguments. This is where the syntax of defmethod is really
;;; implemented.
;;;
(defun parse-defmethod (cdr-of-form)
(declare (values name qualifiers specialized-lambda-list body))
(let ((name (pop cdr-of-form))
(qualifiers ())
(spec-ll ()))
(loop (if (and (car cdr-of-form) (atom (car cdr-of-form)))
(push (pop cdr-of-form) qualifiers)
(return (setq qualifiers (nreverse qualifiers)))))
(setq spec-ll (pop cdr-of-form))
(values name qualifiers spec-ll cdr-of-form)))
(defun parse-specializers (specializers)
(flet ((parse (spec)
(cond ((symbolp spec)
(or (find-class spec nil)
(error
"~S used as a specializer,~%~
but is not the name of a class."
spec)))
((and (listp spec)
(eq (car spec) 'eql)
(null (cddr spec)))
(make-instance 'eql-specializer :object (cadr spec)) ;*EQL*
; spec
)
(t (error "~S is not a legal specializer." spec)))))
(mapcar #'parse specializers)))
(defun unparse-specializers (specializers-or-method)
(if (listp specializers-or-method)
(flet ((unparse (spec)
(cond ((classp spec)
(or (class-name spec) spec))
((eql-specializer-p spec) ;*EQL*
(eql-specializer-object spec)
; (and (listp spec) (eq (car spec) 'eql))
; spec
)
(t
(error "~S is not a legal specializer." spec)))))
(mapcar #'unparse specializers-or-method))
(unparse-specializers (method-specializers specializers-or-method))))
(defun parse-method-or-spec (spec &optional (errorp t))
(declare (values generic-function method method-name))
(let (gf method name temp)
(if (method-p spec)
(setq method spec
gf (method-generic-function method)
temp (and gf (generic-function-name gf))
name (if temp
(intern-function-name
(make-method-spec temp
(method-qualifiers method)
(unparse-specializers
(method-specializers method))))
(make-symbol (format nil "~S" method))))
(multiple-value-bind (gf-spec quals specls)
(parse-defmethod spec)
(and (setq gf (and (or errorp (gboundp gf-spec))
(gdefinition gf-spec)))
(let ((nreq (compute-discriminating-function-arglist-info gf)))
(setq specls (append (parse-specializers specls)
(make-list (- nreq (length specls))
:initial-element
*the-class-t*)))
(and
(setq method (get-method gf quals specls errorp))
(setq name
(intern-function-name (make-method-spec gf-spec
quals
specls))))))))
(values gf method name)))
(defun specialized-lambda-list-parameters (specialized-lambda-list)
(multiple-value-bind (parameters ignore1 ignore2)
(parse-specialized-lambda-list specialized-lambda-list)
(declare (ignore ignore1 ignore2))
parameters))
(defun specialized-lambda-list-lambda-list (specialized-lambda-list)
(multiple-value-bind (ignore1 lambda-list ignore2)
(parse-specialized-lambda-list specialized-lambda-list)
(declare (ignore ignore1 ignore2))
lambda-list))
(defun specialized-lambda-list-specializers (specialized-lambda-list)
(multiple-value-bind (ignore1 ignore2 specializers)
(parse-specialized-lambda-list specialized-lambda-list)
(declare (ignore ignore1 ignore2))
specializers))
(defun specialized-lambda-list-required-parameters (specialized-lambda-list)
(multiple-value-bind (ignore1 ignore2 ignore3 required-parameters)
(parse-specialized-lambda-list specialized-lambda-list)
(declare (ignore ignore1 ignore2 ignore3))
required-parameters))
(defun parse-specialized-lambda-list (arglist &optional post-keyword)
(declare (values parameters lambda-list specializers required-parameters))
(let ((arg (car arglist)))
(cond ((null arglist) (values nil nil nil nil))
((eq arg '&aux)
(values nil arglist nil))
((memq arg lambda-list-keywords)
(unless (memq arg '(&optional &rest &key &allow-other-keys &aux))
;; Warn about non-standard lambda-list-keywords, but then
;; go on to treat them like a standard lambda-list-keyword
;; what with the warning its probably ok.
(warn "Unrecognized lambda-list keyword ~S in arglist.~%~
Assuming that the symbols following it are parameters,~%~
and not allowing any parameter specializers to follow~%~
to follow it."
arg))
;; When we are at a lambda-list-keyword, the parameters don't
;; include the lambda-list-keyword; the lambda-list does include
;; the lambda-list-keyword; and no specializers are allowed to
;; follow the lambda-list-keywords (at least for now).
(multiple-value-bind (parameters lambda-list)
(parse-specialized-lambda-list (cdr arglist) t)
(values parameters
(cons arg lambda-list)
()
())))
(post-keyword
;; After a lambda-list-keyword there can be no specializers.
(multiple-value-bind (parameters lambda-list)
(parse-specialized-lambda-list (cdr arglist) t)
(values (cons (if (listp arg) (car arg) arg) parameters)
(cons arg lambda-list)
()
())))
(t
(multiple-value-bind (parameters lambda-list specializers required)
(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) (car arg) arg) required)))))))
(eval-when (load eval)
(setq *boot-state* 'early))
(defmacro with-slots
(slots instance &body body &environment env)
(let ((gensym (gensym))
(specs (mapcar #'(lambda (ss)
(if (consp ss)
(list (car ss)
(variable-lexical-p (car ss) env)
(cadr ss))
(list ss (variable-lexical-p ss env) ss)))
slots)))
(expand-with-slots specs
body
env
gensym
instance
#'(lambda (s) `(slot-value ,gensym ',s)))))
(defmacro with-accessors
(slot-accessor-pairs instance &body body &environment env)
(let ((gensym (gensym))
(specs (mapcar #'(lambda (ss)
(list (car ss)
(variable-lexical-p (car ss) env)
(cadr ss)))
slot-accessor-pairs)))
(expand-with-slots specs
body
env
gensym
instance
#'(lambda (a) `(,a ,gensym)))))
(defun expand-with-slots (specs body env gensym instance translate-fn)
`(let ((,gensym ,instance))
,@(and (symbolp instance)
`((declare (variable-rebinding ,gensym ,instance))))
,gensym
,@(cdr (walk-form `(progn ,@body)
env
#'(lambda (f c e)
(expand-with-slots-internal specs
f
c
translate-fn
e))))))
(defun expand-with-slots-internal (specs form context translate-fn env)
(let ((entry nil))
(cond ((not (eq context :eval)) form)
((symbolp form)
(if (and (setq entry (assoc form specs))
(eq (cadr entry) (variable-lexical-p form env)))
(funcall translate-fn (caddr entry))
form))
((not (listp form)) form)
((member (car form) '(setq setf))
;; Have to be careful. We must only convert the form to a SETF
;; form when we convert one of the 'logical' variables to a form
;; Otherwise we will get looping in implementations where setf
;; is a macro which expands into setq.
(let ((kind (car form)))
(labels ((scan-setf (tail)
(if (null tail)
nil
(walker::relist*
tail
(if (and (setq entry (assoc (car tail) specs))
(eq (cadr entry)
(variable-lexical-p (car tail)
env)))
(progn (setq kind 'setf)
(funcall translate-fn (caddr entry)))
(car tail))
(cadr tail)
(scan-setf (cddr tail))))))
(let (new-tail)
(setq new-tail (scan-setf (cdr form)))
(walker::recons form kind new-tail)))))
((eq (car form) 'multiple-value-setq)
(let* ((vars (cadr form))
(gensyms (mapcar #'(lambda (i) (declare (ignore i)) (gensym))
vars)))
`(multiple-value-bind ,gensyms
,(caddr form)
.,(reverse (mapcar #'(lambda (v g) `(setf ,v ,g))
vars
gensyms)))))
(t form))))
;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*-
;;;
;;; *************************************************************************
;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
;;; All rights reserved.
;;;
;;; Use and copying of this software and preparation of derivative works
;;; based upon this software are permitted. Any distribution of this
;;; software or derivative works must comply with all applicable United
;;; States export control laws.
;;;
;;; This software is made available AS IS, and Xerox Corporation makes no
;;; warranty about the software, its performance or its conformity to any
;;; specification.
;;;
;;; Any person obtaining a copy of this software is requested to send their
;;; name and post office or electronic mail address to:
;;; CommonLoops Coordinator
;;; Xerox PARC
;;; 3333 Coyote Hill Rd.
;;; Palo Alto, CA 94304
;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
;;;
;;; Suggestions, comments and requests for improvements are also welcome.
;;; *************************************************************************
;;;
;;; Bootstrapping the meta-braid.
;;;
;;; The code in this file takes the early definitions that have been saved
;;; up and actually builds those class objects. This work is largely driven
;;; off of those class definitions, but the fact that STANDARD-CLASS is the
;;; class of all metaclasses in the braid is built into this code pretty
;;; deeply.
;;;
;;;
(in-package 'pcl)
(defun early-class-definition (class-name)
(or (find class-name *early-class-definitions* :key #'ecd-class-name)
(error "~S is not a class in *early-class-definitions*." class-name)))
(defun canonical-slot-name (canonical-slot)
(getf canonical-slot :name))
(defun early-collect-inheritance (class-name)
(declare (values slots cpl default-initargs direct-subclasses))
(let ((cpl (early-collect-cpl class-name)))
(values (early-collect-slots cpl)
cpl
(early-collect-default-initargs cpl)
(gathering1 (collecting)
(dolist (definition *early-class-definitions*)
(when (memq class-name (ecd-superclass-names definition))
(gather1 (ecd-class-name definition))))))))
(defun early-collect-cpl (class-name)
(labels ((walk (c)
(let* ((definition (early-class-definition c))
(supers (ecd-superclass-names definition)))
(cons c
(apply #'append (mapcar #'early-collect-cpl supers))))))
(remove-duplicates (walk class-name) :from-end nil :test #'eq)))
(defun early-collect-slots (cpl)
(let* ((definitions (mapcar #'early-class-definition cpl))
(super-slots (mapcar #'ecd-canonical-slots definitions))
(slots (apply #'append (reverse super-slots))))
(dolist (s1 slots)
(let ((name1 (canonical-slot-name s1)))
(dolist (s2 (cdr (memq s1 slots)))
(when (eq name1 (canonical-slot-name s2))
(error "More than one early class defines a slot with the~%~
name ~S. This can't work because the bootstrap~%~
object system doesn't know how to compute effective~%~
slots."
name1)))))
slots))
(defun early-collect-default-initargs (cpl)
(let ((default-initargs ()))
(dolist (class-name cpl)
(let ((definition (early-class-definition class-name)))
(dolist (option (ecd-other-initargs definition))
(unless (eq (car option) :default-initargs)
(error "The defclass option ~S is not supported by the bootstrap~%~
object system."
(car option)))
(setq default-initargs
(nconc default-initargs (reverse (cdr option)))))))
(reverse default-initargs)))
;;;
;;; bootstrap-get-slot and bootstrap-set-slot are used to access and change
;;; the values of slots during bootstrapping. During bootstrapping, there
;;; are only two kinds of objects whose slots we need to access, CLASSes
;;; and SLOTDs. The first argument to these functions tells whether the
;;; object is a CLASS or a SLOTD.
;;;
;;; Note that the way this works it stores the slot in the same place in
;;; memory that the full object system will expect to find it later. This
;;; is critical to the bootstrapping process, the whole changeover to the
;;; full object system is predicated on this.
;;;
;;; One important point is that the layout of standard classes and standard
;;; slots must be computed the same way in this file as it is by the full
;;; object system later.
;;;
(defun bootstrap-get-slot (type object slot-name)
(let ((index (bootstrap-slot-index type slot-name)))
(svref (std-instance-slots object) index)))
(defun bootstrap-set-slot (type object slot-name new-value)
(let ((index (bootstrap-slot-index type slot-name)))
(setf (svref (std-instance-slots object) index) new-value)))
(defvar *std-class-slots*
(mapcar #'canonical-slot-name
(early-collect-inheritance 'standard-class)))
(defvar *bin-class-slots*
(mapcar #'canonical-slot-name
(early-collect-inheritance 'built-in-class)))
(defvar *std-slotd-slots*
(mapcar #'canonical-slot-name
(early-collect-inheritance 'standard-slot-definition)))
(defun bootstrap-slot-index (type slot-name)
(or (position slot-name (ecase type
(std-class *std-class-slots*)
(bin-class *bin-class-slots*)
(std-slotd *std-slotd-slots*)))
(error "~S not found" slot-name)))
;;;
;;; bootstrap-meta-braid
;;;
;;; This function builds the base metabraid from the early class definitions.
;;;
(defun bootstrap-meta-braid ()
(let* ((std-class-size (length *std-class-slots*))
(std-class (%allocate-instance--class std-class-size))
(std-class-wrapper (make-wrapper std-class))
(built-in-class (%allocate-instance--class std-class-size))
(built-in-class-wrapper (make-wrapper built-in-class))
(direct-slotd (%allocate-instance--class std-class-size))
(effective-slotd (%allocate-instance--class std-class-size))
(direct-slotd-wrapper (make-wrapper direct-slotd))
(effective-slotd-wrapper (make-wrapper effective-slotd)))
;;
;; First, make a class metaobject for each of the early classes. For
;; each metaobject we also set its wrapper. Except for the class T,
;; the wrapper is always that of STANDARD-CLASS.
;;
(dolist (definition *early-class-definitions*)
(let* ((name (ecd-class-name definition))
(meta (ecd-metaclass definition))
(class (case name
(standard-class std-class)
(standard-direct-slot-definition direct-slotd)
(standard-effective-slot-definition effective-slotd)
(built-in-class built-in-class)
(otherwise
(%allocate-instance--class std-class-size)))))
(unless (eq name t)
(inform-type-system-about-class class name))
(setf (std-instance-wrapper class)
(ecase meta
(standard-class std-class-wrapper)
(built-in-class built-in-class-wrapper)))
(setf (find-class name) class)))
;;
;;
;;
(dolist (definition *early-class-definitions*)
(let ((name (ecd-class-name definition))
(source (ecd-source definition))
(direct-supers (ecd-superclass-names definition))
(direct-slots (ecd-canonical-slots definition))
(other-initargs (ecd-other-initargs definition)))
(let ((direct-default-initargs
(getf other-initargs :default-initargs)))
(multiple-value-bind (slots cpl default-initargs direct-subclasses)
(early-collect-inheritance name)
(let* ((class (find-class name))
(wrapper
(cond
((eq class std-class) std-class-wrapper)
((eq class direct-slotd) direct-slotd-wrapper)
((eq class effective-slotd) effective-slotd-wrapper)
((eq class built-in-class) built-in-class-wrapper)
(t (make-wrapper class))))
(proto nil))
(cond ((eq name 't)
(setq *the-wrapper-of-t* wrapper
*the-class-t* class))
((memq name '(standard-object standard-class))
(set (intern (format nil "*THE-CLASS-~A*" (symbol-name name))
*the-pcl-package*)
class)))
(dolist (slot slots)
(unless (eq (getf slot :allocation :instance) :instance)
(error "Slot allocation ~S not supported in bootstrap.")))
(setf (wrapper-instance-slots-layout wrapper)
(mapcar #'canonical-slot-name slots))
(setf (wrapper-class-slots wrapper)
())
(setq proto (%allocate-instance--class (length slots)))
(setf (std-instance-wrapper proto) wrapper)
(setq direct-slots
(bootstrap-make-slot-definitions direct-slots
direct-slotd-wrapper))
(setq slots
(bootstrap-make-slot-definitions slots
effective-slotd-wrapper))
(bootstrap-initialize-std-class
class name source
direct-supers direct-subclasses cpl wrapper
direct-slots slots direct-default-initargs default-initargs
proto)
(dolist (slotd direct-slots)
(bootstrap-accessor-definitions
name
(bootstrap-get-slot 'std-slotd slotd 'name)
(bootstrap-get-slot 'std-slotd slotd 'readers)
(bootstrap-get-slot 'std-slotd slotd 'writers))))))))))
(defun bootstrap-accessor-definitions (class-name slot-name readers writers)
(flet ((do-reader-definition (reader)
(add-method
(ensure-generic-function reader)
(make-a-method
'standard-reader-method
()
(list class-name)
(list class-name)
(make-std-reader-method-function slot-name)
"automatically generated reader method"
slot-name)))
(do-writer-definition (writer)
(add-method
(ensure-generic-function writer)
(make-a-method
'standard-writer-method
()
(list 'new-value class-name)
(list 't class-name)
(make-std-writer-method-function slot-name)
"automatically generated writer method"
slot-name))))
(dolist (reader readers) (do-reader-definition reader))
(dolist (writer writers) (do-writer-definition writer))))
;;;
;;; Initialize a standard class metaobject.
;;;
(defun bootstrap-initialize-std-class
(class
name definition-source direct-supers direct-subclasses cpl wrapper
direct-slots slots direct-default-initargs default-initargs proto)
(flet ((classes (names) (mapcar #'find-class names))
(set-slot (slot-name value)
(bootstrap-set-slot 'std-class class slot-name value)))
(set-slot 'name name)
(set-slot 'source definition-source)
(set-slot 'class-precedence-list (classes cpl))
(set-slot 'direct-superclasses (classes direct-supers))
(set-slot 'direct-slots direct-slots)
(set-slot 'direct-subclasses (classes direct-subclasses))
(set-slot 'direct-methods (cons nil nil))
(set-slot 'no-of-instance-slots (length slots))
(set-slot 'slots slots)
(set-slot 'wrapper wrapper)
(set-slot 'prototype proto)
(set-slot 'plist
`(,@(and direct-default-initargs
`(direct-default-initargs ,direct-default-initargs))
,@(and default-initargs
`(default-initargs ,default-initargs))))
))
;;;
;;; Initialize a built-in-class metaobject.
;;;
(defun bootstrap-initialize-bin-class
(class
name definition-source direct-supers direct-subclasses cpl wrapper)
(flet ((classes (names) (mapcar #'find-class names))
(set-slot (slot-name value)
(bootstrap-set-slot 'bin-class class slot-name value)))
(set-slot 'name name)
(set-slot 'source definition-source)
(set-slot 'direct-superclasses (classes direct-supers))
(set-slot 'direct-subclasses (classes direct-subclasses))
(set-slot 'direct-methods (cons nil nil))
(set-slot 'class-precedence-list (classes cpl))
(set-slot 'wrapper wrapper)))
(defun bootstrap-make-slot-definitions (slots wrapper)
(mapcar #'(lambda (slot) (bootstrap-make-slot-definition slot wrapper))
slots))
(defun bootstrap-make-slot-definition (slot wrapper)
(let ((slotd (%allocate-instance--class (length *std-slotd-slots*))))
(setf (std-instance-wrapper slotd) wrapper)
(flet ((get-val (name) (getf slot name))
(set-val (name val) (bootstrap-set-slot 'std-slotd slotd name val)))
(set-val 'name (get-val :name))
(set-val 'initform (get-val :initform))
(set-val 'initfunction (get-val :initfunction))
(set-val 'initargs (get-val :initargs))
(set-val 'readers (get-val :readers))
(set-val 'writers (get-val :writers))
(set-val 'allocation :instance)
(set-val 'type (get-val :type))
slotd)))
(defun bootstrap-built-in-classes ()
;;
;; First make sure that all the supers listed in *built-in-class-lattice*
;; are themselves defined by *built-in-class-lattice*. This is just to
;; check for typos and other sorts of brainos.
;;
(dolist (e *built-in-classes*)
(dolist (super (cadr e))
(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*."
(car e) super super))))
;;
;; In the first pass, we create a skeletal object to be bound to the
;; class name.
;;
(let* ((built-in-class (find-class 'built-in-class))
(built-in-class-wrapper (class-wrapper built-in-class))
(bin-class-size (length *bin-class-slots*)))
(dolist (e *built-in-classes*)
(let ((class (%allocate-instance--class bin-class-size)))
(setf (std-instance-wrapper class) built-in-class-wrapper)
(setf (find-class (car e)) class))))
;;
;; In the second pass, we initialize the class objects.
;;
(dolist (e *built-in-classes*)
(destructuring-bind (name supers subs cpl) e
(let* ((class (find-class name))
(wrapper (make-wrapper class)))
(set (get-built-in-class-symbol name) class)
(set (get-built-in-wrapper-symbol name) wrapper)
(setf (wrapper-instance-slots-layout wrapper) ()
(wrapper-class-slots wrapper) ())
(bootstrap-initialize-bin-class class
name nil
supers subs
(cons name cpl) wrapper)
))))
;;;
;;;
;;;
(defun class-of (x) (wrapper-class (wrapper-of x)))
(defun wrapper-of (x)
(or (and (std-instance-p x)
(std-instance-wrapper x))
(and (fsc-instance-p x)
(fsc-instance-wrapper x))
(built-in-wrapper-of x)
(error "Can't determine wrapper of ~S" x)))
(eval-when (compile eval)
(defun make-built-in-class-subs ()
(mapcar #'(lambda (e)
(let ((class (car e))
(class-subs ()))
(dolist (s *built-in-classes*)
(when (memq class (cadr s)) (pushnew (car s) class-subs)))
(cons class class-subs)))
(cons '(t) *built-in-classes*)))
(defun make-built-in-class-tree ()
(let ((subs (make-built-in-class-subs)))
(labels ((descend (class)
(cons class (mapcar #'descend (cdr (assq class subs))))))
(descend 't))))
(defun make-built-in-wrapper-of-body ()
(make-built-in-wrapper-of-body-1 (make-built-in-class-tree)
'x
#'get-built-in-wrapper-symbol))
(defun make-built-in-wrapper-of-body-1 (tree var get-symbol)
(let ((*specials* ()))
(declare (special *specials*))
(let ((inner (make-built-in-wrapper-of-body-2 tree var get-symbol)))
`(locally (declare (special .,*specials*)) ,inner))))
(defun make-built-in-wrapper-of-body-2 (tree var get-symbol)
(declare (special *specials*))
(let ((symbol (funcall get-symbol (car tree))))
(push symbol *specials*)
(let ((sub-tests
(mapcar #'(lambda (x)
(make-built-in-wrapper-of-body-2 x var get-symbol))
(cdr tree))))
`(and (typep ,var ',(car tree))
,(if sub-tests
`(or ,.sub-tests ,symbol)
symbol)))))
)
(defun built-in-wrapper-of (x)
#.(make-built-in-wrapper-of-body))
(eval-when (load eval)
(clrhash *find-class*)
(bootstrap-meta-braid)
(bootstrap-built-in-classes)
(setq *boot-state* 'braid)
(setf (symbol-function 'load-defclass) #'real-load-defclass)
)
;;;
;;; All of these method definitions must appear here because the bootstrap
;;; only allows one method per generic function until the braid is fully
;;; built.
;;;
(defmethod print-object (instance stream)
(printing-random-thing (instance stream)
(let ((name (class-name (class-of instance))))
(if name
(format stream "~S" name)
(format stream "Instance")))))
(defmethod print-object ((class class) stream)
(named-object-print-function class stream))
(defmethod print-object ((slotd standard-slot-definition) stream)
(named-object-print-function slotd stream))
(defun named-object-print-function (instance stream
&optional (extra nil extra-p))
(printing-random-thing (instance stream)
(if extra-p
(format stream "~A ~S ~:S"
(capitalize-words (class-name (class-of instance)))
(slot-value-or-default instance 'name)
extra)
(format stream "~A ~S"
(capitalize-words (class-name (class-of instance)))
(slot-value-or-default instance 'name)))))
;;;
;;;
;;;
;(defmethod shared-initialize :after ((class class) slot-names &key name)
; (declare (ignore slot-names))
; (setf (slot-value class 'name) name))
;
;
;(defmethod shared-initialize :after ((class std-class)
; slot-names
; &key direct-superclasses
; direct-slots)
; (declare (ignore slot-names))
; (setf (slot-value class 'direct-superclasses) direct-superclasses
; (slot-value class 'direct-slots) direct-slots))
;;;
;;;
;;;
(defmethod shared-initialize :after ((slotd standard-slot-definition)
slot-names
&key class
name
initform
initfunction
initargs
(allocation :instance)
(type t)
readers
writers)
(declare (ignore slot-names))
(setf (slot-value slotd 'name) name
(slot-value slotd 'initform) initform
(slot-value slotd 'initfunction) initfunction
(slot-value slotd 'initargs) initargs
(slot-value slotd 'allocation) (if (eq allocation :class) class allocation)
(slot-value slotd 'type) type
(slot-value slotd 'readers) readers
(slot-value slotd 'writers) writers))
This diff is collapsed.
;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
;;;
;;; *************************************************************************
;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
;;; All rights reserved.
;;;
;;; Use and copying of this software and preparation of derivative works
;;; based upon this software are permitted. Any distribution of this
;;; software or derivative works must comply with all applicable United
;;; States export control laws.
;;;
;;; This software is made available AS IS, and Xerox Corporation makes no
;;; warranty about the software, its performance or its conformity to any
;;; specification.
;;;
;;; Any person obtaining a copy of this software is requested to send their
;;; name and post office or electronic mail address to:
;;; CommonLoops Coordinator
;;; Xerox PARC
;;; 3333 Coyote Hill Rd.
;;; Palo Alto, CA 94304
;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
;;;
;;; Suggestions, comments and requests for improvements are also welcome.
;;; *************************************************************************
;;;
;;; This is the CMU Lisp version of the file low.
;;;
(in-package 'pcl)
;;
;;;;;; Cache No's
;;
;;; Abuse the type declaration, but it generates great code.
;(defun symbol-cache-no (symbol mask)
; (logand (the fixnum (system:%primitive lisp::make-immediate-type
; symbol
; system::%+-fixnum-type))
; (the fixnum mask)))
;
;(clc::deftransform symbol-cache-no symbol-cache-no-transform (symbol mask)
; `(logand (the fixnum (system:%primitive lisp::make-immediate-type
; ,symbol
; system::%+-fixnum-type))
; (the fixnum ,mask)))
(defun object-cache-no (symbol mask)
(logand (the fixnum (system:%primitive lisp::make-immediate-type
symbol
system::%+-fixnum-type))
(the fixnum mask)))
(clc::deftransform object-cache-no object-cache-no-transform (symbol mask)
`(logand (the fixnum (system:%primitive lisp::make-immediate-type
,symbol
system::%+-fixnum-type))
;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
;;;
;;; *************************************************************************
;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
;;; All rights reserved.
;;;
;;; Use and copying of this software and preparation of derivative works
;;; based upon this software are permitted. Any distribution of this
;;; software or derivative works must comply with all applicable United
;;; States export control laws.
;;;
;;; This software is made available AS IS, and Xerox Corporation makes no
;;; warranty about the software, its performance or its conformity to any
;;; specification.
;;;
;;; Any person obtaining a copy of this software is requested to send their
;;; name and post office or electronic mail address to:
;;; CommonLoops Coordinator
;;; Xerox PARC
;;; 3333 Coyote Hill Rd.
;;; Palo Alto, CA 94304
;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
;;;
;;; Suggestions, comments and requests for improvements are also welcome.
;;; *************************************************************************
;;;
(in-package 'pcl)
(defun make-effective-method-function (generic-function form)
(flet ((name-function (fn) (set-function-name fn 'a-combined-method) fn))
(if (and (listp form)
(eq (car form) 'call-method)
(method-p (cadr form))
(every #'method-p (caddr form)))
;;
;; The effective method is just a call to call-method. This opens up
;; the possibility of just using the method function of the method as
;; as the effective method function.
;;
;; But we have to be careful. If that method function will ask for
;; the next methods we have to provide them. We do not look to see
;; if there are next methods, we look at whether the method function
;; asks about them. If it does, we must tell it whether there are
;; or aren't to prevent the leaky next methods bug.
;;
(let* ((method-function (method-function (cadr form)))
(arg-info (gf-arg-info generic-function))
(metatypes (arg-info-metatypes arg-info))
(applyp (arg-info-applyp arg-info)))
(if (not (method-function-needs-next-methods-p method-function))
method-function
(let ((next-method-functions (mapcar #'method-function (caddr form))))
(name-function
(get-function `(lambda ,(make-dfun-lambda-list metatypes applyp)
(let ((*next-methods* .next-method-functions.))
,(make-dfun-call metatypes applyp '.method-function.)))
#'default-test-converter ;This could be optimized by making
;the interface from here to the
;walker more clear so that the
;form wouldn't get walked at all.
#'(lambda (form)
(if (memq form '(.next-method-functions. .method-function.))
(values form (list form))
form))
#'(lambda (form)
(cond ((eq form '.next-method-functions.)
(list next-method-functions))
((eq form '.method-function.)
(list method-function)))))))))
;;
;; We have some sort of `real' effective method. Go off and get a
;; compiled function for it. Most of the real hair here is done by
;; the GET-FUNCTION mechanism.
;;
(name-function (make-effective-method-function-internal generic-function form)))))
(defvar *global-effective-method-gensyms* ())
(defvar *rebound-effective-method-gensyms*)
(defun get-effective-method-gensym ()
(or (pop *rebound-effective-method-gensyms*)
(let ((new (make-symbol "EFFECTIVE-METHOD-GENSYM-")))
(push new *global-effective-method-gensyms*)
new)))
(eval-when (load)
(let ((*rebound-effective-method-gensyms* ()))
(dotimes (i 10) (get-effective-method-gensym))))
(defun make-effective-method-function-internal (generic-function effective-method)
(let* ((*rebound-effective-method-gensyms* *global-effective-method-gensyms*)
(arg-info (gf-arg-info generic-function))
(metatypes (arg-info-metatypes arg-info))
(applyp (arg-info-applyp arg-info)))
(labels ((test-converter (form)
(if (and (consp form) (eq (car form) 'call-method))
'.call-method.
(default-test-converter form)))
(code-converter (form)
(if (and (consp form) (eq (car form) 'call-method))
;;
;; We have a `call' to CALL-METHOD. There may or may not be next methods
;; and the two cases are a little different. It controls how many gensyms
;; we will generate.
;;
(let ((gensyms
(if (cddr form)
(list (get-effective-method-gensym)
(get-effective-method-gensym))
(list (get-effective-method-gensym)
()))))
(values `(let ((*next-methods* ,(cadr gensyms)))
,(make-dfun-call metatypes applyp (car gensyms)))
gensyms))
(default-code-converter form)))
(constant-converter (form)
(if (and (consp form) (eq (car form) 'call-method))
(if (cddr form)
(list (check-for-make-method (cadr form))
(mapcar #'check-for-make-method (caddr form)))
(list (check-for-make-method (cadr form))
()))
(default-constant-converter form)))
(check-for-make-method (effective-method)
(cond ((method-p effective-method)
(method-function effective-method))
((and (listp effective-method)
(eq (car effective-method) 'make-method))
(make-effective-method-function generic-function
(make-progn (cadr effective-method))))
(t
(error "Effective-method form is malformed.")))))
(get-function `(lambda ,(make-dfun-lambda-list metatypes applyp) ,effective-method)
#'test-converter
#'code-converter
#'constant-converter))))
(defvar *invalid-method-error*
#'(lambda (&rest args)
(declare (ignore args))
(error
"INVALID-METHOD-ERROR was called outside the dynamic scope~%~
of a method combination function (inside the body of~%~
DEFINE-METHOD-COMBINATION or a method on the generic~%~
function COMPUTE-EFFECTIVE-METHOD).")))
(defvar *method-combination-error*
#'(lambda (&rest args)
(declare (ignore args))
(error
"METHOD-COMBINATION-ERROR was called outside the dynamic scope~%~
of a method combination function (inside the body of~%~
DEFINE-METHOD-COMBINATION or a method on the generic~%~
function COMPUTE-EFFECTIVE-METHOD).")))
;(defmethod compute-effective-method :around ;issue with magic
; ((generic-function generic-function) ;generic functions
; (method-combination method-combination)
; applicable-methods)
; (declare (ignore applicable-methods))
; (flet ((real-invalid-method-error (method format-string &rest args)
; (declare (ignore method))
; (apply #'error format-string args))
; (real-method-combination-error (format-string &rest args)
; (apply #'error format-string args)))
; (let ((*invalid-method-error* #'real-invalid-method-error)
; (*method-combination-error* #'real-method-combination-error))
; (call-next-method))))
(defun invalid-method-error (&rest args)
(declare (arglist method format-string &rest format-arguments))
(apply *invalid-method-error* args))
(defun method-combination-error (&rest args)
(declare (arglist format-string &rest format-arguments))
(apply *method-combination-error* args))
;;;
;;; The STANDARD method combination type. This is coded by hand (rather than
;;; with define-method-combination) for bootstrapping and efficiency reasons.
;;; Note that the definition of the find-method-combination-method appears in
;;; the file defcombin.lisp, this is because EQL methods can't appear in the
;;; bootstrap.
;;;
;;; The defclass for the METHOD-COMBINATION and STANDARD-METHOD-COMBINATION
;;; classes has to appear here for this reason. This code must conform to
;;; the code in the file defcombin, look there for more details.
;;;
(defclass method-combination () ())
(define-gf-predicate method-combination-p method-combination)
(defclass standard-method-combination
(definition-source-mixin method-combination)
((type :reader method-combination-type
:initarg :type)
(documentation :reader method-combination-documentation
:initarg :documentation)
(options :reader method-combination-options
:initarg :options)))
(defmethod print-object ((mc method-combination) stream)
(printing-random-thing (mc stream)
(format stream
"Method-Combination ~S ~S"
(method-combination-type mc)
(method-combination-options mc))))
(eval-when (load eval)
(setq *standard-method-combination*
(make-instance 'standard-method-combination
:type 'standard
:documentation "The standard method combination."
:options ())))
;This definition appears in defcombin.lisp.
;
;(defmethod find-method-combination ((generic-function generic-function)
; (type (eql 'standard))
; options)
; (when options
; (method-combination-error
; "The method combination type STANDARD accepts no options."))
; *standard-method-combination*)
(defun make-call-methods (methods)
(mapcar #'(lambda (method) `(call-method ,method ())) methods))
(defmethod compute-effective-method ((generic-function generic-function)
(combin standard-method-combination)
applicable-methods)
(let ((before ())
(primary ())
(after ())
(around ()))
(dolist (m applicable-methods)
(let ((qualifiers (method-qualifiers m)))
(cond ((member ':before qualifiers) (push m before))
((member ':after qualifiers) (push m after))
((member ':around qualifiers) (push m around))
(t
(push m primary)))))
(setq before (reverse before)
after (reverse after)
primary (reverse primary)
around (reverse around))
(cond ((null primary)
`(error "No primary method for the generic function ~S." ',generic-function))
((and (null before) (null after) (null around))
;;
;; By returning a single call-method `form' here we enable an important
;; implementation-specific optimization.
;;
`(call-method ,(first primary) ,(rest primary)))
(t
(let ((main-effective-method
(if (or before after (rest primary))
`(multiple-value-prog1
(progn ,@(make-call-methods before)
(call-method ,(first primary) ,(rest primary)))
,@(make-call-methods (reverse after)))
`(call-method ,(first primary) ()))))
(if around
`(call-method ,(first around)
(,@(rest around) (make-method ,main-effective-method)))
main-effective-method))))))
;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp; -*-
;;;
;;; *************************************************************************
;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
;;; All rights reserved.
;;;
;;; Use and copying of this software and preparation of derivative works
;;; based upon this software are permitted. Any distribution of this
;;; software or derivative works must comply with all applicable United
;;; States export control laws.
;;;
;;; This software is made available AS IS, and Xerox Corporation makes no
;;; warranty about the software, its performance or its conformity to any
;;; specification.
;;;
;;; Any person obtaining a copy of this software is requested to send their
;;; name and post office or electronic mail address to:
;;; CommonLoops Coordinator
;;; Xerox PARC
;;; 3333 Coyote Hill Rd.
;;; Palo Alto, CA 94304
;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
;;;
;;; Suggestions, comments and requests for improvements are also welcome.
;;; *************************************************************************
;;;
(in-package 'pcl)
()
This diff is collapsed.
;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*-
;;;
;;; *************************************************************************
;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
;;; All rights reserved.
;;;
;;; Use and copying of this software and preparation of derivative works
;;; based upon this software are permitted. Any distribution of this
;;; software or derivative works must comply with all applicable United
;;; States export control laws.
;;;
;;; This software is made available AS IS, and Xerox Corporation makes no
;;; warranty about the software, its performance or its conformity to any
;;; specification.
;;;
;;; Any person obtaining a copy of this software is requested to send their
;;; name and post office or electronic mail address to:
;;; CommonLoops Coordinator
;;; Xerox PARC
;;; 3333 Coyote Hill Rd.
;;; Palo Alto, CA 94304
;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
;;;
;;; Suggestions, comments and requests for improvements are also welcome.
;;; *************************************************************************
;;;
(in-package 'pcl)
#-:ccl-1.3
(ccl::add-transform 'std-instance-p
:inline
#'(lambda (call)
(ccl::verify-arg-count call 1 1)
(let ((arg (cadr call)))
`(and (eq (ccl::%type-of ,arg) 'structure)
(eq (%svref ,arg 0) 'std-instance)))))
(eval-when (eval compile load)
(proclaim '(inline std-instance-p)))
(defun printing-random-thing-internal (thing stream)
(prin1 (ccl::%ptr-to-int thing) stream))
(defun set-function-name-1 (function new-name uninterned-name)
(declare (ignore uninterned-name))
(cond ((ccl::lfunp function)
(ccl::lfun-name function new-name)))
function)
(defun doctor-dfun-for-the-debugger (gf dfun)
#+:ccl-1.3
(let* ((gfspec (and (symbolp (generic-function-name gf))
(generic-function-name gf)))
(arglist (generic-function-pretty-arglist gf)))
(when gfspec
(setf (get gfspec 'ccl::%lambda-list)
(if (and arglist (listp arglist))
(format nil "~{~A~^ ~}" arglist)
(format nil "~:A" arglist)))))
;; -[Thu Feb 22 08:38:07 1990 by jkf]-
;; cpatch.cl
;; compiler patch for the fast clos
;;
;; copyright (c) 1990 Franz Inc.
;;
(in-package :comp)
(def-quad-op tail-funcall qp-end-block
;; u = (argcount function-object)
;;
;; does a tail call to the function-object given
;; never returns
)
(defun-in-runtime sys::copy-function (func))
(in-package :hyperion)
(def-quad-hyp r-tail-funcall comp::tail-funcall (u d quad)
;; u = (argcount function)
;;
(r-move-single-to-loc (treg-loc (car u)) *count-reg*)
(r-move-single-to-loc (treg-loc (cadr u)) *fcnin-reg*)
(re restore *zero-reg* *zero-reg*)
(re move.l `(d #.r-function-start-adj #.*fcnout-reg*) '#.*ctr2-reg*)
(re jmpl '(d 0 #.*ctr2-reg*) *zero-reg*)
(re nop))
;;;-*-Mode:LISP; Package:PCL; Base:10; Syntax:Common-lisp -*-
;;;
;;; *************************************************************************
;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
;;; All rights reserved.
;;;
;;; Use and copying of this software and preparation of derivative works
;;; based upon this software are permitted. Any distribution of this
;;; software or derivative works must comply with all applicable United
;;; States export control laws.
;;;
;;; This software is made available AS IS, and Xerox Corporation makes no
;;; warranty about the software, its performance or its conformity to any
;;; specification.
;;;
;;; Any person obtaining a copy of this software is requested to send their
;;; name and post office or electronic mail address to:
;;; CommonLoops Coordinator
;;; Xerox PARC
;;; 3333 Coyote Hill Rd.
;;; Palo Alto, CA 94304
;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
;;;
;;; Suggestions, comments and requests for improvements are also welcome.
;;; *************************************************************************
;;;
(in-package 'pcl)
;;;
;;; compute-class-precedence-list
;;;
;;; Knuth section 2.2.3 has some interesting notes on this.
;;;
;;; What appears here is basically the algorithm presented there.
;;;
;;; The key idea is that we use class-precedence-description (CPD) structures
;;; to store the precedence information as we proceed. The CPD structure for
;;; a class stores two critical pieces of information:
;;;
;;; - a count of the number of "reasons" why the class can't go
;;; into the class precedence list yet.
;;;
;;; - a list of the "reasons" this class prevents others from
;;; going in until after it
;;
;;; A "reason" is essentially a single local precedence constraint. If a
;;; constraint between two classes arises more than once it generates more
;;; than one reason. This makes things simpler, linear, and isn't a problem
;;; as long as we make sure to keep track of each instance of a "reason".
;;;
;;; This code is divided into three phases.
;;;
;;; - the first phase simply generates the CPD's for each of the class
;;; and its superclasses. The remainder of the code will manipulate
;;; these CPDs rather than the class objects themselves. At the end
;;; of this pass, the CPD-SUPERS field of a CPD is a list of the CPDs
;;; of the direct superclasses of the class.
;;;
;;; - the second phase folds all the local constraints into the CPD
;;; structure. The CPD-COUNT of each CPD is built up, and the
;;; CPD-AFTER fields are augmented to include precedence constraints
;;; from the CPD-SUPERS field and from the order of classes in other
;;; CPD-SUPERS fields.
;;;
;;; After this phase, the CPD-AFTER field of a class includes all the
;;; direct superclasses of the class plus any class that immediately
;;; follows the class in the direct superclasses of another. There
;;; can be duplicates in this list. The CPD-COUNT field is equal to
;;; the number of times this class appears in the CPD-AFTER field of
;;; all the other CPDs.
;;;
;;; - In the third phase, classes are put into the precedence list one
;;; at a time, with only those classes with a CPD-COUNT of 0 being
;;; candidates for insertion. When a class is inserted , every CPD
;;; in its CPD-AFTER field has its count decremented.
;;;
;;; In the usual case, there is only one candidate for insertion at
;;; any point. If there is more than one, the specified tiebreaker
;;; rule is used to choose among them.
;;;
(defmethod compute-class-precedence-list ((root std-class) direct-superclasses)
(compute-std-cpl root direct-superclasses))
(defstruct (class-precedence-description
(:conc-name nil)
(:print-function (lambda (obj str depth)
(declare (ignore depth))
(format str
"#<CPD ~S ~D>"
(class-name (cpd-class obj))
(cpd-count obj))))
(:constructor make-cpd ()))
(cpd-class nil)
(cpd-supers ())
(cpd-after ())
(cpd-count 0))
(defun compute-std-cpl (class supers)
(cond ((null supers) ;First two branches of COND
(list class)) ;are implementing the single
((null (cdr supers)) ;inheritance optimization.
(cons class
(compute-std-cpl (car supers)
(class-direct-superclasses (car supers)))))
(t
(multiple-value-bind (all-cpds nclasses)
(compute-std-cpl-phase-1 class supers)
(compute-std-cpl-phase-2 all-cpds)
(compute-std-cpl-phase-3 class all-cpds nclasses)))))
(defvar *compute-std-cpl-class->entry-table-size* 60)
(defun compute-std-cpl-phase-1 (class supers)
(let ((nclasses 0)
(all-cpds ())
(table (make-hash-table :size *compute-std-cpl-class->entry-table-size*
:test #'eq)))
(labels ((get-cpd (c)
(or (gethash c table)
(setf (gethash c table) (make-cpd))))
(walk (c supers)
(if (forward-referenced-class-p c)
(cpl-forward-referenced-class-error class c)
(let ((cpd (get-cpd c)))
(unless (cpd-class cpd) ;If we have already done this
;class before, we can quit.
(setf (cpd-class cpd) c)
(incf nclasses)
(push cpd all-cpds)
(setf (cpd-supers cpd) (mapcar #'get-cpd supers))
(dolist (super supers)
(walk super (class-direct-superclasses super))))))))
(walk class supers)
(values all-cpds nclasses))))
(defun compute-std-cpl-phase-2 (all-cpds)
(dolist (cpd all-cpds)
(let ((supers (cpd-supers cpd)))
(when supers
(setf (cpd-after cpd) (nconc (cpd-after cpd) supers))
(incf (cpd-count (car supers)) 1)
(do* ((t1 supers t2)
(t2 (cdr t1) (cdr t1)))
((null t2))
(incf (cpd-count (car t2)) 2)
(push (car t2) (cpd-after (car t1))))))))
(defun compute-std-cpl-phase-3 (class all-cpds nclasses)
(let ((candidates ())
(next-cpd nil)
(rcpl ()))
;;
;; We have to bootstrap the collection of those CPD's that
;; have a zero count. Once we get going, we will maintain
;; this list incrementally.
;;
(dolist (cpd all-cpds)
(when (zerop (cpd-count cpd)) (push cpd candidates)))
(loop
(when (null candidates)
;;
;; If there are no candidates, and enough classes have been put
;; into the precedence list, then we are all done. Otherwise
;; it means there is a consistency problem.
(if (zerop nclasses)
(return (reverse rcpl))
(cpl-inconsistent-error class all-cpds)))
;;
;; Try to find the next class to put in from among the candidates.
;; If there is only one, its easy, otherwise we have to use the
;; famous RPG tiebreaker rule. There is some hair here to avoid
;; having to call DELETE on the list of candidates. I dunno if
;; its worth it but what the hell.
;;
(setq next-cpd
(if (null (cdr candidates))
(prog1 (car candidates)
(setq candidates ()))
(block tie-breaker
(dolist (c rcpl)
(let ((supers (class-direct-superclasses c)))
(if (memq (cpd-class (car candidates)) supers)
(return-from tie-breaker (pop candidates))
(do ((loc candidates (cdr loc)))
((null (cdr loc)))
(let ((cpd (cadr loc)))
(when (memq (cpd-class cpd) supers)
(setf (cdr loc) (cddr loc))
(return-from tie-breaker cpd))))))))))
(decf nclasses)
(push (cpd-class next-cpd) rcpl)
(dolist (after (cpd-after next-cpd))
(when (zerop (decf (cpd-count after)))
(push after candidates))))))
;;;
;;; Support code for signalling nice error messages.
;;;
(defun cpl-error (class format-string &rest format-args)
(error "While computing the class precedence list of the class ~A.~%~A"
(if (class-name class)
(format nil "named ~S" (class-name class))
class)
(apply #'format nil format-string format-args)))
(defun cpl-forward-referenced-class-error (class forward-class)
(flet ((class-or-name (class)
(if (class-name class)
(format nil "named ~S" (class-name class))
class)))
(let ((names (mapcar #'class-or-name
(cdr (find-superclass-chain class forward-class)))))
(cpl-error class
"The class ~A is a forward referenced class.~@
The class ~A is ~A."
(class-or-name forward-class)
(class-or-name forward-class)
(if (null (cdr names))
(format nil
"a direct superclass of the class ~A"
(class-or-name class))
(format nil
"reached from the class ~A by following~@
the direct superclass chain through: ~A~
~% ending at the class ~A"
(class-or-name class)
(format nil
"~{~% the class ~A,~}"
(butlast names))
(car (last names))))))))
(defun find-superclass-chain (bottom top)
(labels ((walk (c chain)
(if (eq c top)
(return-from find-superclass-chain (nreverse chain))
(dolist (super (class-direct-superclasses c))
(walk super (cons super chain))))))
(walk bottom (list bottom))))
(defun cpl-inconsistent-error (class all-cpds)
(let ((reasons (find-cycle-reasons all-cpds)))
(cpl-error class
"It is not possible to compute the class precedence list because~@
there ~A in the local precedence relations.~@
~A because:~{~% ~A~}."
(if (cdr reasons) "are circularities" "is a circularity")
(if (cdr reasons) "These arise" "This arises")
(format-cycle-reasons (apply #'append reasons)))))
(defun format-cycle-reasons (reasons)
(flet ((class-or-name (cpd)
(let ((class (cpd-class cpd)))
(if (class-name class)
(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))))))
reasons)))
(defun find-cycle-reasons (all-cpds)
(let ((been-here ()) ;List of classes we have visited.
(cycle-reasons ()))
(labels ((chase (path)
(if (memq (car path) (cdr path))
(record-cycle (memq (car path) (nreverse path)))
(unless (memq (car path) been-here)
(push (car path) been-here)
(dolist (after (cpd-after (car path)))
(chase (cons after path))))))
(record-cycle (cycle)
(let ((reasons ()))
(do* ((t1 cycle t2)
(t2 (cdr t1) (cdr t1)))
((null t2))
(let ((c1 (car t1))
(c2 (car t2)))
(if (memq c2 (cpd-supers c1))
(push (list c1 c2 :super) reasons)
(dolist (cpd all-cpds)
(when (memq c2 (memq c1 (cpd-supers cpd)))
(return
(push (list c1 c2 :in-supers cpd) reasons)))))))
(push (nreverse reasons) cycle-reasons))))
(dolist (cpd all-cpds)
(unless (zerop (cpd-count cpd))
(chase (list cpd))))
;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
;;;
;;; *************************************************************************
;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
;;; All rights reserved.
;;;
;;; Use and copying of this software and preparation of derivative works
;;; based upon this software are permitted. Any distribution of this
;;; software or derivative works must comply with all applicable United
;;; States export control laws.
;;;
;;; This software is made available AS IS, and Xerox Corporation makes no
;;; warranty about the software, its performance or its conformity to any
;;; specification.
;;;
;;; Any person obtaining a copy of this software is requested to send their
;;; name and post office or electronic mail address to:
;;; CommonLoops Coordinator
;;; Xerox PARC
;;; 3333 Coyote Hill Rd.
;;; Palo Alto, CA 94304
;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
;;;
;;; Suggestions, comments and requests for improvements are also welcome.
;;; *************************************************************************
;;;
(in-package 'pcl)
;;;
;;; The built-in method combination types as taken from page 1-31 of 88-002R.
;;; Note that the STANDARD method combination type is defined by hand in the
;;; file combin.lisp.
;;;
(define-method-combination + :identity-with-one-argument t)
(define-method-combination and :identity-with-one-argument t)
(define-method-combination append :identity-with-one-argument nil)
(define-method-combination list :identity-with-one-argument nil)
(define-method-combination max :identity-with-one-argument t)
(define-method-combination min :identity-with-one-argument t)
(define-method-combination nconc :identity-with-one-argument t)
(define-method-combination or :identity-with-one-argument t)
(define-method-combination progn :identity-with-one-argument t)
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment