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

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

DEFUN: work in progress.

File size: 9.2 KB
Line 
1;;; compiler.lisp
2;;;
3;;; Copyright (C) 2003 Peter Graves
4;;; $Id: compiler.lisp,v 1.42 2003-10-02 15:48:33 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 compile-special (form)
98  (let ((first (car form)))
99    (case first
100      (BLOCK
101       (unless (>= (length form) 2)
102         (error "wrong number of arguments for BLOCK"))
103       (unless (symbolp (cadr form))
104         (error 'type-error))
105       (list* 'block (cadr form) (mapcar #'compile-sexp (cddr form))))
106      (COND
107       (cons 'cond (compile-cond (cdr form))))
108      (QUOTE
109       form)
110      ((AND OR)
111       (cons first
112             (mapcar #'compile-sexp (cdr form))))
113      (FUNCTION
114       (if (and (consp (cadr form)) (eq (caadr form) 'setf))
115           form
116           (cons 'function (list (compile-sexp (cadr form))))))
117      (WHEN
118       (cons 'when (mapcar #'compile-sexp (cdr form))))
119      ((LET LET*)
120       (list* first (compile-let-vars (cadr form)) (mapcar #'compile-sexp (cddr form))))
121      (SETQ
122       (compile-setq (cdr form)))
123      (PROGN
124       (cons 'progn (mapcar #'compile-sexp (cdr form))))
125      (IF
126       (unless (<= 2 (length (cdr form)) 3)
127         (error "wrong number of arguments for IF"))
128       (cons 'if (mapcar #'compile-sexp (cdr form))))
129      ('CASE
130       (cons 'case (compile-case (cadr form) (cddr form))))
131      (DOLIST
132       (let ((args (cadr form))
133             (body (cddr form)))
134         (cons first (cons args (compile-progn body)))))
135      ((DO DO* MULTIPLE-VALUE-BIND)
136       (let ((second (second form))
137             (third (third form))
138             (body (cdddr form)))
139         (list* first second third (mapcar #'compile-sexp body))))
140      (DOTIMES
141       (let ((args (cadr form))
142             (body (cddr form)))
143         (list* first args (compile-progn body))))
144      (TAGBODY
145       (let ((body (cdr form)))
146         (cons 'tagbody (compile-tagbody body))))
147      (LABELS
148       (let ((locals (cadr form))
149             (body (cddr form)))
150          (append '(labels) (list (compile-locals locals)) (compile-progn body))))
151      (RETURN
152       (if (cdr form)
153           (cons 'return (list (compile-sexp (cadr form))))
154           form))
155      (UNLESS
156       (cons 'unless (mapcar #'compile-sexp (cdr form))))
157      (t
158;;        (format t "    skipping ~S~%" first)
159       form))))
160
161;; EXPAND-MACRO is like MACROEXPAND, but EXPAND-MACRO quits if it encounters a
162;; macro that's also implemented as a special operator, so interpreted code can
163;; use the (faster) special operator implementation.
164(defun expand-macro (form)
165  (do () ()
166    (multiple-value-bind (result expanded) (macroexpand-1 form)
167      (unless expanded (return-from expand-macro result))
168      (when (and (consp result)
169                 (symbolp (car result))
170                 (special-operator-p (car result)))
171        (return-from expand-macro result))
172      (setq form result))))
173
174(defun compile-sexp (form)
175  (if (atom form) form
176      (let ((first (car form)))
177        (unless (and (symbolp first) (fboundp first))
178          (return-from compile-sexp form))
179        (cond ((eq first 'LAMBDA)
180               (list* 'LAMBDA (second form)
181                      (mapcar #'compile-sexp (cddr form))))
182              ((special-operator-p first)
183               (compile-special form))
184              ((macro-function first)
185               (compile-sexp (expand-macro form)))
186              (t
187               (let ((args (mapcar #'compile-sexp (cdr form))))
188                 (cons first args)))))))
189
190(defun %compile (name &optional definition)
191  (unless definition
192    (setq definition (or (and (symbolp name) (macro-function name))
193                         (fdefinition name))))
194  (let (expr result)
195    (cond ((functionp definition)
196           (multiple-value-bind (form closure-p)
197             (function-lambda-expression definition)
198             (unless form
199               (format t "; No lambda expression available for ~S.~%" name)
200               (return-from %compile (values nil t t)))
201             (when closure-p
202               (format t "; Unable to compile function ~S defined in non-null lexical environment.~%" name)
203               (finish-output)
204               (return-from %compile (values nil t t)))
205             (setq expr form)))
206          ((and (consp definition) (eq (car definition) 'lambda))
207           (setq expr definition))
208          (t
209           (error 'type-error)))
210    (setq result (sys::coerce-to-function (compile-sexp expr)))
211    (when (and name (functionp result))
212      (sys::%set-lambda-name result name)
213      (sys::%set-call-count result (sys::%call-count definition))
214      (sys::%set-arglist result (sys::arglist definition))
215      (if (and (symbolp name) (macro-function name))
216          (setf (fdefinition name) (sys::make-macro result))
217          (setf (fdefinition name) result)))
218    (values (or name result) nil nil)))
219
220(defun compile-package (pkg &key verbose)
221  (dolist (sym (sys::package-symbols pkg))
222    (when (fboundp sym)
223      ;;       (unless (or (special-operator-p sym) (macro-function sym))
224      (unless (special-operator-p sym)
225        (let ((f (fdefinition sym)))
226          (unless (compiled-function-p f)
227            (when verbose
228              (format t "compiling ~S~%" sym)
229              (finish-output))
230            (%compile sym))))))
231  t)
232
233(compile-package :compiler)
234(compile-package :sys)
235(compile-package :cl)
236
237(in-package :cl)
238
239(defun compile (name &optional definition)
240  (c::%compile name definition))
241
242;; Redefine DEFUN to compile the definition on the fly.
243(defmacro defun (name lambda-list &rest body)
244  `(progn
245     (sys::%defun ',name ',lambda-list ',body)
246     (compiler::%compile ',name)
247     ',name))
248
249;; Redefine DEFMACRO to compile the expansion function on the fly.
250(defmacro defmacro (name lambda-list &rest body)
251  (let* ((form (gensym))
252         (env (gensym))
253         (body (sys::parse-defmacro lambda-list form body name 'defmacro
254                                    :environment env))
255         (expander `(lambda (,form ,env) (block ,name ,body))))
256    `(progn
257       (if (special-operator-p ',name)
258         (sys::%put ',name
259                    'sys::macroexpand-macro
260                    (sys::make-macro (c::%compile nil ,expander)))
261         (sys::fset ',name
262                    (sys::make-macro (c::%compile nil ,expander))))
263       ',name)))
264
265;; Make an exception just this one time...
266(sys::fset 'defmacro (get 'defmacro 'sys::macroexpand-macro))
Note: See TracBrowser for help on using the repository browser.