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

Last change on this file since 14111 was 14111, checked in by ehuelsmann, 9 years ago

Reverse the REQUIREs graph: before, modules would require JVM,
which would require the rest of the compiler. That doesn't work
with the automatic autoloader, because that requires the files
in which symbol function bindings are located.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 27.3 KB
Line 
1;;; jvm.lisp
2;;;
3;;; Copyright (C) 2003-2008 Peter Graves
4;;; $Id: jvm.lisp 14111 2012-08-17 16:02:52Z 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(require "JVM-CLASS-FILE")
38
39(defvar *closure-variables* nil)
40
41(defvar *enable-dformat* nil)
42(defvar *callbacks* nil
43  "A list of functions to be called by the compiler and code generator
44in order to generate 'compilation events'.")
45
46(declaim (inline invoke-callbacks))
47(defun invoke-callbacks (&rest args)
48  (dolist (cb *callbacks*)
49    (apply cb args)))
50
51#+nil
52(defun dformat (destination control-string &rest args)
53  (when *enable-dformat*
54    (apply #'sys::%format destination control-string args)))
55
56(defmacro dformat (&rest ignored)
57  (declare (ignore ignored)))
58
59(defmacro with-saved-compiler-policy (&body body)
60  "Saves compiler policy variables, restoring them after evaluating `body'."
61  `(let ((*speed* *speed*)
62         (*space* *space*)
63         (*safety* *safety*)
64         (*debug* *debug*)
65         (*explain* *explain*)
66         (*inline-declarations* *inline-declarations*))
67     ,@body))
68
69
70
71(defvar *compiler-debug* nil)
72
73(defvar *pool* nil)
74(defvar *static-code* ())
75(defvar *class-file* nil)
76
77(defvar *externalized-objects* nil)
78(defvar *declared-functions* nil)
79
80(defstruct (abcl-class-file (:include class-file)
81                            (:constructor %make-abcl-class-file))
82  pathname ; pathname of output file
83  class-name
84  static-initializer
85  constructor
86  objects ;; an alist of externalized objects and their field names
87  (functions (make-hash-table :test 'equal)) ;; because of (SETF ...) functions
88  )
89
90(defun class-name-from-filespec (filespec)
91  (let* ((name (pathname-name filespec)))
92    (declare (type string name))
93    (dotimes (i (length name))
94      (declare (type fixnum i))
95      (when (or (char= (char name i) #\-)
96                (char= (char name i) #\Space))
97        (setf (char name i) #\_)))
98    (make-jvm-class-name
99     (concatenate 'string "org.armedbear.lisp." name))))
100
101(defun make-unique-class-name ()
102  "Creates a random class name for use with a `class-file' structure's
103`class' slot."
104  (make-jvm-class-name
105   (concatenate 'string "abcl_"
106                (substitute #\_ #\-
107                            (java:jcall (java:jmethod "java.util.UUID"
108                                                      "toString")
109                                        (java:jstatic "randomUUID"
110                                                      "java.util.UUID"))))))
111
112(defun make-abcl-class-file (&key pathname)
113  "Creates a `class-file' structure. If `pathname' is non-NIL, it's
114used to derive a class name. If it is NIL, a random one created
115using `make-unique-class-name'."
116  (let* ((class-name (if pathname
117                         (class-name-from-filespec  pathname)
118                         (make-unique-class-name)))
119         (class-file (%make-abcl-class-file :pathname pathname
120                                            :class class-name ; to be finalized
121                                            :class-name class-name
122                                            :access-flags '(:public :final))))
123    (when *file-compilation*
124      (let ((source-attribute
125             (make-source-file-attribute
126              :filename (file-namestring *compile-file-truename*))))
127        (class-add-attribute class-file source-attribute)))
128    class-file))
129
130(defmacro with-class-file (class-file &body body)
131  (let ((var (gensym)))
132    `(let* ((,var                   ,class-file)
133            (*class-file*           ,var)
134            (*pool*                 (abcl-class-file-constants ,var))
135            (*externalized-objects* (abcl-class-file-objects ,var))
136            (*declared-functions*   (abcl-class-file-functions ,var)))
137       (progn ,@body)
138       (setf (abcl-class-file-objects ,var)      *externalized-objects*
139             (abcl-class-file-functions ,var)    *declared-functions*))))
140
141(defstruct compiland
142  name
143  lambda-expression
144  arg-vars          ; variables for lambda arguments
145  free-specials     ;
146  arity             ; number of args, or NIL if the number of args can vary.
147  p1-result         ; the parse tree as created in pass 1
148  parent            ; the parent for compilands which defined within another
149  children          ; List of local functions
150                    ; defined with FLET, LABELS or LAMBDA
151  blocks            ; TAGBODY, PROGV, BLOCK, etc. blocks
152  (next-resource 0)
153  argument-register
154  closure-register
155  environment-register
156  class-file ; class-file object
157  (%single-valued-p t))
158
159(defknown compiland-single-valued-p (t) t)
160(defun compiland-single-valued-p (compiland)
161  (unless (compiland-parent compiland)
162    (let ((name (compiland-name compiland)))
163      (when name
164        (let ((result-type
165               (or (function-result-type name)
166                   (and (proclaimed-ftype name)
167                        (ftype-result-type (proclaimed-ftype name))))))
168          (when result-type
169            (return-from compiland-single-valued-p
170                         (cond ((eq result-type '*)
171                                nil)
172                               ((atom result-type)
173                                t)
174                               ((eq (%car result-type) 'VALUES)
175                                (= (length result-type) 2))
176                               (t
177                                t))))))))
178  ;; Otherwise...
179  (compiland-%single-valued-p compiland))
180
181(defvar *current-compiland* nil)
182
183(defvar *this-class* nil)
184
185;; All tags visible at the current point of compilation, some of which may not
186;; be in the current compiland.
187(defvar *visible-tags* ())
188
189;; The next available register.
190(defvar *register* 0)
191
192;; Total number of registers allocated.
193(defvar *registers-allocated* 0)
194
195;; Variables visible at the current point of compilation.
196(defvar *visible-variables* nil
197  "All variables visible to the form currently being
198processed, including free specials.")
199
200;; All variables seen so far.
201(defvar *all-variables* nil
202  "All variables in the lexical scope (thus excluding free specials)
203of the compilands being processed (p1: so far; p2: in total).")
204
205;; Undefined variables that we've already warned about.
206(defvar *undefined-variables* nil)
207
208(defvar *dump-variables* nil)
209
210(defun dump-1-variable (variable)
211  (sys::%format t "  ~S special-p = ~S register = ~S binding-reg = ~S index = ~S declared-type = ~S~%"
212           (variable-name variable)
213           (variable-special-p variable)
214           (variable-register variable)
215           (variable-binding-register variable)
216           (variable-index variable)
217           (variable-declared-type variable)))
218
219(defun dump-variables (list caption &optional (force nil))
220  (when (or force *dump-variables*)
221    (write-string caption)
222    (if list
223        (dolist (variable list)
224          (dump-1-variable variable))
225        (sys::%format t "  None.~%"))))
226
227(defstruct (variable-info (:conc-name variable-)
228                          (:constructor make-variable)
229                          (:predicate variable-p))
230  name
231  initform
232  (declared-type :none)
233  (derived-type :none)
234  ignore-p
235  ignorable-p
236  representation
237  special-p     ; indicates whether a variable is special
238
239;; A variable can be stored in a number of locations.
240;;  1. if it's passed as a normal argument, it'll be in a register (max 8)
241;;     the same is true if the variable is a local variable (at any index)
242;;  2. if it's passed in the argument array, it'll be in the array in
243;;     register 1 (register 0 contains the function object)
244;;  3. if the variable is part of a closure, it'll be in the closure array
245;;  4. if the variable is part of the outer scope of a function with a
246;;     non-null lexical environment, the variable is to be looked up
247;;     from a lexical environment object
248;;  5. the variable is a special variable and its binding has been looked
249;;     up and cached in a local register (binding-register)
250
251;; a variable can be either special-p *or* have a register *or*
252;; have an index *or* a closure-index *or* an environment
253
254  register      ; register number for a local variable
255  binding-register ; register number containing the binding reference
256  index         ; index number for a variable in the argument array
257  closure-index ; index number for a variable in the closure context array
258  environment   ; the environment for the variable, if we're compiling in
259                ; a non-null lexical environment with variables
260
261  (reads 0 :type fixnum)
262  (writes 0 :type fixnum)
263  references
264  (references-allowed-p t) ; NIL if this is a symbol macro in the enclosing
265                           ; lexical environment
266  used-non-locally-p
267  (compiland *current-compiland*)
268  block)
269
270(defstruct (var-ref (:constructor make-var-ref (variable)))
271  ;; The variable this reference refers to. Will be NIL if the VAR-REF has been
272  ;; rewritten to reference a constant value.
273  variable
274  ;; True if the VAR-REF has been rewritten to reference a constant value.
275  constant-p
276  ;; The constant value of this VAR-REF.
277  constant-value)
278
279;; obj can be a symbol or variable
280;; returns variable or nil
281(declaim (ftype (function (t) t) unboxed-fixnum-variable))
282(defun unboxed-fixnum-variable (obj)
283  (cond ((symbolp obj)
284         (let ((variable (find-visible-variable obj)))
285           (if (and variable
286                    (eq (variable-representation variable) :int))
287               variable
288               nil)))
289        ((variable-p obj)
290         (if (eq (variable-representation obj) :int)
291             obj
292             nil))
293        (t
294         nil)))
295
296(defvar *child-p* nil
297  "True for local functions created by FLET, LABELS and (NAMED-)LAMBDA")
298
299(defknown find-variable (symbol list) t)
300(defun find-variable (name variables)
301  (dolist (variable variables)
302    (when (eq name (variable-name variable))
303      (return variable))))
304
305(defknown find-visible-variable (t) t)
306(defun find-visible-variable (name)
307  (dolist (variable *visible-variables*)
308    (when (eq name (variable-name variable))
309      (return variable))))
310
311(defknown representation-size (t) (integer 0 65535))
312(defun representation-size (representation)
313  (ecase representation
314    ((NIL :int :boolean :float :char) 1)
315    ((:long :double) 2)))
316
317(defknown allocate-register (t) (integer 0 65535))
318(defun allocate-register (representation)
319  (let ((register *register*))
320    (incf *register* (representation-size representation))
321    (setf *registers-allocated*
322          (max *registers-allocated* *register*))
323    register))
324
325
326(defstruct local-function
327  name
328  definition
329  compiland
330  field
331  inline-expansion
332  environment ;; the environment in which the function is stored in
333              ;; case of a function from an enclosing lexical environment
334              ;; which itself isn't being compiled
335  (references-allowed-p t) ;;whether a reference to the function CAN be captured
336  (references-needed-p nil) ;;whether a reference to the function NEEDS to be
337                            ;;captured, because the function name is used in a
338                            ;;(function ...) form. Obviously implies
339                            ;;references-allowed-p.
340  )
341
342(defvar *local-functions* ())
343
344(defknown find-local-function (t) t)
345(defun find-local-function (name)
346  (dolist (local-function *local-functions* nil)
347    (when (equal name (local-function-name local-function))
348        (return local-function))))
349
350(defvar *using-arg-array* nil)
351(defvar *hairy-arglist-p* nil)
352
353
354(defvar *block* nil
355  "The innermost block applicable to the current lexical environment.")
356(defvar *blocks* ()
357  "The list of blocks in effect in the current lexical environment.
358
359The top node does not need to be equal to the value of `*block*`. E.g.
360when processing the bindings of a LET form, `*block*` is bound to the node
361of that LET, while the block is not considered 'in effect': that only happens
362until the body is being processed.")
363
364(defstruct node
365  form
366  children
367  (compiland *current-compiland*))
368;; No need for a special constructor: nobody instantiates
369;; nodes directly
370
371(declaim (inline add-node-child))
372(defun add-node-child (parent child)
373  "Add a child node to the `children` list of a parent node,
374if that parent belongs to the same compiland."
375  (when parent
376    (when (eq (node-compiland parent) *current-compiland*)
377      (push child (node-children parent)))))
378
379;; control-transferring blocks: TAGBODY, CATCH, to do: BLOCK
380
381(defstruct (control-transferring-node (:include node))
382  ;; If non-nil, the TAGBODY contains local blocks which "contaminate" the
383  ;; environment, with GO forms in them which target tags in this TAGBODY
384  ;; Non-nil if and only if the block doesn't modify the environment
385  needs-environment-restoration
386  )
387;; No need for a special constructor: nobody instantiates
388;; control-transferring-nodes directly
389
390(defstruct (tagbody-node (:conc-name tagbody-)
391                         (:include control-transferring-node)
392                         (:constructor %make-tagbody-node ()))
393  ;; True if a tag in this tagbody is the target of a non-local GO.
394  non-local-go-p
395  ;; Tags in the tagbody form; a list of tag structures
396  tags
397  ;; Contains a variable whose value uniquely identifies the
398  ;; lexical scope from this block, to be used by GO
399  id-variable)
400(defknown make-tagbody-node () t)
401(defun make-tagbody-node ()
402  (let ((block (%make-tagbody-node)))
403    (push block (compiland-blocks *current-compiland*))
404    (add-node-child *block* block)
405    block))
406
407(defstruct (catch-node (:conc-name catch-)
408                       (:include control-transferring-node)
409                       (:constructor %make-catch-node ()))
410  ;; The catch tag-form is evaluated, meaning we
411  ;; have no predefined value to store here
412  )
413(defknown make-catch-node () t)
414(defun make-catch-node ()
415  (let ((block (%make-catch-node)))
416    (push block (compiland-blocks *current-compiland*))
417    (add-node-child *block* block)
418    block))
419
420(defstruct (block-node (:conc-name block-)
421                       (:include control-transferring-node)
422                       (:constructor %make-block-node (name)))
423  name  ;; Block name
424  (exit (gensym))
425  target
426  ;; True if there is a non-local RETURN from this block.
427  non-local-return-p
428  ;; Contains a variable whose value uniquely identifies the
429  ;; lexical scope from this block, to be used by RETURN-FROM
430  id-variable
431  ;; A list of all RETURN-FROM value forms associated with this block
432  return-value-forms)
433
434(defknown make-block-node (t) t)
435(defun make-block-node (name)
436  (let ((block (%make-block-node name)))
437    (push block (compiland-blocks *current-compiland*))
438    (add-node-child *block* block)
439    block))
440
441(defstruct (jump-node (:conc-name jump-)
442                      (:include node)
443                      (:constructor
444                       %make-jump-node (non-local-p target-block target-tag)))
445  non-local-p
446  target-block
447  target-tag)
448(defun make-jump-node (form non-local-p target-block &optional target-tag)
449  (let ((node (%make-jump-node non-local-p target-block target-tag)))
450    ;; Don't push into compiland blocks, as this as a node rather than a block
451    (setf (node-form node) form)
452    (add-node-child *block* node)
453    node))
454
455
456;; binding blocks: LET, LET*, FLET, LABELS, M-V-B, PROGV, LOCALLY
457;;
458;; Binding blocks can carry references to local (optionally special) variable bindings,
459;;  contain free special bindings or both
460
461(defstruct (binding-node (:include node))
462  ;; number of the register of the saved dynamic env, or NIL if none
463  environment-register
464  ;; Not used for LOCALLY and FLET; LABELS uses vars to store its functions
465  vars
466  free-specials)
467;; nobody instantiates any binding nodes directly, so there's no reason
468;; to create a constructor with the approprate administration code
469
470(defstruct (let/let*-node (:conc-name let-)
471                          (:include binding-node)
472                          (:constructor %make-let/let*-node ())))
473(defknown make-let/let*-node () t)
474(defun make-let/let*-node ()
475  (let ((block (%make-let/let*-node)))
476    (push block (compiland-blocks *current-compiland*))
477    (add-node-child *block* block)
478    block))
479
480(defstruct (flet-node (:conc-name flet-)
481                      (:include binding-node)
482                      (:constructor %make-flet-node ())))
483(defknown make-flet-node () t)
484(defun make-flet-node ()
485  (let ((block (%make-flet-node)))
486    (push block (compiland-blocks *current-compiland*))
487    (add-node-child *block* block)
488    block))
489
490(defstruct (labels-node (:conc-name labels-)
491                        (:include binding-node)
492                        (:constructor %make-labels-node ())))
493(defknown make-labels-node () t)
494(defun make-labels-node ()
495  (let ((block (%make-labels-node)))
496    (push block (compiland-blocks *current-compiland*))
497    (add-node-child *block* block)
498    block))
499
500(defstruct (m-v-b-node (:conc-name m-v-b-)
501                       (:include binding-node)
502                       (:constructor %make-m-v-b-node ())))
503(defknown make-m-v-b-node () t)
504(defun make-m-v-b-node ()
505  (let ((block (%make-m-v-b-node)))
506    (push block (compiland-blocks *current-compiland*))
507    (add-node-child *block* block)
508    block))
509
510(defstruct (progv-node (:conc-name progv-)
511                       (:include binding-node)
512                       (:constructor %make-progv-node ())))
513(defknown make-progv-node () t)
514(defun make-progv-node ()
515  (let ((block (%make-progv-node)))
516    (push block (compiland-blocks *current-compiland*))
517    block))
518
519(defstruct (locally-node (:conc-name locally-)
520                         (:include binding-node)
521                         (:constructor %make-locally-node ())))
522(defknown make-locally-node () t)
523(defun make-locally-node ()
524  (let ((block (%make-locally-node)))
525    (push block (compiland-blocks *current-compiland*))
526    (add-node-child *block* block)
527    block))
528
529;; blocks requiring non-local exits: UNWIND-PROTECT, SYS:SYNCHRONIZED-ON
530
531(defstruct (protected-node (:include node)
532                           (:constructor %make-protected-node ())))
533(defknown make-protected-node () t)
534(defun make-protected-node ()
535  (let ((block (%make-protected-node)))
536    (push block (compiland-blocks *current-compiland*))
537    (add-node-child *block* block)
538    block))
539
540(defstruct (unwind-protect-node (:conc-name unwind-protect-)
541                                (:include protected-node)
542                                (:constructor %make-unwind-protect-node ())))
543(defknown make-unwind-protect-node () t)
544(defun make-unwind-protect-node ()
545  (let ((block (%make-unwind-protect-node)))
546    (push block (compiland-blocks *current-compiland*))
547    (add-node-child *block* block)
548    block))
549
550(defstruct (synchronized-node (:conc-name synchronized-)
551                              (:include protected-node)
552                              (:constructor %make-synchronized-node ())))
553(defknown make-synchronized-node () t)
554(defun make-synchronized-node ()
555  (let ((block (%make-synchronized-node)))
556    (push block (compiland-blocks *current-compiland*))
557    (add-node-child *block* block)
558    block))
559
560(defun find-block (name)
561  (dolist (block *blocks*)
562    (when (and (block-node-p block)
563               (eq name (block-name block)))
564      (return block))))
565
566(defun %find-enclosed-blocks (form traversed-blocks)
567  "Helper function for `find-enclosed-blocks`, implementing the actual
568algorithm specified there.
569`traversed-blocks' prevents traversal of recursive structures."
570  (cond
571   ((node-p form) (list form))
572   ((atom form) nil)
573   (t
574    ;; We can't use MAPCAN or DOLIST here: they'll choke on dotted lists
575    (do* ((tail form (cdr tail))
576          (current-block (if (consp tail)
577                             (car tail) tail)
578                         (if (consp tail)
579                             (car tail) tail))
580          blocks)
581         ((null tail) blocks)
582      (unless (gethash current-block traversed-blocks)
583        (setf (gethash current-block traversed-blocks) t)
584        (setf blocks
585              (nconc (%find-enclosed-blocks current-block
586                                            traversed-blocks)
587                     blocks)))
588      (when (not (listp tail))
589        (return blocks))))))
590
591(defun find-enclosed-blocks (form)
592  "Returns the immediate enclosed blocks by searching the form's subforms.
593
594More deeply nested blocks can be reached through the `node-children`
595field of the immediate enclosed blocks."
596  (when *blocks*
597    ;; when the innermost enclosing block doesn't have node-children,
598    ;;  there's really nothing to search for.
599    (let ((first-enclosing-block (car *blocks*)))
600      (when (and (eq *current-compiland*
601                     (node-compiland first-enclosing-block))
602                 (null (node-children first-enclosing-block)))
603        (return-from find-enclosed-blocks))))
604
605  (%find-enclosed-blocks form (make-hash-table :test 'eq)))
606
607
608(defun some-nested-block (predicate blocks)
609  "Applies `predicate` recursively to the `blocks` and its children,
610until predicate returns non-NIL, returning that value.
611
612`blocks` may be a single block or a list of blocks."
613  (when blocks
614    (some #'(lambda (b)
615              (or (funcall predicate b)
616                  (some-nested-block predicate (node-children b))))
617          (if (listp blocks)
618              blocks
619            (list blocks)))))
620
621(defknown node-constant-p (t) boolean)
622(defun node-constant-p (object)
623  (cond ((node-p object)
624         nil)
625        ((var-ref-p object)
626         nil)
627        ((constantp object)
628         t)
629        (t
630         nil)))
631
632(defknown block-requires-non-local-exit-p (t) boolean)
633(defun block-requires-non-local-exit-p (object)
634  "A block which *always* requires a 'non-local-exit' is a block which
635requires a transfer control exception to be thrown: e.g. Go and Return.
636
637Non-local exits are required by blocks which do more in their cleanup
638than just restore the lastSpecialBinding (= dynamic environment).
639"
640  (or (unwind-protect-node-p object)
641      (catch-node-p object)
642      (synchronized-node-p object)))
643
644(defun node-opstack-unsafe-p (node)
645  (or (when (jump-node-p node)
646        (let ((target-block (jump-target-block node)))
647          (and (null (jump-non-local-p node))
648               (member target-block *blocks*))))
649      (when (tagbody-node-p node) (tagbody-non-local-go-p node))
650      (when (block-node-p node) (block-non-local-return-p node))
651      (catch-node-p node)))
652
653(defknown block-creates-runtime-bindings-p (t) boolean)
654(defun block-creates-runtime-bindings-p (block)
655  ;; FIXME: This may be false, if the bindings to be
656  ;; created are a quoted list
657  (progv-node-p block))
658
659(defknown enclosed-by-runtime-bindings-creating-block-p (t) boolean)
660(defun enclosed-by-runtime-bindings-creating-block-p (outermost-block)
661  "Indicates whether the code being compiled/analyzed is enclosed in a
662block which creates special bindings at runtime."
663  (dolist (enclosing-block *blocks*)
664    (when (eq enclosing-block outermost-block)
665      (return-from enclosed-by-runtime-bindings-creating-block-p nil))
666    (when (block-creates-runtime-bindings-p enclosing-block)
667      (return-from enclosed-by-runtime-bindings-creating-block-p t))))
668
669(defknown enclosed-by-protected-block-p (&optional t) boolean)
670(defun enclosed-by-protected-block-p (&optional outermost-block)
671  "Indicates whether the code being compiled/analyzed is enclosed in
672a block which requires a non-local transfer of control exception to
673be generated.
674"
675  (dolist (enclosing-block *blocks*)
676    (when (eq enclosing-block outermost-block)
677      (return-from enclosed-by-protected-block-p nil))
678    (when (block-requires-non-local-exit-p enclosing-block)
679      (return-from enclosed-by-protected-block-p t))))
680
681(defknown enclosed-by-environment-setting-block-p (&optional t) boolean)
682(defun enclosed-by-environment-setting-block-p (&optional outermost-block)
683  (dolist (enclosing-block *blocks*)
684    (when (eq enclosing-block outermost-block)
685      (return nil))
686    (when (and (binding-node-p enclosing-block)
687               (binding-node-environment-register enclosing-block))
688      (return t))))
689
690(defknown environment-register-to-restore (&optional t) t)
691(defun environment-register-to-restore (&optional outermost-block)
692  "Returns the environment register which contains the
693saved environment from the outermost enclosing block:
694
695That's the one which contains the environment used in the outermost block."
696  (flet ((outermost-register (last-register block)
697           (when (eq block outermost-block)
698             (return-from environment-register-to-restore last-register))
699           (or (and (binding-node-p block)
700                    (binding-node-environment-register block))
701               last-register)))
702    (reduce #'outermost-register *blocks*
703            :initial-value nil)))
704
705(defstruct tag
706  ;; The symbol (or integer) naming the tag
707  name
708  ;; The symbol which is the jump target in JVM byte code
709  label
710  ;; The associated TAGBODY
711  block
712  (compiland *current-compiland*)
713  used
714  used-non-locally)
715
716(defknown find-tag (t) t)
717(defun find-tag (name)
718  (dolist (tag *visible-tags*)
719    (when (eql name (tag-name tag))
720      (return tag))))
721
722(defun process-ignore/ignorable (declaration names variables)
723  (when (memq declaration '(IGNORE IGNORABLE))
724    (let ((what (if (eq declaration 'IGNORE) "ignored" "ignorable")))
725      (dolist (name names)
726        (unless (and (consp name) (eq (car name) 'FUNCTION))
727          (let ((variable (find-variable name variables)))
728            (cond ((null variable)
729                   (compiler-style-warn "Declaring unknown variable ~S to be ~A."
730                                        name what))
731                  ((variable-special-p variable)
732                   (compiler-style-warn "Declaring special variable ~S to be ~A."
733                                        name what))
734                  ((eq declaration 'IGNORE)
735                   (setf (variable-ignore-p variable) t))
736                  (t
737                   (setf (variable-ignorable-p variable) t)))))))))
738
739(defun finalize-generic-functions ()
740  (dolist (sym '(make-instance
741                 initialize-instance
742                 shared-initialize))
743    (let ((gf (and (fboundp sym) (fdefinition sym))))
744      (when (typep gf 'standard-generic-function)
745        (unless (compiled-function-p gf)
746          (mop::finalize-standard-generic-function gf))))))
747
748(finalize-generic-functions)
749
750(provide 'jvm)
Note: See TracBrowser for help on using the repository browser.