source: trunk/abcl/src/org/armedbear/lisp/jvm.lisp @ 13114

Last change on this file since 13114 was 13114, checked in by ehuelsmann, 11 years ago

Register each node being created with its parent.
A parent is always part of the same compiland.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 24.6 KB
Line 
1;;; jvm.lisp
2;;;
3;;; Copyright (C) 2003-2008 Peter Graves
4;;; $Id: jvm.lisp 13114 2011-01-01 11:52:26Z ehuelsmann $
5;;;
6;;; This program is free software; you can redistribute it and/or
7;;; modify it under the terms of the GNU General Public License
8;;; as published by the Free Software Foundation; either version 2
9;;; of the License, or (at your option) any later version.
10;;;
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
19;;;
20;;; As a special exception, the copyright holders of this library give you
21;;; permission to link this library with independent modules to produce an
22;;; executable, regardless of the license terms of these independent
23;;; modules, and to copy and distribute the resulting executable under
24;;; terms of your choice, provided that you also meet, for each linked
25;;; independent module, the terms and conditions of the license of that
26;;; module.  An independent module is a module which is not derived from
27;;; or based on this library.  If you modify this library, you may extend
28;;; this exception to your version of the library, but you are not
29;;; obligated to do so.  If you do not wish to do so, delete this
30;;; exception statement from your version.
31
32(in-package "JVM")
33
34(export '(compile-defun *catch-errors* jvm-compile-package
35          derive-compiler-type))
36
37(eval-when (:compile-toplevel :load-toplevel :execute)
38  (require "LOOP")
39  (require "FORMAT")
40  (require "CLOS")
41  (require "PRINT-OBJECT")
42  (require "COMPILER-TYPES")
43  (require "COMPILER-ERROR")
44  (require "KNOWN-FUNCTIONS")
45  (require "DUMP-FORM")
46  (require "JVM-INSTRUCTIONS")
47  (require "JVM-CLASS-FILE")
48  (require "KNOWN-SYMBOLS")
49  (require "JAVA")
50  (require "COMPILER-PASS1")
51  (require "COMPILER-PASS2"))
52
53(defvar *closure-variables* nil)
54
55(defvar *enable-dformat* nil)
56
57#+nil
58(defun dformat (destination control-string &rest args)
59  (when *enable-dformat*
60    (apply #'sys::%format destination control-string args)))
61
62(defmacro dformat (&rest ignored)
63  (declare (ignore ignored)))
64
65(declaim (inline u2 s1 s2))
66
67(defknown u2 (fixnum) cons)
68(defun u2 (n)
69  (declare (optimize speed))
70  (declare (type (unsigned-byte 16) n))
71  (when (not (<= 0 n 65535))
72    (error "u2 argument ~A out of 65k range." n))
73  (list (logand (ash n -8) #xff)
74        (logand n #xff)))
75
76(defknown s1 (fixnum) fixnum)
77(defun s1 (n)
78  (declare (optimize speed))
79  (declare (type (signed-byte 8) n))
80  (when (not (<= -128 n 127))
81    (error "s2 argument ~A out of 16-bit signed range." n))
82  (if (< n 0)
83      (1+ (logxor (- n) #xFF))
84      n))
85
86
87(defknown s2 (fixnum) cons)
88(defun s2 (n)
89  (declare (optimize speed))
90  (declare (type (signed-byte 16) n))
91  (when (not (<= -32768 n 32767))
92    (error "s2 argument ~A out of 16-bit signed range." n))
93  (u2 (if (< n 0) (1+ (logxor (- n) #xFFFF))
94          n)))
95
96
97
98
99
100(defmacro with-saved-compiler-policy (&body body)
101  "Saves compiler policy variables, restoring them after evaluating `body'."
102  `(let ((*speed* *speed*)
103         (*space* *space*)
104         (*safety* *safety*)
105         (*debug* *debug*)
106         (*explain* *explain*)
107         (*inline-declarations* *inline-declarations*))
108     ,@body))
109
110
111
112(defvar *compiler-debug* nil)
113
114(defvar *pool* nil)
115(defvar *static-code* ())
116(defvar *class-file* nil)
117
118(defvar *externalized-objects* nil)
119(defvar *declared-functions* nil)
120
121(defstruct (abcl-class-file (:include class-file)
122                            (:constructor %make-abcl-class-file))
123  pathname ; pathname of output file
124  class-name
125  lambda-name
126  lambda-list ; as advertised
127  static-initializer
128  constructor
129  objects ;; an alist of externalized objects and their field names
130  (functions (make-hash-table :test 'equal)) ;; because of (SETF ...) functions
131  )
132
133(defun class-name-from-filespec (filespec)
134  (let* ((name (pathname-name filespec)))
135    (declare (type string name))
136    (dotimes (i (length name))
137      (declare (type fixnum i))
138      (when (or (char= (char name i) #\-)
139                (char= (char name i) #\Space))
140        (setf (char name i) #\_)))
141    (make-jvm-class-name
142     (concatenate 'string "org.armedbear.lisp." name))))
143
144(defun make-unique-class-name ()
145  "Creates a random class name for use with a `class-file' structure's
146`class' slot."
147  (make-jvm-class-name
148   (concatenate 'string "abcl_"
149                (substitute #\_ #\-
150                            (java:jcall (java:jmethod "java.util.UUID"
151                                                      "toString")
152                                        (java:jstatic "randomUUID"
153                                                      "java.util.UUID"))))))
154
155(defun make-abcl-class-file (&key pathname lambda-name lambda-list)
156  "Creates a `class-file' structure. If `pathname' is non-NIL, it's
157used to derive a class name. If it is NIL, a random one created
158using `make-unique-class-name'."
159  (let* ((class-name (if pathname
160                         (class-name-from-filespec  pathname)
161                         (make-unique-class-name)))
162         (class-file (%make-abcl-class-file :pathname pathname
163                                            :class class-name ; to be finalized
164                                            :class-name class-name
165                                            :lambda-name lambda-name
166                                            :lambda-list lambda-list
167                                            :access-flags '(:public :final))))
168    (when *file-compilation*
169      (let ((source-attribute
170             (make-source-file-attribute
171              :filename (file-namestring *compile-file-truename*))))
172        (class-add-attribute class-file source-attribute)))
173    class-file))
174
175(defmacro with-class-file (class-file &body body)
176  (let ((var (gensym)))
177    `(let* ((,var                   ,class-file)
178            (*class-file*           ,var)
179            (*pool*                 (abcl-class-file-constants ,var))
180            (*externalized-objects* (abcl-class-file-objects ,var))
181            (*declared-functions*   (abcl-class-file-functions ,var)))
182       (progn ,@body)
183       (setf (abcl-class-file-objects ,var)      *externalized-objects*
184             (abcl-class-file-functions ,var)    *declared-functions*))))
185
186(defstruct compiland
187  name
188  lambda-expression
189  arg-vars          ; variables for lambda arguments
190  free-specials     ;
191  arity             ; number of args, or NIL if the number of args can vary.
192  p1-result         ; the parse tree as created in pass 1
193  parent            ; the parent for compilands which defined within another
194  (children 0       ; Number of local functions
195            :type fixnum) ; defined with FLET, LABELS or LAMBDA
196  blocks            ; TAGBODY, PROGV, BLOCK, etc. blocks
197  argument-register
198  closure-register
199  environment-register
200  class-file ; class-file object
201  (%single-valued-p t))
202
203(defknown compiland-single-valued-p (t) t)
204(defun compiland-single-valued-p (compiland)
205  (unless (compiland-parent compiland)
206    (let ((name (compiland-name compiland)))
207      (when name
208        (let ((result-type
209               (or (function-result-type name)
210                   (and (proclaimed-ftype name)
211                        (ftype-result-type (proclaimed-ftype name))))))
212          (when result-type
213            (return-from compiland-single-valued-p
214                         (cond ((eq result-type '*)
215                                nil)
216                               ((atom result-type)
217                                t)
218                               ((eq (%car result-type) 'VALUES)
219                                (= (length result-type) 2))
220                               (t
221                                t))))))))
222  ;; Otherwise...
223  (compiland-%single-valued-p compiland))
224
225(defvar *current-compiland* nil)
226
227(defvar *this-class* nil)
228
229;; All tags visible at the current point of compilation, some of which may not
230;; be in the current compiland.
231(defvar *visible-tags* ())
232
233;; The next available register.
234(defvar *register* 0)
235
236;; Total number of registers allocated.
237(defvar *registers-allocated* 0)
238
239;; Variables visible at the current point of compilation.
240(defvar *visible-variables* nil
241  "All variables visible to the form currently being
242processed, including free specials.")
243
244;; All variables seen so far.
245(defvar *all-variables* nil
246  "All variables in the lexical scope (thus excluding free specials)
247of the compilands being processed (p1: so far; p2: in total).")
248
249;; Undefined variables that we've already warned about.
250(defvar *undefined-variables* nil)
251
252(defvar *dump-variables* nil)
253
254(defun dump-1-variable (variable)
255  (sys::%format t "  ~S special-p = ~S register = ~S binding-reg = ~S index = ~S declared-type = ~S~%"
256           (variable-name variable)
257           (variable-special-p variable)
258           (variable-register variable)
259           (variable-binding-register variable)
260           (variable-index variable)
261           (variable-declared-type variable)))
262
263(defun dump-variables (list caption &optional (force nil))
264  (when (or force *dump-variables*)
265    (write-string caption)
266    (if list
267        (dolist (variable list)
268          (dump-1-variable variable))
269        (sys::%format t "  None.~%"))))
270
271(defstruct (variable-info (:conc-name variable-)
272                          (:constructor make-variable)
273                          (:predicate variable-p))
274  name
275  initform
276  (declared-type :none)
277  (derived-type :none)
278  ignore-p
279  ignorable-p
280  representation
281  special-p     ; indicates whether a variable is special
282  register      ; register number for a local variable
283  binding-register ; register number containing the binding reference
284  index         ; index number for a variable in the argument array
285  closure-index ; index number for a variable in the closure context array
286  environment   ; the environment for the variable, if we're compiling in
287                ; a non-null lexical environment with variables
288    ;; a variable can be either special-p *or* have a register *or*
289    ;; have an index *or* a closure-index *or* an environment
290  (reads 0 :type fixnum)
291  (writes 0 :type fixnum)
292  references
293  (references-allowed-p t) ; NIL if this is a symbol macro in the enclosing
294                           ; lexical environment
295  used-non-locally-p
296  (compiland *current-compiland*)
297  block)
298
299(defstruct (var-ref (:constructor make-var-ref (variable)))
300  ;; The variable this reference refers to. Will be NIL if the VAR-REF has been
301  ;; rewritten to reference a constant value.
302  variable
303  ;; True if the VAR-REF has been rewritten to reference a constant value.
304  constant-p
305  ;; The constant value of this VAR-REF.
306  constant-value)
307
308;; obj can be a symbol or variable
309;; returns variable or nil
310(declaim (ftype (function (t) t) unboxed-fixnum-variable))
311(defun unboxed-fixnum-variable (obj)
312  (cond ((symbolp obj)
313         (let ((variable (find-visible-variable obj)))
314           (if (and variable
315                    (eq (variable-representation variable) :int))
316               variable
317               nil)))
318        ((variable-p obj)
319         (if (eq (variable-representation obj) :int)
320             obj
321             nil))
322        (t
323         nil)))
324
325(defvar *child-p* nil
326  "True for local functions created by FLET, LABELS and (NAMED-)LAMBDA")
327
328(defknown find-variable (symbol list) t)
329(defun find-variable (name variables)
330  (dolist (variable variables)
331    (when (eq name (variable-name variable))
332      (return variable))))
333
334(defknown find-visible-variable (t) t)
335(defun find-visible-variable (name)
336  (dolist (variable *visible-variables*)
337    (when (eq name (variable-name variable))
338      (return variable))))
339
340(defknown allocate-register () (integer 0 65535))
341(defun allocate-register ()
342  (let* ((register *register*)
343         (next-register (1+ register)))
344    (declare (type (unsigned-byte 16) register next-register))
345    (setf *register* next-register)
346    (when (< *registers-allocated* next-register)
347      (setf *registers-allocated* next-register))
348    register))
349
350(defknown allocate-register-pair () (integer 0 65535))
351(defun allocate-register-pair ()
352  (let* ((register *register*)
353         (next-register (+ register 2)))
354    (declare (type (unsigned-byte 16) register next-register))
355    (setf *register* next-register)
356    (when (< *registers-allocated* next-register)
357      (setf *registers-allocated* next-register))
358    register))
359
360(defstruct local-function
361  name
362  definition
363  compiland
364  inline-expansion
365  function    ;; the function loaded through load-compiled-function
366  class-file  ;; the class file structure for this function
367  variable    ;; the variable which contains the loaded compiled function
368              ;; or compiled closure
369  environment ;; the environment in which the function is stored in
370              ;; case of a function from an enclosing lexical environment
371              ;; which itself isn't being compiled
372  (references-allowed-p t) ;;whether a reference to the function CAN be captured
373  (references-needed-p nil) ;;whether a reference to the function NEEDS to be
374          ;;captured, because the function name is used in a
375                            ;;(function ...) form. Obviously implies
376                            ;;references-allowed-p.
377  )
378
379(defvar *local-functions* ())
380
381(defknown find-local-function (t) t)
382(defun find-local-function (name)
383  (dolist (local-function *local-functions* nil)
384    (when (equal name (local-function-name local-function))
385        (return local-function))))
386
387(defvar *using-arg-array* nil)
388(defvar *hairy-arglist-p* nil)
389
390(defstruct node
391  form
392  children
393  (compiland *current-compiland*))
394;; No need for a special constructor: nobody instantiates
395;; nodes directly
396
397(declaim (inline add-node-child))
398(defun add-node-child (parent child)
399  "Add a child node to the `children` list of a parent node,
400if that parent belongs to the same compiland."
401  (when parent
402    (when (eq (node-compiland parent) *current-compiland*)
403      (push child (node-children parent)))))
404
405;; control-transferring blocks: TAGBODY, CATCH, to do: BLOCK
406
407(defstruct (control-transferring-node (:include node))
408  ;; If non-nil, the TAGBODY contains local blocks which "contaminate" the
409  ;; environment, with GO forms in them which target tags in this TAGBODY
410  ;; Non-nil if and only if the block doesn't modify the environment
411  needs-environment-restoration
412  )
413;; No need for a special constructor: nobody instantiates
414;; control-transferring-nodes directly
415
416(defstruct (tagbody-node (:conc-name tagbody-)
417                         (:include control-transferring-node)
418       (:constructor %make-tagbody-node ()))
419  ;; True if a tag in this tagbody is the target of a non-local GO.
420  non-local-go-p
421  ;; Tags in the tagbody form; a list of tag structures
422  tags
423  ;; Contains a variable whose value uniquely identifies the
424  ;; lexical scope from this block, to be used by GO
425  id-variable)
426(defknown make-tagbody-node () t)
427(defun make-tagbody-node ()
428  (let ((block (%make-tagbody-node)))
429    (push block (compiland-blocks *current-compiland*))
430    (add-node-child (car *blocks*) block)
431    block))
432
433(defstruct (catch-node (:conc-name catch-)
434                       (:include control-transferring-node)
435           (:constructor %make-catch-node ()))
436  ;; The catch tag-form is evaluated, meaning we
437  ;; have no predefined value to store here
438  )
439(defknown make-catch-node () t)
440(defun make-catch-node ()
441  (let ((block (%make-catch-node)))
442    (push block (compiland-blocks *current-compiland*))
443    (add-node-child (car *blocks*) block)
444    block))
445
446(defstruct (block-node (:conc-name block-)
447                       (:include control-transferring-node)
448                       (:constructor %make-block-node (name)))
449  name  ;; Block name
450  (exit (gensym))
451  target
452  ;; True if there is a non-local RETURN from this block.
453  non-local-return-p
454  ;; Contains a variable whose value uniquely identifies the
455  ;; lexical scope from this block, to be used by RETURN-FROM
456  id-variable)
457(defknown make-block-node (t) t)
458(defun make-block-node (name)
459  (let ((block (%make-block-node name)))
460    (push block (compiland-blocks *current-compiland*))
461    (add-node-child (car *blocks*) block)
462    block))
463
464;; binding blocks: LET, LET*, FLET, LABELS, M-V-B, PROGV, LOCALLY
465;;
466;; Binding blocks can carry references to local (optionally special) variable bindings,
467;;  contain free special bindings or both
468
469(defstruct (binding-node (:include node))
470  ;; number of the register of the saved dynamic env, or NIL if none
471  environment-register
472  ;; Not used for LOCALLY and FLET; LABELS uses vars to store its functions
473  vars
474  free-specials)
475;; nobody instantiates any binding nodes directly, so there's no reason
476;; to create a constructor with the approprate administration code
477
478(defstruct (let/let*-node (:conc-name let-)
479                          (:include binding-node)
480        (:constructor %make-let/let*-node ())))
481(defknown make-let/let*-node () t)
482(defun make-let/let*-node ()
483  (let ((block (%make-let/let*-node)))
484    (push block (compiland-blocks *current-compiland*))
485    (add-node-child (car *blocks*) block)
486    block))
487
488(defstruct (flet-node (:conc-name flet-)
489                      (:include binding-node)
490          (:constructor %make-flet-node ())))
491(defknown make-flet-node () t)
492(defun make-flet-node ()
493  (let ((block (%make-flet-node)))
494    (push block (compiland-blocks *current-compiland*))
495    (add-node-child (car *blocks*) block)
496    block))
497
498(defstruct (labels-node (:conc-name labels-)
499                        (:include binding-node)
500      (:constructor %make-labels-node ())))
501(defknown make-labels-node () t)
502(defun make-labels-node ()
503  (let ((block (%make-labels-node)))
504    (push block (compiland-blocks *current-compiland*))
505    (add-node-child (car *blocks*) block)
506    block))
507
508(defstruct (m-v-b-node (:conc-name m-v-b-)
509                       (:include binding-node)
510           (:constructor %make-m-v-b-node ())))
511(defknown make-m-v-b-node () t)
512(defun make-m-v-b-node ()
513  (let ((block (%make-m-v-b-node)))
514    (push block (compiland-blocks *current-compiland*))
515    (add-node-child (car *blocks*) block)
516    block))
517
518(defstruct (progv-node (:conc-name progv-)
519                       (:include binding-node)
520           (:constructor %make-progv-node ())))
521(defknown make-progv-node () t)
522(defun make-progv-node ()
523  (let ((block (%make-progv-node)))
524    (push block (compiland-blocks *current-compiland*))
525    block))
526
527(defstruct (locally-node (:conc-name locally-)
528                         (:include binding-node)
529       (:constructor %make-locally-node ())))
530(defknown make-locally-node () t)
531(defun make-locally-node ()
532  (let ((block (%make-locally-node)))
533    (push block (compiland-blocks *current-compiland*))
534    (add-node-child (car *blocks*) block)
535    block))
536
537;; blocks requiring non-local exits: UNWIND-PROTECT, SYS:SYNCHRONIZED-ON
538
539(defstruct (protected-node (:include node)
540         (:constructor %make-protected-node ())))
541(defknown make-protected-node () t)
542(defun make-protected-node ()
543  (let ((block (%make-protected-node)))
544    (push block (compiland-blocks *current-compiland*))
545    (add-node-child (car *blocks*) block)
546    block))
547
548(defstruct (unwind-protect-node (:conc-name unwind-protect-)
549                                (:include protected-node)
550        (:constructor %make-unwind-protect-node ())))
551(defknown make-unwind-protect-node () t)
552(defun make-unwind-protect-node ()
553  (let ((block (%make-unwind-protect-node)))
554    (push block (compiland-blocks *current-compiland*))
555    (add-node-child (car *blocks*) block)
556    block))
557
558(defstruct (synchronized-node (:conc-name synchronized-)
559                              (:include protected-node)
560            (:constructor %make-synchronized-node ())))
561(defknown make-synchronized-node () t)
562(defun make-synchronized-node ()
563  (let ((block (%make-synchronized-node)))
564    (push block (compiland-blocks *current-compiland*))
565    (add-node-child (car *blocks*) block)
566    block))
567
568
569(defvar *blocks* ())
570
571(defun find-block (name)
572  (dolist (block *blocks*)
573    (when (and (block-node-p block)
574               (eq name (block-name block)))
575      (return block))))
576
577(defknown node-constant-p (t) boolean)
578(defun node-constant-p (object)
579  (cond ((node-p object)
580         nil)
581        ((var-ref-p object)
582         nil)
583        ((constantp object)
584         t)
585        (t
586         nil)))
587
588(defknown block-requires-non-local-exit-p (t) boolean)
589(defun block-requires-non-local-exit-p (object)
590  "A block which *always* requires a 'non-local-exit' is a block which
591requires a transfer control exception to be thrown: e.g. Go and Return.
592
593Non-local exits are required by blocks which do more in their cleanup
594than just restore the lastSpecialBinding (= dynamic environment).
595"
596  (or (unwind-protect-node-p object)
597      (catch-node-p object)
598      (synchronized-node-p object)))
599
600(defknown block-creates-runtime-bindings-p (t) boolean)
601(defun block-creates-runtime-bindings-p (block)
602  ;; FIXME: This may be false, if the bindings to be
603  ;; created are a quoted list
604  (progv-node-p block))
605
606(defknown enclosed-by-runtime-bindings-creating-block-p (t) boolean)
607(defun enclosed-by-runtime-bindings-creating-block-p (outermost-block)
608  "Indicates whether the code being compiled/analyzed is enclosed in a
609block which creates special bindings at runtime."
610  (dolist (enclosing-block *blocks*)
611    (when (eq enclosing-block outermost-block)
612      (return-from enclosed-by-runtime-bindings-creating-block-p nil))
613    (when (block-creates-runtime-bindings-p enclosing-block)
614      (return-from enclosed-by-runtime-bindings-creating-block-p t))))
615
616(defknown enclosed-by-protected-block-p (&optional t) boolean)
617(defun enclosed-by-protected-block-p (&optional outermost-block)
618  "Indicates whether the code being compiled/analyzed is enclosed in
619a block which requires a non-local transfer of control exception to
620be generated.
621"
622  (dolist (enclosing-block *blocks*)
623    (when (eq enclosing-block outermost-block)
624      (return-from enclosed-by-protected-block-p nil))
625    (when (block-requires-non-local-exit-p enclosing-block)
626      (return-from enclosed-by-protected-block-p t))))
627
628(defknown enclosed-by-environment-setting-block-p (&optional t) boolean)
629(defun enclosed-by-environment-setting-block-p (&optional outermost-block)
630  (dolist (enclosing-block *blocks*)
631    (when (eq enclosing-block outermost-block)
632      (return nil))
633    (when (and (binding-node-p enclosing-block)
634               (binding-node-environment-register enclosing-block))
635      (return t))))
636
637(defknown environment-register-to-restore (&optional t) t)
638(defun environment-register-to-restore (&optional outermost-block)
639  "Returns the environment register which contains the
640saved environment from the outermost enclosing block:
641
642That's the one which contains the environment used in the outermost block."
643  (flet ((outermost-register (last-register block)
644           (when (eq block outermost-block)
645             (return-from environment-register-to-restore last-register))
646           (or (and (binding-node-p block)
647                    (binding-node-environment-register block))
648               last-register)))
649    (reduce #'outermost-register *blocks*
650            :initial-value nil)))
651
652(defstruct tag
653  ;; The symbol (or integer) naming the tag
654  name
655  ;; The symbol which is the jump target in JVM byte code
656  label
657  ;; The associated TAGBODY
658  block
659  (compiland *current-compiland*)
660  used
661  used-non-locally)
662
663(defknown find-tag (t) t)
664(defun find-tag (name)
665  (dolist (tag *visible-tags*)
666    (when (eql name (tag-name tag))
667      (return tag))))
668
669(defun process-ignore/ignorable (declaration names variables)
670  (when (memq declaration '(IGNORE IGNORABLE))
671    (let ((what (if (eq declaration 'IGNORE) "ignored" "ignorable")))
672      (dolist (name names)
673        (unless (and (consp name) (eq (car name) 'FUNCTION))
674          (let ((variable (find-variable name variables)))
675            (cond ((null variable)
676                   (compiler-style-warn "Declaring unknown variable ~S to be ~A."
677                                        name what))
678                  ((variable-special-p variable)
679                   (compiler-style-warn "Declaring special variable ~S to be ~A."
680                                        name what))
681                  ((eq declaration 'IGNORE)
682                   (setf (variable-ignore-p variable) t))
683                  (t
684                   (setf (variable-ignorable-p variable) t)))))))))
685
686(defun finalize-generic-functions ()
687  (dolist (sym '(make-instance
688                 initialize-instance
689                 shared-initialize))
690    (let ((gf (and (fboundp sym) (fdefinition sym))))
691      (when (typep gf 'generic-function)
692        (unless (compiled-function-p gf)
693          (mop::finalize-generic-function gf))))))
694
695(finalize-generic-functions)
696
697(provide 'jvm)
Note: See TracBrowser for help on using the repository browser.