1 |
|
;; -*-Lisp-*- |
2 |
;; CMPFUN Library functions. |
;; CMPFUN Library functions. |
3 |
;;; |
;;; |
4 |
;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa |
;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa |
36 |
(si:putprop 'rplacd 'c1rplacd 'c1) |
(si:putprop 'rplacd 'c1rplacd 'c1) |
37 |
(si:putprop 'rplacd 'c2rplacd 'c2) |
(si:putprop 'rplacd 'c2rplacd 'c2) |
38 |
|
|
39 |
(si:putprop 'si::memq 'c1memq 'c1) |
;(dolist (l '(si::memq |
40 |
(si:putprop 'member 'c1member 'c1) |
; member member-i member-if-not |
41 |
(si:putprop 'member!2 'c2member!2 'c2) |
; assoc assoc-i assoc-if-not |
42 |
(si:putprop 'assoc 'c1assoc 'c1) |
; rassoc rassoc-i rassoc-if-not |
43 |
(si:putprop 'rassoc 'c1rassoc 'c1) |
; intersection set-difference set-exclusive-or subsetp union)) |
44 |
(si:putprop 'assoc!2 'c2assoc!2 'c2) |
; (si::putprop l (intern (concatenate 'string "C1" (symbol-name l))) 'c1)) |
45 |
|
|
46 |
|
;(si:putprop 'si::memq 'c1memq 'c1) |
47 |
|
;(si:putprop 'member 'c1member 'c1) |
48 |
|
;(si:putprop 'member-if 'c1member-if 'c1) |
49 |
|
;(si:putprop 'member-if-not 'c1member-if-not 'c1) |
50 |
|
;(si:putprop 'member!2 'c2member!2 'c2) |
51 |
|
;(si:putprop 'assoc 'c1assoc 'c1) |
52 |
|
;(si:putprop 'rassoc 'c1rassoc 'c1) |
53 |
|
;(si:putprop 'set-difference 'c1set-difference 'c1) |
54 |
|
;(si:putprop 'assoc!2 'c2assoc!2 'c2) |
55 |
|
|
56 |
|
|
57 |
(si:putprop 'get 'c1get 'c1) |
(si:putprop 'get 'c1get 'c1) |
58 |
(si:putprop 'get 'c2get 'c2) |
(si:putprop 'get 'c2get 'c2) |
59 |
|
|
64 |
(si:putprop 'list-nth-immediate 'c2list-nth-immediate 'c2) |
(si:putprop 'list-nth-immediate 'c2list-nth-immediate 'c2) |
65 |
|
|
66 |
(defvar *princ-string-limit* 80) |
(defvar *princ-string-limit* 80) |
67 |
|
(defvar *type-alist* |
68 |
|
'((fixnum . si::fixnump) |
69 |
|
(float . floatp) |
70 |
|
(short-float . short-float-p) |
71 |
|
(long-float . long-float-p) |
72 |
|
(integer . integerp) |
73 |
|
(character . characterp) |
74 |
|
(symbol . symbolp) |
75 |
|
(cons . consp) |
76 |
|
(null . null) |
77 |
|
(array . arrayp) |
78 |
|
(vector . vectorp) |
79 |
|
(bit-vector . bit-vector-p) |
80 |
|
(string . stringp) |
81 |
|
(list . listp) |
82 |
|
(number . numberp) |
83 |
|
(rational . rationalp) |
84 |
|
(complex . complexp) |
85 |
|
(ratio . ratiop) |
86 |
|
(sequence . (lambda (y) (or (listp y) (vectorp y)))) |
87 |
|
(function . functionp) |
88 |
|
)) |
89 |
|
|
90 |
(defun c1princ (args &aux stream (info (make-info))) |
(defun c1princ (args &aux stream (info (make-info))) |
91 |
(when (endp args) (too-few-args 'princ 1 0)) |
(when (endp args) (too-few-args 'princ 1 0)) |
265 |
|
|
266 |
(defun c1funcall (args &aux funob (info (make-info))) |
(defun c1funcall (args &aux funob (info (make-info))) |
267 |
(when (endp args) (too-few-args 'funcall 1 0)) |
(when (endp args) (too-few-args 'funcall 1 0)) |
268 |
(setq funob (c1funob (car args))) |
(cond ((and (consp (car args)) (eq (caar args) 'lambda)) |
269 |
(add-info info (cadr funob)) |
(c1lambda-fun (cdar args) (cdr args))) |
270 |
(list 'funcall info funob (c1args (cdr args) info)) |
((and (consp (car args)) (eq (caar args) 'function) (symbolp (cadar args)) (not (cddar args))) |
271 |
) |
(c1expr `(,(cadar args) ,@(cdr args)))) |
272 |
|
((constantp (car args)) |
273 |
|
(c1expr `(,(cmp-eval (car args)) ,@(cdr args)))) |
274 |
|
((progn |
275 |
|
(setq funob (c1funob (car args))) |
276 |
|
(add-info info (cadr funob)) |
277 |
|
(list 'funcall info funob (c1args (cdr args) info)))))) |
278 |
|
|
279 |
(defun c1rplaca (args &aux (info (make-info))) |
(defun c1rplaca (args &aux (info (make-info))) |
280 |
(when (or (endp args) (endp (cdr args))) |
(when (or (endp args) (endp (cdr args))) |
317 |
(defconstant +ifr+ (ash (- +ifb+) -1)) |
(defconstant +ifr+ (ash (- +ifb+) -1)) |
318 |
(defconstant +ift+ '(integer #.(- +ifr+) #.(1- +ifr+))) |
(defconstant +ift+ '(integer #.(- +ifr+) #.(1- +ifr+))) |
319 |
|
|
320 |
|
;;FIXME the right way to do these is by defining compound types and |
321 |
|
;;using typep and subtypep -- alas these choke on these types of forms |
322 |
|
;;at the moment. 20050704 CM |
323 |
|
|
324 |
(defun eql-is-eq (x) |
(defun eql-is-eq (x) |
325 |
(cond ((typep x '#.+ift+)) |
(cond ((typep x '#.+ift+)) |
326 |
((or (typep x 'number) (typep x 'character)) nil) |
((member-if (lambda (y) (typep x y)) '(number character)) nil) |
327 |
(t))) |
(t))) |
328 |
|
|
329 |
(defun eql-is-eq-tp (x) |
(defun eql-is-eq-tp (x) |
330 |
(cond ((subtypep x +ift+)) |
(cond ((subtypep x +ift+) (values t t)) |
331 |
((or (subtypep x 'number) (subtypep x 'character)) nil) |
((subtypep +ift+ x) (values nil nil)) |
332 |
((or (subtypep 'number x) (subtypep 'character x)) nil) |
((member-if (lambda (y) (subtypep x y)) '(number character)) (values nil t)) |
333 |
(t))) |
(t (values t t)))) |
334 |
|
|
335 |
(defun implicit-eq-tst (item list) |
(defun equal-is-eq (x) |
336 |
(cond ((and (constantp item) (eql-is-eq item))) |
(cond ((member-if (lambda (y) (typep x y)) '(cons string bit-vector pathname)) nil) |
337 |
((and (constantp list) (consp list) (consp (cadr list)) |
((eql-is-eq x)))) |
338 |
(reduce (lambda (x y) (and (eql-is-eq x) y)) (cadr list)))) |
|
339 |
((let* ((info (make-info)) |
(defun equal-is-eq-tp (x) |
340 |
(nargs (c1args (list item list) info))) |
(cond ((member-if (lambda (y) (subtypep x y)) '(cons string bit-vector pathname)) (values nil t)) |
341 |
(eql-is-eq-tp (info-type (cadar nargs))))))) |
(t (eql-is-eq-tp x)))) |
342 |
|
|
343 |
(defun lit-fun (x &rest r) |
(defun equalp-is-eq (x) |
344 |
(cond ((atom x) `(funcall ,x ,@r)) |
(cond ((member-if (lambda (y) (typep x y)) '(array hash-table structure number)) nil) |
345 |
((member (car x) '(quote function)) `(,(cadr x) ,@r)) |
((equal-is-eq x)))) |
346 |
((eq (car x) 'lambda) `(,x ,@r)) |
|
347 |
((wfs-error)))) |
(defun equalp-is-eq-tp (x) |
348 |
|
(cond ((member-if (lambda (y) (subtypep x y)) '(array hash-table structure number)) (values nil t)) |
349 |
(defun do-list-srch (item list tst key k1 ret) |
(t (equal-is-eq-tp x)))) |
350 |
(let* ((key-form `(,k1 ,list)) |
|
351 |
(key-form (if key (lit-fun key key-form) key-form)) |
(defun do-eq-et-al (fn args) |
352 |
(tst-form (lit-fun tst item key-form)) |
(let* ((tf (cadr (test-to-tf fn))) |
353 |
(tst-form (if ret `(and (,ret ,list) ,tst-form) tst-form)) |
(info (make-info)) |
354 |
(exit-form `(or (not ,list) ,tst-form)) |
(nargs (c1args args info))) |
355 |
(ret-form (if ret `(,ret ,list) list))) |
(cond ((and tf |
356 |
`(do ((,list ,list (cdr ,list))) |
(or (funcall tf (info-type (cadar nargs))) |
357 |
(,exit-form ,ret-form)))) |
(funcall tf (info-type (cadadr nargs))))) |
358 |
|
(list 'call-global info 'eq nargs)) |
359 |
(defun fun-to-sym (x) |
((list 'call-global info fn nargs))))) |
360 |
(if (and (consp x) (or (eq (car x) 'quote) (eq (car x) 'function))) |
|
361 |
(cadr x) |
(dolist (l `(eq eql equal equalp)) |
362 |
x)) |
(si::putprop l 'do-eq-et-al 'c1g)) |
363 |
|
|
364 |
(defun do-list-srch-eql (item list tst key k1 ret) |
(defun num-type-bounds (t1) |
365 |
(let ((ei (gensym)) (el (gensym))) |
(let ((t1 (si::normalize-type t1)) |
366 |
`(let ((,ei ,item) (,el ,list)) |
(i 1) j) |
367 |
,(if (eq (fun-to-sym tst) 'eql) |
(mapcar (lambda (x) |
368 |
`(if (eql-is-eq ,ei) |
(setq j i i (- i) |
369 |
,(do-list-srch ei el ''eq key k1 ret) |
x (cond ((atom x) x) |
370 |
,(do-list-srch ei el tst key k1 ret)) |
((and (eq (car t1) 'integer) (integerp (car x))) (+ (car x) j)) |
371 |
(do-list-srch ei el tst key k1 ret))))) |
((car x))))) (cdr t1)))) |
372 |
|
|
373 |
(defun list-expr (item list &key key test test-not k1 ret) |
|
374 |
(when (and test test-not) |
(defun num-type-rel (fn t1 t2 &optional s) |
375 |
(error ":test and :test-not both specified")) |
(let ((nop (car (rassoc fn '((>= . <) (> . <=) (= . /=))))) |
376 |
(let ((test (or test |
(rfn (cdr (assoc fn '((>= . >) (> . >=)))))) |
377 |
(and test-not `(lambda (x y) (not ,(lit-fun test-not 'x 'y)))) |
(cond (nop (let ((q (num-type-rel nop t1 t2))) |
378 |
(if (implicit-eq-tst item list) ''eq ''eql)))) |
(list (and (not (car q)) (cadr q)) (cadr q)))) |
379 |
(c1expr (do-list-srch-eql item list test key k1 ret)))) |
((eq fn '=) (mapcar (lambda (x y) (and x y)) (num-type-rel '>= t1 t2) (num-type-rel '>= t2 t1))) |
380 |
|
((not s) (let ((f (num-type-rel fn t1 t2 t))) |
381 |
(defmacro with-item-list-keys ((item list keys) args &body body) |
(list f (or f (num-type-rel rfn t2 t1 t))))) |
382 |
`(let ((,item (car ,args)) (,list (cadr ,args)) (,keys (cddr ,args))) |
((let ((t1 (car (num-type-bounds t1))) |
383 |
(when (or (endp ,args) (endp (cdr ,args))) |
(t2 (cadr (num-type-bounds t2)))) |
384 |
(too-few-args 'list-expr 2 (length ,args))) |
(and (numberp t1) (numberp t2) (funcall fn t1 t2))))))) |
385 |
,@body)) |
|
386 |
|
|
387 |
(defun c1assoc (args) |
(defun do-num-relations (fn args) |
388 |
(with-item-list-keys |
(let* ((info (make-info)) |
389 |
(item list keys) args |
(nargs (c1args args info)) |
390 |
(apply 'list-expr item list :k1 'caar :ret 'car keys))) |
(t1 (and (cddr args) (info-type (cadar nargs)))) |
391 |
(defun c1rassoc (args) |
(t2 (and (cddr args) (info-type (cadadr nargs)))) |
392 |
(with-item-list-keys |
(r (and t1 t2 (num-type-rel fn t1 t2)))) |
393 |
(item list keys) args |
(cond ((cddr args) (list 'call-global info fn nargs)) |
394 |
(apply 'list-expr item list :k1 'cdar :ret 'car keys))) |
((car r) (c1expr t)) |
395 |
(defun c1member (args) |
((cadr r) (c1expr nil)) |
396 |
(with-item-list-keys |
((list 'call-global info fn nargs))))) |
397 |
(item list keys) args |
|
398 |
(apply 'list-expr item list :k1 'car keys))) |
(dolist (l `(>= > < <= = /=)) |
399 |
(defun c1memq (args) |
(si::putprop l 'do-num-relations 'c1g)) |
400 |
(with-item-list-keys |
|
401 |
(item list keys) args |
(dolist (l `(eq eql equal equalp > >= < <= = /= |
402 |
(apply 'list-expr item list :k1 'car :test ''eq keys))) |
,@(mapcar (lambda (x) (cdr x)) (remove-if-not (lambda (x) (symbolp (cdr x))) *type-alist*)))) |
403 |
|
(si::putprop l t 'c1no-side-effects)) |
404 |
;;FIXME member-if member-if-not et.al by ;test -> :test-not |
|
405 |
|
;;bound type comparisons |
406 |
|
;; only boolean eval const args |
407 |
|
|
408 |
|
|
409 |
|
|
410 |
|
|
411 |
|
(defun list-tp-test (tf lt) |
412 |
|
(cond ((null lt) (values t t)) |
413 |
|
((atom lt) (values nil nil)) |
414 |
|
((eq (car lt) 'cons) |
415 |
|
(multiple-value-bind |
416 |
|
(m1 f1) (funcall tf (cadr lt)) |
417 |
|
(multiple-value-bind |
418 |
|
(m2 f2) (list-tp-test tf (caddr lt)) |
419 |
|
(values (and m1 m2) (or f1 f2))))) |
420 |
|
(t (values nil nil)))) |
421 |
|
|
422 |
|
(defun test-to-tf (test) |
423 |
|
(let ((test (if (constantp test) (cmp-eval test) test))) |
424 |
|
(cond ((member test `(eql ,#'eql)) '(eql-is-eq eql-is-eq-tp)) |
425 |
|
((member test `(equal ,#'equal)) '(equal-is-eq equal-is-eq-tp)) |
426 |
|
((member test `(equalp ,#'equalp)) '(equalp-is-eq equalp-is-eq-tp))))) |
427 |
|
|
428 |
|
(defun is-eq-test-item-list (test item list) |
429 |
|
(declare (ignore list)) |
430 |
|
(let ((tf (car (test-to-tf test)))) |
431 |
|
(and tf (funcall tf item)))) |
432 |
|
|
433 |
|
(defun c1is-eq-test-item-list (args) |
434 |
|
(let* ((ltf (test-to-tf (car args))) |
435 |
|
(tf (cadr ltf)) |
436 |
|
(info (make-info))) |
437 |
|
(if (not tf) |
438 |
|
(c1expr nil) |
439 |
|
(let ((nargs (c1args (cdr args) info))) |
440 |
|
(multiple-value-bind |
441 |
|
(m1 f1) (funcall tf (info-type (cadar nargs))) |
442 |
|
(multiple-value-bind |
443 |
|
(m2 f2) (list-tp-test tf (info-type (cadadr nargs))) |
444 |
|
(declare (ignore f2)) |
445 |
|
(cond ((or m1 m2) (c1expr t)) |
446 |
|
(f1 (c1expr nil)) |
447 |
|
((let ((info (make-info))) (list 'call-global info (car ltf) (c1args (list (cadr args)) info))))))))))) |
448 |
|
(si::putprop 'is-eq-test-item-list 'c1is-eq-test-item-list 'c1) |
449 |
|
|
450 |
|
(defun do-predicate (fn args) |
451 |
|
(let* ((info (make-info)) |
452 |
|
(nargs (c1args args info)) |
453 |
|
(tp (car (rassoc fn *type-alist*)))) |
454 |
|
(let ((at (and (not (cdr args)) (info-type (cadar nargs))))) |
455 |
|
(cond ((and at (subtypep at tp)) (c1expr t)) |
456 |
|
((not (type-and at tp)) (c1expr nil)) |
457 |
|
((list 'call-global info fn nargs)))))) |
458 |
|
(dolist (l *type-alist*) (when (symbolp (cdr l)) (si::putprop (cdr l) 'do-predicate 'c1g))) |
459 |
|
|
460 |
|
(defun c1or (args) |
461 |
|
(cond ((null args) (c1expr nil)) |
462 |
|
((constantp (car args)) (let ((na (cmp-eval (car args)))) (if na (c1expr na) (c1or (cdr args))))) |
463 |
|
((null (cdr args)) (c1expr (car args))) |
464 |
|
((macro-function 'or) (c1expr (cmp-macroexpand `(or ,@args)))) |
465 |
|
((let ((info (make-info))) (list 'call-global info 'or (c1args args info)))))) |
466 |
|
(si::putprop 'or 'c1or 'c1) |
467 |
|
|
468 |
|
(defun cmp-array-element-type (&rest args) |
469 |
|
(and |
470 |
|
args |
471 |
|
(let ((z (or (not (typep (car args) 'array)) (upgraded-array-element-type (array-element-type (car args))))) |
472 |
|
(y (apply 'cmp-array-element-type (cdr args)))) |
473 |
|
;;need type-or here |
474 |
|
(cond ((subtypep z y) y) |
475 |
|
((subtypep y z) z) |
476 |
|
(t))))) |
477 |
|
|
478 |
|
(defun array-element-subtype (type) |
479 |
|
(let ((type (si::normalize-type type))) |
480 |
|
(or |
481 |
|
(not (consp type)) |
482 |
|
(not (member (car type) '(array simple-array))) |
483 |
|
(null (cadr type)) |
484 |
|
(eq (cadr type) '*) |
485 |
|
(cadr type)))) |
486 |
|
|
487 |
|
(defun cmp-array-element-subtype (args) |
488 |
|
(and |
489 |
|
args |
490 |
|
(let ((z (array-element-subtype (car args))) |
491 |
|
(y (cmp-array-element-subtype (cdr args)))) |
492 |
|
;;need type-or here |
493 |
|
(cond ((subtypep z y) y) |
494 |
|
((subtypep y z) z) |
495 |
|
(t))))) |
496 |
|
|
497 |
|
(defun c1cmp-array-element-type (args) |
498 |
|
(let* ((info (make-info)) |
499 |
|
(nargs (c1args args info))) |
500 |
|
(c1expr `(quote ,(cmp-array-element-subtype (mapcar (lambda (x) (info-type (cadr x))) nargs)))))) |
501 |
|
(si::putprop 'cmp-array-element-type 'c1cmp-array-element-type 'c1) |
502 |
|
|
503 |
|
(defun cons-type-length (type) |
504 |
|
(cond ((null type) 0) |
505 |
|
((and (consp type) (eq (car type) 'cons)) (+ 1 (cons-type-length (caddr type)))))) |
506 |
|
|
507 |
|
(defun c1make-array (args) |
508 |
|
(let* ((info (make-info)) |
509 |
|
(nargs (c1args args info))) |
510 |
|
(let* ((eltp (position :element-type args)) |
511 |
|
(eltp (and eltp (nth (1+ eltp) nargs))) |
512 |
|
(eltp (and eltp (consp eltp) (eq (car eltp) 'location) (caddr eltp))) |
513 |
|
(eltp (and (consp eltp) (eq (car eltp) 'VV) (caar (member (cadr eltp) *objects* :key 'cadr)))) |
514 |
|
(eltp (if eltp `(,eltp) `(*)))) |
515 |
|
(let ((szf (let ((st (info-type (cadar nargs)))) |
516 |
|
(cond ((subtypep st 'list) `(,(make-list (cons-type-length st) :initial-element '*))) |
517 |
|
((and st (not (subtypep 'list st))) `((*))))))) |
518 |
|
(setf (info-type info) `(array ,@eltp ,@szf)) |
519 |
|
(list 'call-global info 'make-array nargs))))) |
520 |
|
(si::putprop 'make-array 'c1make-array 'c1) |
521 |
|
|
522 |
|
;(defun all-type (types type) |
523 |
|
; (if (null types) |
524 |
|
; (values t nil) |
525 |
|
; (let ((m (subtypep (car types) type)) |
526 |
|
; (f (subtypep type (car types)))) |
527 |
|
; (multiple-value-bind |
528 |
|
; (m1 f1)(all-type (cdr types) type) |
529 |
|
; (values (and m m1) (or (and (not m) (not f)) f1)))))) |
530 |
|
|
531 |
|
;(defun all-type-check (fn type pred args) |
532 |
|
; (let* ((info (make-info)) |
533 |
|
; (nargs (c1args args info))) |
534 |
|
; (multiple-value-bind |
535 |
|
; (m f) (all-type (mapcar (lambda (x) (info-type (cadr x))) nargs) type) |
536 |
|
; (cond (m (c1expr t)) |
537 |
|
; (f (c1expr nil)) |
538 |
|
; ((c1expr (reduce (lambda (x y) `(and ,x (,pred ,y))) args :initial-value t))))))) |
539 |
|
|
540 |
|
;(defun all-lists (args) |
541 |
|
; (every 'listp args)) |
542 |
|
;(defun c1all-lists (args) |
543 |
|
; (all-type-check 'all-lists 'list 'listp args)) |
544 |
|
;(si::putprop 'all-lists 'c1all-lists 'c1) |
545 |
|
;(defun all-vectors (args) |
546 |
|
; (every 'vectorp args)) |
547 |
|
;(defun c1all-vectors (args) |
548 |
|
; (all-type-check 'all-vectors 'vector 'vectorp args)) |
549 |
|
;(si::putprop 'all-vectors 'c1all-vectors 'c1) |
550 |
|
|
551 |
(defun boole3 (a b c) (boole a b c)) |
(defun boole3 (a b c) (boole a b c)) |
552 |
(si:putprop 'boole '(c1boole-condition . c1boole3) 'c1conditional) |
(si:putprop 'boole '(c1boole-condition . c1boole3) 'c1conditional) |
706 |
(t t))) |
(t t))) |
707 |
|
|
708 |
|
|
709 |
|
;(defvar *std-instance-class-type* nil) |
710 |
(defvar *type-alist* |
;(defvar *std-instance-symbol* nil) |
|
'((fixnum . si::fixnump) |
|
|
(float . floatp) |
|
|
(short-float . short-float-p) |
|
|
(long-float . long-float-p) |
|
|
(integer . integerp) |
|
|
(character . characterp) |
|
|
(symbol . symbolp) |
|
|
(cons . consp) |
|
|
(null . null) |
|
|
(array . arrayp) |
|
|
(vector . vectorp) |
|
|
(bit-vector . bit-vector-p) |
|
|
(string . stringp) |
|
|
(list . (lambda (y) (or (consp y) (null y)))) |
|
|
(number . numberp) |
|
|
(rational . rationalp) |
|
|
(complex . complexp) |
|
|
(ratio . ratiop) |
|
|
(sequence . (lambda (y) (or (listp y) (vectorp y)))) |
|
|
(function . functionp) |
|
|
)) |
|
|
|
|
711 |
|
|
712 |
(defun co1typep (f args &aux tem) f |
(defun co1typep (f args &aux tem) f |
713 |
(let* |
(let* ((x (car args)) new |
714 |
((x (car args)) new |
(type (and (literalp (cadr args)) (cmp-eval (cadr args))))) |
715 |
(type (and (consp (second args)) |
; (unless *std-instance-symbol* |
716 |
(eq (car (second args)) 'quote) |
; (setq *std-instance-symbol* (let ((p (find-package 'pcl))) (and p (find-symbol "STD-INSTANCE" p))))) |
717 |
(second (second args))))) |
; (when (eq type *std-instance-symbol*) |
718 |
(cond ((subtypep (result-type (car args)) type) |
; (unless *std-instance-class-type* |
719 |
(setq new t) |
; (let* ((p (find-package 'pcl)) |
720 |
(return-from co1typep (c1expr new)))) |
; (s (and p (find-symbol "SLOT-OBJECT" p))) |
721 |
|
; (si (and s (import s 'compiler))) |
722 |
|
; (q (and p (find-symbol "FUNCALLABLE-STANDARD-OBJECT" p))) |
723 |
|
; (qi (and q (import q 'compiler)))) |
724 |
|
; (when (and si qi) |
725 |
|
; (setq *std-instance-class-type* `(and ,s (not ,q))))))) |
726 |
|
; (let ((type (or (and (eq type *std-instance-symbol*) *std-instance-class-type*) type))) |
727 |
|
(let ((rt (result-type (car args)))) |
728 |
|
; (format t "~a ~a ~a ~a ~a ~a~%" type rt (car args) (subtypep rt type) (multiple-value-list (subtypep type rt)) (type-and type rt)) |
729 |
|
(cond ((subtypep rt type) |
730 |
|
(setq new t) |
731 |
|
(return-from co1typep (c1expr new))) |
732 |
|
((and type (multiple-value-bind (m v) (subtypep type rt) (and (not m) v)) (not (type-and type rt))) |
733 |
|
(setq new nil) |
734 |
|
(return-from co1typep (c1expr new))))) |
735 |
|
;) |
736 |
(setq new |
(setq new |
737 |
(cond |
(cond |
738 |
((null type) nil) |
((null type) nil) |
1103 |
|
|
1104 |
|
|
1105 |
;; end new |
;; end new |
1106 |
|
|
1107 |
|
(defun c1list (args) |
1108 |
|
(let* ((info (make-info)) |
1109 |
|
(nargs (c1args args info))) |
1110 |
|
(setf (info-type info) (nil-to-t (reduce (lambda (x y) (list 'cons (info-type (cadr x)) y)) (append nargs '(nil)) :from-end t))) |
1111 |
|
(list 'call-global info 'list nargs))); |
1112 |
|
(si::putprop 'list 'c1list 'c1) |
1113 |
|
|
1114 |
(defun c1list-nth (args &aux (info (make-info))) |
(defun c1list-nth (args &aux (info (make-info))) |
1115 |
(when (or (endp args) (endp (cdr args))) |
(when (or (endp args) (endp (cdr args))) |