/[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.3 by camm, Wed Jun 29 04:29:40 2005 UTC revision 1.4 by camm, Sat Jul 23 08:47:52 2005 UTC
# Line 1  Line 1 
1    ;; -*-Lisp-*-
2  ;;; CMPIF  Conditionals.  ;;; CMPIF  Conditionals.
3  ;;;  ;;;
4  ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa  ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
# Line 35  Line 36 
36  (si:putprop 'ecase 'c1ecase 'c1)  (si:putprop 'ecase 'c1ecase 'c1)
37  (si:putprop 'case 'c2case 'c2)  (si:putprop 'case 'c2case 'c2)
38    
39    (defun note-branch-elimination (test-form val elim-form)
40      (cmpnote "Test form ~S is ~S,~%;; eliminating branch ~S~%" test-form val elim-form))
41    
42  (defun c1if (args &aux info f)  (defun c1if (args &aux info f)
43    (when (or (endp args) (endp (cdr args)))    (when (or (endp args) (endp (cdr args)))
44          (too-few-args 'if 2 (length args)))          (too-few-args 'if 2 (length args)))
# Line 43  Line 47 
47    (setq f (c1fmla-constant (car args)))    (setq f (c1fmla-constant (car args)))
48    
49    (case f    (case f
50          ((t) (c1expr (cadr args)))          ((t)
51          ((nil) (if (endp (cddr args)) (c1nil) (c1expr (caddr args))))           (when (caddr args) (note-branch-elimination (car args) t (caddr args)))
52             (c1expr (cadr args)))
53            ((nil)
54             (note-branch-elimination (car args) nil (cadr args))
55            (if (endp (cddr args)) (c1nil) (c1expr (caddr args))))
56          (otherwise          (otherwise
57           (setq info (make-info))           (setq info (make-info))
58           (list 'if info           (let* ((*fmla-eval-const* t)
59                 (c1fmla f info)                  (fmla (c1fmla f info))
60                    (fmlae (fmla-eval-const fmla)))
61               (if *fmla-eval-const*
62                   (cond (fmlae
63                          (when (caddr args) (note-branch-elimination (car args) t (caddr args)))
64                          (c1expr (cadr args)))
65                         (t
66                           (note-branch-elimination (car args) nil (cadr args))
67                          (endp (cddr args)) (c1nil) (c1expr (caddr args))))
68                 (list 'if info
69                   fmla
70                 (c1expr* (cadr args) info)                 (c1expr* (cadr args) info)
71                 (if (endp (cddr args)) (c1nil) (c1expr* (caddr args) info)))))                 (if (endp (cddr args)) (c1nil) (c1expr* (caddr args) info))))))))
   )  
72    
73    (defvar *fmla-eval-const*)
74    (defun fmla-eval-const (fmla)
75      (case (car fmla)
76            (fmla-and (and (fmla-eval-const (cdr fmla)) (fmla-eval-const (cddr fmla))))
77            (fmla-or (or (fmla-eval-const (cdr fmla)) (fmla-eval-const (cddr fmla))))
78            (fmla-not (not (fmla-eval-const (cdr fmla))))
79            (location (caddr fmla))
80            ((t nil) (car fmla))
81            (otherwise (if (consp (car fmla))
82                           (fmla-eval-const (car fmla))
83                         (setq *fmla-eval-const* nil)))))
84                      
85  (defun c1fmla-constant (fmla &aux f)  (defun c1fmla-constant (fmla &aux f)
86    (cond    (cond
87     ((consp fmla)     ((consp fmla)

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

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