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

Last change on this file since 5244 was 5244, checked in by piso, 18 years ago

Work in progress.

File size: 20.0 KB
Line 
1;;; precompiler.lisp
2;;;
3;;; Copyright (C) 2003 Peter Graves
4;;; $Id: precompiler.lisp,v 1.24 2003-12-23 13:42:05 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(in-package "EXTENSIONS")
87
88(export '(precompile-form precompile))
89
90(unless (find-package "PRECOMPILER")
91  (make-package "PRECOMPILER"
92                :nicknames '("PRE")
93                :use '("COMMON-LISP" "EXTENSIONS")))
94
95(in-package "PRECOMPILER")
96
97(defvar *in-jvm-compile* nil)
98
99(defun precompile-identity (form)
100  form)
101
102(defun precompile-cons (form)
103  (cons (car form) (mapcar #'precompile1 (cdr form))))
104
105(defun precompile-block (form)
106  (let ((args (cdr form)))
107    (if (null (cdr args))
108        nil
109        (list* 'BLOCK (car args) (mapcar #'precompile1 (cdr args))))))
110
111(defun precompile-dolist (form)
112  (cons 'DOLIST (cons (cadr form) (mapcar #'precompile1 (cddr form)))))
113
114(defun precompile-dotimes (form)
115  (cons 'DOTIMES (cons (cadr form) (mapcar #'precompile1 (cddr form)))))
116
117(defun precompile-do/do*-vars (varlist)
118  (let ((result nil))
119    (dolist (varspec varlist)
120      (if (atom varspec)
121          (push varspec result)
122          (case (length varspec)
123            (1
124             (push (car varspec) result))
125            (2
126             (let* ((var (car varspec))
127                    (init-form (cadr varspec)))
128               (unless (symbolp var)
129                 (error 'type-error))
130               (push (list var (precompile1 init-form))
131                     result)))
132            (3
133             (let* ((var (car varspec))
134                    (init-form (cadr varspec))
135                    (step-form (caddr varspec)))
136               (unless (symbolp var)
137                 (error 'type-error))
138               (push (list var (precompile1 init-form) (precompile1 step-form))
139                     result))))))
140    (nreverse result)))
141
142(defun precompile-do/do* (form)
143  (list* (car form)
144         (precompile-do/do*-vars (cadr form))
145         (caddr form)
146         (mapcar #'precompile1 (cdddr form))))
147
148(defun precompile-do-symbols (form)
149  (list* (car form) (cadr form) (mapcar #'precompile1 (cddr form))))
150
151(defun precompile-load-time-value (form)
152  form)
153
154(defun precompile-progn (form)
155  (let ((body (cdr form)))
156    (if (= (length body) 1)
157        (let ((res (precompile1 (car body))))
158          ;; If the result turns out to be a bare symbol, leave it wrapped
159          ;; with PROGN so it won't be mistaken for a tag in an enclosing
160          ;; TAGBODY.
161          (if (symbolp res)
162              (list 'progn res)
163              res))
164        (cons 'PROGN (mapcar #'precompile1 body)))))
165
166(defun precompile-progv (form)
167  (list* 'PROGV (cadr form) (caddr form) (mapcar #'precompile1 (cdddr form))))
168
169(defun precompile-setq (form)
170  (let* ((args (cdr form))
171         (len (length args)))
172    (when (oddp len)
173      (error "odd number of arguments to SETQ"))
174    (if (= len 2)
175        (list 'SETQ (car args) (precompile1 (cadr args)))
176        (let ((result ()))
177          (loop
178            (when (null args)
179              (return))
180            (push (list 'SETQ (car args) (precompile1 (cadr args))) result)
181            (setq args (cddr args)))
182          (setq result (nreverse result))
183          (push 'PROGN result)
184          result))))
185
186(defun precompile-lambda (form)
187  (let* ((args (cdr form))
188         (lambda-list (car args))
189         (body (cdr args))
190         (auxvars (memq '&AUX lambda-list)))
191    (when auxvars
192      (setf lambda-list (subseq lambda-list 0 (position '&AUX lambda-list)))
193      (setf body (list (append (list 'LET* (cdr auxvars)) body))))
194    (let ((specials ()))
195      (dolist (var lambda-list)
196        (when (special-variable-p var)
197          (push var specials)))
198      (when specials
199        (dolist (var specials)
200          (let ((sym (gensym)))
201            (setf lambda-list (subst sym var lambda-list))
202            (setf body (list (append (list 'LET* (list (list var sym))) body)))))))
203    (list* 'LAMBDA lambda-list (mapcar #'precompile1 body))))
204
205(defun define-local-macro (name lambda-list body)
206  (let* ((form (gensym))
207         (env (gensym))
208         (body (sys::parse-defmacro lambda-list form body name 'macrolet
209                                    :environment env))
210         (expander `(lambda (,form ,env) (block ,name ,body)))
211         (compiled-expander (compile nil expander)))
212    (sys::coerce-to-function (or compiled-expander expander))))
213
214(defvar *local-macros* ())
215
216(defun local-macro-function (name)
217  (getf *local-macros* name))
218
219(defun expand-local-macro (form)
220  (let ((expansion (funcall (local-macro-function (car form)) form nil)))
221    ;; If the expansion turns out to be a bare symbol, wrap it with PROGN so it
222    ;; won't be mistaken for a tag in an enclosing TAGBODY.
223    (if (symbolp expansion)
224        (list 'progn expansion)
225        expansion)))
226
227(defun precompile-macrolet (form)
228  (let ((*local-macros* *local-macros*)
229        (macros (cadr form))
230        (body (cddr form))
231        (res ())
232        compiled-body)
233    (dolist (macro macros)
234      (let ((name (car macro))
235            (lambda-list (cadr macro))
236            (forms (cddr macro)))
237        (push (define-local-macro name lambda-list forms) *local-macros*)
238        (push name *local-macros*)
239        (push (list* name lambda-list (mapcar #'precompile1 forms)) res)))
240    (setf compiled-body (mapcar #'precompile1 body))
241    (setf res (list* 'PROGN compiled-body))
242    res))
243
244(defun precompile-symbol-macrolet (form)
245  (list* 'SYMBOL-MACROLET (cadr form) (mapcar #'precompile1 (cddr form))))
246
247(defun precompile-let/let*-vars (vars)
248  (let ((result nil))
249    (dolist (var vars)
250      (if (consp var)
251          (let* ((v (car var))
252                 (expr (cadr var)))
253            (unless (symbolp v)
254              (error 'type-error))
255            (push (list v (precompile1 expr)) result))
256          (push var result)))
257    (nreverse result)))
258
259(defun precompile-let/let* (form)
260  (list* (car form)
261         (precompile-let/let*-vars (cadr form))
262         (mapcar #'precompile1 (cddr form))))
263
264(defun precompile-case (form)
265  (let* ((keyform (cadr form))
266         (clauses (cddr form))
267         (result (list (precompile1 keyform))))
268    (dolist (clause clauses)
269      (push (precompile-case-clause clause) result))
270    (cons (car form) (nreverse result))))
271
272(defun precompile-case-clause (clause)
273  (let ((keys (car clause))
274        (forms (cdr clause)))
275    (cons keys (mapcar #'precompile1 forms))))
276
277(defun precompile-cond (form)
278  (let ((clauses (cdr form))
279        (result nil))
280    (dolist (clause clauses)
281      (push (precompile-cond-clause clause) result))
282    (cons 'COND (nreverse result))))
283
284(defun precompile-cond-clause (clause)
285  (let ((test (car clause))
286        (forms (cdr clause)))
287    (cons (precompile1 test) (mapcar #'precompile1 forms))))
288
289(defun precompile-local-function-def (def)
290  (let ((name (car def))
291        (arglist (cadr def))
292        (body (cddr def)))
293    (list* name arglist (mapcar #'precompile1 body))))
294
295(defun precompile-local-functions (defs)
296  (let ((result nil))
297    (dolist (def defs (nreverse result))
298      (push (precompile-local-function-def def) result))))
299
300(defun precompile-flet/labels (form)
301  (let ((locals (cadr form))
302        (body (cddr form)))
303    (list* (car form)
304           (precompile-local-functions locals)
305           (mapcar #'precompile1 body))))
306
307(defun precompile-function (form)
308  (if (and (consp (cadr form)) (eq (caadr form) 'LAMBDA))
309      (list 'FUNCTION (precompile-lambda (cadr form)))
310      form))
311
312(defun precompile-if (form)
313  (let ((args (cdr form)))
314    (case (length args)
315      (2
316       (let ((test (precompile1 (car args))))
317         (cond ((null test)
318                nil)
319               ((constantp test)
320                (precompile1 (cadr args)))
321               (t
322                (list 'IF
323                      test
324                      (precompile1 (cadr args)))))))
325      (3
326       (let ((test (precompile1 (car args))))
327         (cond ((null test)
328                (precompile1 (caddr args)))
329               ((constantp test)
330                (precompile1 (cadr args)))
331               (t
332                (list 'IF
333                      test
334                      (precompile1 (cadr args))
335                      (precompile1 (caddr args)))))))
336      (t
337       (error "wrong number of arguments for IF")))))
338
339(defun precompile-multiple-value-bind (form)
340  (let ((vars (cadr form))
341        (values-form (caddr form))
342        (body (cdddr form)))
343    (list* 'MULTIPLE-VALUE-BIND
344           vars
345           (precompile1 values-form)
346           (mapcar #'precompile1 body))))
347
348(defun precompile-multiple-value-list (form)
349  (list 'MULTIPLE-VALUE-LIST (precompile1 (cadr form))))
350
351(defun precompile-return (form)
352  (list 'RETURN (precompile1 (cadr form))))
353
354(defun precompile-return-from (form)
355  (list 'RETURN-FROM (cadr form) (precompile1 (caddr form))))
356
357(defun precompile-tagbody (form)
358  (do ((body (cdr form) (cdr body))
359       (result ()))
360      ((null body) (cons 'TAGBODY (nreverse result)))
361    (if (atom (car body))
362        (push (car body) result)
363        (push (precompile1 (car body)) result))))
364
365(defun precompile-the (form)
366  (precompile1 (caddr form)))
367
368(defun precompile-unwind-protect (form)
369  (list* 'UNWIND-PROTECT
370         (precompile1 (cadr form))
371         (mapcar #'precompile1 (cddr form))))
372
373;; EXPAND-MACRO is like MACROEXPAND, but EXPAND-MACRO quits if *in-jvm-compile*
374;; is false and a macro is encountered that's also implemented as a special
375;; operator, so interpreted code can use the special operator implementation.
376(defun expand-macro (form)
377  (loop
378    (unless *in-jvm-compile*
379      (when (and (consp form)
380                 (symbolp (car form))
381                 (special-operator-p (car form)))
382        (return-from expand-macro form)))
383    (multiple-value-bind (result expanded) (macroexpand-1 form)
384      (unless expanded
385        (return-from expand-macro result))
386      (setf form result))))
387
388;;; From OpenMCL.
389(defun compiler-macroexpand-1 (form &optional env)
390  (let ((expander nil)
391        (newdef nil))
392    (if (and (consp form)
393             (symbolp (car form))
394             (setq expander (compiler-macro-function (car form) env)))
395        (values (setq newdef (funcall expander form env))
396                (not (eq newdef form)))
397        (values form
398                nil))))
399
400(defun compiler-macroexpand (form &optional env)
401  (let ((expanded-p nil))
402    (loop
403      (multiple-value-bind (expansion exp-p) (compiler-macroexpand-1 form env)
404        (if exp-p
405            (setf form expansion expanded-p t)
406            (return))))
407    (values form expanded-p)))
408
409(defun precompile1 (form)
410  (if (atom form)
411      form
412      (let ((op (car form)))
413        (when (symbolp op)
414          (cond ((local-macro-function op)
415                 (let ((result (expand-local-macro form)))
416                   (if (equal result form)
417                       (return-from precompile1 result)
418                       (return-from precompile1 (precompile1 result)))))
419                ((compiler-macro-function op)
420                 (let ((result (compiler-macroexpand form)))
421                   ;; Fall through if no change...
422                   (unless (equal result form)
423                     (return-from precompile1 (precompile1 result)))))
424                ((and (not (eq op 'LAMBDA))
425                      (macro-function op))
426                 ;; It's a macro...
427                 (unless (and (special-operator-p op) (not *in-jvm-compile*))
428                   (let ((result (expand-macro form)))
429                     (return-from precompile1 (precompile1 result))))))
430          (let ((handler (get op 'precompile-handler)))
431            (when handler
432              (return-from precompile1 (funcall handler form)))))
433        (when (and (symbolp op) (special-operator-p op))
434          (format t "PRECOMPILE1: unsupported special operator ~S~%" op))
435        (precompile-cons form))))
436
437(defun precompile-form (form in-jvm-compile)
438  (let ((*in-jvm-compile* in-jvm-compile))
439    (precompile1 form)))
440
441(defun install-handler (fun &optional handler)
442  (let ((handler (or handler
443                     (find-symbol (concatenate 'string "PRECOMPILE-"
444                                               (symbol-name fun))
445                                  'precompiler))))
446    (unless (and handler (fboundp handler))
447      (error "no handler for ~S" fun))
448    (setf (get fun 'precompile-handler) handler)))
449
450(mapcar #'install-handler '(block
451                            case
452                            cond
453                            dolist
454                            dotimes
455                            function
456                            if
457                            lambda
458                            macrolet
459                            multiple-value-bind
460                            multiple-value-list
461                            progn
462                            progv
463                            return
464                            return-from
465                            setq
466                            symbol-macrolet
467                            tagbody
468                            the
469                            unwind-protect))
470
471(install-handler 'ecase                'precompile-case)
472
473(install-handler 'and                  'precompile-cons)
474(install-handler 'catch                'precompile-cons)
475(install-handler 'locally              'precompile-cons)
476(install-handler 'multiple-value-call  'precompile-cons)
477(install-handler 'multiple-value-prog1 'precompile-cons)
478(install-handler 'or                   'precompile-cons)
479(install-handler 'unless               'precompile-cons)
480(install-handler 'when                 'precompile-cons)
481
482(install-handler 'do                   'precompile-do/do*)
483(install-handler 'do*                  'precompile-do/do*)
484
485(install-handler 'flet                 'precompile-flet/labels)
486(install-handler 'labels               'precompile-flet/labels)
487
488(install-handler 'do-symbols           'precompile-do-symbols)
489(install-handler 'do-external-symbols  'precompile-do-symbols)
490
491(install-handler 'let                  'precompile-let/let*)
492(install-handler 'let*                 'precompile-let/let*)
493
494(install-handler 'load-time-value      'precompile-load-time-value)
495
496(install-handler 'declare              'precompile-identity)
497(install-handler 'go                   'precompile-identity)
498(install-handler 'handler-bind         'precompile-identity)
499(install-handler 'handler-case         'precompile-identity)
500(install-handler 'nth-value            'precompile-identity)
501(install-handler 'quote                'precompile-identity)
502(install-handler 'throw                'precompile-identity)
503
504(in-package "SYSTEM")
505
506(defun precompile (name &optional definition)
507  (unless definition
508    (setq definition (or (and (symbolp name) (macro-function name))
509                         (fdefinition name))))
510  (let (expr result)
511    (cond ((functionp definition)
512           (multiple-value-bind (form closure-p)
513             (function-lambda-expression definition)
514             (unless form
515               (format t "; No lambda expression available for ~S.~%" name)
516               (return-from precompile (values nil t t)))
517             (when closure-p
518               (format t "; Unable to compile function ~S defined in non-null lexical environment.~%" name)
519               (finish-output)
520               (return-from precompile (values nil t t)))
521             (setq expr form)))
522          ((and (consp definition) (eq (car definition) 'lambda))
523           (setq expr definition))
524          (t
525           (error 'type-error)))
526    (setf result (coerce-to-function (precompile-form expr nil)))
527    (when (and name (functionp result))
528      (%set-lambda-name result name)
529      (%set-call-count result (%call-count definition))
530      (if (and (symbolp name) (macro-function name))
531          (let ((mac (make-macro result)))
532            (%set-arglist mac (arglist (symbol-function name)))
533            (setf (fdefinition name) mac))
534          (progn
535            (setf (fdefinition name) result)
536            (%set-arglist result (arglist definition)))))
537    (values (or name result) nil nil)))
538
539(defun precompile-package (pkg &key verbose)
540  (dolist (sym (package-symbols pkg))
541    (when (fboundp sym)
542      (unless (special-operator-p sym)
543        (let ((f (fdefinition sym)))
544          (unless (compiled-function-p f)
545            (when verbose
546              (format t "compiling ~S~%" sym)
547              (finish-output))
548            (precompile sym))))))
549  t)
550
551(defun compile (name &optional definition)
552  (if (and name (fboundp name) (typep (symbol-function name) 'generic-function))
553      (values name nil nil)
554      (precompile name definition)))
555
556;; Redefine DEFMACRO to compile the expansion function on the fly.
557
558(defmacro defmacro (name lambda-list &rest body)
559  (let* ((form (gensym))
560         (env (gensym))
561         (body (parse-defmacro lambda-list form body name 'defmacro
562                               :environment env))
563         (expander `(lambda (,form ,env) (block ,name ,body))))
564    `(progn
565       (let ((mac (make-macro (or (precompile nil ,expander) ,expander))))
566         (if (special-operator-p ',name)
567             (%put ',name 'macroexpand-macro mac)
568             (fset ',name mac))
569         (%set-arglist mac ',lambda-list)
570         ',name))))
571
572;; Make an exception just this one time...
573(fset 'defmacro (get 'defmacro 'macroexpand-macro))
574
575;; Redefine DEFUN to compile the definition on the fly.
576(defmacro defun (name lambda-list &rest body &environment env)
577  `(progn
578     (%defun ',name ',lambda-list ',body ,env)
579     (precompile ',name)
580     ',name))
581
582
Note: See TracBrowser for help on using the repository browser.