source: trunk/source/compiler/nx-basic.lisp @ 14044

Last change on this file since 14044 was 14044, checked in by gz, 9 years ago

support for reporting code coverage of acode, needs more testing

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 48.2 KB
Line 
1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2009 Clozure Associates
4;;;   Copyright (C) 1994-2001 Digitool, Inc
5;;;   This file is part of Clozure CL. 
6;;;
7;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
8;;;   License , known as the LLGPL and distributed with Clozure CL as the
9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
10;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
11;;;   conflict, the preamble takes precedence. 
12;;;
13;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
14;;;
15;;;   The LLGPL is also available online at
16;;;   http://opensource.franz.com/preamble.html
17
18
19;; used by compiler and eval - stuff here is not excised with rest of compiler
20
21
22(in-package :ccl)
23
24#|| Note: when MCL-AppGen 4.0 is built, the following form will need to be included in it:
25; for compiler-special-form-p, called by cheap-eval-in-environment
26(defparameter *nx1-compiler-special-forms*
27  `(%DEFUN %FUNCTION %NEW-PTR %NEWGOTAG %PRIMITIVE %VREFLET BLOCK CATCH COMPILER-LET DEBIND
28    DECLARE EVAL-WHEN FBIND FLET FUNCTION GO IF LABELS LAP LAP-INLINE LET LET* LOAD-TIME-VALUE
29    LOCALLY MACRO-BIND MACROLET MAKE-LIST MULTIPLE-VALUE-BIND MULTIPLE-VALUE-CALL
30    MULTIPLE-VALUE-LIST MULTIPLE-VALUE-PROG1 NEW-LAP NEW-LAP-INLINE NFUNCTION OLD-LAP
31    OLD-LAP-INLINE OR PROG1 PROGN PROGV QUOTE RETURN-FROM SETQ STRUCT-REF STRUCT-SET
32    SYMBOL-MACROLET TAGBODY THE THROW UNWIND-PROTECT WITH-STACK-DOUBLE-FLOATS WITHOUT-INTERRUPTS))
33||#
34
35(eval-when (:compile-toplevel)
36  (require 'nxenv))
37
38(defvar *lisp-compiler-version* 666 "I lost count.")
39
40(defvar *nx-compile-time-types* nil)
41(defvar *nx-proclaimed-types* nil)
42(defvar *nx-method-warning-name* nil)
43
44(defvar *nx-current-code-note*)
45
46;; The problem with undefind type warnings is that there is no in-language way to shut
47;; them up even when the reference is intentional.  (In case of undefined functions,
48;; you can declare FTYPE and that will turn off any warnings without interfering with
49;; the function being defined later).  For now just provide this as an out.
50(defvar *compiler-warn-on-undefined-type-references* #+ccl-qres t #-ccl-qres t)
51
52
53
54;; In lieu of a slot in acode.  Don't reference this variable elsewhere because I'm
55;; hoping to make it go away.
56(defparameter *nx-acode-note-map* nil)
57
58(defun acode-note (acode &aux (hash *nx-acode-note-map*))
59  (and hash (gethash acode hash)))
60
61(defun (setf acode-note) (note acode)
62  (when note
63    (assert *nx-acode-note-map*)
64    ;; Only record if have a unique key
65    (unless (or (atom acode)
66                (nx-null acode)
67                (nx-t acode))
68      (setf (gethash acode *nx-acode-note-map*) note))))
69
70
71(defstruct (code-note (:constructor %make-code-note))
72  ;; Code coverage state.  This MUST be the first slot - see nx2-code-coverage.
73  code-coverage
74  ;; The source note of this form, or NIL if random code form (no file info,
75  ;; generated by macros or other source transform)
76  source-note
77  ;; the note that was being compiled when this note was emitted.
78  parent-note
79  ;; start/end position in the acode string for the toplevel lfun containing this code note.
80  acode-range
81  #+debug-code-notes ;; The actual source form - useful for debugging, otherwise unused.
82  form)
83
84(defun make-code-note (&key form source-note parent-note)
85  (declare (ignorable form))
86  (let ((note (%make-code-note
87               :source-note source-note
88               :parent-note parent-note)))
89    #+debug-code-notes
90    (when form
91      ;; Unfortunately, recording the macroexpanded form is problematic, since they
92      ;; can have references to non-dumpable forms, see e.g. loop.
93      (setf (code-note-form note)
94            (with-output-to-string (s) (let ((*print-circle* t)) (prin1 form s)))))
95    note))
96
97(defmethod print-object ((note code-note) stream)
98  (print-unreadable-object (note stream :type t :identity t)
99    (format stream "[~s]" (code-note-code-coverage note))
100    (let ((sn (code-note-source-note note)))
101      (if sn
102        (progn
103          (format stream " for ")
104          (print-source-note sn stream))
105        #+debug-code-notes
106        (when (code-note-form note)
107          (format stream " form ~a"
108                  (string-sans-most-whitespace (code-note-form note))))))))
109
110(defun nx-ensure-code-note (form &optional parent-note)
111  (let* ((parent-note (or parent-note *nx-current-code-note*))
112         (source-note (nx-source-note form)))
113    (unless (and source-note
114                 ;; Look out for a case like a lambda macro that turns (lambda ...)
115                 ;; into (FUNCTION (lambda ...)) which then has (lambda ...)
116                 ;; as a child.  Create a fresh note for the child, to avoid ambiguity.
117                 ;; Another case is forms wrapping THE around themselves.
118                 (neq source-note (code-note-source-note parent-note))
119                 ;; Don't use source notes from a different toplevel form, which could
120                 ;; happen due to inlining etc.  The result then is that the source note
121                 ;; appears in multiple places, and shows partial coverage (from the
122                 ;; other reference) in code that's never executed.
123                 (loop for p = parent-note then (code-note-parent-note p)
124                       when (null p) return t
125                       when (code-note-source-note p)
126                       return (eq (loop for n = source-note then s
127                                        as s = (source-note-source n)
128                                        unless (source-note-p s) return n)
129                                  (loop for n = (code-note-source-note p) then s
130                                        as s = (source-note-source n)
131                                        unless (source-note-p s) return n))))
132      (setq source-note nil))
133    (make-code-note :form form :source-note source-note :parent-note parent-note)))
134
135(defun nx-note-source-transformation (original new &aux (source-notes *nx-source-note-map*) sn)
136  (when (and source-notes
137             (setq sn (gethash original source-notes))
138             (not (gethash new source-notes)))
139    (setf (gethash new source-notes) sn)))
140
141
142(defvar *nx1-alphatizers* (make-hash-table :size 180 :test #'eq))
143
144(let ((policy (%istruct 'compiler-policy
145               #'(lambda (env)
146                   #+ccl-qres (< (debug-optimize-quantity env) 2)
147                   #-ccl-qres (neq (debug-optimize-quantity env) 3))   ;  allow-tail-recursion-elimination
148               #'(lambda (env)
149                   (declare (ignorable env))
150                   #+ccl-qres nil
151                   #-ccl-qres (eq (debug-optimize-quantity env) 3))   ; inhibit-register-allocation
152               #'(lambda (env)
153                   (let* ((safety (safety-optimize-quantity env)))
154                     (and (< safety 3)
155                          (>= (speed-optimize-quantity env)
156                              safety)))) ; trust-declarations
157               #'(lambda (env)
158                   #+ccl-qres (> (speed-optimize-quantity env)
159                                 (space-optimize-quantity env))
160                   #-ccl-qres (>= (speed-optimize-quantity env)
161                                  (+ (space-optimize-quantity env) 2))) ; open-code-inline
162               #'(lambda (env)
163                   (and (eq (speed-optimize-quantity env) 3) 
164                        (eq (safety-optimize-quantity env) 0)))   ; inhibit-safety-checking
165               #'(lambda (env)
166                   (let* ((safety (safety-optimize-quantity env)))
167                     (or (eq safety 3)
168                         (> safety (speed-optimize-quantity env)))))          ;declarations-typecheck
169               #'(lambda (env)
170                   (neq (debug-optimize-quantity env) 3))   ; inline-self-calls
171               #'(lambda (env)
172                   (and (neq (compilation-speed-optimize-quantity env) 3)
173                        (or (neq (speed-optimize-quantity env) 0)
174                            (and (neq (safety-optimize-quantity env) 3)
175                                 (neq (debug-optimize-quantity env) 3))))) ; allow-transforms
176               #'(lambda (var env)       ; force-boundp-checks
177                   (declare (ignore var))
178                   (eq (safety-optimize-quantity env) 3))
179               #'(lambda (var val env)       ; allow-constant-substitution
180                   (declare (ignore var val env))
181                   t)
182               nil           ; extensions
183               )))
184  (defun new-compiler-policy (&key (allow-tail-recursion-elimination nil atr-p)
185                                   (inhibit-register-allocation nil ira-p)
186                                   (trust-declarations nil td-p)
187                                   (open-code-inline nil oci-p)
188                                   (inhibit-safety-checking nil ischeck-p)
189                                   (inline-self-calls nil iscall-p)
190                                   (allow-transforms nil at-p)
191                                   (force-boundp-checks nil fb-p)
192                                   (allow-constant-substitution nil acs-p)
193                                   (declarations-typecheck nil dt-p))
194    (let ((p (copy-uvector policy)))
195      (if atr-p (setf (policy.allow-tail-recursion-elimination p) allow-tail-recursion-elimination))
196      (if ira-p (setf (policy.inhibit-register-allocation p) inhibit-register-allocation))
197      (if td-p (setf (policy.trust-declarations p) trust-declarations))
198      (if oci-p (setf (policy.open-code-inline p) open-code-inline))
199      (if ischeck-p (setf (policy.inhibit-safety-checking p) inhibit-safety-checking))
200      (if iscall-p (setf (policy.inline-self-calls p) inline-self-calls))
201      (if at-p (setf (policy.allow-transforms p) allow-transforms))
202      (if fb-p (setf (policy.force-boundp-checks p) force-boundp-checks))
203      (if acs-p (setf (policy.allow-constant-substitution p) allow-constant-substitution))
204      (if dt-p (setf (policy.declarations-typecheck p) declarations-typecheck))
205      p))
206  (defun %default-compiler-policy () policy))
207
208(%include "ccl:compiler;lambda-list.lisp")
209
210;Syntactic Environment Access.
211
212(defun declaration-information (decl-name &optional env)
213  (if (and env (not (istruct-typep env 'lexical-environment)))
214    (report-bad-arg env 'lexical-environment))
215; *** This needs to deal with things defined with DEFINE-DECLARATION ***
216  (case decl-name
217    (optimize
218     (list 
219      (list 'speed (speed-optimize-quantity env))
220      (list 'safety (safety-optimize-quantity env))
221      (list 'compilation-speed (compilation-speed-optimize-quantity env))
222      (list 'space (space-optimize-quantity env))
223      (list 'debug (debug-optimize-quantity env))))
224    (declaration
225     *nx-known-declarations*)))
226
227(defun function-information (name &optional env &aux decls)
228  (let ((name (ensure-valid-function-name name)))
229    (if (and env (not (istruct-typep env 'lexical-environment)))
230      (report-bad-arg env 'lexical-environment))
231    (if (special-operator-p name)
232      (values :special-form nil nil)
233      (flet ((process-new-fdecls (fdecls)
234                                 (dolist (fdecl fdecls)
235                                   (when (eq (car fdecl) name)
236                                     (let ((decl-type (cadr fdecl)))
237                                       (when (and (memq decl-type '(dynamic-extent inline ftype))
238                                                  (not (assq decl-type decls)))
239                                         (push (cdr fdecl) decls)))))))
240        (declare (dynamic-extent #'process-new-fdecls))
241        (do* ((root t)
242              (contour env (when root (lexenv.parent-env contour))))
243             ((null contour)
244              (if (macro-function name)
245                (values :macro nil nil)
246                (if (fboundp name)
247                  (values :function 
248                          nil 
249                          (if (assq 'inline decls)
250                            decls
251                            (if (proclaimed-inline-p name)
252                              (push '(inline . inline) decls)
253                                (if (proclaimed-notinline-p name)
254                                  (push '(inline . notinline) decls)))))
255                  (values nil nil decls))))
256          (if (istruct-typep contour 'definition-environment)
257            (if (assq name (defenv.functions contour))
258              (return (values :macro nil nil))
259              (progn (setq root nil) (process-new-fdecls (defenv.fdecls contour))))
260            (progn
261              (process-new-fdecls (lexenv.fdecls contour))
262              (let ((found (assq name (lexenv.functions contour))))
263                (when found
264                  (return
265                   (if (and (consp (cdr found))(eq (%cadr found) 'macro))
266                     (values :macro t nil)
267                     (values :function t decls))))))))))))
268
269(defun variable-information (var &optional env)
270  (setq var (require-type var 'symbol))
271  (if (and env (not (istruct-typep env 'lexical-environment)))
272    (report-bad-arg env 'lexical-environment))
273  (let* ((vartype nil)
274         (boundp nil)
275         (envtype nil)
276         (typedecls (nx-declared-type var env)) ; should grovel nested/shadowed special decls for us.
277         (decls (if (and typedecls (neq t typedecls)) (list (cons 'type typedecls)))))
278    (loop
279      (cond ((null env)
280             (if (constant-symbol-p var)
281               (setq vartype :constant decls nil)
282               (if (proclaimed-special-p var)
283                 (setq vartype :special)
284                 (let* ((not-a-symbol-macro (cons nil nil)))
285                   (declare (dynamic-extent not-a-symbol-macro))
286                   (unless (eq (gethash var *symbol-macros* not-a-symbol-macro)
287                               not-a-symbol-macro)
288                     (setq vartype :symbol-macro)))))
289             (return))
290            ((eq (setq envtype (istruct-type-name env)) 'definition-environment)
291             (cond ((assq var (defenv.constants env))
292                    (setq vartype :constant)
293                    (return))
294                   ((assq var (defenv.symbol-macros env))
295                    (setq vartype :symbol-macro)
296                    (return))
297                   ((assq var (defenv.specials env))
298                    (setq vartype :special)
299                    (return))))
300            (t
301             (dolist (vdecl (lexenv.vdecls env))
302               (when (eq (car vdecl) var)
303                 (let ((decltype (cadr vdecl)))
304                   (unless (assq decltype decls)
305                     (case decltype
306                       (special (setq vartype :special))
307                       ((type dynamic-extent ignore) (push (cdr vdecl) decls)))))))
308             (let ((vars (lexenv.variables env)))
309               (unless (atom vars)
310                 (dolist (v vars)
311                   (when (eq (var-name v) var)
312                     (setq boundp t)
313                     (if (and (consp (var-ea v))
314                              (eq :symbol-macro (car (var-ea v))))
315                       (setq vartype :symbol-macro)
316                       (unless vartype (setq vartype
317                                             (let* ((bits (var-bits v)))
318                                               (if (and (typep bits 'integer)
319                                                        (logbitp $vbitspecial bits))
320                                                 :special
321                                                 :lexical)))))
322                     (return)))
323                 (when vartype (return))))))
324      (setq env (if (eq envtype 'lexical-environment) (lexenv.parent-env env))))
325    (values vartype boundp decls)))
326
327(defun nx-target-type (typespec)
328  ;; Could do a lot more here
329  (if (or (eq *host-backend* *target-backend*)
330          (not (eq typespec 'fixnum)))
331    typespec
332    (target-word-size-case
333     (32 '(signed-byte 30))
334     (64 '(signed-byte 61)))))
335
336; Type declarations affect all references.
337(defun nx-declared-type (sym &optional (env *nx-lexical-environment*))
338  (loop
339    (when (or (null env) (istruct-typep env 'definition-environment)) (return))
340    (dolist (decl (lexenv.vdecls env))
341      (if (and (eq (car decl) sym)
342               (eq (cadr decl) 'type))
343               (return-from nx-declared-type (nx-target-type (cddr decl)))))
344    (let ((vars (lexenv.variables env)))
345      (when (and (consp vars) 
346                 (dolist (var vars) 
347                   (when (eq (var-name var) sym) 
348                     (return t))))
349        (return-from nx-declared-type t)))
350    (setq env (lexenv.parent-env env)))
351  (let ((decl (or (assq sym *nx-compile-time-types*)
352                     (assq sym *nx-proclaimed-types*))))
353    (if decl (%cdr decl) t)))
354
355(defun nx-declared-result-type (sym &optional (env *nx-lexical-environment*) args)
356  (when (symbolp (setq sym (maybe-setf-function-name sym)))
357    (let* ((ftype (find-ftype-decl sym env args))
358           (ctype (and ftype (if (typep ftype 'ctype) ftype (specifier-type-if-known ftype env)))))
359      (unless (or (null ctype)
360                  (not (function-ctype-p ctype))
361                  (eq *wild-type* (function-ctype-returns ctype)))
362        (let ((result-type (type-specifier (single-value-type (function-ctype-returns ctype)))))
363          (and (neq result-type 't) result-type))))))
364
365(defmacro define-declaration (decl-name lambda-list &body body &environment env)
366  (multiple-value-bind (body decls)
367                       (parse-body body env)
368    (let ((fn `(nfunction (define-declaration ,decl-name)
369                          (lambda ,lambda-list
370                            ,@decls
371                            (block ,decl-name
372                              ,@body)))))
373      `(progn
374         (proclaim '(declaration ,decl-name))
375         (setf (getf *declaration-handlers* ',decl-name) ,fn)))))
376
377(defun check-environment-args (variable symbol-macro function macro)
378  (flet ((check-all-pairs (pairlist argname)
379          (dolist (pair pairlist)
380            (unless (and (consp pair) (consp (%cdr pair)) (null (%cddr pair)) (symbolp (%car pair)))
381              (signal-simple-program-error "Malformed ~s argument: ~s is not of the form (~S ~S) in ~S" 
382                                           argname
383                                           pair
384                                           'name
385                                           'definition
386                                           pairlist))))
387         (check-all-symbols (symlist argname pairs pairsname)
388          (dolist (v symlist)
389            (unless (symbolp v) 
390              (signal-simple-program-error "Malformed ~S list: ~S is not a symbol in ~S." argname v symlist))
391            (when (assq v pairs) 
392              (signal-simple-program-error "~S ~S conflicts with ~S ~S" argname v pairsname (assq v pairs))))))
393    (check-all-pairs symbol-macro :symbol-macro)
394    (check-all-pairs macro :macro)
395    (check-all-symbols variable :variable symbol-macro :symbol-macro)
396    (check-all-symbols function :function macro :macro)))
397
398
399;; This -isn't- PARSE-DECLARATIONS.  It can't work; neither can this ...
400(defun process-declarations (env decls symbol-macros)
401  (let ((vdecls nil)
402        (fdecls nil)
403        (mdecls nil))
404    (flet ((add-type-decl (spec)
405            (destructuring-bind (typespec &rest vars) spec
406              (dolist (var vars)
407                (when (non-nil-symbol-p var)
408                  (push (list* var 
409                               'type
410                               (let ((already (assq 'type (nth-value 2 (variable-information var env)))))
411                                 (if already
412                                   (let ((oldtype (%cdr already)))
413                                     (if oldtype
414                                       (if (subtypep oldtype typespec)
415                                         oldtype
416                                         (if (subtypep typespec oldtype)
417                                           typespec))))
418                                   typespec)))
419                        vdecls))))))
420      ; do SPECIAL declarations first - this approximates the right thing, but doesn't quite make it.
421      (dolist (decl decls)
422        (when (eq (car decl) 'special)
423          (dolist (spec (%cdr decl))
424            (when (non-nil-symbol-p spec)
425              (if (assq spec symbol-macros)
426                (signal-program-error "Special declaration cannot be applied to symbol-macro ~S" spec))
427              (push (list* spec 'special t) vdecls)))))
428      (dolist (decl decls)
429        (let ((decltype (car decl)))
430          (case decltype
431              ((inline notinline)
432               (dolist (spec (%cdr decl))
433               (let ((fname nil))
434                 (if (non-nil-symbol-p spec)
435                   (setq fname spec)
436                   (if (setf-function-name-p spec)
437                     (setq fname (setf-function-name (cadr spec)))))
438                 (if fname
439                   (push (list* fname decltype t) fdecls)))))
440              (optimize
441               (dolist (spec (%cdr decl))
442                 (let ((val 3)
443                       (quantity spec))
444                   (if (consp spec)
445                     (setq quantity (car spec) val (cadr spec)))
446                 (if (and (fixnump val) (<= 0 val 3) (memq quantity '(debug speed space safety compilation-speed)))
447                   (push (cons quantity val) mdecls)))))
448              (dynamic-extent
449               (dolist (spec (%cdr decl))
450               (if (non-nil-symbol-p spec)
451                 (push (list* spec decltype t) vdecls)
452                 (if (and (consp spec) (eq (%car spec) 'function))
453                   (let ((fname (cadr spec)))
454                     (if (not (non-nil-symbol-p fname))
455                       (setq fname 
456                             (if (setf-function-name-p fname)
457                               (setf-function-name (cadr fname)))))
458                     (if fname (push (list* fname decltype t) fdecls)))))))
459              (type (add-type-decl (cdr decl)))
460              (ftype (destructuring-bind (typespec &rest fnames) (%cdr decl)
461                       (dolist (name fnames)
462                         (let ((fname name))
463                           (if (not (non-nil-symbol-p fname))
464                             (setq fname 
465                                   (if (setf-function-name-p fname)
466                                     (setf-function-name (cadr fname)))))
467                           (if fname (push (list* fname decltype typespec) fdecls))))))
468              (special)
469              (t
470               (if (memq decltype *cl-types*)
471                 (add-type-decl decl)
472                 (let ((handler (getf *declaration-handlers* decltype)))
473                   (when handler
474                     (multiple-value-bind (type info) (funcall handler decl)
475                       (ecase type
476                         (:variable
477                          (dolist (v info) (push (apply #'list* v) vdecls)))
478                         (:function
479                          (dolist (f info) (push (apply #'list* f) fdecls)))
480                         (:declare  ;; N.B. CLtL/2 semantics
481                          (push info mdecls)))))))))))
482      (setf (lexenv.vdecls env) (nconc vdecls (lexenv.vdecls env))
483            (lexenv.fdecls env) (nconc fdecls (lexenv.fdecls env))
484            (lexenv.mdecls env) (nconc mdecls (lexenv.mdecls env))))))
485
486 
487(defun nx-cons-var (name &optional (bits 0))
488  (%istruct 'var name bits nil nil nil nil 0 nil))
489
490
491(defun augment-environment (env &key variable symbol-macro function macro declare)
492  (if (and env (not (istruct-typep env 'lexical-environment)))
493    (report-bad-arg env 'lexical-environment))
494  (check-environment-args variable symbol-macro function macro)
495  (let* ((vars (mapcar #'nx-cons-var variable))
496         (symbol-macros (mapcar #'(lambda (s)
497                                    (let* ((sym (car s)))
498                                      (unless (and (symbolp sym)
499                                                   (not (constantp sym env))
500                                                   (not (eq (variable-information sym env) :special)))
501                                        (signal-program-error "~S can't by bound as a SYMBOL-MACRO" sym))
502                                      (let ((v (nx-cons-var (car s)))) 
503                                        (setf (var-expansion v) (cons :symbol-macro (cadr s)))
504                                        v)))
505                                symbol-macro))
506         (macros (mapcar #'(lambda (m) (list* (car m) 'macro (cadr m))) macro))
507         (functions (mapcar #'(lambda (f) (list* f 'function nil)) function))
508         (new-env (new-lexical-environment env)))
509    (setf (lexenv.variables new-env) (nconc vars symbol-macros)
510          (lexenv.functions new-env) (nconc functions macros))
511    (process-declarations new-env declare symbol-macro)
512    new-env))
513
514(defun enclose (lambda-expression &optional env)
515  (if (and env (not (istruct-typep env 'lexical-environment)))
516    (report-bad-arg env 'lexical-environment))
517  (unless (lambda-expression-p lambda-expression)
518    (error "Invalid lambda-expression ~S." lambda-expression))
519  (%make-function nil lambda-expression env))
520
521#|| Might be nicer to do %declaim
522(defmacro declaim (&rest decl-specs &environment env)
523  `(progn
524     (eval-when (:load-toplevel :execute)
525       (proclaim ',@decl-specs))
526     (eval-when (:compile-toplevel)
527       (%declaim ',@decl-specs ,env))))
528||#
529
530(defmacro declaim (&environment env &rest decl-specs)
531  "DECLAIM Declaration*
532  Do a declaration or declarations for the global environment."
533  (let* ((body (mapcar #'(lambda (spec) `(proclaim ',spec)) decl-specs)))
534  `(progn
535     (eval-when (:compile-toplevel)
536       (compile-time-proclamation ',decl-specs ,env))
537     (eval-when (:load-toplevel :execute)
538       ,@body))))
539
540(defvar *strict-checking* nil
541  "If true, issues warnings/errors in more cases, e.g. for valid but non-portable code")
542
543
544;; Should be true if compiler warnings UI doesn't use source locations, false if it does.
545(defvar *merge-compiler-warnings* t "If false, don't merge compiler warnings with different source locations")
546
547;;; If warnings have more than a single entry on their
548;;; args slot, don't merge them.
549(defun merge-compiler-warnings (old-warnings)
550  (let ((warnings nil))
551    (dolist (w old-warnings)
552      (let* ((w-args (compiler-warning-args w)))
553        (if
554          (or (cdr w-args)
555              ;; See if W can be merged into an existing warning
556              (dolist (w1 warnings t) 
557                (let ((w1-args (compiler-warning-args w1)))
558                  (when (and (eq (compiler-warning-warning-type w)
559                                 (compiler-warning-warning-type w1))
560                             w1-args
561                             (null (cdr w1-args))
562                             (eq (%car w-args)
563                                 (%car w1-args))
564                             (or *merge-compiler-warnings*
565                                 (eq (compiler-warning-source-note w)
566                                     (compiler-warning-source-note w1))))
567                    (let ((nrefs (compiler-warning-nrefs w1)))
568                      (setf (compiler-warning-nrefs w1)
569                            (cons (compiler-warning-source-note w)
570                                  (or nrefs
571                                      (list (compiler-warning-source-note w1)))))
572                      (return nil))))))
573          (push w warnings))))
574    warnings))
575
576;;; This is called by, e.g., note-function-info & so can't be -too- funky ...
577;;; don't call proclaimed-inline-p or proclaimed-notinline-p with alphatized crap
578
579(defun nx-declared-inline-p (sym env)
580  (setq sym (maybe-setf-function-name sym))
581  (loop
582    (when (listp env)
583      (return (and (symbolp sym)
584                   (proclaimed-inline-p sym))))
585    (dolist (decl (lexenv.fdecls env))
586      (when (and (eq (car decl) sym)
587                 (eq (cadr decl) 'inline))
588        (return-from nx-declared-inline-p (eq (cddr decl) 'inline))))
589    (setq env (lexenv.parent-env env))))
590
591(defun report-compile-time-argument-mismatch (condition stream &aux (type (compiler-warning-warning-type condition)))
592  (destructuring-bind (callee reason args spread-p)
593      (compiler-warning-args condition)
594    (format stream "In the ~a ~s with arguments ~:s,~%  "
595            (if spread-p "application of" "call to")
596            callee
597            args)
598    (ecase (car reason)
599      (:toomany
600       (destructuring-bind (provided max)
601           (cdr reason)
602         (format stream "~d argument~:p ~:*~[were~;was~:;were~] provided, but at most ~d ~:*~[are~;is~:;are~] accepted~&  by " provided max)))
603      (:toofew
604       (destructuring-bind (provided min)
605           (cdr reason)
606         (format stream "~d argument~:p ~:*~[were~;was~:;were~] provided, but at least ~d ~:*~[are~;is~:;are~] required~&  by " provided min)))
607      (:odd-keywords
608       (let* ((tail (cadr reason)))
609         (format stream "the variable portion of the argument list ~s contains an odd number~&  of arguments and so can't be used to initialize keyword parameters~&  for " tail)))
610      (:unknown-keyword
611       (destructuring-bind (badguy goodguys)
612           (cdr reason)
613         (format stream "the keyword argument~:[ ~s is~;s~{ ~s~^~#[~; and~:;,~]~} are~] not one of ~:s, which are recognized by "
614                 (consp badguy) badguy goodguys)))
615      (:unknown-gf-keywords
616         (let ((badguys (cadr reason)))
617           (when (and (consp badguys) (null (%cdr badguys))) (setq badguys (car badguys)))
618           (format stream "the keyword argument~:[ ~s is~;s~{ ~s~^~#[~; and~:;,~]~} are~] not recognized by "
619
620                   (consp badguys) badguys))))
621    (format stream
622            (ecase type
623              (:ftype-mismatch "the FTYPE declaration of ~s")
624              (:global-mismatch "the current global definition of ~s")
625              (:environment-mismatch "the definition of ~s visible in the current compilation unit.")
626              (:lexical-mismatch "the lexically visible definition of ~s")
627              ;; This can happen when compiling without compilation unit:
628              (:deferred-mismatch "~s"))
629            callee)))
630
631(defparameter *compiler-warning-formats*
632  '((:special . "Undeclared free variable ~S")
633    (:unused . "Unused lexical variable ~S")
634    (:ignore . "Variable ~S not ignored.")
635    (:undefined-function . "Undefined function ~S") ;; (deferred)
636    (:undefined-type . "Undefined type ~S")         ;; (deferred)
637    (:unknown-type-in-declaration . "Unknown or invalid type ~S, declaration ignored")
638    (:bad-declaration . "Unknown or invalid declaration ~S")
639    (:invalid-type . report-invalid-type-compiler-warning)
640    (:unknown-declaration-variable . "~s declaration for unknown variable ~s")
641    (:unknown-declaration-function . "~s declaration for unknown function ~s")
642    (:macro-used-before-definition . "Macro function ~S was used before it was defined.")
643    (:unsettable . "Shouldn't assign to variable ~S")
644    (:global-mismatch . report-compile-time-argument-mismatch)
645    (:environment-mismatch . report-compile-time-argument-mismatch)
646    (:lexical-mismatch . report-compile-time-argument-mismatch)   
647    (:ftype-mismatch . report-compile-time-argument-mismatch)
648    (:deferred-mismatch . report-compile-time-argument-mismatch)
649    (:type . "Type declarations violated in ~S")
650    (:type-conflict . "Conflicting type declarations for ~S")
651    (:special-fbinding . "Attempt to bind compiler special name: ~s. Result undefined.")
652    (:lambda . "Suspicious lambda-list: ~s")
653    (:incongruent-gf-lambda-list . "Lambda list of generic function ~s is incongruent with previously defined methods")
654    (:incongruent-method-lambda-list . "Lambda list of ~s is incongruent with previous definition of ~s")
655    (:gf-keys-not-accepted . "~s does not accept keywords ~s required by the generic functions")
656    (:result-ignored . "Function result ignored in call to ~s")
657    (:duplicate-definition . report-compile-time-duplicate-definition)
658    (:format-error . "~:{~@?~%~}")
659    (:program-error . "~a")
660    (:unsure . "Nonspecific warning")))
661
662(defun report-invalid-type-compiler-warning (condition stream)
663  (destructuring-bind (type &optional why) (compiler-warning-args condition)
664    (when (typep why 'invalid-type-specifier)
665      (setq type (invalid-type-specifier-typespec why) why nil))
666    (format stream "Invalid type specifier ~S~@[: ~A~]" type why)))
667
668(defun report-compile-time-duplicate-definition (condition stream)
669  (destructuring-bind (name old-file new-file &optional from to) (compiler-warning-args condition)
670    (format stream
671            "Duplicate definitions of ~s~:[~*~;~:* (as a ~a and a ~a)~]~:[~;, in this file~:[~; and in ~s~]~]"
672            (maybe-setf-name name) from to
673            (and old-file new-file)
674            (neq old-file new-file)
675            old-file)))
676
677(defun adjust-compiler-warning-args (warning-type args)
678  (case warning-type
679    ((:undefined-function :result-ignored) (mapcar #'maybe-setf-name args))
680    (t args)))
681
682
683(defun report-compiler-warning (condition stream &key short)
684  (let* ((warning-type (compiler-warning-warning-type condition))
685         (format-string (cdr (assq warning-type *compiler-warning-formats*)))
686         (warning-args (compiler-warning-args condition)))
687    (unless short
688      (let ((name (reverse (compiler-warning-function-name condition))))
689        (format stream "In ")
690        (print-nested-name name stream)
691        (when (every #'null name)
692          (let ((position (source-note-start-pos (compiler-warning-source-note condition))))
693            (when position (format stream " at position ~s" position))))
694        (format stream ": ")))
695    (if (typep format-string 'string)
696      (apply #'format stream format-string (adjust-compiler-warning-args warning-type warning-args))
697      (if (null format-string)
698        (format stream "~A: ~S" warning-type warning-args)
699        (funcall format-string condition stream)))
700    ;(format stream ".")
701    (let ((nrefs (compiler-warning-nrefs condition)))
702      (when nrefs
703        (format stream " (~D references)" (length nrefs))))))
704
705(defun environment-structref-info (name env)
706  (let ((defenv (definition-environment env)))
707    (when defenv
708      (cdr (assq name (defenv.structrefs defenv))))))
709
710;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
711;;
712;;  For code coverage, pretty-print acode to string and store position info in code notes.
713;;
714;;  decomp-acode can also be used separately for debugging.
715;;
716(defmacro dbg-assert (form)
717  #-debug-code-notes (declare (ignore form))
718  #+debug-code-notes `(assert ,form))
719
720(defvar *acode-right-margin* 120)
721(defvar *nx-pprint-stream* nil)
722(defvar *nx-acode-inner-refs* :default)
723(defvar *nx-acode-refs-counter* 0)
724
725(defun nx-pprinting-p (stream)
726  (and *nx-pprint-stream*
727       (typep stream 'xp-stream)
728       (slot-value stream 'xp-structure)
729       (eq *nx-pprint-stream* (xp-base-stream (slot-value stream 'xp-structure)))))
730
731(defstruct acode-ref
732  object)
733
734(defstruct (acode-afunc-ref (:include acode-ref))
735  afunc
736  index)
737
738(defun nx-record-code-coverage-acode (afunc)
739  (assert *nx-current-code-note*)
740  (let* ((form->note (make-hash-table :test #'eq))
741         (*nx-acode-inner-refs* nil)
742         (*nx-acode-refs-counter* 0)
743         (form (decomp-acode (afunc-acode afunc)
744                             :prettify t
745                             :hook (lambda (acode form &aux (note (acode-note acode)))
746                                     ;; For expressions within without-compiling-code-coverage, there is a source
747                                     ;; note and not a code note, so need to check for code note explicitly.
748                                     (when (code-note-p note)
749                                       (dbg-assert (null (gethash form form->note)))
750                                       (dbg-assert (null (code-note-acode-range note)))
751                                       (setf (gethash form form->note) note)))))
752         (package *package*)
753         (string (with-standard-io-syntax
754                     (with-output-to-string (*nx-pprint-stream*)
755                       (let* ((*package* package)
756                              (*print-right-margin* *acode-right-margin*)
757                              (*print-case* :downcase)
758                              (*print-readably* nil))
759                         (pprint-recording-positions
760                          form *nx-pprint-stream*
761                          (lambda (form open-p pos)
762                            (let* ((note (gethash form form->note))
763                                   (range (and note (code-note-acode-range note))))
764                              (when note
765                                (cond (open-p
766                                       (dbg-assert (null range))
767                                       (setf (code-note-acode-range note)
768                                             (encode-file-range pos pos)))
769                                      (t
770                                       (dbg-assert (not (null range)))
771                                       (multiple-value-bind (start end)
772                                                            (decode-file-range range)
773                                         (declare (ignorable end))
774                                         (dbg-assert (eq start end))
775                                         (setf (code-note-acode-range note)
776                                               (encode-file-range start pos))))))))))))))
777    (iterate store ((afunc afunc))
778      (setf (getf (afunc-lfun-info afunc) '%function-acode-string) string)
779      (loop for inner in (afunc-inner-functions afunc)
780        unless (getf (afunc-lfun-info inner) '%function-acode-string)
781        do (store inner)))
782    afunc))
783
784(defmethod print-object ((ref acode-afunc-ref) stream)
785  (if (nx-pprinting-p stream)
786    (let ((index (acode-afunc-ref-index ref)))
787      (when index ;; referenced multiple times.
788        (if (eql index 0)  ;; never referenced before?
789          (format stream "#~d=" 
790                  (setf (acode-afunc-ref-index ref) (incf *nx-acode-refs-counter*)))
791          ;; If not first reference, just point back.
792          (return-from print-object (format stream "#~d#" index))))
793      (write-1 (acode-afunc-ref-object ref) stream))
794    (call-next-method)))
795
796(defmethod print-object ((ref acode-ref) stream)
797  (if (nx-pprinting-p stream)
798    (write-1 (acode-ref-object ref) stream)
799    (call-next-method)))
800
801(defun decomp-ref (obj)
802  (if (and (listp *nx-acode-inner-refs*) ;; code coverage case
803           (not (acode-p obj)))
804    (make-acode-ref :object obj)
805    obj))
806
807(defvar *decomp-prettify* nil "If true, loses info but results in more recognizable lisp")
808
809(defvar *decomp-hook* nil)
810
811(defun decomp-acode (acode &key (hook *decomp-hook*) (prettify *decomp-prettify*))
812  (let ((*decomp-hook* hook)
813        (*decomp-prettify* prettify))
814    (decomp-form acode)))
815
816(defun decomp-form (acode)
817  (cond ((eq acode *nx-t*) t)
818        ((eq acode *nx-nil*) nil)
819        (t (let* ((op (car acode))
820                  (num (length *next-nx-operators*))
821                  (name (when (and (fixnump op)
822                                   (<= 0 op)
823                                   (setq op (logand op operator-id-mask))
824                                   (< op num))
825                          (car (nth (- num op 1) *next-nx-operators*))))
826                  (new (decomp-using-name (or name op) (cdr acode))))
827             (when *decomp-hook*
828               (funcall *decomp-hook* acode new))
829             new))))
830
831
832(defun decomp-afunc (afunc)
833  (setq afunc (require-type afunc 'afunc))
834  (dbg-assert (afunc-acode afunc))
835  (if (listp *nx-acode-inner-refs*)    ;; code coverage case
836      (let ((ref (find afunc *nx-acode-inner-refs* :key #'acode-afunc-ref-afunc)))
837        (if ref ;; seen before, mark that multiply referenced.
838            (setf (acode-afunc-ref-index ref) 0)
839            (push (setq ref (make-acode-afunc-ref :afunc afunc
840                                                  :object (decomp-form (afunc-acode afunc))))
841                  *nx-acode-inner-refs*))
842        ref)
843      afunc))
844
845(defun decomp-var (var)
846  (decomp-ref (var-name (require-type var 'var))))
847
848(defun decomp-formlist (formlist)
849  (mapcar #'decomp-form formlist))
850
851(defun decomp-arglist (arglist)
852  (destructuring-bind (stack-forms register-forms) arglist
853    (nconc (decomp-formlist stack-forms)
854           (nreverse (decomp-formlist register-forms)))))
855
856(defun decomp-lambda-list (req opt rest keys auxen &optional whole)
857  (flet ((decomp-arg (var)
858           (if (acode-p var)
859             (destructuring-bind (op whole req opt rest keys auxen) var
860               (assert (eq op (%nx1-operator lambda-list))) ;; fake
861               (decomp-lambda-list req opt rest keys auxen whole))
862             (decomp-var var))))
863    (let ((whole (and whole (list '&whole (decomp-arg whole))))
864          (reqs (mapcar #'decomp-arg req))
865          (opts (when opt (cons '&optional (apply #'mapcar
866                                                  (lambda (var init supp)
867                                                    (if (and (not supp) (eq init *nx-nil*))
868                                                      (decomp-arg var)
869                                                      (list* (decomp-arg var)
870                                                             (decomp-form init)
871                                                             (and supp (list (decomp-arg supp))))))
872                                                  opt))))
873          (rest (when rest (list '&rest (decomp-arg rest))))
874          (keys (when keys
875                  (destructuring-bind (aok vars supps inits keyvect) keys
876                    (nconc
877                     (when vars
878                       (cons '&key (map 'list (lambda (var supp init key)
879                                                (let* ((sym (decomp-arg var))
880                                                       (arg (if (and (symbolp sym) (eq (make-keyword sym) key))
881                                                              sym
882                                                              (list key sym))))
883                                                  (if (and (not supp) (eq init *nx-nil*) (eq arg sym))
884                                                    sym
885                                                    (list* arg
886                                                           (decomp-form init)
887                                                           (and supp (list (decomp-arg supp)))))))
888                                        vars supps inits keyvect)))
889                     (when aok (list '&allow-other-keys))))))
890          (auxen (when (car auxen)
891                   (cons '&aux (apply #'mapcar
892                                      (lambda (var init)
893                                        (if (eq init *nx-nil*)
894                                          (decomp-arg var)
895                                          (list (decomp-arg var) (decomp-form init))))
896                                      auxen)))))
897      (nconc whole reqs opts rest keys auxen))))
898
899(defmacro defdecomp (names arglist &body body)
900  (let ((op-var (car arglist))
901        (args-vars (cdr arglist))
902        (op-decls nil)
903        (args-var (gensym)))
904    (multiple-value-bind (body decls) (parse-body body nil)
905    ;; Kludge but good enuff for here
906      (setq decls (loop for decl in decls
907                    collect (cons (car decl)
908                                  (loop for exp in (cdr decl)
909                                    do (when (and (consp exp) (member op-var (cdr exp)))
910                                         (push (list (car exp) op-var) op-decls))
911                                    collect (cons (car exp) (remove op-var (cdr exp)))))))
912    `(progn
913       ,@(loop for name in (if (atom names) (list names) names)
914           collect `(defmethod decomp-using-name ((,op-var (eql ',name)) ,args-var)
915                      (declare ,@op-decls)
916                      (destructuring-bind ,args-vars ,args-var
917                        ,@decls
918                        ,@body)))))))
919
920;; Default method
921(defmethod decomp-using-name (op forms)
922  `(,op ,@(decomp-formlist forms)))
923
924;; not real op, kludge generated below for lambda-bind
925(defdecomp keyref (op index)
926  `(,op ,index))
927
928(defdecomp immediate (op imm)
929  (when *decomp-prettify*
930    (setq op 'quote))
931  `(,op ,imm))
932
933(defdecomp fixnum (op raw-fixnum)
934  (declare (ignore op))
935  (decomp-ref raw-fixnum))
936
937(defdecomp %function (op symbol)
938  (when *decomp-prettify*
939    (setq op 'function))
940  `(,op ,symbol))
941
942(defdecomp simple-function (op afunc)
943  (when *decomp-prettify*
944    (setq op 'function))
945  `(,op ,(decomp-afunc afunc)))
946
947(defdecomp closed-function (op afunc)
948  (when *decomp-prettify*
949    (setq op 'function))
950  `(,op ,(decomp-afunc afunc)))
951
952(defdecomp (progn prog1 multiple-value-prog1 or list %temp-list values) (op form-list)
953  `(,op ,@(decomp-formlist form-list)))
954
955(defdecomp multiple-value-call (op fn form-list)
956  `(,op ,(decomp-form fn) ,@(decomp-formlist form-list)))
957
958(defdecomp vector (op formlist)
959  `(,op ,@(decomp-formlist formlist)))
960
961(defdecomp (%gvector list* %err-disp) (op arglist)
962  `(,op ,@(decomp-arglist arglist)))
963
964(defdecomp (i386-syscall syscall eabi-syscall poweropen-syscall
965            i386-ff-call ff-call eabi-ff-call poweropen-ff-call)
966           (op target argspecs argvals resultspec &rest rest)
967  `(,op
968    ,(decomp-form target)
969    ,@(mapcan (lambda (spec val) (list spec (decomp-form val))) argspecs argvals)
970    ,resultspec
971    ,@rest))
972
973(defdecomp (consp characterp istruct-typep %ptr-eql int>0-p %izerop endp eq %ilogbitp %base-char-p not neq) (op cc &rest forms)
974  (if (eq (acode-immediate-operand cc) :eq)
975    `(,op ,@(decomp-formlist forms))
976    `(,op ,(decomp-form cc) ,@(decomp-formlist forms))))
977
978(defdecomp (typed-form type-asserted-form) (op typespec form &optional check-p)
979  `(,op ',typespec ,(decomp-form form) ,@(and check-p (list check-p))))
980
981(defdecomp (%i+ %i-) (op form1 form2 &optional overflow-p)
982  `(,op ,(decomp-form form1) ,(decomp-form form2) ,overflow-p))
983
984(defdecomp (immediate-get-xxx %immediate-set-xxx) (op bits &rest forms)
985  `(,op ,bits ,@(decomp-formlist forms)))
986
987(defdecomp call (op fn arglist &optional spread-p)
988  (setq op (if spread-p 'apply 'funcall))
989  `(,op ,(decomp-form fn) ,@(decomp-arglist arglist)))
990
991(defdecomp lexical-function-call (op afunc arglist &optional spread-p)
992  (setq op (if *decomp-prettify*
993             (if spread-p 'apply 'funcall)
994             (if spread-p 'lexical-apply 'lexical-funcall)))
995  `(,op ,(decomp-afunc afunc) ,@(decomp-arglist arglist)))
996
997(defdecomp self-call (op arglist &optional spread-p)
998  (declare (Ignore op))
999  `(,(if spread-p 'self-apply 'self-funcall) ,@(decomp-arglist arglist)))
1000
1001(defdecomp (free-reference special-ref bound-special-ref global-ref) (op symbol)
1002  (if *decomp-prettify*
1003    (decomp-ref symbol)
1004    `(,op ,symbol)))
1005
1006(defdecomp (setq-special setq-free global-setq) (op symbol form)
1007  (when *decomp-prettify*
1008    (setq op 'setq))
1009  `(,op ,symbol ,(decomp-form form)))
1010
1011(defdecomp inherited-arg (op var)
1012  `(,op ,(decomp-var var)))
1013
1014(defdecomp lexical-reference (op var)
1015  (if *decomp-prettify*
1016    (decomp-var var)
1017    `(,op ,(decomp-var var))))
1018
1019(defdecomp setq-lexical (op var form)
1020  (when *decomp-prettify*
1021    (setq op 'setq))
1022  `(,op ,(decomp-var var) ,(decomp-form form)))
1023
1024(defdecomp (let let* with-downward-closures) (op vars vals body p2decls)
1025  (declare (ignore p2decls))
1026  `(,op ,(mapcar (lambda (var val) (list (decomp-var var) (decomp-form val))) vars vals)
1027    ,(decomp-form body)))
1028
1029(defdecomp %decls-body (op form p2decls)
1030  (declare (ignore p2decls))
1031  `(,op ,(decomp-form form)))
1032
1033(defdecomp multiple-value-bind (op vars form body p2decls)
1034  (declare (ignore p2decls))
1035  `(,op ,(mapcar #'decomp-var vars) ,(decomp-form form) ,(decomp-form body)))
1036
1037
1038(defdecomp lambda-list (op req opt rest keys auxen body p2decls &optional code-note)
1039  (declare (ignore p2decls code-note))
1040  (when *decomp-prettify*
1041    (setq op 'lambda))
1042  `(,op ,(decomp-lambda-list req opt rest keys auxen) ,(decomp-form body)))
1043
1044(defdecomp debind (op ll form req opt rest keys auxen whole body p2decls cdr-p)
1045  (declare (ignore ll p2decls cdr-p))
1046  `(,op ,(decomp-lambda-list req opt rest keys auxen whole) ,(decomp-form form) ,(decomp-form body)))
1047
1048(defdecomp lambda-bind (op vals req rest keys-p auxen body p2decls)
1049  (declare (ignore keys-p p2decls))
1050  (when (find-if #'fixnump (cadr auxen))
1051    (destructuring-bind (vars vals) auxen
1052      (setq auxen (list vars
1053                        (mapcar (lambda (x) (if (fixnump x) `(keyref ,x) x)) vals)))))
1054  (let ((lambda-list (decomp-lambda-list req nil rest nil  auxen)))
1055    `(,op ,lambda-list ,(decomp-formlist vals) ,(decomp-form body))))
1056
1057(defdecomp (flet labels) (op vars afuncs body p2decls)
1058  (declare (ignore p2decls))
1059  `(,op ,(mapcar (lambda (var afunc)
1060                            (list (decomp-var var) (decomp-afunc afunc)))
1061                          vars afuncs)
1062    ,(decomp-form body)))
1063
1064(defdecomp local-go (op tag)
1065  (when *decomp-prettify*
1066    (setq op 'go))
1067  `(,op ,(car tag)))
1068
1069(defdecomp tag-label (op &rest tag)
1070  (if *decomp-prettify*
1071    (decomp-ref (car tag))
1072    `(,op ,(car tag))))
1073
1074(defdecomp local-tagbody (op tags forms)
1075  (declare (ignore tags))
1076  (when *decomp-prettify*
1077    (setq op 'tagbody))
1078  `(,op ,@(decomp-formlist forms)))
1079
1080(defdecomp local-block (op block body)
1081  (when *decomp-prettify*
1082    (setq op 'block))
1083  `(,op ,(car block) ,(decomp-form body)))
1084
1085(defdecomp local-return-from (op block form)
1086  (when *decomp-prettify*
1087    (setq op 'return-from))
1088  `(,op ,(car block) ,(decomp-form form)))
1089
1090; end
Note: See TracBrowser for help on using the repository browser.