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

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

EQL compiler macro.

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