source: trunk/j/src/org/armedbear/lisp/precompiler.lisp @ 8429

Last change on this file since 8429 was 8429, checked in by piso, 17 years ago

PRECOMPILE: bind *WARN-ON-REDEFINITION* to NIL.

File size: 30.9 KB
Line 
1;;; precompiler.lisp
2;;;
3;;; Copyright (C) 2003-2005 Peter Graves
4;;; $Id: precompiler.lisp,v 1.87 2005-01-31 17:25:39 piso Exp $
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., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
19
20(in-package "SYSTEM")
21
22(define-compiler-macro assoc (&whole form &rest args)
23  (cond ((and (= (length args) 4)
24              (eq (third args) :test)
25              (or (equal (fourth args) '(quote eq))
26                  (equal (fourth args) '(function eq))))
27         `(assq ,(first args) ,(second args)))
28        ((= (length args) 2)
29         `(assql ,(first args) ,(second args)))
30        (t form)))
31
32(define-compiler-macro member (&whole form &rest args)
33  (cond ((and (= (length args) 4)
34              (eq (third args) :test)
35              (or (equal (fourth args) '(quote eq))
36                  (equal (fourth args) '(function eq))))
37         `(memq ,(first args) ,(second args)))
38        ((and (= (length args) 4)
39              (eq (third args) :test)
40              (or (equal (fourth args) '(quote eql))
41                  (equal (fourth args) '(function eql))))
42         `(memql ,(first args) ,(second args)))
43        ((= (length args) 2)
44         `(memql ,(first args) ,(second args)))
45        (t form)))
46
47(define-compiler-macro search (&whole form &rest args)
48  (if (= (length args) 2)
49      `(simple-search ,@args)
50      form))
51
52(define-compiler-macro %aset (&whole form &rest args)
53  (if (= (length args) 3)
54      `(%set-row-major-aref ,(first args) ,(second args) ,(third args))
55      form))
56
57(define-compiler-macro identity (&whole form &rest args)
58  (if (= (length args) 1)
59      `(progn ,(car args))
60      form))
61
62(defun quoted-form-p (form)
63  (and (consp form) (eq (car form) 'quote) (= (length form) 2)))
64
65(define-compiler-macro eql (&whole form &rest args)
66  (let ((first (car args))
67        (second (cadr args)))
68    (if (or (and (sys::quoted-form-p first) (symbolp (cadr first)))
69            (and (sys::quoted-form-p second) (symbolp (cadr second))))
70        `(eq ,(car args) ,(cadr args))
71        form)))
72
73(define-compiler-macro not (&whole form arg)
74  (if (atom arg)
75      form
76      (let ((op (case (car arg)
77                  (>= '<)
78                  (<  '>=)
79                  (<= '>)
80                  (>  '<=)
81                  (t  nil))))
82        (if (and op (= (length arg) 3))
83            (cons op (cdr arg))
84            form))))
85
86(define-compiler-macro typep (&whole form &rest args)
87  (if (= (length args) 2)
88      `(%typep ,@args)
89      form))
90
91(define-compiler-macro subtypep (&whole form &rest args)
92  (if (= (length args) 2)
93      `(%subtypep ,@args)
94      form))
95
96(define-compiler-macro funcall (&whole form &rest args)
97  (let ((callee (car args)))
98    (if (and (>= jvm:*speed* jvm:*debug*)
99             (consp callee)
100             (eq (car callee) 'function)
101             (symbolp (cadr callee))
102             (not (special-operator-p (cadr callee)))
103             (not (macro-function (cadr callee)))
104             (memq (symbol-package (cadr callee))
105                   (list (find-package "CL") (find-package "SYS"))))
106        `(,(cadr callee) ,@(cdr args))
107        form)))
108
109(define-compiler-macro byte (size position)
110  `(cons ,size ,position))
111
112(define-compiler-macro byte-size (bytespec)
113  `(car ,bytespec))
114
115(define-compiler-macro byte-position (bytespec)
116  `(cdr ,bytespec))
117
118(define-compiler-macro ldb (&whole form bytespec integer)
119  (if (and (consp bytespec)
120           (eq (car bytespec) 'byte)
121           (= (length bytespec) 3))
122      (let ((size (second bytespec))
123            (position (third bytespec)))
124        `(sys::%ldb ,size ,position ,integer))
125      form))
126
127(define-compiler-macro catch (&whole form tag &rest args)
128  (if (and (null (cdr args))
129           (constantp (car args)))
130      (car args)
131      form))
132
133(define-compiler-macro string= (&whole form &rest args)
134  (if (= (length args) 2)
135      `(sys::%%string= ,@args)
136      form))
137
138(in-package "EXTENSIONS")
139
140(export '(precompile-form precompile))
141
142(unless (find-package "PRECOMPILER")
143  (make-package "PRECOMPILER"
144                :nicknames '("PRE")
145                :use '("COMMON-LISP" "EXTENSIONS")))
146
147(in-package "PRECOMPILER")
148
149(defvar *in-jvm-compile* nil)
150
151;;; From OpenMCL.
152(defun compiler-macroexpand-1 (form &optional env)
153  (let ((expander nil)
154        (newdef nil))
155    (if (and (consp form)
156             (symbolp (car form))
157             (setq expander (compiler-macro-function (car form) env)))
158        (values (setq newdef (funcall expander form env))
159                (not (eq newdef form)))
160        (values form
161                nil))))
162
163(defun compiler-macroexpand (form &optional env)
164  (let ((expanded-p nil))
165    (loop
166      (multiple-value-bind (expansion exp-p) (compiler-macroexpand-1 form env)
167        (if exp-p
168            (setf form expansion expanded-p t)
169            (return))))
170    (values form expanded-p)))
171
172(defvar *local-variables* ())
173
174(defun find-varspec (sym)
175  (dolist (varspec *local-variables*)
176    (when (eq sym (car varspec))
177      (return varspec))))
178
179(defun precompile1 (form)
180  (cond ((symbolp form)
181         (let ((varspec (find-varspec form)))
182           (if (and varspec (eq (second varspec) :symbol-macro))
183               (third varspec)
184               form)))
185        ((atom form)
186         form)
187        (t
188         (let ((op (car form))
189               handler)
190           (when (symbolp op)
191             (cond ((local-macro-function op)
192                    (let ((result (expand-local-macro (precompile-cons form))))
193                      (return-from precompile1
194                                   (if (equal result form)
195                                       result
196                                       (precompile1 result)))))
197                   ((compiler-macro-function op)
198                    (let ((result (compiler-macroexpand form)))
199                      ;; Fall through if no change...
200                      (unless (equal result form)
201                        (return-from precompile1 (precompile1 result)))))
202                   ((setf handler (get op 'precompile-handler))
203                    (return-from precompile1 (funcall handler form)))
204                   ((macro-function op)
205                    (return-from precompile1 (precompile1 (expand-macro form))))
206                   ((special-operator-p op)
207                    (error "PRECOMPILE1: unsupported special operator ~S." op))))
208           (precompile-cons form)))))
209
210(defun precompile-identity (form)
211  (declare (optimize speed (safety 0)))
212  form)
213
214(defun precompile-cons (form)
215  (cons (car form) (mapcar #'precompile1 (cdr form))))
216
217(defun precompile-block (form)
218  (let ((args (cdr form)))
219    (if (null (cdr args))
220        nil
221        (list* 'BLOCK (car args) (mapcar #'precompile1 (cdr args))))))
222
223(defun precompile-dolist (form)
224  (if *in-jvm-compile*
225      (precompile1 (macroexpand form))
226      (cons 'DOLIST (cons (cadr form) (mapcar #'precompile1 (cddr form))))))
227
228(defun precompile-dotimes (form)
229  (if *in-jvm-compile*
230      (precompile1 (macroexpand form))
231      (cons 'DOTIMES (cons (cadr form) (mapcar #'precompile1 (cddr form))))))
232
233(defun precompile-do/do*-vars (varlist)
234  (let ((result nil))
235    (dolist (varspec varlist)
236      (if (atom varspec)
237          (push varspec result)
238          (case (length varspec)
239            (1
240             (push (car varspec) result))
241            (2
242             (let* ((var (car varspec))
243                    (init-form (cadr varspec)))
244               (unless (symbolp var)
245                 (error 'type-error))
246               (push (list var (precompile1 init-form))
247                     result)))
248            (3
249             (let* ((var (car varspec))
250                    (init-form (cadr varspec))
251                    (step-form (caddr varspec)))
252               (unless (symbolp var)
253                 (error 'type-error))
254               (push (list var (precompile1 init-form) (precompile1 step-form))
255                     result))))))
256    (nreverse result)))
257
258(defun precompile-do/do*-end-form (end-form)
259  (let ((end-test-form (car end-form))
260        (result-forms (cdr end-form)))
261    (list* end-test-form (mapcar #'precompile1 result-forms))))
262
263(defun precompile-do/do* (form)
264  (if *in-jvm-compile*
265      (precompile1 (macroexpand form))
266      (list* (car form)
267             (precompile-do/do*-vars (cadr form))
268             (precompile-do/do*-end-form (caddr form))
269             (mapcar #'precompile1 (cdddr form)))))
270
271(defun precompile-do-symbols (form)
272  (list* (car form) (cadr form) (mapcar #'precompile1 (cddr form))))
273
274(defun precompile-load-time-value (form)
275  form)
276
277(defun precompile-progn (form)
278  (let ((body (cdr form)))
279    (if (= (length body) 1)
280        (let ((res (precompile1 (car body))))
281          ;; If the result turns out to be a bare symbol, leave it wrapped
282          ;; with PROGN so it won't be mistaken for a tag in an enclosing
283          ;; TAGBODY.
284          (if (symbolp res)
285              (list 'progn res)
286              res))
287        (cons 'PROGN (mapcar #'precompile1 body)))))
288
289(defun precompile-progv (form)
290  (list* 'PROGV (cadr form) (caddr form) (mapcar #'precompile1 (cdddr form))))
291
292(defun precompile-setf (form)
293  (let ((place (second form)))
294    (cond ((and (consp place)
295                (local-macro-function (car place)))
296           (let ((expansion (expand-local-macro place)))
297             (precompile1 (list* 'SETF expansion (cddr form)))))
298          ((and (consp place)
299                (eq (car place) 'VALUES))
300           (setf form
301                 (list* 'SETF
302                        (list* 'VALUES
303                               (mapcar #'precompile1 (cdr place)))
304                        (cddr form)))
305           (precompile1 (expand-macro form)))
306          ((symbolp place)
307           (let ((varspec (find-varspec place)))
308             (if (and varspec (eq (second varspec) :symbol-macro))
309                 (precompile1 (list* 'SETF (third varspec) (cddr form)))
310                 (precompile1 (expand-macro form)))))
311          (t
312           (precompile1 (expand-macro form))))))
313
314(defun precompile-setq (form)
315  (let* ((args (cdr form))
316         (len (length args)))
317    (when (oddp len)
318      (error 'simple-program-error
319             :format-control "Odd number of arguments to SETQ."))
320    (if (= len 2)
321        (let* ((sym (car args))
322               (val (cadr args))
323               (varspec (find-varspec sym)))
324          (if (and varspec (eq (second varspec) :symbol-macro))
325              (precompile1 (list 'SETF (third varspec) val))
326              (list 'SETQ sym (precompile1 val))))
327        (let ((result ()))
328          (loop
329            (when (null args)
330              (return))
331            (push (precompile-setq (list 'SETQ (car args) (cadr args))) result)
332            (setq args (cddr args)))
333          (setq result (nreverse result))
334          (push 'PROGN result)
335          result))))
336
337(defun precompile-psetf (form)
338  (setf form
339        (list* 'PSETF
340               (mapcar #'precompile1 (cdr form))))
341  (precompile1 (expand-macro form)))
342
343(defun precompile-psetq (form)
344  ;; Make sure all the vars are symbols.
345  (do* ((rest (cdr form) (cddr rest))
346        (var (car rest)))
347       ((null rest))
348    (unless (symbolp var)
349      (error 'simple-error
350             :format-control "~S is not a symbol."
351             :format-arguments (list var))))
352  ;; Delegate to PRECOMPILE-PSETF so symbol macros are handled correctly.
353  (precompile-psetf form))
354
355(defun maybe-rewrite-lambda (form)
356  (let* ((args (cdr form))
357         (lambda-list (car args))
358         (body (cdr args))
359         (auxvars (memq '&AUX lambda-list))
360         (specials '()))
361    (when auxvars
362      (setf lambda-list (subseq lambda-list 0 (position '&AUX lambda-list)))
363      (setf body (list (append (list 'LET* (cdr auxvars)) body))))
364    (dolist (var lambda-list)
365      (when (consp var)
366        (if (consp (first var))
367            (setf var (second (first var)))   ;; e.g. "&key ((:x *x*) 42)"
368            (setf var (first var))))          ;; e.g. "&optional (*x* 42)"
369      (when (special-variable-p var)
370        (push var specials)))
371    (when specials
372      (dolist (special specials)
373        (let ((sym (gensym)))
374          (let ((res ())
375                (keyp nil))
376            (dolist (var lambda-list)
377              (cond ((eq var '&KEY)
378                     (setf keyp t)
379                     (push var res))
380                    ((and (consp var) (consp (first var))
381                          (eq special (second (first var))))
382                     (push (list (list (first (first var)) sym) (second var)) res))
383                    ((and (consp var) (eq special (first var)))
384                     (push (cons sym (cdr var)) res))
385                    ((eq var special)
386                     (if keyp
387                         ;; "&key x" => "&key ((:x x) nil)"
388                         (push (list (list (intern (symbol-name var) sys:*keyword-package*)
389                                           sym)
390                                     nil)
391                               res)
392                         (push sym res)))
393                    (t
394                     (push var res))))
395            (setf lambda-list (nreverse res)))
396          (setf body (list (append (list 'LET* (list (list special sym))) body))))))
397    (list* 'LAMBDA lambda-list body)))
398
399(defun precompile-lambda (form)
400  (setf form (maybe-rewrite-lambda form))
401  (list* 'LAMBDA (cadr form) (mapcar #'precompile1 (cddr form))))
402
403(defun define-local-macro (name lambda-list body)
404  (let* ((form (gensym))
405         (env (gensym))
406         (body (sys::parse-defmacro lambda-list form body name 'macrolet
407                                    :environment env))
408         (expander `(lambda (,form ,env) (block ,name ,body)))
409         (compiled-expander (sys::%compile nil expander)))
410    (sys::coerce-to-function (or compiled-expander expander))))
411
412(defvar *local-functions-and-macros* ())
413
414(defun local-macro-function (name)
415  (getf *local-functions-and-macros* name))
416
417(defun expand-local-macro (form)
418  (let ((expansion (funcall (local-macro-function (car form)) form nil)))
419    ;; If the expansion turns out to be a bare symbol, wrap it with PROGN so it
420    ;; won't be mistaken for a tag in an enclosing TAGBODY.
421    (if (symbolp expansion)
422        (list 'progn expansion)
423        expansion)))
424
425(defun precompile-macrolet (form)
426  (let ((*local-functions-and-macros* *local-functions-and-macros*)
427        (macros (cadr form)))
428    (dolist (macro macros)
429      (let ((name (car macro))
430            (lambda-list (cadr macro))
431            (forms (cddr macro)))
432        (push (define-local-macro name lambda-list forms) *local-functions-and-macros*)
433        (push name *local-functions-and-macros*)))
434    ;; FIXME Process declarations!
435    (let ((body (sys::parse-body (cddr form) nil)))
436      (list* 'PROGN (mapcar #'precompile1 body)))))
437
438;; "If the restartable-form is a list whose car is any of the symbols SIGNAL,
439;; ERROR, CERROR, or WARN (or is a macro form which macroexpands into such a
440;; list), then WITH-CONDITION-RESTARTS is used implicitly to associate the
441;; indicated restarts with the condition to be signaled." So we need to
442;; precompile the restartable form before macroexpanding RESTART-CASE.
443(defun precompile-restart-case (form)
444  (let ((new-form (list* 'RESTART-CASE (precompile1 (cadr form)) (cddr form))))
445    (precompile1 (macroexpand new-form))))
446
447(defun precompile-symbol-macrolet (form)
448  (let ((*local-variables* *local-variables*)
449        (defs (cadr form)))
450    (dolist (def defs)
451      (let ((sym (car def))
452            (expansion (cadr def)))
453        (when (special-variable-p sym)
454          (error 'program-error
455                 :format-control "Attempt to bind the special variable ~S with SYMBOL-MACROLET."
456                 :format-arguments (list sym)))
457        (push (list sym :symbol-macro expansion) *local-variables*)))
458    (multiple-value-bind (body decls) (sys::parse-body (cddr form) nil)
459      (when decls
460        (let ((specials ()))
461          (dolist (decl decls)
462            (when (eq (car decl) 'DECLARE)
463              (dolist (declspec (cdr decl))
464                (when (eq (car declspec) 'SPECIAL)
465                  (setf specials (append specials (cdr declspec)))))))
466          (when specials
467            (let ((syms (mapcar #'car (cadr form))))
468              (dolist (special specials)
469                (when (memq special syms)
470                  (error 'program-error
471                         :format-control "~S is a symbol-macro and may not be declared special."
472                         :format-arguments (list special))))))))
473      (list* 'PROGN (mapcar #'precompile1 body)))))
474
475(defun precompile-the (form)
476  (list 'THE
477        (second form)
478        (precompile1 (third form))))
479
480(defun precompile-let/let*-vars (vars)
481  (let ((result nil))
482    (dolist (var vars)
483      (cond ((consp var)
484             (let ((v (car var))
485                   (expr (cadr var)))
486               (unless (symbolp v)
487                 (error 'simple-type-error
488                        :format-control "The variable ~S is not a symbol."
489                        :format-arguments (list v)))
490               (push (list v (precompile1 expr)) result)
491               (push (list v :variable) *local-variables*)))
492            (t
493             (push var result)
494             (push (list var :variable) *local-variables*))))
495    (nreverse result)))
496
497(defun precompile-let (form)
498  (let ((*local-variables* *local-variables*))
499    (list* 'LET
500           (precompile-let/let*-vars (cadr form))
501           (mapcar #'precompile1 (cddr form)))))
502
503;; (LET* ((X 1)) (LET* ((Y 2)) (LET* ((Z 3)) (+ X Y Z)))) =>
504;; (LET* ((X 1) (Y 2) (Z 3)) (+ X Y Z))
505(defun maybe-fold-let* (form)
506  (if (and (= (length form) 3)
507           (consp (third form))
508           (eq (car (third form)) 'let*))
509      (let ((third (maybe-fold-let* (third form))))
510        (list* 'LET* (append (second form) (second third)) (cddr third)))
511      form))
512
513(defun precompile-let* (form)
514  (setf form (maybe-fold-let* form))
515  (let ((*local-variables* *local-variables*))
516    (list* 'LET*
517           (precompile-let/let*-vars (cadr form))
518           (mapcar #'precompile1 (cddr form)))))
519
520(defun precompile-case (form)
521  (if *in-jvm-compile*
522      (precompile1 (macroexpand form))
523      (let* ((keyform (cadr form))
524             (clauses (cddr form))
525             (result (list (precompile1 keyform))))
526        (dolist (clause clauses)
527          (push (precompile-case-clause clause) result))
528        (cons (car form) (nreverse result)))))
529
530(defun precompile-case-clause (clause)
531  (let ((keys (car clause))
532        (forms (cdr clause)))
533    (cons keys (mapcar #'precompile1 forms))))
534
535(defun precompile-cond (form)
536  (if *in-jvm-compile*
537      (precompile1 (macroexpand form))
538      (let ((clauses (cdr form))
539            (result nil))
540        (dolist (clause clauses)
541          (push (precompile-cond-clause clause) result))
542        (cons 'COND (nreverse result)))))
543
544(defun precompile-cond-clause (clause)
545  (let ((test (car clause))
546        (forms (cdr clause)))
547    (cons (precompile1 test) (mapcar #'precompile1 forms))))
548
549(defun precompile-local-function-def (def)
550  (let ((name (car def))
551        (arglist (cadr def))
552        (body (cddr def)))
553    ;; Macro names are shadowed by local functions.
554    (push nil *local-functions-and-macros*)
555    (push name *local-functions-and-macros*)
556    (list* name arglist (mapcar #'precompile1 body))))
557
558(defun precompile-local-functions (defs)
559  (let ((result nil))
560    (dolist (def defs (nreverse result))
561      (push (precompile-local-function-def def) result))))
562
563(defun find-use (name expression)
564  (cond ((atom expression)
565         nil)
566        ((eq (car expression) name)
567         t)
568        ((consp name)
569         t) ;; FIXME Recognize use of SETF functions!
570        (t
571         (or (find-use name (car expression))
572             (find-use name (cdr expression))))))
573
574(defun precompile-flet/labels (form)
575  (let ((*local-functions-and-macros* *local-functions-and-macros*)
576        (operator (car form))
577        (locals (cadr form))
578        (body (cddr form)))
579    (dolist (local locals)
580      (let* ((name (car local))
581             (used-p (find-use name body)))
582        (unless used-p
583          (when (eq operator 'LABELS)
584            (dolist (local locals)
585              (when (neq name (car local))
586                (when (find-use name (cddr local))
587                  (setf used-p t)
588                  (return))
589                ;; Scope of defined function names includes &AUX parameters (LABELS.7B).
590                (let ((aux-vars (cdr (memq '&aux (cadr local)))))
591                  (when (and aux-vars (find-use name aux-vars)
592                             (setf used-p t)
593                             (return))))))))
594        (unless used-p
595          (format t "; Note: deleting unused local function ~A ~S~%" operator name)
596          (let* ((new-locals (remove local locals :test 'eq))
597                 (new-form
598                  (if new-locals
599                      (list* operator new-locals body)
600                      (list* 'PROGN body))))
601            (return-from precompile-flet/labels (precompile1 new-form))))))
602    (list* (car form)
603           (precompile-local-functions locals)
604           (mapcar #'precompile1 body))))
605
606(defun precompile-function (form)
607  (if (and (consp (cadr form)) (eq (caadr form) 'LAMBDA))
608      (list 'FUNCTION (precompile-lambda (cadr form)))
609      form))
610
611(defun precompile-if (form)
612  (let ((args (cdr form)))
613    (case (length args)
614      (2
615       (let ((test (precompile1 (car args))))
616         (cond ((null test)
617                nil)
618               (;;(constantp test)
619                (eq test t)
620                (precompile1 (cadr args)))
621               (t
622                (list 'IF
623                      test
624                      (precompile1 (cadr args)))))))
625      (3
626       (let ((test (precompile1 (car args))))
627         (cond ((null test)
628                (precompile1 (caddr args)))
629               (;;(constantp test)
630                (eq test t)
631                (precompile1 (cadr args)))
632               (t
633                (list 'IF
634                      test
635                      (precompile1 (cadr args))
636                      (precompile1 (caddr args)))))))
637      (t
638       (error "wrong number of arguments for IF")))))
639
640(defun precompile-when (form)
641  (if *in-jvm-compile*
642      (precompile1 (macroexpand form))
643      (precompile-cons form)))
644
645(defun precompile-unless (form)
646  (if *in-jvm-compile*
647      (precompile1 (macroexpand form))
648      (precompile-cons form)))
649
650(defun precompile-and (form)
651  (if *in-jvm-compile*
652      (precompile1 (macroexpand form))
653      (precompile-cons form)))
654
655(defun precompile-or (form)
656  (if *in-jvm-compile*
657      (precompile1 (macroexpand form))
658      (precompile-cons form)))
659
660;; MULTIPLE-VALUE-BIND is handled explicitly by the JVM compiler.
661(defun precompile-multiple-value-bind (form)
662  (let ((vars (cadr form))
663        (values-form (caddr form))
664        (body (cdddr form)))
665    (list* 'MULTIPLE-VALUE-BIND
666           vars
667           (precompile1 values-form)
668           (mapcar #'precompile1 body))))
669
670;; MULTIPLE-VALUE-LIST is handled explicitly by the JVM compiler.
671(defun precompile-multiple-value-list (form)
672  (list 'MULTIPLE-VALUE-LIST (precompile1 (cadr form))))
673
674(defun precompile-nth-value (form)
675  (if *in-jvm-compile*
676      (precompile1 (macroexpand form))
677      form))
678
679(defun precompile-return (form)
680  (if *in-jvm-compile*
681      (precompile1 (macroexpand form))
682      (list 'RETURN (precompile1 (cadr form)))))
683
684(defun precompile-return-from (form)
685  (list 'RETURN-FROM (cadr form) (precompile1 (caddr form))))
686
687(defun precompile-tagbody (form)
688  (do ((body (cdr form) (cdr body))
689       (result ()))
690      ((null body) (cons 'TAGBODY (nreverse result)))
691    (if (atom (car body))
692        (push (car body) result)
693        (push (precompile1 (car body)) result))))
694
695(defun precompile-eval-when (form)
696  (list* 'EVAL-WHEN (cadr form) (mapcar #'precompile1 (cddr form))))
697
698(defun precompile-unwind-protect (form)
699  (list* 'UNWIND-PROTECT
700         (precompile1 (cadr form))
701         (mapcar #'precompile1 (cddr form))))
702
703;; EXPAND-MACRO is like MACROEXPAND, but EXPAND-MACRO quits if *IN-JVM-COMPILE*
704;; is false and a macro is encountered that is also implemented as a special
705;; operator, so interpreted code can use the special operator implementation.
706(defun expand-macro (form)
707  (loop
708    (unless *in-jvm-compile*
709      (when (and (consp form)
710                 (symbolp (car form))
711                 (special-operator-p (car form)))
712        (return-from expand-macro form)))
713    (multiple-value-bind (result expanded) (macroexpand-1 form)
714      (unless expanded
715        (return-from expand-macro result))
716      (setf form result))))
717
718(defun precompile-form (form in-jvm-compile)
719  (let ((*in-jvm-compile* in-jvm-compile)
720        (*local-functions-and-macros* ()))
721    (precompile1 form)))
722
723(defun install-handler (fun &optional handler)
724  (let ((handler (or handler
725                     (find-symbol (sys::%format nil "PRECOMPILE-~A" (symbol-name fun))
726                                  'precompiler))))
727    (unless (and handler (fboundp handler))
728      (error "No handler for ~S." fun))
729    (setf (get fun 'precompile-handler) handler)))
730
731(mapcar #'install-handler '(and
732                            block
733                            case
734                            cond
735                            dolist
736                            dotimes
737                            eval-when
738                            function
739                            if
740                            lambda
741                            macrolet
742                            multiple-value-bind
743                            multiple-value-list
744                            nth-value
745                            or
746                            progn
747                            progv
748                            psetf
749                            psetq
750                            restart-case
751                            return
752                            return-from
753                            setf
754                            setq
755                            symbol-macrolet
756                            tagbody
757                            unwind-protect
758                            unless
759                            when))
760
761(install-handler 'ecase                'precompile-case)
762
763(install-handler 'catch                'precompile-cons)
764(install-handler 'locally              'precompile-cons)
765(install-handler 'multiple-value-call  'precompile-cons)
766(install-handler 'multiple-value-prog1 'precompile-cons)
767
768(install-handler 'do                   'precompile-do/do*)
769(install-handler 'do*                  'precompile-do/do*)
770
771(install-handler 'let                  'precompile-let)
772(install-handler 'let*                 'precompile-let*)
773
774(install-handler 'flet                 'precompile-flet/labels)
775(install-handler 'labels               'precompile-flet/labels)
776
777(install-handler 'load-time-value      'precompile-load-time-value)
778
779(install-handler 'declare              'precompile-identity)
780(install-handler 'defmethod            'precompile-identity)
781(install-handler 'defun                'precompile-identity)
782(install-handler 'go                   'precompile-identity)
783(install-handler 'quote                'precompile-identity)
784(install-handler 'the                  'precompile-the)
785(install-handler 'throw                'precompile-cons)
786
787(in-package "SYSTEM")
788
789(defun precompile (name &optional definition)
790  (unless definition
791    (setq definition (or (and (symbolp name) (macro-function name))
792                         (fdefinition name))))
793  (let (expr result)
794    (cond ((functionp definition)
795           (multiple-value-bind (form closure-p)
796             (function-lambda-expression definition)
797             (unless form
798;;                (format t "; No lambda expression available for ~S.~%" name)
799               (return-from precompile (values nil t t)))
800             (when closure-p
801               (format t "; Unable to compile function ~S defined in non-null lexical environment.~%" name)
802               (finish-output)
803               (return-from precompile (values nil t t)))
804             (setq expr form)))
805          ((and (consp definition) (eq (car definition) 'lambda))
806           (setq expr definition))
807          (t
808;;            (error 'type-error)))
809           (format t "Unable to precompile ~S.~%" name)
810           (return-from precompile (values nil t t))))
811    (setf result (coerce-to-function (precompile-form expr nil)))
812    (when (and name (functionp result))
813      (%set-lambda-name result name)
814      (set-call-count result (call-count definition))
815      (let ((*warn-on-redefinition* nil))
816        (if (and (symbolp name) (macro-function name))
817            (let ((mac (make-macro name result)))
818              (%set-arglist mac (arglist (symbol-function name)))
819              (setf (fdefinition name) mac))
820            (progn
821              (setf (fdefinition name) result)
822              (%set-arglist result (arglist definition))))))
823    (values (or name result) nil nil)))
824
825(defun precompile-package (pkg &key verbose)
826  (dolist (sym (package-symbols pkg))
827    (when (fboundp sym)
828      (unless (special-operator-p sym)
829        (let ((f (fdefinition sym)))
830          (unless (compiled-function-p f)
831            (when verbose
832              (format t "Precompiling ~S~%" sym)
833              (finish-output))
834            (precompile sym))))))
835  t)
836
837(defun %compile (name definition)
838  (if (and name (fboundp name) (%typep (symbol-function name) 'generic-function))
839      (values name nil nil)
840      (precompile name definition)))
841
842;; Redefine EVAL to precompile its argument.
843(defun eval (form)
844  (%eval (precompile-form form nil)))
845
846;; Redefine DEFMACRO to precompile the expansion function on the fly.
847(defmacro defmacro (name lambda-list &rest body)
848  (let* ((form (gensym))
849         (env (gensym))
850         (body (parse-defmacro lambda-list form body name 'defmacro
851                               :environment env))
852         (expander `(lambda (,form ,env) (block ,name ,body))))
853    `(progn
854       (let ((macro (make-macro ',name
855                                (or (precompile nil ,expander) ,expander))))
856         (if (special-operator-p ',name)
857             (%put ',name 'macroexpand-macro macro)
858             (fset ',name macro))
859         (%set-arglist macro ',lambda-list)
860         ',name))))
861
862;; Make an exception just this one time...
863(when (get 'defmacro 'macroexpand-macro)
864  (fset 'defmacro (get 'defmacro 'macroexpand-macro))
865  (remprop 'defmacro 'macroexpand-macro))
866
867;; Redefine DEFUN to precompile the definition on the fly.
868(defmacro defun (name lambda-list &rest body &environment env)
869  (when (and env (empty-environment-p env))
870    (setf env nil))
871  `(progn
872     (%defun ',name ',lambda-list ',body ,env)
873     (precompile ',name)
874     ',name))
Note: See TracBrowser for help on using the repository browser.