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

Diff of /gcl/cmpnew/gcl_cmpfun.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.19 by camm, Thu Oct 6 20:30:06 2005 UTC revision 1.20 by camm, Mon Nov 14 04:45:18 2005 UTC
# Line 405  Line 405 
405    
406    
407    
408    ;;FIXME rewrite elim mv
409  (defun list-tp-test (tf lt)  (defun list-tp-test (tf lt &optional ic &aux aet)
410    (cond ((atom lt) (let ((z (funcall tf lt))) (values z z)))    (cond
411          ((eq (car lt) 'cons)     ((setq aet (aref-propagator 'list-tp-test lt))
412           (multiple-value-bind       (let ((z (funcall tf aet))) (values z z)));;FIXME second value meaning
413            (m1 f1) (funcall tf (cadr lt))     ((or (atom lt) (not (eq (car lt) 'cons)))
414            (multiple-value-bind      (let ((z (and ic (funcall tf lt)))) (values z z)))
415             (m2 f2) (list-tp-test tf (caddr lt))     (t
416             (values (and m1 m2) (or f1 f2)))))      (unless (caddr lt) (return-from list-tp-test (values nil t)))
417          ((list-tp-test tf (car lt)))))      (multiple-value-bind
418  ;       (t (values nil nil))))       (m1 f1) (funcall tf (cadr lt))
419         (multiple-value-bind
420          (m2 f2) (list-tp-test tf (caddr lt) t)
421          (values (and m1 m2) (or f1 f2)))))))
422                                            ;       ((and ic (list-tp-test tf (car lt))))))
423                                            ;       (t (values nil nil))))
424    
425  (defun test-to-tf (test)  (defun test-to-tf (test)
426    (let ((test (if (constantp test) (cmp-eval test) test)))    (let ((test (if (constantp test) (cmp-eval test) test)))
# Line 1088  Line 1093 
1093  (defun c1list (args)  (defun c1list (args)
1094    (let* ((info (make-info))    (let* ((info (make-info))
1095          (nargs (c1args args info)))          (nargs (c1args args info)))
1096      (setf (info-type info) (nil-to-t (reduce (lambda (x y) (list 'cons (info-type (cadr x)) y)) (append nargs '(null)) :from-end t)))      (setf (info-type info)
1097              (cmp-norm-tp
1098               (nil-to-t
1099                (reduce (lambda (x y) (list 'cons (info-type (cadr x)) y)) (append nargs '(null)) :from-end t))))
1100      (list 'call-global info 'list nargs)));      (list 'call-global info 'list nargs)));
1101  (si::putprop 'list 'c1list 'c1)  (si::putprop 'list 'c1list 'c1)
1102                

Legend:
Removed from v.1.19  
changed lines
  Added in v.1.20

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