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
RevLine 
[1055]1;;; compiler.lisp
2;;;
3;;; Copyright (C) 2003 Peter Graves
[4665]4;;; $Id: compiler.lisp,v 1.59 2003-11-07 18:26:32 piso Exp $
[1055]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
[1417]20(unless (find-package "COMPILER")
[2819]21  (make-package "COMPILER" :nicknames '("C") :use '("COMMON-LISP")))
[1055]22
[4445]23;; (in-package "COMMON-LISP")
[1132]24
[4445]25;; (export 'compile)
[1132]26
[2048]27(in-package "COMPILER")
[1055]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"))
[4665]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)))))
[1055]43
44(defun compile-cond (clauses)
45  (let ((result nil))
46    (dolist (clause clauses)
[2095]47      (setq result (nconc result (list (compile-cond-clause clause)))))
[1055]48    result))
49
50(defun compile-cond-clause (clause)
51  (let ((test (car clause))
52        (forms (cdr clause)))
[2111]53    (nconc (list (compile-sexp test)) (compile-progn forms))))
[1055]54
55(defun compile-case (keyform clauses)
56  (let ((result (list (compile-sexp keyform))))
57    (dolist (clause clauses)
[2095]58      (setq result (nconc result (list (compile-case-clause clause)))))
[1055]59    result))
60
61(defun compile-case-clause (clause)
62  (let ((keys (car clause))
63        (forms (cdr clause)))
[2111]64    (nconc (list keys) (compile-progn forms))))
[1055]65
66(defun compile-tagbody (body)
67  (let ((rest body)
68        (result ()))
[2702]69    (do () ((null rest) result)
[1055]70      (if (atom (car rest))
[2095]71          (setq result (nconc result (list (car rest))))
[1055]72          (setq result (append result (list (compile-sexp (car rest))))))
[2702]73      (setq rest (cdr rest)))))
[1055]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)))
[2449]85    (list* name arglist (compile-progn body))))
[1055]86
[1127]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)))
[1131]93            (unless (symbolp v)
94              (error 'type-error))
[1127]95            (setq result (append result (list (list v (compile-sexp expr))))))
96          (setq result (append result (list var)))))
97    result))
98
[4445]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)
[4446]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)))
[4445]131
[4443]132(defun compile-macrolet (form)
[4445]133  (let ((*local-macros* *local-macros*)
134        (macros (cadr form))
[4443]135        (body (cddr form))
[4445]136        (res ())
137        compiled-body)
[4443]138    (dolist (macro macros)
139      (let ((name (car macro))
140            (lambda-list (cadr macro))
141            (forms (cddr macro)))
[4445]142        (push (define-local-macro name lambda-list forms) *local-macros*)
143        (push name *local-macros*)
[4443]144        (push (list* name lambda-list (compile-progn forms)) res)))
[4445]145    (setf compiled-body (compile-progn body))
[4449]146    (setf res (list* 'progn compiled-body))
[4445]147    res))
[4443]148
[1055]149(defun compile-special (form)
150  (let ((first (car form)))
151    (case first
[1127]152      (BLOCK
153       (unless (>= (length form) 2)
154         (error "wrong number of arguments for BLOCK"))
155       (unless (symbolp (cadr form))
156         (error 'type-error))
[2542]157       (list* 'block (cadr form) (mapcar #'compile-sexp (cddr form))))
[1055]158      (COND
[2113]159       (cons 'cond (compile-cond (cdr form))))
160      (QUOTE
161       form)
[1055]162      ((AND OR)
[2113]163       (cons first
164             (mapcar #'compile-sexp (cdr form))))
[1055]165      (FUNCTION
[4174]166       (if (and (consp (cadr form)) (eq (caadr form) 'setf))
167           form
168           (cons 'function (list (compile-sexp (cadr form))))))
[2113]169      (WHEN
170       (cons 'when (mapcar #'compile-sexp (cdr form))))
[1127]171      ((LET LET*)
[2542]172       (list* first (compile-let-vars (cadr form)) (mapcar #'compile-sexp (cddr form))))
[2113]173      (SETQ
174       (compile-setq (cdr form)))
175      (PROGN
[4445]176       (let ((body (cdr form)))
177         (if (= (length body) 1)
[4446]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))
[4445]185             (cons 'progn (mapcar #'compile-sexp body)))))
[2113]186      (IF
[2542]187       (unless (<= 2 (length (cdr form)) 3)
188         (error "wrong number of arguments for IF"))
189       (cons 'if (mapcar #'compile-sexp (cdr form))))
[4444]190      ((CASE ECASE)
191       (cons first (compile-case (cadr form) (cddr form))))
[1127]192      (DOLIST
[1055]193       (let ((args (cadr form))
194             (body (cddr form)))
[2114]195         (cons first (cons args (compile-progn body)))))
[4448]196      ((DO DO*)
[1055]197       (let ((second (second form))
198             (third (third form))
199             (body (cdddr form)))
[2542]200         (list* first second third (mapcar #'compile-sexp body))))
[1055]201      (DOTIMES
202       (let ((args (cadr form))
203             (body (cddr form)))
[2449]204         (list* first args (compile-progn body))))
[1055]205      (TAGBODY
206       (let ((body (cdr form)))
[2113]207         (cons 'tagbody (compile-tagbody body))))
[4453]208      ((LABELS FLET)
[4449]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)
[4453]216;;          (append '(labels) (list compiled-locals) compiled-body)))
217         (list* first compiled-locals compiled-body)))
[1055]218      (RETURN
219       (if (cdr form)
[2113]220           (cons 'return (list (compile-sexp (cadr form))))
221           form))
[4415]222      (RETURN-FROM form)
[2095]223      (UNLESS
[2113]224       (cons 'unless (mapcar #'compile-sexp (cdr form))))
[4415]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
[4416]230       (compile-sexp (caddr form)))
[4415]231      (GO form)
[4443]232      (MACROLET
233       (compile-macrolet form))
[4448]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))))
[4447]240      (MULTIPLE-VALUE-SETQ
241       (list 'multiple-value-setq (second form) (compile-sexp (third form))))
[1055]242      (t
[4415]243;;        (format t "COMPILE-SPECIAL skipping ~S~%" first)
[1055]244       form))))
245
[2191]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)
[4452]250  (loop
[2191]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))))
[1055]258
259(defun compile-sexp (form)
[1253]260  (if (atom form) form
261      (let ((first (car form)))
[4451]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))))))
[1055]273
[3543]274(defun %compile (name &optional definition)
[1968]275  (unless definition
[4164]276    (setq definition (or (and (symbolp name) (macro-function name))
277                         (fdefinition name))))
[1055]278  (let (expr result)
279    (cond ((functionp definition)
[1185]280           (multiple-value-bind (form closure-p)
281             (function-lambda-expression definition)
[3813]282             (unless form
283               (format t "; No lambda expression available for ~S.~%" name)
284               (return-from %compile (values nil t t)))
[1185]285             (when closure-p
[3813]286               (format t "; Unable to compile function ~S defined in non-null lexical environment.~%" name)
[1185]287               (finish-output)
[3813]288               (return-from %compile (values nil t t)))
[1185]289             (setq expr form)))
[1055]290          ((and (consp definition) (eq (car definition) 'lambda))
291           (setq expr definition))
292          (t
293           (error 'type-error)))
[3521]294    (setq result (sys::coerce-to-function (compile-sexp expr)))
[1055]295    (when (and name (functionp result))
[2980]296      (sys::%set-lambda-name result name)
297      (sys::%set-call-count result (sys::%call-count definition))
[3125]298      (sys::%set-arglist result (sys::arglist definition))
[4164]299      (if (and (symbolp name) (macro-function name))
[3500]300          (setf (fdefinition name) (sys::make-macro result))
[1968]301          (setf (fdefinition name) result)))
[1055]302    (values (or name result) nil nil)))
[2048]303
[3543]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
[2048]317(compile-package :compiler)
[2847]318(compile-package :sys)
[2048]319(compile-package :cl)
320
321(in-package :cl)
322
[3543]323(defun compile (name &optional definition)
[4335]324  (if (and name (fboundp name) (typep (symbol-function name) 'generic-function))
325      (values name nil nil)
326      (c::%compile name definition)))
[3543]327
[2048]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))
[4153]332         (body (sys::parse-defmacro lambda-list form body name 'defmacro
333                                    :environment env))
[2048]334         (expander `(lambda (,form ,env) (block ,name ,body))))
[3501]335    `(progn
336       (if (special-operator-p ',name)
[3543]337         (sys::%put ',name
[3813]338                    'sys::macroexpand-macro
[4393]339                    (sys::make-macro (or (c::%compile nil ,expander) ,expander)))
[3543]340         (sys::fset ',name
[4393]341                    (sys::make-macro (or (c::%compile nil ,expander) ,expander))))
[3501]342       ',name)))
[2099]343
344;; Make an exception just this one time...
[3813]345(sys::fset 'defmacro (get 'defmacro 'sys::macroexpand-macro))
[4401]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.