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

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

Move exports from autoloads.lisp to the respective defining files.
Also, delete JVM-COMPILE-PACKAGE, which hasn't been used in our
sources for ages and doesn't seem to serve an external purpose.

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