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

Last change on this file was 16685, checked in by rme, 4 years ago

Update copyright/license headers in files.

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