Diff of /s-code.lisp [9af4a7] .. [e165b7]  Maximize  Restore

  Switch to unified view

a/s-code.lisp b/s-code.lisp
...
...
7
;;;; If you obtained this file from somewhere else, or copied the
7
;;;; If you obtained this file from somewhere else, or copied the
8
;;;; files a long time ago, you might consider copying them from the
8
;;;; files a long time ago, you might consider copying them from the
9
;;;; above web site now to obtain the latest version.
9
;;;; above web site now to obtain the latest version.
10
;;;; NO PATCHES TO OTHER BUT THE LATEST VERSION WILL BE ACCEPTED.
10
;;;; NO PATCHES TO OTHER BUT THE LATEST VERSION WILL BE ACCEPTED.
11
;;;;
11
;;;;
12
;;;; $Id: s-code.lisp,v 1.69 2000/03/23 23:04:11 matomira Exp $
12
;;;; $Id: s-code.lisp,v 1.70 2000/03/25 22:16:57 matomira Exp $
13
;;;;
13
;;;;
14
;;;; This is Richard C. Waters' Series package.
14
;;;; This is Richard C. Waters' Series package.
15
;;;; This started from his November 26, 1991 version.
15
;;;; This started from his November 26, 1991 version.
16
;;;;
16
;;;;
17
;;;; $Log: s-code.lisp,v $
17
;;;; $Log: s-code.lisp,v $
18
;;;; Revision 1.70  2000/03/25 22:16:57  matomira
19
;;;; Removed gratuitous consing in map-fn.
20
;;;; Added install and system files.
21
;;;;
18
;;;; Revision 1.69  2000/03/23 23:04:11  matomira
22
;;;; Revision 1.83  2000/03/25 21:44:26  matomira
19
;;;;   NEW FEATURES:
23
;;;; Avoided gratuitous consig in values-lists.
20
;;;;   ------------
21
;;;;    - (collect 'set
22
;;;;      Collects a series into a list removing any duplicates in the most efficient way possible.
23
;;;;    - (collect 'ordered-set
24
;;;;      Collects a series into a list removing any duplicates but keeping the original series order.
25
;;;;    - SCAN now allows to drop the type specifier for any source expression
26
;;;;      [:cltl2-series reactivates the old 'list assumption]
27
;;;;    - SCAN now can scan multidimensional arrays in row-major order.
28
;;;;
29
;;;;   IMPROVEMENTS:
30
;;;;   ------------
31
;;;;    - Better code generation
32
;;;;      . Some fixnum declarations were further constrained.
33
;;;;      . Optimized scanning of constant sequences.
34
;;;;      . Somewhat optimized scanning of "empty" vectors, ie,
35
;;;;        declared to be of constant 0 length, like in
36
;;;;        (collect (scan '(vector t 0) <gimme-a-huge-array-to-throw-away>)
37
;;;;        now gives you NIL generating/executing less instructions.
38
;;;;        [<gimme-a-huge-array-to-throw-away> is still executed if not constantp,
39
;;;;         though]
40
;;;;      . Variables of type NULL are replaced by constant NILs.
41
;;;;
42
;;;;   BUG FIXES:
43
;;;;   ---------
44
;;;;    - Some incorrect fixnum declarations were relaxed.
45
;;;;    - Improved some declarations to avoid spurious range warnings regarding
46
;;;;      dead code by not-so-smart compilers.
47
;;;;
24
;;;;
48
;;;; Revision 1.80  2000/03/23 23:01:56  matomira
25
;;;; Revision 1.80  2000/03/23 23:01:56  matomira
49
;;;;   NEW FEATURES:
26
;;;;   NEW FEATURES:
50
;;;;   ------------
27
;;;;   ------------
51
;;;;    - (collect 'set
28
;;;;    - (collect 'set
...
...
678
          (vars (n-gensyms n)))
655
          (vars (n-gensyms n)))
679
      `(cl:multiple-value-bind ,vars ,vals
656
      `(cl:multiple-value-bind ,vars ,vals
680
     (values
657
     (values
681
       ,@(mapcar #'(lambda (p v) `(setf ,p ,v)) places vars)))))
658
       ,@(mapcar #'(lambda (p v) `(setf ,p ,v)) places vars)))))
682
659
683
  (cl:defun poly-funcall (fun &rest args)
660
  (cl:defun polyapply (fun args)
661
    (declare (dynamic-extent args))
684
    (if args
662
    (if args
685
    (cl:let ((d (cdr args)))
663
    (cl:let ((d (cdr args)))
686
      (if d
664
      (if d
687
          (valuate (cl:funcall fun (car args)) (apply #'poly-funcall fun (cdr args)))
665
          (valuate (cl:funcall fun (car args)) (polyapply fun (cdr args)))
688
        (cl:funcall fun (car args))))
666
        (cl:funcall fun (car args))))
689
      (values)))       
667
      (values)))
690
668
669
  (cl:defun polycall (fun &rest args)
670
    (declare (dynamic-extent args))
671
    (if args
672
  (cl:let ((d (cdr args)))
673
    (if d
674
        (valuate (cl:funcall fun (car args)) (polyapply fun (cdr args)))
675
      (cl:funcall fun (car args))))
676
      (values)))
677
691
  (defmacro multiple-value-poly-funcall (n fun vals)
678
  (defmacro multiple-value-polycall (fun vals)
692
    (cl:let* ((vars (n-gensyms n)))
679
    `(multiple-value-call #'polycall ,fun ,vals))
693
      `(cl:multiple-value-bind ,vars ,vals
694
   (poly-funcall ,fun ,@vars))))
695
680
696
  (cl:defun 2mapcar (fun orig)
681
  (cl:defun 2mapcar (fun orig)
697
    (if orig
682
    (if orig
698
    (cl:let* ((lastcons1 (list nil))
683
    (cl:let* ((lastcons1 (list nil))
699
          (lastcons2 (list nil))
684
          (lastcons2 (list nil))
...
...
701
          (lst2 lastcons2))
686
          (lst2 lastcons2))
702
      (do ((remains orig (cdr remains)))
687
      (do ((remains orig (cdr remains)))
703
          ((not (consp remains)) (values (cdr lst1) (cdr lst2)))
688
          ((not (consp remains)) (values (cdr lst1) (cdr lst2)))
704
        (multiple-value-setq (lastcons1 lastcons2)              
689
        (multiple-value-setq (lastcons1 lastcons2)              
705
          (multiple-value-setf ((cdr  lastcons1) (cdr lastcons2))
690
          (multiple-value-setf ((cdr  lastcons1) (cdr lastcons2))
706
                   (multiple-value-poly-funcall 2
691
                   (multiple-value-polycall #'list
707
                              #'list
708
                              (cl:funcall fun (car remains)))))))
692
                                (cl:funcall fun (car remains)))))))
709
      (values nil nil)))
693
      (values nil nil)))
710
694
711
  (cl:defun 3mapcar (fun orig)
695
  (cl:defun 3mapcar (fun orig)
712
    (if orig
696
    (if orig
713
    (cl:let* ((lastcons1 (list nil))
697
    (cl:let* ((lastcons1 (list nil))
...
...
718
          (lst3 lastcons3))
702
          (lst3 lastcons3))
719
      (do ((remains orig (cdr remains)))
703
      (do ((remains orig (cdr remains)))
720
          ((not (consp remains)) (values (cdr lst1) (cdr lst2) (cdr lst3)))
704
          ((not (consp remains)) (values (cdr lst1) (cdr lst2) (cdr lst3)))
721
        (multiple-value-setq (lastcons1 lastcons2 lastcons3)                
705
        (multiple-value-setq (lastcons1 lastcons2 lastcons3)                
722
          (multiple-value-setf ((cdr  lastcons1) (cdr lastcons2) (cdr lastcons3))
706
          (multiple-value-setf ((cdr  lastcons1) (cdr lastcons2) (cdr lastcons3))
723
                   (multiple-value-poly-funcall 3
707
                   (multiple-value-polycall #'list
724
                              #'list
725
                              (cl:funcall fun (car remains)))))))
708
                                (cl:funcall fun (car remains)))))))
726
      (values nil nil nil)))
709
      (values nil nil nil)))
727
710
728
  (cl:defun 2mapcan (fun orig)
711
  (cl:defun 2mapcan (fun orig)
729
    (if orig
712
    (if orig
730
    (cl:let* ((lastcons1 (list nil))
713
    (cl:let* ((lastcons1 (list nil))
...
...
732
          (lst1 lastcons1)
715
          (lst1 lastcons1)
733
          (lst2 lastcons2))
716
          (lst2 lastcons2))
734
      (do ((remains orig (cdr remains)))
717
      (do ((remains orig (cdr remains)))
735
          ((not (consp remains)) (values (cdr lst1) (cdr lst2)))
718
          ((not (consp remains)) (values (cdr lst1) (cdr lst2)))
736
        (multiple-value-setq (lastcons1 lastcons2)
719
        (multiple-value-setq (lastcons1 lastcons2)
737
          (multiple-value-poly-funcall 2 #'last
720
          (multiple-value-polycall
721
          #'last
738
          (multiple-value-setf ((cdr  lastcons1) (cdr lastcons2))
722
      (multiple-value-setf ((cdr  lastcons1) (cdr lastcons2))
739
                   (multiple-value-poly-funcall 2
723
                     (multiple-value-polycall #'list
740
                              #'list
741
                              (cl:funcall fun (car remains))))))))
724
                                  (cl:funcall fun (car remains))))))))
742
      (values nil nil)))
725
      (values nil nil)))
743
726
744
  (cl:defun 3mapcan (fun orig)
727
  (cl:defun 3mapcan (fun orig)
745
    (if orig
728
    (if orig
746
    (cl:let* ((lastcons1 (list nil))
729
    (cl:let* ((lastcons1 (list nil))
...
...
750
          (lst2 lastcons2)
733
          (lst2 lastcons2)
751
          (lst3 lastcons3))
734
          (lst3 lastcons3))
752
      (do ((remains orig (cdr remains)))
735
      (do ((remains orig (cdr remains)))
753
          ((not (consp remains)) (values (cdr lst1) (cdr lst2) (cdr lst3)))
736
          ((not (consp remains)) (values (cdr lst1) (cdr lst2) (cdr lst3)))
754
        (multiple-value-setq (lastcons1 lastcons2 lastcons3)
737
        (multiple-value-setq (lastcons1 lastcons2 lastcons3)
755
          (multiple-value-poly-funcall 3 #'last
738
          (multiple-value-polycall
739
          #'last
756
          (multiple-value-setf ((cdr  lastcons1) (cdr lastcons2) (cdr lastcons3))
740
            (multiple-value-setf ((cdr  lastcons1) (cdr lastcons2) (cdr lastcons3))
757
                   (multiple-value-poly-funcall 3
741
                     (multiple-value-polycall #'list
758
                              #'list
759
                              (cl:funcall fun (car remains))))))))
742
                                  (cl:funcall fun (car remains))))))))
760
      (values nil nil nil)))
743
      (values nil nil nil)))
761
744
762
  (cl:defun nsubst-inline (new-list old list &optional (save-spot nil))
745
  (cl:defun nsubst-inline (new-list old list &optional (save-spot nil))
763
    (cl:let ((tail (member old list)))
746
    (cl:let ((tail (member old list)))
764
      (cond ((not tail) old)
747
      (cond ((not tail) old)
...
...
859
  (cl:defun n-integers (n)
842
  (cl:defun n-integers (n)
860
    (do ((i (1- n) (1- i))
843
    (do ((i (1- n) (1- i))
861
         (l nil (cons i l)))
844
         (l nil (cons i l)))
862
        ((minusp i) l)))
845
        ((minusp i) l)))
863
846
847
  (cl:defun n-integer-values (n)
848
    (cl:labels ((n-integer-values-1 (n &rest args)
849
        (declare (dynamic-extent args))        
850
        (cond ((> n 1) (cl:multiple-value-call #'n-integer-values-1
851
                           (1- n) (1- n) (values-list args)))
852
          ((= n 1) (valuate 0 (values-list args)))
853
          (t (values)))))
854
      (n-integer-values-1 n)))
855
864
) ; end of eval-when
856
) ; end of eval-when
865
857
866
;;; Code generation utilities
858
;;; Code generation utilities
867
859
868
(eval-when (:compile-toplevel :load-toplevel :execute)
860
(eval-when (:compile-toplevel :load-toplevel :execute)
861
862
(defmacro funcase ((binds funexpr) &rest cases)
863
  (cl:let (var expr
864
     (a (gensym)))
865
    (if (consp binds)
866
  (destructuring-bind (v &optional (e (gensym))) binds
867
    (setq var v
868
      expr e))
869
      (setq var binds
870
      expr (gensym)))
871
    (cl:flet ((nameguard () `(and (eq ,a 'function) (symbolp (setq ,var (cadr ,expr)))))
872
        (anonguard () `(setq ,var (cond ((eq ,a 'function) (cadr ,expr))
873
                        ((eq ,a 'lambda) ,expr)
874
                        (t nil))))
875
        (varguard  () `(symbolp ,expr))
876
        (compguard () `(and ,a (case ,a ((function lambda) nil) (t t))))
877
        (elseguard () t))
878
      (cl:flet ((compute-guard-1 (tag)
879
        (ecase tag
880
          (name      (nameguard))
881
          (anonymous (anonguard))
882
          (variable  (varguard))
883
          (computed  (compguard))
884
          ((t otherwise else) (elseguard)))))
885
        (cl:flet ((compute-guard (tag)
886
              (if (consp tag)
887
              (cons 'or (mapcar #'compute-guard-1 tag))
888
            (compute-guard-1 tag))))
889
          `(cl:let* ((,expr ,funexpr)
890
           (,a (when (consp ,expr) (car ,expr)))
891
           ,var)
892
             (cond ,@(mapcar #'(lambda (x) (list* (compute-guard (car x)) (cdr x)))
893
               cases))))))))
869
894
870
(cl:defun prognize (forms &optional (prognize-p t))
895
(cl:defun prognize (forms &optional (prognize-p t))
871
  (if prognize-p
896
  (if prognize-p
872
      (values
897
      (values
873
       (if (cdr forms)
898
       (if (cdr forms)
...
...
1083
           ;; Everything else is a sequence
1108
           ;; Everything else is a sequence
1084
           (T
1109
           (T
1085
            (values 'sequence nil T)))))
1110
            (values 'sequence nil T)))))
1086
    (values 'sequence nil T))) ; "SEQUENCE" - It might be a multidimensional array
1111
    (values 'sequence nil T))) ; "SEQUENCE" - It might be a multidimensional array
1087
1112
1113
(declaim (inline retuns-list-p))
1114
(cl:defun retuns-list-p (expr)
1115
  (or (null expr) (lister-p expr)))
1116
1088
(cl:defun lister-p (expr)
1117
(cl:defun lister-p (expr)
1089
  (when-bind (a (and (consp expr) (car expr)))
1118
  (when-bind (a (and (consp expr) (car expr)))
1090
    (case a
1119
    (case a
1091
      ((cons list list* 
1120
      ((cons list 
1092
  cdr cddr cdddr cddddr
1093
  cdar cddar cdddar
1094
  cdaar cddaar
1095
  cdaaar
1096
  cdadr cddadr
1097
  cdaddr
1098
  cdaadr
1099
    push pushnew
1121
    push pushnew
1100
    last
1122
    last
1101
    copy-list make-list append nconc member butlast nbutlast revappend nreconc
1123
    copy-list make-list append nconc member butlast nbutlast revappend nreconc
1102
    rplaca rplacd
1124
    rplaca rplacd
1103
  nthcdr rest
1104
    mapcar mapcan mapl maplist mapcon
1125
    mapcar mapcan mapl maplist mapcon
1105
    assoc pairlis acons copy-alist assoc-if assoc-if-not 
1126
    assoc pairlis acons copy-alist assoc-if assoc-if-not 
1106
    subst subst-if subst-if-not
1127
    subst subst-if subst-if-not
1107
    nsubst nsubst-if nsubst-if-not 
1128
    nsubst nsubst-if nsubst-if-not 
1108
    sublis nsublis
1129
    sublis nsublis
...
...
1113
      (collect (when (or (not (cadddr expr))
1134
      (collect (when (or (not (cadddr expr))
1114
             (case (decode-seq-type (caddr expr))
1135
             (case (decode-seq-type (caddr expr))
1115
               ((list bag set ordered-set) t)
1136
               ((list bag set ordered-set) t)
1116
               (t nil)))
1137
               (t nil)))
1117
         expr))
1138
         expr))
1139
      (list* (when (or (caddr expr) (retuns-list-p (cadr expr)))
1140
         expr))
1118
      (copy-seq (when (or (null (cadr expr))
1141
      (copy-seq (when (retuns-list-p (cadr expr))
1119
            (lister-p (cadr expr)))
1120
          expr))
1142
          expr))
1121
      (t nil))))
1143
      (t nil))))
1144
1145
1122
1146
1123
(cl:defun matching-scan-p (expr pred)
1147
(cl:defun matching-scan-p (expr pred)
1124
  (cl:let (a)
1148
  (cl:let (a)
1125
    (and (eq-car expr 'scan)
1149
    (and (eq-car expr 'scan)
1126
     (or (and (setq a (cadr expr))  (not (caddr expr)) (cl:funcall pred a))
1150
     (or (and (setq a (cadr expr))  (not (caddr expr)) (cl:funcall pred a))
...
...
2722
2746
2723
;;;                        ---- MACROEXPANSION TEMPLATES ----
2747
;;;                        ---- MACROEXPANSION TEMPLATES ----
2724
2748
2725
;; The following are the fns allowed in templates.
2749
;; The following are the fns allowed in templates.
2726
2750
2751
(cl:defun FUN (code) (if (not (consp code)) code (process-fn code)))
2752
2753
;; This handles binding lists for FLET.
2754
2755
(cl:defun fbind-list (args)
2756
  (mapcar #'FUN args))
2757
2758
;; This handles binding lists for LET.
2759
(cl:defun bind-list (args sequential &aux (pending nil))
2760
  (prog1 (mapcar #'(lambda (arg)
2761
                     (cl:let* ((val-p (and (consp arg) (cdr arg)))
2762
                 (new-val (when val-p
2763
                    (m-&-r1 (cadr arg))))
2764
                 (var (if (consp arg)
2765
                  (car arg)
2766
                    arg)))
2767
                       (if sequential
2768
             (push (list var) *renames*)
2769
           (push (list var) pending))
2770
                       (if val-p
2771
             (list (car arg) new-val)
2772
           arg)))
2773
                 args)
2774
    (setq *renames* (append pending *renames*))))
2775
2776
(cl:defun arg-list (args)
2777
  (mapcar #'(lambda (arg)
2778
              (cl:let* ((vars (vars-of arg))
2779
          (val-p (and (consp arg) (cdr arg)))
2780
          (new-val (when val-p
2781
                 (m-&-r1 (cadr arg)))))
2782
                (setq *renames* (append (mapcar #'list vars) *renames*))
2783
                (if val-p
2784
          (list* (car arg) new-val (cddr arg))
2785
        arg)))
2786
          args))
2787
2727
(cl:defun Q   (code) code)
2788
(cl:defun Q   (code) code)
2728
(cl:defun E   (code) (m-&-r1 code))
2789
(cl:defun E   (code) (m-&-r1 code))
2729
(cl:defun EX  (code)
2790
(cl:defun EX  (code)
2730
  (cl:let* ((*not-straight-line-code* *in-series-expr*)
2791
  (cl:let* ((*not-straight-line-code* *in-series-expr*)
2731
              (*in-series-expr* nil))
2792
              (*in-series-expr* nil))
...
...
2741
(cl:defun S   (code) (cl:let ((*being-setqed* T)) (m-&-r1 code)))
2802
(cl:defun S   (code) (cl:let ((*being-setqed* T)) (m-&-r1 code)))
2742
(cl:defun B   (code) (bind-list code nil))
2803
(cl:defun B   (code) (bind-list code nil))
2743
(cl:defun B*  (code) (bind-list code T))
2804
(cl:defun B*  (code) (bind-list code T))
2744
(cl:defun A   (code) (arg-list code))
2805
(cl:defun A   (code) (arg-list code))
2745
(cl:defun LAB (code) (if (symbolp code) code (EL code)))
2806
(cl:defun LAB (code) (if (symbolp code) code (EL code)))
2746
(cl:defun FUN (code) (if (not (consp code)) code (process-fn code)))
2807
(cl:defun F   (code) (fbind-list code))
2747
2748
;; This handles binding lists for LET.
2749
2750
(cl:defun bind-list (args sequential &aux (pending nil))
2751
  (prog1 (mapcar #'(lambda (arg)
2752
                     (cl:let* ((val-p (and (consp arg) (cdr arg)))
2753
                 (new-val (when val-p
2754
                    (m-&-r1 (cadr arg))))
2755
                 (var (if (consp arg)
2756
                  (car arg)
2757
                    arg)))
2758
                       (if sequential
2759
             (push (list var) *renames*)
2760
           (push (list var) pending))
2761
                       (if val-p
2762
             (list (car arg) new-val)
2763
           arg)))
2764
                 args)
2765
    (setq *renames* (append pending *renames*))))
2766
2767
(cl:defun arg-list (args)
2768
  (mapcar #'(lambda (arg)
2769
              (cl:let* ((vars (vars-of arg))
2770
          (val-p (and (consp arg) (cdr arg)))
2771
          (new-val (when val-p
2772
                 (m-&-r1 (cadr arg)))))
2773
                (setq *renames* (append (mapcar #'list vars) *renames*))
2774
                (if val-p
2775
          (list* (car arg) new-val (cddr arg))
2776
        arg)))
2777
          args))
2778
2808
2779
(cl:defun compiler-let-template (form)
2809
(cl:defun compiler-let-template (form)
2780
  (cl:let ((symbols (mapcar #'(lambda (p) (if (consp p) (car p) p)) (cadr form)))
2810
  (cl:let ((symbols (mapcar #'(lambda (p) (if (consp p) (car p) p)) (cadr form)))
2781
       (values (mapcar #'(lambda (p) (when (consp p) (eval (cadr p)))) (cadr form)))
2811
       (values (mapcar #'(lambda (p) (when (consp p) (eval (cadr p)))) (cadr form)))
2782
       (body (cddr form)))
2812
       (body (cddr form)))
...
...
2816
(deft                throw (Q)    (E))
2846
(deft                throw (Q)    (E))
2817
(deft       unwind-protect (Q)    (EL))
2847
(deft       unwind-protect (Q)    (EL))
2818
2848
2819
(deft               lambda (Q A)  (E))
2849
(deft               lambda (Q A)  (E))
2820
2850
2821
(deft                 flet (Q)    (E))
2851
(deft                 flet (F)    (E))
2822
(deft         compiler-let (Q)    (E))
2852
(deft         compiler-let (Q)    (E))
2823
(deft             macrolet (Q)    (E))
2853
(deft             macrolet (Q)    (E))
2824
(deft               labels (Q)    (E))
2854
(deft               labels (F)    (E))
2825
(deft                 type (Q Q)  (E))
2855
(deft                 type (Q Q)  (E))
2826
2856
2827
(deft                  setf (Q)    (E))   ;fixes weird interaction with lispm setf 
2857
(deft                  setf (Q)    (E))   ;fixes weird interaction with lispm setf 
2828
2858
2829
#+symbolics
2859
#+symbolics
...
...
3091
;; the image series.
3121
;; the image series.
3092
(cl:defun image-of-datum-th (g datum)
3122
(cl:defun image-of-datum-th (g datum)
3093
  (nth datum (basic-do-next-in g)))
3123
  (nth datum (basic-do-next-in g)))
3094
3124
3095
  (cl:defun values-lists (n series-of-lists &optional (alterers nil))
3125
  (cl:defun values-lists (n series-of-lists &optional (alterers nil))
3096
    (values-list
3126
    (multiple-value-polycall
3097
     (mapcar #'(lambda (i)
3127
      #'(lambda (i)
3098
                 (make-image-series :alter-fn (pop alterers)
3128
    (make-image-series :alter-fn (pop alterers)
3099
                                    :image-fn #'image-of-datum-th
3129
               :image-fn #'image-of-datum-th
3100
                                    :image-datum i
3130
               :image-datum i
3101
                                    :image-base series-of-lists))
3131
               :image-base series-of-lists))
3102
             (n-integers n))))
3132
      (n-integer-values n))))
3103
3133
3104
3134
3105
(cl:defun print-series (series stream depth)
3135
(cl:defun print-series (series stream depth)
3106
  (cl:let ((generator (generator series)))
3136
  (cl:let ((generator (generator series)))
3107
    (write-string "#Z(" stream)
3137
    (write-string "#Z(" stream)
...
...
3178
             (cadar arg)
3208
             (cadar arg)
3179
           (car arg))
3209
           (car arg))
3180
                 (copy-list (cddr arg))))))
3210
                 (copy-list (cddr arg))))))
3181
3211
3182
;; Important that this allows extra args and doesn't check.
3212
;; Important that this allows extra args and doesn't check.
3183
(cl:defun funcall-frag (frag values)
3213
(cl:defun apply-frag (frag values)
3184
  (mapc #'(lambda (v a) (+dflow (retify v) a)) values (args frag))
3214
  (mapc #'(lambda (v a) (+dflow (retify v) a)) values (args frag))
3185
  (+frag frag))
3215
  (+frag frag))
3186
3216
3187
3217
(cl:defun funcall-frag (frag &rest values)
3218
  (apply-frag frag values))
3188
3219
3189
;; Macroexpansion may result in unexpected arcana we should let through.
3220
;; Macroexpansion may result in unexpected arcana we should let through.
3190
(defconstant /allowed-generic-opts/ 
3221
(defconstant /allowed-generic-opts/ 
3191
    (cons 'optimize 
3222
    (cons 'optimize 
3192
          #+:lispworks '(CLOS::VARIABLE-REBINDING)
3223
          #+:lispworks '(CLOS::VARIABLE-REBINDING)
...
...
4657
           ;; BUG: Try to hack it through MAKE-SEQUENCE.  This could fail.
4688
           ;; BUG: Try to hack it through MAKE-SEQUENCE.  This could fail.
4658
       #+:ignore    
4689
       #+:ignore    
4659
           (aref (make-sequence `(vector ,var-type) 1) 0)))))
4690
           (aref (make-sequence `(vector ,var-type) 1) 0)))))
4660
4691
4661
(cl:defun aux-init (aux)
4692
(cl:defun aux-init (aux)
4662
  (destructuring-bind (var-name &optional (var-type T) &optional (var-value nil value-provided-p))
4693
  (destructuring-bind (var-name &optional (var-type T) (var-value nil value-provided-p))
4663
      aux
4694
      aux
4664
    (list var-name (if value-provided-p
4695
    (list var-name (if value-provided-p
4665
               var-value
4696
               var-value
4666
             (init-elem var-type)))))
4697
             (init-elem var-type)))))
4667
4698
...
...
4750
  (doaux (v aux)
4781
  (doaux (v aux)
4751
    (propagate-types (cdr v) aux))
4782
    (propagate-types (cdr v) aux))
4752
  (3mapaux #'(lambda (v)
4783
  (3mapaux #'(lambda (v)
4753
          (if (atom v)
4784
          (if (atom v)
4754
          (values v nil nil)
4785
          (values v nil nil)
4755
        (destructuring-bind (var-name &optional (typ T) &optional (var-value nil value-provided-p))
4786
        (destructuring-bind (var-name &optional (typ T) (var-value nil value-provided-p))
4756
            v
4787
            v
4757
          ;; Sometimes the desired type is quoted.  Remove the
4788
          ;; Sometimes the desired type is quoted.  Remove the
4758
                  ;; quote.  (Is this right?)       
4789
                  ;; quote.  (Is this right?)       
4759
          (when (and (listp typ)
4790
          (when (and (listp typ)
4760
                 (eq 'quote (car typ)))
4791
                 (eq 'quote (car typ)))
...
...
5106
                   "~%OPTIMIZABLE-SERIES-FUNCTION neither uses nor returns a series."))
5137
                   "~%OPTIMIZABLE-SERIES-FUNCTION neither uses nor returns a series."))
5107
            `(,name ,(reverse rev-arglist)
5138
            `(,name ,(reverse rev-arglist)
5108
               ,(if (not dcls) doc (cons doc `(declare . ,dcls)))
5139
               ,(if (not dcls) doc (cons doc `(declare . ,dcls)))
5109
               ,(frag->physical frag used-vars)
5140
               ,(frag->physical frag used-vars)
5110
               :optimizer
5141
               :optimizer
5111
               (funcall-frag (list->frag1 ',frag-list) (list ,@ used-vars))
5142
               (apply-frag (list->frag1 ',frag-list) (list ,@ used-vars))
5112
               :trigger ,(not series-p)))))
5143
               :trigger ,(not series-p)))))
5113
      (cl:multiple-value-bind (forms decls doc)
5144
      (cl:multiple-value-bind (forms decls doc)
5114
          (decode-dcls expr-list '(no-complaints doc opts))
5145
          (decode-dcls expr-list '(no-complaints doc opts))
5115
        `(,name ,lambda-list
5146
        `(,name ,lambda-list
5116
           ,@(when doc (list doc))
5147
           ,@(when doc (list doc))
...
...
5288
    
5319
    
5289
) ;end of eval-when for defS
5320
) ;end of eval-when for defS
5290
5321
5291
;;;;                          ---- fragL ----
5322
;;;;                          ---- fragL ----
5292
5323
5293
(cl:defun funcall-literal-frag (frag-and-values)
5324
(cl:defun apply-literal-frag (frag-and-values)
5294
  (funcall-frag (literal-frag (car frag-and-values)) (cdr frag-and-values)))
5325
  (apply-frag (literal-frag (car frag-and-values)) (cdr frag-and-values)))
5295
5326
5296
(eval-when (:compile-toplevel :load-toplevel :execute)
5327
(eval-when (:compile-toplevel :load-toplevel :execute)
5297
5328
5298
;; this forms are useful for making code that comes out one way in the
5329
;; this forms are useful for making code that comes out one way in the
5299
;; body and another way in the optimizer
5330
;; body and another way in the optimizer
...
...
5303
5334
5304
(defmacro non-optq (x) `(opt-non-opt ,x (list 'quote ,x)))
5335
(defmacro non-optq (x) `(opt-non-opt ,x (list 'quote ,x)))
5305
5336
5306
(defmacro optq (x) `(opt-non-opt ',x ,x))
5337
(defmacro optq (x) `(opt-non-opt ',x ,x))
5307
5338
5339
(cl:defun apply-physical-frag (stuff args)
5340
  (frag->physical (literal-frag stuff)
5341
        args))
5342
5343
(declaim (inline unopt-fragl))
5308
(cl:defun unopt-fragl (stuff)
5344
(cl:defun unopt-fragl (stuff)
5309
  (frag->physical (literal-frag stuff)
5345
  (apply-physical-frag stuff (mapcar #'car (car stuff))))   
5310
        (mapcar #'car (car stuff))))
5311
5346
5312
(cl:defun opt-fragl (stuff inputs)
5347
(cl:defun opt-fragl (stuff inputs)
5313
  `(funcall-literal-frag
5348
  `(apply-literal-frag
5314
     (list ,stuff
5349
     (list ,stuff
5315
       ,@inputs)))
5350
       ,@inputs)))
5316
5351
5352
(cl:defun fragL-2 (stuff args)
5353
  (if *optimize-series-expressions*
5354
      (opt-fragl `(quote ,stuff) args)
5355
    (apply-physical-frag stuff args)))
5356
5357
#|
5358
(cl:defun fragL-2 (stuff args)
5359
  (if *optimize-series-expressions*
5360
      `(apply-literal-frag (list (quote ,stuff) ,args))
5361
    (apply-physical-frag stuff args)))
5362
|#
5363
5364
(cl:defmacro efragL (a stuff)
5365
  (if *optimize-series-expressions*     
5366
      `(funcall-frag (literal-frag (cons ',a ,stuff)) ,@(mapcar #'car a))
5367
    `(apply-physical-frag (cons ',a ,stuff) (mapcar #'car ',a))))
5368
5369
(declaim (inline fragL-1))
5317
(cl:defun fragL-1 (stuff)
5370
(cl:defun fragL-1 (stuff)
5318
  (if *optimize-series-expressions*
5319
      (opt-fragl `(quote ,stuff) (mapcar #'car (car stuff)))
5371
  (fragL-2 stuff (mapcar #'car (car stuff))))
5320
    (unopt-fragl stuff)))
5321
5372
5322
(cl:defun sublis-limits (tree)
5373
(cl:defun sublis-limits (tree)
5323
  (sublis `((*limit*                . ,most-positive-fixnum)
5374
  (sublis `((*limit*                . ,most-positive-fixnum)
5324
        (most-positive-fixnum   . ,most-positive-fixnum)
5375
        (most-positive-fixnum   . ,most-positive-fixnum)
5325
        (array-total-size-limit . ,array-total-size-limit)
5376
        (array-total-size-limit . ,array-total-size-limit)
...
...
5461
       ;; optimize better.
5512
       ;; optimize better.
5462
       (setq *type* (if (eq *type* 'simple-array)
5513
       (setq *type* (if (eq *type* 'simple-array)
5463
                (list *type* el-type '(*))
5514
                (list *type* el-type '(*))
5464
              (list *type* el-type)))
5515
              (list *type* el-type)))
5465
       (bind-if* (l (matching-scan-p items #'lister-p))
5516
       (bind-if* (l (matching-scan-p items #'lister-p))
5466
             (funcall-literal-frag
5517
             (apply-literal-frag
5467
               `((() ((seq)) 
5518
               `((() ((seq)) 
5468
              ((seq (null-or ,*type*)))
5519
              ((seq (null-or ,*type*)))
5469
              ()
5520
              ()
5470
              ()
5521
              ()
5471
              ()
5522
              ()
...
...
5918
;; Helping functions
5969
;; Helping functions
5919
5970
5920
(cl:defun list-of-next (at-end list-of-generators)
5971
(cl:defun list-of-next (at-end list-of-generators)
5921
 (mapcar #'(lambda (g) (do-next-in g at-end)) list-of-generators))
5972
 (mapcar #'(lambda (g) (do-next-in g at-end)) list-of-generators))
5922
5973
5974
(cl:defun values-of-next (at-end list-of-generators)
5975
 (polyapply #'(lambda (g) (do-next-in g at-end)) list-of-generators))
5976
5923
;; HELPER
5977
;; HELPER
5924
;;
5978
;;
5925
;; If function is not a simple quoted function, then a non-series
5979
;; If function is not a simple quoted function, then a non-series
5926
;; input is added to frag, and a parameter is added to params so that
5980
;; input is added to frag, and a parameter is added to params so that
5927
;; the function will get processed right.
5981
;; the function will get processed right.
...
...
6002
           (fragL ((function) (args)) ((items T))
6056
           (fragL ((function) (args)) ((items T))
6003
                  ((items T)
6057
                  ((items T)
6004
           (list-of-generators list #+:series-letify (mapcar #'generator args)))
6058
           (list-of-generators list #+:series-letify (mapcar #'generator args)))
6005
          ()
6059
          ()
6006
          (#-:series-letify (setq list-of-generators (mapcar #'generator args)))
6060
          (#-:series-letify (setq list-of-generators (mapcar #'generator args)))
6007
                  ((setq items (apply function (list-of-next #'(lambda () (go end))
6061
                  ((setq items (cl:multiple-value-call function
6008
                                              list-of-generators))))
6062
                             (values-of-next #'(lambda () (go end))
6063
                                     list-of-generators))))
6009
          ()
6064
          ()
6010
          ()
6065
          ()
6011
          :fun ; Assumes impure function for now
6066
          :fun ; Assumes impure function for now
6012
          ))
6067
          ))
6013
          (T (values-lists n (apply #'map-fn T
6068
          (T (values-lists n (apply #'map-fn T
...
...
6030
      (handle-fn-arg frag function params))
6085
      (handle-fn-arg frag function params))
6031
    (setq params (mapcar #'retify (nconc params args)))
6086
    (setq params (mapcar #'retify (nconc params args)))
6032
    (dolist (var in-vars)
6087
    (dolist (var in-vars)
6033
      (+arg (make-sym :var var :series-var-p T) frag))
6088
      (+arg (make-sym :var var :series-var-p T) frag))
6034
    (setf (body frag) (handle-fn-call frag out-vars function in-vars t))
6089
    (setf (body frag) (handle-fn-call frag out-vars function in-vars t))
6035
    (funcall-frag frag params)))
6090
    (apply-frag frag params)))
6036
6091
6037
;; OPTIMIZER
6092
;; OPTIMIZER
6038
(cl:defun scan-fn-opt (wrap-fn inclusive-p type init step
6093
(cl:defun scan-fn-opt (wrap-fn inclusive-p type init step
6039
                                 &optional (test nil test-p))
6094
                                 &optional (test nil test-p))
6040
  (cl:let* ((types (decode-type-arg (must-be-quoted type)))
6095
  (cl:let* ((types (decode-type-arg (must-be-quoted type)))
...
...
6070
      (setf (body frag)
6125
      (setf (body frag)
6071
        `((if ,done (go ,END))
6126
        `((if ,done (go ,END))
6072
          ,(car (handle-fn-call frag (list done) test state-vars t))
6127
          ,(car (handle-fn-call frag (list done) test state-vars t))
6073
          ,output-expr
6128
          ,output-expr
6074
          (if (not ,done) ,step-code))))))
6129
          (if (not ,done) ,step-code))))))
6075
    (funcall-frag frag params)))
6130
    (apply-frag frag params)))
6076
6131
6077
;; OPTIMIZER
6132
;; OPTIMIZER
6078
(cl:defun collect-fn-opt (wrap-fn type inits function &rest args)
6133
(cl:defun collect-fn-opt (wrap-fn type inits function &rest args)
6079
  (declare (type list args))
6134
  (declare (type list args))
6080
  (cl:let* ((types (decode-type-arg (must-be-quoted type)))
6135
  (cl:let* ((types (decode-type-arg (must-be-quoted type)))
...
...
6096
      (+arg (make-sym :var var :series-var-p T)
6151
      (+arg (make-sym :var var :series-var-p T)
6097
            frag)) ;must be before other possible args
6152
            frag)) ;must be before other possible args
6098
    (setf (prolog frag) (makeprolog (handle-fn-call frag out-vars inits nil)))
6153
    (setf (prolog frag) (makeprolog (handle-fn-call frag out-vars inits nil)))
6099
    (setf (body frag)
6154
    (setf (body frag)
6100
          (handle-fn-call frag out-vars function (append out-vars in-vars) t))
6155
          (handle-fn-call frag out-vars function (append out-vars in-vars) t))
6101
    (funcall-frag frag params)))
6156
    (apply-frag frag params)))
6102
6157
6103
;; needed because collect is a macro
6158
;; needed because collect is a macro
6104
(cl:defun basic-collect-list (items)
6159
(cl:defun basic-collect-list (items)
6105
  (compiler-let ((*optimize-series-expressions* nil))
6160
  (compiler-let ((*optimize-series-expressions* nil))
6106
    (fragL ((items T)) ((lst))
6161
    (fragL ((items T)) ((lst))
...
...
6112
       ((setq lastcons (setf (cdr lastcons) (cons items nil))))    
6167
       ((setq lastcons (setf (cdr lastcons) (cons items nil))))    
6113
           ((setq lst (cdr lst)))
6168
           ((setq lst (cdr lst)))
6114
       ()
6169
       ()
6115
       nil
6170
       nil
6116
       )))
6171
       )))
6172
6173
(cl:defun scan-multi-out->scan-list-out (fn type init step test)
6174
  (compiler-let ((*optimize-series-expressions* nil))
6175
    (cl:let ((n (length (decode-type-arg type))))
6176
      (cl:flet ((new-init () (forceL n (multiple-value-list (cl:funcall init))))
6177
      (new-step (state) (forceL n (multiple-value-list (apply step state))))
6178
      (new-test (state) (apply test state)))
6179
  (declare (indefinite-extent #'new-init #'new-step #'new-test))
6180
        (cl:funcall fn T #'new-init #'new-step #'new-test)))))
6117
6181
6118
(defmacro encapsulated-macro (encapsulating-fn scanner-or-collector)
6182
(defmacro encapsulated-macro (encapsulating-fn scanner-or-collector)
6119
  (when (not (eq-car encapsulating-fn 'function))
6183
  (when (not (eq-car encapsulating-fn 'function))
6120
    (ers 68 "~%First ENCAPSULATING arg " encapsulating-fn
6184
    (ers 68 "~%First ENCAPSULATING arg " encapsulating-fn
6121
         " is not quoted function."))
6185
         " is not quoted function."))
...
...
6155
6219
6156
 :trigger T
6220
 :trigger T
6157
 :discriminator (or (eq-car (caddr call) 'scan-fn)
6221
 :discriminator (or (eq-car (caddr call) 'scan-fn)
6158
                    (eq-car (caddr call) 'scan-fn-inclusive)))
6222
                    (eq-car (caddr call) 'scan-fn-inclusive)))
6159
6223
6160
(cl:defun scan-multi-out->scan-list-out (fn type init step test)
6161
  (compiler-let ((*optimize-series-expressions* nil))
6162
    (cl:let ((n (length (decode-type-arg type))))
6163
      (cl:flet ((new-init () (forceL n (multiple-value-list (cl:funcall init))))
6164
             (new-step (state) (forceL n (multiple-value-list (apply step state))))
6165
             (new-test (state) (apply test state)))
6166
  (declare (indefinite-extent #'new-init #'new-step #'new-test))
6167
        (cl:funcall fn T #'new-init #'new-step #'new-test)))))
6168
6169
;;needed because collect-fn is macro
6224
;;needed because collect-fn is macro
6170
(cl:defun basic-collect-fn (inits function &rest args)
6225
(cl:defun basic-collect-fn (inits function &rest args)
6171
  (declare (dynamic-extent args))     
6226
  (declare (dynamic-extent args))     
6172
  (declare (type list args))
6227
  (declare (type list args))
6173
  (compiler-let ((*optimize-series-expressions* nil))
6228
  (compiler-let ((*optimize-series-expressions* nil))
6174
    (fragL ((inits) (function) (args)) ((result))
6229
    (funcase (fun inits)
6230
      ((name anonymous)
6231
       (efragL ((function) (args))
6232
        `(((result))
6233
      ((result t (,(if (symbolp fun) fun (process-fn fun))))
6234
       (list-of-generators list #+:series-letify (mapcar #'generator args)))
6235
      ()
6236
      (#-:series-letify (setq list-of-generators (mapcar #'generator args)))
6237
      ((setq result (cl:multiple-value-call function
6238
                            result
6239
                            (values-of-next #'(lambda () (go end))
6240
                                    list-of-generators))))
6241
      ()
6242
      ()
6243
      :fun            ; assumes function is impure for now
6244
      )))
6245
      (t
6246
       (funcase (f function)
6247
   ((name anonymous)
6248
    (efragL ((inits) (args)) 
6249
        `(((result))
6175
           ((result t (cl:funcall inits))
6250
          ((result t (cl:funcall inits))
6176
        (list-of-generators list #+:series-letify (mapcar #'generator args)))
6251
           (list-of-generators list #+:series-letify (mapcar #'generator args)))
6177
       ()
6252
          ()
6178
       (#-:series-letify (setq list-of-generators (mapcar #'generator args)))
6253
          (#-:series-letify (setq list-of-generators (mapcar #'generator args)))
6179
           ((cl:let ((vals (list-of-next #'(lambda () (go end))
6254
          ((setq result (cl:multiple-value-call (function ,f)
6180
                                           list-of-generators)))
6255
                            result
6181
              (setq result (apply function result vals))))
6256
                            (values-of-next #'(lambda () (go end))
6257
                                    list-of-generators))))
6182
       ()
6258
          ()
6183
       ()
6259
          ()
6184
       :fun ; assumes function is impure for now
6260
          :fun     ; assumes function is impure for now
6185
       )))
6261
          )))
6262
   (t
6263
    (fragL ((inits) (function) (args))
6264
       ((result))
6265
       ((result t (cl:funcall inits))
6266
        (list-of-generators list #+:series-letify (mapcar #'generator args)))
6267
       ()
6268
       (#-:series-letify (setq list-of-generators (mapcar #'generator args)))
6269
       ((setq result (cl:multiple-value-call function
6270
                             result
6271
                             (values-of-next #'(lambda () (go end))
6272
                                     list-of-generators))))
6273
       ()
6274
       ()
6275
       :fun           ; assumes function is impure for now
6276
       )))))))
6186
6277
6187
;; API
6278
;; API
6188
(defS collect-fn (type inits function &rest args)
6279
(defS collect-fn (type inits function &rest args)
6189
   "Computes a cumulative value by applying FUNCTION to the elements of ITEMS."
6280
   "Computes a cumulative value by applying FUNCTION to the elements of ITEMS."
6190
  (cl:let ((n (length (decode-type-arg type))))
6281
  (cl:let ((n (length (decode-type-arg type))))
...
...
6215
                  ((result T #+:series-letify (cl:funcall inits))
6306
                  ((result T #+:series-letify (cl:funcall inits))
6216
           (list-of-generators list #+:series-letify (mapcar #'generator args)))
6307
           (list-of-generators list #+:series-letify (mapcar #'generator args)))
6217
          ()
6308
          ()
6218
          (#-:series-letify (setq result (cl:funcall inits))
6309
          (#-:series-letify (setq result (cl:funcall inits))
6219
           #-:series-letify (setq list-of-generators (mapcar #'generator args)))
6310
           #-:series-letify (setq list-of-generators (mapcar #'generator args)))
6220
                  ((cl:let ((vals (list-of-next #'(lambda () (go end))
6311
                  ((setq result (cl:multiple-value-call function
6221
                                                  list-of-generators)))
6312
                          result
6222
                     (setq result (apply function result vals))))
6313
                          (values-of-next #'(lambda () (go end))
6314
                                  list-of-generators))))
6223
          ()
6315
          ()
6224
          ()
6316
          ()
6225
          :fun ; assumes function is impure for now
6317
          :fun ; assumes function is impure for now
6226
          ))
6318
          ))
6227
          (T (values-lists n
6319
          (T (values-lists n
...
...
6250
    (dolist (var in-vars)
6342
    (dolist (var in-vars)
6251
      (+arg (make-sym :var var :series-var-p T) frag))
6343
      (+arg (make-sym :var var :series-var-p T) frag))
6252
    (setf (prolog frag) (makeprolog (handle-fn-call frag out-vars inits nil)))
6344
    (setf (prolog frag) (makeprolog (handle-fn-call frag out-vars inits nil)))
6253
    (setf (body frag)
6345
    (setf (body frag)
6254
          (handle-fn-call frag out-vars function (append out-vars in-vars) t))
6346
          (handle-fn-call frag out-vars function (append out-vars in-vars) t))
6255
    (funcall-frag frag params)))
6347
    (apply-frag frag params)))
6256
6348
6257
;; API
6349
;; API
6258
(defS scan-fn (type init step &optional (test nil test-p))
6350
(defS scan-fn (type init step &optional (test nil test-p))
6259
  "Enumerates a series"
6351
  "Enumerates a series"
6260
  (cl:let ((n (length (decode-type-arg type))))
6352
  (cl:let ((n (length (decode-type-arg type))))
...
...
6729
                   nil ; series dataflow constraint takes care
6821
                   nil ; series dataflow constraint takes care
6730
                   ))))
6822
                   ))))
6731
      (unless form
6823
      (unless form
6732
        (ers 65 "~%Alter applied to an unalterable series:~%" *call*)) 
6824
        (ers 65 "~%Alter applied to an unalterable series:~%" *call*)) 
6733
      (setf (body frag) (list (subst (var (cadr (args frag))) '*alt* form)))
6825
      (setf (body frag) (list (subst (var (cadr (args frag))) '*alt* form)))
6734
      (funcall-frag frag (list ret items))))
6826
      (apply-frag frag (list ret items))))
6735
  :trigger T)
6827
  :trigger T)
6736
6828
6737
;; API
6829
;; API
6738
(defS to-alter (series alter-function &rest other-inputs)
6830
(defS to-alter (series alter-function &rest other-inputs)
6739
  "Specifies how to alter SERIES."
6831
  "Specifies how to alter SERIES."
...
...
6767
              (push `(setq ,state-var ,in-var) (body frag)))
6859
              (push `(setq ,state-var ,in-var) (body frag)))
6768
          input-vars state-vars)
6860
          input-vars state-vars)
6769
    (setq params (append params other-inputs))
6861
    (setq params (append params other-inputs))
6770
    (setf (alterable frag)
6862
    (setf (alterable frag)
6771
          `((,var (cl:funcall ,alter-function *alt* ,@ state-vars) ,@ state-vars)))
6863
          `((,var (cl:funcall ,alter-function *alt* ,@ state-vars) ,@ state-vars)))
6772
    (funcall-frag frag params)))
6864
    (apply-frag frag params)))
6773
6865
6774
;; API
6866
;; API
6775
(defS series (expr &rest expr-list)
6867
(defS series (expr &rest expr-list)
6776
  "Creates an infinite series of the results of the expressions."
6868
  "Creates an infinite series of the results of the expressions."
6777
  (cond ((null expr-list)
6869
  (cond ((null expr-list)
...
...
7202
                (mapcar #'alter-fn items-list))
7294
                (mapcar #'alter-fn items-list))
7203
 :optimizer
7295
 :optimizer
7204
  (cl:let* ((args (copy-list items-list))
7296
  (cl:let* ((args (copy-list items-list))
7205
        (vars (n-gensyms (length args) "COTRUNC-"))
7297
        (vars (n-gensyms (length args) "COTRUNC-"))
7206
        (ports (mapcar #'(lambda (v) (list v t)) vars)))
7298
        (ports (mapcar #'(lambda (v) (list v t)) vars)))
7207
    (funcall-frag
7299
    (apply-frag
7208
      (literal-frag `(,ports ,(copy-list ports) nil nil nil nil nil nil nil))
7300
      (literal-frag `(,ports ,(copy-list ports) nil nil nil nil nil nil nil))
7209
      args)))
7301
      args)))
7210
7302
7211
;; API
7303
;; API
7212
(defS scan* (seq-type seq)
7304
(defS scan* (seq-type seq)
...
...
7471
     ()
7563
     ()
7472
     :context) ; file can change
7564
     :context) ; file can change
7473
                   ; Movement should only be allowed if no unknown functions
7565
                   ; Movement should only be allowed if no unknown functions
7474
                   ; and constrained by sync and file operations
7566
                   ; and constrained by sync and file operations
7475
 :optimizer
7567
 :optimizer
7476
  (funcall-literal-frag
7568
  (apply-literal-frag
7477
    (cl:let ((file (new-var 'file)))
7569
    (cl:let ((file (new-var 'file)))
7478
      `((((reader)) ((items T))
7570
      `((((reader)) ((items T))
7479
     ((items t) (done t (list nil)))
7571
     ((items t) (done t (list nil)))
7480
     ()
7572
     ()
7481
         ()
7573
         ()
...
...
7513
     ()
7605
     ()
7514
     ()
7606
     ()
7515
     :mutable ; stream can change - OK if scan-private stream
7607
     :mutable ; stream can change - OK if scan-private stream
7516
     )
7608
     )
7517
 :optimizer
7609
 :optimizer
7518
  (funcall-literal-frag
7610
  (apply-literal-frag
7519
   `((((reader)) ((items T))
7611
   `((((reader)) ((items T))
7520
      ((items t) (done t (list nil)))
7612
      ((items t) (done t (list nil)))
7521
      ()
7613
      ()
7522
      ()
7614
      ()
7523
      ((if (eq (setq items (cl:funcall reader ,name nil done)) done)
7615
      ((if (eq (setq items (cl:funcall reader ,name nil done)) done)
...
...
7553
         ()
7645
         ()
7554
     ()
7646
     ()
7555
     :mutable ; table can change - OK if scan-private table
7647
     :mutable ; table can change - OK if scan-private table
7556
     )
7648
     )
7557
#+symbolics :optimizer #+symbolics
7649
#+symbolics :optimizer #+symbolics
7558
  (funcall-literal-frag
7650
  (apply-literal-frag
7559
    `((((table)) ((keys T) (values T))
7651
    `((((table)) ((keys T) (values T))
7560
       ((state T nil) (keys T) (values T))
7652
       ((state T nil) (keys T) (values T))
7561
       ()
7653
       ()
7562
       ()
7654
       ()
7563
       ((if (not (multiple-value-setq (state keys values)
7655
       ((if (not (multiple-value-setq (state keys values)
...
...
7655
       (mapcar #'(lambda (i) (until1 bools i)) (cons items-1 items-i))))
7747
       (mapcar #'(lambda (i) (until1 bools i)) (cons items-1 items-i))))
7656
 :optimizer
7748
 :optimizer
7657
  (cl:let ((extra-ins (mapcar #'(lambda (x) (declare (ignore x))
7749
  (cl:let ((extra-ins (mapcar #'(lambda (x) (declare (ignore x))
7658
                                          (list (gensym "ITEMS") T))
7750
                                          (list (gensym "ITEMS") T))
7659
                                items-i)))
7751
                                items-i)))
7660
    (funcall-literal-frag
7752
    (apply-literal-frag
7661
      (list* `(((bools T) (items T) ,@ extra-ins)
7753
      (list* `(((bools T) (items T) ,@ extra-ins)
7662
               ((items T) ,@(copy-tree extra-ins))
7754
               ((items T) ,@(copy-tree extra-ins))
7663
               () ()
7755
               () ()
7664
               () ((if bools (go END))) () () nil)
7756
               () ((if bools (go END))) () () nil)
7665
             bools items-1 items-i))))
7757
             bools items-1 items-i))))
...
...
7688
      (+arg (make-sym :var var :series-var-p T) frag)
7780
      (+arg (make-sym :var var :series-var-p T) frag)
7689
      (+ret (make-sym :var var :series-var-p T) frag))
7781
      (+ret (make-sym :var var :series-var-p T) frag))
7690
    (setf (body frag)
7782
    (setf (body frag)
7691
          `((if ,(car (handle-fn-call frag nil pred (list (car item-vars)) t))
7783
          `((if ,(car (handle-fn-call frag nil pred (list (car item-vars)) t))
7692
                (go ,END))))
7784
                (go ,END))))
7693
    (funcall-frag frag params)))
7785
    (apply-frag frag params)))
7694
7786
7695
;; API
7787
;; API
7696
(defS positions (bools)
7788
(defS positions (bools)
7697
    "Returns a series of the positions of non-null elements in bools."
7789
    "Returns a series of the positions of non-null elements in bools."
7698
  (fragL ((bools T -X-)) ((index T)) ((index fixnum -1))
7790
  (fragL ((bools T -X-)) ((index T)) ((index fixnum -1))
...
...
7731
                  () (L -X- (if (not bools) (go L))) () () nil))))
7823
                  () (L -X- (if (not bools) (go L))) () () nil))))
7732
7824
7733
;; API
7825
;; API
7734
(defS choose-if (pred items)
7826
(defS choose-if (pred items)
7735
    "Chooses the elements of ITEMS for which PRED is non-null."
7827
    "Chooses the elements of ITEMS for which PRED is non-null."
7828
  (funcase (fun pred)
7829
    ((name anonymous)
7830
     (efragL ((items T -X-))
7831
       `(((items T)) () ()
7832
         ()
7833
         (L -X- (if (not (,(if (symbolp fun) fun (process-fn fun)) items))
7834
            (go L)))
7835
         () () nil)))
7836
    (t
7736
  (fragL ((pred) (items T -X-)) ((items T)) () ()
7837
     (fragL ((pred) (items T -X-)) ((items T)) () ()
7737
         () (L -X- (if (not (cl:funcall pred items)) (go L))) () () nil))
7838
      () (L -X- (if (not (cl:funcall pred items)) (go L))) () () nil))))
7738
7839
7739
;; API
7840
;; API
7740
(defS expand (bools items &optional (default nil))
7841
(defS expand (bools items &optional (default nil))
7741
    "Spreads the elements of ITEMS out into the indicated positions."
7842
    "Spreads the elements of ITEMS out into the indicated positions."
7742
  (fragL ((bools T) (items T -X-) (default)) ((expanded T))
7843
  (fragL ((bools T) (items T -X-) (default)) ((expanded T))
...
...
7884
    (cl:let ((-X- (new-var '-Y-)))
7985
    (cl:let ((-X- (new-var '-Y-)))
7885
      (+ret (make-sym :var ivar :series-var-p T :off-line-spot -X-) frag)
7986
      (+ret (make-sym :var ivar :series-var-p T :off-line-spot -X-) frag)
7886
      (setf (body frag)
7987
      (setf (body frag)
7887
            `(,@(body frag)
7988
            `(,@(body frag)
7888
               ,-X- ,D)))
7989
               ,-X- ,D)))
7889
    (funcall-frag frag (cons items stuff))))
7990
    (apply-frag frag (cons items stuff))))
7890
7991
7891
;; API
7992
;; API
7892
(defS split (items bools &rest more-bools)
7993
(defS split (items bools &rest more-bools)
7893
    "Divides a series into multiple outputs based on BOOLS."
7994
    "Divides a series into multiple outputs based on BOOLS."
7894
  (cl:let* ((pos-lists
7995
  (cl:let* ((pos-lists
...
...
7968
                                           `(,v ,(copy-list
8069
                                           `(,v ,(copy-list
7969
                                                   '(series-element-type in))))
8070
                                                   '(series-element-type in))))
7970
                                       vars))
8071
                                       vars))
7971
                        (setqs (mapcar #'(lambda (u v) (list 'setq u v))
8072
                        (setqs (mapcar #'(lambda (u v) (list 'setq u v))
7972
                                       vars (cdr vars))))
8073
                                       vars (cdr vars))))
7973
              (funcall-frag
8074
              (apply-frag
7974
               (literal-frag
8075
               (literal-frag
7975
                `(((in T -X-)) ,outs ((count fixnum) ,@ auxes) ()
8076
                `(((in T -X-)) ,outs ((count fixnum) ,@ auxes) ()
7976
                  ((setq count ,(1- m)))
8077
                  ((setq count ,(1- m)))
7977
                  (L -X- ,@ setqs (setq ,(car (last vars)) in)
8078
                  (L -X- ,@ setqs (setq ,(car (last vars)) in)
7978
                     (cond ((plusp count) (decf count) (go L))
8079
                     (cond ((plusp count) (decf count) (go L))
...
...
8029
     ((table T #+:series-letify (apply #'make-hash-table option-plist)))
8130
     ((table T #+:series-letify (apply #'make-hash-table option-plist)))
8030
     ()
8131
     ()
8031
         (#-:series-letify (setq table (apply #'make-hash-table option-plist)))
8132
         (#-:series-letify (setq table (apply #'make-hash-table option-plist)))
8032
         ((setf (gethash keys table) values)) () () nil)
8133
         ((setf (gethash keys table) values)) () () nil)
8033
 :optimizer
8134
 :optimizer
8034
  (funcall-literal-frag
8135
  (apply-literal-frag
8035
    (list '(((keys T) (values T) (table)) ((table)) () ()
8136
    (list '(((keys T) (values T) (table)) ((table)) () ()
8036
            () ((setf (gethash keys table) values)) () () nil)
8137
            () ((setf (gethash keys table) values)) () () nil)
8037
          keys values `(make-hash-table ,@ option-plist)))
8138
          keys values `(make-hash-table ,@ option-plist)))
8038
 :trigger T)
8139
 :trigger T)
8039
8140
...
...
8053
              (cl:funcall printer item f))))
8154
              (cl:funcall printer item f))))
8054
     ()
8155
     ()
8055
     :context
8156
     :context
8056
     )
8157
     )
8057
 :optimizer
8158
 :optimizer
8058
  (funcall-literal-frag
8159
  (apply-literal-frag
8059
    (cl:let ((file (new-var 'outfile)))
8160
    (cl:let ((file (new-var 'outfile)))
8060
      `((((items T) (printer)) ((out)) 
8161
      `((((items T) (printer)) ((out)) 
8061
         ((out boolean T))
8162
         ((out boolean T))
8062
     ()
8163
     ()
8063
         ()
8164
         ()
...
...
8084
            (cl:funcall printer item name)))
8185
            (cl:funcall printer item name)))
8085
     ()
8186
     ()
8086
     :context
8187
     :context
8087
     )
8188
     )
8088
 :optimizer
8189
 :optimizer
8089
  (funcall-literal-frag
8190
  (apply-literal-frag
8090
   `((((items T) (printer)) (()) () ()
8191
   `((((items T) (printer)) (()) () ()
8091
      () ((cl:funcall printer items ,name)) ()
8192
      () ((cl:funcall printer items ,name)) ()
8092
      ((#'(lambda (c)
8193
      ((#'(lambda (c)
8093
           c) :loop))
8194
           c) :loop))
8094
      :context
8195
      :context
...
...
8192
     ()
8293
     ()
8193
     (#-:series-letify (setq sum (coerce 0 type)))
8294
     (#-:series-letify (setq sum (coerce 0 type)))
8194
         ((setq sum (+ sum numbers)))
8295
         ((setq sum (+ sum numbers)))
8195
     () () nil)
8296
     () () nil)
8196
 :optimizer
8297
 :optimizer
8197
  (funcall-literal-frag
8298
  (apply-literal-frag
8198
    `((((numbers T)) ((sum)) 
8299
    `((((numbers T)) ((sum)) 
8199
       ((sum ,(must-be-quoted type) ,(coerce 0 (must-be-quoted type)))) ()
8300
       ((sum ,(must-be-quoted type) ,(coerce 0 (must-be-quoted type)))) ()
8200
       ()
8301
       ()
8201
       ((setq sum (+ sum numbers))) () () nil)
8302
       ((setq sum (+ sum numbers))) () () nil)
8202
      ,numbers))
8303
      ,numbers))
...
...
8211
      ()
8312
      ()
8212
          (#-:series-letify (setq mul (coerce 1 type)))
8313
          (#-:series-letify (setq mul (coerce 1 type)))
8213
          ((setq mul (* mul numbers)))
8314
          ((setq mul (* mul numbers)))
8214
      () () nil)
8315
      () () nil)
8215
  :optimizer
8316
  :optimizer
8216
  (funcall-literal-frag
8317
  (apply-literal-frag
8217
   `((((numbers T)) ((mul))
8318
   `((((numbers T)) ((mul))
8218
      ((mul ,(must-be-quoted type) ,(coerce 1 (must-be-quoted type)))) ()
8319
      ((mul ,(must-be-quoted type) ,(coerce 1 (must-be-quoted type)))) ()
8219
      ()
8320
      ()
8220
      ((setq mul (* mul numbers))) () () nil)
8321
      ((setq mul (* mul numbers))) () () nil)
8221
     ,numbers))
8322
     ,numbers))

Get latest updates about Open Source Projects, Conferences and News.

Sign up for the SourceForge newsletter:





No, thanks