1
;;; CMPIF Conditionals.
3
;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
5
;; This file is part of GNU Common Lisp, herein referred to as GCL
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)
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.
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.
22
(in-package 'compiler)
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)
31
(si:putprop 'jump-true 'set-jump-true 'set-loc)
32
(si:putprop 'jump-false 'set-jump-false 'set-loc)
34
(si:putprop 'case 'c1case 'c1)
35
(si:putprop 'ecase 'c1ecase 'c1)
36
(si:putprop 'case 'c2case 'c2)
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)))
46
((t) (c1expr (cadr args)))
47
((nil) (if (endp (cddr args)) (c1nil) (c1expr (caddr args))))
49
(setq info (make-info))
52
(c1expr* (cadr args) info)
53
(if (endp (cddr args)) (c1nil) (c1expr* (caddr args) info)))))
56
(defun c1fmla-constant (fmla &aux f)
60
(and (do ((fl (cdr fmla) (cdr fl)))
63
(setq f (c1fmla-constant (car fl)))
67
(t (if (endp (cdr fl))
69
(return (list* 'and f (cdr fl))))))))
70
(or (do ((fl (cdr fmla) (cdr fl)))
73
(setq f (c1fmla-constant (car fl)))
77
(t (if (endp (cdr fl))
79
(return (list* 'or f (cdr fl))))))))
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)))
90
((symbolp fmla) (if (constantp fmla)
91
(if (symbol-value fmla) t nil)
96
(defun c1fmla (fmla info)
99
(and (case (length (cdr fmla))
101
(1 (c1fmla (cadr fmla) info))
103
(mapcar #'(lambda (x) (c1fmla x info))
105
(or (case (length (cdr fmla))
107
(1 (c1fmla (cadr fmla) info))
109
(mapcar #'(lambda (x) (c1fmla x info))
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)))
120
(defun c2if (fmla form1 form2
121
&aux (Tlabel (next-label)) Flabel)
122
(cond ((and (eq (car form2) 'LOCATION)
124
(eq *value-to-go* 'TRASH)
125
(not (eq *exit* 'RETURN)))
127
(*unwind-exit* (cons Tlabel *unwind-exit*))
129
(CJF fmla Tlabel exit))
133
(setq Flabel (next-label))
134
(let ((*unwind-exit* (cons Flabel (cons Tlabel *unwind-exit*)))
136
(CJF fmla Tlabel Flabel))
138
(let ((*unwind-exit* (cons 'JUMP *unwind-exit*))) (c2expr form1))
143
;;; If fmla is true, jump to Tlabel. If false, do nothing.
144
(defun CJT (fmla Tlabel Flabel)
146
(fmla-and (do ((fs (cdr fmla) (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)
154
(fmla-or (do ((fs (cdr fmla) (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)
162
(fmla-not (CJF (cadr fmla) Flabel Tlabel))
165
((t) (unwind-no-exit Tlabel) (wt-nl) (wt-go Tlabel))
167
(t (let ((*value-to-go* (list 'jump-true Tlabel)))
169
(t (let ((*value-to-go* (list 'jump-true Tlabel))) (c2expr* fmla))))
172
;;; If fmla is false, jump to Flabel. If true, do nothing.
173
(defun CJF (fmla Tlabel Flabel)
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)
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)
189
(FMLA-NOT (CJT (cadr fmla) Flabel Tlabel))
193
((nil) (unwind-no-exit Flabel) (wt-nl) (wt-go Flabel))
194
(t (let ((*value-to-go* (list 'jump-false Flabel)))
196
(t (let ((*value-to-go* (list 'jump-false Flabel))) (c2expr* fmla))))
200
(cond ((endp args) (c1t))
201
((endp (cdr args)) (c1expr (car args)))
202
(t (let ((info (make-info))) (list 'AND info (c1args args info))))))
205
(do ((forms forms (cdr forms)))
207
(c2expr (car forms)))
208
(declare (object forms))
209
(cond ((eq (caar forms) 'LOCATION)
212
((nil) (unwind-exit nil 'JUMP))
213
(t (wt-nl "if(" (caddar forms) "==Cnil){")
214
(unwind-exit nil 'JUMP) (wt "}")
216
((eq (caar forms) 'VAR)
218
(wt-var (car (caddar forms)) (cadr (caddar forms)))
220
(unwind-exit nil 'jump) (wt "}"))
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)
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))))))
236
(defun c2or (forms &aux (*vs* *vs*) temp)
237
(do ((forms forms (cdr forms))
240
(c2expr (car forms)))
241
(declare (object forms))
242
(cond ((eq (caar forms) 'LOCATION)
244
((t) (unwind-exit t 'JUMP))
246
(t (wt-nl "if(" (caddar forms) "!=Cnil){")
247
(unwind-exit (caddar forms) 'JUMP) (wt "}"))))
248
((eq (caar forms) 'VAR)
250
(wt-var (car (caddar forms)) (cadr (caddar forms)))
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)
262
(let* ((label (next-label))
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)
270
(close-inline-blocks)
275
(defun set-jump-true (loc label)
278
((and (consp loc) (eq (car loc) 'INLINE-COND))
280
(wt-inline-loc (caddr loc) (cadddr loc))
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 "}")))
289
(defun set-jump-false (loc label)
292
((and (consp loc) (eq (car loc) 'INLINE-COND))
294
(wt-inline-loc (caddr loc) (cadddr loc))
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 "}")))
303
(defun c1ecase (args) (c1case args t))
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.
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))
315
(cmperror "T or otherwise found in an ecase"))
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"
325
`(block ,sym (si::switch ,(car args) ,@ (nreverse body)))))
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))
334
(cond ((subtypep (info-type (second key-form)) 'fixnum)
335
(return-from c1case (c1expr (convert-case-to-switch
337
(dolist (clause (cdr args))
338
(cmpck (endp clause) "The CASE clause ~S is illegal." clause)
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)))
349
(cond ((consp (car clause))
350
(mapcar #'(lambda (key) (if (symbolp key) key
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)))))
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 ";")
365
(dolist (clause clauses)
366
(let* ((label (next-label))
367
(keylist (car clause))
370
((<= (length keylist) 5))
371
(when (null local-label) (setq local-label (next-label)))
374
(cond ((symbolp (car keylist))
379
(otherwise (wt "VV[" (add-symbol (car keylist)) "]")))
381
(t (wt "eql(V" cvar ",VV[" (car keylist) "])")))
382
(when (< i 4) (wt-nl "|| "))
390
(cond ((symbolp (car keylist))
395
(otherwise (wt "VV[" (add-symbol (car keylist)) "]")))
397
(t (wt "!eql(V" cvar ",VV[" (car keylist) "])")))
398
(unless (endp (cdr keylist)) (wt-nl "&& "))
402
(when local-label (wt-label local-label))
403
(let ((*unwind-exit* (cons 'JUMP *unwind-exit*))) (c2expr (cdr clause)))
407
(progn (wt-nl "FEerror(\"The ECASE key value ~s is illegal.\",1,V" cvar ");")
408
(unwind-exit nil 'jump))
412
(close-inline-blocks))