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

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

Work in progress.

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