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

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

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