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

Last change on this file since 4446 was 4446, checked in by piso, 19 years ago

Work in progress.

File size: 12.4 KB
Line 
1;;; compiler.lisp
2;;;
3;;; Copyright (C) 2003 Peter Graves
4;;; $Id: compiler.lisp,v 1.51 2003-10-18 16:23:59 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;;     (format t "*local-macros* = ~S~%" *local-macros*)
144;;     (format t "body          = ~S~%" body)
145    (setf compiled-body (compile-progn body))
146;;     (format t "compiled-body = ~S~%" compiled-body)
147    (setf res (list* 'macrolet (reverse res) compiled-body))
148    res))
149
150(defun compile-special (form)
151  (let ((first (car form)))
152    (case first
153      (BLOCK
154       (unless (>= (length form) 2)
155         (error "wrong number of arguments for BLOCK"))
156       (unless (symbolp (cadr form))
157         (error 'type-error))
158       (list* 'block (cadr form) (mapcar #'compile-sexp (cddr form))))
159      (COND
160       (cons 'cond (compile-cond (cdr form))))
161      (QUOTE
162       form)
163      ((AND OR)
164       (cons first
165             (mapcar #'compile-sexp (cdr form))))
166      (FUNCTION
167       (if (and (consp (cadr form)) (eq (caadr form) 'setf))
168           form
169           (cons 'function (list (compile-sexp (cadr form))))))
170      (WHEN
171       (cons 'when (mapcar #'compile-sexp (cdr form))))
172      ((LET LET*)
173       (list* first (compile-let-vars (cadr form)) (mapcar #'compile-sexp (cddr form))))
174      (SETQ
175       (compile-setq (cdr form)))
176      (PROGN
177       (let ((body (cdr form)))
178         (if (= (length body) 1)
179             (let ((res (compile-sexp (car body))))
180               ;; If the result turns out to be a bare symbol, leave it wrapped
181               ;; with PROGN so it won't be mistaken for a tag in an enclosing
182               ;; TAGBODY.
183               (if (symbolp res)
184                   (list 'progn res)
185                   res))
186             (cons 'progn (mapcar #'compile-sexp body)))))
187      (IF
188       (unless (<= 2 (length (cdr form)) 3)
189         (error "wrong number of arguments for IF"))
190       (cons 'if (mapcar #'compile-sexp (cdr form))))
191      ((CASE ECASE)
192       (cons first (compile-case (cadr form) (cddr form))))
193      (DOLIST
194       (let ((args (cadr form))
195             (body (cddr form)))
196         (cons first (cons args (compile-progn body)))))
197      ((DO DO* MULTIPLE-VALUE-BIND)
198       (let ((second (second form))
199             (third (third form))
200             (body (cdddr form)))
201         (list* first second third (mapcar #'compile-sexp body))))
202      (DOTIMES
203       (let ((args (cadr form))
204             (body (cddr form)))
205         (list* first args (compile-progn body))))
206      (TAGBODY
207       (let ((body (cdr form)))
208         (cons 'tagbody (compile-tagbody body))))
209      (LABELS
210       (let ((locals (cadr form))
211             (body (cddr form)))
212          (append '(labels) (list (compile-locals locals)) (compile-progn body))))
213      (RETURN
214       (if (cdr form)
215           (cons 'return (list (compile-sexp (cadr form))))
216           form))
217      (RETURN-FROM form)
218      (UNLESS
219       (cons 'unless (mapcar #'compile-sexp (cdr form))))
220      (UNWIND-PROTECT
221       (list* 'unwind-protect (compile-sexp (cadr form)) (mapcar #'compile-sexp (cddr form))))
222      (MULTIPLE-VALUE-PROG1
223       (list* 'unwind-protect (compile-sexp (cadr form)) (mapcar #'compile-sexp (cddr form))))
224      (THE
225       (compile-sexp (caddr form)))
226      (GO form)
227      (MACROLET
228       (compile-macrolet form))
229      (t
230;;        (format t "COMPILE-SPECIAL skipping ~S~%" first)
231       form))))
232
233;; EXPAND-MACRO is like MACROEXPAND, but EXPAND-MACRO quits if it encounters a
234;; macro that's also implemented as a special operator, so interpreted code can
235;; use the (faster) special operator implementation.
236(defun expand-macro (form)
237  (do () ()
238    (multiple-value-bind (result expanded) (macroexpand-1 form)
239      (unless expanded (return-from expand-macro result))
240      (when (and (consp result)
241                 (symbolp (car result))
242                 (special-operator-p (car result)))
243        (return-from expand-macro result))
244      (setq form result))))
245
246(defun compile-sexp (form)
247  (if (atom form) form
248      (let ((first (car form)))
249        (when (local-macro-function first)
250;;           (format t "form = ~S~%" form)
251          (let ((expansion (expand-local-macro form)))
252;;             (format t "expansion = ~S~%" expansion)
253            (return-from compile-sexp expansion)))
254        (unless (and (symbolp first) (fboundp first))
255          (return-from compile-sexp form))
256        (cond ((eq first 'LAMBDA)
257               (list* 'LAMBDA (second form)
258                      (mapcar #'compile-sexp (cddr form))))
259              ((special-operator-p first)
260               (compile-special form))
261              ((macro-function first)
262               (compile-sexp (expand-macro form)))
263              (t
264               (let ((args (mapcar #'compile-sexp (cdr form))))
265                 (cons first args)))))))
266
267(defun %compile (name &optional definition)
268  (unless definition
269    (setq definition (or (and (symbolp name) (macro-function name))
270                         (fdefinition name))))
271  (let (expr result)
272    (cond ((functionp definition)
273           (multiple-value-bind (form closure-p)
274             (function-lambda-expression definition)
275             (unless form
276               (format t "; No lambda expression available for ~S.~%" name)
277               (return-from %compile (values nil t t)))
278             (when closure-p
279               (format t "; Unable to compile function ~S defined in non-null lexical environment.~%" name)
280               (finish-output)
281               (return-from %compile (values nil t t)))
282             (setq expr form)))
283          ((and (consp definition) (eq (car definition) 'lambda))
284           (setq expr definition))
285          (t
286           (error 'type-error)))
287    (setq result (sys::coerce-to-function (compile-sexp expr)))
288    (when (and name (functionp result))
289      (sys::%set-lambda-name result name)
290      (sys::%set-call-count result (sys::%call-count definition))
291      (sys::%set-arglist result (sys::arglist definition))
292      (if (and (symbolp name) (macro-function name))
293          (setf (fdefinition name) (sys::make-macro result))
294          (setf (fdefinition name) result)))
295    (values (or name result) nil nil)))
296
297(defun compile-package (pkg &key verbose)
298  (dolist (sym (sys::package-symbols pkg))
299    (when (fboundp sym)
300      ;;       (unless (or (special-operator-p sym) (macro-function sym))
301      (unless (special-operator-p sym)
302        (let ((f (fdefinition sym)))
303          (unless (compiled-function-p f)
304            (when verbose
305              (format t "compiling ~S~%" sym)
306              (finish-output))
307            (%compile sym))))))
308  t)
309
310(compile-package :compiler)
311(compile-package :sys)
312(compile-package :cl)
313
314(in-package :cl)
315
316(defun compile (name &optional definition)
317  (if (and name (fboundp name) (typep (symbol-function name) 'generic-function))
318      (values name nil nil)
319      (c::%compile name definition)))
320
321;; Redefine DEFMACRO to compile the expansion function on the fly.
322(defmacro defmacro (name lambda-list &rest body)
323  (let* ((form (gensym))
324         (env (gensym))
325         (body (sys::parse-defmacro lambda-list form body name 'defmacro
326                                    :environment env))
327         (expander `(lambda (,form ,env) (block ,name ,body))))
328    `(progn
329       (if (special-operator-p ',name)
330         (sys::%put ',name
331                    'sys::macroexpand-macro
332                    (sys::make-macro (or (c::%compile nil ,expander) ,expander)))
333         (sys::fset ',name
334                    (sys::make-macro (or (c::%compile nil ,expander) ,expander))))
335       ',name)))
336
337;; Make an exception just this one time...
338(sys::fset 'defmacro (get 'defmacro 'sys::macroexpand-macro))
339
340;; Redefine DEFUN to compile the definition on the fly.
341(defmacro defun (name lambda-list &rest body &environment env)
342  `(progn
343     (sys::%defun ',name ',lambda-list ',body ,env)
344     (compiler::%compile ',name)
345     ',name))
Note: See TracBrowser for help on using the repository browser.