;;;-*- Mode: Lisp; Package: CCL -*-
;;;
;;;   Copyright (C) 2009 Clozure Associates
;;;   Copyright (C) 1994-2001 Digitool, Inc
;;;   This file is part of Clozure CL.  
;;;
;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
;;;   License , known as the LLGPL and distributed with Clozure CL as the
;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
;;;   conflict, the preamble takes precedence.  
;;;
;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
;;;
;;;   The LLGPL is also available online at
;;;   http://opensource.franz.com/preamble.html


;; used by compiler and eval - stuff here is not excised with rest of compiler


(in-package :ccl)

#|| Note: when MCL-AppGen 4.0 is built, the following form will need to be included in it:
; for compiler-special-form-p, called by cheap-eval-in-environment
(defparameter *nx1-compiler-special-forms*
  `(%DEFUN %FUNCTION %NEW-PTR %NEWGOTAG %PRIMITIVE %VREFLET BLOCK CATCH COMPILER-LET DEBIND
    DECLARE EVAL-WHEN FBIND FLET FUNCTION GO IF LABELS LAP LAP-INLINE LET LET* LOAD-TIME-VALUE
    LOCALLY MACRO-BIND MACROLET MAKE-LIST MULTIPLE-VALUE-BIND MULTIPLE-VALUE-CALL
    MULTIPLE-VALUE-LIST MULTIPLE-VALUE-PROG1 NEW-LAP NEW-LAP-INLINE NFUNCTION OLD-LAP
    OLD-LAP-INLINE OR PROG1 PROGN PROGV QUOTE RETURN-FROM SETQ STRUCT-REF STRUCT-SET
    SYMBOL-MACROLET TAGBODY THE THROW UNWIND-PROTECT WITH-STACK-DOUBLE-FLOATS WITHOUT-INTERRUPTS))
||#

(eval-when (:compile-toplevel)
  (require 'nxenv))

(defvar *lisp-compiler-version* 666 "I lost count.")

(defparameter *nx-32-bit-fixnum-type* '(signed-byte 30))
(defparameter *nx-64-bit-fixnum-type* '(signed-byte 61))
(defparameter *nx-32-bit-natural-type* '(unsigned-byte 32))
(defparameter *nx-64-bit-natural-type* '(unsigned-byte 64))
(defparameter *nx-target-fixnum-type* 'fixnum)

(defparameter *nx-target-natural-type*
  #+32-bit-target *nx-32-bit-natural-type*
  #+64-bit-target *nx-64-bit-natural-type*)

(defvar *nx-compile-time-types* nil)
(defvar *nx-proclaimed-types* nil)
(defvar *nx-method-warning-name* nil)

(defvar *nx-current-code-note*)

;; The problem with undefind type warnings is that there is no in-language way to shut
;; them up even when the reference is intentional.  (In case of undefined functions,
;; you can declare FTYPE and that will turn off any warnings without interfering with
;; the function being defined later).  For now just provide this as an out.
(defvar *compiler-warn-on-undefined-type-references* t)



;; In lieu of a slot in acode.  Don't reference this variable elsewhere because I'm
;; hoping to make it go away.
(defparameter *nx-acode-note-map* nil)

(defun acode-note (acode &aux (hash *nx-acode-note-map*))
  (and hash (gethash acode hash)))

(defun (setf acode-note) (note acode)
  (when note
    (assert *nx-acode-note-map*)
    ;; Only record if have a unique key
    (unless (or (atom acode)
                (nx-null acode)
                (nx-t acode))
      (setf (gethash acode *nx-acode-note-map*) note))))


(defstruct (code-note (:constructor %make-code-note))
  ;; Code coverage state.  This MUST be the first slot - see nx2-code-coverage.
  code-coverage
  ;; The source note of this form, or NIL if random code form (no file info,
  ;; generated by macros or other source transform)
  source-note
  ;; the note that was being compiled when this note was emitted.
  parent-note
  ;; start/end position in the acode string for the toplevel lfun containing this code note.
  acode-range
  #+debug-code-notes ;; The actual source form - useful for debugging, otherwise unused.
  form)

(defun make-code-note (&key form source-note parent-note)
  (declare (ignorable form))
  (let ((note (%make-code-note
               :source-note source-note
               :parent-note parent-note)))
    #+debug-code-notes
    (when form
      ;; Unfortunately, recording the macroexpanded form is problematic, since they
      ;; can have references to non-dumpable forms, see e.g. loop.
      (setf (code-note-form note)
	    (with-output-to-string (s) (let ((*print-circle* t)) (prin1 form s)))))
    note))

(defun code-note-acode-start-pos (note)
  (nth-value 0 (decode-file-range (code-note-acode-range note))))

(defun code-note-acode-end-pos (note)
  (nth-value 1 (decode-file-range (code-note-acode-range note))))

(defmethod print-object ((note code-note) stream)
  (print-unreadable-object (note stream :type t :identity t)
    (format stream "[~s]" (code-note-code-coverage note))
    (let ((sn (code-note-source-note note)))
      (if sn
        (progn
          (format stream " for ")
          (print-source-note sn stream))
        #+debug-code-notes
        (when (code-note-form note)
          (format stream " form ~a"
                  (string-sans-most-whitespace (code-note-form note))))))))

(defun nx-ensure-code-note (form &optional parent-note)
  (let* ((parent-note (or parent-note *nx-current-code-note*))
         (source-note (nx-source-note form)))
    (unless (and source-note
                 ;; Look out for a case like a lambda macro that turns (lambda ...)
                 ;; into (FUNCTION (lambda ...)) which then has (lambda ...)
                 ;; as a child.  Create a fresh note for the child, to avoid ambiguity.
                 ;; Another case is forms wrapping THE around themselves.
                 (neq source-note (code-note-source-note parent-note))
                 ;; Don't use source notes from a different toplevel form, which could
                 ;; happen due to inlining etc.  The result then is that the source note
                 ;; appears in multiple places, and shows partial coverage (from the
                 ;; other reference) in code that's never executed.
                 (loop for p = parent-note then (code-note-parent-note p)
                       when (null p) return t
                       when (code-note-source-note p)
                       return (eq (loop for n = source-note then s
                                        as s = (source-note-source n)
                                        unless (source-note-p s) return n)
                                  (loop for n = (code-note-source-note p) then s
                                        as s = (source-note-source n)
                                        unless (source-note-p s) return n))))
      (setq source-note nil))
    (make-code-note :form form :source-note source-note :parent-note parent-note)))

(defun nx-note-source-transformation (original new &aux (source-notes *nx-source-note-map*) sn)
  (when (and source-notes
             (setq sn (gethash original source-notes))
             (not (gethash new source-notes)))
    (setf (gethash new source-notes) sn)))


(defvar *nx1-alphatizers* (make-hash-table :size 180 :test #'eq))

(let ((policy (%istruct 'compiler-policy
               #'(lambda (env)
                   (neq (debug-optimize-quantity env) 3))   ;  allow-tail-recursion-elimination
               #'(lambda (env)
                   (eq (debug-optimize-quantity env) 3))   ; inhibit-register-allocation
               #'(lambda (env)
                   (let* ((safety (safety-optimize-quantity env)))
                     (and (< safety 3)
                          (>= (speed-optimize-quantity env)
                              safety)))) ; trust-declarations
               #'(lambda (env)
                   (>= (speed-optimize-quantity env)
		       (+ (space-optimize-quantity env) 2))) ; open-code-inline
               #'(lambda (env)
                   (and (eq (speed-optimize-quantity env) 3) 
                        (eq (safety-optimize-quantity env) 0)))   ; inhibit-safety-checking
               #'(lambda (env)
                   (let* ((safety (safety-optimize-quantity env)))
                     (or (eq safety 3)
                         (> safety (speed-optimize-quantity env)))))          ;declarations-typecheck
               #'(lambda (env)
                   (neq (debug-optimize-quantity env) 3))   ; inline-self-calls
               #'(lambda (env)
                   (and (neq (compilation-speed-optimize-quantity env) 3)
                        (or (neq (speed-optimize-quantity env) 0)
                            (and (neq (safety-optimize-quantity env) 3)
                                 (neq (debug-optimize-quantity env) 3))))) ; allow-transforms
               #'(lambda (var env)       ; force-boundp-checks
                   (declare (ignore var))
                   (eq (safety-optimize-quantity env) 3))
               #'(lambda (var val env)       ; allow-constant-substitution
                   (declare (ignore var val env))
                   t)
               `(:strict-structure-typechecking
                 ,(lambda (env)
                   (let* ((debug (debug-optimize-quantity env))
                          (safety (safety-optimize-quantity env))
                          (speed (speed-optimize-quantity env)))
                     (declare (fixnum debug safety speed))
                     (or (>= debug 2)
                         (>= safety 2)
                         (> debug speed)
                         (> safety speed))))) ; extensions
               )))
  (defun new-compiler-policy (&key (allow-tail-recursion-elimination nil atr-p)
                                   (inhibit-register-allocation nil ira-p)
                                   (trust-declarations nil td-p)
                                   (open-code-inline nil oci-p)
                                   (inhibit-safety-checking nil ischeck-p)
                                   (inline-self-calls nil iscall-p)
                                   (allow-transforms nil at-p)
                                   (force-boundp-checks nil fb-p)
                                   (allow-constant-substitution nil acs-p)
                                   (declarations-typecheck nil dt-p)
                                   (strict-structure-typechecking nil sst-p))
    (let ((p (copy-uvector policy)))
      (if atr-p (setf (policy.allow-tail-recursion-elimination p) allow-tail-recursion-elimination))
      (if ira-p (setf (policy.inhibit-register-allocation p) inhibit-register-allocation))
      (if td-p (setf (policy.trust-declarations p) trust-declarations))
      (if oci-p (setf (policy.open-code-inline p) open-code-inline))
      (if ischeck-p (setf (policy.inhibit-safety-checking p) inhibit-safety-checking))
      (if iscall-p (setf (policy.inline-self-calls p) inline-self-calls))
      (if at-p (setf (policy.allow-transforms p) allow-transforms))
      (if fb-p (setf (policy.force-boundp-checks p) force-boundp-checks))
      (if acs-p (setf (policy.allow-constant-substitution p) allow-constant-substitution))
      (if dt-p (setf (policy.declarations-typecheck p) declarations-typecheck))
      (if sst-p (setf (getf (policy.misc p) :strict-structure-typechecking) strict-structure-typechecking))
      p))
  (defun %default-compiler-policy () policy))

(%include "ccl:compiler;lambda-list.lisp")

;Syntactic Environment Access.

(defun declaration-information (decl-name &optional env)
  (if (and env (not (istruct-typep env 'lexical-environment)))
    (report-bad-arg env 'lexical-environment))
; *** This needs to deal with things defined with DEFINE-DECLARATION ***
  (case decl-name
    (optimize
     (list 
      (list 'speed (speed-optimize-quantity env))
      (list 'safety (safety-optimize-quantity env))
      (list 'compilation-speed (compilation-speed-optimize-quantity env))
      (list 'space (space-optimize-quantity env))
      (list 'debug (debug-optimize-quantity env))))
    (declaration
     *nx-known-declarations*)))

(defun function-information (name &optional env &aux decls)
  (let ((name (ensure-valid-function-name name)))
    (if (and env (not (istruct-typep env 'lexical-environment)))
      (report-bad-arg env 'lexical-environment))
    (if (special-operator-p name)
      (values :special-form nil nil)
      (flet ((process-new-fdecls (fdecls)
                                 (dolist (fdecl fdecls)
                                   (when (eq (car fdecl) name)
                                     (let ((decl-type (cadr fdecl)))
                                       (when (and (memq decl-type '(dynamic-extent inline ftype))
                                                  (not (assq decl-type decls)))
                                         (push (cdr fdecl) decls)))))))
        (declare (dynamic-extent #'process-new-fdecls))
        (do* ((root t)
              (contour env (when root (lexenv.parent-env contour))))
             ((null contour)
              (if (macro-function name)
                (values :macro nil nil)
                (if (fboundp name)
                  (values :function 
                          nil 
                          (if (assq 'inline decls)
			    decls
                            (if (proclaimed-inline-p name)
			      (push '(inline . inline) decls)
                                (if (proclaimed-notinline-p name)
				  (push '(inline . notinline) decls)))))
                  (values nil nil decls))))
          (if (istruct-typep contour 'definition-environment)
            (if (assq name (defenv.functions contour))
              (return (values :macro nil nil))
              (progn (setq root nil) (process-new-fdecls (defenv.fdecls contour))))
            (progn
              (process-new-fdecls (lexenv.fdecls contour))
              (let ((found (assq name (lexenv.functions contour))))
                (when found
                  (return
                   (if (and (consp (cdr found))(eq (%cadr found) 'macro))
                     (values :macro t nil)
                     (values :function t decls))))))))))))

(defun variable-information (var &optional env)
  (setq var (require-type var 'symbol))
  (if (and env (not (istruct-typep env 'lexical-environment)))
    (report-bad-arg env 'lexical-environment))
  (let* ((vartype nil)
         (boundp nil)
         (envtype nil)
         (typedecls (nx-declared-type var env)) ; should grovel nested/shadowed special decls for us.
         (decls (if (and typedecls (neq t typedecls)) (list (cons 'type typedecls)))))
    (loop
      (cond ((null env)
             (if (constant-symbol-p var)
               (setq vartype :constant decls nil)
               (if (proclaimed-special-p var)
                 (setq vartype :special)
		 (let* ((not-a-symbol-macro (cons nil nil)))
		   (declare (dynamic-extent not-a-symbol-macro))
		   (unless (eq (gethash var *symbol-macros* not-a-symbol-macro)
			       not-a-symbol-macro)
		     (setq vartype :symbol-macro)))))
             (return))
            ((eq (setq envtype (istruct-type-name env)) 'definition-environment)
             (cond ((assq var (defenv.constants env))
                    (setq vartype :constant)
                    (return))
		   ((assq var (defenv.symbol-macros env))
		    (setq vartype :symbol-macro)
		    (return))
                   ((assq var (defenv.specials env))
                    (setq vartype :special)
                    (return))))
            (t
             (dolist (vdecl (lexenv.vdecls env))
               (when (eq (car vdecl) var)
                 (let ((decltype (cadr vdecl)))
                   (unless (assq decltype decls)
                     (case decltype
                       (special (setq vartype :special))
                       ((type dynamic-extent ignore) (push (cdr vdecl) decls)))))))
             (let ((vars (lexenv.variables env)))
	       (unless (atom vars)
                 (dolist (v vars)
                   (when (eq (var-name v) var)
                     (setq boundp t)
                     (if (and (consp (var-ea v))
                              (eq :symbol-macro (car (var-ea v))))
                       (setq vartype :symbol-macro)
                       (unless vartype (setq vartype
					     (let* ((bits (var-bits v)))
					       (if (and (typep bits 'integer)
							(logbitp $vbitspecial bits))
						 :special
						 :lexical)))))
                     (return)))
		 (when vartype (return))))))
      (setq env (if (eq envtype 'lexical-environment) (lexenv.parent-env env))))
    (values vartype boundp decls)))

(defun nx-target-type (typespec)
  ;; Could do a lot more here
  (if (or (eq *host-backend* *target-backend*)
          (not (eq typespec 'fixnum)))
    typespec
    (target-word-size-case
     (32 '(signed-byte 30))
     (64 '(signed-byte 61)))))

; Type declarations affect all references.
(defun nx-declared-type (sym &optional (env *nx-lexical-environment*))
  (loop
    (when (or (null env) (istruct-typep env 'definition-environment)) (return))
    (dolist (decl (lexenv.vdecls env))
      (if (and (eq (car decl) sym)
               (eq (cadr decl) 'type))
               (return-from nx-declared-type (nx-target-type (cddr decl)))))
    (let ((vars (lexenv.variables env)))
      (when (and (consp vars) 
                 (dolist (var vars) 
                   (when (eq (var-name var) sym) 
                     (return t))))
        (return-from nx-declared-type t)))
    (setq env (lexenv.parent-env env)))
  (let ((decl (or (assq sym *nx-compile-time-types*)
                     (assq sym *nx-proclaimed-types*))))
    (if decl (%cdr decl) t)))

(defun nx-declared-result-type (sym &optional (env *nx-lexical-environment*) args)
  (when (symbolp (setq sym (maybe-setf-function-name sym)))
    (let* ((ftype (find-ftype-decl sym env args))
	   (ctype (and ftype (if (typep ftype 'ctype) ftype (specifier-type-if-known ftype env)))))
      (unless (or (null ctype)
		  (not (function-ctype-p ctype))
		  (eq *wild-type* (function-ctype-returns ctype)))
	(let ((result-type (type-specifier (single-value-type (function-ctype-returns ctype)))))
	  (and (neq result-type 't) result-type))))))

(defmacro define-declaration (decl-name lambda-list &body body &environment env)
  (multiple-value-bind (body decls)
                       (parse-body body env)
    (let ((fn `(nfunction (define-declaration ,decl-name)
                          (lambda ,lambda-list
                            ,@decls
                            (block ,decl-name
                              ,@body)))))
      `(progn
         (proclaim '(declaration ,decl-name))
         (setf (getf *declaration-handlers* ',decl-name) ,fn)))))

(defun check-environment-args (variable symbol-macro function macro)
  (flet ((check-all-pairs (pairlist argname)
          (dolist (pair pairlist)
            (unless (and (consp pair) (consp (%cdr pair)) (null (%cddr pair)) (symbolp (%car pair)))
              (signal-simple-program-error "Malformed ~s argument: ~s is not of the form (~S ~S) in ~S" 
                                           argname
                                           pair
                                           'name
                                           'definition
                                           pairlist))))
         (check-all-symbols (symlist argname pairs pairsname)
          (dolist (v symlist)
            (if (symbolp v)
              (when (assq v pairs) 
                (signal-simple-program-error "~S ~S conflicts with ~S ~S" argname v pairsname (assq v pairs)))
              (if (eq argname :function)
                (unless (valid-function-name-p v)
                  (signal-simple-program-error "Malformed ~S list: ~S is not a function name in ~S." argname v symlist))
                (signal-simple-program-error "Malformed ~S list: ~S is not a symbol in ~S." argname v symlist))))))
    (check-all-pairs symbol-macro :symbol-macro)
    (check-all-pairs macro :macro)
    (check-all-symbols variable :variable symbol-macro :symbol-macro)
    (check-all-symbols function :function macro :macro)))


;; This -isn't- PARSE-DECLARATIONS.  It can't work; neither can this ...
(defun process-declarations (env decls symbol-macros)
  (let ((vdecls nil)
        (fdecls nil)
        (mdecls nil))
    (flet ((add-type-decl (spec)
            (destructuring-bind (typespec &rest vars) spec
              (dolist (var vars)
                (when (non-nil-symbol-p var)
                  (push (list* var 
                               'type
                               (let ((already (assq 'type (nth-value 2 (variable-information var env)))))
                                 (if already
                                   (let ((oldtype (%cdr already)))
                                     (if oldtype
                                       (if (subtypep oldtype typespec)
                                         oldtype
                                         (if (subtypep typespec oldtype)
                                           typespec))))
                                   typespec)))
                        vdecls))))))
      ; do SPECIAL declarations first - this approximates the right thing, but doesn't quite make it.
      (dolist (decl decls)
        (when (eq (car decl) 'special)
          (dolist (spec (%cdr decl))
            (when (non-nil-symbol-p spec)
              (if (assq spec symbol-macros)
                (signal-program-error "Special declaration cannot be applied to symbol-macro ~S" spec))
              (push (list* spec 'special t) vdecls)))))
      (dolist (decl decls)
        (let ((decltype (car decl)))
          (case decltype
              ((inline notinline)
               (dolist (spec (%cdr decl))
               (let ((fname nil))
                 (if (non-nil-symbol-p spec)
                   (setq fname spec)
                   (if (setf-function-name-p spec)
                     (setq fname (setf-function-name (cadr spec)))))
                 (if fname
                   (push (list* fname decltype t) fdecls)))))
              (optimize
               (dolist (spec (%cdr decl))
                 (let ((val 3)
                       (quantity spec))
                   (if (consp spec)
                     (setq quantity (car spec) val (cadr spec)))
                 (if (and (fixnump val) (<= 0 val 3) (memq quantity '(debug speed space safety compilation-speed)))
                   (push (cons quantity val) mdecls)))))
              (dynamic-extent
               (dolist (spec (%cdr decl))
               (if (non-nil-symbol-p spec)
                 (push (list* spec decltype t) vdecls)
                 (if (and (consp spec) (eq (%car spec) 'function))
                   (let ((fname (cadr spec)))
                     (if (not (non-nil-symbol-p fname))
                       (setq fname 
                             (if (setf-function-name-p fname)
                               (setf-function-name (cadr fname)))))
                     (if fname (push (list* fname decltype t) fdecls)))))))
              (type (add-type-decl (cdr decl)))
              (ftype (destructuring-bind (typespec &rest fnames) (%cdr decl)
                       (dolist (name fnames)
                         (let ((fname name))
                           (if (not (non-nil-symbol-p fname))
                             (setq fname 
                                   (if (setf-function-name-p fname)
                                     (setf-function-name (cadr fname)))))
                           (if fname (push (list* fname decltype typespec) fdecls))))))
              (special)
              (t
               (if (memq decltype *cl-types*)
                 (add-type-decl decl)
                 (let ((handler (getf *declaration-handlers* decltype)))
                   (when handler
                     (multiple-value-bind (type info) (funcall handler decl)
                       (ecase type
                         (:variable
                          (dolist (v info) (push (apply #'list* v) vdecls)))
                         (:function
                          (dolist (f info) (push (apply #'list* f) fdecls)))
                         (:declare  ;; N.B. CLtL/2 semantics
                          (push info mdecls)))))))))))
      (setf (lexenv.vdecls env) (nconc vdecls (lexenv.vdecls env))
            (lexenv.fdecls env) (nconc fdecls (lexenv.fdecls env))
            (lexenv.mdecls env) (nconc mdecls (lexenv.mdecls env))))))

 
(defun nx-cons-var (name &optional (bits 0))
  (%istruct 'var name bits nil nil nil nil 0 nil nil 0 0 nil 0))



(defun augment-environment (env &key variable symbol-macro function macro declare)
  (if (and env (not (istruct-typep env 'lexical-environment)))
    (report-bad-arg env 'lexical-environment))
  (check-environment-args variable symbol-macro function macro)
  (let* ((vars (mapcar #'nx-cons-var variable))
         (symbol-macros (mapcar #'(lambda (s)
				    (let* ((sym (car s)))
				      (unless (and (symbolp sym)
						   (not (constantp sym env))
						   (not (eq (variable-information sym env) :special)))
					(signal-program-error "~S can't by bound as a SYMBOL-MACRO" sym))
				      (let ((v (nx-cons-var (car s)))) 
					(setf (var-expansion v) (cons :symbol-macro (cadr s)))
					v)))
				symbol-macro))
         (macros (mapcar #'(lambda (m) (list* (car m) 'macro (cadr m))) macro))
         (functions (mapcar #'(lambda (f) (list* (ensure-valid-function-name f) 'function nil)) function))
         (new-env (new-lexical-environment env)))
    (setf (lexenv.variables new-env) (nconc vars symbol-macros)
          (lexenv.functions new-env) (nconc functions macros))
    (process-declarations new-env declare symbol-macro)
    new-env))

(defun enclose (lambda-expression &optional env)
  (if (and env (not (istruct-typep env 'lexical-environment)))
    (report-bad-arg env 'lexical-environment))
  (unless (lambda-expression-p lambda-expression)
    (error "Invalid lambda-expression ~S." lambda-expression))
  (%make-function nil lambda-expression env))

#|| Might be nicer to do %declaim
(defmacro declaim (&rest decl-specs &environment env)
  `(progn
     (eval-when (:load-toplevel :execute)
       (proclaim ',@decl-specs))
     (eval-when (:compile-toplevel)
       (%declaim ',@decl-specs ,env))))
||#

(defmacro declaim (&environment env &rest decl-specs)
  "DECLAIM Declaration*
  Do a declaration or declarations for the global environment."
  (let* ((body (mapcar #'(lambda (spec) `(proclaim ',spec)) decl-specs)))
  `(progn
     (eval-when (:compile-toplevel)
       (compile-time-proclamation ',decl-specs ,env))
     (eval-when (:load-toplevel :execute)
       ,@body))))

(defvar *strict-checking* nil
  "If true, issues warnings/errors in more cases, e.g. for valid but non-portable code")


;; Should be true if compiler warnings UI doesn't use source locations, false if it does.
(defvar *merge-compiler-warnings* t "If false, don't merge compiler warnings with different source locations")

;;; If warnings have more than a single entry on their
;;; args slot, don't merge them.
(defun merge-compiler-warnings (old-warnings)
  (let ((warnings nil))
    (dolist (w old-warnings)
      (let* ((w-args (compiler-warning-args w)))
        (if
          (or (cdr w-args)
              ;; See if W can be merged into an existing warning
              (dolist (w1 warnings t) 
                (let ((w1-args (compiler-warning-args w1)))
                  (when (and (eq (compiler-warning-warning-type w)
                                 (compiler-warning-warning-type w1))
                             w1-args
                             (null (cdr w1-args))
                             (eq (%car w-args)
                                 (%car w1-args))
                             (or *merge-compiler-warnings*
                                 (eq (compiler-warning-source-note w)
                                     (compiler-warning-source-note w1))))
                    (let ((nrefs (compiler-warning-nrefs w1)))
                      (when (null nrefs)
                        (let ((s1 (compiler-warning-source-note w1)))
                          (when s1
                            (setq nrefs (list s1)))))
                      (let ((s (compiler-warning-source-note w)))
                        (when s (push s nrefs)))
                      (setf (compiler-warning-nrefs w1) nrefs)
                      (return nil))))))
          (push w warnings))))
    warnings))

;;; This is called by, e.g., note-function-info & so can't be -too- funky ...
;;; don't call proclaimed-inline-p or proclaimed-notinline-p with alphatized crap

(defun nx-declared-inline-p (sym env)
  (setq sym (maybe-setf-function-name sym))
  (loop
    (when (listp env)
      (return (and (symbolp sym)
                   (proclaimed-inline-p sym))))
    (dolist (decl (lexenv.fdecls env))
      (when (and (eq (car decl) sym)
                 (eq (cadr decl) 'inline))
        (return-from nx-declared-inline-p (eq (cddr decl) 'inline))))
    (when (assq sym (lexenv.functions env))
      (return nil))
    (setq env (lexenv.parent-env env))))

(defun report-compile-time-argument-mismatch (condition stream &aux (type (compiler-warning-warning-type condition)))
  (destructuring-bind (callee reason args spread-p)
      (compiler-warning-args condition)
    (format stream "In the ~a ~s with arguments ~:s,~%  "
            (if spread-p "application of" "call to")
            callee
            args)
    (ecase (car reason)
      (:toomany
       (destructuring-bind (provided max)
           (cdr reason)
         (format stream "~d argument~:p ~:*~[were~;was~:;were~] provided, but at most ~d ~:*~[are~;is~:;are~] accepted~&  by " provided max)))
      (:toofew
       (destructuring-bind (provided min)
           (cdr reason)
	 (format stream "~d argument~:p ~:*~[were~;was~:;were~] provided, but at least ~d ~:*~[are~;is~:;are~] required~&  by " provided min)))
      (:odd-keywords
       (let* ((tail (cadr reason)))
         (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)))
      (:unknown-keyword
       (destructuring-bind (badguy goodguys)
           (cdr reason)
         (format stream "the keyword argument~:[ ~s is~;s~{ ~s~^~#[~; and~:;,~]~} are~] not one of ~:s, which are recognized by "
		 (consp badguy) badguy goodguys)))
      (:unknown-gf-keywords
         (let ((badguys (cadr reason)))
           (when (and (consp badguys) (null (%cdr badguys))) (setq badguys (car badguys)))
           (format stream "the keyword argument~:[ ~s is~;s~{ ~s~^~#[~; and~:;,~]~} are~] not recognized by "

                   (consp badguys) badguys))))
    (format stream
            (ecase type
	      (:ftype-mismatch "the FTYPE declaration of ~s")
              (:global-mismatch "the current global definition of ~s")
              (:environment-mismatch "the definition of ~s visible in the current compilation unit.")
              (:lexical-mismatch "the lexically visible definition of ~s")
              ;; This can happen when compiling without compilation unit:
              (:deferred-mismatch "~s"))
            callee)))

(defparameter *compiler-warning-formats*
  '((:special . "Undeclared free variable ~S")
    (:unused . "Unused lexical variable ~S")
    (:ignore . "Variable ~S not ignored.")
    (:undefined-function . "Undefined function ~S") ;; (deferred)
    (:undefined-type . "Undefined type ~S")         ;; (deferred)
    (:unknown-type-in-declaration . "Unknown type ~S, declaration ignored")
    (:bad-declaration . "Unknown or invalid declaration ~S")
    (:invalid-type . report-invalid-type-compiler-warning)
    (:unknown-declaration-variable . "~s declaration for unknown variable ~s")
    (:unknown-declaration-function . "~s declaration for unknown function ~s")
    (:macro-used-before-definition . "Macro function ~S was used before it was defined.")
    (:unsettable . "Shouldn't assign to variable ~S")
    (:global-mismatch . report-compile-time-argument-mismatch)
    (:environment-mismatch . report-compile-time-argument-mismatch)
    (:lexical-mismatch . report-compile-time-argument-mismatch)    
    (:ftype-mismatch . report-compile-time-argument-mismatch)
    (:deferred-mismatch . report-compile-time-argument-mismatch)
    (:type . "Type declarations violated in ~S")
    (:type-conflict . "Conflicting type declarations for ~S")
    (:special-fbinding . "Attempt to bind compiler special name: ~s. Result undefined.")
    (:lambda . "Suspicious lambda-list: ~s")
    (:incongruent-gf-lambda-list . "Lambda list of generic function ~s is incongruent with previously defined methods")
    (:incongruent-method-lambda-list . "Lambda list of ~s is incongruent with previous definition of ~s")
    (:gf-keys-not-accepted . "~s does not accept keywords ~s required by the generic functions")
    (:result-ignored . "Function result ignored in call to ~s")
    (:duplicate-definition . report-compile-time-duplicate-definition)
    (:format-error . "~:{~@?~%~}")
    (:program-error . "~a")
    (:unsure . "Nonspecific warning")
    (:duplicate-binding . "Multiple bindings of ~S in ~A form")
    (:shadow-cl-package-definition . "Local function or macro name ~s shadows standard CL definition.")))

(defun report-invalid-type-compiler-warning (condition stream)
  (destructuring-bind (type &optional why) (compiler-warning-args condition)
    (when (typep why 'invalid-type-specifier)
      (setq type (invalid-type-specifier-typespec why) why nil))
    (format stream "Invalid type specifier ~S~@[: ~A~]" type why)))

(defun report-compile-time-duplicate-definition (condition stream)
  (destructuring-bind (name old-file new-file &optional from to) (compiler-warning-args condition)
    (format stream
            "Duplicate definitions of ~s~:[~*~;~:* (as a ~a and a ~a)~]~:[~;, in this file~:[~; and in ~s~]~]"
            (maybe-setf-name name) from to
            (and old-file new-file)
            (neq old-file new-file)
            old-file)))

(defun adjust-compiler-warning-args (warning-type args)
  (case warning-type
    ((:undefined-function :result-ignored) (mapcar #'maybe-setf-name args))
    (t args)))


(defun report-compiler-warning (condition stream &key short)
  (let* ((warning-type (compiler-warning-warning-type condition))
         (format-string (cdr (assq warning-type *compiler-warning-formats*)))
         (warning-args (compiler-warning-args condition)))
    (unless short
      (let ((name (reverse (compiler-warning-function-name condition))))
        (format stream "In ")
        (print-nested-name name stream)
        (when (every #'null name)
          (let ((position (source-note-start-pos (compiler-warning-source-note condition))))
            (when position (format stream " at position ~s" position))))
        (format stream ": ")))
    (if (typep format-string 'string)
      (apply #'format stream format-string (adjust-compiler-warning-args warning-type warning-args))
      (if (null format-string)
	(format stream "~A: ~S" warning-type warning-args)
	(funcall format-string condition stream)))
    ;(format stream ".")
    (let ((nrefs (compiler-warning-nrefs condition)))
      (when nrefs
        (format stream " (~D references)" (length nrefs))))))

(defun environment-structref-info (name env)
  (let ((defenv (definition-environment env)))
    (when defenv
      (cdr (assq name (defenv.structrefs defenv))))))

 ;; can be removed once new images are checked in
#-BOOTSTRAPPED
(unless (fboundp 'structref-info)
  (fset 'structref-info
        (nlambda boostrapping-structref-info (sym &optional env)
                 (or (and env (environment-structref-info sym env))
                     (gethash sym %structure-refs%)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;  For code coverage, pretty-print acode to string and store position info in code notes.
;;
;;  decomp-acode can also be used separately for debugging.
;;
(defmacro dbg-assert (form)
  #-debug-code-notes (declare (ignore form))
  #+debug-code-notes `(unless ,form (cerror "Ignore assertion failure"
                                            "Assertion failure: ~s" ',form)))

(defvar *acode-right-margin* 120)
(defvar *nx-pprint-stream* nil)
(defvar *nx-acode-inner-refs* :default)
(defvar *nx-acode-refs-counter* 0)

(defun nx-pprinting-p (stream)
  (and *nx-pprint-stream*
       (typep stream 'xp-stream)
       (slot-value stream 'xp-structure)
       (eq *nx-pprint-stream* (xp-base-stream (slot-value stream 'xp-structure)))))

(defstruct acode-ref
  object)

(defstruct (acode-afunc-ref (:include acode-ref))
  afunc
  index)

(defun nx-record-code-coverage-acode (afunc)
  (assert *nx-current-code-note*)
  (let ((form->note (make-hash-table :test #'eq)))
    (labels ((decomp-hook (acode form &aux (note (acode-note acode)))
               ;; For expressions within without-compiling-code-coverage, there is a source
               ;; note and not a code note, so need to check for code note explicitly.
               (when (code-note-p note)
                 (dbg-assert (eq note (gethash form form->note note)))
                 (dbg-assert (null (code-note-acode-range note)))
                 (setf (gethash form form->note) note)))
             (print-hook (form open-p pos)
               (let* ((note (gethash form form->note))
                      (range (and note (code-note-acode-range note))))
                 (when note
                   (cond (open-p
                          (dbg-assert (null range))
                          (setf (code-note-acode-range note)
                                (encode-file-range pos pos)))
                         (t
                          (dbg-assert (not (null range)))
                          (multiple-value-bind (start end)
                              (decode-file-range range)
                            (declare (ignorable end))
                            (dbg-assert (eq start end))
                            (setf (code-note-acode-range note)
                                  (encode-file-range start pos))))))))
             (stringify (acode)
               (let* ((*nx-acode-refs-counter* 0)
                      (form (decomp-acode acode :prettify t :hook #'decomp-hook))
                      (package *package*))
                 (with-standard-io-syntax
                     (with-output-to-string (*nx-pprint-stream*)
                       (let* ((*package* package)
                              (*print-right-margin* *acode-right-margin*)
                              (*print-case* :downcase)
                              (*print-readably* nil))
                         (pprint-recording-positions form *nx-pprint-stream* #'print-hook))))))
             (record (afunc)
               (let* ((*nx-acode-inner-refs* nil);; filled in by stringify.
                      (string (stringify (afunc-acode afunc)))
                      ;; Can't use with-output-to-vector directly above because we
                      ;; want the recorded positions to be relative to the string.
                      (vec (encode-string-to-octets string :external-format :utf-8)))
                 (setf (getf (afunc-lfun-info afunc) '%function-acode-string) vec)
                 (loop for ref in *nx-acode-inner-refs* as fn = (acode-afunc-ref-afunc ref)
                       do (dbg-assert (null (getf (afunc-lfun-info fn) '%function-acode-string)))
                       do (setf (getf (afunc-lfun-info fn) '%function-acode-string) vec)))))
      (if (getf (afunc-lfun-info afunc) '%function-source-note)
        (record afunc)
        ;; If don't have a function source note while recording code coverage, it's
        ;; probably a toplevel function consed up by the file compiler.  Don't store it,
        ;; as it just confuses things
        (loop for inner in (afunc-inner-functions afunc) do (record inner)))))
  afunc)

(defmethod print-object ((ref acode-afunc-ref) stream)
  (if (nx-pprinting-p stream)
    (let ((index (acode-afunc-ref-index ref)))
      (when index ;; referenced multiple times.
        (if (eql index 0)  ;; never referenced before?
          (format stream "#~d=" 
                  (setf (acode-afunc-ref-index ref) (incf *nx-acode-refs-counter*)))
          ;; If not first reference, just point back.
          (return-from print-object (format stream "#~d#" index))))
      (write-1 (acode-afunc-ref-object ref) stream))
    (call-next-method)))

(defmethod print-object ((ref acode-ref) stream)
  (if (nx-pprinting-p stream)
    (write-1 (acode-ref-object ref) stream)
    (call-next-method)))

(defun decomp-ref (obj)
  (if (and (listp *nx-acode-inner-refs*) ;; code coverage case
           (not (acode-p obj)))
    (make-acode-ref :object obj)
    obj))

(defvar *decomp-prettify* nil "If true, loses info but results in more recognizable lisp")

(defvar *decomp-hook* nil)

(defun decomp-acode (acode &key (hook *decomp-hook*) (prettify *decomp-prettify*))
  (let ((*decomp-hook* hook)
        (*decomp-prettify* prettify))
    (decomp-form acode)))

(defun decomp-form (acode)
  (cond ((nx-t acode) t)
        ((nx-null acode) nil)
        (t (let* ((op (car acode))
                  (num (length *next-nx-operators*))
                  (name (when (and (fixnump op)
                                   (<= 0 op)
                                   (setq op (logand op operator-id-mask))
                                   (< op num))
                          (car (nth (- num op 1) *next-nx-operators*))))
                  (new (decomp-using-name (or name op) acode)))
             (when *decomp-hook*
               (funcall *decomp-hook* acode new))
             new))))


(defun decomp-afunc (afunc)
  (setq afunc (require-type afunc 'afunc))
  (dbg-assert (afunc-acode afunc))
  (if (listp *nx-acode-inner-refs*)    ;; code coverage case
      (let ((ref (find afunc *nx-acode-inner-refs* :key #'acode-afunc-ref-afunc)))
	(if ref ;; seen before, mark that multiply referenced.
	    (setf (acode-afunc-ref-index ref) 0)
            (progn
              (push (setq ref (make-acode-afunc-ref :afunc afunc)) *nx-acode-inner-refs*)
              (setf (acode-afunc-ref-object ref) (decomp-form (afunc-acode afunc)))))
	ref)
      afunc))

(defun decomp-var (var)
  (decomp-ref (var-name (require-type var 'var))))

(defun decomp-formlist (formlist)
  (mapcar #'decomp-form formlist))

(defun decomp-arglist (arglist)
  (destructuring-bind (stack-forms register-forms) arglist
    (nconc (decomp-formlist stack-forms)
           (nreverse (decomp-formlist register-forms)))))

(defun decomp-lambda-list (req opt rest keys auxen &optional whole)
  (flet ((decomp-arg (var)
           (if (acode-p var)
             (destructuring-bind (op whole req opt rest keys auxen) var
               (assert (eq op (%nx1-operator lambda-list))) ;; fake
               (decomp-lambda-list req opt rest keys auxen whole))
             (decomp-var var))))
    (let ((whole (and whole (list '&whole (decomp-arg whole))))
          (reqs (mapcar #'decomp-arg req))
          (opts (when opt (cons '&optional (apply #'mapcar
                                                  (lambda (var init supp)
                                                    (if (and (not supp) (nx-null init))
                                                      (decomp-arg var)
                                                      (list* (decomp-arg var)
                                                             (decomp-form init)
                                                             (and supp (list (decomp-arg supp))))))
                                                  opt))))
          (rest (when rest (list '&rest (decomp-arg rest))))
          (keys (when keys
                  (destructuring-bind (aok vars supps inits keyvect) keys
                    (nconc
                     (when vars
                       (cons '&key (map 'list (lambda (var supp init key)
                                                (let* ((sym (decomp-arg var))
                                                       (arg (if (and (symbolp sym) (eq (make-keyword sym) key))
                                                              sym
                                                              (list key sym))))
                                                  (if (and (not supp) (nx-null init) (eq arg sym))
                                                    sym
                                                    (list* arg
                                                           (decomp-form init)
                                                           (and supp (list (decomp-arg supp)))))))
                                        vars supps inits keyvect)))
                     (when aok (list '&allow-other-keys))))))
          (auxen (when (car auxen)
                   (cons '&aux (apply #'mapcar
                                      (lambda (var init)
                                        (if (nx-null init)
                                          (decomp-arg var)
                                          (list (decomp-arg var) (decomp-form init))))
                                      auxen)))))
      (nconc whole reqs opts rest keys auxen))))

(defmacro defdecomp (names arglist &body body)
  (let ((op-var (car arglist))
        (args-vars (cdr arglist))
        (acode-var (gensym))
        (op-decls nil))
    (when (eq op-var '&whole)
      (setq acode-var (pop args-vars))
      (setq op-var (pop args-vars)))
    (multiple-value-bind (body decls) (parse-body body nil)
    ;; Kludge but good enuff for here
      (setq decls (loop for decl in decls
                    collect (cons (car decl)
                                  (loop for exp in (cdr decl)
                                    do (when (and (consp exp) (member op-var (cdr exp)))
                                         (push (list (car exp) op-var) op-decls))
                                    collect (cons (car exp) (remove op-var (cdr exp)))))))
    `(progn
       ,@(loop for name in (if (atom names) (list names) names)
           collect `(defmethod decomp-using-name ((,op-var (eql ',name)) ,acode-var)
                      (declare ,@op-decls)
                      (destructuring-bind ,args-vars (cdr ,acode-var)
                        ,@decls
                        ,@body)))))))

;; Default method
(defmethod decomp-using-name (op acode)
  `(,op ,@(decomp-formlist (cdr acode))))

;; not real op, kludge generated below for lambda-bind
(defdecomp keyref (op index)
  `(,op ,index))

(defdecomp immediate (op imm)
  (when *decomp-prettify*
    (setq op 'quote))
  `(,op ,imm))

(defdecomp fixnum (op raw-fixnum)
  (declare (ignore op))
  (decomp-ref raw-fixnum))

(defdecomp %function (op symbol)
  (when *decomp-prettify*
    (setq op 'function))
  `(,op ,symbol))

(defdecomp simple-function (op afunc)
  (when *decomp-prettify*
    (setq op 'function))
  `(,op ,(decomp-afunc afunc)))

(defdecomp closed-function (op afunc)
  (when *decomp-prettify*
    (setq op 'function))
  `(,op ,(decomp-afunc afunc)))

(defun decomp-replace (from-form to-form)
  (let ((note (acode-note from-form)))
    (unless (and note (acode-note to-form))
      (when note
        (setf (acode-note to-form) note))
      t)))
           
(defdecomp progn (&whole form op form-list)
  (if (and *decomp-prettify*
           (null (cdr form-list))
           (decomp-replace form (car form-list)))
    (decomp-form (car form-list))
    `(,op ,@(decomp-formlist form-list))))

(defdecomp (prog1 multiple-value-prog1 or list %temp-list values) (op form-list)
  `(,op ,@(decomp-formlist form-list)))

(defdecomp multiple-value-call (op fn form-list)
  `(,op ,(decomp-form fn) ,@(decomp-formlist form-list)))

(defdecomp vector (op formlist)
  `(,op ,@(decomp-formlist formlist)))

(defdecomp (%gvector list* %err-disp) (op arglist)
  `(,op ,@(decomp-arglist arglist)))

(defdecomp (i386-syscall syscall eabi-syscall poweropen-syscall
            i386-ff-call ff-call eabi-ff-call poweropen-ff-call)
           (op target argspecs argvals resultspec &rest rest)
  `(,op
    ,(decomp-form target)
    ,@(mapcan (lambda (spec val) (list spec (decomp-form val))) argspecs argvals)
    ,resultspec
    ,@rest))

(defdecomp (consp characterp istruct-typep %ptr-eql int>0-p %izerop endp eq %ilogbitp %base-char-p not neq) (op cc &rest forms)
  (if (eq (acode-immediate-operand cc) :eq)
    `(,op ,@(decomp-formlist forms))
    `(,op ,(decomp-form cc) ,@(decomp-formlist forms))))

(defdecomp (typed-form type-asserted-form) (&whole whole op typespec form &optional check-p)
  (if (and *decomp-prettify*
           (not check-p)
           (decomp-replace whole form))
    (decomp-form form)
    `(,op ',typespec ,(decomp-form form) ,@(and check-p (list check-p)))))

(defdecomp (%i+ %i-) (op form1 form2 &optional overflow-p)
  `(,op ,(decomp-form form1) ,(decomp-form form2) ,overflow-p))

(defdecomp (immediate-get-xxx %immediate-set-xxx) (op bits &rest forms)
  `(,op ,bits ,@(decomp-formlist forms)))

(defdecomp (builtin-call call) (op fn arglist &optional spread-p)
  (setq op (if spread-p 'apply 'funcall))
  `(,op ,(decomp-form fn) ,@(decomp-arglist arglist)))

(defdecomp lexical-function-call (op afunc arglist &optional spread-p)
  (setq op (if *decomp-prettify*
             (if spread-p 'apply 'funcall)
             (if spread-p 'lexical-apply 'lexical-funcall)))
  `(,op ,(decomp-afunc afunc) ,@(decomp-arglist arglist)))

(defdecomp self-call (op arglist &optional spread-p)
  (declare (Ignore op))
  `(,(if spread-p 'self-apply 'self-funcall) ,@(decomp-arglist arglist)))

(defdecomp (free-reference special-ref bound-special-ref global-ref) (op symbol)
  (if *decomp-prettify*
    (decomp-ref symbol)
    `(,op ,symbol)))

(defdecomp (setq-special setq-free global-setq) (op symbol form)
  (when *decomp-prettify*
    (setq op 'setq))
  `(,op ,symbol ,(decomp-form form)))

(defdecomp inherited-arg (op var)
  `(,op ,(decomp-var var)))

(defdecomp lexical-reference (op var)
  (if *decomp-prettify*
    (decomp-var var)
    `(,op ,(decomp-var var))))

(defdecomp setq-lexical (op var form)
  (when *decomp-prettify*
    (setq op 'setq))
  `(,op ,(decomp-var var) ,(decomp-form form)))

(defdecomp (let let* with-downward-closures) (op vars vals body p2decls)
  (declare (ignore p2decls))
  `(,op ,(mapcar (lambda (var val) (list (decomp-var var) (decomp-form val))) vars vals)
    ,(decomp-form body)))

(defdecomp %decls-body (op form p2decls)
  (declare (ignore p2decls))
  `(,op ,(decomp-form form)))

(defdecomp multiple-value-bind (op vars form body p2decls)
  (declare (ignore p2decls))
  `(,op ,(mapcar #'decomp-var vars) ,(decomp-form form) ,(decomp-form body)))


(defdecomp lambda-list (op req opt rest keys auxen body p2decls &optional code-note)
  (declare (ignore p2decls code-note))
  (when *decomp-prettify*
    (setq op 'lambda))
  `(,op ,(decomp-lambda-list req opt rest keys auxen) ,(decomp-form body)))

(defdecomp debind (op ll form req opt rest keys auxen whole body p2decls cdr-p)
  (declare (ignore ll p2decls cdr-p))
  `(,op ,(decomp-lambda-list req opt rest keys auxen whole) ,(decomp-form form) ,(decomp-form body)))

(defdecomp lambda-bind (op vals req rest keys-p auxen body p2decls)
  (declare (ignore keys-p p2decls))
  (when (find-if #'fixnump (cadr auxen))
    (destructuring-bind (vars vals) auxen
      (setq auxen (list vars
			(mapcar (lambda (x) (if (fixnump x) `(keyref ,x) x)) vals)))))
  (let ((lambda-list (decomp-lambda-list req nil rest nil  auxen)))
    `(,op ,lambda-list ,(decomp-formlist vals) ,(decomp-form body))))

(defdecomp (flet labels) (op vars afuncs body p2decls)
  (declare (ignore p2decls))
  `(,op ,(mapcar (lambda (var afunc)
                            (list (decomp-var var) (decomp-afunc afunc)))
                          vars afuncs)
    ,(decomp-form body)))

(defdecomp local-go (op tag)
  (when *decomp-prettify*
    (setq op 'go))
  `(,op ,(car tag)))

(defdecomp tag-label (op &rest tag)
  (if *decomp-prettify*
    (decomp-ref (car tag))
    `(,op ,(car tag))))

(defdecomp local-tagbody (op tags forms)
  (declare (ignore tags))
  (when *decomp-prettify*
    (setq op 'tagbody))
  `(,op ,@(decomp-formlist forms)))

(defdecomp local-block (op block body)
  (when *decomp-prettify*
    (setq op 'block))
  `(,op ,(car block) ,(decomp-form body)))

(defdecomp local-return-from (op block form)
  (when *decomp-prettify*
    (setq op 'return-from))
  `(,op ,(car block) ,(decomp-form form)))

; end