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