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

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

SEARCH compiler macro.

File size: 20.0 KB
Line 
1;;; precompiler.lisp
2;;;
3;;; Copyright (C) 2003 Peter Graves
4;;; $Id: precompiler.lisp,v 1.19 2003-12-07 01:16:53 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)
298      (setq result (append result (list (precompile-local-function-def def)))))
299    result))
300
301(defun precompile-flet/labels (form)
302  (let ((locals (cadr form))
303        (body (cddr form)))
304    (list* (car form)
305           (precompile-local-functions locals)
306           (mapcar #'precompile1 body))))
307
308(defun precompile-function (form)
309  (if (and (consp (cadr form)) (eq (caadr form) 'LAMBDA))
310      (list 'FUNCTION (precompile-lambda (cadr form)))
311      form))
312
313(defun precompile-if (form)
314  (let ((args (cdr form)))
315    (case (length args)
316      (2
317       (let ((test (precompile1 (car args))))
318         (cond ((null test)
319                nil)
320               ((constantp test)
321                (precompile1 (cadr args)))
322               (t
323                (list 'IF
324                      test
325                      (precompile1 (cadr args)))))))
326      (3
327       (let ((test (precompile1 (car args))))
328         (cond ((null test)
329                (precompile1 (caddr args)))
330               ((constantp test)
331                (precompile1 (cadr args)))
332               (t
333                (list 'IF
334                      test
335                      (precompile1 (cadr args))
336                      (precompile1 (caddr args)))))))
337      (t
338       (error "wrong number of arguments for IF")))))
339
340(defun precompile-multiple-value-bind (form)
341  (let ((vars (cadr form))
342        (values-form (caddr form))
343        (body (cdddr form)))
344    (list* 'MULTIPLE-VALUE-BIND
345           vars
346           (precompile1 values-form)
347           (mapcar #'precompile1 body))))
348
349(defun precompile-multiple-value-list (form)
350   (list 'MULTIPLE-VALUE-LIST (precompile1 (cadr form))))
351
352(defun precompile-return (form)
353   (list 'RETURN (precompile1 (cadr form))))
354
355(defun precompile-return-from (form)
356  (list 'RETURN-FROM (cadr form) (precompile1 (caddr form))))
357
358(defun precompile-tagbody (form)
359  (do ((body (cdr form) (cdr body))
360       (result ()))
361      ((null body) (cons 'TAGBODY (nreverse result)))
362    (if (atom (car body))
363        (push (car body) result)
364        (push (precompile1 (car body)) result))))
365
366(defun precompile-the (form)
367  (precompile1 (caddr form)))
368
369(defun precompile-unwind-protect (form)
370   (list* 'UNWIND-PROTECT
371          (precompile1 (cadr form))
372          (mapcar #'precompile1 (cddr form))))
373
374;; EXPAND-MACRO is like MACROEXPAND, but EXPAND-MACRO quits if *in-jvm-compile*
375;; is false and a macro is encountered that's also implemented as a special
376;; operator, so interpreted code can use the special operator implementation.
377(defun expand-macro (form)
378  (loop
379    (unless *in-jvm-compile*
380      (when (and (consp form)
381                 (symbolp (car form))
382                 (special-operator-p (car form)))
383        (return-from expand-macro form)))
384    (multiple-value-bind (result expanded) (macroexpand-1 form)
385      (unless expanded
386        (return-from expand-macro result))
387      (setf form result))))
388
389;;; From OpenMCL.
390(defun compiler-macroexpand-1 (form &optional env)
391  (let ((expander nil)
392        (newdef nil))
393    (if (and (consp form)
394             (symbolp (car form))
395             (setq expander (compiler-macro-function (car form) env)))
396        (values (setq newdef (funcall expander form env))
397                (not (eq newdef form)))
398        (values form
399                nil))))
400
401(defun compiler-macroexpand (form &optional env)
402  (let ((expanded-p nil))
403    (loop
404      (multiple-value-bind (expansion exp-p) (compiler-macroexpand-1 form env)
405        (if exp-p
406            (setf form expansion expanded-p t)
407            (return))))
408    (values form expanded-p)))
409
410(defun precompile1 (form)
411  (if (atom form)
412      form
413      (let ((op (car form)))
414        (when (symbolp op)
415          (cond ((local-macro-function op)
416                 (let ((result (expand-local-macro form)))
417                   (if (equal result form)
418                       (return-from precompile1 result)
419                       (return-from precompile1 (precompile1 result)))))
420                ((compiler-macro-function op)
421                 (let ((result (compiler-macroexpand form)))
422                   ;; Fall through if no change...
423                   (unless (equal result form)
424                     (return-from precompile1 (precompile1 result)))))
425                ((and (not (eq op 'LAMBDA))
426                      (macro-function op))
427                 ;; It's a macro...
428                 (unless (and (special-operator-p op) (not *in-jvm-compile*))
429                   (let ((result (expand-macro form)))
430                     (return-from precompile1 (precompile1 result))))))
431          (let ((handler (get op 'precompile-handler)))
432            (when handler
433              (return-from precompile1 (funcall handler form)))))
434        (when (and (symbolp op) (special-operator-p op))
435          (format t "PRECOMPILE1: unsupported special operator ~S~%" op))
436        (precompile-cons form))))
437
438(defun precompile-form (form in-jvm-compile)
439  (let ((*in-jvm-compile* in-jvm-compile))
440    (precompile1 form)))
441
442(defun install-handler (fun &optional handler)
443  (let ((handler (or handler
444                     (find-symbol (concatenate 'string "PRECOMPILE-"
445                                               (symbol-name fun))
446                                  'precompiler))))
447    (unless (and handler (fboundp handler))
448      (error "no handler for ~S" fun))
449    (setf (get fun 'precompile-handler) handler)))
450
451(mapcar #'install-handler '(block
452                            case
453                            cond
454                            dolist
455                            dotimes
456                            function
457                            if
458                            lambda
459                            macrolet
460                            multiple-value-bind
461                            multiple-value-list
462                            progn
463                            progv
464                            return
465                            return-from
466                            setq
467                            symbol-macrolet
468                            tagbody
469                            the
470                            unwind-protect))
471
472(install-handler 'ecase                'precompile-case)
473
474(install-handler 'and                  '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 'catch                'precompile-identity)
497(install-handler 'declare              'precompile-identity)
498(install-handler 'go                   'precompile-identity)
499(install-handler 'handler-bind         'precompile-identity)
500(install-handler 'handler-case         'precompile-identity)
501(install-handler 'nth-value            'precompile-identity)
502(install-handler 'quote                'precompile-identity)
503(install-handler 'throw                'precompile-identity)
504
505(in-package "SYSTEM")
506
507(defun precompile (name &optional definition)
508  (unless definition
509    (setq definition (or (and (symbolp name) (macro-function name))
510                         (fdefinition name))))
511  (let (expr result)
512    (cond ((functionp definition)
513           (multiple-value-bind (form closure-p)
514             (function-lambda-expression definition)
515             (unless form
516               (format t "; No lambda expression available for ~S.~%" name)
517               (return-from precompile (values nil t t)))
518             (when closure-p
519               (format t "; Unable to compile function ~S defined in non-null lexical environment.~%" name)
520               (finish-output)
521               (return-from precompile (values nil t t)))
522             (setq expr form)))
523          ((and (consp definition) (eq (car definition) 'lambda))
524           (setq expr definition))
525          (t
526           (error 'type-error)))
527    (setf result (coerce-to-function (precompile-form expr nil)))
528    (when (and name (functionp result))
529      (%set-lambda-name result name)
530      (%set-call-count result (%call-count definition))
531      (%set-arglist result (arglist definition))
532      (if (and (symbolp name) (macro-function name))
533          (setf (fdefinition name) (make-macro result))
534          (setf (fdefinition name) result)))
535    (values (or name result) nil nil)))
536
537(defun precompile-package (pkg &key verbose)
538  (dolist (sym (package-symbols pkg))
539    (when (fboundp sym)
540      (unless (special-operator-p sym)
541        (let ((f (fdefinition sym)))
542          (unless (compiled-function-p f)
543            (when verbose
544              (format t "compiling ~S~%" sym)
545              (finish-output))
546            (precompile sym))))))
547  t)
548
549(defun compile (name &optional definition)
550  (if (and name (fboundp name) (typep (symbol-function name) 'generic-function))
551      (values name nil nil)
552      (precompile name definition)))
553
554;; Redefine DEFMACRO to compile the expansion function on the fly.
555(defmacro defmacro (name lambda-list &rest body)
556  (let* ((form (gensym))
557         (env (gensym))
558         (body (parse-defmacro lambda-list form body name 'defmacro
559                               :environment env))
560         (expander `(lambda (,form ,env) (block ,name ,body))))
561    `(progn
562       (if (special-operator-p ',name)
563           (%put ',name
564                 'macroexpand-macro
565                 (make-macro (or (precompile nil ,expander) ,expander)))
566           (fset ',name
567                 (make-macro (or (precompile nil ,expander) ,expander))))
568       ',name)))
569
570;; Make an exception just this one time...
571(fset 'defmacro (get 'defmacro 'macroexpand-macro))
572
573;; Redefine DEFUN to compile the definition on the fly.
574(defmacro defun (name lambda-list &rest body &environment env)
575  `(progn
576     (%defun ',name ',lambda-list ',body ,env)
577     (precompile ',name)
578     ',name))
Note: See TracBrowser for help on using the repository browser.