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

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

Work in progress.

File size: 5.4 KB
Line 
1;;; transform.lisp
2;;;
3;;; Copyright (C) 2003 Peter Graves
4;;; $Id: transform.lisp,v 1.4 2003-11-04 19:13:51 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  (when (symbolp (car form))
66    (let ((expander (compiler-macro-function (car form))))
67      (when expander
68        (return-from transform1 (funcall expander form nil)))))
69  (let ((fun (car form))
70        (args (cdr form)))
71    (when (and (symbolp fun)
72               (not (eq fun 'LAMBDA))
73               (macro-function fun))
74      (setq form (macroexpand form))
75      (return-from transform1 (transform1 form)))
76    (cond ((eq fun 'COND)
77           (assert false)
78           (transform-cond args))
79          ((eq fun 'AND)
80           (assert false)
81           (transform-and args))
82          ((eq fun 'OR)
83           (error "transform-or called")
84           (transform-or args))
85          ((eq fun 'NOT)
86           (if (consp args)
87               (if (eq (first args) 'NOT)
88                   (transform (second args))
89                   (list 'NOT (transform (car args))))
90               (list 'NOT (transform (car args)))))
91          ((eq fun 'TAGBODY)
92           (append (list 'TAGBODY) (mapcar #'transform1 args)))
93          ((eq fun 'PROGN)
94           (append (list 'PROGN) (mapcar #'transform1 args)))
95          ((eq fun 'RETURN-FROM)
96           (append (list 'RETURN-FROM) (list (car args))
97                   (list (transform1 (cadr args)))))
98          ((eq fun 'IF)
99           (cond ((= (length args) 2)
100                  (list 'IF
101                        (transform1 (first args))
102                        (transform1 (second args))))
103                 ((= (length args) 3)
104                  (list 'IF
105                        (transform1 (first args))
106                        (transform1 (second args))
107                        (transform1 (third args))))
108                 (t
109                  (error "wrong number of arguments for IF"))))
110          ((eq fun 'LET)
111           (append (list 'LET (car args)) (mapcar #'transform1 (cdr args))))
112          ((eq fun 'LET*)
113           (append (list 'LET* (car args)) (mapcar #'transform1 (cdr args))))
114          ((eq fun 'LAMBDA)
115           (transform-lambda args))
116          ((eq fun 'BLOCK)
117           (append (list 'BLOCK (car args)) (mapcar #'transform1 (cdr args))))
118          ((eq fun 'SETQ)
119           (when (= 2 (length args))
120               (return-from transform1 (list 'SETQ (first args) (transform1 (second args)))))
121           (let ((result ()))
122             (loop
123               (when (zerop (length args))
124                 (return))
125               (when (= 1 (length args))
126                 (error "odd number of args to SETQ"))
127               (push (transform1 (list 'SETQ (first args) (second args))) result)
128               (setq args (cddr args)))
129             (setq result (nreverse result))
130             (push 'PROGN result)
131             result))
132          ((eq fun 'QUOTE)
133           form)
134          ((eq fun 'FUNCTION)
135           form)
136          ((and (symbolp fun) (fboundp fun))
137           (cons fun (mapcar #'transform1 args)))
138          (t
139           form))))
140
141(defun transform (form)
142  (do* ((form1 form)
143        (form2 (transform1 form1)))
144       ((equal form1 form2) form1)
145    (setq form1 form2 form2 (transform1 form1))))
146
147(provide 'transform)
Note: See TracBrowser for help on using the repository browser.