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

Diff of /gcl/cmpnew/gcl_cmpif.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    ;;; CMPIF  Conditionals.
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 'if 'c1if 'c1special)
25    (si:putprop 'if 'c2if 'c2)
26    (si:putprop 'and 'c1and 'c1)
27    (si:putprop 'and 'c2and 'c2)
28    (si:putprop 'or 'c1or 'c1)
29    (si:putprop 'or 'c2or 'c2)
30    
31    (si:putprop 'jump-true 'set-jump-true 'set-loc)
32    (si:putprop 'jump-false 'set-jump-false 'set-loc)
33    
34    (si:putprop 'case 'c1case 'c1)
35    (si:putprop 'ecase 'c1ecase 'c1)
36    (si:putprop 'case 'c2case 'c2)
37    
38    (defun c1if (args &aux info f)
39      (when (or (endp args) (endp (cdr args)))
40            (too-few-args 'if 2 (length args)))
41      (unless (or (endp (cddr args)) (endp (cdddr args)))
42              (too-many-args 'if 3 (length args)))
43      (setq f (c1fmla-constant (car args)))
44    
45      (case f
46            ((t) (c1expr (cadr args)))
47            ((nil) (if (endp (cddr args)) (c1nil) (c1expr (caddr args))))
48            (otherwise
49             (setq info (make-info))
50             (list 'if info
51                   (c1fmla f info)
52                   (c1expr* (cadr args) info)
53                   (if (endp (cddr args)) (c1nil) (c1expr* (caddr args) info)))))
54      )
55    
56    (defun c1fmla-constant (fmla &aux f)
57      (cond
58       ((consp fmla)
59        (case (car fmla)
60              (and (do ((fl (cdr fmla) (cdr fl)))
61                       ((endp fl) t)
62                       (declare (object fl))
63                       (setq f (c1fmla-constant (car fl)))
64                       (case f
65                             ((t))
66                             ((nil) (return nil))
67                             (t (if (endp (cdr fl))
68                                    (return f)
69                                      (return (list* 'and f (cdr fl))))))))
70              (or (do ((fl (cdr fmla) (cdr fl)))
71                      ((endp fl) nil)
72                      (declare (object fl))
73                      (setq f (c1fmla-constant (car fl)))
74                      (case f
75                            ((t) (return t))
76                            ((nil))
77                            (t (if (endp (cdr fl))
78                                   (return f)
79                                   (return (list* 'or f (cdr fl))))))))
80              ((not null)
81               (when (endp (cdr fmla)) (too-few-args 'not 1 0))
82               (unless (endp (cddr fmla))
83                       (too-many-args 'not 1 (length (cdr fmla))))
84               (setq f (c1fmla-constant (cadr fmla)))
85               (case f
86                     ((t) nil)
87                     ((nil) t)
88                     (t (list 'not f))))
89              (t fmla)))
90       ((symbolp fmla) (if (constantp fmla)
91                           (if (symbol-value fmla) t nil)
92                           fmla))
93       (t t))
94      )
95    
96    (defun c1fmla (fmla info)
97      (if (consp fmla)
98          (case (car fmla)
99                (and (case (length (cdr fmla))
100                       (0 (c1t))
101                       (1 (c1fmla (cadr fmla) info))
102                       (t (cons 'FMLA-AND
103                                (mapcar #'(lambda (x) (c1fmla x info))
104                                        (cdr fmla))))))
105                (or (case (length (cdr fmla))
106                       (0 (c1nil))
107                       (1 (c1fmla (cadr fmla) info))
108                       (t (cons 'FMLA-OR
109                                (mapcar #'(lambda (x) (c1fmla x info))
110                                        (cdr fmla))))))
111                ((not null)
112                      (when (endp (cdr fmla)) (too-few-args 'not 1 0))
113                      (unless (endp (cddr fmla))
114                              (too-many-args 'not 1 (length (cdr fmla))))
115                      (list 'FMLA-NOT (c1fmla (cadr fmla) info)))
116                (t (c1expr* `(the boolean ,fmla) info)))
117          (c1expr* fmla info))
118      )
119    
120    (defun c2if (fmla form1 form2
121                      &aux (Tlabel (next-label)) Flabel)
122      (cond ((and (eq (car form2) 'LOCATION)
123                  (null (caddr form2))
124                  (eq *value-to-go* 'TRASH)
125                   (not (eq *exit* 'RETURN)))
126             (let ((exit *exit*)
127                   (*unwind-exit* (cons Tlabel *unwind-exit*))
128                   (*exit* Tlabel))
129                  (CJF fmla Tlabel exit))
130             (wt-label Tlabel)
131             (c2expr form1))
132            (t
133             (setq Flabel (next-label))
134             (let ((*unwind-exit* (cons Flabel (cons Tlabel *unwind-exit*)))
135                   (*exit* Tlabel))
136                  (CJF fmla Tlabel Flabel))
137             (wt-label Tlabel)
138             (let ((*unwind-exit* (cons 'JUMP *unwind-exit*))) (c2expr form1))
139             (wt-label Flabel)
140             (c2expr form2)))
141      )
142    
143    ;;; If fmla is true, jump to Tlabel.  If false, do nothing.
144    (defun CJT (fmla Tlabel Flabel)
145      (case (car fmla)
146        (fmla-and (do ((fs (cdr fmla) (cdr fs)))
147                      ((endp (cdr fs))
148                       (CJT (car fs) Tlabel Flabel))
149                      (declare (object fs))
150                      (let* ((label (next-label))
151                             (*unwind-exit* (cons label *unwind-exit*)))
152                            (CJF (car fs) label Flabel)
153                            (wt-label label))))
154        (fmla-or (do ((fs (cdr fmla) (cdr fs)))
155                     ((endp (cdr fs))
156                      (CJT (car fs) Tlabel Flabel))
157                     (declare (object fs))
158                     (let* ((label (next-label))
159                            (*unwind-exit* (cons label *unwind-exit*)))
160                           (CJT (car fs) Tlabel label)
161                           (wt-label label))))
162        (fmla-not (CJF (cadr fmla) Flabel Tlabel))
163        (LOCATION
164         (case (caddr fmla)
165               ((t) (unwind-no-exit Tlabel) (wt-nl) (wt-go Tlabel))
166               ((nil))
167               (t (let ((*value-to-go* (list 'jump-true Tlabel)))
168                       (c2expr* fmla)))))
169        (t (let ((*value-to-go* (list 'jump-true Tlabel))) (c2expr* fmla))))
170      )
171    
172    ;;; If fmla is false, jump to Flabel.  If true, do nothing.
173    (defun CJF (fmla Tlabel Flabel)
174      (case (car fmla)
175        (FMLA-AND (do ((fs (cdr fmla) (cdr fs)))
176                      ((endp (cdr fs)) (CJF (car fs) Tlabel Flabel))
177                      (declare (object fs))
178                      (let* ((label (next-label))
179                             (*unwind-exit* (cons label *unwind-exit*)))
180                            (CJF (car fs) label Flabel)
181                            (wt-label label))))
182        (FMLA-OR (do ((fs (cdr fmla) (cdr fs)))
183                     ((endp (cdr fs)) (CJF (car fs) Tlabel Flabel))
184                     (declare (object fs))
185                     (let* ((label (next-label))
186                            (*unwind-exit* (cons label *unwind-exit*)))
187                           (CJT (car fs) Tlabel label)
188                           (wt-label label))))
189        (FMLA-NOT (CJT (cadr fmla) Flabel Tlabel))
190        (LOCATION
191         (case (caddr fmla)
192               ((t))
193               ((nil) (unwind-no-exit Flabel) (wt-nl) (wt-go Flabel))
194               (t (let ((*value-to-go* (list 'jump-false Flabel)))
195                       (c2expr* fmla)))))
196        (t (let ((*value-to-go* (list 'jump-false Flabel))) (c2expr* fmla))))
197      )
198    
199    (defun c1and (args)
200      (cond ((endp args) (c1t))
201            ((endp (cdr args)) (c1expr (car args)))
202            (t (let ((info (make-info))) (list 'AND info (c1args args info))))))
203    
204    (defun c2and (forms)
205      (do ((forms forms (cdr forms)))
206          ((endp (cdr forms))
207           (c2expr (car forms)))
208          (declare (object forms))
209          (cond ((eq (caar forms) 'LOCATION)
210                 (case (caddar forms)
211                       ((t))
212                       ((nil) (unwind-exit nil 'JUMP))
213                       (t (wt-nl "if(" (caddar forms) "==Cnil){")
214                          (unwind-exit nil 'JUMP) (wt "}")
215                          )))
216                ((eq (caar forms) 'VAR)
217                 (wt-nl "if(")
218                 (wt-var (car (caddar forms)) (cadr (caddar forms)))
219                 (wt "==Cnil){")
220                 (unwind-exit nil 'jump) (wt "}"))
221                (t
222                 (let* ((label (next-label))
223                        (*unwind-exit* (cons label *unwind-exit*)))
224                       (let ((*value-to-go* (list 'jump-true label)))
225                            (c2expr* (car forms)))
226                       (unwind-exit nil 'jump)
227                       (wt-label label))))
228          ))
229    
230    (defun c1or (args)
231      (cond ((endp args) (c1nil))
232            ((endp (cdr args)) (c1expr (car args)))
233            (t (let ((info (make-info)))
234                    (list 'OR info (c1args args info))))))
235    
236    (defun c2or (forms &aux (*vs* *vs*) temp)
237      (do ((forms forms (cdr forms))
238           )
239          ((endp (cdr forms))
240           (c2expr (car forms)))
241          (declare (object forms))
242          (cond ((eq (caar forms) 'LOCATION)
243                 (case (caddar forms)
244                       ((t) (unwind-exit t 'JUMP))
245                       ((nil))
246                       (t (wt-nl "if(" (caddar forms) "!=Cnil){")
247                          (unwind-exit (caddar forms) 'JUMP) (wt "}"))))
248                ((eq (caar forms) 'VAR)
249                 (wt-nl "if(")
250                 (wt-var (car (caddar forms)) (cadr (caddar forms)))
251                 (wt "!=Cnil){")
252                 (unwind-exit (cons 'VAR (caddar forms)) 'jump) (wt "}"))
253                ((and (eq (caar forms) 'CALL-GLOBAL)
254                      (get (caddar forms) 'predicate))
255                 (let* ((label (next-label))
256                        (*unwind-exit* (cons label *unwind-exit*)))
257                       (let ((*value-to-go* (list 'jump-false label)))
258                            (c2expr* (car forms)))
259                       (unwind-exit t 'jump)
260                       (wt-label label)))
261                (t
262                 (let* ((label (next-label))
263                        (*inline-blocks* 0)
264                        (*unwind-exit* (cons label *unwind-exit*)))
265                       (setq temp (wt-c-push))
266                       (let ((*value-to-go* temp)) (c2expr* (car forms)))
267                       (wt-nl "if(" temp "==Cnil)") (wt-go label)
268                       (unwind-exit temp 'jump)
269                       (wt-label label)
270                       (close-inline-blocks)
271                       )))
272          )
273      )
274    
275    (defun set-jump-true (loc label)
276      (unless (null loc)
277        (cond ((eq loc t))
278              ((and (consp loc) (eq (car loc) 'INLINE-COND))
279               (wt-nl "if(")
280               (wt-inline-loc (caddr loc) (cadddr loc))
281               (wt ")"))
282              (t (wt-nl "if((" loc ")!=Cnil)")))
283        (unless (eq loc t) (wt "{"))
284        (unwind-no-exit label)
285        (wt-nl) (wt-go label)
286        (unless (eq loc t) (wt "}")))
287      )
288    
289    (defun set-jump-false (loc label)
290      (unless (eq loc t)
291        (cond ((null loc))
292              ((and (consp loc) (eq (car loc) 'INLINE-COND))
293               (wt-nl "if(!(")
294               (wt-inline-loc (caddr loc) (cadddr loc))
295               (wt "))"))
296              (t (wt-nl "if((" loc ")==Cnil)")))
297        (unless (null loc) (wt "{"))
298        (unwind-no-exit label)
299        (wt-nl) (wt-go label)
300        (unless (null loc) (wt "}")))
301      )
302    
303    (defun c1ecase (args) (c1case args t))  
304    
305    ;;If the key is declared fixnum, then we convert a case statement to a switch,
306    ;;so that we may see the benefit of a table jump.
307    
308    (defun convert-case-to-switch (args default)
309      (let ((sym (gensym)) body keys)
310        (dolist (v (cdr args))
311                (cond ((si::fixnump (car v)) (push  (car v) body))
312                      ((consp (car v))(dolist (w (car v)) (push w body)))
313                      ((member (car v) '(t otherwise))
314                       (and default
315                            (cmperror "T or otherwise found in an ecase"))
316                       (push t body)))
317                (push `(return-from ,sym (progn ,@ (cdr v))) body))
318        (cond (default (push t body)
319                (dolist (v (cdr args))
320                        (cond ((atom (car v)) (push (car v) keys))
321                              (t (setq keys (append (car v) keys)))))
322                (push `(error "The key ~a for ECASE was not found in cases ~a"
323                              ,(car args) ',keys)
324                      body)))
325        `(block ,sym (si::switch ,(car args) ,@ (nreverse body)))))
326                
327                      
328    
329    (defun c1case (args &optional (default nil))
330      (when (endp args) (too-few-args 'case 1 0))
331      (let* ((info (make-info))
332             (key-form (c1expr* (car args) info))
333             (clauses nil))
334        (cond ((subtypep (info-type (second key-form)) 'fixnum)
335               (return-from c1case  (c1expr (convert-case-to-switch
336                                     args default )))))
337        (dolist (clause (cdr args))
338          (cmpck (endp clause) "The CASE clause ~S is illegal." clause)
339          (case (car clause)
340                ((nil))
341                ((t otherwise)
342                 (when default
343                       (cmperr (if (eq default 't)
344                                   "ECASE had an OTHERWISE clause."
345                                   "CASE had more than one OTHERWISE clauses.")))
346                 (setq default (c1progn (cdr clause)))
347                 (add-info info (cadr default)))
348                (t (let* ((keylist
349                           (cond ((consp (car clause))
350                                  (mapcar #'(lambda (key) (if (symbolp key) key
351                                                              (add-object key)))
352                                          (car clause)))
353                                 ((symbolp (car clause)) (list (car clause)))
354                                 (t (list (add-object (car clause))))))
355                          (body (c1progn (cdr clause))))
356                     (add-info info (cadr body))
357                     (push (cons keylist body) clauses)))))
358        (list 'case info key-form (reverse clauses) (or default (c1nil)))))
359    
360    (defun c2case (key-form clauses default
361                   &aux (cvar (next-cvar)) (*vs* *vs*) (*inline-blocks* 0))
362      (setq key-form (car (inline-args (list key-form) '(t))))
363      (wt-nl "{object V" cvar "= " key-form ";")
364    
365      (dolist (clause clauses)
366        (let* ((label (next-label))
367               (keylist (car clause))
368               (local-label nil))
369          (do ()
370              ((<= (length keylist) 5))
371            (when (null local-label) (setq local-label (next-label)))
372            (wt-nl "if(")
373            (dotimes (i 5)
374              (cond ((symbolp (car keylist))
375                     (wt "(V" cvar "== ")
376                     (case (car keylist)
377                       ((t) (wt "Ct"))
378                       ((nil) (wt "Cnil"))
379                       (otherwise (wt "VV[" (add-symbol (car keylist)) "]")))
380                     (wt ")"))
381                    (t (wt "eql(V" cvar ",VV[" (car keylist) "])")))
382              (when (< i 4) (wt-nl "|| "))
383              (pop keylist))
384            (wt ")")
385            (wt-go local-label))
386    
387          (wt-nl "if(")
388          (do ()
389              ((endp keylist))
390            (cond ((symbolp (car keylist))
391                   (wt "(V" cvar "!= ")
392                   (case (car keylist)
393                     ((t) (wt "Ct"))
394                     ((nil) (wt "Cnil"))
395                     (otherwise (wt "VV[" (add-symbol (car keylist)) "]")))
396                   (wt ")"))
397                  (t (wt "!eql(V" cvar ",VV[" (car keylist) "])")))
398            (unless (endp (cdr keylist)) (wt-nl "&& "))
399            (pop keylist))
400          (wt ")")
401          (wt-go label)
402          (when local-label (wt-label local-label))
403          (let ((*unwind-exit* (cons 'JUMP *unwind-exit*))) (c2expr (cdr clause)))
404          (wt-label label)))
405    
406      (if (eq default 't)
407          (progn (wt-nl "FEerror(\"The ECASE key value ~s is illegal.\",1,V" cvar ");")
408                 (unwind-exit nil 'jump))
409          (c2expr default))
410    
411      (wt "}")
412      (close-inline-blocks))
413    
414    

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