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

Diff of /gcl/cmpnew/gcl_cmpeval.lsp

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

revision 1.33 by camm, Mon Sep 26 16:46:00 2005 UTC revision 1.34 by camm, Wed Oct 5 15:19:01 2005 UTC
# Line 372  Line 372 
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)))

Legend:
Removed from v.1.33  
changed lines
  Added in v.1.34

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