/[gcl]/gcl/cmpnew/gcl_cmpflet.lsp
ViewVC logotype

Diff of /gcl/cmpnew/gcl_cmpflet.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by camm, Sun Sep 14 02:30:33 2003 UTC revision 1.2 by camm, Sun Sep 14 02:43:01 2003 UTC
# Line 0  Line 1 
1    ;;; CMPFLET  Flet, Labels, and Macrolet.
2    ;;;
3    ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
4    
5    ;; This file is part of GNU Common Lisp, herein referred to as GCL
6    ;;
7    ;; GCL is free software; you can redistribute it and/or modify it under
8    ;;  the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
9    ;; the Free Software Foundation; either version 2, or (at your option)
10    ;; any later version.
11    ;;
12    ;; GCL is distributed in the hope that it will be useful, but WITHOUT
13    ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
14    ;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public
15    ;; License for more details.
16    ;;
17    ;; You should have received a copy of the GNU Library General Public License
18    ;; along with GCL; see the file COPYING.  If not, write to the Free Software
19    ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
20    
21    
22    (in-package 'compiler)
23    
24    (si:putprop 'flet 'c1flet 'c1special)
25    (si:putprop 'flet 'c2flet 'c2)
26    (si:putprop 'labels 'c1labels 'c1special)
27    (si:putprop 'labels 'c2labels 'c2)
28    (si:putprop 'macrolet 'c1macrolet 'c1special)
29    ;;; c2macrolet is not defined, because MACROLET is replaced by PROGN
30    ;;; during Pass 1.
31    (si:putprop 'call-local 'c2call-local 'c2)
32    
33    (defstruct fun
34               name                 ;;; Function name.
35               ref                  ;;; Referenced or not.
36                                    ;;; During Pass1, T or NIL.
37                                    ;;; During Pass2, the vs-address for the
38                                    ;;; function closure, or NIL.
39               ref-ccb              ;;; Cross closure reference.
40                                    ;;; During Pass1, T or NIL.
41                                    ;;; During Pass2, the vs-address for the
42                                    ;;; function closure, or NIL.
43               cfun                 ;;; The cfun for the function.
44               level                ;;; The level of the function.
45               )
46    
47    (defvar *funs* nil)
48    
49    ;;; During Pass 1, *funs* holds a list of fun objects, local macro definitions
50    ;;; and the symbol 'CB' (Closure Boundary).  'CB' will be pushed on *funs*
51    ;;; when the compiler begins to process a closure.  A local macro definition
52    ;;; is a list ( macro-name expansion-function).
53    
54    (defun c1flet (args &aux body ss ts is other-decl info
55                             (defs1 nil) (local-funs nil) (closures nil))
56      (when (endp args) (too-few-args 'flet 1 0))
57      (let ((*funs* *funs*))
58           (dolist** (def (car args))
59             (cmpck (or (endp def)
60                        (not (symbolp (car def)))
61                        (endp (cdr def)))
62                    "The function definition ~s is illegal." def)
63             (let ((fun (make-fun :name (car def) :ref nil :ref-ccb nil)))
64                  (push fun *funs*)
65                  (push (list fun (cdr def)) defs1)))
66    
67           (multiple-value-setq (body ss ts is other-decl) (c1body (cdr args) t))
68    
69           (let ((*vars* *vars*))
70                (c1add-globals ss)
71                (check-vdecl nil ts is)
72                (setq body (c1decl-body other-decl body)))
73           (setq info (copy-info (cadr body))))
74    
75      (dolist* (def (reverse defs1))
76        (when (fun-ref-ccb (car def))
77              (let ((*vars* (cons 'cb *vars*))
78                    (*funs* (cons 'cb *funs*))
79                    (*blocks* (cons 'cb *blocks*))
80                    (*tags* (cons 'cb *tags*)))
81                   (let ((lam (c1lambda-expr (cadr def) (fun-name (car def)))))
82                        (add-info info (cadr lam))
83                        (push (list (car def) lam) closures))))
84    
85        (when (fun-ref (car def))
86              (let ((*blocks* (cons 'lb *blocks*))
87                    (*tags* (cons 'lb *tags*))
88                    (*vars* (cons 'lb *vars*)))
89                   (let ((lam (c1lambda-expr (cadr def) (fun-name (car def)))))
90                        (add-info info (cadr lam))
91                        (push (list (car def) lam) local-funs))))
92    
93        (when (or (fun-ref (car def)) (fun-ref-ccb (car def)))
94              (setf (fun-cfun (car def)) (next-cfun)))
95        )
96      (if (or local-funs closures)
97          (list 'flet info (reverse local-funs) (reverse closures) body)
98          body)
99      )
100    
101    (defun c2flet (local-funs closures body
102                   &aux (*vs* *vs*) (*clink* *clink*) (*ccb-vs* *ccb-vs*))
103    
104      (dolist** (def local-funs)
105        (setf (fun-level (car def)) *level*)
106        (push (list nil *clink* *ccb-vs* (car def) (cadr def)) *local-funs*))
107    
108      ;;; Setup closures.
109      (dolist** (def closures)
110        (push (list 'closure
111                    (if (null *clink*) nil (cons 0 0))
112                    *ccb-vs* (car def) (cadr def))
113              *local-funs*)
114        (push (car def) *closures*)
115        (let ((fun (car def)))
116             (declare (object fun))
117             (setf (fun-ref fun) (vs-push))
118             (wt-nl)
119             (wt-vs (fun-ref fun))
120             (wt "=make_cclosure_new(LC" (fun-cfun fun) ",Cnil,") (wt-clink)
121             (wt ",Cdata);")
122             (wt-nl)
123             (wt-vs (fun-ref fun))
124             (wt "=MMcons(") (wt-vs (fun-ref fun)) (wt ",") (wt-clink) (wt ");")
125             (clink (fun-ref fun))
126             (setf (fun-ref-ccb fun) (ccb-vs-push))
127             ))
128    
129      (c2expr body)
130      )
131    
132    (defun c1labels (args &aux body ss ts is other-decl info
133                          (defs1 nil) (local-funs nil) (closures nil)
134                          (fnames nil) (processed-flag nil) (*funs* *funs*))
135      (when (endp args) (too-few-args 'labels 1 0))
136    
137      ;;; bind local-functions
138      (dolist** (def (car args))
139        (cmpck (or (endp def) (not (symbolp (car def))) (endp (cdr def)))
140               "The local function definition ~s is illegal." def)
141        (cmpck (member (car def) fnames)
142               "The function ~s was already defined." (car def))
143        (push (car def) fnames)
144        (let ((fun (make-fun :name (car def) :ref nil :ref-ccb nil)))
145             (push fun *funs*)
146             (push (list fun nil nil (cdr def)) defs1)))
147    
148      (setq defs1 (reverse defs1))
149    
150      ;;; Now DEFS1 holds ( { ( fun-object NIL NIL body ) }* ).
151    
152      (multiple-value-setq (body ss ts is other-decl) (c1body (cdr args) t))
153      (let ((*vars* *vars*))
154           (c1add-globals ss)
155           (check-vdecl nil ts is)
156           (setq body (c1decl-body other-decl body)))
157      (setq info (copy-info (cadr body)))
158    
159      (block local-process
160        (loop
161         (setq processed-flag nil)
162         (dolist** (def defs1)
163           (when (and (fun-ref (car def))           ;;; referred locally and
164                      (null (cadr def)))            ;;; not processed yet
165             (setq processed-flag t)
166             (setf (cadr def) t)
167             (let ((*blocks* (cons 'lb *blocks*))
168                   (*tags* (cons 'lb *tags*))
169                   (*vars* (cons 'lb *vars*)))
170                  (let ((lam (c1lambda-expr (cadddr def) (fun-name (car def)))))
171                       (add-info info (cadr lam))
172                       (push (list (car def) lam) local-funs)))))
173         (unless processed-flag (return-from local-process))
174         )) ;;; end local process
175    
176      (block closure-process
177        (loop
178         (setq processed-flag nil)
179         (dolist** (def defs1)
180           (when (and (fun-ref-ccb (car def))       ; referred across closure
181                      (null (caddr def)))           ; and not processed
182             (setq processed-flag t)
183             (setf (caddr def) t)
184             (let ((*vars* (cons 'cb *vars*))
185                   (*funs* (cons 'cb *funs*))
186                   (*blocks* (cons 'cb *blocks*))
187                   (*tags* (cons 'cb *tags*)))
188                  (let ((lam (c1lambda-expr (cadddr def) (fun-name (car def)))))
189                       (add-info info (cadr lam))
190                       (push (list (car def) lam) closures))))
191           )
192         (unless processed-flag (return-from closure-process))
193         )) ;;; end closure process
194    
195      (dolist** (def defs1)
196        (when (or (fun-ref (car def)) (fun-ref-ccb (car def)))
197              (setf (fun-cfun (car def)) (next-cfun))))
198    
199      (if (or local-funs closures)
200          (list 'labels info (reverse local-funs) (reverse closures) body)
201          body)
202      )
203    
204    (defun c2labels (local-funs closures body &aux (*vs* *vs*) (*clink* *clink*))
205    
206      ;;; Prepare for cross-referencing closures.
207      (dolist** (def closures)
208        (let ((fun (car def)))
209             (declare (object fun))
210             (setf (fun-ref fun) (vs-push))
211             (wt-nl)
212             (wt-vs (fun-ref fun))
213             (wt "=MMcons(Cnil,") (wt-clink) (wt ");")
214             (clink (fun-ref fun))
215             (setf (fun-ref-ccb fun) (ccb-vs-push))
216        ))
217    
218      (dolist** (def local-funs)
219        (setf (fun-level (car def)) *level*)
220        (push (list nil *clink* *ccb-vs* (car def) (cadr def)) *local-funs*))
221    
222      ;;; Then make closures.
223      (dolist** (def closures)
224        (push (list 'closure (if (null *clink*) nil (cons 0 0))
225                    *ccb-vs* (car def) (cadr def))
226              *local-funs*)
227        (push (car def) *closures*)
228        (wt-nl)
229        (wt-vs* (fun-ref (car def)))
230        (wt "=make_cclosure_new(LC" (fun-cfun (car def)) ",Cnil,") (wt-clink)
231        (wt ",Cdata);")
232        )
233    
234      ;;; now the body of flet
235    
236      (c2expr body)
237      )
238    
239    (defun c1macrolet (args &aux body ss ts is other-decl
240                            (*funs* *funs*) (*vars* *vars*))
241      (when (endp args) (too-few-args 'macrolet 1 0))
242      (dolist** (def (car args))
243        (cmpck (or (endp def) (not (symbolp (car def))) (endp (cdr def)))
244               "The macro definition ~s is illegal." def)
245        (push (list (car def)
246                    (caddr (si:defmacro* (car def) (cadr def) (cddr def))))
247              *funs*))
248      (multiple-value-setq (body ss ts is other-decl) (c1body (cdr args) t))
249      (c1add-globals ss)
250      (check-vdecl nil ts is)
251      (c1decl-body other-decl body)
252      )
253    
254    (defun c1local-fun (fname &aux (ccb nil))
255      (declare (object ccb))
256      (dolist* (fun *funs* nil)
257        (cond ((eq fun 'CB) (setq ccb t))
258              ((consp fun)
259               (when (eq (car fun) fname) (return (cadr fun))))
260              ((eq (fun-name fun) fname)
261               (if ccb
262                   (setf (fun-ref-ccb fun) t)
263                   (setf (fun-ref fun) t))
264               (return (list 'call-local *info* fun ccb)))))
265      )
266    
267    (defun sch-local-fun (fname)
268      ;;; Returns fun-ob for the local function (not locat macro) named FNAME,
269      ;;; if any.  Otherwise, returns FNAME itself.
270      (dolist* (fun *funs* fname)
271        (when (and (not (eq fun 'CB))
272                   (not (consp fun))
273                   (eq (fun-name fun) fname))
274              (return fun)))
275      )
276    
277    (defun c1local-closure (fname &aux (ccb nil))
278      (declare (object ccb))
279      ;;; Called only from C1FUNCTION.
280      (dolist* (fun *funs* nil)
281        (cond ((eq fun 'CB) (setq ccb t))
282              ((consp fun)
283               (when (eq (car fun) fname) (return (cadr fun))))
284              ((eq (fun-name fun) fname)
285               (setf (fun-ref-ccb fun) t)
286               (return (list 'call-local *info* fun ccb)))))
287      )
288    
289    (defun c2call-local (fd args &aux (*vs* *vs*))
290      ;;; FD is a list ( fun-object ccb ).
291      (cond
292       ((cadr fd)
293        (push-args args)
294        (wt-nl "cclosure_call(") (wt-ccb-vs (fun-ref-ccb (car fd))) (wt ");"))
295       ((and (listp args)
296             *do-tail-recursion*
297             *tail-recursion-info*
298             (eq (car *tail-recursion-info*) (car fd))
299             (eq *exit* 'RETURN)
300             (tail-recursion-possible)
301             (= (length args) (length (cdr *tail-recursion-info*))))
302        (let* ((*value-to-go* 'trash)
303               (*exit* (next-label))
304               (*unwind-exit* (cons *exit* *unwind-exit*)))
305              (c2psetq (mapcar #'(lambda (v) (list v nil))
306                               (cdr *tail-recursion-info*))
307                       args)
308              (wt-label *exit*))
309        (unwind-no-exit 'tail-recursion-mark)
310        (wt-nl "goto TTL;")
311        (cmpnote "Tail-recursive call of ~s was replaced by iteration."
312                 (fun-name (car fd))))
313       (t (push-args args)
314          (wt-nl "L" (fun-cfun (car fd)) "(")
315          (dotimes** (n (fun-level (car fd))) (wt "base" n ","))
316          (wt "base")
317          (unless (= (fun-level (car fd)) *level*) (wt (fun-level (car fd))))
318          (wt ");")
319          (base-used)))
320      (unwind-exit 'fun-val)
321      )
322    

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26