372 |
(si::putprop '1+ (function incr-to-plus) 'si::compiler-macro-prop) |
(si::putprop '1+ (function incr-to-plus) 'si::compiler-macro-prop) |
373 |
(si::putprop '1- (function decr-to-minus) 'si::compiler-macro-prop) |
(si::putprop '1- (function decr-to-minus) 'si::compiler-macro-prop) |
374 |
|
|
375 |
|
(defun reverse-expander (form env) |
376 |
|
(declare (ignore env)) |
377 |
|
(let ((x (gensym)) (i (gensym)) (s (gensym))) |
378 |
|
`(let ((,s ,(cadr form))) |
379 |
|
(if (typep ,s 'vector) |
380 |
|
(let ((,x (make-array (length ,s) :element-type (cmp-array-element-type ,s)))) |
381 |
|
(do ((,i 0 (1+ ,i))) ((= ,i (length ,s)) ,x) |
382 |
|
(declare (seqind ,i)) |
383 |
|
(setf (aref ,x (1- (- (length ,s) ,i))) (aref ,s ,i)))) |
384 |
|
(let (,x) |
385 |
|
(do ((,s ,s (cdr ,s))) ((endp ,s) ,x) |
386 |
|
(setq ,x (cons (car ,s) ,x)))))))) |
387 |
|
(si::putprop 'reverse (function reverse-expander) 'si::compiler-macro-prop) |
388 |
|
|
389 |
|
(defun cmp-vec-length (x) |
390 |
|
(declare (vector x)) |
391 |
|
(fill-pointer x)) |
392 |
|
|
393 |
|
(defun length-expander (form env) |
394 |
|
(declare (ignore env)) |
395 |
|
(let ((i (gensym)) (s (gensym))) |
396 |
|
`(let ((,s ,(cadr form))) |
397 |
|
(the seqind ;FIXME |
398 |
|
(if (typep ,s 'vector) |
399 |
|
(let ((,s ,s)) ;;FIXME should be automatic co1typep |
400 |
|
(declare (vector ,s)) |
401 |
|
(cmp-vec-length ,s)) |
402 |
|
(do ((,i 0 (1+ ,i)) (,s ,s (cdr ,s))) ((endp ,s) ,i) |
403 |
|
(declare (seqind ,i)))))))) |
404 |
|
(si::putprop 'length (function length-expander) 'si::compiler-macro-prop) |
405 |
|
|
406 |
|
|
407 |
|
(defun endp-expander (form env) |
408 |
|
(declare (ignore env)) |
409 |
|
(if *compiler-check-args* |
410 |
|
`(not (or (consp ,(cadr form)) (check-type ,(cadr form) null))) |
411 |
|
`(not ,(cadr form)))) |
412 |
|
(si::putprop 'endp (function endp-expander) 'si::compiler-macro-prop) |
413 |
|
|
414 |
|
(defun garef (a i l) |
415 |
|
(let ((ff `(aref ,a ,i))) |
416 |
|
(if l `(car ,ff) ff))) |
417 |
|
|
418 |
|
(defun qsl-fun (l p k list) |
419 |
|
(let ((ll (gensym)) (a (gensym)) (fi (gensym)) (ls (gensym)) (lf (gensym)) (rt (gensym)) |
420 |
|
(sp (gensym)) (spi (gensym)) (s (gensym)) (ii (gensym))) |
421 |
|
`(let* ((,ll (length ,l)) |
422 |
|
(,a ,(if list `(make-array ,ll) l)));FIXME default? |
423 |
|
,(when list `(declare ((vector t) ,a))) |
424 |
|
,(when list `(do ((,fi 0 (1+ ,fi)) (,l ,l (cdr ,l))) ((= ,fi ,ll)) |
425 |
|
(declare (seqind ,fi)) |
426 |
|
(setf (aref ,a ,fi) ,l))) |
427 |
|
(let* ((,ii (make-array 1024 :element-type 'non-negative-fixnum :adjustable t)) |
428 |
|
(,s 2)) |
429 |
|
(declare (seqind ,s) ((vector seqind) ,ii));FIXME (adjust-array |
430 |
|
(setf (aref ,ii 0) 0 (aref ,ii 1) ,ll) |
431 |
|
(do () ((= ,s 0)) |
432 |
|
(let* ((,ls (aref ,ii (decf ,s))) (,fi (aref ,ii (decf ,s)))) |
433 |
|
(declare (seqind ,ls ,fi));FIXME setq |
434 |
|
(do () ((>= ,fi (1- ,ls))) |
435 |
|
(rotatef ,(garef a fi list) ,(garef a `(+ ,fi (truncate (- ,ls ,fi) 2)) list)) |
436 |
|
(let* ((,spi ,fi) |
437 |
|
(,sp (funcall ,k ,(garef a spi list)))) |
438 |
|
(declare (seqind ,spi)) |
439 |
|
(do ((,lf ,fi) (,rt ,ls)) ((>= ,lf ,rt)) |
440 |
|
(declare (seqind ,lf ,rt)) |
441 |
|
(do () ((or (>= (incf ,lf) ,rt) |
442 |
|
(not (funcall ,p (funcall ,k ,(garef a lf list)) ,sp))))) |
443 |
|
(do () ((or (>= ,lf (decf ,rt)) |
444 |
|
(funcall ,p (funcall ,k ,(garef a rt list)) ,sp)))) |
445 |
|
(when (< ,lf ,rt) |
446 |
|
(rotatef ,(garef a lf list) ,(garef a rt list))) |
447 |
|
(setq ,spi (1- ,lf))) |
448 |
|
(rotatef ,(garef a fi list) ,(garef a spi list)) |
449 |
|
(if (< (- ,ls ,spi) (- ,spi ,fi)) |
450 |
|
(let ((,lf (1+ ,spi))) |
451 |
|
(when (> (- ,ls ,lf) 1) |
452 |
|
(when (>= ,s (1- (length ,ii))) |
453 |
|
(setq ,ii (adjust-array ,ii (ash (length ,ii) 1)))) |
454 |
|
(setf (aref ,ii ,s) ,lf (aref ,ii (incf ,s)) ,ls ,s (1+ ,s))) |
455 |
|
(setq ,ls ,spi)) |
456 |
|
(let ((,rt ,spi)) |
457 |
|
(when (> (- ,rt ,fi) 1) |
458 |
|
(when (>= ,s (1- (length ,ii))) |
459 |
|
(setq ,ii (adjust-array ,ii (ash (length ,ii) 1)))) |
460 |
|
(setf (aref ,ii ,s) ,fi (aref ,ii (incf ,s)) ,rt ,s (1+ ,s))) |
461 |
|
(setq ,fi (1+ ,spi))))))))) |
462 |
|
,l))) |
463 |
|
|
464 |
|
(defun qsort-expander (form env) ;l p k |
465 |
|
(declare (ignore env)) |
466 |
|
(if (or (not (consp (caddr form))) |
467 |
|
(not (member (caaddr form) '(function lambda quote))) |
468 |
|
(and (cdddr form) |
469 |
|
(or (not (eq :key (cadddr form))) |
470 |
|
(not (consp (fifth form))) |
471 |
|
(not (member (car (fifth form)) '(function lambda quote)))))) |
472 |
|
form |
473 |
|
(let ((seq (gensym))) |
474 |
|
`(let ((,seq ,(cadr form))) |
475 |
|
(if (typep ,seq 'vector) |
476 |
|
(let ((,seq ,seq)) |
477 |
|
(declare (vector ,seq)) |
478 |
|
,(qsl-fun seq (caddr form) (if (cdddr form) (fifth form) ''identity) nil)) |
479 |
|
(let ((,seq ,seq)) |
480 |
|
(declare (list ,seq)) |
481 |
|
,(qsl-fun seq (caddr form) (if (cdddr form) (fifth form) ''identity) t))))))) |
482 |
|
(si::putprop 'sort (function qsort-expander) 'si::compiler-macro-prop) |
483 |
|
|
484 |
|
(defun mheap (a r b key p) |
485 |
|
(let ((block (gensym)) (j (gensym)) (k (gensym)) (k1 (gensym)) (kk (gensym)) (kk1 (gensym)) (x (gensym))) |
486 |
|
`(block |
487 |
|
,block |
488 |
|
(do ((,j ,r) (,k (ash ,r 1))) ((>= ,k ,b)) |
489 |
|
(declare (seqind ,j ,k)) |
490 |
|
(let ((,kk (funcall ,key (car (aref ,a ,k))))) |
491 |
|
(unless (= ,k (1- ,b)) |
492 |
|
(let* ((,k1 (1+ ,k)) |
493 |
|
(,kk1 (funcall ,key (car (aref ,a ,k1))))) |
494 |
|
(when (funcall ,p ,kk ,kk1) |
495 |
|
(setq ,kk ,kk1 ,k ,k1)))) |
496 |
|
(let ((,x (car (aref ,a ,j)))) |
497 |
|
(if (funcall ,p (funcall ,key ,x) ,kk) |
498 |
|
(setf (car (aref ,a ,j)) (car (aref ,a ,k)) |
499 |
|
(car (aref ,a ,k)) ,x |
500 |
|
,j ,k |
501 |
|
,k (ash ,j 1)) |
502 |
|
(return-from ,block)))))))) |
503 |
|
|
504 |
|
(defconstant +hash-index-type+ (car (si::resolve-type `(or (integer -1 -1) seqind)))) |
505 |
|
|
506 |
|
(defun sort-expander (form env) |
507 |
|
(declare (ignore env)) |
508 |
|
(if (or (not (consp (caddr form))) |
509 |
|
(not (member (caaddr form) '(function lambda quote))) |
510 |
|
(and (cdddr form) |
511 |
|
(or (not (eq :key (cadddr form))) |
512 |
|
(not (consp (fifth form))) |
513 |
|
(not (member (car (fifth form)) '(function lambda quote)))))) |
514 |
|
form |
515 |
|
(let ((ll (gensym)) (a (gensym)) (i (gensym)) (x (gensym)) |
516 |
|
(seq (gensym)) (pred (caddr form)) (key (if (cdddr form) (fifth form) ''identity))) |
517 |
|
`(let ((,seq ,(cadr form))) |
518 |
|
(declare (list ,seq)) |
519 |
|
(let* ((,ll (length ,seq)) |
520 |
|
(,a (make-array ,ll :element-type t))) |
521 |
|
(declare ((vector t) ,a)) ;FIXME |
522 |
|
(do ((,i 0 (1+ ,i)) (,x ,seq (cdr ,x))) ((= ,i ,ll)) |
523 |
|
(declare (seqind ,i)) |
524 |
|
(setf (aref ,a ,i) ,x)) |
525 |
|
(do ((,i (floor ,ll 2) (1- ,i))) ((< ,i 0)) |
526 |
|
(declare (,+hash-index-type+ ,i)) |
527 |
|
,(mheap a i ll key pred)) |
528 |
|
(do ((,i (1- ,ll) (1- ,i))) ((<= ,i 0)) |
529 |
|
(declare (seqind ,i)) |
530 |
|
(let ((,x (car (aref ,a 0)))) |
531 |
|
(setf (car (aref ,a 0)) (car (aref ,a ,i)) (car (aref ,a ,i)) ,x)) |
532 |
|
,(mheap a 0 i key pred))) |
533 |
|
,seq)))) |
534 |
|
;(si::putprop 'sort (function sort-expander) 'si::compiler-macro-prop) |
535 |
|
|
536 |
|
(defun identity-expander (form env) |
537 |
|
(declare (ignore env)) |
538 |
|
(cadr form)) |
539 |
|
(si::putprop 'identity (function identity-expander) 'si::compiler-macro-prop) |
540 |
|
|
541 |
(defun seqind-wrap (form) |
(defun seqind-wrap (form) |
542 |
(if *safe-compile* |
(if *safe-compile* |
543 |
form |
form |
544 |
`(the seqind ,form))) |
`(the seqind ,form))) |
545 |
|
|
|
(defconstant +hash-index-type+ (car (si::resolve-type `(or (integer -1 -1) seqind)))) |
|
|
|
|
546 |
(defun maphash-expander (form env) |
(defun maphash-expander (form env) |
547 |
(declare (ignore env)) |
(declare (ignore env)) |
548 |
(let ((block (gensym))(tag (gensym)) (ind (gensym)) (key (gensym)) (val (gensym))) |
(let ((block (gensym))(tag (gensym)) (ind (gensym)) (key (gensym)) (val (gensym))) |