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 |
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))) |
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) |