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

Last change on this file since 15314 was 15314, checked in by gb, 8 years ago

Warn (via full warning) on duplicate bindings in SYMBOL-MACROLET,
MACROLET, FLET, LABELS (fixes ticket:927.)

If a DECLARE expression is encountered when a form is expected,
make the error message more verbose (and mention macroexpansion
as a possible cause of the problem.) Fixes ticket:926.

Warn (via a full warning) if a local function shadows a global
CL function name. Fixes ticket:923.

If STYLE-WARNINGs are incidentally signaled during (e.g.)
macroexpansion and are handled and postprocessed by the compiler,
ensure that the warning actually generated will be a STYLE-WARNING.

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