source: branches/1.1.x/src/org/armedbear/lisp/compiler-pass1.lisp

Last change on this file was 14147, checked in by ehuelsmann, 12 years ago

Close #241: Fix "part 2": ABCL accepts disallowed lambda list ordering.

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