source: trunk/j/src/org/armedbear/lisp/compiler.lisp @ 4654

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

Minor cleanup.

File size: 12.7 KB
Line 
1;;; compiler.lisp
2;;;
3;;; Copyright (C) 2003 Peter Graves
4;;; $Id: compiler.lisp,v 1.58 2003-11-05 19:34: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(unless (find-package "COMPILER")
21  (make-package "COMPILER" :nicknames '("C") :use '("COMMON-LISP")))
22
23;; (in-package "COMMON-LISP")
24
25;; (export 'compile)
26
27(in-package "COMPILER")
28
29(defun compile-progn (forms)
30  (mapcar #'compile-sexp forms))
31
32(defun compile-setq (exprs)
33  (when (oddp (length exprs))
34    (error "odd number of arguments to SETQ"))
35  (do* ((result '(setq))
36        (sym (car exprs) (car exprs))
37        (val (cadr exprs) (cadr exprs)))
38    ((null exprs) result)
39    (setq result (append result (list sym) (list (compile-sexp val))))
40    (setq exprs (cddr exprs))))
41
42(defun compile-cond (clauses)
43  (let ((result nil))
44    (dolist (clause clauses)
45      (setq result (nconc result (list (compile-cond-clause clause)))))
46    result))
47
48(defun compile-cond-clause (clause)
49  (let ((test (car clause))
50        (forms (cdr clause)))
51    (nconc (list (compile-sexp test)) (compile-progn forms))))
52
53(defun compile-case (keyform clauses)
54  (let ((result (list (compile-sexp keyform))))
55    (dolist (clause clauses)
56      (setq result (nconc result (list (compile-case-clause clause)))))
57    result))
58
59(defun compile-case-clause (clause)
60  (let ((keys (car clause))
61        (forms (cdr clause)))
62    (nconc (list keys) (compile-progn forms))))
63
64(defun compile-tagbody (body)
65  (let ((rest body)
66        (result ()))
67    (do () ((null rest) result)
68      (if (atom (car rest))
69          (setq result (nconc result (list (car rest))))
70          (setq result (append result (list (compile-sexp (car rest))))))
71      (setq rest (cdr rest)))))
72
73(defun compile-locals (locals)
74  (let ((result nil))
75    (dolist (local locals)
76      (setq result (append result (list (compile-local-def local)))))
77    result))
78
79(defun compile-local-def (def)
80  (let ((name (car def))
81        (arglist (cadr def))
82        (body (cddr def)))
83    (list* name arglist (compile-progn body))))
84
85(defun compile-let-vars (vars)
86  (let ((result nil))
87    (dolist (var vars)
88      (if (consp var)
89          (let* ((v (car var))
90                 (expr (cadr var)))
91            (unless (symbolp v)
92              (error 'type-error))
93            (setq result (append result (list (list v (compile-sexp expr))))))
94          (setq result (append result (list var)))))
95    result))
96
97;; (defun define-local-macro (name lambda-list &rest body)
98;;   (let* ((form (gensym))
99;;          (env (gensym))
100;;          (body (sys::parse-defmacro lambda-list form body name 'macrolet
101;;                                     :environment env))
102;;          (expander `(lambda (,form ,env) (block ,name ,body))))
103;;     (format t "expander = ~S~%" expander)
104;;     (sys::make-macro expander)))
105
106(defun define-local-macro (name lambda-list body)
107  (let* ((form (gensym))
108         (env (gensym))
109         (body (sys::parse-defmacro lambda-list form body name 'macrolet
110                                    :environment env))
111         (expander `(lambda (,form ,env) (block ,name ,body)))
112         (compiled-expander (%compile nil expander)))
113;;     (format t "expander = ~S~%" expander)
114;;     (format t "compiled-expander = ~S~%" compiled-expander)
115    (or compiled-expander expander)))
116
117(defparameter *local-macros* ())
118
119(defun local-macro-function (name)
120  (getf *local-macros* name))
121
122(defun expand-local-macro (form)
123  (let ((expansion (funcall (local-macro-function (car form)) form nil)))
124    ;; If the expansion turns out to be a bare symbol, wrap it with PROGN so it
125    ;; won't be mistaken for a tag in an enclosing TAGBODY.
126    (if (symbolp expansion)
127        (list 'progn expansion)
128        expansion)))
129
130(defun compile-macrolet (form)
131  (let ((*local-macros* *local-macros*)
132        (macros (cadr form))
133        (body (cddr form))
134        (res ())
135        compiled-body)
136    (dolist (macro macros)
137      (let ((name (car macro))
138            (lambda-list (cadr macro))
139            (forms (cddr macro)))
140        (push (define-local-macro name lambda-list forms) *local-macros*)
141        (push name *local-macros*)
142        (push (list* name lambda-list (compile-progn forms)) res)))
143    (setf compiled-body (compile-progn body))
144    (setf res (list* 'progn compiled-body))
145    res))
146
147(defun compile-special (form)
148  (let ((first (car form)))
149    (case first
150      (BLOCK
151       (unless (>= (length form) 2)
152         (error "wrong number of arguments for BLOCK"))
153       (unless (symbolp (cadr form))
154         (error 'type-error))
155       (list* 'block (cadr form) (mapcar #'compile-sexp (cddr form))))
156      (COND
157       (cons 'cond (compile-cond (cdr form))))
158      (QUOTE
159       form)
160      ((AND OR)
161       (cons first
162             (mapcar #'compile-sexp (cdr form))))
163      (FUNCTION
164       (if (and (consp (cadr form)) (eq (caadr form) 'setf))
165           form
166           (cons 'function (list (compile-sexp (cadr form))))))
167      (WHEN
168       (cons 'when (mapcar #'compile-sexp (cdr form))))
169      ((LET LET*)
170       (list* first (compile-let-vars (cadr form)) (mapcar #'compile-sexp (cddr form))))
171      (SETQ
172       (compile-setq (cdr form)))
173      (PROGN
174       (let ((body (cdr form)))
175         (if (= (length body) 1)
176             (let ((res (compile-sexp (car body))))
177               ;; If the result turns out to be a bare symbol, leave it wrapped
178               ;; with PROGN so it won't be mistaken for a tag in an enclosing
179               ;; TAGBODY.
180               (if (symbolp res)
181                   (list 'progn res)
182                   res))
183             (cons 'progn (mapcar #'compile-sexp body)))))
184      (IF
185       (unless (<= 2 (length (cdr form)) 3)
186         (error "wrong number of arguments for IF"))
187       (cons 'if (mapcar #'compile-sexp (cdr form))))
188      ((CASE ECASE)
189       (cons first (compile-case (cadr form) (cddr form))))
190      (DOLIST
191       (let ((args (cadr form))
192             (body (cddr form)))
193         (cons first (cons args (compile-progn body)))))
194      ((DO DO*)
195       (let ((second (second form))
196             (third (third form))
197             (body (cdddr form)))
198         (list* first second third (mapcar #'compile-sexp body))))
199      (DOTIMES
200       (let ((args (cadr form))
201             (body (cddr form)))
202         (list* first args (compile-progn body))))
203      (TAGBODY
204       (let ((body (cdr form)))
205         (cons 'tagbody (compile-tagbody body))))
206      ((LABELS FLET)
207;;        (format t "LABELS *local-macros* = ~S~%" *local-macros*)
208       (let* ((locals (cadr form))
209              (body (cddr form))
210              (compiled-locals (compile-locals locals))
211              (compiled-body (compile-progn body)))
212;;          (format t "body          = ~S~%" body)
213;;          (format t "compiled-body = ~S~%" compiled-body)
214;;          (append '(labels) (list compiled-locals) compiled-body)))
215         (list* first compiled-locals compiled-body)))
216      (RETURN
217       (if (cdr form)
218           (cons 'return (list (compile-sexp (cadr form))))
219           form))
220      (RETURN-FROM form)
221      (UNLESS
222       (cons 'unless (mapcar #'compile-sexp (cdr form))))
223      (UNWIND-PROTECT
224       (list* 'unwind-protect (compile-sexp (cadr form)) (mapcar #'compile-sexp (cddr form))))
225      (MULTIPLE-VALUE-PROG1
226       (list* 'unwind-protect (compile-sexp (cadr form)) (mapcar #'compile-sexp (cddr form))))
227      (THE
228       (compile-sexp (caddr form)))
229      (GO form)
230      (MACROLET
231       (compile-macrolet form))
232      (MULTIPLE-VALUE-BIND
233       (let ((vars (second form))
234             (values-form (third form))
235             (body (cdddr form)))
236         (list* 'multiple-value-bind vars (compile-sexp values-form)
237                (mapcar #'compile-sexp body))))
238      (MULTIPLE-VALUE-SETQ
239       (list 'multiple-value-setq (second form) (compile-sexp (third form))))
240      (t
241;;        (format t "COMPILE-SPECIAL skipping ~S~%" first)
242       form))))
243
244;; EXPAND-MACRO is like MACROEXPAND, but EXPAND-MACRO quits if it encounters a
245;; macro that's also implemented as a special operator, so interpreted code can
246;; use the (faster) special operator implementation.
247(defun expand-macro (form)
248  (loop
249    (multiple-value-bind (result expanded) (macroexpand-1 form)
250      (unless expanded (return-from expand-macro result))
251      (when (and (consp result)
252                 (symbolp (car result))
253                 (special-operator-p (car result)))
254        (return-from expand-macro result))
255      (setq form result))))
256
257(defun compile-sexp (form)
258  (if (atom form) form
259      (let ((first (car form)))
260        (when (symbolp first)
261          (cond ((local-macro-function first)
262                 (return-from compile-sexp (expand-local-macro form)))
263                ((eq first 'LAMBDA)
264                 (return-from compile-sexp (list* 'LAMBDA (second form)
265                                                  (mapcar #'compile-sexp (cddr form)))))
266                ((special-operator-p first)
267                 (return-from compile-sexp (compile-special form)))
268                ((macro-function first)
269                 (return-from compile-sexp (compile-sexp (expand-macro form))))))
270        (cons first (mapcar #'compile-sexp (cdr form))))))
271
272(defun %compile (name &optional definition)
273  (unless definition
274    (setq definition (or (and (symbolp name) (macro-function name))
275                         (fdefinition name))))
276  (let (expr result)
277    (cond ((functionp definition)
278           (multiple-value-bind (form closure-p)
279             (function-lambda-expression definition)
280             (unless form
281               (format t "; No lambda expression available for ~S.~%" name)
282               (return-from %compile (values nil t t)))
283             (when closure-p
284               (format t "; Unable to compile function ~S defined in non-null lexical environment.~%" name)
285               (finish-output)
286               (return-from %compile (values nil t t)))
287             (setq expr form)))
288          ((and (consp definition) (eq (car definition) 'lambda))
289           (setq expr definition))
290          (t
291           (error 'type-error)))
292    (setq result (sys::coerce-to-function (compile-sexp expr)))
293    (when (and name (functionp result))
294      (sys::%set-lambda-name result name)
295      (sys::%set-call-count result (sys::%call-count definition))
296      (sys::%set-arglist result (sys::arglist definition))
297      (if (and (symbolp name) (macro-function name))
298          (setf (fdefinition name) (sys::make-macro result))
299          (setf (fdefinition name) result)))
300    (values (or name result) nil nil)))
301
302(defun compile-package (pkg &key verbose)
303  (dolist (sym (sys::package-symbols pkg))
304    (when (fboundp sym)
305      ;;       (unless (or (special-operator-p sym) (macro-function sym))
306      (unless (special-operator-p sym)
307        (let ((f (fdefinition sym)))
308          (unless (compiled-function-p f)
309            (when verbose
310              (format t "compiling ~S~%" sym)
311              (finish-output))
312            (%compile sym))))))
313  t)
314
315(compile-package :compiler)
316(compile-package :sys)
317(compile-package :cl)
318
319(in-package :cl)
320
321(defun compile (name &optional definition)
322  (if (and name (fboundp name) (typep (symbol-function name) 'generic-function))
323      (values name nil nil)
324      (c::%compile name definition)))
325
326;; Redefine DEFMACRO to compile the expansion function on the fly.
327(defmacro defmacro (name lambda-list &rest body)
328  (let* ((form (gensym))
329         (env (gensym))
330         (body (sys::parse-defmacro lambda-list form body name 'defmacro
331                                    :environment env))
332         (expander `(lambda (,form ,env) (block ,name ,body))))
333    `(progn
334       (if (special-operator-p ',name)
335         (sys::%put ',name
336                    'sys::macroexpand-macro
337                    (sys::make-macro (or (c::%compile nil ,expander) ,expander)))
338         (sys::fset ',name
339                    (sys::make-macro (or (c::%compile nil ,expander) ,expander))))
340       ',name)))
341
342;; Make an exception just this one time...
343(sys::fset 'defmacro (get 'defmacro 'sys::macroexpand-macro))
344
345;; Redefine DEFUN to compile the definition on the fly.
346(defmacro defun (name lambda-list &rest body &environment env)
347  `(progn
348     (sys::%defun ',name ',lambda-list ',body ,env)
349     (compiler::%compile ',name)
350     ',name))
Note: See TracBrowser for help on using the repository browser.