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

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

COMPILE-SETQ

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