source: trunk/j/src/org/armedbear/lisp/transform.lisp @ 4664

Last change on this file since 4664 was 4664, checked in by piso, 18 years ago

TRANSFORM1: cleanup.

File size: 4.9 KB
Line 
1;;; transform.lisp
2;;;
3;;; Copyright (C) 2003 Peter Graves
4;;; $Id: transform.lisp,v 1.5 2003-11-07 18:12:01 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(in-package "SYSTEM")
21
22(defun compiler-macro-function (name &optional environment)
23  (get name 'compiler-macro-expander))
24
25(defun (setf compiler-macro-function) (new-function name &optional environment)
26  (%put name 'compiler-macro-expander new-function))
27
28(defmacro define-compiler-macro (name lambda-list &rest body)
29  (let* ((form (gensym))
30         (env (gensym))
31         (body (sys::parse-defmacro lambda-list form body name 'defmacro
32                                    :environment env))
33         (expander `(lambda (,form ,env) (block ,name ,body))))
34    `(progn
35       (sys::%put ',name 'compiler-macro-expander
36                  (c::%compile nil ,expander))
37       ',name)))
38
39(define-compiler-macro assoc (&whole form &rest args)
40  (cond ((and (= (length args) 4)
41              (eq (third args) :test)
42              (or (equal (fourth args) '(quote eq))
43                  (equal (fourth args) '(function eq))))
44         `(assq ,(first args) ,(second args)))
45        (t form)))
46
47(defpackage "JVM" (:use "COMMON-LISP"))
48
49(in-package "JVM")
50
51(defun transform-lambda (args)
52  (let* ((lambda-list (car args))
53         (auxvars (memq '&AUX lambda-list))
54         (body (cdr args)))
55    (if auxvars
56        (append (list 'LAMBDA (subseq lambda-list 0 (position '&AUX lambda-list))
57                      (append (list 'LET*
58                                    (cdr auxvars))
59                              (mapcar #'transform1 body))))
60        (append (list 'LAMBDA lambda-list) (mapcar #'transform1 body)))))
61
62(defun transform1 (form)
63  (when (atom form)
64    (return-from transform1 form))
65  (let ((op (car form))
66        (args (cdr form)))
67    (when (symbolp op)
68      (let ((expander (compiler-macro-function op)))
69        (when expander
70          (return-from transform1 (funcall expander form nil)))))
71    (when (and (symbolp op)
72               (not (eq op 'LAMBDA))
73               (macro-function op))
74      (setq form (macroexpand form))
75      (return-from transform1 (transform1 form)))
76    (cond ((eq op 'TAGBODY)
77           (append (list 'TAGBODY) (mapcar #'transform1 args)))
78          ((eq op 'PROGN)
79           (append (list 'PROGN) (mapcar #'transform1 args)))
80          ((eq op 'RETURN-FROM)
81           (append (list 'RETURN-FROM) (list (car args))
82                   (list (transform1 (cadr args)))))
83          ((eq op 'IF)
84           (cond ((= (length args) 2)
85                  (list 'IF
86                        (transform1 (first args))
87                        (transform1 (second args))))
88                 ((= (length args) 3)
89                  (list 'IF
90                        (transform1 (first args))
91                        (transform1 (second args))
92                        (transform1 (third args))))
93                 (t
94                  (error "wrong number of arguments for IF"))))
95          ((eq op 'LET)
96           (append (list 'LET (car args)) (mapcar #'transform1 (cdr args))))
97          ((eq op 'LET*)
98           (append (list 'LET* (car args)) (mapcar #'transform1 (cdr args))))
99          ((eq op 'LAMBDA)
100           (transform-lambda args))
101          ((eq op 'BLOCK)
102           (append (list 'BLOCK (car args)) (mapcar #'transform1 (cdr args))))
103          ((eq op 'SETQ)
104           (when (= 2 (length args))
105               (return-from transform1 (list 'SETQ (first args) (transform1 (second args)))))
106           (let ((result ()))
107             (loop
108               (when (zerop (length args))
109                 (return))
110               (when (= 1 (length args))
111                 (error "odd number of args to SETQ"))
112               (push (transform1 (list 'SETQ (first args) (second args))) result)
113               (setq args (cddr args)))
114             (setq result (nreverse result))
115             (push 'PROGN result)
116             result))
117          ((eq op 'QUOTE)
118           form)
119          ((eq op 'FUNCTION)
120           form)
121          ((and (symbolp op) (fboundp op))
122           (cons op (mapcar #'transform1 args)))
123          (t
124           form))))
125
126(defun transform (form)
127  (do* ((form1 form)
128        (form2 (transform1 form1)))
129       ((equal form1 form2) form1)
130    (setq form1 form2 form2 (transform1 form1))))
131
132(provide 'transform)
Note: See TracBrowser for help on using the repository browser.