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

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

PRECOMPILE-IF

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