← Back to branch summary

~ubuntu-branches/ubuntu/vivid/gcl/vivid

« back to all changes in this revision

Viewing changes to cmpnew/cmpflet.lsp

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2002-03-04 14:29:59 UTC
  • Revision ID: james.westby@ubuntu.com-20020304142959-dey14w08kr7lldu3
Tags: upstream-2.5.0.cvs20020219
Import upstream version 2.5.0.cvs20020219

Show diffs side-by-side

added added

removed removed

Lines of Context:
cmpnew/cmpflet.lsp
 
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