From 683874b497a99cd2c11b6c5d9b47e2785b1ede5f Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Wed, 26 Dec 2001 22:25:11 +0000 Subject: [PATCH] 0.pre7.98: belatedly 'cvs remove src/pcl/iterate.lisp' deleted dead code that I noticed when looking at NJF patch... ...DEFCONSTRUCTOR ...MAKE-CONSTRUCTOR ...LOAD-CONSTRUCTOR ...ENABLE-CONSTRUCTORS ...DISABLE-CONSTRUCTORS ...RESET-CONSTRUCTORS ...MAP-CONSTRUCTORS ...INSTALL-LAZY-CONSTRUCTOR-INSTALLER ...COMPUTE-CONSTRUCTOR-CODE ...SET-CONSTRUCTOR-CODE ...ADD-CONSTRUCTOR, REMOVE-CONSTRUCTOR, GET-CONSTRUCTOR ...CLASS-CONSTRUCTORS added note that more (all?) of construct.lisp might be dead --- TODO | 8 +- src/pcl/construct.lisp | 440 ++------------- src/pcl/fast-init.lisp | 6 - src/pcl/generic-functions.lisp | 2 - src/pcl/iterate.lisp | 1210 ---------------------------------------- src/pcl/std-class.lisp | 3 - version.lisp-expr | 2 +- 7 files changed, 58 insertions(+), 1613 deletions(-) delete mode 100644 src/pcl/iterate.lisp diff --git a/TODO b/TODO index a861858..506b353 100644 --- a/TODO +++ b/TODO @@ -13,9 +13,13 @@ for 0.7.0: * global style systematization: ** s/#'(lambda/(lambda/ ** four-space indentation in C -* pending patches that go in (or else get rejected) before 0.7.0: - ** Alexey Dejneka "BUG in nested backquotes processing" +* pending patches and bug reports that go in (or else get handled + somehow, rejected/logged/whatever) before 0.7.0: + ** AD "BUG in nested backquotes processing" sbcl-devel 2001-12-21 + ** NJF bug report "bug in COPY-READTABLE" and AD patch, + both sbcl-devel 2001-12-24 + ** AD patch for other readtable functions, sbcl-devel 2001-12-24 ======================================================================= for early 0.7.x: diff --git a/src/pcl/construct.lisp b/src/pcl/construct.lisp index 3fc122b..501ff2d 100644 --- a/src/pcl/construct.lisp +++ b/src/pcl/construct.lisp @@ -1,5 +1,10 @@ -;;;; This file defines the defconstructor and other make-instance optimization -;;;; mechanisms. +;;;; This file defines MAKE-INSTANCE optimization mechanisms. +;;;; +;;;; KLUDGE: I removed the old DEFCONSTRUCTOR, MAKE-CONSTRUCTOR, and +;;;; LOAD-CONSTRUCTOR families of definitions in sbcl-0.pre7.99, since +;;;; it was clear from a few minutes with egrep that they were dead +;;;; code, but I suspect more dead code remains in this file. (Maybe +;;;; it's all dead?) -- WHN 2001-12-26 ;;;; This software is part of the SBCL system. See the README file for ;;;; more information. @@ -26,146 +31,6 @@ (in-package "SB-PCL") -;;; defconstructor is used to define special purpose functions which just -;;; call make-instance with a symbol as the first argument. The semantics -;;; of defconstructor is that it is equivalent to defining a function which -;;; just calls make-instance. The purpose of defconstructor is to provide -;;; PCL with a way of noticing these calls to make-instance so that it can -;;; optimize them. Specific ports of PCL could just have their compiler -;;; spot these calls to make-instance and then call this code. Having the -;;; special defconstructor facility is the best we can do portably. -;;; -;;; A call to defconstructor like: -;;; -;;; (defconstructor make-foo foo (a b &rest r) a a :mumble b baz r) -;;; -;;; Is equivalent to a defun like: -;;; -;;; (defun make-foo (a b &rest r) -;;; (make-instance 'foo 'a a ':mumble b 'baz r)) -;;; -;;; Calls like the following are also legal: -;;; -;;; (defconstructor make-foo foo ()) -;;; (defconstructor make-bar bar () :x *x* :y *y*) -;;; (defconstructor make-baz baz (a b c) a-b (list a b) b-c (list b c)) -;;; -;;; The general idea of this implementation is that the expansion of the -;;; defconstructor form includes the creation of closure generators which -;;; can be called to create constructor code for the class. The ways that -;;; a constructor can be optimized depends not only on the defconstructor -;;; form, but also on the state of the class and the generic functions in -;;; the initialization protocol. Because of this, the determination of the -;;; form of constructor code to be used is a two part process. -;;; -;;; At compile time, make-constructor-code-generators looks at the actual -;;; defconstructor form and makes a list of appropriate constructor code -;;; generators. All that is really taken into account here is whether -;;; any initargs are supplied in the call to make-instance, and whether -;;; any of those are constant. -;;; -;;; At constructor code generation time (see note about lazy evaluation) -;;; compute-constructor-code calls each of the constructor code generators -;;; to try to get code for this constructor. Each generator looks at the -;;; state of the class and initialization protocol generic functions and -;;; decides whether its type of code is appropriate. This depends on things -;;; like whether there are any applicable methods on initialize-instance, -;;; whether class slots are affected by initialization etc. -;;; -;;; Constructor objects are funcallable instances, the protocol followed to -;;; to compute the constructor code for them is quite similar to the protocol -;;; followed to compute the discriminator code for a generic function. When -;;; the constructor is first loaded, we install as its code a function which -;;; will compute the actual constructor code the first time it is called. -;;; -;;; If there is an update to the class structure which might invalidate the -;;; optimized constructor, the special lazy constructor installer is put back -;;; so that it can compute the appropriate constructor when it is called. -;;; This is the same kind of lazy evaluation update strategy used elswhere -;;; in PCL. -;;; -;;; To allow for flexibility in the PCL implementation and to allow PCL users -;;; to specialize this constructor facility for their own metaclasses, there -;;; is an internal protocol followed by the code which loads and installs -;;; the constructors. This is documented in the comments in the code. -;;; -;;; This code is also designed so that one of its levels, can be used to -;;; implement optimization of calls to make-instance which can't go through -;;; the defconstructor facility. This has not been implemented yet, but the -;;; hooks are there. - -(defmacro defconstructor - (name class lambda-list &rest initialization-arguments) - (expand-defconstructor class - name - lambda-list - (copy-list initialization-arguments))) - -(defun expand-defconstructor (class-name name lambda-list supplied-initargs) - (let ((class (find-class class-name nil)) - (supplied-initarg-names - (loop for name in supplied-initargs by #'cddr - collect name))) - (when (null class) - (error "defconstructor form being compiled (or evaluated) before~@ - class ~S is defined." - class-name)) - `(progn - ;; comments from PCL code back when it was portable: - ;; In order to avoid undefined function warnings, we want to - ;; tell the compile time environment that a function with this - ;; name and this argument list has been defined. The portable - ;; way to do this is with defun: - ;; #-cmu (declaim (notinline ,name)) - ;; #-cmu - ;; (defun ,name ,lambda-list - ;; (declare (ignore ,@(extract-parameters lambda-list))) - ;; (error "Constructor ~S not loaded." ',name)) - ;; But the derived result type for the above is wrong under CMU CL. - ;; So instead: - (declaim (ftype ,(ftype-declaration-from-lambda-list lambda-list name) - ,name)) - (load-constructor - ',class-name - ',(class-name (class-of class)) - ',name - ',supplied-initarg-names - ;; make-constructor-code-generators is called to return a list - ;; of constructor code generators. The actual interpretation - ;; of this list is left to compute-constructor-code, but the - ;; general idea is that it should be an plist where the keys - ;; name a kind of constructor code and the values are generator - ;; functions which return the actual constructor code. The - ;; constructor code is usually a closures over the arguments - ;; to the generator. - ,(make-constructor-code-generators class - name - lambda-list - supplied-initarg-names - supplied-initargs))))) - -(defun load-constructor (class-name metaclass-name constructor-name - supplied-initarg-names code-generators) - (let ((class (find-class class-name nil))) - (cond ((null class) - (error "defconstructor form being loaded (or evaluated) before~@ - class ~S is defined." - class-name)) - ((neq (class-name (class-of class)) metaclass-name) - (error "When defconstructor ~S was compiled, the metaclass of the~@ - class ~S was ~S. The metaclass is now ~S.~@ - The constructor must be recompiled." - constructor-name - class-name - metaclass-name - (class-name (class-of class)))) - (t - (load-constructor-internal class - constructor-name - supplied-initarg-names - code-generators) - constructor-name)))) - ;;; The actual constructor objects. (defclass constructor (funcallable-standard-object) ((class ;The class with which this @@ -177,8 +42,9 @@ :initform nil ;This is the symbol in whose :initarg :name ;function cell the constructor :reader constructor-name) ;usually sits. Of course, this - ;is optional. defconstructor - ;makes named constructors, but + ;is optional. The old + ;DEFCONSTRUCTOR macro made + ;named constructors, but ;it is possible to manipulate ;anonymous constructors also. @@ -201,14 +67,6 @@ :reader constructor-code-generators)) ;could use. (:metaclass funcallable-standard-class)) -;;; Because the value in the code-type slot should always correspond -;;; to the FUNCALLABLE-INSTANCE-FUN of the constructor, this function -;;; should always be used to set them both at the same time. -(defun set-constructor-code (constructor code type) - (set-funcallable-instance-fun constructor code) - (set-fun-name constructor (constructor-name constructor)) - (setf (constructor-code-type constructor) type)) - (defmethod describe-object ((constructor constructor) stream) (format stream "~S is a constructor for the class ~S.~%~ @@ -220,137 +78,43 @@ (doplist (key val) (constructor-code-generators constructor) (push key collect)) (nreverse collect)))) - -;;; I am not in a hairy enough mood to make this implementation be -;;; metacircular enough that it can support a defconstructor for -;;; constructor objects. -(defun make-constructor (class name supplied-initarg-names code-generators) - (make-instance 'constructor - :class class - :name name - :supplied-initarg-names supplied-initarg-names - :code-generators code-generators)) - -; This definition actually appears in std-class.lisp. -;(defmethod class-constructors ((class std-class)) -; (with-slots (plist) class (getf plist 'constructors))) - -(defmethod add-constructor ((class slot-class) - (constructor constructor)) - (with-slots (plist) class - (pushnew constructor (getf plist 'constructors)))) - -(defmethod remove-constructor ((class slot-class) - (constructor constructor)) - (with-slots (plist) class - (setf (getf plist 'constructors) - (delete constructor (getf plist 'constructors))))) - -(defmethod get-constructor ((class slot-class) name &optional (error-p t)) - (or (dolist (c (class-constructors class)) - (when (eq (constructor-name c) name) (return c))) - (if error-p - (error "Couldn't find a constructor with name ~S for class ~S." - name class) - ()))) - -;;; This is called to actually load a defconstructor constructor. It -;;; must install the lazy installer in the function cell of the -;;; constructor name, and also add this constructor to the list of -;;; constructors the class has. -(defmethod load-constructor-internal - ((class slot-class) name initargs generators) - (let ((constructor (make-constructor class name initargs generators)) - (old (get-constructor class name nil))) - (when old (remove-constructor class old)) - (install-lazy-constructor-installer constructor) - (add-constructor class constructor) - (setf (gdefinition name) constructor))) - -(defmethod install-lazy-constructor-installer ((constructor constructor)) - (let ((class (constructor-class constructor))) - (set-constructor-code constructor - #'(sb-kernel:instance-lambda (&rest args) - (multiple-value-bind (code type) - (compute-constructor-code class constructor) - (set-constructor-code constructor code type) - (apply constructor args))) - 'lazy))) - -;;; the interface to keeping the constructors updated -;;; -;;; add-method and remove-method (for standard-generic-function and -;;; -method), promise to call maybe-update-constructors on the generic -;;; function and the method. -;;; -;;; The class update code promises to call update-constructors -;;; whenever the class is changed. That is, whenever the supers, slots -;;; or options change. If user defined classes of constructor needs to -;;; be updated in more than these circumstances, they should use the -;;; dependent updating mechanism to make sure update-constructors is -;;; called. -;;; -;;; Bootstrapping concerns force the definitions of -;;; maybe-update-constructors and update-constructors to be in the -;;; file std-class. For clarity, they also appear below. Be sure to -;;; keep the definition here and there in sync. -;(defvar *initialization-generic-functions* -; (list #'make-instance -; #'default-initargs -; #'allocate-instance -; #'initialize-instance -; #'shared-initialize)) -; -;(defmethod maybe-update-constructors -; ((generic-function generic-function) -; (method method)) -; (when (memq generic-function *initialization-generic-functions*) -; (labels ((recurse (class) -; (update-constructors class) -; (dolist (subclass (class-direct-subclasses class)) -; (recurse subclass)))) -; (when (classp (car (method-specializers method))) -; (recurse (car (method-specializers method))))))) -; -;(defmethod update-constructors ((class slot-class)) -; (dolist (cons (class-constructors class)) -; (install-lazy-constructor-installer cons))) -; -;(defmethod update-constructors ((class class)) -; ()) -;;; Here is the actual smarts for making the code generators and then trying -;;; each generator to get constructor code. This extensible mechanism allows -;;; new kinds of constructor code types to be added. A programmer defining a -;;; specialization of the constructor class can either use this mechanism to -;;; define new code types, or can override this mechanism by overriding the -;;; methods on make-constructor-code-generators and compute-constructor-code. -;;; -;;; The function defined by define-constructor-code-type will receive the -;;; class object, and the 4 original arguments to defconstructor. It can -;;; return a constructor code generator, or return nil if this type of code -;;; is determined to not be appropriate after looking at the defconstructor -;;; arguments. -;;; -;;; When compute-constructor-code is called, it first performs basic checks -;;; to make sure that the basic assumptions common to all the code types are -;;; valid. (For details see method definition). If any of the tests fail, -;;; the fallback constructor code type is used. If none of the tests fail, -;;; the constructor code generators are called in order. They receive 5 -;;; arguments: -;;; -;;; CLASS the class the constructor is making instances of -;;; WRAPPER that class's wrapper -;;; DEFAULTS the result of calling class-default-initargs on class -;;; INITIALIZE the applicable methods on initialize-instance -;;; SHARED the applicable methosd on shared-initialize -;;; -;;; The first code generator to return code is used. The code generators are -;;; called in reverse order of definition, so define-constructor-code-type -;;; forms which define better code should appear after ones that define less -;;; good code. The fallback code type appears first. Note that redefining a -;;; code type does not change its position in the list. To do that, define -;;; a new type at the end with the behavior. +;;;; Here is the actual smarts for making the code generators and then +;;;; trying each generator to get constructor code. This extensible +;;;; mechanism allows new kinds of constructor code types to be added. +;;;; A programmer defining a specialization of the constructor class +;;;; can use this mechanism to define new code types. +;;;; +;;;; original PCL comment from before dead DEFCONSTRUCTOR was deleted: +;;;; The function defined by define-constructor-code-type will receive +;;;; the class object, and the 4 original arguments to DEFCONSTRUCTOR. +;;;; It can return a constructor code generator, or return NIL if this +;;;; type of code is determined to not be appropriate after looking at +;;;; the DEFCONSTRUCTOR arguments. +;;;; +;;;; original PCL comment from before dead COMPUTE-CONSTRUCTOR-CODE +;;;; was deleted: +;;;; When compute-constructor-code is called, it first performs +;;;; basic checks to make sure that the basic assumptions common to +;;;; all the code types are valid. (For details see method +;;;; definition). If any of the tests fail, the fallback +;;;; constructor code type is used. If none of the tests fail, the +;;;; constructor code generators are called in order. They receive +;;;; 5 arguments: +;;;; +;;;; CLASS the class the constructor is making instances of +;;;; WRAPPER that class's wrapper +;;;; DEFAULTS the result of calling class-default-initargs on class +;;;; INITIALIZE the applicable methods on initialize-instance +;;;; SHARED the applicable methosd on shared-initialize +;;;; +;;;; The first code generator to return code is used. The code +;;;; generators are called in reverse order of definition, so +;;;; DEFINE-CONSTRUCTOR-CODE-TYPE forms which define better code +;;;; should appear after ones that define less good code. The fallback +;;;; code type appears first. Note that redefining a code type does +;;;; not change its position in the list. To do that, define a new +;;;; type at the end with the behavior. (defvar *constructor-code-types* ()) @@ -370,111 +134,9 @@ (setf (cadr old-entry) generator) (push (list type generator) *constructor-code-types*)) type)) - -(defmethod make-constructor-code-generators - ((class slot-class) - name lambda-list supplied-initarg-names supplied-initargs) - (cons 'list - (let ((collect nil)) - (dolist (entry *constructor-code-types*) - (let ((generator - (funcall (cadr entry) class name lambda-list - supplied-initarg-names - supplied-initargs))) - (when generator - (push `',(car entry) collect) - (push generator collect)))) - (nreverse collect)))) - -(defmethod compute-constructor-code ((class slot-class) - (constructor constructor)) - (let* ((proto (class-prototype class)) - (wrapper (class-wrapper class)) - (defaults (class-default-initargs class)) - (make - (compute-applicable-methods (gdefinition 'make-instance) (list class))) - (supplied-initarg-names - (constructor-supplied-initarg-names constructor)) - (default - (compute-applicable-methods (gdefinition 'default-initargs) - (list class supplied-initarg-names))) ;? - (allocate - (compute-applicable-methods (gdefinition 'allocate-instance) - (list class))) - (initialize - (compute-applicable-methods (gdefinition 'initialize-instance) - (list proto))) - (shared - (compute-applicable-methods (gdefinition 'shared-initialize) - (list proto t))) - (code-generators - (constructor-code-generators constructor))) - (flet ((call-code-generator (generator) - (when (null generator) - (unless (setq generator (getf code-generators 'fallback)) - (error "No FALLBACK generator?"))) - (funcall generator class wrapper defaults initialize shared))) - (if (or (cdr make) - (cdr default) - (cdr allocate) - (not (check-initargs-1 class - supplied-initarg-names - (append initialize shared) - nil nil))) - ;; These are basic shared assumptions, if one of the - ;; has been violated, we have to resort to the fallback - ;; case. Any of these assumptions could be moved out - ;; of here and into the individual code types if there - ;; was a need to do so. - (values (call-code-generator nil) 'fallback) - ;; Otherwise try all the generators until one produces - ;; code for us. - (doplist (type generator) code-generators - (let ((code (call-code-generator generator))) - (when code (return (values code type))))))))) - -;;; The facilities are useful for debugging, and to measure the performance -;;; boost from constructors. -;;; -;;; FIXME: so they should probably be #+SB-SHOW instead of unconditional - -(defun map-constructors (fn) - (let ((nclasses 0) - (nconstructors 0)) - (labels ((recurse (class) - (incf nclasses) - (dolist (constructor (class-constructors class)) - (incf nconstructors) - (funcall fn constructor)) - (dolist (subclass (class-direct-subclasses class)) - (recurse subclass)))) - (recurse (find-class t)) - (values nclasses nconstructors)))) - -(defun reset-constructors () - (multiple-value-bind (nclass ncons) - (map-constructors #'install-lazy-constructor-installer ) - (format t "~&~W classes, ~W constructors." nclass ncons))) - -(defun disable-constructors () - (multiple-value-bind (nclass ncons) - (map-constructors - #'(lambda (c) - (let ((gen (getf (constructor-code-generators c) 'fallback))) - (if (null gen) - (error "No fallback constructor for ~S." c) - (set-constructor-code c - (funcall gen - (constructor-class c) - () () () ()) - 'fallback))))) - (format t "~&~W classes, ~W constructors." nclass ncons))) - -(defun enable-constructors () - (reset-constructors)) -;;; helper functions and utilities that are shared by all of the code types -;;; and by the main compute-constructor-code method as well +;;;; helper functions and utilities that are shared by all of the code +;;;; types (defvar *standard-initialize-instance-method* (get-method #'initialize-instance @@ -578,9 +240,9 @@ (push (cons initarg positions) collect)))) (nreverse collect)))) -;;; The FALLBACK case allows anything. This always works, and always appears -;;; as the last of the generators for a constructor. It does a full call to -;;; make-instance. +;;; The FALLBACK case allows anything. This always works, and always +;;; appears as the last of the generators for a constructor. It does a +;;; full call to make-instance. (define-constructor-code-type fallback (class name arglist supplied-initarg-names supplied-initargs) (declare (ignore name supplied-initarg-names)) diff --git a/src/pcl/fast-init.lisp b/src/pcl/fast-init.lisp index 6a173ea..2d723e1 100644 --- a/src/pcl/fast-init.lisp +++ b/src/pcl/fast-init.lisp @@ -95,12 +95,6 @@ subform)))) forms))) -(defmacro defconstructor - (name class lambda-list &rest initialization-arguments) - `(expanding-make-instance-toplevel - (defun ,name ,lambda-list - (make-instance ',class ,@initialization-arguments)))) - (defun get-make-instance-functions (key-list) (dolist (key key-list) (let* ((cell (find-class-cell (car key))) diff --git a/src/pcl/generic-functions.lisp b/src/pcl/generic-functions.lisp index 0e101bc..59330a5 100644 --- a/src/pcl/generic-functions.lisp +++ b/src/pcl/generic-functions.lisp @@ -235,8 +235,6 @@ (defgeneric accessor-method-slot-name (m)) -(defgeneric class-constructors (class)) - (defgeneric class-default-initargs (class)) (defgeneric class-direct-default-initargs (class)) diff --git a/src/pcl/iterate.lisp b/src/pcl/iterate.lisp deleted file mode 100644 index ebfbf98..0000000 --- a/src/pcl/iterate.lisp +++ /dev/null @@ -1,1210 +0,0 @@ -;;;; This software is part of the SBCL system. See the README file for -;;;; more information. - -;;;; FIXME: It'd be nice to get rid of all 750 lines of code in this -;;;; file, plus miscellaneous cruft elsewhere (e.g. the definition of -;;;; the SB-ITERATE package). There are only 20 calls to this ITERATE -;;;; macro in the PCL code. (There's another ITERATE macro used in the -;;;; classic CMU CL code, but that's different.) Most if not all of -;;;; them would be easy to replace with ANSI LOOP or simpler standard -;;;; iteration constructs. - -;;;; This software is derived from software originally released by Xerox -;;;; Corporation. Copyright and release statements follow. Later modifications -;;;; to the software are in the public domain and are provided with -;;;; absolutely no warranty. See the COPYING and CREDITS files for more -;;;; information. - -;;;; copyright information from original PCL sources: -;;;; -;;;; 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. - -(in-package "SB-ITERATE") - -;;; Are warnings to be issued for iterate/gather forms that aren't -;;; optimized? -;;; NIL => never -;;; :USER => those resulting from user code -;;; T => always, even if it's the iteration macro that's suboptimal. -(defvar *iterate-warnings* :any) - -;;; ITERATE macro -(defmacro iterate (clauses &body body &environment env) - (optimize-iterate-form clauses body env)) - -;;; temporary variable names used by ITERATE expansions -(defparameter *iterate-temp-vars-list* - '(iterate-temp-1 iterate-temp-2 iterate-temp-3 iterate-temp-4 - iterate-temp-5 iterate-temp-6 iterate-temp-7 iterate-temp-8)) - -(defun - optimize-iterate-form - (clauses body iterate-env) - (let* - ((temp-vars *iterate-temp-vars-list*) - (block-name (gensym)) - (finish-form `(return-from ,block-name)) - (bound-vars (mapcan #'(lambda (clause) - (let ((names (first clause))) - (if (listp names) - (copy-list names) - (list names)))) - clauses)) - iterate-decls generator-decls update-forms bindings leftover-body) - (do ((tail bound-vars (cdr tail))) - ((null tail)) - ;; Check for duplicates - (when (member (car tail) - (cdr tail)) - (warn "Variable appears more than once in ITERATE: ~S" (car tail)))) - (flet - ((get-iterate-temp nil - - ;; Make temporary var. Note that it is ok to re-use these symbols - ;; in each iterate, because they are not used within BODY. - (or (pop temp-vars) - (gensym)))) - (dolist (clause clauses) - (cond - ((or (not (consp clause)) - (not (consp (cdr clause)))) - (warn "bad syntax in ITERATE: clause not of form (var iterator): ~S" - clause)) - (t - (unless (null (cddr clause)) - (warn - "probable parenthesis error in ITERATE clause--more than 2 elements: ~S" - clause)) - (multiple-value-bind - (let-body binding-type let-bindings localdecls otherdecls extra-body) - (expand-into-let (second clause) - 'iterate iterate-env) - - ;; We have expanded the generator clause and parsed it into - ;; its LET pieces. - (prog* - ((vars (first clause)) - gen-args renamed-vars) - (setq vars (if (listp vars) - (copy-list vars) - (list vars))) - ; VARS is now a (fresh) list of - ; all iteration vars bound in - ; this clause - (cond - ((eq let-body :abort) - ; Already issued a warning - ; about malformedness - ) - ((null (setq let-body (function-lambda-p let-body 1))) - ; Not of the expected form - (let ((generator (second clause))) - (cond ((and (consp generator) - (fboundp (car generator))) - ; It looks ok--a macro or - ; function here--so the guy who - ; wrote it just didn't do it in - ; an optimizable way - (maybe-warn :definition "could not optimize iterate clause ~S because generator not of form (LET[*] ... (FUNCTION (LAMBDA (finish) ...)))" - generator)) - (t ; Perhaps it's just a - ; misspelling? Probably user - ; error - (maybe-warn :user - "Iterate operator in clause ~S is not fboundp." - generator))) - (setq let-body :abort))) - (t - - ;; We have something of the form #'(LAMBDA (finisharg) ...), - ;; possibly with some LET bindings around it. LET-BODY = - ;; ((finisharg) ...). - (setq let-body (cdr let-body)) - (setq gen-args (pop let-body)) - (when let-bindings - - ;; The first transformation we want to perform is - ;; "LET-eversion": turn (let* ((generator (let (..bindings..) - ;; #'(lambda ...)))) ..body..) into (let* (..bindings.. - ;; (generator #'(lambda ...))) ..body..). This - ;; transformation is valid if nothing in body refers to any - ;; of the bindings, something we can ensure by - ;; alpha-converting the inner let (substituting new names for - ;; each var). Of course, none of those vars can be special, - ;; but we already checked for that above. - (multiple-value-setq (let-bindings renamed-vars) - (rename-let-bindings let-bindings binding-type - iterate-env leftover-body #'get-iterate-temp)) - (setq leftover-body nil) - ; If there was any leftover - ; from previous, it is now - ; consumed. - ) - - ;; The second transformation is substituting the body of the - ;; generator (LAMBDA (finish-arg) . gen-body) for its appearance - ;; in the update form (funcall generator #'(lambda () - ;; finish-form)), then simplifying that form. The requirement - ;; for this part is that the generator body not refer to any - ;; variables that are bound between the generator binding and the - ;; appearance in the loop body. The only variables bound in that - ;; interval are generator temporaries, which have unique names so - ;; are no problem, and the iteration variables remaining for - ;; subsequent clauses. We'll discover the story as we walk the - ;; body. - (multiple-value-bind (finishdecl other rest) - (parse-declarations let-body gen-args) - (declare (ignore finishdecl)) - ; Pull out declares, if any, - ; separating out the one(s) - ; referring to the finish arg, - ; which we will throw away. - (when other - ; Combine remaining decls with - ; decls extracted from the LET, - ; if any. - (setq otherdecls (nconc otherdecls other))) - (setq let-body (cond - (otherdecls - ; There are interesting - ; declarations, so have to keep - ; it wrapped. - `(let nil (declare ,@otherdecls) - ,@rest)) - ((null (cdr rest)) - ; Only one form left - (first rest)) - (t `(progn ,@rest))))) - (unless (eq (setq let-body (iterate-transform-body let-body - iterate-env renamed-vars - (first gen-args) - finish-form bound-vars clause)) - :abort) - - ;; Skip the rest if transformation failed. Warning has - ;; already been issued. - - ;; Note possible further optimization: if LET-BODY expanded - ;; into (prog1 oldvalue prepare-for-next-iteration), as so - ;; many do, then we could in most cases split the PROG1 into - ;; two pieces: do the (setq var oldvalue) here, and do the - ;; prepare-for-next-iteration at the bottom of the loop. - ;; This does a slight optimization of the PROG1 and also - ;; rearranges the code in a way that a reasonably clever - ;; compiler might detect how to get rid of redundant - ;; variables altogether (such as happens with INTERVAL and - ;; LIST-TAILS); that would make the whole thing closer to - ;; what you might have coded by hand. However, to do this - ;; optimization, we need to ensure that (a) the - ;; prepare-for-next-iteration refers freely to no vars other - ;; than the internal vars we have extracted from the LET, and - ;; (b) that the code has no side effects. These are both - ;; true for all the iterators defined by this module, but how - ;; shall we represent side-effect info and/or tap into the - ;; compiler's knowledge of same? - (when localdecls - ; There were declarations for - ; the generator locals--have to - ; keep them for later, and - ; rename the vars mentioned - (setq - generator-decls - (nconc - generator-decls - (mapcar - #'(lambda - (decl) - (let ((head (car decl))) - (cons head (if (eq head 'type) - (cons (second decl) - (sublis renamed-vars - (cddr decl))) - (sublis renamed-vars - (cdr decl)))))) - localdecls))))))) - - ;; Finished analyzing clause now. LET-BODY is the form which, when - ;; evaluated, returns updated values for the iteration variable(s) - ;; VARS. - (when (eq let-body :abort) - - ;; Some punt case: go with the formal semantics: bind a var to - ;; the generator, then call it in the update section - (let - ((gvar (get-iterate-temp)) - (generator (second clause))) - (setq - let-bindings - (list (list gvar - (cond - ;; FIXME: This conditional was here with this - ;; comment in old CMU CL PCL. Does Python really - ;; think it's unreachable? - ;;#-cmu ; Python thinks this is unreachable. - (leftover-body - ; Have to use this up - `(progn ,@(prog1 leftover-body (setq - leftover-body - nil)) - generator)) - (t generator))))) - (setq let-body `(funcall ,gvar #'(lambda nil ,finish-form))))) - (push (mv-setq (copy-list vars) - let-body) - update-forms) - (dolist (v vars) - (declare (ignore v)) - ;; Pop off the vars we have now bound from the list of vars to - ;; watch out for -- we'll bind them right now. - (pop bound-vars)) - (setq bindings - (nconc bindings let-bindings - (cond (extra-body - ;; There was some computation to do after the - ;; bindings--here's our chance. - (cons (list (first vars) - `(progn ,@extra-body nil)) - (rest vars))) - (t vars)))))))))) - (do ((tail body (cdr tail))) - ((not (and (consp tail) - (consp (car tail)) - (eq (caar tail) - 'declare))) - - ;; TAIL now points at first non-declaration. If there were - ;; declarations, pop them off so they appear in the right place - (unless (eq tail body) - (setq iterate-decls (ldiff body tail)) - (setq body tail)))) - `(block ,block-name - (let* ,bindings ,@(and generator-decls - `((declare ,@generator-decls))) - ,@iterate-decls - ,@leftover-body - (loop ,@(nreverse update-forms) - ,@body))))) - -(defun expand-into-let (clause parent-name env) - - ;; Return values: Body, LET[*], bindings, localdecls, otherdecls, extra - ;; body, where BODY is a single form. If multiple forms in a LET, the - ;; preceding forms are returned as extra body. Returns :ABORT if it - ;; issued a punt warning. - (prog ((expansion clause) - expandedp binding-type let-bindings let-body) - expand - (multiple-value-setq (expansion expandedp) - (macroexpand-1 expansion env)) - (cond ((not (consp expansion)) - ; Shouldn't happen - ) - ((symbolp (setq binding-type (first expansion))) - (case binding-type - ((let let*) - (setq let-bindings (second expansion)) - ; List of variable bindings - (setq let-body (cddr expansion)) - (go handle-let)))) - ((and (consp binding-type) - (eq (car binding-type) - 'lambda) - (not (find-if #'(lambda (x) - (member x lambda-list-keywords) - ) - (setq let-bindings (second binding-type))) - ) - (eql (length (second expansion)) - (length let-bindings)) - (null (cddr expansion))) - ; A simple LAMBDA form can be - ; treated as LET - (setq let-body (cddr binding-type)) - (setq let-bindings (mapcar #'list let-bindings (second - expansion)) - ) - (setq binding-type 'let) - (go handle-let))) - - ;; Fall thru if not a LET - (cond (expandedp ; try expanding again - (go expand)) - (t ; Boring--return form as the - ; body - (return expansion))) - handle-let - (return (let ((locals (variables-from-let let-bindings)) - extra-body specials) - (multiple-value-bind (localdecls otherdecls let-body) - (parse-declarations let-body locals) - (cond ((setq specials (extract-special-bindings - locals localdecls)) - (maybe-warn (cond ((find-if - #'var-globally-special-p - specials) - ;; This could be the - ;; fault of a user - ;; proclamation. - :user) - (t :definition)) - - "Couldn't optimize ~S because expansion of ~S binds specials ~(~S ~)" - parent-name clause specials) - :abort) - (t (values (cond ((not (consp let-body)) - - ; Null body of LET? unlikely, - ; but someone else will likely - ; complain - nil) - ((null (cdr let-body)) - - ; A single expression, which we - ; hope is (function - ; (lambda...)) - (first let-body)) - (t - - ;; More than one expression. These are forms to - ;; evaluate after the bindings but before the - ;; generator form is returned. Save them to - ;; evaluate in the next convenient place. Note that - ;; this is ok, as there is no construct that can - ;; cause a LET to return prematurely (without - ;; returning also from some surrounding construct). - (setq extra-body - (butlast let-body)) - (car (last let-body)))) - binding-type let-bindings localdecls - otherdecls extra-body)))))))) - -(defun variables-from-let (bindings) - - ;; Return a list of the variables bound in the first argument to LET[*]. - (mapcar #'(lambda (binding) - (if (consp binding) - (first binding) - binding)) - bindings)) - -(defun iterate-transform-body (let-body iterate-env renamed-vars finish-arg - finish-form bound-vars clause) - -;;; This is the second major transformation for a single iterate clause. -;;; LET-BODY is the body of the iterator after we have extracted its local -;;; variables and declarations. We have two main tasks: (1) Substitute -;;; internal temporaries for occurrences of the LET variables; the alist -;;; RENAMED-VARS specifies this transformation. (2) Substitute evaluation of -;;; FINISH-FORM for any occurrence of (funcall FINISH-ARG). Along the way, we -;;; check for forms that would invalidate these transformations: occurrence of -;;; FINISH-ARG outside of a funcall, and free reference to any element of -;;; BOUND-VARS. CLAUSE & TYPE are the original ITERATE clause and its type -;;; (ITERATE or ITERATE*), for purpose of error messages. On success, we -;;; return the transformed body; on failure, :ABORT. - - (walk-form - let-body - iterate-env - (lambda (form context env) - (declare (ignore context)) - - ;; We need to substitute RENAMED-VARS, as well as turn - ;; (FUNCALL finish-arg) into the finish form. - (cond ((symbolp form) - (let (renaming) - (cond ((and (eq form finish-arg) - (var-same-p form env iterate-env)) - ;; an occurrence of the finish arg outside - ;; of FUNCALL context: I can't handle this! - (maybe-warn :definition "Couldn't optimize iterate form because generator ~S does something with its FINISH arg besides FUNCALL it." - (second clause)) - (return-from iterate-transform-body - :abort)) - ((and (setq renaming (assoc form renamed-vars)) - (var-same-p form env iterate-env)) - ;; Reference to one of the vars - ;; we're renaming - (cdr renaming)) - ((and (member form bound-vars) - (var-same-p form env iterate-env)) - ;; FORM is a var that is bound in this same - ;; ITERATE, or bound later in this ITERATE*. - ;; This is a conflict. - (maybe-warn :user "Couldn't optimize iterate form because generator ~S is closed over ~S, in conflict with a subsequent iteration variable." - (second clause) - form) - (return-from iterate-transform-body - :abort)) - (t form)))) - ((and (consp form) - (eq (first form) - 'funcall) - (eq (second form) - finish-arg) - (var-same-p (second form) env - iterate-env)) - ;; (FUNCALL finish-arg) => finish-form - (unless (null (cddr form)) - (maybe-warn :definition - "Generator for ~S applied its finish arg to > 0 arguments ~S--ignored." - (second clause) - (cddr form))) - finish-form) - (t form))))) - -(defun - parse-declarations - (tail locals) - - ;; Extract the declarations from the head of TAIL and divide them into 2 - ;; classes: declares about variables in the list LOCALS, and all other - ;; declarations. Returns 3 values: those 2 lists plus the remainder of TAIL. - (let - (localdecls otherdecls form) - (loop - (unless (and tail (consp (setq form (car tail))) - (eq (car form) - 'declare)) - (return (values localdecls otherdecls tail))) - (mapc - #'(lambda - (decl) - (case (first decl) - ((inline notinline optimize) - ; These don't talk about vars - (push decl otherdecls)) - (t ; Assume all other kinds are - ; for vars - (let* ((vars (if (eq (first decl) - 'type) - (cddr decl) - (cdr decl))) - (l (intersection locals vars)) - other) - (cond - ((null l) - ; None talk about LOCALS - (push decl otherdecls)) - ((null (setq other (set-difference vars l))) - ; All talk about LOCALS - (push decl localdecls)) - (t ; Some of each - (let ((head (cons 'type (and (eq (first decl) - 'type) - (list (second decl)))))) - (push (append head other) - otherdecls) - (push (append head l) - localdecls)))))))) - (cdr form)) - (pop tail)))) - -(defun extract-special-bindings (vars decls) - - ;; Return the subset of VARS that are special, either globally or - ;; because of a declaration in DECLS - (let ((specials (remove-if-not #'var-globally-special-p vars))) - (dolist (d decls) - (when (eq (car d) - 'special) - (setq specials (union specials (intersection vars - (cdr d)))))) - specials)) - -(defun function-lambda-p (form &optional nargs) - - ;; If FORM is #'(LAMBDA bindings . body) and bindings is of length - ;; NARGS, return the lambda expression - (let (args body) - (and (consp form) - (eq (car form) - 'function) - (consp (setq form (cdr form))) - (null (cdr form)) - (consp (setq form (car form))) - (eq (car form) - 'lambda) - (consp (setq body (cdr form))) - (listp (setq args (car body))) - (or (null nargs) - (eql (length args) - nargs)) - form))) - -(defun - rename-let-bindings - (let-bindings binding-type env leftover-body &optional tempvarfn) - - ;; Perform the alpha conversion required for "LET eversion" of - ;; (LET[*] LET-BINDINGS . body)--rename each of the variables to an - ;; internal name. Returns 2 values: a new set of LET bindings and the - ;; alist of old var names to new (so caller can walk the body doing - ;; the rest of the renaming). BINDING-TYPE is one of LET or LET*. - ;; LEFTOVER-BODY is optional list of forms that must be eval'ed - ;; before the first binding happens. ENV is the macro expansion - ;; environment, in case we have to walk a LET*. TEMPVARFN is a - ;; function of no args to return a temporary var; if omitted, we use - ;; GENSYM. - (let - (renamed-vars) - (values (mapcar #'(lambda (binding) - (let ((valueform (cond ((not (consp binding)) - - ; No initial value - nil) - ((or (eq binding-type - 'let) - (null renamed-vars)) - - ; All bindings are in parallel, - ; so none can refer to others - (second binding)) - (t - ; In a LET*, have to substitute - ; vars in the 2nd and - ; subsequent initialization - ; forms - (rename-variables - (second binding) - renamed-vars env)))) - (newvar (if tempvarfn - (funcall tempvarfn) - (gensym)))) - (push (cons (if (consp binding) - (first binding) - binding) - newvar) - renamed-vars) - ; Add new variable to the list - ; AFTER we have walked the - ; initial value form - (when leftover-body - ;; Previous clause had some computation to do - ;; after its bindings. Here is the first - ;; opportunity to do it - (setq valueform `(progn ,@leftover-body - ,valueform)) - (setq leftover-body nil)) - (list newvar valueform))) - let-bindings) - renamed-vars))) - -(defun rename-variables (form alist env) - - ;; Walks FORM, renaming occurrences of the key variables in ALIST with - ;; their corresponding values. ENV is FORM's environment, so we can - ;; make sure we are talking about the same variables. - (walk-form form env - #'(lambda (form context subenv) - (declare (ignore context)) - (let (pair) - (cond ((and (symbolp form) - (setq pair (assoc form alist)) - (var-same-p form subenv env)) - (cdr pair)) - (t form)))))) - -(defun - mv-setq - (vars expr) - - ;; Produces (MULTIPLE-VALUE-SETQ vars expr), except that I'll optimize some - ;; of the simple cases for benefit of compilers that don't, and I don't care - ;; what the value is, and I know that the variables need not be set in - ;; parallel, since they can't be used free in EXPR - (cond - ((null vars) - ; EXPR is a side-effect - expr) - ((not (consp vars)) - ; This is an error, but I'll - ; let MULTIPLE-VALUE-SETQ - ; report it - `(multiple-value-setq ,vars ,expr)) - ((and (listp expr) - (eq (car expr) - 'values)) - - ;; (mv-setq (a b c) (values x y z)) can be reduced to a parallel setq - ;; (psetq returns nil, but I don't care about returned value). Do this - ;; even for the single variable case so that we catch (mv-setq (a) (values - ;; x y)) - (pop expr) - ; VALUES - `(setq ,@(mapcon #'(lambda (tail) - (list (car tail) - (cond ((or (cdr tail) - (null (cdr expr))) - ; One result expression for - ; this var - (pop expr)) - (t ; More expressions than vars, - ; so arrange to evaluate all - ; the rest now. - (cons 'prog1 expr))))) - vars))) - ((null (cdr vars)) - ; Simple one variable case - `(setq ,(car vars) - ,expr)) - (t ; General case--I know nothing - `(multiple-value-setq ,vars ,expr)))) - -(defun var-same-p (var env1 env2) - (eq (var-lexical-p var env1) - (var-lexical-p var env2))) - -(defun maybe-warn (type &rest warn-args) - - ;; Issue a warning about not being able to optimize this thing. TYPE - ;; is one of :DEFINITION, meaning the definition is at fault, and - ;; :USER, meaning the user's code is at fault. - (when (case *iterate-warnings* - ((nil) nil) - ((:user) (eq type :user)) - (t t)) - (apply #'warn warn-args))) - -;;; sample iterators -;;; -;;; FIXME: If they're only samples, can they be commented out? - -(defmacro - interval - (&whole whole &key from downfrom to downto above below by type) - (cond - ((and from downfrom) - (error "Can't use both FROM and DOWNFROM in ~S" whole)) - ((cdr (remove nil (list to downto above below))) - (error "Can't use more than one limit keyword in ~S" whole)) - (t - (let* - ((down (or downfrom downto above)) - (limit (or to downto above below)) - (inc (cond ((null by) - 1) - ((constantp by) - ; Can inline this increment - by)))) - `(let - ((from ,(or from downfrom 0)) - ,@(and limit `((to ,limit))) - ,@(and (null inc) - `((by ,by)))) - ,@(and type `((declare (type ,type from ,@(and limit '(to)) - ,@(and (null inc) - `(by)))))) - #'(lambda - (finish) - ,@(cond ((null limit) - ; We won't use the FINISH arg. - '((declare (ignore finish))))) - (prog1 ,(cond (limit ; Test the limit. If ok, - ; return current value and - ; increment, else quit - `(if (,(cond (above '>) - (below '<) - (down '>=) - (t '<=)) - from to) - from - (funcall finish))) - (t ; No test - 'from)) - (setq from (,(if down - '- - '+) - from - ,(or inc 'by)))))))))) - -(defmacro list-elements (list &key (by '#'cdr)) - `(let ((tail ,list)) - #'(lambda (finish) - (prog1 (if (endp tail) - (funcall finish) - (first tail)) - (setq tail (funcall ,by tail)))))) - -(defmacro list-tails (list &key (by '#'cdr)) - `(let ((tail ,list)) - #'(lambda (finish) - (prog1 (if (endp tail) - (funcall finish) - tail) - (setq tail (funcall ,by tail)))))) - -(defmacro - elements - (sequence) - "Generates successive elements of SEQUENCE, with second value being the index. Use (ELEMENTS (THE type arg)) if you care about the type." - (let* - ((type (and (consp sequence) - (eq (first sequence) - 'the) - (second sequence))) - (accessor (if type - (sequence-accessor type) - 'elt)) - (listp (eq type 'list))) - - ;; If type is given via THE, we may be able to generate a good accessor here - ;; for the benefit of implementations that aren't smart about (ELT (THE - ;; STRING FOO)). I'm not bothering to keep the THE inside the body, - ;; however, since I assume any compiler that would understand (AREF (THE - ;; SIMPLE-ARRAY S)) would also understand that (AREF S) is the same when I - ;; bound S to (THE SIMPLE-ARRAY foo) and never modified it. - - ;; If sequence is declared to be a list, it's better to cdr down it, so we - ;; have some extra cases here. Normally folks would write LIST-ELEMENTS, - ;; but maybe they wanted to get the index for free... - `(let* ((index 0) - (s ,sequence) - ,@(and (not listp) - '((size (length s))))) - #'(lambda (finish) - (values (cond ,(if listp - '((not (endp s)) - (pop s)) - `((< index size) - (,accessor s index))) - (t (funcall finish))) - (prog1 index - (setq index (1+ index)))))))) - -(defmacro - plist-elements - (plist) - "Generates each time 2 items, the indicator and the value." - `(let ((tail ,plist)) - #'(lambda (finish) - (values (if (endp tail) - (funcall finish) - (first tail)) - (prog1 (if (endp (setq tail (cdr tail))) - (funcall finish) - (first tail)) - (setq tail (cdr tail))))))) - -(defun sequence-accessor (type) - - ;; returns the function with which most efficiently to make accesses to - ;; a sequence of type TYPE. - (case (if (consp type) - ; e.g., (VECTOR FLOAT *) - (car type) - type) - ((array simple-array vector) 'aref) - (simple-vector 'svref) - (string 'char) - (simple-string 'schar) - (bit-vector 'bit) - (simple-bit-vector 'sbit) - (t 'elt))) - -;; These "iterators" may be withdrawn - -(defmacro eachtime (expr) - `#'(lambda (finish) - (declare (ignore finish)) - ,expr)) - -(defmacro while (expr) - `#'(lambda (finish) - (unless ,expr (funcall finish)))) - -(defmacro until (expr) - `#'(lambda (finish) - (when ,expr (funcall finish)))) - - ; GATHERING macro - -(defmacro gathering (clauses &body body &environment env) - (or (optimize-gathering-form clauses body env) - (simple-expand-gathering-form clauses body env))) - -(defmacro with-gathering (clauses gather-body &body use-body) - "Binds the variables specified in CLAUSES to the result of (GATHERING clauses gather-body) and evaluates the forms in USE-BODY inside that contour." - - ;; We may optimize this a little better later for those compilers that - ;; don't do a good job on (m-v-bind vars (... (values ...)) ...). - `(multiple-value-bind ,(mapcar #'car clauses) - (gathering ,clauses ,gather-body) - ,@use-body)) - -(defun - simple-expand-gathering-form - (clauses body env) - (declare (ignore env)) - - ;; The "formal semantics" of GATHERING. We use this only in cases that can't - ;; be optimized. - (let - ((acc-names (mapcar #'first (if (symbolp clauses) - ; Shorthand using anonymous - ; gathering site - (setq clauses `((*anonymous-gathering-site* - (,clauses)))) - clauses))) - (realizer-names (mapcar #'(lambda (binding) - (declare (ignore binding)) - (gensym)) - clauses))) - `(multiple-value-call - #'(lambda - ,(mapcan #'list acc-names realizer-names) - (flet ((gather (value &optional (accumulator *anonymous-gathering-site*) - ) - (funcall accumulator value))) - ,@body - (values ,@(mapcar #'(lambda (rname) - `(funcall ,rname)) - realizer-names)))) - ,@(mapcar #'second clauses)))) - -(defvar *active-gatherers* nil - "List of GATHERING bindings currently active during macro expansion)") - -(defvar *anonymous-gathering-site* nil "Variable used in formal expansion of an abbreviated GATHERING form (one with anonymous gathering site).") - -(defun optimize-gathering-form (clauses body gathering-env) - (let* - (acc-info leftover-body top-bindings finish-forms top-decls) - (dolist (clause (if (symbolp clauses) - ; a shorthand - `((*anonymous-gathering-site* (,clauses))) - clauses)) - (multiple-value-bind - (let-body binding-type let-bindings localdecls otherdecls extra-body) - (expand-into-let (second clause) - 'gathering gathering-env) - (prog* - ((acc-var (first clause)) - renamed-vars accumulator realizer) - (when (and (consp let-body) - (eq (car let-body) - 'values) - (consp (setq let-body (cdr let-body))) - (setq accumulator (function-lambda-p (car let-body))) - (consp (setq let-body (cdr let-body))) - (setq realizer (function-lambda-p (car let-body) - 0)) - (null (cdr let-body))) - - ;; Macro returned something of the form - ;; (VALUES #'(lambda (value) ...) - ;; #'(lambda () ...)), - ;; a function to accumulate values and a function to realize the - ;; result. - (when binding-type - - ;; Gatherer expanded into a LET - (cond (otherdecls (maybe-warn :definition "Couldn't optimize GATHERING clause ~S because its expansion carries declarations about more than the bound variables: ~S" - (second clause) - `(declare ,@otherdecls)) - (go punt))) - (when let-bindings - - ;; The first transformation we want to perform is a - ;; variant of "LET-eversion": turn - ;; (mv-bind - ;; (acc real) - ;; (let (..bindings..) - ;; (values #'(lambda ...) - ;; #'(lambda ...))) - ;; ..body..) - ;; into - ;; (let* (..bindings.. - ;; (acc #'(lambda ...)) - ;; (real #'(lambda ...))) - ;; ..body..). - ;; This transformation is valid if nothing in body refers - ;; to any of the bindings, something we can ensure by - ;; alpha-converting the inner let (substituting new names - ;; for each var). Of course, none of those vars can be - ;; special, but we already checked for that above. - (multiple-value-setq (let-bindings renamed-vars) - (rename-let-bindings let-bindings binding-type - gathering-env leftover-body)) - (setq top-bindings (nconc top-bindings let-bindings)) - (setq leftover-body nil) - ; If there was any leftover - ; from previous, it is now - ; consumed - )) - (setq leftover-body (nconc leftover-body extra-body)) - ; Computation to do after these - ; bindings - (push (cons acc-var (rename-and-capture-variables accumulator - renamed-vars gathering-env)) - acc-info) - (setq realizer (rename-variables realizer renamed-vars - gathering-env)) - (push (cond ((null (cdddr realizer)) - ; Simple (LAMBDA () expr) => - ; expr - (third realizer)) - (t ; There could be declarations - ; or something, so leave as a - ; LET - (cons 'let (cdr realizer)))) - finish-forms) - (unless (null localdecls) - ; Declarations about the LET - ; variables also has to - ; percolate up - (setq top-decls (nconc top-decls (sublis renamed-vars - localdecls)))) - (return)) - (maybe-warn :definition "Couldn't optimize GATHERING clause ~S because its expansion is not of the form (VALUES #'(LAMBDA ...) #'(LAMBDA () ...))" - (second clause)) - punt - (let - ((gs (gensym)) - (expansion `(multiple-value-list ,(second clause)))) - ; Slow way--bind gensym to the - ; macro expansion, and we will - ; funcall it in the body - (push (list acc-var gs) - acc-info) - (push `(funcall (cadr ,gs)) - finish-forms) - (setq - top-bindings - (nconc - top-bindings - (list (list gs (cond (leftover-body - `(progn ,@(prog1 leftover-body - (setq leftover-body nil)) - ,expansion)) - (t expansion)))))))))) - (setq body (walk-gathering-body body gathering-env acc-info)) - (cond ((eq body :abort) - ; Couldn't finish expansion - nil) - (t `(let* ,top-bindings - ,@(and top-decls `((declare ,@top-decls))) - ,body - ,(cond ((null (cdr finish-forms)) - ; just a single value - (car finish-forms)) - (t `(values ,@(reverse finish-forms))))))))) - -(defun rename-and-capture-variables (form alist env) - - ;; Walks FORM, renaming occurrences of the key variables in ALIST with - ;; their corresponding values, and capturing any other free variables. - ;; Returns a list of the new form and the list of other closed-over - ;; vars. ENV is FORM's environment, so we can make sure we are talking - ;; about the same variables. - (let (closed) - (list (walk-form - form env - #'(lambda (form context subenv) - (declare (ignore context)) - (let (pair) - (cond ((or (not (symbolp form)) - (not (var-same-p form subenv env))) - ; non-variable or one that has - ; been rebound - form) - ((setq pair (assoc form alist)) - ; One to rename - (cdr pair)) - (t ; var is free - (pushnew form closed) - form))))) - closed))) - -(defun - walk-gathering-body - (body gathering-env acc-info) - - ;; Walk the body of (GATHERING (...) . BODY) in environment GATHERING-ENV. - ;; ACC-INFO is a list of information about each of the gathering "bindings" - ;; in the form, in the form (var gatheringfn freevars env) - (let - ((*active-gatherers* (nconc (mapcar #'car acc-info) - *active-gatherers*))) - - ;; *ACTIVE-GATHERERS* tells us what vars are currently legal as GATHER - ;; targets. This is so that when we encounter a GATHER not belonging to us - ;; we can know whether to warn about it. - (walk-form - (cons 'progn body) - gathering-env - #'(lambda - (form context env) - (declare (ignore context)) - (let (info site) - (cond ((consp form) - (cond - ((not (eq (car form) - 'gather)) - ; We only care about GATHER - (when (and (eq (car form) - 'function) - (eq (cadr form) - 'gather)) - ; Passed as functional--can't - ; macroexpand - (maybe-warn :user - "Can't optimize GATHERING because of reference to #'GATHER." - ) - (return-from walk-gathering-body :abort)) - form) - ((setq info (assoc (setq site (if (null (cddr form)) - - ' - *anonymous-gathering-site* - (third form))) - acc-info)) - ; One of ours--expand (GATHER - ; value var). INFO = (var - ; gatheringfn freevars env) - (unless (null (cdddr form)) - (warn "Extra arguments (> 2) in ~S discarded." form) - ) - (let ((fn (second info))) - (cond ((symbolp fn) - ; Unoptimized case--just call - ; the gatherer. FN is the - ; gensym that we bound to the - ; list of two values returned - ; from the gatherer. - `(funcall (car ,fn) - ,(second form))) - (t ; FN = (lambda (value) ...) - (dolist (s (third info)) - (unless (or (var-same-p s env - gathering-env) - (and (var-special-p - s env) - (var-special-p - s gathering-env))) - - ;; Some var used free in the LAMBDA form has been - ;; rebound between here and the parent GATHERING - ;; form, so can't substitute the lambda. Ok if it's - ;; a special reference both here and in the LAMBDA, - ;; because then it's not closed over. - (maybe-warn :user "Can't optimize GATHERING because the expansion closes over the variable ~S, which is rebound around a GATHER for it." - s) - (return-from walk-gathering-body - :abort))) - - ;; Return ((lambda (value) ...) actual-value). In - ;; many cases we could simplify this further by - ;; substitution, but we'd have to be careful (for - ;; example, we would need to alpha-convert any LET - ;; we found inside). Any decent compiler will do it - ;; for us. - (list fn (second form)))))) - ((and (setq info (member site *active-gatherers*)) - (or (eq site '*anonymous-gathering-site*) - (var-same-p site env (fourth info)))) - ; Some other GATHERING will - ; take care of this form, so - ; pass it up for now. - ; Environment check is to make - ; sure nobody shadowed it - ; between here and there - form) - (t ; Nobody's going to handle it - (if (eq site '*anonymous-gathering-site*) - ; More likely that she forgot - ; to mention the site than - ; forget to write an anonymous - ; gathering. - (warn "There is no gathering site specified in ~S." - form) - (warn - "The site ~S in ~S is not defined in an enclosing GATHERING form." - site form)) - ; Turn it into something else - ; so we don't warn twice in the - ; nested case - `(%orphaned-gather ,@(cdr form))))) - ((and (symbolp form) - (setq info (assoc form acc-info)) - (var-same-p form env gathering-env)) - ; A variable reference to a - ; gather binding from - ; environment TEM - (maybe-warn :user "Can't optimize GATHERING because site variable ~S is used outside of a GATHER form." - form) - (return-from walk-gathering-body :abort)) - (t form))))))) - -;; sample gatherers -;; -;; FIXME: If these are only samples, can we delete them? - -(defmacro - collecting - (&key initial-value) - `(let* ((head ,initial-value) - (tail ,(and initial-value `(last head)))) - (values #'(lambda (value) - (if (null head) - (setq head (setq tail (list value))) - (setq tail (cdr (rplacd tail (list value)))))) - #'(lambda nil head)))) - -(defmacro joining (&key initial-value) - `(let ((result ,initial-value)) - (values #'(lambda (value) - (setq result (nconc result value))) - #'(lambda nil result)))) - -(defmacro - maximizing - (&key initial-value) - `(let ((result ,initial-value)) - (values - #'(lambda (value) - (when ,(cond ((and (constantp initial-value) - (not (null (eval initial-value)))) - ; Initial value is given and we - ; know it's not NIL, so leave - ; out the null check - '(> value result)) - (t '(or (null result) - (> value result)))) - (setq result value))) - #'(lambda nil result)))) - -(defmacro - minimizing - (&key initial-value) - `(let ((result ,initial-value)) - (values - #'(lambda (value) - (when ,(cond ((and (constantp initial-value) - (not (null (eval initial-value)))) - ; Initial value is given and we - ; know it's not NIL, so leave - ; out the null check - '(< value result)) - (t '(or (null result) - (< value result)))) - (setq result value))) - #'(lambda nil result)))) - -(defmacro summing (&key (initial-value 0)) - `(let ((sum ,initial-value)) - (values #'(lambda (value) - (setq sum (+ sum value))) - #'(lambda nil sum)))) - -;;; It's easier to read expanded code if PROG1 gets left alone. -(define-walker-template prog1 (nil return sb-walker::repeat (eval))) diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index fc0e2d9..9697915 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -173,9 +173,6 @@ (defmethod class-default-initargs ((class slot-class)) (plist-value class 'default-initargs)) -(defmethod class-constructors ((class slot-class)) - (plist-value class 'constructors)) - (defmethod class-slot-cells ((class std-class)) (plist-value class 'class-slot-cells)) diff --git a/version.lisp-expr b/version.lisp-expr index a73127f..9844f20 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; for internal versions, especially for internal versions off the ;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.pre7.97" +"0.pre7.98" -- 1.7.10.4