← Back to branch summary

~ubuntu-branches/debian/squeeze/maxima/squeeze

« back to all changes in this revision

Viewing changes to src/trans5.lisp

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2006-10-18 14:52:42 UTC
  • mto: (1.1.5 upstream)
  • mto: This revision was merged to the branch mainline in revision 4.
  • Revision ID: james.westby@ubuntu.com-20061018145242-vzyrm5hmxr8kiosf
Import upstream version 5.10.0

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/trans5.lisp
8
8
;;;     (c) Copyright 1980 Massachusetts Institute of Technology         ;;;
9
9
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
10
10
 
11
 
(in-package "MAXIMA")
 
11
(in-package :maxima)
12
12
(macsyma-module trans5)
13
13
 
14
14
 
15
 
(TRANSL-MODULE TRANS5)
 
15
(transl-module trans5)
16
16
 
17
17
;;; these are TRANSLATE properies for the FSUBRS in JPG;COMM >
18
18
 
63
63
;;;
64
64
 
65
65
 
66
 
(DEF%TR $DISP (FORM) 
67
 
        `($ANY . (DISPLAY-FOR-TR ,(eq (caar form) '$ldisp)
68
 
                                 NIL ; equationsp
69
 
                                 ,@(TR-ARGS (CDR FORM)))))
70
 
(DEF-SAME%TR $LDISP $DISP)
71
 
 
72
 
(DEF%TR $DISPLAY (FORM) 
73
 
        `($ANY . (DISPLAY-FOR-TR ,(EQ (CAAR FORM) '$LDISPLAY)
74
 
                                 T
75
 
                                 ,@(MAPCAR #'TR-EXP-TO-DISPLAY (CDR FORM)))))
76
 
 
77
 
(DEF-SAME%TR $LDISPLAY $DISPLAY)
 
66
(def%tr $disp (form) 
 
67
  `($any . (display-for-tr ,(eq (caar form) '$ldisp)
 
68
            nil                         ; equationsp
 
69
            ,@(tr-args (cdr form)))))
 
70
(def-same%tr $ldisp $disp)
 
71
 
 
72
(def%tr $display (form) 
 
73
  `($any . (display-for-tr ,(eq (caar form) '$ldisplay)
 
74
            t
 
75
            ,@(mapcar #'tr-exp-to-display (cdr form)))))
 
76
 
 
77
(def-same%tr $ldisplay $display)
78
78
 
79
79
;;; DISPLAY(F(X,Y,FOO()))
80
80
;;; (F X Y (FOO)) => (LET ((&G1 (FOO))) (list '(mequal) (LIST '(F) X Y &G1)
99
99
;;; be evaluated first. I don't seriously expect anyone to find this
100
100
;;; bug.
101
101
 
102
 
(DEFVAR VALUE-ALIST NIL)
103
 
(DEFUN MAKE-VALUES (EXPR-ARGS)
104
 
       (MAPCAR #'(LAMBDA (ARG)
105
 
                         (COND ((OR (ATOM ARG)
106
 
                                    (MEMQ (CAR ARG) '(TRD-MSYMEVAL QUOTE)))
107
 
                                ARG)
108
 
                               (T
109
 
                                (LET ((SYM (GENSYM)))
110
 
                                     (PUSH (CONS ARG SYM) VALUE-ALIST)
111
 
                                     SYM))))
112
 
               EXPR-ARGS))
113
 
 
114
 
 
115
 
(EVAL-WHEN (COMPILE EVAL #-PDP10 LOAD)
116
 
#-cl
117
 
(DEFSTRUCT (DISP-HACK-OB #+Maclisp TREE #-Maclisp :TREE)
118
 
  LEFT-OB RIGHT-OB)
119
 
#+cl
120
 
(DEFSTRUCT (DISP-HACK-OB (:conc-name nil)( :type list ))  ;;it wanted tree but that's illegal
121
 
  LEFT-OB RIGHT-OB)
122
 
)
123
 
 
124
 
(DEFUN OBJECT-FOR-DISPLAY-HACK (EXP)
125
 
       (IF (ATOM EXP)
126
 
           (MAKE-DISP-HACK-OB
127
 
             #+cl :LEFT-OB #-cl LEFT-OB `',EXP
128
 
             #+cl :RIGHT-OB #-cl RIGHT-OB EXP)
129
 
           (CASE (CAR EXP)
130
 
                  (SIMPLIFY
131
 
                   (LET ((V (OBJECT-FOR-DISPLAY-HACK (CADR EXP))))
132
 
                        (MAKE-DISP-HACK-OB
133
 
                         #+cl :LEFT-OB #-cl LEFT-OB (LEFT-OB V)
134
 
                         #+cl :RIGHT-OB #-cl RIGHT-OB `(SIMPLIFY ,(RIGHT-OB V)))))
135
 
                  (MARRAYREF
136
 
                   (LET ((VALS (MAKE-VALUES (CDR EXP))))
137
 
                        (MAKE-DISP-HACK-OB
138
 
                         #+cl :LEFT-OB #-cl LEFT-OB `(LIST (LIST* ,(CAR VALS) '(ARRAY))
139
 
                                        ,@(CDR VALS))
140
 
                         #+cl :RIGHT-OB #-cl RIGHT-OB `(MARRAYREF ,@VALS))))
141
 
                  (MFUNCTION-CALL
142
 
                   ; assume evaluation of arguments.
143
 
                   (LET ((VALS (MAKE-VALUES (CDDR EXP))))
144
 
                        (MAKE-DISP-HACK-OB
145
 
                         #+cl :LEFT-OB #-cl LEFT-OB `(LIST '(,(CADR EXP)) ,@VALS)
146
 
                         #+cl :RIGHT-OB #-cl RIGHT-OB `(MFUNCTION-CALL ,(CADR EXP) ,@VALS))))
147
 
                  (LIST
148
 
                   (LET ((OBS (MAPCAR #'OBJECT-FOR-DISPLAY-HACK (CDR EXP))))
149
 
                        (MAKE-DISP-HACK-OB
150
 
                         #+cl :LEFT-OB #-cl LEFT-OB `(LIST ,@(MAPCAR #'(LAMBDA (U) (LEFT-OB U))
151
 
                                                  OBS))
152
 
                         #+cl :RIGHT-OB #-cl RIGHT-OB `(LIST ,@(MAPCAR #'(LAMBDA (U) (RIGHT-OB U))
153
 
                                                   OBS)))))
154
 
                  (QUOTE (MAKE-DISP-HACK-OB
155
 
                           #+cl :LEFT-OB #-cl LEFT-OB EXP
156
 
                           #+cl :RIGHT-OB #-cl RIGHT-OB EXP))
157
 
                  (TRD-MSYMEVAL
158
 
                   (MAKE-DISP-HACK-OB
159
 
                     #+cl :LEFT-OB #-cl LEFT-OB `',(CADR EXP)
160
 
                     #+cl :RIGHT-OB #-cl RIGHT-OB EXP))
161
 
                 (T
162
 
                   (COND ((OR (NOT (ATOM (CAR EXP)))
163
 
                              (GETL (CAR EXP) '(FSUBR FEXPR MACRO)))
164
 
                          (MAKE-DISP-HACK-OB
165
 
                            #+cl :LEFT-OB #-cl LEFT-OB `',EXP
166
 
                            #+cl :RIGHT-OB #-cl RIGHT-OB EXP))
167
 
                         (T
168
 
                          (LET ((VALS (MAKE-VALUES (CDR EXP))))
169
 
                               (MAKE-DISP-HACK-OB
170
 
                                #+cl :LEFT-OB #-cl LEFT-OB `(LIST '(,(UNTRANS-OP (CAR EXP)))
171
 
                                               ,@VALS)
172
 
                                #+cl :RIGHT-OB #-cl RIGHT-OB `(,(CAR EXP) ,@VALS)))))))))
173
 
 
174
 
(DEFUN TR-EXP-TO-DISPLAY (EXP)
175
 
       (LET* ((LISP-EXP (DTRANSLATE EXP))
176
 
              (VALUE-ALIST NIL)
177
 
              (OB (OBJECT-FOR-DISPLAY-HACK LISP-EXP))
178
 
              (DISP `(LIST '(MEQUAL) ,(LEFT-OB OB) ,(RIGHT-OB OB))))
179
 
             (SETQ VALUE-ALIST (NREVERSE VALUE-ALIST))
180
 
             (IF VALUE-ALIST
181
 
                 `((LAMBDA ,(MAPCAR #'CDR VALUE-ALIST) ,DISP)
182
 
                   ,@(MAPCAR #'CAR VALUE-ALIST))
183
 
                 DISP)))
184
 
 
185
 
(DEFUN UNTRANS-OP (OP)
186
 
       (OR (CDR (ASSQ OP '((ADD* . MPLUS)
187
 
                           (SUB* . MMINUS)
188
 
                           (MUL* . MTIMES)
189
 
                           (DIV* . MQUOTIENT)
190
 
                           (POWER* . MEXPT))))
191
 
           OP))
 
102
(defvar value-alist nil)
 
103
(defun make-values (expr-args)
 
104
  (mapcar #'(lambda (arg)
 
105
              (cond ((or (atom arg)
 
106
                         (memq (car arg) '(trd-msymeval quote)))
 
107
                     arg)
 
108
                    (t
 
109
                     (let ((sym (gensym)))
 
110
                       (push (cons arg sym) value-alist)
 
111
                       sym))))
 
112
          expr-args))
 
113
 
 
114
 
 
115
(eval-when (compile eval #-pdp10 load)
 
116
  #-cl
 
117
  (defstruct (disp-hack-ob #+maclisp tree #-maclisp :tree)
 
118
    left-ob right-ob)
 
119
  #+cl
 
120
  (defstruct (disp-hack-ob (:conc-name nil)( :type list )) ;;it wanted tree but that's illegal
 
121
    left-ob right-ob)
 
122
  )
 
123
 
 
124
(defun object-for-display-hack (exp)
 
125
  (if (atom exp)
 
126
      (make-disp-hack-ob
 
127
       #+cl :left-ob #-cl left-ob `',exp
 
128
       #+cl :right-ob #-cl right-ob exp)
 
129
      (case (car exp)
 
130
        (simplify
 
131
         (let ((v (object-for-display-hack (cadr exp))))
 
132
           (make-disp-hack-ob
 
133
            #+cl :left-ob #-cl left-ob (left-ob v)
 
134
            #+cl :right-ob #-cl right-ob `(simplify ,(right-ob v)))))
 
135
        (marrayref
 
136
         (let ((vals (make-values (cdr exp))))
 
137
           (make-disp-hack-ob
 
138
            #+cl :left-ob #-cl left-ob `(list (list* ,(car vals) '(array))
 
139
                                         ,@(cdr vals))
 
140
            #+cl :right-ob #-cl right-ob `(marrayref ,@vals))))
 
141
        (mfunction-call
 
142
                                        ; assume evaluation of arguments.
 
143
         (let ((vals (make-values (cddr exp))))
 
144
           (make-disp-hack-ob
 
145
            #+cl :left-ob #-cl left-ob `(list '(,(cadr exp)) ,@vals)
 
146
            #+cl :right-ob #-cl right-ob `(mfunction-call ,(cadr exp) ,@vals))))
 
147
        (list
 
148
         (let ((obs (mapcar #'object-for-display-hack (cdr exp))))
 
149
           (make-disp-hack-ob
 
150
            #+cl :left-ob #-cl left-ob `(list ,@(mapcar #'(lambda (u) (left-ob u))
 
151
                                                        obs))
 
152
            #+cl :right-ob #-cl right-ob `(list ,@(mapcar #'(lambda (u) (right-ob u))
 
153
                                                          obs)))))
 
154
        (quote (make-disp-hack-ob
 
155
                #+cl :left-ob #-cl left-ob exp
 
156
                #+cl :right-ob #-cl right-ob exp))
 
157
        (trd-msymeval
 
158
         (make-disp-hack-ob
 
159
          #+cl :left-ob #-cl left-ob `',(cadr exp)
 
160
          #+cl :right-ob #-cl right-ob exp))
 
161
        (t
 
162
         (cond ((or (not (atom (car exp)))
 
163
                    (getl (car exp) '(fsubr fexpr macro)))
 
164
                (make-disp-hack-ob
 
165
                 #+cl :left-ob #-cl left-ob `',exp
 
166
                 #+cl :right-ob #-cl right-ob exp))
 
167
               (t
 
168
                (let ((vals (make-values (cdr exp))))
 
169
                  (make-disp-hack-ob
 
170
                   #+cl :left-ob #-cl left-ob `(list '(,(untrans-op (car exp)))
 
171
                                                ,@vals)
 
172
                   #+cl :right-ob #-cl right-ob `(,(car exp) ,@vals)))))))))
 
173
 
 
174
(defun tr-exp-to-display (exp)
 
175
  (let* ((lisp-exp (dtranslate exp))
 
176
         (value-alist nil)
 
177
         (ob (object-for-display-hack lisp-exp))
 
178
         (disp `(list '(mequal) ,(left-ob ob) ,(right-ob ob))))
 
179
    (setq value-alist (nreverse value-alist))
 
180
    (if value-alist
 
181
        `((lambda ,(mapcar #'cdr value-alist) ,disp)
 
182
          ,@(mapcar #'car value-alist))
 
183
        disp)))
 
184
 
 
185
(defun untrans-op (op)
 
186
  (or (cdr (assq op '((add* . mplus)
 
187
                      (sub* . mminus)
 
188
                      (mul* . mtimes)
 
189
                      (div* . mquotient)
 
190
                      (power* . mexpt))))
 
191
      op))
192
192
 
193
193
 
194
194
;;; From RZ;COMBIN >
208
208
;;;       (let (($listarith nil))
209
209
;;;         (cfeval (meval (car a)))))
210
210
 
211
 
(DEF%TR $CF (FORM)
212
 
        (SETQ FORM (CAR (TR-ARGS (CDR FORM))))
213
 
        (PUSH-AUTOLOAD-DEF '$CF '(CFEVAL))
214
 
        `($ANY . ((LAMBDA (DIVOV $LISTARITH)
215
 
                          (SSTATUS DIVOV T)
216
 
                          (UNWIND-PROTECT (CFEVAL ,FORM)
217
 
                                          (SSTATUS DIVOV DIVOV)))
218
 
                  (STATUS DIVOV)
219
 
                  NIL)))
 
211
(def%tr $cf (form)
 
212
  (setq form (car (tr-args (cdr form))))
 
213
  (push-autoload-def '$cf '(cfeval))
 
214
  `($any . ((lambda (divov $listarith)
 
215
              (sstatus divov t)
 
216
              (unwind-protect (cfeval ,form)
 
217
                (sstatus divov divov)))
 
218
            (status divov)
 
219
            nil)))
220
220
 
221
221
;;; from RZ;TRGRED >
222
222
;;;
227
227
;;;          ( '*NOVAR ))
228
228
;;;     T NIL NIL NIL))
229
229
 
230
 
; JPG made this an LSUBR now! win win win good old Jeff.
231
 
;(DEF%TR $TRIGREDUCE (FORM)
232
 
;       (LET ((ARG1 (DTRANSLATE (CADR FORM)))
233
 
;             (ARG2 (COND ((CDDR FORM) (DTRANSLATE (CADDR FORM)))
234
 
;                         (T ''*NOVAR))))
235
 
;            `($ANY . #%(LET ((*TRIGRED T)
236
 
;                             (VAR ,ARG2)
237
 
;                             (*NOEXPAND T)
238
 
;                             ($TRIGEXPAND NIL)
239
 
;                             ($VERBOSE NIL)
240
 
;                             ($RATPRINT NIL))
241
 
;                            ; gross hack, please fix me quick gjc!!!!
242
 
;                            (OR (SYMBOL-PLIST 'GCDRED) (LOAD (GET '$TRIGREDUCE 'AUTOLOAD)))
243
 
;                            (GCDRED (SP1 ,ARG1))))))
 
230
;; JPG made this an LSUBR now! win win win good old Jeff.
 
231
;;(DEF%TR $TRIGREDUCE (FORM)
 
232
;;      (LET ((ARG1 (DTRANSLATE (CADR FORM)))
 
233
;;            (ARG2 (COND ((CDDR FORM) (DTRANSLATE (CADDR FORM)))
 
234
;;                        (T ''*NOVAR))))
 
235
;;           `($ANY . #%(LET ((*TRIGRED T)
 
236
;;                            (VAR ,ARG2)
 
237
;;                            (*NOEXPAND T)
 
238
;;                            ($TRIGEXPAND NIL)
 
239
;;                            ($VERBOSE NIL)
 
240
;;                            ($RATPRINT NIL))
 
241
;;                           ; gross hack, please fix me quick gjc!!!!
 
242
;;                           (OR (SYMBOL-PLIST 'GCDRED) (LOAD (GET '$TRIGREDUCE 'AUTOLOAD)))
 
243
;;                           (GCDRED (SP1 ,ARG1))))))
244
244
 
245
245
;;; From MATRUN
246
246
;;; (DEFUN $APPLY1 FEXPR (L)
251
251
;;;                (CDR L))
252
252
;;;          (RETURN *EXPR)))
253
253
 
254
 
(DEF%TR $APPLY1 (FORM &AUX
255
 
                      (EXPR (TR-GENSYM))
256
 
                      (RULES (TR-GENSYM)))
257
 
        (PUSH-AUTOLOAD-DEF '$APPLY1 '(APPLY1))
 
254
(def%tr $apply1 (form &aux
 
255
                      (expr (tr-gensym))
 
256
                      (rules (tr-gensym)))
 
257
  (push-autoload-def '$apply1 '(apply1))
258
258
                      
259
 
        `($ANY  . (DO ((,EXPR ,(DTRANSLATE (CADR FORM))
260
 
                               (APPLY1 ,EXPR (CAR ,RULES) 0))
261
 
                       (,RULES ',(CDDR FORM) (CDR ,RULES)))
262
 
                      ((NULL ,RULES) ,EXPR))))
 
259
  `($any  . (do ((,expr ,(dtranslate (cadr form))
 
260
                        (apply1 ,expr (car ,rules) 0))
 
261
                 (,rules ',(cddr form) (cdr ,rules)))
 
262
                ((null ,rules) ,expr))))
263
263
 
264
264
;;; This code was written before they had formatting of lisp code invented.
265
265
;;;(DEFUN $APPLY2 FEXPR (L)(PROG (*RULELIST)
266
266
;;;(SETQ *RULELIST (CDR L))
267
267
;;;(RETURN (APPLY2 (MEVAL (CAR L)) 0))))
268
268
 
269
 
(DEF%TR $APPLY2 (FORM)
270
 
        `($ANY . ((LAMBDA (*RULELIST)
271
 
                          (DECLARE (SPECIAL *RULELIST))
272
 
                          (APPLY2 ,(DTRANSLATE (CADR FORM)) 0))
273
 
                  ',(CDDR FORM))))
 
269
(def%tr $apply2 (form)
 
270
  `($any . ((lambda (*rulelist)
 
271
              (declare (special *rulelist))
 
272
              (apply2 ,(dtranslate (cadr form)) 0))
 
273
            ',(cddr form))))
274
274
 
275
275
;;;(DEFUN $APPLYB1 FEXPR (L) 
276
276
;;;      (PROG (*EXPR) 
282
282
;;;                  (CDR L))
283
283
;;;            (RETURN *EXPR )))
284
284
 
285
 
(DEF%TR $APPLYB1 (FORM &AUX (EXPR (TR-GENSYM)) (RULES (TR-GENSYM)))
286
 
        (PUSH-AUTOLOAD-DEF '$APPLYB1 '(APPLY1HACK))
287
 
        `($ANY . (DO ((,EXPR ,(DTRANSLATE (CADR FORM))
288
 
                             (CAR (APPLY1HACK ,EXPR (CAR ,RULES))))
289
 
                      (,RULES ',(CDDR FORM) (CDR ,RULES)))
290
 
                     ((NULL ,RULES) ,EXPR))))
 
285
(def%tr $applyb1 (form &aux (expr (tr-gensym)) (rules (tr-gensym)))
 
286
  (push-autoload-def '$applyb1 '(apply1hack))
 
287
  `($any . (do ((,expr ,(dtranslate (cadr form))
 
288
                       (car (apply1hack ,expr (car ,rules))))
 
289
                (,rules ',(cddr form) (cdr ,rules)))
 
290
               ((null ,rules) ,expr))))
291
291
 
292
292
;;;(DEFUN $APPLYB2 FEXPR (L)(PROG (*RULELIST)
293
293
;;;(SETQ *RULELIST (CDR L))
294
294
;;;(RETURN(CAR (APPLY2HACK (MEVAL (CAR L)))))))
295
295
 
296
 
(DEF%TR $APPLYB2 (FORM)
297
 
        (PUSH-AUTOLOAD-DEF '$APPLYB2 '(APPLY2HACK))
298
 
        `($ANY . ((LAMBDA (*RULELIST)
299
 
                          (DECLARE (SPECIAL *RULELIST))
300
 
                          (APPLY2HACK ,(DTRANSLATE (CADR FORM))))
301
 
                  ',(CDDR FORM))))
 
296
(def%tr $applyb2 (form)
 
297
  (push-autoload-def '$applyb2 '(apply2hack))
 
298
  `($any . ((lambda (*rulelist)
 
299
              (declare (special *rulelist))
 
300
              (apply2hack ,(dtranslate (cadr form))))
 
301
            ',(cddr form))))
302
302
 
303
303
 
304
304
 
307
307
;;; write the translation property for his own special form!
308
308
 
309
309
 
310
 
(DEF%TR $BUILDQ (FORM)
 
310
(def%tr $buildq (form)
311
311
 
312
 
 (LET ((ALIST                               ;would be nice to output
313
 
        (MAPCAR                             ;backquote instead of list/cons
314
 
          #'(LAMBDA (VAR)                   ;but I'm not sure if things get
315
 
             (COND ((ATOM VAR)              ;macroexpanded.  -REH
316
 
                                            ; Well, any macros are o.k. They
317
 
                                            ; get expanded "at the right time". -gjc
 
312
  (let ((alist                          ;would be nice to output
 
313
         (mapcar                       ;backquote instead of list/cons
 
314
          #'(lambda (var)              ;but I'm not sure if things get
 
315
              (cond ((atom var)         ;macroexpanded.  -REH
 
316
                                        ; Well, any macros are o.k. They
 
317
                                        ; get expanded "at the right time". -gjc
318
318
                    
319
 
                    `(CONS ',VAR ,(DTRANSLATE VAR)))
320
 
                   ((EQ (CAAR VAR) 'MSETQ)
321
 
                    `(CONS ',(CADR VAR) ,(DTRANSLATE (CADDR VAR))))
322
 
                   (T (SETQ TR-ABORT T)
323
 
                      (TR-TELL VAR
324
 
                            "Illegal BUILDQ form encountered during translation"))))
325
 
                       ;right thing to do here??
326
 
                       ;how much error checking does transl do now?
327
 
                       ; Yes. Not as much as it should! -GJC
 
319
                     `(cons ',var ,(dtranslate var)))
 
320
                    ((eq (caar var) 'msetq)
 
321
                     `(cons ',(cadr var) ,(dtranslate (caddr var))))
 
322
                    (t (setq tr-abort t)
 
323
                       (tr-tell var
 
324
                                "Illegal `buildq' form encountered during translation"))))
 
325
                                        ;right thing to do here??
 
326
                                        ;how much error checking does transl do now?
 
327
                                        ; Yes. Not as much as it should! -GJC
328
328
          
329
 
         (CDR (CADR FORM)))))
330
 
      (COND ((NULL ALIST) 
331
 
               `($ANY QUOTE ,(CADDR FORM)))
332
 
            (T `($ANY MBUILDQ-SUBST (LIST ,@ALIST) ',(CADDR FORM))))))
 
329
          (cdr (cadr form)))))
 
330
    (cond ((null alist) 
 
331
           `($any quote ,(caddr form)))
 
332
          (t `($any mbuildq-subst (list ,@alist) ',(caddr form))))))
333
333
 
334
334
 
335
335
;;; Presently STATUS and SSTATUS are FEXPR which don't evaluate 
337
337
 
338
338
#-cl
339
339
(def%tr $sstatus (form)
340
 
        `($any . ($sstatus . ,(cdr form))))
 
340
  `($any . ($sstatus . ,(cdr form))))
341
341
 
342
342
#-cl
343
343
(def%tr $status (form)
344
 
        (setq form (cdr form))
345
 
        (cond ((null form) ; %%%PLEASE FIX ME%%% with WNA-CHECKING %%%%%%
346
 
               nil)
347
 
              (t
348
 
               (case (car form)
349
 
                      ($FEATURE
350
 
                       (cond ((null (cdr form))
351
 
                              `($any . ($status $feature)))
352
 
                             ; this BOOLEAN check is important, since
353
 
                             ; STATUS(FEATURE,FOO) will always be used in a
354
 
                             ; BOOLEAN context.
355
 
                             (t `($BOOLEAN . ($STATUS $FEATURE ,(CADR FORM))))))
356
 
                      (T `($ANY . ($STATUS . ,FORM)))))))
 
344
  (setq form (cdr form))
 
345
  (cond ((null form)    ; %%%PLEASE FIX ME%%% with WNA-CHECKING %%%%%%
 
346
         nil)
 
347
        (t
 
348
         (case (car form)
 
349
           ($feature
 
350
            (cond ((null (cdr form))
 
351
                   `($any . ($status $feature)))
 
352
                                        ; this BOOLEAN check is important, since
 
353
                                        ; STATUS(FEATURE,FOO) will always be used in a
 
354
                                        ; BOOLEAN context.
 
355
                  (t `($boolean . ($status $feature ,(cadr form))))))
 
356
           (t `($any . ($status . ,form)))))))
357
357