1.0.1.9:
[sbcl.git] / src / pcl / vector.lisp
1 ;;;; permutation vectors
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5
6 ;;;; This software is derived from software originally released by Xerox
7 ;;;; Corporation. Copyright and release statements follow. Later modifications
8 ;;;; to the software are in the public domain and are provided with
9 ;;;; absolutely no warranty. See the COPYING and CREDITS files for more
10 ;;;; information.
11
12 ;;;; copyright information from original PCL sources:
13 ;;;;
14 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
15 ;;;; All rights reserved.
16 ;;;;
17 ;;;; Use and copying of this software and preparation of derivative works based
18 ;;;; upon this software are permitted. Any distribution of this software or
19 ;;;; derivative works must comply with all applicable United States export
20 ;;;; control laws.
21 ;;;;
22 ;;;; This software is made available AS IS, and Xerox Corporation makes no
23 ;;;; warranty about the software, its performance or its conformity to any
24 ;;;; specification.
25
26 (in-package "SB-PCL")
27 \f
28 (defmacro instance-slot-index (wrapper slot-name)
29   `(let ((pos 0))
30      (declare (fixnum pos))
31      (block loop
32        (dolist (sn (wrapper-instance-slots-layout ,wrapper))
33          (when (eq ,slot-name sn) (return-from loop pos))
34          (incf pos)))))
35 \f
36 (defun pv-cache-limit-fn (nlines)
37   (default-limit-fn nlines))
38
39 (defstruct (pv-table (:predicate pv-tablep)
40                      (:constructor make-pv-table-internal
41                                    (slot-name-lists call-list))
42                      (:copier nil))
43   (cache nil :type (or cache null))
44   (pv-size 0 :type fixnum)
45   (slot-name-lists nil :type list)
46   (call-list nil :type list))
47
48 #-sb-fluid (declaim (sb-ext:freeze-type pv-table))
49
50 ;;; FIXME: The comment below seem to indicate that this was intended
51 ;;; to be actually used, however, it isn't anymore, and was commented
52 ;;; out at 0.9.13.47. Also removed was code in MAKE-PV-TABLE that
53 ;;; pushed each new PV-TABLE onto this list. --NS 2006-06-18
54 ;;;
55 ;;;   help new slot-value-using-class methods affect fast iv access
56 ;;;
57 ;;;  (defvar *all-pv-table-list* nil)
58
59 (declaim (inline make-pv-table))
60 (defun make-pv-table (&key slot-name-lists call-list)
61   (make-pv-table-internal slot-name-lists call-list))
62
63 (defun make-pv-table-type-declaration (var)
64   `(type pv-table ,var))
65
66 (defvar *slot-name-lists-inner* (make-hash-table :test 'equal))
67 (defvar *slot-name-lists-outer* (make-hash-table :test 'equal))
68
69 ;;; Entries in this are lists of (table . pv-offset-list).
70 (defvar *pv-key-to-pv-table-table* (make-hash-table :test 'equal))
71
72 (defun intern-pv-table (&key slot-name-lists call-list)
73   (let ((new-p nil))
74     (flet ((inner (x)
75              (or (gethash x *slot-name-lists-inner*)
76                  (setf (gethash x *slot-name-lists-inner*) (copy-list x))))
77            (outer (x)
78              (or (gethash x *slot-name-lists-outer*)
79                  (setf (gethash x *slot-name-lists-outer*)
80                        (let ((snl (copy-list (cdr x)))
81                              (cl (car x)))
82                          (setq new-p t)
83                          (make-pv-table :slot-name-lists snl
84                                         :call-list cl))))))
85       (let ((pv-table
86              (outer (mapcar #'inner (cons call-list slot-name-lists)))))
87         (when new-p
88           (let ((pv-index 0))
89             (dolist (slot-name-list slot-name-lists)
90               (dolist (slot-name (cdr slot-name-list))
91                 (note-pv-table-reference slot-name pv-index pv-table)
92                 (incf pv-index)))
93             (dolist (gf-call call-list)
94               (note-pv-table-reference gf-call pv-index pv-table)
95               (incf pv-index))
96             (setf (pv-table-pv-size pv-table) pv-index)))
97         pv-table))))
98
99 (defun note-pv-table-reference (ref pv-offset pv-table)
100   (let ((entry (gethash ref *pv-key-to-pv-table-table*)))
101     (when (listp entry)
102       (let ((table-entry (assq pv-table entry)))
103         (when (and (null table-entry)
104                    (> (length entry) 8))
105           (let ((new-table-table (make-hash-table :size 16 :test 'eq)))
106             (dolist (table-entry entry)
107               (setf (gethash (car table-entry) new-table-table)
108                     (cdr table-entry)))
109             (setf (gethash ref *pv-key-to-pv-table-table*) new-table-table)))
110         (when (listp entry)
111           (if (null table-entry)
112               (let ((new (cons pv-table pv-offset)))
113                 (if (consp entry)
114                     (push new (cdr entry))
115                     (setf (gethash ref *pv-key-to-pv-table-table*)
116                           (list new))))
117               (push pv-offset (cdr table-entry)))
118           (return-from note-pv-table-reference nil))))
119     (let ((list (gethash pv-table entry)))
120       (if (consp list)
121           (push pv-offset (cdr list))
122           (setf (gethash pv-table entry) (list pv-offset)))))
123   nil)
124
125 (defun map-pv-table-references-of (ref function)
126   (let ((entry (gethash ref *pv-key-to-pv-table-table*)))
127     (if (listp entry)
128         (dolist (table+pv-offset-list entry)
129           (funcall function
130                    (car table+pv-offset-list)
131                    (cdr table+pv-offset-list)))
132         (maphash function entry)))
133   ref)
134 \f
135 (defun optimize-slot-value-by-class-p (class slot-name type)
136   (or (not (eq *boot-state* 'complete))
137       (let ((slotd (find-slot-definition class slot-name)))
138         (and slotd
139              (slot-accessor-std-p slotd type)))))
140
141 (defun compute-pv-slot (slot-name wrapper class class-slots)
142   (if (symbolp slot-name)
143       (when (optimize-slot-value-by-class-p class slot-name 'all)
144         (or (instance-slot-index wrapper slot-name)
145             (assq slot-name class-slots)))
146       (when (consp slot-name)
147         (case (first slot-name)
148           ((reader writer)
149            (when (eq *boot-state* 'complete)
150              (let ((gf (gdefinition (second slot-name))))
151                (when (generic-function-p gf)
152                  (accessor-values1 gf (first slot-name) class)))))
153           (t (bug "Don't know how to deal with ~S in ~S"
154                   slot-name 'compute-pv-slots))))))
155
156 (defun compute-pv (slot-name-lists wrappers)
157   (unless (listp wrappers)
158     (setq wrappers (list wrappers)))
159   (let (elements)
160     (dolist (slot-names slot-name-lists
161              (make-permutation-vector (nreverse elements)))
162       (when slot-names
163         (let* ((wrapper (pop wrappers))
164                (std-p (typep wrapper 'wrapper))
165                (class (wrapper-class* wrapper))
166                (class-slots (and std-p (wrapper-class-slots wrapper))))
167           (dolist (slot-name (cdr slot-names))
168             (push (if std-p
169                       (compute-pv-slot slot-name wrapper class class-slots)
170                       nil)
171                   elements)))))))
172
173 (defun compute-calls (call-list wrappers)
174   (declare (ignore call-list wrappers))
175   #||
176   (map 'vector
177        (lambda (call)
178          (compute-emf-from-wrappers call wrappers))
179        call-list)
180   ||#
181   '#())
182
183 #|| ; Need to finish this, then write the maintenance functions.
184 (defun compute-emf-from-wrappers (call wrappers)
185   (when call
186     (destructuring-bind (gf-name nreq restp arg-info) call
187       (if (eq gf-name 'make-instance)
188           (error "should not get here") ; there is another mechanism for this.
189           (lambda (&rest args)
190             (if (not (eq *boot-state* 'complete))
191                 (apply (gdefinition gf-name) args)
192                 (let* ((gf (gdefinition gf-name))
193                        (arg-info (arg-info-reader gf))
194                        (classes '?)
195                        (types '?)
196                        (emf (cache-miss-values-internal gf arg-info
197                                                         wrappers classes types
198                                                         'caching)))
199                   (update-all-pv-tables call wrappers emf)
200                   (invoke-emf emf args))))))))
201 ||#
202
203 (defun make-permutation-vector (indexes)
204   (make-array (length indexes) :initial-contents indexes))
205
206 (defun pv-table-lookup (pv-table pv-wrappers)
207   (let* ((slot-name-lists (pv-table-slot-name-lists pv-table))
208          (call-list (pv-table-call-list pv-table))
209          (cache (or (pv-table-cache pv-table)
210                     (setf (pv-table-cache pv-table)
211                           (get-cache (- (length slot-name-lists)
212                                         (count nil slot-name-lists))
213                                      t
214                                      #'pv-cache-limit-fn
215                                      2)))))
216     (or (probe-cache cache pv-wrappers)
217         (let* ((pv (compute-pv slot-name-lists pv-wrappers))
218                (calls (compute-calls call-list pv-wrappers))
219                (pv-cell (cons pv calls))
220                (new-cache (fill-cache cache pv-wrappers pv-cell)))
221           (unless (eq new-cache cache)
222             (setf (pv-table-cache pv-table) new-cache))
223           pv-cell))))
224
225 (defun make-pv-type-declaration (var)
226   `(type simple-vector ,var))
227
228 (defmacro pvref (pv index)
229   `(svref ,pv ,index))
230
231 (defmacro copy-pv (pv)
232   `(copy-seq ,pv))
233
234 (defun make-calls-type-declaration (var)
235   `(type simple-vector ,var))
236
237 (defmacro callsref (calls index)
238   `(svref ,calls ,index))
239
240 (defvar *pv-table-cache-update-info* nil)
241
242 (defun update-pv-table-cache-info (class)
243   (let ((slot-names-for-pv-table-update nil)
244         (new-icui nil))
245     (dolist (icu *pv-table-cache-update-info*)
246       (if (eq (car icu) class)
247           (pushnew (cdr icu) slot-names-for-pv-table-update)
248           (push icu new-icui)))
249     (setq *pv-table-cache-update-info* new-icui)
250     (when slot-names-for-pv-table-update
251       (update-all-pv-table-caches class slot-names-for-pv-table-update))))
252
253 (defun update-all-pv-table-caches (class slot-names)
254   (let* ((cwrapper (class-wrapper class))
255          (std-p (typep cwrapper 'wrapper))
256          (class-slots (and std-p (wrapper-class-slots cwrapper)))
257          (new-values
258           (mapcar
259            (lambda (slot-name)
260              (cons slot-name
261                    (if std-p
262                        (compute-pv-slot slot-name cwrapper class class-slots)
263                        nil)))
264            slot-names))
265          (pv-tables nil))
266     (dolist (slot-name slot-names)
267       (map-pv-table-references-of
268        slot-name
269        (lambda (pv-table pv-offset-list)
270          (declare (ignore pv-offset-list))
271          (pushnew pv-table pv-tables))))
272     (dolist (pv-table pv-tables)
273       (let* ((cache (pv-table-cache pv-table))
274              (slot-name-lists (pv-table-slot-name-lists pv-table))
275              (pv-size (pv-table-pv-size pv-table))
276              (pv-map (make-array pv-size :initial-element nil)))
277         (let ((map-index 0) (param-index 0))
278           (dolist (slot-name-list slot-name-lists)
279             (dolist (slot-name (cdr slot-name-list))
280               (let ((a (assoc slot-name new-values)))
281                 (setf (svref pv-map map-index)
282                       (and a (cons param-index (cdr a)))))
283               (incf map-index))
284             (incf param-index)))
285         (when cache
286           (map-cache (lambda (wrappers pv-cell)
287                        (update-slots-in-pv wrappers (car pv-cell)
288                                            cwrapper pv-size pv-map))
289                      cache))))))
290
291 (defun update-slots-in-pv (wrappers pv cwrapper pv-size pv-map)
292   (if (atom wrappers)
293       (when (eq cwrapper wrappers)
294         (dotimes-fixnum (i pv-size)
295           (let ((map (svref pv-map i)))
296             (when map
297               (aver (= (car map) 0))
298               (setf (pvref pv i) (cdr map))))))
299       (when (memq cwrapper wrappers)
300         (let ((param 0))
301           (dolist (wrapper wrappers)
302             (when (eq wrapper cwrapper)
303               (dotimes-fixnum (i pv-size)
304                 (let ((map (svref pv-map i)))
305                   (when (and map (= (car map) param))
306                     (setf (pvref pv i) (cdr map))))))
307             (incf param))))))
308 \f
309 (defun can-optimize-access (form required-parameters env)
310   (let ((type (ecase (car form)
311                 (slot-value 'reader)
312                 (set-slot-value 'writer)
313                 (slot-boundp 'boundp)))
314         (var (cadr form))
315         (slot-name (eval (caddr form)))) ; known to be constant
316     (can-optimize-access1 var required-parameters env type slot-name)))
317
318 ;;; FIXME: This looks like an internal helper function for
319 ;;; CAN-OPTIMIZE-ACCESS, and it is used that way, but it's also called
320 ;;; bare from several places in the code. Perhaps the two functions
321 ;;; should be renamed CAN-OPTIMIZE-ACCESS-FOR-FORM and
322 ;;; CAN-OPTIMIZE-ACCESS-FOR-VAR. If so, I'd just as soon use keyword
323 ;;; args instead of optional ones, too.
324 (defun can-optimize-access1 (var required-parameters env
325                              &optional type slot-name)
326   (when (and (consp var) (eq 'the (car var)))
327     ;; FIXME: We should assert list of length 3 here. Or maybe we
328     ;; should just define EXTRACT-THE, replace the whole
329     ;;   (WHEN ..)
330     ;; form with
331     ;;   (AWHEN (EXTRACT-THE VAR)
332     ;;     (SETF VAR IT))
333     ;; and then use EXTRACT-THE similarly to clean up the other tests
334     ;; against 'THE scattered through the PCL code.
335     (setq var (caddr var)))
336   (when (symbolp var)
337     (let* ((rebound? (caddr (var-declaration '%variable-rebinding var env)))
338            (parameter-or-nil (car (memq (or rebound? var)
339                                         required-parameters))))
340       (when parameter-or-nil
341         (let* ((class-name (caddr (var-declaration '%class
342                                                    parameter-or-nil
343                                                    env)))
344                (class (find-class class-name nil)))
345           (when (or (not (eq *boot-state* 'complete))
346                     (and class (not (class-finalized-p class))))
347             (setq class nil))
348           (when (and class-name (not (eq class-name t)))
349             (when (or (null type)
350                       (not (and class
351                                 (memq *the-class-structure-object*
352                                       (class-precedence-list class))))
353                       (optimize-slot-value-by-class-p class slot-name type))
354               (cons parameter-or-nil (or class class-name)))))))))
355
356 ;;; Check whether the binding of the named variable is modified in the
357 ;;; method body.
358 (defun parameter-modified-p (parameter-name env)
359   (let ((modified-variables (macroexpand '%parameter-binding-modified env)))
360     (memq parameter-name modified-variables)))
361
362 (defun optimize-slot-value (slots sparameter form)
363   (if sparameter
364       (let ((optimized-form
365              (destructuring-bind (ignore1 ignore2 slot-name-form) form
366                (declare (ignore ignore1 ignore2))
367                (let ((slot-name (eval slot-name-form)))
368                  (optimize-instance-access slots :read sparameter
369                                            slot-name nil)))))
370         ;; We don't return the optimized form directly, since there's
371         ;; still a chance that we'll find out later on that the
372         ;; optimization should not have been done, for example due to
373         ;; the walker encountering a SETQ on SPARAMETER later on in
374         ;; the body [ see for example clos.impure.lisp test with :name
375         ;; ((:setq :method-parameter) slot-value)) ]. Instead we defer
376         ;; the decision until the compiler macroexpands
377         ;; OPTIMIZED-SLOT-VALUE.
378         ;;
379         ;; Note that we must still call OPTIMIZE-INSTANCE-ACCESS at
380         ;; this point (instead of when expanding
381         ;; OPTIMIZED-SLOT-VALUE), since it mutates the structure of
382         ;; SLOTS. If that mutation isn't done during the walking,
383         ;; MAKE-METHOD-LAMBDA-INTERNAL won't wrap a correct PV-BINDING
384         ;; form around the body, and compilation will fail.  -- JES,
385         ;; 2006-09-18
386         `(optimized-slot-value ,form ,(car sparameter) ,optimized-form))
387       `(accessor-slot-value ,@(cdr form))))
388
389 (defmacro optimized-slot-value (form parameter-name optimized-form
390                                 &environment env)
391   ;; Either use OPTIMIZED-FORM or fall back to the safe
392   ;; ACCESSOR-SLOT-VALUE.
393   (if (parameter-modified-p parameter-name env)
394       `(accessor-slot-value ,@(cdr form))
395       optimized-form))
396
397 (defun optimize-set-slot-value (slots sparameter form)
398   (if sparameter
399       (let ((optimized-form
400              (destructuring-bind (ignore1 ignore2 slot-name-form new-value) form
401                (declare (ignore ignore1 ignore2))
402                (let ((slot-name (eval slot-name-form)))
403                  (optimize-instance-access slots
404                                            :write
405                                            sparameter
406                                            slot-name
407                                            new-value)))))
408         ;; See OPTIMIZE-SLOT-VALUE
409         `(optimized-set-slot-value ,form ,(car sparameter) ,optimized-form))
410       `(accessor-set-slot-value ,@(cdr form))))
411
412 (defmacro optimized-set-slot-value (form parameter-name optimized-form
413                                     &environment env)
414   (cond ((safe-code-p env)
415          ;; Don't optimize slot value setting in safe code, since the
416          ;; optimized version will fail to catch some type errors
417          ;; (for example when a subclass declares a tighter type for
418          ;; the slot than a superclass).
419          `(safe-set-slot-value ,@(cdr form)))
420         ((parameter-modified-p parameter-name env)
421          `(accessor-set-slot-value ,@(cdr form)))
422         (t
423          optimized-form)))
424
425 (defun optimize-slot-boundp (slots sparameter form)
426   (if sparameter
427       (let ((optimized-form
428              (destructuring-bind
429                    ;; FIXME: In CMU CL ca. 19991205, this binding list
430                    ;; had a fourth element in it, NEW-VALUE. It's hard
431                    ;; to see how that could possibly be right, since
432                    ;; SLOT-BOUNDP has no NEW-VALUE. Since it was
433                    ;; causing a failure in building PCL for SBCL, so I
434                    ;; changed it to match the definition of
435                    ;; SLOT-BOUNDP (and also to match the list used in
436                    ;; the similar OPTIMIZE-SLOT-VALUE,
437                    ;; above). However, I'm weirded out by this, since
438                    ;; this is old code which has worked for ages to
439                    ;; build PCL for CMU CL, so it's hard to see why it
440                    ;; should need a patch like this in order to build
441                    ;; PCL for SBCL. I'd like to return to this and
442                    ;; find a test case which exercises this function
443                    ;; both in CMU CL, to see whether it's really a
444                    ;; previously-unexercised bug or whether I've
445                    ;; misunderstood something (and, presumably,
446                    ;; patched it wrong).
447                    (slot-boundp-symbol instance slot-name-form)
448                  form
449                (declare (ignore slot-boundp-symbol instance))
450                (let ((slot-name (eval slot-name-form)))
451                  (optimize-instance-access slots
452                                            :boundp
453                                            sparameter
454                                            slot-name
455                                            nil)))))
456         ;; See OPTIMIZE-SLOT-VALUE
457         `(optimized-slot-boundp ,form ,(car sparameter) ,optimized-form))
458       `(accessor-slot-boundp ,@(cdr form))))
459
460 (defmacro optimized-slot-boundp (form parameter-name optimized-form
461                                  &environment env)
462   (if (parameter-modified-p parameter-name env)
463       `(accessor-slot-boundp ,@(cdr form))
464       optimized-form))
465
466 ;;; The SLOTS argument is an alist, the CAR of each entry is the name
467 ;;; of a required parameter to the function. The alist is in order, so
468 ;;; the position of an entry in the alist corresponds to the
469 ;;; argument's position in the lambda list.
470 (defun optimize-instance-access (slots
471                                  read/write
472                                  sparameter
473                                  slot-name
474                                  new-value)
475   (let ((class (if (consp sparameter) (cdr sparameter) *the-class-t*))
476         (parameter (if (consp sparameter) (car sparameter) sparameter)))
477     (if (and (eq *boot-state* 'complete)
478              (classp class)
479              (memq *the-class-structure-object* (class-precedence-list class)))
480         (let ((slotd (find-slot-definition class slot-name)))
481           (ecase read/write
482             (:read
483              `(,(slot-definition-defstruct-accessor-symbol slotd) ,parameter))
484             (:write
485              `(setf (,(slot-definition-defstruct-accessor-symbol slotd)
486                      ,parameter)
487                     ,new-value))
488             (:boundp
489              t)))
490         (let* ((parameter-entry (assq parameter slots))
491                (slot-entry      (assq slot-name (cdr parameter-entry)))
492                (position (posq parameter-entry slots))
493                (pv-offset-form (list 'pv-offset ''.PV-OFFSET.)))
494           (unless parameter-entry
495             (bug "slot optimization bewilderment: O-I-A"))
496           (unless slot-entry
497             (setq slot-entry (list slot-name))
498             (push slot-entry (cdr parameter-entry)))
499           (push pv-offset-form (cdr slot-entry))
500           (ecase read/write
501             (:read
502              `(instance-read ,pv-offset-form ,parameter ,position
503                              ',slot-name ',class))
504             (:write
505              `(let ((.new-value. ,new-value))
506                 (instance-write ,pv-offset-form ,parameter ,position
507                                 ',slot-name ',class .new-value.)))
508             (:boundp
509              `(instance-boundp ,pv-offset-form ,parameter ,position
510                                ',slot-name ',class)))))))
511
512 (define-walker-template pv-offset) ; These forms get munged by mutate slots.
513 (defmacro pv-offset (arg) arg)
514 (define-walker-template instance-accessor-parameter)
515 (defmacro instance-accessor-parameter (x) x)
516
517 ;;; It is safe for these two functions to be wrong. They just try to
518 ;;; guess what the most likely case will be.
519 (defun generate-fast-class-slot-access-p (class-form slot-name-form)
520   (let ((class (and (constantp class-form) (constant-form-value class-form)))
521         (slot-name (and (constantp slot-name-form)
522                         (constant-form-value slot-name-form))))
523     (and (eq *boot-state* 'complete)
524          (standard-class-p class)
525          (not (eq class *the-class-t*)) ; shouldn't happen, though.
526          (let ((slotd (find-slot-definition class slot-name)))
527            (and slotd (eq :class (slot-definition-allocation slotd)))))))
528
529 (defun skip-fast-slot-access-p (class-form slot-name-form type)
530   (let ((class (and (constantp class-form) (constant-form-value class-form)))
531         (slot-name (and (constantp slot-name-form)
532                         (constant-form-value slot-name-form))))
533     (and (eq *boot-state* 'complete)
534          (standard-class-p class)
535          (not (eq class *the-class-t*)) ; shouldn't happen, though.
536          (let ((slotd (find-slot-definition class slot-name)))
537            (and slotd (skip-optimize-slot-value-by-class-p class
538                                                            slot-name
539                                                            type))))))
540
541 (defun skip-optimize-slot-value-by-class-p (class slot-name type)
542   (let ((slotd (find-slot-definition class slot-name)))
543     (and slotd
544          (eq *boot-state* 'complete)
545          (not (slot-accessor-std-p slotd type)))))
546
547 (defmacro instance-read-internal (pv slots pv-offset default &optional kind)
548   (unless (member kind '(nil :instance :class :default))
549     (error "illegal kind argument to ~S: ~S" 'instance-read-internal kind))
550   (if (eq kind :default)
551       default
552       (let* ((index (gensym))
553              (value index))
554         `(locally (declare #.*optimize-speed*)
555           (let ((,index (pvref ,pv ,pv-offset)))
556             (setq ,value (typecase ,index
557                            ;; FIXME: the line marked by KLUDGE below
558                            ;; (and the analogous spot in
559                            ;; INSTANCE-WRITE-INTERNAL) is there purely
560                            ;; to suppress a type mismatch warning that
561                            ;; propagates through to user code.
562                            ;; Presumably SLOTS at this point can never
563                            ;; actually be NIL, but the compiler seems
564                            ;; to think it could, so we put this here
565                            ;; to shut it up.  (see also mail Rudi
566                            ;; Schlatte sbcl-devel 2003-09-21) -- CSR,
567                            ;; 2003-11-30
568                            ,@(when (or (null kind) (eq kind :instance))
569                                `((fixnum
570                                   (and ,slots ; KLUDGE
571                                    (clos-slots-ref ,slots ,index)))))
572                            ,@(when (or (null kind) (eq kind :class))
573                                `((cons (cdr ,index))))
574                            (t +slot-unbound+)))
575             (if (eq ,value +slot-unbound+)
576                 ,default
577                 ,value))))))
578
579 (defmacro instance-read (pv-offset parameter position slot-name class)
580   (if (skip-fast-slot-access-p class slot-name 'reader)
581       `(accessor-slot-value ,parameter ,slot-name)
582       `(instance-read-internal .pv. ,(slot-vector-symbol position)
583         ,pv-offset (accessor-slot-value ,parameter ,slot-name)
584         ,(if (generate-fast-class-slot-access-p class slot-name)
585              :class :instance))))
586
587 (defmacro instance-write-internal (pv slots pv-offset new-value default
588                                       &optional kind)
589   (unless (member kind '(nil :instance :class :default))
590     (error "illegal kind argument to ~S: ~S" 'instance-write-internal kind))
591   (if (eq kind :default)
592       default
593       (let* ((index (gensym)))
594         `(locally (declare #.*optimize-speed*)
595           (let ((,index (pvref ,pv ,pv-offset)))
596             (typecase ,index
597               ,@(when (or (null kind) (eq kind :instance))
598                   `((fixnum (and ,slots
599                              (setf (clos-slots-ref ,slots ,index)
600                                    ,new-value)))))
601               ,@(when (or (null kind) (eq kind :class))
602                   `((cons (setf (cdr ,index) ,new-value))))
603               (t ,default)))))))
604
605 (defmacro instance-write (pv-offset
606                           parameter
607                           position
608                           slot-name
609                           class
610                           new-value)
611   (if (skip-fast-slot-access-p class slot-name 'writer)
612       `(accessor-set-slot-value ,parameter ,slot-name ,new-value)
613       `(instance-write-internal .pv. ,(slot-vector-symbol position)
614         ,pv-offset ,new-value
615         (accessor-set-slot-value ,parameter ,slot-name ,new-value)
616         ,(if (generate-fast-class-slot-access-p class slot-name)
617              :class :instance))))
618
619 (defmacro instance-boundp-internal (pv slots pv-offset default
620                                        &optional kind)
621   (unless (member kind '(nil :instance :class :default))
622     (error "illegal kind argument to ~S: ~S" 'instance-boundp-internal kind))
623   (if (eq kind :default)
624       default
625       (let* ((index (gensym)))
626         `(locally (declare #.*optimize-speed*)
627           (let ((,index (pvref ,pv ,pv-offset)))
628             (typecase ,index
629               ,@(when (or (null kind) (eq kind :instance))
630                   `((fixnum (not (and ,slots
631                                       (eq (clos-slots-ref ,slots ,index)
632                                           +slot-unbound+))))))
633               ,@(when (or (null kind) (eq kind :class))
634                   `((cons (not (eq (cdr ,index) +slot-unbound+)))))
635               (t ,default)))))))
636
637 (defmacro instance-boundp (pv-offset parameter position slot-name class)
638   (if (skip-fast-slot-access-p class slot-name 'boundp)
639       `(accessor-slot-boundp ,parameter ,slot-name)
640       `(instance-boundp-internal .pv. ,(slot-vector-symbol position)
641         ,pv-offset (accessor-slot-boundp ,parameter ,slot-name)
642         ,(if (generate-fast-class-slot-access-p class slot-name)
643              :class :instance))))
644
645 ;;; This magic function has quite a job to do indeed.
646 ;;;
647 ;;; The careful reader will recall that <slots> contains all of the
648 ;;; optimized slot access forms produced by OPTIMIZE-INSTANCE-ACCESS.
649 ;;; Each of these is a call to either INSTANCE-READ or INSTANCE-WRITE.
650 ;;;
651 ;;; At the time these calls were produced, the first argument was
652 ;;; specified as the symbol .PV-OFFSET.; what we have to do now is
653 ;;; convert those pv-offset arguments into the actual number that is
654 ;;; the correct offset into the pv.
655 ;;;
656 ;;; But first, oh but first, we sort <slots> a bit so that for each
657 ;;; argument we have the slots in alphabetical order. This
658 ;;; canonicalizes the PV-TABLE's a bit and will hopefully lead to
659 ;;; having fewer PV's floating around. Even if the gain is only
660 ;;; modest, it costs nothing.
661 (defun slot-name-lists-from-slots (slots calls)
662   (multiple-value-bind (slots calls) (mutate-slots-and-calls slots calls)
663     (let* ((slot-name-lists
664             (mapcar (lambda (parameter-entry)
665                       (cons nil (mapcar #'car (cdr parameter-entry))))
666                     slots))
667            (call-list
668             (mapcar #'car calls)))
669       (dolist (call call-list)
670         (dolist (arg (cdr call))
671           (when (integerp arg)
672             (setf (car (nth arg slot-name-lists)) t))))
673       (setq slot-name-lists (mapcar (lambda (r+snl)
674                                       (when (or (car r+snl) (cdr r+snl))
675                                         r+snl))
676                                     slot-name-lists))
677       (let ((cvt (apply #'vector
678                         (let ((i -1))
679                           (mapcar (lambda (r+snl)
680                                     (when r+snl (incf i)))
681                                   slot-name-lists)))))
682         (setq call-list (mapcar (lambda (call)
683                                   (cons (car call)
684                                         (mapcar (lambda (arg)
685                                                   (if (integerp arg)
686                                                       (svref cvt arg)
687                                                       arg))
688                                                 (cdr call))))
689                                 call-list)))
690       (values slot-name-lists call-list))))
691
692 (defun mutate-slots-and-calls (slots calls)
693   (let ((sorted-slots (sort-slots slots))
694         (sorted-calls (sort-calls (cdr calls)))
695         (pv-offset -1))
696     (dolist (parameter-entry sorted-slots)
697       (dolist (slot-entry (cdr parameter-entry))
698         (incf pv-offset)
699         (dolist (form (cdr slot-entry))
700           (setf (cadr form) pv-offset))))
701     (dolist (call-entry sorted-calls)
702       (incf pv-offset)
703       (dolist (form (cdr call-entry))
704         (setf (cadr form) pv-offset)))
705     (values sorted-slots sorted-calls)))
706
707 (defun symbol-pkg-name (sym)
708   (let ((pkg (symbol-package sym)))
709     (if pkg (package-name pkg) "")))
710
711 ;;; FIXME: Because of the existence of UNINTERN and RENAME-PACKAGE,
712 ;;; the part of this ordering which is based on SYMBOL-PKG-NAME is not
713 ;;; stable. This ordering is only used in to
714 ;;; SLOT-NAME-LISTS-FROM-SLOTS, where it serves to "canonicalize the
715 ;;; PV-TABLE's a bit and will hopefully lead to having fewer PV's
716 ;;; floating around", so it sounds as though the instability won't
717 ;;; actually lead to bugs, just small inefficiency. But still, it
718 ;;; would be better to reimplement this function as a comparison based
719 ;;; on SYMBOL-HASH:
720 ;;;   * stable comparison
721 ;;;   * smaller code (here, and in being able to discard SYMBOL-PKG-NAME)
722 ;;;   * faster code.
723 (defun symbol-lessp (a b)
724   (if (eq (symbol-package a)
725           (symbol-package b))
726       (string-lessp (symbol-name a)
727                     (symbol-name b))
728       (string-lessp (symbol-pkg-name a)
729                     (symbol-pkg-name b))))
730
731 (defun symbol-or-cons-lessp (a b)
732   (etypecase a
733     (symbol (etypecase b
734               (symbol (symbol-lessp a b))
735               (cons t)))
736     (cons   (etypecase b
737               (symbol nil)
738               (cons (if (eq (car a) (car b))
739                         (symbol-or-cons-lessp (cdr a) (cdr b))
740                         (symbol-or-cons-lessp (car a) (car b))))))))
741
742 (defun sort-slots (slots)
743   (mapcar (lambda (parameter-entry)
744             (cons (car parameter-entry)
745                   (sort (cdr parameter-entry)   ;slot entries
746                         #'symbol-or-cons-lessp
747                         :key #'car)))
748           slots))
749
750 (defun sort-calls (calls)
751   (sort calls #'symbol-or-cons-lessp :key #'car))
752 \f
753 ;;;; This needs to work in terms of metatypes and also needs to work
754 ;;;; for automatically generated reader and writer functions.
755 ;;;; Automatically generated reader and writer functions use this
756 ;;;; stuff too.
757
758 (defmacro pv-binding ((required-parameters slot-name-lists pv-table-form)
759                       &body body)
760   (let (slot-vars pv-parameters)
761     (loop for slots in slot-name-lists
762           for required-parameter in required-parameters
763           for i from 0
764           do (when slots
765                (push required-parameter pv-parameters)
766                (push (slot-vector-symbol i) slot-vars)))
767     `(pv-binding1 (.pv. .calls. ,pv-table-form
768                    ,(nreverse pv-parameters) ,(nreverse slot-vars))
769        ,@body)))
770
771 (defmacro pv-binding1 ((pv calls pv-table-form pv-parameters slot-vars)
772                        &body body)
773   `(pv-env (,pv ,calls ,pv-table-form ,pv-parameters)
774      (let (,@(mapcar (lambda (slot-var p) `(,slot-var (get-slots-or-nil ,p)))
775                      slot-vars pv-parameters))
776        (declare (ignorable ,@(mapcar #'identity slot-vars)))
777        ,@body)))
778
779 ;;; This will only be visible in PV-ENV when the default MAKE-METHOD-LAMBDA is
780 ;;; overridden.
781 (define-symbol-macro pv-env-environment overridden)
782
783 (defmacro pv-env (&environment env
784                   (pv calls pv-table-form pv-parameters)
785                   &rest forms)
786   ;; Decide which expansion to use based on the state of the PV-ENV-ENVIRONMENT
787   ;; symbol-macrolet.
788   (if (eq (macroexpand 'pv-env-environment env) 'default)
789       `(let ((,pv (car .pv-cell.))
790              (,calls (cdr .pv-cell.)))
791          (declare ,(make-pv-type-declaration pv)
792                   ,(make-calls-type-declaration calls))
793          ,pv ,calls
794          ,@forms)
795       `(let* ((.pv-table. ,pv-table-form)
796               (.pv-cell. (pv-table-lookup-pv-args .pv-table. ,@pv-parameters))
797               (,pv (car .pv-cell.))
798               (,calls (cdr .pv-cell.)))
799         (declare ,(make-pv-type-declaration pv))
800         (declare ,(make-calls-type-declaration calls))
801         ,pv ,calls
802         ,@forms)))
803
804 (defvar *non-var-declarations*
805   ;; FIXME: VALUES was in this list, conditionalized with #+CMU, but I
806   ;; don't *think* CMU CL had, or SBCL has, VALUES declarations. If
807   ;; SBCL doesn't have 'em, VALUES should probably be removed from
808   ;; this list.
809   '(values
810     %method-name
811     %method-lambda-list
812     optimize
813     ftype
814     inline
815     notinline))
816
817 (defvar *var-declarations-with-arg*
818   '(%class
819     type))
820
821 (defvar *var-declarations-without-arg*
822   '(ignore
823     ignorable special dynamic-extent
824     ;; FIXME: Possibly this entire list and variable could go away.
825     ;; If not, certainly we should remove all these built-in typenames
826     ;; from the list, and replace them with a test for "is it a type
827     ;; name?" (CLTL1 allowed only built-in type names as declarations,
828     ;; but ANSI CL allows any type name as a declaration.)
829     array atom base-char bignum bit bit-vector character compiled-function
830     complex cons double-float extended-char
831     fixnum float function hash-table integer
832     keyword list long-float nil null number package pathname random-state ratio
833     rational readtable sequence short-float signed-byte simple-array
834     simple-bit-vector simple-string simple-vector single-float standard-char
835     stream string symbol t unsigned-byte vector))
836
837 (defun split-declarations (body args maybe-reads-params-p)
838   (let ((inner-decls nil)
839         (outer-decls nil)
840         decl)
841     (loop (when (null body) (return nil))
842           (setq decl (car body))
843           (unless (and (consp decl)
844                        (eq (car decl) 'declare))
845             (return nil))
846           (dolist (form (cdr decl))
847             (when (consp form)
848               (let ((declaration-name (car form)))
849                 (if (member declaration-name *non-var-declarations*)
850                     (push `(declare ,form) outer-decls)
851                     (let ((arg-p
852                            (member declaration-name
853                                    *var-declarations-with-arg*))
854                           (non-arg-p
855                            (member declaration-name
856                                    *var-declarations-without-arg*))
857                           (dname (list (pop form)))
858                           (inners nil) (outers nil))
859                       (unless (or arg-p non-arg-p)
860                         ;; FIXME: This warning, and perhaps the
861                         ;; various *VAR-DECLARATIONS-FOO* and/or
862                         ;; *NON-VAR-DECLARATIONS* variables,
863                         ;; could probably go away now that we're not
864                         ;; trying to be portable between different
865                         ;; CLTL1 hosts the way PCL was. (Note that to
866                         ;; do this right, we need to be able to handle
867                         ;; user-defined (DECLAIM (DECLARATION FOO))
868                         ;; stuff.)
869                         (warn "The declaration ~S is not understood by ~S.~@
870                                Please put ~S on one of the lists ~S,~%~S, or~%~S.~@
871                         (Assuming it is a variable declaration without argument)."
872                               declaration-name 'split-declarations
873                               declaration-name
874                               '*non-var-declarations*
875                               '*var-declarations-with-arg*
876                               '*var-declarations-without-arg*)
877                         (push declaration-name *var-declarations-without-arg*))
878                       (when arg-p
879                         (setq dname (append dname (list (pop form)))))
880                       (case (car dname)
881                         (%class (push `(declare (,@dname ,@form)) inner-decls))
882                         (t
883                          (dolist (var form)
884                            (if (member var args)
885                                ;; Quietly remove IGNORE declarations
886                                ;; on args when a next-method is
887                                ;; involved, to prevent compiler
888                                ;; warnings about ignored args being
889                                ;; read.
890                                (unless (and maybe-reads-params-p
891                                             (eq (car dname) 'ignore))
892                                  (push var outers))
893                                (push var inners)))
894                          (when outers
895                            (push `(declare (,@dname ,@outers)) outer-decls))
896                          (when inners
897                            (push
898                             `(declare (,@dname ,@inners))
899                             inner-decls)))))))))
900           (setq body (cdr body)))
901     (values outer-decls inner-decls body)))
902
903 ;;; Pull a name out of the %METHOD-NAME declaration in the function
904 ;;; body given, or return NIL if no %METHOD-NAME declaration is found.
905 (defun body-method-name (body)
906   (multiple-value-bind (real-body declarations documentation)
907       (parse-body body)
908     (declare (ignore real-body documentation))
909     (let ((name-decl (get-declaration '%method-name declarations)))
910       (and name-decl
911            (destructuring-bind (name) name-decl
912              name)))))
913
914 ;;; Convert a lambda expression containing a SB-PCL::%METHOD-NAME
915 ;;; declaration (which is a naming style internal to PCL) into an
916 ;;; SB-INT:NAMED-LAMBDA expression (which is a naming style used
917 ;;; throughout SBCL, understood by the main compiler); or if there's
918 ;;; no SB-PCL::%METHOD-NAME declaration, then just return the original
919 ;;; lambda expression.
920 (defun name-method-lambda (method-lambda)
921   (let ((method-name (body-method-name (cddr method-lambda))))
922     (if method-name
923         `(named-lambda (slow-method ,method-name) ,(rest method-lambda))
924         method-lambda)))
925
926 (defun make-method-initargs-form-internal (method-lambda initargs env)
927   (declare (ignore env))
928   (let (method-lambda-args
929         lmf ; becomes body of function
930         lmf-params)
931     (if (not (and (= 3 (length method-lambda))
932                   (= 2 (length (setq method-lambda-args (cadr method-lambda))))
933                   (consp (setq lmf (third method-lambda)))
934                   (eq 'simple-lexical-method-functions (car lmf))
935                   (eq (car method-lambda-args)
936                       (cadr (setq lmf-params (cadr lmf))))
937                   (eq (cadr method-lambda-args)
938                       (caddr lmf-params))))
939         `(list* :function ,(name-method-lambda method-lambda)
940                 ',initargs)
941         (let* ((lambda-list (car lmf-params))
942                (nreq 0)
943                (restp nil)
944                (args nil))
945           (dolist (arg lambda-list)
946             (when (member arg '(&optional &rest &key))
947               (setq restp t)
948               (return nil))
949             (when (eq arg '&aux)
950               (return nil))
951             (incf nreq)
952             (push arg args))
953           (setq args (nreverse args))
954           (setf (getf (getf initargs 'plist) :arg-info) (cons nreq restp))
955           (make-method-initargs-form-internal1
956            initargs (cddr lmf) args lmf-params restp)))))
957
958 (defun lambda-list-parameter-names (lambda-list)
959   ;; Given a valid lambda list, extract the parameter names.
960   (loop for x in lambda-list
961         with res = nil
962         do (unless (member x lambda-list-keywords)
963              (if (consp x)
964                  (let ((name (car x)))
965                    (if (consp name)
966                        ;; ... ((:BAR FOO) 1)
967                        (push (second name) res)
968                        ;; ... (FOO 1)
969                        (push name res))
970                    ;; ... (... 1 FOO-P)
971                    (let ((name-p (cddr x)))
972                      (when name-p
973                        (push (car name-p) res))))
974                  ;; ... FOO
975                  (push x res)))
976         finally (return res)))
977
978 (defun make-method-initargs-form-internal1
979     (initargs body req-args lmf-params restp)
980   (let* (;; The lambda-list of the method, minus specifiers
981          (lambda-list (car lmf-params))
982          ;; Names of the parameters that will be in the outermost lambda-list
983          ;; (and whose bound declarations thus need to be in OUTER-DECLS).
984          (outer-parameters req-args)
985          ;; The lambda-list used by BIND-ARGS
986          (bind-list lambda-list)
987          (setq-p (getf (cdr lmf-params) :setq-p))
988          (auxp (member '&aux bind-list))
989          (call-next-method-p (getf (cdr lmf-params) :call-next-method-p)))
990     ;; Try to use the normal function call machinery instead of BIND-ARGS
991     ;; binding the arguments, unless:
992     (unless (or ;; If all arguments are required, BIND-ARGS will be a no-op
993                 ;; in any case.
994                 (and (not restp) (not auxp))
995                 ;; CALL-NEXT-METHOD wants to use BIND-ARGS, and needs a
996                 ;; list of all non-required arguments.
997                 call-next-method-p)
998       (setf ;; We don't want a binding for .REST-ARG.
999             restp nil
1000             ;; Get all the parameters for declaration parsing
1001             outer-parameters (lambda-list-parameter-names lambda-list)
1002             ;; Ensure that BIND-ARGS won't do anything (since
1003             ;; BIND-LIST won't contain any non-required parameters,
1004             ;; and REQ-ARGS will be of an equal length). We still want
1005             ;; to pass BIND-LIST to FAST-LEXICAL-METHOD-FUNCTIONS so
1006             ;; that BIND-FAST-LEXICAL-METHOD-FUNCTIONS can take care
1007             ;; of rebinding SETQd required arguments around the method
1008             ;; body.
1009             bind-list req-args))
1010     (multiple-value-bind (outer-decls inner-decls body-sans-decls)
1011         (split-declarations
1012          body outer-parameters (or call-next-method-p setq-p))
1013       (let* ((rest-arg (when restp
1014                          '.rest-arg.))
1015              (fmf-lambda-list (if rest-arg
1016                                   (append req-args (list '&rest rest-arg))
1017                                   (if call-next-method-p
1018                                       req-args
1019                                       lambda-list))))
1020         `(list*
1021           :function
1022           (let* ((fmf (,(if (body-method-name body) 'named-lambda 'lambda)
1023                         ,@(when (body-method-name body)
1024                                 ;; function name
1025                                 (list (cons 'fast-method (body-method-name body))))
1026                         ;; The lambda-list of the FMF
1027                         (.pv-cell. .next-method-call. ,@fmf-lambda-list)
1028                         ;; body of the function
1029                         (declare (ignorable .pv-cell. .next-method-call.)
1030                                  (disable-package-locks pv-env-environment))
1031                         ,@outer-decls
1032                         (symbol-macrolet ((pv-env-environment default))
1033                           (fast-lexical-method-functions
1034                               (,bind-list .next-method-call. ,req-args ,rest-arg
1035                                 ,@(cdddr lmf-params))
1036                             ,@inner-decls
1037                             ,@body-sans-decls))))
1038                  (mf (%make-method-function fmf nil)))
1039             (set-funcallable-instance-function
1040              mf (method-function-from-fast-function fmf ',(getf initargs 'plist)))
1041             mf)
1042           ',initargs)))))
1043
1044 ;;; Use arrays and hash tables and the fngen stuff to make this much
1045 ;;; better. It doesn't really matter, though, because a function
1046 ;;; returned by this will get called only when the user explicitly
1047 ;;; funcalls a result of method-function. BUT, this is needed to make
1048 ;;; early methods work.
1049 (defun method-function-from-fast-function (fmf plist)
1050   (declare (type function fmf))
1051   (let* ((method-function nil)
1052          (calls (getf plist :call-list))
1053          (snl (getf plist :slot-name-lists))
1054          (pv-table (when (or calls snl)
1055                      (intern-pv-table :call-list calls :slot-name-lists snl)))
1056          (arg-info (getf plist :arg-info))
1057          (nreq (car arg-info))
1058          (restp (cdr arg-info)))
1059     (setq method-function
1060           (lambda (method-args next-methods)
1061             (let* ((pv-cell (when pv-table
1062                               (get-pv-cell method-args pv-table)))
1063                    (nm (car next-methods))
1064                    (nms (cdr next-methods))
1065                    (nmc (when nm
1066                           (make-method-call
1067                            :function (if (std-instance-p nm)
1068                                          (method-function nm)
1069                                          nm)
1070                            :call-method-args (list nms)))))
1071               (apply fmf pv-cell nmc method-args))))
1072     ;; FIXME: this looks dangerous.
1073     (let* ((fname (%fun-name fmf)))
1074       (when (and fname (eq (car fname) 'fast-method))
1075         (set-fun-name method-function (cons 'slow-method (cdr fname)))))
1076     method-function))
1077
1078 ;;; this is similar to the above, only not quite.  Only called when
1079 ;;; the MOP is heavily involved.  Not quite parallel to
1080 ;;; METHOD-FUNCTION-FROM-FAST-METHOD-FUNCTION, because we can close
1081 ;;; over the actual PV-CELL in this case.
1082 (defun method-function-from-fast-method-call (fmc)
1083   (let* ((fmf (fast-method-call-function fmc))
1084          (pv-cell (fast-method-call-pv-cell fmc))
1085          (arg-info (fast-method-call-arg-info fmc))
1086          (nreq (car arg-info))
1087          (restp (cdr arg-info)))
1088     (lambda (method-args next-methods)
1089       (let* ((nm (car next-methods))
1090              (nms (cdr next-methods))
1091              (nmc (when nm
1092                     (make-method-call
1093                      :function (if (std-instance-p nm)
1094                                    (method-function nm)
1095                                    nm)
1096                      :call-method-args (list nms)))))
1097         (apply fmf pv-cell nmc method-args)))))
1098
1099 (defun get-pv-cell (method-args pv-table)
1100   (let ((pv-wrappers (pv-wrappers-from-all-args pv-table method-args)))
1101     (when pv-wrappers
1102       (pv-table-lookup pv-table pv-wrappers))))
1103
1104 (defun pv-table-lookup-pv-args (pv-table &rest pv-parameters)
1105   (pv-table-lookup pv-table (pv-wrappers-from-pv-args pv-parameters)))
1106
1107 (defun pv-wrappers-from-pv-args (&rest args)
1108   (let (wrappers)
1109     (dolist (arg args (if (cdr wrappers) (nreverse wrappers) (car wrappers)))
1110       (let ((wrapper (wrapper-of arg)))
1111         (push (if (invalid-wrapper-p wrapper)
1112                   (check-wrapper-validity wrapper)
1113                   wrapper)
1114               wrappers)))))
1115
1116 (defun pv-wrappers-from-all-args (pv-table args)
1117   (loop for snl in (pv-table-slot-name-lists pv-table) and arg in args
1118         when snl
1119           collect (wrapper-of arg) into wrappers
1120         finally (return (if (cdr wrappers) wrappers (car wrappers)))))
1121
1122 ;;; Return the subset of WRAPPERS which is used in the cache
1123 ;;; of PV-TABLE.
1124 (defun pv-wrappers-from-all-wrappers (pv-table wrappers)
1125   (loop for snl in (pv-table-slot-name-lists pv-table) and w in wrappers
1126         when snl
1127           collect w into result
1128         finally (return (if (cdr result) result (car result)))))
1129