(call-next-method)))
Now (FOO 3) should return 3, but instead it returns 4.
+137:
+ (SB-DEBUG:BACKTRACE) output should start with something
+ including the name BACKTRACE, not (as in 0.pre7.88)
+ just "0: (\"hairy arg processor\" ...)". In general
+ the names in BACKTRACE are all screwed up compared to
+ the nice useful names in 0.6.13.
+
+ Note for those who observe that this is an annoying
+ bug and doesn't belong in a release: See the "note for the
+ ambitious", below.
+
+ Note for the ambitious: This is an important bug and I'd
+ really like to fix it and spent many hours on it. The
+ obvious ways to fix it are hard, because the underlying
+ infrastructure seems to be rather broken.
+ * There are two mostly-separate systems for storing names,
+ the in-the-function-object system used by e.g.
+ CL:FUNCTION-LAMBDA-EXPRESSION and the
+ in-the-DEBUG-FUN-object system used by e.g. BACKTRACE.
+ The code as of sbcl-0.pre7.94 is smart enough to set
+ up the first value, but not the second (because I naively
+ assumed that one mechanism is enough, and didn't proof
+ read the entire system to see whether there might be
+ another mechanism?! argh...)
+ * The systems are not quite separate, but instead weirdly and
+ fragilely coupled by the FUN-DEBUG-FUN algorithm.
+ * If you try to refactor this dain bramage away, reducing
+ things to a single system -- I tried to add a
+ %SIMPLE-FUN-DEBUG-FUN slot, planning eventually to get
+ rid of the old %SIMPLE-FUN-NAME slot in favor of indirection
+ through the new slot -- you get torpedoed by the fragility
+ of the SIMPLE-FUN primitive object. Just adding the
+ new slot, without making any other changes in the system,
+ is enough to make the system fail with what look like
+ memory corruption problems in warm init.
+ But please do fix some or all of the problem, I'm tired
+ of messing with it. -- WHN 2001-12-22
+
+
KNOWN BUGS RELATED TO THE IR1 INTERPRETER
(Now that the IR1 interpreter has gone away, these should be
leaving some filing for later:-) from the monster
EVAL/EVAL-WHEN/%COMPILE/DEFUN/DEFSTRUCT cleanup:
** made inlining DEFUN inside MACROLET work again
- ** (SB-DEBUG:BACKTRACE) output should start with something
- including the name BACKTRACE, not (as in 0.pre7.88)
- just "0: (\"hairy arg processor\" ...)"
* more renaming in global external names:
** reserved DO-FOO-style names for iteration macros
** finished s/FUNCTION/FUN/
** s/#'(lambda/(lambda/
** four-space indentation in C
* pending patches that go in (or else get rejected) before 0.7.0:
- ** Nathan Froyd "Goodbye ITERATE" 2001-12-15
+ ** Alexey Dejneka "BUG in nested backquotes processing"
+ sbcl-devel 2001-12-21
=======================================================================
for early 0.7.x:
* patches postponed until after 0.7.0:
** Christophe Rhodes "rough patch to fix bug 106" 2001-10-28
* building with CLISP (or explaining why not)
+* urgent EVAL/EVAL-WHEN/%COMPILE/DEFUN/DEFSTRUCT cleanup:
+ ** fixed bug 137
* faster bootstrapping (both make.sh and slam.sh)
** added mechanisms for automatically finding dead code, and
used them to remove dead code
("src/code/bit-bash" :not-host) ; needs %NEGATE from assembly/target/arith
- ("src/code/target-load" :not-host) ; needs specials from code/load.lisp
+ ("src/code/target-load" :not-host) ; needs special vars from code/load.lisp
;; FIXME: Does this really need stuff from compiler/dump.lisp?
("src/compiler/target-dump" :not-host) ; needs stuff from compiler/dump.lisp
"COLD-FSET"
"!DEFUN-FROM-COLLECTED-COLD-INIT-FORMS"))
- #s(sb-cold:package-data
- :name "SB!ITERATE"
- :doc "private: an iteration facility used to implement PCL"
- :use ("CL" "SB!WALKER" "SB!INT" "SB!EXT")
- :export ("ITERATE" "ITERATE*" "GATHERING" "GATHER"
- "WITH-GATHERING" "INTERVAL" "ELEMENTS"
- "LIST-ELEMENTS" "LIST-TAILS" "PLIST-ELEMENTS"
- "EACHTIME" "WHILE" "UNTIL" "COLLECTING" "JOINING"
- "MAXIMIZING" "MINIMIZING" "SUMMING"
- "*ITERATE-WARNINGS*"))
-
;; FIXME: This package is awfully huge. It'd probably be good to
;; split it. There's at least one natural way to split it: the
;; implementation of the Lisp type system (e.g. TYPE-INTERSECTION and
;; this until the duplicate SB-PCL:CLASS/CL:CLASS hierarchy kludge
;; is unscrewed, since until it is there are too many things which
;; conflict between the two packages.
- :use ("CL" "SB!ITERATE" "SB!WALKER" "SB!INT" "SB!EXT")
+ :use ("CL" "SB!INT" "SB!EXT" "SB!WALKER")
:import-from (("SB!KERNEL" "FUNCALLABLE-INSTANCE-P" "%FUN-DOC"
"PACKAGE-DOC-STRING"
"PACKAGE-HASHTABLE-SIZE" "PACKAGE-HASHTABLE-FREE"
(/show0 "redefining NAME in %DEFUN")
(style-warn "redefining ~S in DEFUN" name))
(setf (sb!xc:fdefinition name) def)
- (setf (%fun-name def) name)
+
+ ;; FIXME: I want to do this here (and fix bug 137), but until the
+ ;; breathtaking CMU CL function name architecture is converted into
+ ;; something sane, (1) doing so doesn't really fix the bug, and
+ ;; (2) doing probably isn't even really safe.
+ #+nil (setf (%fun-name def) name)
+
(when doc
;; FIXME: This should use shared SETF-name-parsing logic.
(if (and (consp name) (eq (first name) 'setf))
;;; Note that despite the connoting-no-side-effects-pure-predicate
;;; name, we emit some error output if we're called at a point where
;;; /SHOW is inherently invalid.
+#!+sb-show
(defun suppress-/show-p ()
(cond (;; protection against /SHOW too early in cold init for
;; (FORMAT *TRACE-OUTPUT* ..) to work, part I: Obviously
(funcallable-instance-fun fun)))))
(defun (setf %fun-name) (new-name fun)
+ (aver nil) ; since this is unsafe 'til bug 137 is fixed
(let ((widetag (widetag-of fun)))
(case widetag
((#.sb!vm:simple-fun-header-widetag
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
+\f
+;;;; CLISP issues
#+clisp
(locally
(export 'boolean "LISP")
|#
- ;; I gave up on using CLISP-1999-01-08 as a cross-compilation host because of
- ;; problems that I don't have workarounds for:
- (error "can't use CLISP -- no MAKE-LOAD-FORM")
- (error "can't use CLISP -- no (FUNCTION (SETF SYMBOL-FUNCTION))")
- )
+ ;; apparently fixed sometime in 2001, hurray!
+ #| (error "can't use CLISP -- no MAKE-LOAD-FORM") |#
+
+ ;; CLISP is still unsupported as a cross-compilation host because of
+ ;; these known problems:
+ (flet ((clisp-ouch (s) (error "can't bootstrap with CLISP: ~A" s)))
+ ;; These problems don't seem deep, and could probably be worked
+ ;; around.
+ #+nil (clisp-ouch "no (DOCUMENTATION X) when X is a PACKAGE")
+ #+nil (clisp-ouch "no (FUNCTION (SETF SYMBOL-FUNCTION))")))
+\f
+;;;; CMU CL issues
;;; CMU CL, at least as of 18b, doesn't support PRINT-OBJECT. In
;;; particular, it refuses to compile :PRINT-OBJECT options to
(warn "CMU CL has a broken implementation of READ-SEQUENCE.")
(pushnew :no-ansi-read-sequence *features*))
+#+(and cmu alpha)
+(unless (ignore-errors (read-from-string "1.0l0"))
+ (error "CMUCL on Alpha can't read floats in the format \"1.0l0\". Patch your core file~%~%"))
+\f
+;;;; general non-ANSI-ness
+
+(in-package :sb-cold)
+
;;; Do the exports of COMMON-LISP conform to the standard? If not, try
;;; to make them conform. (Of course, ANSI says that bashing symbols
;;; in the COMMON-LISP package like this is undefined, but then if the
cl)
(kernel:%set-symbol-package symbol cl))))
standard-ht))
-
-#+(and cmu alpha)
-(unless (ignore-errors (read-from-string "1.0l0"))
- (error "CMUCL on Alpha can't read floats in the format \"1.0l0\". Patch your core file~%~%"))
-
(package-data-name package-data)
:nicknames (package-data-nicknames package-data)
:use nil)))
- #!+sb-doc (setf (documentation package t)
- (package-data-doc package-data))
+ #-clisp ; As of "2.27 (released 2001-07-17) (built 3215971334)"
+ ; CLISP didn't support DOCUMENTATION on PACKAGE values.
+ (progn
+ #!+sb-doc (setf (documentation package t)
+ (package-data-doc package-data)))
;; Walk the tree of exported names, exporting each name.
(labels ((recurse (tree)
(etypecase tree
;;; able to get rid of this function and use plain RENAME-FILE in the
;;; COMPILE-STEM function above. -- WHN 19990321
(defun rename-file-a-la-unix (x y)
+
+ ;; CLISP signals an error when the target file exists, which
+ ;; seems unjustified by the ANSI definition of RENAME-FILE.
+ ;; Work around it.
+ #+clisp (ignore-errors (delete-file y))
+
(rename-file x
;; (Note that the TRUENAME expression here is lifted
;; from an example in the ANSI spec for TRUENAME.)
;; dependencies from the old PCL defsys.lisp
;; dependency database.
"src/pcl/walk"
- "src/pcl/iterate"
+ ;; "src/pcl/iterate" removed 2001-12-20 njf
"src/pcl/early-low"
"src/pcl/macros"
"src/pcl/compiler-support"
:ref-trans %simple-fun-type
:set-known (unsafe)
:set-trans (setf %simple-fun-type))
+ ;; the SB!C::DEBUG-FUN object corresponding to this object, or NIL for none
+ #+nil ; FIXME: doesn't work (gotcha, lowly maintenoid!) See notes on bug 137.
+ (debug-fun :ref-known (flushable)
+ :ref-trans %simple-fun-debug-fun
+ :set-known (unsafe)
+ :set-trans (setf %simple-fun-debug-fun))
(code :rest-p t :c-type "unsigned char"))
(define-primitive-object (return-pc :lowtag other-pointer-lowtag :widetag t)
(or (nth arg-number (the list *slot-vector-symbols*))
(intern (format nil ".SLOTS~A." arg-number) *pcl-package*)))
+;; FIXME: There ought to be a good way to factor out the idiom:
+;;
+;; (dotimes (i (length metatypes))
+;; (push (dfun-arg-symbol i) lambda-list))
+;;
+;; used in the following six functions into common code that we can
+;; declare inline or something. --njf 2001-12-20
(defun make-dfun-lambda-list (metatypes applyp)
- (gathering1 (collecting)
- (iterate ((i (interval :from 0))
- (s (list-elements metatypes)))
- (progn s)
- (gather1 (dfun-arg-symbol i)))
+ (let ((lambda-list nil))
+ (dotimes (i (length metatypes))
+ (push (dfun-arg-symbol i) lambda-list))
(when applyp
- (gather1 '&rest)
- (gather1 '.dfun-rest-arg.))))
+ (push '&rest lambda-list)
+ (push '.dfun-rest-arg. lambda-list))
+ (nreverse lambda-list)))
(defun make-dlap-lambda-list (metatypes applyp)
- (gathering1 (collecting)
- (iterate ((i (interval :from 0))
- (s (list-elements metatypes)))
- (progn s)
- (gather1 (dfun-arg-symbol i)))
+ (let ((lambda-list nil))
+ (dotimes (i (length metatypes))
+ (push (dfun-arg-symbol i) lambda-list))
+ ;; FIXME: This is translated directly from the old PCL code.
+ ;; It didn't have a (PUSH '.DFUN-REST-ARG. LAMBDA-LIST) or
+ ;; something similar, so we don't either. It's hard to see how
+ ;; this could be correct, since &REST wants an argument after
+ ;; it. This function works correctly because the caller
+ ;; magically tacks on something after &REST. The calling functions
+ ;; (in dlisp.lisp) should be fixed and this function rewritten.
+ ;; --njf 2001-12-20
(when applyp
- (gather1 '&rest))))
-
+ (push '&rest lambda-list))
+ (nreverse lambda-list)))
+
+;; FIXME: The next four functions suffer from having a `.DFUN-REST-ARG.'
+;; in their lambda lists, but no corresponding `&REST' symbol. We assume
+;; this should be the case by analogy with the previous two functions.
+;; It works, and I don't know why. Check the calling functions and
+;; fix these too. --njf 2001-12-20
(defun make-emf-call (metatypes applyp fn-variable &optional emf-type)
(let ((required
- (gathering1 (collecting)
- (iterate ((i (interval :from 0))
- (s (list-elements metatypes)))
- (progn s)
- (gather1 (dfun-arg-symbol i))))))
+ (let ((required nil))
+ (dotimes (i (length metatypes))
+ (push (dfun-arg-symbol i) required))
+ (nreverse required))))
`(,(if (eq emf-type 'fast-method-call)
'invoke-effective-method-function-fast
'invoke-effective-method-function)
(defun make-dfun-call (metatypes applyp fn-variable)
(let ((required
- (gathering1 (collecting)
- (iterate ((i (interval :from 0))
- (s (list-elements metatypes)))
- (progn s)
- (gather1 (dfun-arg-symbol i))))))
+ (let ((required nil))
+ (dotimes (i (length metatypes))
+ (push (dfun-arg-symbol i) required))
+ (nreverse required))))
(if applyp
`(function-apply ,fn-variable ,@required .dfun-rest-arg.)
`(function-funcall ,fn-variable ,@required))))
(defun make-dfun-arg-list (metatypes applyp)
(let ((required
- (gathering1 (collecting)
- (iterate ((i (interval :from 0))
- (s (list-elements metatypes)))
- (progn s)
- (gather1 (dfun-arg-symbol i))))))
+ (let ((required nil))
+ (dotimes (i (length metatypes))
+ (push (dfun-arg-symbol i) required))
+ (nreverse required))))
(if applyp
`(list* ,@required .dfun-rest-arg.)
`(list ,@required))))
(defun make-fast-method-call-lambda-list (metatypes applyp)
- (gathering1 (collecting)
- (gather1 '.pv-cell.)
- (gather1 '.next-method-call.)
- (iterate ((i (interval :from 0))
- (s (list-elements metatypes)))
- (progn s)
- (gather1 (dfun-arg-symbol i)))
+ (let ((lambda-list nil))
+ (push '.pv-cell. lambda-list)
+ (push '.next-method-call. lambda-list)
+ (dotimes (i (length metatypes))
+ (push (dfun-arg-symbol i) lambda-list))
(when applyp
- (gather1 '.dfun-rest-arg.))))
+ (push '.dfun-rest-arg. lambda-list))
+ (nreverse lambda-list)))
+
\f
;;;; a comment from some PCL implementor:
;;;; Its too bad Common Lisp compilers freak out when you have a
(defun expand-defconstructor (class-name name lambda-list supplied-initargs)
(let ((class (find-class class-name nil))
(supplied-initarg-names
- (gathering1 (collecting)
- (iterate ((name (*list-elements supplied-initargs :by #'cddr)))
- (gather1 name)))))
+ (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."
Other possible code types are ~S."
constructor (constructor-class constructor)
(constructor-code-type constructor)
- (gathering1 (collecting)
+ (let ((collect nil))
(doplist (key val) (constructor-code-generators constructor)
- (gather1 key)))))
+ (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
((class slot-class)
name lambda-list supplied-initarg-names supplied-initargs)
(cons 'list
- (gathering1 (collecting)
+ (let ((collect nil))
(dolist (entry *constructor-code-types*)
(let ((generator
(funcall (cadr entry) class name lambda-list
supplied-initarg-names
supplied-initargs)))
(when generator
- (gather1 `',(car entry))
- (gather1 generator)))))))
+ (push `',(car entry) collect)
+ (push generator collect))))
+ (nreverse collect))))
(defmethod compute-constructor-code ((class slot-class)
(constructor constructor))
(defun compute-initarg-positions (class initarg-names)
(let* ((layout (wrapper-instance-slots-layout (class-wrapper class)))
(positions
- (gathering1 (collecting)
- (iterate ((slot-name (list-elements layout))
- (position (interval :from 0)))
- (gather1 (cons slot-name position)))))
+ (loop for slot-name in layout
+ for position from 0
+ collect (cons slot-name position)))
(slot-initargs
(mapcar #'(lambda (slotd)
(list (slot-definition-initargs slotd)
(not (null slot-initargs))
(memq initarg slot-initargs))
(setf (car slot-entry) initarg)))))
- (gathering1 (collecting)
+ (let (collect)
(dolist (initarg initarg-names)
- (let ((positions (gathering1 (collecting)
+ (let ((positions (let (collect)
(dolist (slot-entry slot-initargs)
(when (eq (car slot-entry) initarg)
- (gather1 (cadr slot-entry)))))))
+ (push (cadr slot-entry) collect)))
+ (nreverse collect))))
(when positions
- (gather1 (cons initarg positions))))))))
+ (push (cons initarg positions) collect))))
+ (nreverse collect))))
\f
;;; 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
(sb-kernel:instance-lambda ,arglist
(make-instance
',(class-name class)
- ,@(gathering1 (collecting)
- (iterate ((tail (*list-tails supplied-initargs :by #'cddr)))
- (gather1 `',(car tail))
- (gather1 (cadr tail))))))))))
+ ,@(let (collect)
+ (loop for tail on supplied-initargs by #'cddr
+ do (push `',(car tail) collect)
+ (push (cadr tail) collect))
+ (nreverse collect))))))))
\f
;;; The GENERAL case allows:
;;; constant, unsupplied or non-constant initforms
(dolist (pos (cddr entry))
(setf (clos-slots-ref .slots. pos) val))))
- ,@(gathering1 (collecting)
+ ,@(let (collect)
(doplist (initarg value) supplied-initargs
(unless (constantp value)
- (gather1 `(let ((.value. ,value))
- (push .value. .initargs.)
- (push ',initarg .initargs.)
- (dolist (.p. (pop .positions.))
- (setf (clos-slots-ref .slots. .p.)
- .value.)))))))
+ (push `(let ((.value. ,value))
+ (push .value. .initargs.)
+ (push ',initarg .initargs.)
+ (dolist (.p. (pop .positions.))
+ (setf (clos-slots-ref .slots. .p.)
+ .value.)))
+ collect)))
+ (nreverse collect))
(dolist (fn .shared-initfns.)
(apply fn .instance. t .initargs.))
(dolist (pos (cdr entry))
(setf (clos-slots-ref .slots. pos) val))))
- ,@(gathering1 (collecting)
+ ,@(let (collect)
(doplist (initarg value) supplied-initargs
(unless (constantp value)
- (gather1
+ (push
`(let ((.value. ,value))
(dolist (.p. (pop .positions.))
(setf (clos-slots-ref .slots. .p.)
- .value.)))))))
+ .value.)))
+ collect)))
+ (nreverse collect))
.instance.))))))))
(.positions. .supplied-initarg-positions.))
.positions.
- ,@(gathering1 (collecting)
+ ,@(let (collect)
(doplist (initarg value) supplied-initargs
(unless (constantp value)
- (gather1
+ (push
`(let ((.value. ,value))
(dolist (.p. (pop .positions.))
(setf (clos-slots-ref .slots. .p.)
- .value.)))))))
+ .value.)))
+ collect)))
+ (nreverse collect))
.instance.))))))))))
(values (early-collect-slots cpl)
cpl
(early-collect-default-initargs cpl)
- (gathering1 (collecting)
+ (let (collect)
(dolist (definition *early-class-definitions*)
(when (memq class-name (ecd-superclass-names definition))
- (gather1 (ecd-class-name definition))))))))
+ (push (ecd-class-name definition) collect)))
+ (nreverse collect)))))
(defun early-collect-slots (cpl)
(let* ((definitions (mapcar #'early-class-definition cpl))
(defun wrap-method-group-specifier-bindings
(method-group-specifiers declarations real-body)
- (with-gathering ((names (collecting))
- (specializer-caches (collecting))
- (cond-clauses (collecting))
- (required-checks (collecting))
- (order-cleanups (collecting)))
+ (let (names
+ specializer-caches
+ cond-clauses
+ required-checks
+ order-cleanups)
(dolist (method-group-specifier method-group-specifiers)
(multiple-value-bind (name tests description order required)
(parse-method-group-specifier method-group-specifier)
(declare (ignore description))
(let ((specializer-cache (gensym)))
- (gather name names)
- (gather specializer-cache specializer-caches)
- (gather `((or ,@tests)
+ (push name names)
+ (push specializer-cache specializer-caches)
+ (push `((or ,@tests)
(if (equal ,specializer-cache .specializers.)
(return-from .long-method-combination-function.
'(error "More than one method of type ~S ~
(push .method. ,name))
cond-clauses)
(when required
- (gather `(when (null ,name)
+ (push `(when (null ,name)
(return-from .long-method-combination-function.
'(error "No ~S methods." ',name)))
required-checks))
(loop (unless (and (constantp order)
(neq order (setq order (eval order))))
(return t)))
- (gather (cond ((eq order :most-specific-first)
+ (push (cond ((eq order :most-specific-first)
`(setq ,name (nreverse ,name)))
((eq order :most-specific-last) ())
(t
(setq ,name (nreverse ,name)))
(:most-specific-last))))
order-cleanups))))
- `(let (,@names ,@specializer-caches)
+ `(let (,@(nreverse names) ,@(nreverse specializer-caches))
,@declarations
(dolist (.method. .applicable-methods.)
(let ((.qualifiers. (method-qualifiers .method.))
(.specializers. (method-specializers .method.)))
(progn .qualifiers. .specializers.)
- (cond ,@cond-clauses)))
- ,@required-checks
- ,@order-cleanups
+ (cond ,@(nreverse cond-clauses))))
+ ,@(nreverse required-checks)
+ ,@(nreverse order-cleanups)
,@real-body)))
(defun parse-method-group-specifier (method-group-specifier)
(let* ((name (pop method-group-specifier))
(patterns ())
(tests
- (gathering1 (collecting)
+ (let (collect)
(block collect-tests
(loop
(if (or (null method-group-specifier)
(return-from collect-tests t)
(let ((pattern (pop method-group-specifier)))
(push pattern patterns)
- (gather1 (parse-qualifier-pattern name pattern)))))))))
+ (push (parse-qualifier-pattern name pattern)
+ collect)))))
+ (nreverse collect))))
(values name
tests
(getf method-group-specifier :description
;;; option are bound to the symbols in the intercept lambda list.
(defun deal-with-arguments-option (wrapped-body arguments-option)
(let* ((intercept-lambda-list
- (gathering1 (collecting)
+ (let (collect)
(dolist (arg arguments-option)
(if (memq arg lambda-list-keywords)
- (gather1 arg)
- (gather1 (gensym))))))
+ (push arg collect)
+ (push (gensym) collect)))
+ (nreverse collect)))
(intercept-rebindings
- (gathering1 (collecting)
- (iterate ((arg (list-elements arguments-option))
- (int (list-elements intercept-lambda-list)))
- (unless (memq arg lambda-list-keywords)
- (gather1 `(,arg ',int)))))))
-
+ (loop for arg in arguments-option
+ for int in intercept-lambda-list
+ unless (memq arg lambda-list-keywords)
+ collect `(,arg ',int))))
(setf (cadr wrapped-body)
(append intercept-rebindings (cadr wrapped-body)))
(defmacro precompile-dfun-constructors (&optional system)
(let ((*precompiling-lap* t))
`(progn
- ,@(gathering1 (collecting)
+ ,@(let (collect)
(dolist (generator-entry *dfun-constructors*)
(dolist (args-entry (cdr generator-entry))
(when (or (null (caddr args-entry))
(eq (caddr args-entry) system))
(when system (setf (caddr args-entry) system))
- (gather1
- `(load-precompiled-dfun-constructor
- ',(car generator-entry)
- ',(car args-entry)
- ',system
- ,(apply (fdefinition (car generator-entry))
- (car args-entry)))))))))))
+ (push `(load-precompiled-dfun-constructor
+ ',(car generator-entry)
+ ',(car args-entry)
+ ',system
+ ,(apply (fdefinition (car generator-entry))
+ (car args-entry)))
+ collect))))
+ (nreverse collect)))))
\f
;;; When all the methods of a generic function are automatically
;;; generated reader or writer methods a number of special
(defmacro precompile-iis-functions (&optional system)
`(progn
- ,@(gathering1 (collecting)
- (dolist (iis-entry *initialize-instance-simple-alist*)
- (when (or (null (caddr iis-entry))
- (eq (caddr iis-entry) system))
- (when system (setf (caddr iis-entry) system))
- (gather1
- `(load-precompiled-iis-entry
- ',(car iis-entry)
- #',(car iis-entry)
- ',system
- ',(cdddr iis-entry))))))))
+ ,@(let (collect)
+ (dolist (iis-entry *initialize-instance-simple-alist*)
+ (when (or (null (caddr iis-entry))
+ (eq (caddr iis-entry) system))
+ (when system (setf (caddr iis-entry) system))
+ (push `(load-precompiled-iis-entry
+ ',(car iis-entry)
+ #',(car iis-entry)
+ ',system
+ ',(cdddr iis-entry))
+ collect)))
+ (nreverse collect))))
(defun compile-iis-functions (after-p)
(let ((*compile-make-instance-functions-p* t)
gensyms)))
(defun compute-constants (lambda constant-converter)
- (let ((*walk-form-expand-macros-p* t)) ; doesn't matter here.
- (macrolet ((appending ()
- `(let ((result ()))
- (values #'(lambda (value) (setq result (append result value)))
- #'(lambda ()result)))))
- (gathering1 (appending)
- (walk-form lambda
- nil
- #'(lambda (f c e)
- (declare (ignore e))
- (if (neq c :eval)
- f
- (let ((consts (funcall constant-converter f)))
- (if consts
- (progn (gather1 consts) (values f t))
- f)))))))))
+ (let ((*walk-form-expand-macros-p* t) ; doesn't matter here.
+ collect)
+ (walk-form lambda
+ nil
+ #'(lambda (f c e)
+ (declare (ignore e))
+ (if (neq c :eval)
+ f
+ (let ((consts (funcall constant-converter f)))
+ (if consts
+ (progn
+ (setq collect (nconc collect consts))
+ (values f t))
+ f)))))
+ collect))
\f
(defmacro precompile-function-generators (&optional system)
`(progn
- ,@(gathering1 (collecting)
- (dolist (fgen *fgens*)
- (when (or (null (fgen-system fgen))
- (eq (fgen-system fgen) system))
- (when system (setf (svref fgen 4) system))
- (gather1
- `(load-function-generator
- ',(fgen-test fgen)
- ',(fgen-gensyms fgen)
- (function ,(fgen-generator-lambda fgen))
- ',(fgen-generator-lambda fgen)
- ',system)))))))
+ ,@(let (collect)
+ (dolist (fgen *fgens*)
+ (when (or (null (fgen-system fgen))
+ (eq (fgen-system fgen) system))
+ (when system (setf (svref fgen 4) system))
+ (push `(load-function-generator
+ ',(fgen-test fgen)
+ ',(fgen-gensyms fgen)
+ (function ,(fgen-generator-lambda fgen))
+ ',(fgen-generator-lambda fgen)
+ ',system)
+ collect)))
+ (nreverse collect))))
(defun load-function-generator (test gensyms generator generator-lambda system)
(store-fgen (make-fgen test gensyms generator generator-lambda system)))
(/show "pcl/macros.lisp 85")
-(defmacro collecting-once (&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)))
- (unless (memq value head)
- (setq tail
- (cdr (rplacd tail (list value)))))))
- #'(lambda nil head))))
-
-(/show "pcl/macros.lisp 98")
-
(defmacro doplist ((key val) plist &body body &environment env)
(multiple-value-bind (doc decls bod)
(extract-declarations body env)
(setq ,val (pop .plist-tail.))
(progn ,@bod)))))
-(/show "pcl/macros.lisp 113")
+(/show "pcl/macros.lisp 101")
(defmacro dolist-carefully ((var list improper-list-handler) &body body)
`(let ((,var nil)
;;;; SBCL deviates from the spec by having CL:FIND-CLASS distinct from
;;;; PCL:FIND-CLASS, alas.
-(/show "pcl/macros.lisp 132")
+(/show "pcl/macros.lisp 119")
(defvar *find-class* (make-hash-table :test 'eq))
;;; (DECLAIM (TYPE (MEMBER NIL :EARLY :BRAID :COMPLETE) *BOOT-STATE*))
(defvar *boot-state* nil)
-(/show "pcl/macros.lisp 199")
+(/show "pcl/macros.lisp 187")
;;; Note that in SBCL as in CMU CL,
;;; COMMON-LISP:FIND-CLASS /= SB-PCL:FIND-CLASS.
new-value)
(error "~S is not a legal class name." symbol)))
-(/show "pcl/macros.lisp 242")
+(/show "pcl/macros.lisp 230")
(defun (setf find-class-predicate)
(new-value symbol)
(defun find-wrapper (symbol)
(class-wrapper (find-class symbol)))
-(defmacro gathering1 (gatherer &body body)
- `(gathering ((.gathering1. ,gatherer))
- (macrolet ((gather1 (x) `(gather ,x .gathering1.)))
- ,@body)))
-
-(defmacro vectorizing (&key (size 0))
- `(let* ((limit ,size)
- (result (make-array limit))
- (index 0))
- (values #'(lambda (value)
- (if (= index limit)
- (error "vectorizing more elements than promised")
- (progn
- (setf (svref result index) value)
- (incf index)
- value)))
- #'(lambda () result))))
-
-(/show "pcl/macros.lisp 271")
-
-;;; These are augmented definitions of LIST-ELEMENTS and LIST-TAILS from
-;;; iterate.lisp. These versions provide the extra :BY keyword which can
-;;; be used to specify the step function through the list.
-(defmacro *list-elements (list &key (by #'cdr))
- `(let ((tail ,list))
- #'(lambda (finish)
- (if (endp tail)
- (funcall finish)
- (prog1 (car 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))))))
+(/show "pcl/macros.lisp 241")
(defmacro function-funcall (form &rest args)
`(funcall (the function ,form) ,@args))
(defmacro function-apply (form &rest args)
`(apply (the function ,form) ,@args))
-(/show "pcl/macros.lisp 299")
+(/show "pcl/macros.lisp 249")
\f
(defun get-setf-fun-name (name)
`(setf ,name))
;; in the usual sort of way. For efficiency don't bother to
;; keep specialized-argument-positions sorted, rather depend
;; on our caller to do that.
- (iterate ((type-spec (list-elements (method-specializers method)))
- (pos (interval :from 0)))
- (unless (eq type-spec *the-class-t*)
- (pushnew pos specialized-argument-positions)))
+ (let ((pos 0))
+ (dolist (type-spec (method-specializers method))
+ (unless (eq type-spec *the-class-t*)
+ (pushnew pos specialized-argument-positions))
+ (incf pos)))
;; Finally merge the values for this method into the values
;; for the exisiting methods and return them. Note that if
;; num-of-requireds is NIL it means this is the first method
specialized-argument-positions)))
(defun make-discriminating-function-arglist (number-required-arguments restp)
- (nconc (gathering ((args (collecting)))
- (iterate ((i (interval :from 0 :below number-required-arguments)))
- (gather (intern (format nil "Discriminating Function Arg ~D" i))
- args)))
+ (nconc (let ((args nil))
+ (dotimes (i number-required-arguments)
+ (push (intern (format nil "Discriminating Function Arg ~D" i))
+ args))
+ (nreverse args))
(when restp
`(&rest ,(intern "Discriminating Function &rest Arg")))))
\f
(with-slots (direct-methods) specializer
(or (cdr direct-methods)
(setf (cdr direct-methods)
- (gathering1 (collecting-once)
+ (let (collect)
(dolist (m (car direct-methods))
- (gather1 (method-generic-function m))))))))
+ ;; the old PCL code used COLLECTING-ONCE which used
+ ;; #'EQ to check for newness
+ (pushnew (method-generic-function m) collect :test #'eq))
+ (nreverse collect))))))
\f
;;; This hash table is used to store the direct methods and direct generic
;;; functions of EQL specializers. Each value in the table is the cons.
(when entry
(or (cdr entry)
(setf (cdr entry)
- (gathering1 (collecting-once)
+ (let (collect)
(dolist (m (car entry))
- (gather1 (method-generic-function m)))))))))
+ (pushnew (method-generic-function m) collect :test #'eq))
+ (nreverse collect)))))))
(defun map-specializers (function)
(map-all-classes #'(lambda (class)
(setq direct-default-initargs
(plist-value class 'direct-default-initargs)))
(setf (plist-value class 'class-slot-cells)
- (gathering1 (collecting)
+ (let (collect)
(dolist (dslotd direct-slots)
(when (eq (slot-definition-allocation dslotd) class)
(let ((initfunction (slot-definition-initfunction dslotd)))
- (gather1 (cons (slot-definition-name dslotd)
+ (push (cons (slot-definition-name dslotd)
(if initfunction
(funcall initfunction)
- +slot-unbound+))))))))
+ +slot-unbound+))
+ collect))))
+ (nreverse collect)))
(setq predicate-name (if predicate-name-p
(setf (slot-value class 'predicate-name)
(car predicate-name))
(make-wrapper nslots class))
((and (equal nlayout olayout)
(not
- (iterate ((o (list-elements owrapper-class-slots))
- (n (list-elements nwrapper-class-slots)))
- (unless (eq (car o) (car n)) (return t)))))
+ (loop for o in owrapper-class-slots
+ for n in nwrapper-class-slots
+ do (unless (eq (car o) (car n)) (return t)))))
owrapper)
(t
;; This will initialize the new wrapper to have the
(update-pv-table-cache-info class)))))
(defun compute-class-slots (eslotds)
- (gathering1 (collecting)
+ (let (collect)
(dolist (eslotd eslotds)
- (gather1
- (assoc (slot-definition-name eslotd)
- (class-slot-cells (slot-definition-allocation eslotd)))))))
+ (push (assoc (slot-definition-name eslotd)
+ (class-slot-cells (slot-definition-allocation eslotd)))
+ collect))
+ (nreverse collect)))
(defun compute-layout (cpl instance-eslotds)
(let* ((names
- (gathering1 (collecting)
+ (let (collect)
(dolist (eslotd instance-eslotds)
(when (eq (slot-definition-allocation eslotd) :instance)
- (gather1 (slot-definition-name eslotd))))))
+ (push (slot-definition-name eslotd) collect)))
+ (nreverse collect)))
(order ()))
(labels ((rwalk (tail)
(when tail
;; -- --> shared --
;; Go through all the old local slots.
- (iterate ((name (list-elements olayout))
- (opos (interval :from 0)))
- (let ((npos (posq name nlayout)))
- (if npos
- (setf (clos-slots-ref nslots npos)
- (clos-slots-ref oslots opos))
- (progn
- (push name discarded)
- (unless (eq (clos-slots-ref oslots opos) +slot-unbound+)
- (setf (getf plist name) (clos-slots-ref oslots opos)))))))
+ (let ((opos 0))
+ (dolist (name olayout)
+ (let ((npos (posq name nlayout)))
+ (if npos
+ (setf (clos-slots-ref nslots npos)
+ (clos-slots-ref oslots opos))
+ (progn
+ (push name discarded)
+ (unless (eq (clos-slots-ref oslots opos) +slot-unbound+)
+ (setf (getf plist name) (clos-slots-ref oslots opos))))))
+ (incf opos)))
;; Go through all the old shared slots.
- (iterate ((oclass-slot-and-val (list-elements oclass-slots)))
+ (dolist (oclass-slot-and-val oclass-slots)
(let ((name (car oclass-slot-and-val))
(val (cdr oclass-slot-and-val)))
(let ((npos (posq name nlayout)))
;; "The values of local slots specified by both the class CTO and
;; CFROM are retained. If such a local slot was unbound, it
;; remains unbound."
- (iterate ((new-slot (list-elements new-layout))
- (new-position (interval :from 0)))
- (let ((old-position (posq new-slot old-layout)))
- (when old-position
- (setf (clos-slots-ref new-slots new-position)
- (clos-slots-ref old-slots old-position)))))
+ (let ((new-position 0))
+ (dolist (new-slot new-layout)
+ (let ((old-position (posq new-slot old-layout)))
+ (when old-position
+ (setf (clos-slots-ref new-slots new-position)
+ (clos-slots-ref old-slots old-position))))))
;; "The values of slots specified as shared in the class CFROM and
;; as local in the class CTO are retained."
- (iterate ((slot-and-val (list-elements old-class-slots)))
+ (dolist (slot-and-val old-class-slots)
(let ((position (posq (car slot-and-val) new-layout)))
(when position
(setf (clos-slots-ref new-slots position) (cdr slot-and-val)))))
(unless (listp wrappers) (setq wrappers (list wrappers)))
(let* ((not-simple-p-cell (list nil))
(elements
- (gathering1 (collecting)
- (iterate ((slot-names (list-elements slot-name-lists)))
+ (let ((elements nil))
+ (dolist (slot-names slot-name-lists)
(when slot-names
(let* ((wrapper (pop wrappers))
(std-p (typep wrapper 'wrapper))
(class (wrapper-class* wrapper))
(class-slots (and std-p (wrapper-class-slots wrapper))))
(dolist (slot-name (cdr slot-names))
- (gather1
- (when std-p
- (compute-pv-slot slot-name wrapper class
- class-slots not-simple-p-cell))))))))))
+ ;; Original PCL code had this idiom. why not:
+ ;;
+ ;; (WHEN STD-P
+ ;; (PUSH ...)) ?
+ (push (when std-p
+ (compute-pv-slot slot-name wrapper class
+ class-slots not-simple-p-cell))
+ elements)))))
+ (nreverse elements))))
(if (car not-simple-p-cell)
(make-permutation-vector (cons t elements))
(or (gethash elements *pvs*)
(defmacro pv-binding ((required-parameters slot-name-lists pv-table-symbol)
&body body)
- (with-gathering ((slot-vars (collecting))
- (pv-parameters (collecting)))
- (iterate ((slots (list-elements slot-name-lists))
- (required-parameter (list-elements required-parameters))
- (i (interval :from 0)))
- (when slots
- (gather required-parameter pv-parameters)
- (gather (slot-vector-symbol i) slot-vars)))
- `(pv-binding1 (.pv. .calls. ,pv-table-symbol ,pv-parameters ,slot-vars)
+ (let (slot-vars pv-parameters)
+ (loop for slots in slot-name-lists
+ for required-parameter in required-parameters
+ for i from 0
+ do (when slots
+ (push required-parameter pv-parameters)
+ (push (slot-vector-symbol i) slot-vars)))
+ `(pv-binding1 (.pv. .calls. ,pv-table-symbol
+ ,(nreverse pv-parameters) ,(nreverse slot-vars))
,@body)))
(defmacro pv-binding1 ((pv calls pv-table-symbol pv-parameters slot-vars)
;;; for internal versions, especially for internal versions off the
;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.pre7.94"
+"0.pre7.97"
projects / sbcl.git / commitdiff