source: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp @ 14067

Last change on this file since 14067 was 14067, checked in by ehuelsmann, 9 years ago

Fix declarations being dropped on inline expansions.

Report by James M. Lawrence.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 53.8 KB
Line 
1;;; compiler-pass1.lisp
2;;;
3;;; Copyright (C) 2003-2008 Peter Graves
4;;; $Id: compiler-pass1.lisp 14067 2012-08-09 09:19:40Z ehuelsmann $
5;;;
6;;; This program is free software; you can redistribute it and/or
7;;; modify it under the terms of the GNU General Public License
8;;; as published by the Free Software Foundation; either version 2
9;;; of the License, or (at your option) any later version.
10;;;
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
19;;;
20;;; As a special exception, the copyright holders of this library give you
21;;; permission to link this library with independent modules to produce an
22;;; executable, regardless of the license terms of these independent
23;;; modules, and to copy and distribute the resulting executable under
24;;; terms of your choice, provided that you also meet, for each linked
25;;; independent module, the terms and conditions of the license of that
26;;; module.  An independent module is a module which is not derived from
27;;; or based on this library.  If you modify this library, you may extend
28;;; this exception to your version of the library, but you are not
29;;; obligated to do so.  If you do not wish to do so, delete this
30;;; exception statement from your version.
31
32(in-package "JVM")
33
34(require "LOOP")
35(require "FORMAT")
36(require "CLOS")
37(require "PRINT-OBJECT")
38(require "COMPILER-TYPES")
39(require "KNOWN-FUNCTIONS")
40(require "KNOWN-SYMBOLS")
41(require "DUMP-FORM")
42(require "OPCODES")
43(require "JAVA")
44
45
46(defun generate-inline-expansion (name lambda-list body
47                                  &optional (args nil args-p))
48  "Generates code that can be used to expand a named local function inline.
49It can work either per-function (no args provided) or per-call."
50  (if args-p
51      (multiple-value-bind
52            (body decls)
53          (parse-body body)
54        (expand-function-call-inline nil lambda-list
55                                     ;; the forms below get wrapped
56                                     ;; in a LET, making the decls
57                                     ;; part of the decls of the LET.
58                                     (copy-tree `(,@decls (block ,name ,@body)))
59                                     args))
60      (cond ((intersection lambda-list
61                           '(&optional &rest &key &allow-other-keys &aux)
62                           :test #'eq)
63             nil)
64            (t
65             (multiple-value-bind
66                   (body decls)
67                 (parse-body body)
68               (setf body (copy-tree body))
69               `(lambda ,lambda-list ,@decls
70                        (block ,name ,@body)))))))
71
72
73;;; Pass 1.
74
75(defun parse-lambda-list (lambda-list)
76  "Breaks the lambda list into the different elements, returning the values
77
78 required-vars
79 optional-vars
80 key-vars
81 key-p
82 rest-var
83 allow-other-keys-p
84 aux-vars
85 whole-var
86 env-var
87
88where each of the vars returned is a list with these elements:
89
90 var      - the actual variable name
91 initform - the init form if applicable; optional, keyword and aux vars
92 p-var    - variable indicating presence
93 keyword  - the keyword argument to match against
94
95"
96  (let ((state :req)
97        req opt key rest whole env aux key-p allow-others-p)
98    (dolist (arg lambda-list)
99      (case arg
100        (&optional (setf state :opt))
101        (&key (setf state :key
102                    key-p t))
103        (&rest (setf state :rest))
104        (&aux (setf state :aux))
105        (&allow-other-keys (setf state :none
106                                 allow-others-p t))
107        (&whole (setf state :whole))
108        (&environment (setf state :env))
109        (t
110         (case state
111           (:req (push arg req))
112           (:rest (setf rest (list arg)
113                        state :none))
114           (:env (setf env (list arg)
115                       state :req))
116           (:whole (setf whole (list arg)
117                         state :req))
118           (:none
119            (error "Invalid lambda list: argument found in :none state."))
120           (:opt
121            (cond
122              ((symbolp arg)
123               (push (list arg nil nil nil) opt))
124              ((consp arg)
125               (push (list (car arg) (cadr arg) (caddr arg)) opt))
126              (t
127               (error "Invalid state."))))
128           (:aux
129            (cond
130              ((symbolp arg)
131               (push (list arg nil nil nil) aux))
132              ((consp arg)
133               (push (list (car arg) (cadr arg) nil nil) aux))
134              (t
135               (error "Invalid :aux state."))))
136           (:key
137            (cond
138              ((symbolp arg)
139               (push (list arg nil nil (sys::keywordify arg)) key))
140              ((and (consp arg)
141                    (consp (car arg)))
142               (push (list (cadar arg) (cadr arg) (caddr arg) (caar arg)) key))
143              ((consp arg)
144               (push (list (car arg) (cadr arg) (caddr arg)
145                           (sys::keywordify (car arg))) key))
146              (t
147               (error "Invalid :key state."))))
148           (t (error "Invalid state found."))))))
149    (values
150     (nreverse req)
151     (nreverse opt)
152     (nreverse key)
153     key-p
154     rest allow-others-p
155     (nreverse aux) whole env)))
156
157(define-condition lambda-list-mismatch (error)
158  ((mismatch-type :reader lambda-list-mismatch-type :initarg :mismatch-type)))
159
160(defmacro push-argument-binding (var form temp-bindings bindings)
161  (let ((g (gensym)))
162    `(let ((,g (gensym (symbol-name '#:temp))))
163       (push (list ,g ,form) ,temp-bindings)
164       (push (list ,var ,g) ,bindings))))
165
166(defun match-lambda-list (parsed-lambda-list arguments)
167  (flet ((pop-required-argument ()
168     (if (null arguments)
169         (error 'lambda-list-mismatch :mismatch-type :too-few-arguments)
170         (pop arguments)))
171   (var (var-info) (car var-info))
172   (initform (var-info) (cadr var-info))
173   (p-var (var-info) (caddr var-info)))
174    (destructuring-bind (req opt key key-p rest allow-others-p aux whole env)
175  parsed-lambda-list
176      (declare (ignore whole env))
177      (let (req-bindings temp-bindings bindings ignorables)
178  ;;Required arguments.
179  (setf req-bindings
180        (loop :for var :in req :collect `(,var ,(pop-required-argument))))
181
182  ;;Optional arguments.
183  (when opt
184    (dolist (var-info opt)
185      (if arguments
186    (progn
187      (push-argument-binding (var var-info) (pop arguments)
188           temp-bindings bindings)
189      (when (p-var var-info)
190        (push `(,(p-var var-info) t) bindings)))
191    (progn
192      (push `(,(var var-info) ,(initform var-info)) bindings)
193      (when (p-var var-info)
194        (push `(,(p-var var-info) nil) bindings)))))
195    (setf bindings (nreverse bindings)))
196 
197  (unless (or key-p rest (null arguments))
198    (error 'lambda-list-mismatch :mismatch-type :too-many-arguments))
199
200  ;;Keyword and rest arguments.
201  (if key-p
202      (multiple-value-bind (kbindings ktemps kignor)
203    (match-keyword-and-rest-args 
204     key allow-others-p rest arguments)
205        (setf bindings (append bindings kbindings)
206        temp-bindings (append temp-bindings ktemps)
207        ignorables (append kignor ignorables)))
208      (when rest
209        (let (rest-binding)
210    (push-argument-binding (var rest) `(list ,@arguments)
211               temp-bindings rest-binding)
212    (setf bindings (append bindings rest-binding)))))
213  ;;Aux parameters.
214  (when aux
215    (setf bindings
216    `(,@bindings
217      ,@(loop
218           :for var-info :in aux
219           :collect `(,(var var-info) ,(initform var-info))))))
220  (values (append req-bindings temp-bindings bindings)
221    ignorables)))))
222
223(defun match-keyword-and-rest-args (key allow-others-p rest arguments)
224  (flet ((var (var-info) (car var-info))
225   (initform (var-info) (cadr var-info))
226   (p-var (var-info) (caddr var-info))
227   (keyword (var-info) (cadddr var-info)))
228    (when (oddp (list-length arguments))
229      (error 'lambda-list-mismatch
230       :mismatch-type :odd-number-of-keyword-arguments))
231   
232    (let (temp-bindings bindings other-keys-found-p ignorables already-seen
233    args)
234      ;;If necessary, make up a fake argument to hold :allow-other-keys,
235      ;;needed later. This also handles nicely:
236      ;;  3.4.1.4.1 Suppressing Keyword Argument Checking
237      ;;third statement.
238      (unless (find :allow-other-keys key :key #'keyword)
239  (let ((allow-other-keys-temp (gensym (symbol-name :allow-other-keys))))
240    (push allow-other-keys-temp ignorables)
241    (push (list allow-other-keys-temp nil nil :allow-other-keys) key)))
242     
243      ;;First, let's bind the keyword arguments that have been passed by
244      ;;the caller. If we encounter an unknown keyword, remember it.
245      ;;As per the above, :allow-other-keys will never be considered
246      ;;an unknown keyword.
247      (loop
248   :for var :in arguments :by #'cddr
249   :for value :in (cdr arguments) :by #'cddr
250   :do (let ((var-info (find var key :key #'keyword)))
251         (if (and var-info (not (member var already-seen)))
252       ;;var is one of the declared keyword arguments
253       (progn
254         (push-argument-binding (var var-info) value
255              temp-bindings bindings)
256         (when (p-var var-info)
257           (push `(,(p-var var-info) t) bindings))
258         (push var args)
259         (push (var var-info) args)
260         (push var already-seen))
261       (let ((g (gensym)))
262         (push `(,g ,value) temp-bindings)
263         (push var args)
264         (push g args)
265         (push g ignorables)
266         (unless var-info
267           (setf other-keys-found-p t))))))
268     
269      ;;Then, let's bind those arguments that haven't been passed in
270      ;;to their default value, in declaration order.
271      (let (defaults)
272  (loop
273     :for var-info :in key
274     :do (unless (find (var var-info) bindings :key #'car)
275     (push `(,(var var-info) ,(initform var-info)) defaults)
276     (when (p-var var-info)
277       (push `(,(p-var var-info) nil) defaults))))
278  (setf bindings (append (nreverse defaults) bindings)))
279     
280      ;;If necessary, check for unrecognized keyword arguments.
281      (when (and other-keys-found-p (not allow-others-p))
282  (if (loop
283         :for var :in arguments :by #'cddr
284         :if (eq var :allow-other-keys)
285         :do (return t))
286      ;;We know that :allow-other-keys has been passed, so we
287      ;;can access the binding for it and be sure to get the
288      ;;value passed by the user and not an initform.
289      (let* ((arg (var (find :allow-other-keys key :key #'keyword)))
290       (binding (find arg bindings :key #'car))
291       (form (cadr binding)))
292        (if (constantp form)
293      (unless (eval form)
294        (error 'lambda-list-mismatch
295         :mismatch-type :unknown-keyword))
296      (setf (cadr binding)
297      `(or ,(cadr binding)
298           (error 'program-error
299            "Unrecognized keyword argument")))))
300      ;;TODO: it would be nice to report *which* keyword
301      ;;is unknown
302      (error 'lambda-list-mismatch :mismatch-type :unknown-keyword)))
303      (when rest
304  (setf bindings (append bindings `((,(var rest) (list ,@(nreverse args)))))))
305      (values bindings temp-bindings ignorables))))
306
307#||test for the above
308(handler-case
309    (let ((lambda-list
310     (multiple-value-list
311      (jvm::parse-lambda-list
312       '(a b &optional (c 42) &rest foo &key (bar c) baz ((kaz kuz) bar))))))
313      (jvm::match-lambda-list
314       lambda-list
315       '((print 1) 3 (print 32) :bar 2)))
316  (jvm::lambda-list-mismatch (x) (jvm::lambda-list-mismatch-type x)))
317||#
318
319(defun expand-function-call-inline (form lambda-list body args)
320  (handler-case
321      (multiple-value-bind (bindings ignorables)
322    (match-lambda-list (multiple-value-list
323            (parse-lambda-list lambda-list))
324           args)
325  `(let* ,bindings
326     ,@(when ignorables
327       `((declare (ignorable ,@ignorables))))
328     ,@body))
329    (lambda-list-mismatch (x)
330      (compiler-warn "Invalid function call: ~S (mismatch type: ~A)"
331         form (lambda-list-mismatch-type x))
332      form)))
333
334;; Returns a list of declared free specials, if any are found.
335(declaim (ftype (function (list list block-node) list)
336                process-declarations-for-vars))
337(defun process-declarations-for-vars (body variables block)
338  (let ((free-specials '()))
339    (dolist (subform body)
340      (unless (and (consp subform) (eq (%car subform) 'DECLARE))
341        (return))
342      (let ((decls (%cdr subform)))
343        (dolist (decl decls)
344          (case (car decl)
345            ((DYNAMIC-EXTENT FTYPE INLINE NOTINLINE OPTIMIZE)
346             ;; Nothing to do here.
347             )
348            ((IGNORE IGNORABLE)
349             (process-ignore/ignorable (%car decl) (%cdr decl) variables))
350            (SPECIAL
351             (dolist (name (%cdr decl))
352               (let ((variable (find-variable name variables)))
353                 (cond ((and variable
354                             ;; see comment below (and DO-ALL-SYMBOLS.11)
355                             (eq (variable-compiland variable)
356                                 *current-compiland*))
357                        (setf (variable-special-p variable) t))
358                       (t
359                        (dformat t "adding free special ~S~%" name)
360                        (push (make-variable :name name :special-p t
361                                             :block block)
362                              free-specials))))))
363            (TYPE
364             (dolist (name (cddr decl))
365               (let ((variable (find-variable name variables)))
366                 (when (and variable
367                            ;; Don't apply a declaration in a local function to
368                            ;; a variable defined in its parent. For an example,
369                            ;; see CREATE-GREEDY-NO-ZERO-MATCHER in cl-ppcre.
370                            ;; FIXME suboptimal, since we ignore the declaration
371                            (eq (variable-compiland variable)
372                                *current-compiland*))
373                   (setf (variable-declared-type variable)
374                         (make-compiler-type (cadr decl)))))))
375            (t
376             (dolist (name (cdr decl))
377               (let ((variable (find-variable name variables)))
378                 (when variable
379                   (setf (variable-declared-type variable)
380                         (make-compiler-type (%car decl)))))))))))
381    free-specials))
382
383(defun check-name (name)
384  ;; FIXME Currently this error is signalled by the precompiler.
385  (unless (symbolp name)
386    (compiler-error "The variable ~S is not a symbol." name))
387  (when (constantp name)
388    (compiler-error "The name of the variable ~S is already in use to name a constant." name))
389  name)
390
391(declaim (ftype (function (t) t) p1-body))
392(defun p1-body (body)
393  (declare (optimize speed))
394  (let ((tail body))
395    (loop
396      (when (endp tail)
397        (return))
398      (setf (car tail) (p1 (%car tail)))
399      (setf tail (%cdr tail))))
400  body)
401
402(defknown p1-default (t) t)
403(declaim (inline p1-default))
404(defun p1-default (form)
405  (setf (cdr form) (p1-body (cdr form)))
406  form)
407
408(defmacro p1-let/let*-vars
409    (block varlist variables-var var body1 body2)
410  (let ((varspec (gensym))
411  (initform (gensym))
412  (name (gensym)))
413    `(let ((,variables-var ()))
414       (dolist (,varspec ,varlist)
415   (cond ((consp ,varspec)
416                ;; Even though the precompiler already signals this
417                ;; error, double checking can't hurt; after all, we're
418                ;; also rewriting &AUX into LET* bindings.
419    (unless (<= 1 (length ,varspec) 2)
420      (compiler-error "The LET/LET* binding specification ~S is invalid."
421          ,varspec))
422    (let* ((,name (%car ,varspec))
423           (,initform (p1 (%cadr ,varspec)))
424           (,var (make-variable :name (check-name ,name)
425                                            :initform ,initform
426                                            :block ,block)))
427      (when (neq ,initform (cadr ,varspec))
428        (setf (cadr ,varspec) ,initform))
429      (push ,var ,variables-var)
430      ,@body1))
431         (t
432    (let ((,var (make-variable :name (check-name ,varspec)
433                                           :block ,block)))
434      (push ,var ,variables-var)
435      ,@body1))))
436       ,@body2)))
437
438(defknown p1-let-vars (t) t)
439(defun p1-let-vars (block varlist)
440  (p1-let/let*-vars block
441   varlist vars var
442   ()
443   ((setf vars (nreverse vars))
444    (dolist (variable vars)
445      (push variable *visible-variables*)
446      (push variable *all-variables*))
447    vars)))
448
449(defknown p1-let*-vars (t) t)
450(defun p1-let*-vars (block varlist)
451  (p1-let/let*-vars block
452   varlist vars var
453   ((push var *visible-variables*)
454    (push var *all-variables*))
455   ((nreverse vars))))
456
457(defun p1-let/let* (form)
458  (declare (type cons form))
459  (let* ((*visible-variables* *visible-variables*)
460         (block (make-let/let*-node))
461   (*block* block)
462         (op (%car form))
463         (varlist (cadr form))
464         (body (cddr form)))
465    (aver (or (eq op 'LET) (eq op 'LET*)))
466    (when (eq op 'LET)
467      ;; Convert to LET* if possible.
468      (if (null (cdr varlist))
469          (setf op 'LET*)
470          (dolist (varspec varlist (setf op 'LET*))
471            (or (atom varspec)
472                (constantp (cadr varspec))
473                (eq (car varspec) (cadr varspec))
474                (return)))))
475    (let ((vars (if (eq op 'LET)
476                    (p1-let-vars block varlist)
477                    (p1-let*-vars block varlist))))
478      ;; Check for globally declared specials.
479      (dolist (variable vars)
480        (when (special-variable-p (variable-name variable))
481          (setf (variable-special-p variable) t
482                (let-environment-register block) t)))
483      ;; For processing declarations, we want to walk the variable list from
484      ;; last to first, since declarations apply to the last-defined variable
485      ;; with the specified name.
486      (setf (let-free-specials block)
487            (process-declarations-for-vars body (reverse vars) block))
488      (setf (let-vars block) vars)
489      ;; Make free specials visible.
490      (dolist (variable (let-free-specials block))
491        (push variable *visible-variables*)))
492    (let ((*blocks* (cons block *blocks*)))
493      (setf body (p1-body body)))
494    (setf (let-form block) (list* op varlist body))
495    block))
496
497(defun p1-locally (form)
498  (let* ((*visible-variables* *visible-variables*)
499         (block (make-locally-node))
500   (*block* block)
501         (free-specials (process-declarations-for-vars (cdr form) nil block)))
502    (setf (locally-free-specials block) free-specials)
503    (dolist (special free-specials)
504;;       (format t "p1-locally ~S is special~%" name)
505      (push special *visible-variables*))
506    (let ((*blocks* (cons block *blocks*)))
507      (setf (locally-form block)
508            (list* 'LOCALLY (p1-body (cdr form))))
509      block)))
510
511(defknown p1-m-v-b (t) t)
512(defun p1-m-v-b (form)
513  (when (= (length (cadr form)) 1)
514    (let ((new-form `(let* ((,(caadr form) ,(caddr form))) ,@(cdddr form))))
515      (return-from p1-m-v-b (p1-let/let* new-form))))
516  (let* ((*visible-variables* *visible-variables*)
517         (block (make-m-v-b-node))
518   (*block* block)
519         (varlist (cadr form))
520         ;; Process the values-form first. ("The scopes of the name binding and
521         ;; declarations do not include the values-form.")
522         (values-form (p1 (caddr form)))
523         (*blocks* (cons block *blocks*))
524         (body (cdddr form)))
525    (let ((vars ()))
526      (dolist (symbol varlist)
527        (let ((var (make-variable :name symbol :block block)))
528          (push var vars)
529          (push var *visible-variables*)
530          (push var *all-variables*)))
531      ;; Check for globally declared specials.
532      (dolist (variable vars)
533        (when (special-variable-p (variable-name variable))
534          (setf (variable-special-p variable) t
535                (m-v-b-environment-register block) t)))
536      (setf (m-v-b-free-specials block)
537            (process-declarations-for-vars body vars block))
538      (dolist (special (m-v-b-free-specials block))
539        (push special *visible-variables*))
540      (setf (m-v-b-vars block) (nreverse vars)))
541    (setf body (p1-body body))
542    (setf (m-v-b-form block)
543          (list* 'MULTIPLE-VALUE-BIND varlist values-form body))
544    block))
545
546(defun p1-block (form)
547  (let* ((block (make-block-node (cadr form)))
548   (*block* block)
549         (*blocks* (cons block *blocks*)))
550    (setf (cddr form) (p1-body (cddr form)))
551    (setf (block-form block) form)
552    (when (block-non-local-return-p block)
553      ;; Add a closure variable for RETURN-FROM to use
554      (push (setf (block-id-variable block)
555                  (make-variable :name (gensym)
556                                 :block block
557                                 :used-non-locally-p t))
558            *all-variables*))
559    block))
560
561(defun p1-catch (form)
562  (let* ((tag (p1 (cadr form)))
563         (body (cddr form))
564         (block (make-catch-node))
565   (*block* block)
566         ;; our subform processors need to know
567         ;; they're enclosed in a CATCH block
568         (*blocks* (cons block *blocks*))
569         (result '()))
570    (dolist (subform body)
571      (let ((op (and (consp subform) (%car subform))))
572        (push (p1 subform) result)
573        (when (memq op '(GO RETURN-FROM THROW))
574          (return))))
575    (setf result (nreverse result))
576    (when (and (null (cdr result))
577               (consp (car result))
578               (eq (caar result) 'GO))
579      (return-from p1-catch (car result)))
580    (push tag result)
581    (push 'CATCH result)
582    (setf (catch-form block) result)
583    block))
584
585(defun p1-threads-synchronized-on (form)
586  (let* ((synchronized-object (p1 (cadr form)))
587         (body (cddr form))
588         (block (make-synchronized-node))
589   (*block* block)
590         (*blocks* (cons block *blocks*))
591         result)
592    (dolist (subform body)
593      (let ((op (and (consp subform) (%car subform))))
594        (push (p1 subform) result)
595        (when (memq op '(GO RETURN-FROM THROW))
596          (return))))
597    (setf (synchronized-form block)
598          (list* 'threads:synchronized-on synchronized-object
599                 (nreverse result)))
600    block))
601
602(defun p1-unwind-protect (form)
603  (if (= (length form) 2)
604      (p1 (second form)) ; No cleanup forms: (unwind-protect (...)) => (...)
605
606      ;; in order to compile the cleanup forms twice (see
607      ;; p2-unwind-protect-node), we need to p1 them twice; p1 outcomes
608      ;; can be compiled (in the same compiland?) only once.
609      ;;
610      ;; However, p1 transforms the forms being processed, so, we
611      ;; need to copy the forms to create a second copy.
612      (let* ((block (make-unwind-protect-node))
613       (*block* block)
614             ;; a bit of jumping through hoops...
615             (unwinding-forms (p1-body (copy-tree (cddr form))))
616             (unprotected-forms (p1-body (cddr form)))
617             ;; ... because only the protected form is
618             ;; protected by the UNWIND-PROTECT block
619             (*blocks* (cons block *blocks*))
620             (protected-form (p1 (cadr form))))
621        (setf (unwind-protect-form block)
622              `(unwind-protect ,protected-form
623                 (progn ,@unwinding-forms)
624                 ,@unprotected-forms))
625        block)))
626
627(defknown p1-return-from (t) t)
628(defun p1-return-from (form)
629  (let* ((name (second form))
630         (block (find-block name))
631         non-local-p)
632    (when (null block)
633      (compiler-error "RETURN-FROM ~S: no block named ~S is currently visible."
634                      name name))
635    (dformat t "p1-return-from block = ~S~%" (block-name block))
636    (cond ((eq (block-compiland block) *current-compiland*)
637           ;; Local case. If the RETURN is nested inside an UNWIND-PROTECT
638           ;; which is inside the block we're returning from, we'll do a non-
639           ;; local return anyway so that UNWIND-PROTECT can catch it and run
640           ;; its cleanup forms.
641           ;;(dformat t "*blocks* = ~S~%" (mapcar #'node-name *blocks*))
642           (let ((protected (enclosed-by-protected-block-p block)))
643             (dformat t "p1-return-from protected = ~S~%" protected)
644             (if protected
645                 (setf (block-non-local-return-p block) t
646                       non-local-p t)
647                 ;; non-local GO's ensure environment restoration
648                 ;; find out about this local GO
649                 (when (null (block-needs-environment-restoration block))
650                   (setf (block-needs-environment-restoration block)
651                         (enclosed-by-environment-setting-block-p block))))))
652          (t
653           (setf (block-non-local-return-p block) t
654                 non-local-p t)))
655    (when (block-non-local-return-p block)
656      (dformat t "non-local return from block ~S~%" (block-name block)))
657    (let ((value-form (p1 (caddr form))))
658      (push value-form (block-return-value-forms block))
659      (make-jump-node (list 'RETURN-FROM name value-form)
660                      non-local-p block))))
661
662(defun p1-tagbody (form)
663  (let* ((block (make-tagbody-node))
664   (*block* block)
665         (*blocks* (cons block *blocks*))
666         (*visible-tags* *visible-tags*)
667         (local-tags '())
668         (body (cdr form)))
669    ;; Make all the tags visible before processing the body forms.
670    (dolist (subform body)
671      (when (or (symbolp subform) (integerp subform))
672        (let* ((tag (make-tag :name subform :label (gensym) :block block)))
673          (push tag local-tags)
674          (push tag *visible-tags*))))
675    (let ((new-body '())
676          (live t))
677      (dolist (subform body)
678        (cond ((or (symbolp subform) (integerp subform))
679               (push subform new-body)
680               (push (find subform local-tags :key #'tag-name :test #'eql)
681                     (tagbody-tags block))
682               (setf live t))
683              ((not live)
684               ;; Nothing to do.
685               )
686              (t
687               (when (and (consp subform)
688                          (memq (%car subform) '(GO RETURN-FROM THROW)))
689                 ;; Subsequent subforms are unreachable until we see another
690                 ;; tag.
691                 (setf live nil))
692               (push (p1 subform) new-body))))
693      (setf (tagbody-form block) (list* 'TAGBODY (nreverse new-body))))
694    (when (some #'tag-used-non-locally (tagbody-tags block))
695      (push (setf (tagbody-id-variable block)
696                  (make-variable :name (gensym)
697                                 :block block
698                                 :used-non-locally-p t))
699            *all-variables*))
700    block))
701
702(defknown p1-go (t) t)
703(defun p1-go (form)
704  (let* ((name (cadr form))
705         (tag (find-tag name)))
706    (unless tag
707      (error "p1-go: tag not found: ~S" name))
708    (setf (tag-used tag) t)
709    (let ((tag-block (tag-block tag))
710          non-local-p)
711      (cond ((eq (tag-compiland tag) *current-compiland*)
712             ;; Does the GO leave an enclosing UNWIND-PROTECT or CATCH?
713             (if (enclosed-by-protected-block-p tag-block)
714                 (setf (tagbody-non-local-go-p tag-block) t
715                       (tag-used-non-locally tag) t
716                       non-local-p t)
717                 ;; non-local GO's ensure environment restoration
718                 ;; find out about this local GO
719                 (when (null (tagbody-needs-environment-restoration tag-block))
720                   (setf (tagbody-needs-environment-restoration tag-block)
721                         (enclosed-by-environment-setting-block-p tag-block)))))
722            (t
723             (setf (tagbody-non-local-go-p tag-block) t
724                   (tag-used-non-locally tag) t
725                   non-local-p t)))
726      (make-jump-node form non-local-p tag-block tag))))
727
728(defun split-decls (forms specific-vars)
729  (let ((other-decls nil)
730        (specific-decls nil))
731    (dolist (form forms)
732      (unless (and (consp form) (eq (car form) 'DECLARE)) ; shouldn't happen
733        (return))
734      (dolist (decl (cdr form))
735        (case (car decl)
736          ((OPTIMIZE DECLARATION DYNAMIC-EXTENT FTYPE INLINE NOTINLINE)
737           (push (list 'DECLARE decl) other-decls))
738          (SPECIAL
739           (dolist (name (cdr decl))
740             (if (memq name specific-vars)
741                 (push `(DECLARE (SPECIAL ,name)) specific-decls)
742                 (push `(DECLARE (SPECIAL ,name)) other-decls))))
743          (TYPE
744           (dolist (name (cddr decl))
745             (if (memq name specific-vars)
746                 (push `(DECLARE (TYPE ,(cadr decl) ,name)) specific-decls)
747                 (push `(DECLARE (TYPE ,(cadr decl) ,name)) other-decls))))
748          (t
749           (dolist (name (cdr decl))
750             (if (memq name specific-vars)
751                 (push `(DECLARE (,(car decl) ,name)) specific-decls)
752                 (push `(DECLARE (,(car decl) ,name)) other-decls)))))))
753    (values (nreverse other-decls)
754            (nreverse specific-decls))))
755
756(defun rewrite-aux-vars (form)
757  (let* ((lambda-list (cadr form))
758         (aux-p (memq '&AUX lambda-list))
759         (lets (cdr aux-p))
760         aux-vars)
761    (unless aux-p
762      ;; no rewriting required
763      (return-from rewrite-aux-vars form))
764    (multiple-value-bind (body decls)
765        (parse-body (cddr form))
766      (dolist (form lets)
767        (cond ((consp form)
768               (push (car form) aux-vars))
769              (t
770               (push form aux-vars))))
771      (setf lambda-list (subseq lambda-list 0 (position '&AUX lambda-list)))
772      (multiple-value-bind (let-decls lambda-decls)
773          (split-decls decls (lambda-list-names lambda-list))
774        `(lambda ,lambda-list
775           ,@lambda-decls
776           (let* ,lets
777             ,@let-decls
778             ,@body))))))
779
780(defun rewrite-lambda (form)
781  (setf form (rewrite-aux-vars form))
782  (let* ((lambda-list (cadr form)))
783    (if (not (or (memq '&optional lambda-list)
784                 (memq '&key lambda-list)))
785        ;; no need to rewrite: no arguments with possible initforms anyway
786        form
787      (multiple-value-bind (body decls doc)
788          (parse-body (cddr form))
789        (let (state let-bindings new-lambda-list
790                    (non-constants 0))
791          (do* ((vars lambda-list (cdr vars))
792                (var (car vars) (car vars)))
793               ((endp vars))
794            (push (car vars) new-lambda-list)
795            (let ((replacement (gensym)))
796              (flet ((parse-compound-argument (arg)
797                       "Returns the values NAME, KEYWORD, INITFORM, INITFORM-P,
798   SUPPLIED-P and SUPPLIED-P-P assuming ARG is a compound argument."
799                       (destructuring-bind
800                             (name &optional (initform nil initform-supplied-p)
801                                   (supplied-p nil supplied-p-supplied-p))
802                           (if (listp arg) arg (list arg))
803                         (if (listp name)
804                             (values (cadr name) (car name)
805                                     initform initform-supplied-p
806                                     supplied-p supplied-p-supplied-p)
807                             (values name (make-keyword name)
808                                     initform initform-supplied-p
809                                     supplied-p supplied-p-supplied-p)))))
810                (case var
811                  (&optional (setf state :optional))
812                  (&key (setf state :key))
813                  ((&whole &environment &rest &body &allow-other-keys)
814                   ;; do nothing special
815                   )
816                  (t
817                   (cond
818                     ((atom var)
819                      (setf (car new-lambda-list)
820                            (if (eq state :key)
821                                (list (list (make-keyword var) replacement))
822                                replacement))
823                      (push (list var replacement) let-bindings))
824                     ((constantp (second var))
825                      ;; so, we must have a consp-type var we're looking at
826                      ;; and it has a constantp initform
827                      (multiple-value-bind
828                            (name keyword initform initform-supplied-p
829                                  supplied-p supplied-p-supplied-p)
830                          (parse-compound-argument var)
831                        (let ((var-form (if (eq state :key)
832                                            (list keyword replacement)
833                                            replacement))
834                              (supplied-p-replacement (gensym)))
835                          (setf (car new-lambda-list)
836                                (cond
837                                  ((not initform-supplied-p)
838                                   (list var-form))
839                                  ((not supplied-p-supplied-p)
840                                   (list var-form initform))
841                                  (t
842                                   (list var-form initform
843                                         supplied-p-replacement))))
844                          (push (list name replacement) let-bindings)
845                          ;; if there was a 'supplied-p' variable, it might
846                          ;; be used in the declarations. Since those will be
847                          ;; moved below the LET* block, we need to move the
848                          ;; supplied-p parameter too.
849                          (when supplied-p-supplied-p
850                            (push (list supplied-p supplied-p-replacement)
851                                  let-bindings)))))
852                     (t
853                      (incf non-constants)
854                      ;; this is either a keyword or an optional argument
855                      ;; with a non-constantp initform
856                      (multiple-value-bind
857                            (name keyword initform initform-supplied-p
858                                  supplied-p supplied-p-supplied-p)
859                          (parse-compound-argument var)
860                        (declare (ignore initform-supplied-p))
861                        (let ((var-form (if (eq state :key)
862                                            (list keyword replacement)
863                                            replacement))
864                              (supplied-p-replacement (gensym)))
865                          (setf (car new-lambda-list)
866                                (list var-form nil supplied-p-replacement))
867                          (push (list name `(if ,supplied-p-replacement
868                                                ,replacement ,initform))
869                                let-bindings)
870                          (when supplied-p-supplied-p
871                            (push (list supplied-p supplied-p-replacement)
872                                  let-bindings)))))))))))
873          (if (zerop non-constants)
874              ;; there was no reason to rewrite...
875              form
876              (let ((rv
877                     `(lambda ,(nreverse new-lambda-list)
878                        ,@(when doc (list doc))
879                        (let* ,(nreverse let-bindings)
880                          ,@decls ,@body))))
881                rv)))))))
882
883(defun validate-function-name (name)
884  (unless (or (symbolp name) (setf-function-name-p name))
885    (compiler-error "~S is not a valid function name." name))
886  name)
887
888(defun construct-flet/labels-function (definition)
889  (let* ((name (car definition))
890         (block-name (fdefinition-block-name (validate-function-name name)))
891         (lambda-list (cadr definition))
892         (compiland (make-compiland :name name :parent *current-compiland*))
893         (local-function (make-local-function :name name :compiland compiland)))
894    (push local-function (compiland-children *current-compiland*))
895    (multiple-value-bind
896          (body decls)
897        (parse-body (cddr definition))
898      (setf (local-function-definition local-function)
899            (copy-tree (cdr definition)))
900      (setf (compiland-lambda-expression compiland)
901            (rewrite-lambda `(lambda ,lambda-list
902                               ,@decls
903                               (block ,block-name
904                                 ,@body)))))
905    local-function))
906
907(defun p1-flet (form)
908  (let* ((local-functions
909          (mapcar #'(lambda (definition)
910                      (construct-flet/labels-function definition))
911                  (cadr form)))
912         (*local-functions* *local-functions*))
913    (dolist (local-function local-functions)
914      (p1-compiland (local-function-compiland local-function)))
915    (dolist (local-function local-functions)
916      (push local-function *local-functions*))
917    (with-saved-compiler-policy
918        (process-optimization-declarations (cddr form))
919      (let* ((block (make-flet-node))
920             (*block* block)
921             (*blocks* (cons block *blocks*))
922             (body (cddr form))
923             (*visible-variables* *visible-variables*))
924        (setf (flet-free-specials block)
925              (process-declarations-for-vars body nil block))
926        (dolist (special (flet-free-specials block))
927          (push special *visible-variables*))
928        (setf body (p1-body body) ;; affects the outcome of references-needed-p
929              (flet-form block)
930              (list* (car form)
931                     (remove-if #'(lambda (fn)
932                                    (and (inline-p (local-function-name fn))
933                                         (not (local-function-references-needed-p fn))))
934                                local-functions)
935                     body))
936        block))))
937
938
939(defun p1-labels (form)
940  (let* ((local-functions
941          (mapcar #'(lambda (definition)
942                      (construct-flet/labels-function definition))
943                  (cadr form)))
944         (*local-functions* *local-functions*)
945         (*visible-variables* *visible-variables*))
946    (dolist (local-function local-functions)
947      (push local-function *local-functions*))
948    (dolist (local-function local-functions)
949      (p1-compiland (local-function-compiland local-function)))
950    (let* ((block (make-labels-node))
951           (*block* block)
952           (*blocks* (cons block *blocks*))
953           (body (cddr form))
954           (*visible-variables* *visible-variables*))
955      (setf (labels-free-specials block)
956            (process-declarations-for-vars body nil block))
957      (dolist (special (labels-free-specials block))
958        (push special *visible-variables*))
959      (setf (labels-form block)
960            (list* (car form) local-functions (p1-body (cddr form))))
961      block)))
962
963(defknown p1-funcall (t) t)
964(defun p1-funcall (form)
965  (unless (> (length form) 1)
966    (compiler-warn "Wrong number of arguments for ~A." (car form))
967    (return-from p1-funcall form))
968  (let ((function-form (%cadr form)))
969    (when (and (consp function-form)
970               (eq (%car function-form) 'FUNCTION))
971      (let ((name (%cadr function-form)))
972;;         (format t "p1-funcall name = ~S~%" name)
973        (let ((source-transform (source-transform name)))
974          (when source-transform
975;;             (format t "found source transform for ~S~%" name)
976;;             (format t "old form = ~S~%" form)
977;;             (let ((new-form (expand-source-transform form)))
978;;               (when (neq new-form form)
979;;                 (format t "new form = ~S~%" new-form)
980;;                 (return-from p1-funcall (p1 new-form))))
981            (let ((new-form (expand-source-transform (list* name (cddr form)))))
982;;               (format t "new form = ~S~%" new-form)
983              (return-from p1-funcall (p1 new-form)))
984            )))))
985  ;; Otherwise...
986  (p1-function-call form))
987
988(defun p1-function (form)
989  (let ((form (copy-tree form))
990        local-function)
991    (cond ((and (consp (cadr form))
992                (or (eq (caadr form) 'LAMBDA)
993                    (eq (caadr form) 'NAMED-LAMBDA)))
994           (let* ((named-lambda-p (eq (caadr form) 'NAMED-LAMBDA))
995                  (named-lambda-form (when named-lambda-p
996                                       (cadr form)))
997                  (name (when named-lambda-p
998                          (cadr named-lambda-form)))
999                  (lambda-form (if named-lambda-p
1000                                   (cons 'LAMBDA (cddr named-lambda-form))
1001                                   (cadr form)))
1002                  (lambda-list (cadr lambda-form))
1003                  (body (cddr lambda-form))
1004                  (compiland (make-compiland :name (if named-lambda-p
1005                                                       name (gensym "ANONYMOUS-LAMBDA-"))
1006                                             :lambda-expression lambda-form
1007                                             :parent *current-compiland*))
1008                  (local-function (make-local-function :compiland compiland)))
1009             (push local-function (compiland-children *current-compiland*))
1010             (multiple-value-bind (body decls)
1011                 (parse-body body)
1012               (setf (compiland-lambda-expression compiland)
1013                     ;; if there still was a doc-string present, remove it
1014                     (rewrite-lambda
1015                      `(lambda ,lambda-list ,@decls ,@body)))
1016               (let ((*visible-variables* *visible-variables*)
1017                     (*current-compiland* compiland))
1018                 (p1-compiland compiland)))
1019             (list 'FUNCTION local-function)))
1020          ((setf local-function (find-local-function (cadr form)))
1021           (dformat "p1-function local function ~S~%" (cadr form))
1022           ;;we found out that the function needs a reference
1023           (setf (local-function-references-needed-p local-function) t)
1024           form)
1025          (t
1026           form))))
1027
1028(defun p1-lambda (form)
1029  (setf form (rewrite-lambda form))
1030  (let* ((lambda-list (cadr form)))
1031    (when (or (memq '&optional lambda-list)
1032              (memq '&key lambda-list))
1033      (let ((state nil))
1034        (dolist (arg lambda-list)
1035          (cond ((memq arg lambda-list-keywords)
1036                 (setf state arg))
1037                ((memq state '(&optional &key))
1038                 (when (and (consp arg)
1039                            (not (constantp (second arg))))
1040                   (compiler-unsupported
1041                    "P1-LAMBDA: can't handle optional argument with non-constant initform.")))))))
1042    (p1-function (list 'FUNCTION form))))
1043
1044(defun p1-eval-when (form)
1045  (list* (car form) (cadr form) (mapcar #'p1 (cddr form))))
1046
1047(defknown p1-progv (t) t)
1048(defun p1-progv (form)
1049  ;; We've already checked argument count in PRECOMPILE-PROGV.
1050  (let* ((symbols-form (p1 (cadr form)))
1051         (values-form (p1 (caddr form)))
1052         (block (make-progv-node))
1053   (*block* block)
1054         (*blocks* (cons block *blocks*))
1055         (body (cdddr form)))
1056;;  The (commented out) block below means to detect compile-time
1057;;  enumeration of bindings to be created (a quoted form in the symbols
1058;;  position).
1059;;    (when (and (quoted-form-p symbols-form)
1060;;               (listp (second symbols-form)))
1061;;      (dolist (name (second symbols-form))
1062;;        (let ((variable (make-variable :name name :special-p t)))
1063;;          (push
1064    (setf (progv-environment-register block) t
1065          (progv-form block)
1066          `(progv ,symbols-form ,values-form ,@(p1-body body)))
1067    block))
1068
1069(defun p1-quote (form)
1070  (unless (= (length form) 2)
1071    (compiler-error "Wrong number of arguments for special operator ~A (expected 1, but received ~D)."
1072                    'QUOTE
1073                    (1- (length form))))
1074  (let ((arg (%cadr form)))
1075    (if (or (numberp arg) (characterp arg))
1076        arg
1077        form)))
1078
1079(defun p1-setq (form)
1080  (unless (= (length form) 3)
1081    (error "Too many arguments for SETQ."))
1082  (let ((arg1 (%cadr form))
1083        (arg2 (%caddr form)))
1084    (let ((variable (find-visible-variable arg1)))
1085      (if variable
1086          (progn
1087            (when (variable-ignore-p variable)
1088              (compiler-style-warn
1089               "Variable ~S is assigned even though it was declared to be ignored."
1090               (variable-name variable)))
1091            (incf (variable-writes variable))
1092            (cond ((eq (variable-compiland variable) *current-compiland*)
1093                   (dformat t "p1-setq: write ~S~%" arg1))
1094                  (t
1095                   (dformat t "p1-setq: non-local write ~S~%" arg1)
1096                   (setf (variable-used-non-locally-p variable) t))))
1097          (dformat t "p1-setq: unknown variable ~S~%" arg1)))
1098    (list 'SETQ arg1 (p1 arg2))))
1099
1100(defun p1-the (form)
1101  (unless (= (length form) 3)
1102    (compiler-error "Wrong number of arguments for special operator ~A (expected 2, but received ~D)."
1103                    'THE
1104                    (1- (length form))))
1105  (let ((type (%cadr form))
1106        (expr (%caddr form)))
1107    (cond ((and (listp type) (eq (car type) 'VALUES))
1108           ;; FIXME
1109           (p1 expr))
1110          ((= *safety* 3)
1111           (let* ((sym (gensym))
1112                  (new-expr `(let ((,sym ,expr))
1113                               (require-type ,sym ',type)
1114                               ,sym)))
1115             (p1 new-expr)))
1116          ((and (<= 1 *safety* 2) ;; at safety 1 or 2 check relatively
1117                (symbolp type))   ;; simple types (those specified by a single symbol)
1118           (let* ((sym (gensym))
1119                  (new-expr `(let ((,sym ,expr))
1120                               (require-type ,sym ',type)
1121                               ,sym)))
1122             (p1 new-expr)))
1123          (t
1124           (list 'THE type (p1 expr))))))
1125
1126(defun p1-truly-the (form)
1127  (unless (= (length form) 3)
1128    (compiler-error "Wrong number of arguments for special operator ~A (expected 2, but received ~D)."
1129                    'TRULY-THE
1130                    (1- (length form))))
1131  (list 'TRULY-THE (%cadr form) (p1 (%caddr form))))
1132
1133(defknown p1-throw (t) t)
1134(defun p1-throw (form)
1135  (list* 'THROW (mapcar #'p1 (cdr form))))
1136
1137(defknown rewrite-function-call (t) t)
1138(defun rewrite-function-call (form)
1139  (let ((op (car form)) (args (cdr form)))
1140    (cond
1141      ((and (eq op 'funcall) (listp (car args)) (eq (caar args) 'lambda))
1142       ;;(funcall (lambda (...) ...) ...)
1143       (let ((op (car args)) (args (cdr args)))
1144         (expand-function-call-inline form (cadr op) (copy-tree (cddr op))
1145                                      args)))
1146      ((and (listp op) (eq (car op) 'lambda))
1147       ;;((lambda (...) ...) ...)
1148       (expand-function-call-inline form (cadr op) (copy-tree (cddr op)) args))
1149      (t form))))
1150
1151(defknown p1-function-call (t) t)
1152(defun p1-function-call (form)
1153  (let ((new-form (rewrite-function-call form)))
1154    (when (neq new-form form)
1155      (return-from p1-function-call (p1 new-form))))
1156  (let* ((op (car form))
1157         (local-function (find-local-function op)))
1158    (when local-function
1159;;            (format t "p1 local call to ~S~%" op)
1160;;            (format t "inline-p = ~S~%" (inline-p op))
1161
1162      (when (and *enable-inline-expansion* (inline-p op)
1163                 (local-function-definition local-function))
1164        (let* ((definition (local-function-definition local-function))
1165               (lambda-list (car definition))
1166               (body (cdr definition))
1167               (expansion (generate-inline-expansion op lambda-list body
1168                                                     (cdr form))))
1169          (when expansion
1170            (let ((explain *explain*))
1171              (when (and explain (memq :calls explain))
1172                (format t ";   inlining call to local function ~S~%" op)))
1173            (return-from p1-function-call
1174                         (let ((*inline-declarations*
1175                                (remove op *inline-declarations* :key #'car :test #'equal)))
1176                           (p1 expansion))))))))
1177  (p1-default form))
1178
1179(defun %funcall (fn &rest args)
1180  "Dummy FUNCALL wrapper to force p1 not to optimize the call."
1181  (apply fn args))
1182
1183(defun p1-variable-reference (var)
1184  (let ((variable (find-visible-variable var)))
1185    (when (null variable)
1186      (unless (or (special-variable-p var)
1187                  (memq var *undefined-variables*))
1188        (compiler-style-warn
1189         "Undefined variable ~S assumed special" var)
1190        (push var *undefined-variables*))
1191      (setf variable (make-variable :name var :special-p t))
1192      (push variable *visible-variables*))
1193    (let ((ref (make-var-ref variable)))
1194      (unless (variable-special-p variable)
1195        (when (variable-ignore-p variable)
1196          (compiler-style-warn
1197           "Variable ~S is read even though it was declared to be ignored."
1198           (variable-name variable)))
1199        (push ref (variable-references variable))
1200        (incf (variable-reads variable))
1201        (cond
1202          ((eq (variable-compiland variable) *current-compiland*)
1203           (dformat t "p1: read ~S~%" var))
1204          (t
1205           (dformat t "p1: non-local read ~S variable-compiland = ~S current compiland = ~S~%"
1206                    var
1207                    (compiland-name (variable-compiland variable))
1208                    (compiland-name *current-compiland*))
1209           (setf (variable-used-non-locally-p variable) t))))
1210      ref)))
1211
1212(defknown p1 (t) t)
1213(defun p1 (form)
1214  (cond
1215    ((symbolp form)
1216     (let (value)
1217       (cond
1218         ((null form)
1219          form)
1220         ((eq form t)
1221          form)
1222         ((keywordp form)
1223          form)
1224         ((and (constantp form)
1225               (progn
1226                 (setf value (symbol-value form))
1227                 (or (numberp value)
1228                     (stringp value)
1229                     (pathnamep value))))
1230          (setf form value))
1231         (t
1232          (p1-variable-reference form)))))
1233    ((atom form)
1234     form)
1235    (t
1236     (let ((op (%car form))
1237           handler)
1238       (cond
1239         ((symbolp op)
1240          (when (find-local-function op)
1241            ;; local functions shadow macros and functions in
1242            ;; the global environment as well as compiler macros
1243            (return-from p1
1244              (p1-function-call form)))
1245          (when (compiler-macro-function op)
1246            (unless (notinline-p op)
1247              (multiple-value-bind (expansion expanded-p)
1248                  (compiler-macroexpand form)
1249                ;; Fall through if no change...
1250                (when expanded-p
1251                  (return-from p1 (p1 expansion))))))
1252          (cond
1253            ((setf handler (get op 'p1-handler))
1254             (funcall handler form))
1255            ((macro-function op *compile-file-environment*)
1256             (p1 (macroexpand form *compile-file-environment*)))
1257            ((special-operator-p op)
1258             (compiler-unsupported "P1: unsupported special operator ~S" op))
1259            (t
1260             (p1-function-call form))))
1261         ((and (consp op) (eq (%car op) 'LAMBDA))
1262          (let ((maybe-optimized-call (rewrite-function-call form)))
1263            (if (eq maybe-optimized-call form)
1264                (p1 `(%funcall (function ,op) ,@(cdr form)))
1265                (p1 maybe-optimized-call))))
1266         (t
1267          form))))))
1268
1269(defun install-p1-handler (symbol handler)
1270  (setf (get symbol 'p1-handler) handler))
1271
1272(defun initialize-p1-handlers ()
1273  (dolist (pair '((AND                  p1-default)
1274                  (BLOCK                p1-block)
1275                  (CATCH                p1-catch)
1276                  (DECLARE              identity)
1277                  (EVAL-WHEN            p1-eval-when)
1278                  (FLET                 p1-flet)
1279                  (FUNCALL              p1-funcall)
1280                  (FUNCTION             p1-function)
1281                  (GO                   p1-go)
1282                  (IF                   p1-default)
1283                  ;; used to be p1-if, which was used to rewrite the test
1284                  ;; form to a LET-binding; that's not necessary, because
1285                  ;; the test form doesn't lead to multiple operands on the
1286                  ;; operand stack
1287                  (LABELS               p1-labels)
1288                  (LAMBDA               p1-lambda)
1289                  (LET                  p1-let/let*)
1290                  (LET*                 p1-let/let*)
1291                  (LOAD-TIME-VALUE      identity)
1292                  (LOCALLY              p1-locally)
1293                  (MULTIPLE-VALUE-BIND  p1-m-v-b)
1294                  (MULTIPLE-VALUE-CALL  p1-default)
1295                  (MULTIPLE-VALUE-LIST  p1-default)
1296                  (MULTIPLE-VALUE-PROG1 p1-default)
1297                  (OR                   p1-default)
1298                  (PROGN                p1-default)
1299                  (PROGV                p1-progv)
1300                  (QUOTE                p1-quote)
1301                  (RETURN-FROM          p1-return-from)
1302                  (SETQ                 p1-setq)
1303                  (SYMBOL-MACROLET      identity)
1304                  (TAGBODY              p1-tagbody)
1305                  (THE                  p1-the)
1306                  (THROW                p1-throw)
1307                  (TRULY-THE            p1-truly-the)
1308                  (UNWIND-PROTECT       p1-unwind-protect)
1309                  (THREADS:SYNCHRONIZED-ON
1310                                        p1-threads-synchronized-on)
1311      (JVM::WITH-INLINE-CODE identity)))
1312    (install-p1-handler (%car pair) (%cadr pair))))
1313
1314(initialize-p1-handlers)
1315
1316(defun p1-compiland (compiland)
1317;;   (format t "p1-compiland name = ~S~%" (compiland-name compiland))
1318  (let ((*current-compiland* compiland)
1319        (*local-functions* *local-functions*)
1320        (*visible-variables* *visible-variables*)
1321        (form (compiland-lambda-expression compiland)))
1322    (aver (eq (car form) 'LAMBDA))
1323    (setf form (rewrite-lambda form))
1324    (with-saved-compiler-policy
1325      (process-optimization-declarations (cddr form))
1326
1327      (let* ((lambda-list (cadr form))
1328             (body (cddr form))
1329             (closure (make-closure `(lambda ,lambda-list nil) nil))
1330             (syms (sys::varlist closure))
1331             (vars nil)
1332             compiland-result)
1333        (dolist (sym syms)
1334          (let ((var (make-variable :name sym
1335                                    :special-p (special-variable-p sym))))
1336            (push var vars)
1337            (push var *all-variables*)
1338            (push var *visible-variables*)))
1339        (setf (compiland-arg-vars compiland) (nreverse vars))
1340        (let ((free-specials (process-declarations-for-vars body vars nil)))
1341          (setf (compiland-free-specials compiland) free-specials)
1342          (dolist (var free-specials)
1343            (push var *visible-variables*)))
1344        (setf compiland-result
1345              (list* 'LAMBDA lambda-list (p1-body body)))
1346        (setf (compiland-%single-valued-p compiland)
1347              (single-valued-p compiland-result))
1348        (setf (compiland-p1-result compiland)
1349              compiland-result)))))
1350
1351(provide "COMPILER-PASS1")
Note: See TracBrowser for help on using the repository browser.