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

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

NOT compiler macro.

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