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