/
s-code.lisp
9941 lines (9077 loc) · 364 KB
/
s-code.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
;-*- Mode: lisp; syntax:ANSI-COMMON-LISP; Package: (SERIES :use "COMMON-LISP" :colon-mode :external) -*-
;;;; The standard version of this program is available from
;;;;
;;;; http://series.sourceforge.net/
;;;;
;;;; If you obtained this file from somewhere else, or copied the
;;;; files a long time ago, you might consider copying them from the
;;;; above web site now to obtain the latest version.
;;;; NO PATCHES TO OTHER BUT THE LATEST VERSION WILL BE ACCEPTED.
;;;;
;;;; $Id: s-code.lisp,v 1.114 2010/07/28 19:54:39 rtoy Exp $
;;;;
;;;; This is Richard C. Waters' Series package.
;;;; This started from his November 26, 1991 version.
;;;;
;;;; $Log: s-code.lisp,v $
;;;; Revision 1.114 2010/07/28 19:54:39 rtoy
;;;; Add optimizer for scan-hash. From Helmut Eller.
;;;;
;;;; Revision 1.113 2010/07/28 19:10:59 rtoy
;;;; Fix issue noted by Helmut Eller that (collect (scan '(1 2 3))) was not
;;;; optimized. Solution pointed out by Helmut too.
;;;;
;;;; s-code.lisp:
;;;; o LIFT-OUT-VARS needs to return CODE instead of NIL if there are no
;;;; variables to be lifted.
;;;;
;;;; s-test.lisp:
;;;; o Add test that series should optimize (collect (scan '(1 2 3))) to
;;;; just '(1 2 3) during macroexpansion.
;;;;
;;;; Revision 1.112 2010/07/26 12:23:17 rtoy
;;;; Oops. As Helmut points out, REPORT-ERROR should use CL:LET, not LET.
;;;;
;;;; Revision 1.111 2010/07/25 20:06:04 rtoy
;;;; Fix from Helmut Eller:
;;;;
;;;; The functions ERS, WRS, and RRS call ERROR resp. WARN with empty
;;;; strings. This is annoying when working with Slime. I propose to
;;;; change that: instead of printing the messages to *error-output*
;;;; and calling ERROR with an empty string it's better to pass the
;;;; message to ERROR and let the compiler print it.
;;;;
;;;; Revision 1.110 2010/06/11 02:16:02 rtoy
;;;; Changes to make series work with ccl.
;;;;
;;;; o Remove the eval-when around the defstructs. (Could this be a bug in
;;;; ccl?) This works fine with cmucl and clisp.
;;;; o Define the generator type for ccl too.
;;;; o Remove the double definition of the foundation-series type for cmucl
;;;; and clisp. Not needed anymore with cmucl 20a and clisp 2.47.
;;;;
;;;; Revision 1.109 2010/06/04 14:21:06 rtoy
;;;; Feature request 2295778 - don't ignore fill-pointer
;;;; Patch 2298394 - patch for #2295778
;;;;
;;;; s-code.lisp:
;;;; s-test.lisp:
;;;; o Patch applied
;;;;
;;;; Revision 1.108 2008/10/27 16:25:58 rtoy
;;;; Bug 2165712: Export COLLECT-IGNORE functionality
;;;;
;;;; s-code.lisp:
;;;; o Add better docstring for COLLECT-IGNORE.
;;;;
;;;; s-package.lisp:
;;;; o Export COLLECT-IGNORE
;;;;
;;;; s-doc.txt:
;;;; o Document COLLECT-IGNORE.
;;;;
;;;; Revision 1.107 2008/10/27 14:24:53 rtoy
;;;; Support SCL. Just add scl conditionalizations where we have cmucl
;;;; ones, and convert uppercase symbols and symbol-names to use
;;;; symbol-name and uninterned symbols. This is to support scl's default
;;;; "modern" mode.
;;;;
;;;; Changes from Stelian Ionescu.
;;;;
;;;; Revision 1.106 2007/08/08 15:07:45 rtoy
;;;; Change default test for SCAN-ALIST to EQL instead of EQ.
;;;;
;;;; Revision 1.105 2007/08/08 13:36:56 rtoy
;;;; s-code.lisp:
;;;; o Update docstrings
;;;;
;;;; s-doc.txt:
;;;; o Add documentation for COLLECT-PRODUCT, COLLECT-STREAM
;;;; o Correct the documentation for COLLECT-MAX and COLLECT-MIN.
;;;;
;;;; Revision 1.104 2007/08/08 03:42:43 rtoy
;;;; s-code.lisp:
;;;; o Update docstrings with more descriptive strings.
;;;;
;;;; s-doc.txt:
;;;; o Document SCAN-STREAM.
;;;;
;;;; Revision 1.103 2007/07/31 21:14:11 rtoy
;;;; Make the #Z reader signal an error if we are trying to create an
;;;; infinite literal series. Series doesn't support that.
;;;;
;;;; Revision 1.102 2007/07/10 17:45:46 rtoy
;;;; s-code.lisp:
;;;; o Add an optimizer for SERIES and update appropriately for the normal
;;;; path and the optimized path. This is needed so that (series t nil)
;;;; returns #z(t nil t nil ...) instead of #z(list t nil list t nil ...)
;;;;
;;;; s-test.lisp:
;;;; o Add two tests for SERIES. The tests need some work, but are based
;;;; on the errors reported by Szymon 'tichy' on comp.lang.lisp on Jul 7,
;;;; 2007.
;;;;
;;;; Revision 1.101 2007/02/06 21:10:38 rtoy
;;;; Get rid of a warning message. Don't know why the warning is done at
;;;; all.
;;;;
;;;; Revision 1.100 2005/12/13 14:40:30 rtoy
;;;; Lispworks wants an eval-when around coerce-maybe-fold. From Chris
;;;; Dean, 2005/12/09.
;;;;
;;;; Revision 1.99 2005/11/15 15:07:57 rtoy
;;;; ANSI CL says a declaration cannot also be the name of a type, so
;;;; remove the declaration for SERIES.
;;;;
;;;; Revision 1.98 2005/01/27 04:19:33 rtoy
;;;; Fix for bug 434120.
;;;;
;;;; s-code.lisp:
;;;; o scan* should initialize the index to -1 instead of 0, to keep in
;;;; step with scan.
;;;;
;;;; s-test.lisp:
;;;; o Add test from the bug report.
;;;;
;;;; Revision 1.97 2005/01/26 18:37:34 rtoy
;;;; Fix bug reported by Dirk Gerrits, series-users, 2005-01-16.
;;;;
;;;; s-code.lisp:
;;;; o ALTER was not handling some cases where the frag had multiple
;;;; ALTERABLE forms that matched the var. Adjust ALTER so that all
;;;; matching alterable forms are placed in the body. This only works
;;;; for optimized series. Unoptimized series still has the bug.
;;;;
;;;; s-test.lisp:
;;;; o Add :if-exists :supersede when opening files for output.
;;;; o Add a test for the ALTER bug reported by Dirk Gerrits.
;;;;
;;;; Revision 1.96 2004/12/15 17:18:53 rtoy
;;;; Apply fixes from Hannu Koivisto to support sbcl. Also added asdf
;;;; support. His comments:
;;;;
;;;;
;;;; * series.asd:
;;;; * Initial checkin.
;;;; * series.system:
;;;; * Removed logical pathname stuff and made this "self-sufficient", i.e. it is
;;;; sufficient to just load it; no need to edit pathname translations.
;;;; * Removed s-install from series system; we certainly don't want Series to
;;;; install itself to CL-USER whenever the system is compiled/loaded.
;;;;
;;;; * s-test.lisp:
;;;; * Replaced all uses of defconstant with series::defconst-once.
;;;;
;;;; * s-package.lisp:
;;;; * sb-cltl2 module is now required at compile time too.
;;;;
;;;; * s-code.lisp:
;;;; * (defconst-once) New macro.
;;;; * Replaced all uses of defconstant with it.
;;;;
;;;; * RELEASE-NOTES:
;;;; * Installation instructions based on system definition files.
;;;; * Updated the list of contributors.
;;;; * Some cosmetic changes.
;;;;
;;;; Revision 1.95 2003/06/08 12:52:40 rtoy
;;;; From Alexey Dejneka:
;;;;
;;;; o Add support for SBCL
;;;; o Fix a missing initialization of temp.
;;;;
;;;; Revision 1.94 2003/01/21 20:12:40 rtoy
;;;; Add support for CMUCL 18e which no longer has
;;;; pcl::walk-form-macroexpand. It's walker::macroexpand-all.
;;;;
;;;; Revision 1.93 2002/12/12 04:27:41 rtoy
;;;; Add support for a macrolet code-walker for Clisp.
;;;;
;;;; Revision 1.92 2002/12/11 04:03:26 rtoy
;;;; o Update /allowed-generic-opts/ to include SYSTEM::READ-ONLY for CLISP
;;;; 2.29.
;;;; o Modify COMPUTE-SERIES-MACFORM-1 and COMPUTE-SERIES-MACFORM-2 so that
;;;; CMUCL doesn't try to dump functions directly to a FASL file. Fixes
;;;; bug 498418: cmucl doesn't like dumping functions.
;;;;
;;;; Revision 1.91 2002/12/10 19:36:32 rtoy
;;;; Previous patch failed some tests. Let's try this
;;;; again. PROMOTE-SERIES returns an extra arg telling us what it did. We
;;;; use that to decide if we want the car or not of the item.
;;;;
;;;; Revision 1.90 2002/12/10 17:55:46 rtoy
;;;; Bug [ 516952 ] only optimized split-if works
;;;;
;;;; A gross hack to fix this has been applied. The wrong things were
;;;; passed to pos-if in some situations.
;;;;
;;;; Revision 1.89 2002/06/03 17:53:14 rtoy
;;;; From Joe Marshall:
;;;;
;;;; I found a bug in `scan-fn-opt' that caused an unbound variable
;;;; when the initialization thunk in scan-fn refers to a lexical
;;;; variable, and there is a test function.
;;;;
;;;; The existing code calls `handle-fn-call' to invoke the thunks
;;;; for scanning. handle-fn-call keeps track of free variable references.
;;;; When calling it the last time, you pass in T as the last argument.
;;;;
;;;; In the case where there was a test expression, however, the
;;;; order of calling handle-fn-call changes making the *second* to last
;;;; call have the T argument, rather than the last. By re-ordering the
;;;; way scan-fn-opt expands the thunks, this is fixed.
;;;;
;;;; Revision 1.88 2002/03/29 23:53:38 rtoy
;;;; Should not macroexpand declarations? I think this is right. I think
;;;; I did it right, but needs more testing.
;;;;
;;;; Revision 1.87 2001/12/23 16:54:44 rtoy
;;;; Make series support Allegro "modern" lisp with its case-sensitive
;;;; reader. Mostly just making every that needs to be lower case actually
;;;; lower case. The tests still work.
;;;;
;;;; Revision 1.86 2001/08/31 15:51:54 rtoy
;;;; Some changes from Joe Marshall for Allegro which apparently doesn't
;;;; fold constants in coerce. These changes only apply to Allegro.
;;;;
;;;; Revision 1.85 2001/04/10 17:22:33 rtoy
;;;; o Change series printer to output items one at a time instead of
;;;; gathering up everything before printing.
;;;; o Add more detailed doc strings for some functions.
;;;;
;;;; Revision 1.84 2001/04/09 22:18:47 rtoy
;;;; o Random re-indents so I can read the code better
;;;; o The latest versions of CMUCL's PCL have a better code walker that
;;;; allows us to do a macroexpand, ala lispworks.
;;;; o For CMUCL, use its list pretty-printer for printing out series.
;;;; It looks much better. But may be a problem if the series is
;;;; infinite. We won't get any output at all. (I think the original
;;;; would produce output and just never stop.)
;;;;
;;;; Revision 1.83 2001/04/09 19:52:34 rtoy
;;;; Stupid typo commenting (too much) stuff out.
;;;;
;;;; Revision 1.82 2001/04/07 20:14:31 rtoy
;;;; o remove-aux-if was inadvertently defined twice (should have been
;;;; remove-aux-if-not)
;;;; o remove-aux-if and remove-aux-if-not don't appear to be used
;;;; anywhere, so comment them out for now. Remember to remove them
;;;; later.
;;;;
;;;; Revision 1.81 2001/04/07 15:35:51 rtoy
;;;; scan-stream didn't work when not optimized, due to a typo. The core
;;;; of scan-stream should now be identical to the core of scan-file.
;;;;
;;;; Revision 1.80 2000/10/10 21:03:12 rtoy
;;;; Oops. It's cl:let, not just plain let.
;;;;
;;;; Revision 1.79 2000/10/10 15:02:27 rtoy
;;;; Fix up the lifting code to handle all variables except #:SEQ.
;;;; (There's some code in collect that initializes a SEQ var with (if SEQ
;;;; SEQ <do something else>), which I can't lift up because then SEQ would
;;;; be undefined.)
;;;;
;;;; Change the default for *lift-out-vars-p* to be T.
;;;;
;;;; Revision 1.78 2000/10/07 20:02:10 rtoy
;;;; Comment and clean up code added in previous update.
;;;;
;;;; Revision 1.77 2000/10/06 23:03:01 rtoy
;;;; First cut at trying to lift some variable initializations into the
;;;; enclosing LET.
;;;;
;;;; Basically, we look for something like
;;;;
;;;; (let (out-1 out-2)
;;;; (setq out-1 <init-1>)
;;;; (setq out-2 <init-2>)
;;;; <stuff>)
;;;;
;;;; and try to convert that to
;;;;
;;;; (let ((out-1 <init-1>) (out-2 <init-2>))
;;;; <stuff>)
;;;;
;;;; right after series has completed all of the macroexpansions it wants.
;;;;
;;;; Because this may be buggy, you can enable this feature by setting
;;;; *lift-out-vars-p* to T. It defaults to NIL.
;;;;
;;;; Note: this can cause CMUCL sometimes to produce a compile warning
;;;; that constant folding failed. (Often caused by trying to compute
;;;; array-total-size of a known constant list.)
;;;;
;;;; Revision 1.76 2000/10/01 23:07:28 rtoy
;;;; o Add some comments.
;;;; o Add a template for LOCALLY. (MCL works now!!!!)
;;;; o Move the OPTIF macro before it's first use in EOPTIF-Q. Seems that
;;;; this is required according to the CLHS. (Noticed by Rainer Joswig.)
;;;;
;;;; Thanks to Rainer for testing this on MCL. MCL passes all of the
;;;; tests!
;;;;
;;;; Revision 1.75 2000/09/30 21:44:41 rtoy
;;;; Bug #115738:
;;;;
;;;; Use remove-if-not instead of delete-if-not in delete-aux-if-not. This
;;;; was causing CLISP to fail test 530.
;;;;
;;;; (I'm not sure about this. It seems there's some shared list structure
;;;; with CLISP that doesn't happen in CMUCL. However, I think it's safe
;;;; to cons up a new list instead of destructively modifying the
;;;; original.)
;;;;
;;;; Revision 1.74 2000/09/05 15:54:09 rtoy
;;;; Fix bug 113625: scan doesn't scan constants very well.
;;;;
;;;; Solution: If it's a symbol, take the value of the symbol. (Not sure
;;;; this is quite correct, but it works and the other tests pass without
;;;; problems.)
;;;;
;;;; Revision 1.73 2000/06/26 18:11:26 rtoy
;;;; Fix for bug #108331: collect 'vector sometimes returns results in
;;;; reverse order. Example is (collect 'vector (scan '(1 2 3))).
;;;;
;;;; Revision 1.72 2000/06/26 15:28:19 rtoy
;;;; DECODE-SEQ-TYPE was getting BASE-STRING and STRING mashed together,
;;;; and didn't even handle BASE-STRING. They are slightly different:
;;;; BASE-STRING is composed of BASE-CHAR's and STRING is composed of
;;;; CHARACTER's.
;;;;
;;;; Revision 1.71 2000/03/28 10:23:49 matomira
;;;; polycall et all are now tail recursive.
;;;; LETIFICATION WORKS COMPLETELY!!
;;;;
;;;; Revision 1.86 2000/03/28 10:19:04 matomira
;;;; polycall et al. are now tail recursive.
;;;; LETIFICATION WORKS COMPLETELY!
;;;;
;;;; Revision 1.85 2000/03/27 17:21:14 matomira
;;;; Fixed eval-on-first-cycle for letification.
;;;; Improved clean-code so it does not miss completely unused variables.
;;;;
;;;; Revision 1.83 2000/03/25 21:44:26 matomira
;;;; Avoided gratuitous consig in values-lists.
;;;;
;;;; Revision 1.80 2000/03/23 23:01:56 matomira
;;;; NEW FEATURES:
;;;; ------------
;;;; - (collect 'set
;;;; Collects a series into a list removing any duplicates in the most efficient way possible.
;;;; - (collect 'ordered-set
;;;; Collects a series into a list removing any duplicates but keeping the original series order.
;;;; - SCAN now allows to drop the type specifier for any source expression
;;;; [:cltl2-series reactivates the old 'list assumption]
;;;; - SCAN now can scan multidimensional arrays in row-major order.
;;;;
;;;; IMPROVEMENTS:
;;;; ------------
;;;; - Better code generation
;;;; . Some fixnum declarations were further constrained.
;;;; . Optimized scanning of constant sequences.
;;;; . Somewhat optimized scanning of "empty" vectors, ie,
;;;; declared to be of constant 0 length, like in
;;;; (collect (scan '(vector t 0) <gimme-a-huge-array-to-throw-away>)
;;;; now gives you NIL generating/executing less instructions.
;;;; [<gimme-a-huge-array-to-throw-away> is still executed if not constantp,
;;;; though]
;;;; . Variables of type NULL are replaced by constant NILs.
;;;;
;;;; BUG FIXES:
;;;; ---------
;;;; - Some incorrect fixnum declarations were relaxed.
;;;; - Improved some declarations to avoid spurious range warnings regarding
;;;; dead code by not-so-smart compilers.
;;;;
;;;; Revision 1.79 2000/03/21 17:18:56 matomira
;;;; Reinstated plain generation support.
;;;;
;;;; Revision 1.78 2000/03/21 15:26:12 matomira
;;;; Fixed letified merge-frags bug.
;;;; Adapted handle-dflow and non-series-merge for letification.
;;;; Spawned list->frag1 from list->frag.
;;;; define-optimizable-series-function uses list->frag1 to support letification.
;;;; Still can't handle all initial bindings because off-line handling seems to
;;;; move prologs into TAGBODYs.
;;;;
;;;; Revision 1.75 2000/03/18 20:12:52 matomira
;;;; Improved code generated by compute-series-macform-2 when trigger is t.
;;;;
;;;; Revision 1.74 2000/03/18 19:14:45 matomira
;;;; Improved merging when letified.
;;;; Last version with series library definitions not requiring letification.
;;;;
;;;; Revision 1.73 2000/03/18 18:05:24 matomira
;;;; Full letification works.
;;;;
;;;; Revision 1.72 2000/03/17 19:24:23 matomira
;;;; MERGE-FRAGS no longer depends on frag component order.
;;;; purity component of frag is now just a symbol.
;;;; Abstracted use of prolog component of frags.
;;;; Prolog letification almost works. Need to adapt MERGE-FRAGS still.
;;;;
;;;; Revision 1.71 2000/03/15 18:40:35 matomira
;;;; LOCALLY and letification works.
;;;;
;;;; Revision 1.70 2000/03/15 09:05:39 matomira
;;;; Temporary NULL-OR wrap for some declarations.
;;;;
;;;; Revision 1.69 2000/03/14 10:48:09 matomira
;;;; Workaround for ACL 5.0.1 TAGBODY bug added.
;;;; ALL-TIME SERIES BUG FIX: wrappers now inserted more precisely.
;;;; Abstracted use of wrapper component of frags.
;;;; GENERATOR deftyped to CONS, not LIST, when necessary.
;;;;
;;;; Revision 1.68 2000/03/11 17:36:33 matomira
;;;; Added eval-when compatibility magic.
;;;;
;;;; Revision 1.67 2000/03/11 15:35:44 matomira
;;;; Fixed worsen-purity.
;;;;
;;;; Revision 1.66 2000/03/10 12:49:27 matomira
;;;; Letification works.
;;;; Started purity analysis.
;;;;
;;;; Revision 1.65 2000/03/09 13:28:03 matomira
;;;; Almost there with letification.
;;;; Activated GENERATOR deftype also for :excl.
;;;;
;;;; Revision 1.64 2000/03/08 18:20:35 matomira
;;;; Fixed fragL instead of *fragL bug in COLLECT.
;;;;
;;;; Revision 1.63 2000/03/08 17:58:24 matomira
;;;; Fixed mixed CL: before FUNCALL in DESTARRIFY.
;;;;
;;;; Revision 1.62 2000/03/08 12:30:53 matomira
;;;; Continued work on letification.
;;;;
;;;; Revision 1.61 2000/03/07 13:47:23 matomira
;;;; Removed gratuitous sorting in CODIFY.
;;;;
;;;; Revision 1.60 2000/03/07 08:54:20 matomira
;;;; Abstracted all uses of a frag's aux component.
;;;;
;;;; Revision 1.59 2000/03/06 18:24:35 matomira
;;;; Replaced IF by WHEN in non-output code when possible.
;;;; Abstracted use of aux frag field.
;;;;
;;;; Revision 1.58 2000/03/06 12:33:14 matomira
;;;; Simplified inserted aux var initialization.
;;;;
;;;; Revision 1.57 2000/03/06 12:11:53 matomira
;;;; Fixed declaration handling in GATHERING.
;;;;
;;;; Revision 1.56 2000/03/05 16:21:56 matomira
;;;; Fixed missing CL: before FUNCALL bug.
;;;; Removed NULL-ORs by using THE.
;;;; Renamed old fragL as *fragL.
;;;; New fragL does not do *type* substitution.
;;;;
;;;; Revision 1.55 2000/03/03 19:17:14 matomira
;;;; Series 2.0 - Change details in RELEASE-NOTES.
;;;;
;;;; Revision 1.51 2000/02/23 15:27:02 toy
;;;; o Fernando added an indefinite-extent declaration and uses
;;;; it in the one place where it's needed.
;;;; o Fernando renamed split-assignment to detangle2 and
;;;; corrected some bugs in my version.
;;;;
;;;; Revision 1.50 2000/02/22 23:37:22 toy
;;;; Remove the cmu version from scan-range. It was generating bad
;;;; initialization code for things like (scan-range :length 10 :type
;;;; 'single-float).
;;;;
;;;; Revision 1.49 2000/02/22 22:25:51 toy
;;;; o One of Fernando's uses of dynamic-extent was wrong, as Fernando
;;;; points out.
;;;;
;;;; o CLISP apparently has a bug in loop such that split-assignment is
;;;; broken. Replace that with an equivalent do loop.
;;;;
;;;; Revision 1.48 2000/02/22 15:21:38 toy
;;;; Fernando added dynamic-extent declarations wherever needed.
;;;;
;;;; Revision 1.47 2000/02/11 14:45:42 toy
;;;; Let's not use fix-types for CMU in optimize-producing. This means the
;;;; compiler can't optimize things as well as it could, and I (RLT) want
;;;; to see these warnings.
;;;;
;;;; Revision 1.46 2000/02/10 17:15:11 toy
;;;; Fix a typo that got in the last few patches: LET should really be
;;;; CL:LET. (From Fernando.)
;;;;
;;;; Revision 1.45 2000/02/09 22:46:00 toy
;;;; Changed all occurrences of defunique to be just defun and added a
;;;; comment on where the function is called.
;;;;
;;;; Revision 1.44 2000/02/08 17:08:36 toy
;;;; o As discussed with Fernando, the "optional" type is renamed to
;;;; null-or.
;;;; o Cleaned up and indented some of the comments.
;;;;
;;;; Revision 1.43 2000/02/04 23:05:57 toy
;;;; A few more changes from Fernando:
;;;;
;;;; o All functions called from a single site are defined with DEFUNIQUE
;;;; for documentation purposes (and eventual inlining via DEFEMBEDDED).
;;;; o Fixed the long standing bug that install uninterned everything that
;;;; it didn't like. Shadowing import is used now.
;;;;
;;;; There were some other changes that I (RLT) don't understand.
;;;;
;;;; Revision 1.41 2000/02/04 16:34:30 toy
;;;; o Some more changes from Fernando. This fixes some bugs that show up
;;;; in the test suite. The test suite now passes on CMUCL.
;;;;
;;;; o Fixed up some declarations that used the optional type when, in
;;;; fact, it didn't. (Hope I got these all right.)
;;;;
;;;; Revision 1.40 2000/02/03 17:30:08 toy
;;;; Two major fixes:
;;;;
;;;; o Bug in collect (missing set of parens)
;;;; o Change some defconstants back to defvar. (Tickles CMUCL inf loop).
;;;;
;;;; Revision 1.39 2000/02/02 21:31:44 toy
;;;; Here are the changes that Fernando made. I (RLT) don't claim to
;;;; understand everything that was changed or why.
;;;;
;;;; 1. Removed 1 redundant eval-when
;;;; 2. Sorted functions so that it can be loaded w/o `undefined function'
;;;; warnings.
;;;; 3. Added inline declarations for all functions called from a single
;;;; site.
;;;; 4. Sorted functions so that inlining will work even if a compiler does
;;;; not inline forward references to functions defined in the same
;;;; file.
;;;; 5. Setup eval-when's so that it can be compiled w/o having to load the
;;;; source first.
;;;; 6. Simplified redundant (OR NULL T) to T
;;;; 7. Simplified redundant #'(lambda (x) (foo x)) to #'foo where foo is a
;;;; function.
;;;; 8. Fixed so it won't complain when LispWorks adds
;;;; CLOS::VARIABLE-REBINDING declarations after CLOS macro
;;;; transformations (general support provided via the constant
;;;; allowed-generic-opts).
;;;; 9. Added support for MACROLET on LispWorks (necessary because of CLOS
;;;; macro transformations).
;;;; 10. Only declare variables as (OR foo NULL) on implementations that
;;;; won't allow to store NIL otherwise (currently, only CMUCL).
;;;; 11. Added specialization to series declarations (eg: (SERIES FIXNUM)).
;;;; 12. Do more precise type propagation in PRODUCING forms.
;;;; 13. Allow `SETF like SETQ' in PRODUCING forms.
;;;; 14. Added COLLECT-PRODUCT.
;;;; 15. Extended SETQ-P to take into account multiassignments (not used
;;;; yet). This should still be trivially generalized to support PSETQ
;;;; and SETF, BTW.
;;;; 16. Added DEFTYPE for GENERATOR so that LispWorks and CMUCL won't
;;;; complain "because it's not a list" (IT IS!!)
;;;; 17. Replaced PROCLAIMS with DECLAIMS.
;;;; 18. Replaced DEFVARs with DEFCONSTANTs where appropriate.
;;;; 19. Removed function namespace pollution by defS-generated code.
;;;;
;;;; Revision 1.38 2000/01/20 18:19:21 toy
;;;; Merged 1.32.2.2 (Fernando's changes) with 1.37.
;;;; I hope I got this right.
;;;;
;;;; Revision 1.32.2.2 2000/01/20 18:05:26 toy
;;;; Merged the changes between 1.32 and 1.37 into this revision.
;;;; This should merge my changes with Fernando's.
;;;;
;;;; Revision 1.32.2.1 2000/01/20 17:51:45 toy
;;;; Checking in the changes from Fernando Mato Mira <matomira@iname.com>
;;;; with the hope of merging our two versions together.
;;;;
;;;; Revision 1.32 1999/07/02 20:37:39 toy
;;;; Moved the package stuff out to a separate file.
;;;;
;;;; Revision 1.31 1999/07/02 15:09:49 toy
;;;; o Need explicit package qualifier for multiple-value-bind in
;;;; init-elem.
;;;; o Reordered some of the tests in init-elem.
;;;;
;;;; Revision 1.30 1999/07/01 16:44:23 toy
;;;; A comment was in the wrong place.
;;;;
;;;; Revision 1.29 1999/07/01 14:15:39 toy
;;;; o "Pekka P. Pirinen" <pekka@harlequin.co.uk> supplied a new version
;;;; of aux-init (and init-elem). This is probably better. I added one
;;;; additional case.
;;;;
;;;; o Added simple-base-string to the tests in decode-seq-type. (Needed
;;;; by the new aux-init.
;;;;
;;;; Revision 1.28 1999/06/30 19:34:49 toy
;;;; "Pekka P. Pirinen" <pekka@harlequin.co.uk> says:
;;;;
;;;; "Tests 289, 290, 417, and 426 [on Liquid CL] fail because of
;;;; incorrect type decls generated in ADD-PHYSICAL-OUT-INTERFACE.
;;;; The variable NEW-OUT is used for two conflicting purposes; The
;;;; fix is to split it into two."
;;;;
;;;; Thanks!
;;;;
;;;; Revision 1.27 1999/04/29 22:06:49 toy
;;;; Fix some problems in aux-init not handling some strings and
;;;; bit-vectors correctly.
;;;;
;;;; Revision 1.26 1999/04/23 17:51:24 toy
;;;; For CMUCL, decode-seq-type didn't handle base-string types. Make it
;;;; work.
;;;;
;;;; In aux-init, change the test for simple-string to be string instead.
;;;;
;;;; Revision 1.25 1999/04/15 17:09:41 toy
;;;; Rework aux-init once again. The bit-vector entry goes away, and the
;;;; entry for vector and simple-array are changed to create the proper
;;;; types when the length is not given. I hope this is the last change
;;;; here! :-)
;;;;
;;;; Revision 1.24 1999/04/15 16:35:54 toy
;;;; In aux-init, the bit-vector entry is actually applicable to all Lisps
;;;; because bit-vectors would get initialized to #() instead of #*, which
;;;; is wrong. Remove the CMU conditionalization.
;;;;
;;;; Revision 1.23 1999/04/13 16:51:32 toy
;;;; o Back up the gensym changes made in 1.21 because CLISP doesn't like
;;;; it.
;;;; o type-expand for CLISP is in the LISP package.
;;;; o For CMUCL, in aux-init need to check for bit-vector before
;;;; simple-array because simple-bit-vector was done as simple-array
;;;; instead of bit-vector, which is wrong.
;;;;
;;;; Revision 1.22 1999/04/09 12:32:26 toy
;;;; Add definition of canonical-type for CLISP.
;;;;
;;;; Revision 1.21 1999/04/08 21:46:08 toy
;;;; Use gensym instead of gentemp, which is deprecated in ANSI CL.
;;;;
;;;; Revision 1.20 1999/04/08 21:41:16 toy
;;;; Add CLISP to the Series-ANSI. Then need to import COMPILER-LET.
;;;;
;;;; In aux-init, the bit-vector entry is only for CMUCL which
;;;; canonicalizes (vector bit) into bit-vector.
;;;;
;;;; Revision 1.19 1999/04/06 18:36:13 toy
;;;; Some fixes from Arthur Lemmens <lemmens@simplex.nl>:
;;;; MAKE-SEQUENCE was being called with things like (BIT-VECTOR BIT) and
;;;; (STRING STRING-CHAR). Change DECODE-SEQ-TYPE to convert BIT-VECTOR's
;;;; and STRING's to the the underlying array types. Also change
;;;; STRING-CHAR to CHARACTER.
;;;;
;;;; This change necessitates adding a BIT-VECTOR case in AUX-INIT. (This
;;;; is probably only need by CMUCL where CANONICAL-TYPE actually does
;;;; something.)
;;;;
;;;; Revision 1.18 1998/06/12 20:45:23 toy
;;;; An addition to scan-hash for CLISP. This reduces consing and should
;;;; be at least as fast. From Bruno Haible.
;;;;
;;;; Also, defstruct alter-fn needs to be defined twice for CLISP and
;;;; probably also for CMUCL. From Brun Haible.
;;;;
;;;; Revision 1.17 1998/06/10 18:59:51 toy
;;;; Fixed long-standing bug in scan-range where the initial values of the
;;;; loop variables didn't match the specified :type. I'm not sure this is
;;;; the correct solution, but it seems to produce the desired macro
;;;; expansions. I would be interested in a better solution, if possible.
;;;;
;;;; Revision 1.16 1998/06/08 17:34:59 toy
;;;; Couple of small changes for CLISP.
;;;;
;;;; Revision 1.15 1998/05/26 16:23:25 toy
;;;; One last fix from Reginald: Don't make series a declaration. With
;;;; this fix, this should now run correctly for lispworks.
;;;;
;;;; Revision 1.14 1998/05/24 19:19:22 toy
;;;; Fixes from Reginald S. Perry were incompletely applied: Forgot to
;;;; import compiler-let and messed up a fix for uninterning SERIES for
;;;; Harlequin.
;;;;
;;;; Revision 1.13 1998/05/21 15:18:27 toy
;;;; Added a few fixes from "Reginald S. Perry" <reggie@aa.net> to make
;;;; this work with LWW.
;;;;
;;;; Revision 1.12 1997/10/02 13:36:45 toy
;;;; Forgot to export scan-stream.
;;;;
;;;; Revision 1.11 1997/10/02 13:25:18 toy
;;;; Added canonical-type function to extract out the "real" type if
;;;; something has been deftype'd. Changed code to support this new
;;;; function.
;;;;
;;;; Do a better job in decode-seq-type. Needed for CMUCL to complain
;;;; less.
;;;;
;;;; Added scan-stream series function. Just like scan-file, except that
;;;; we have a stream instead of a file name.
;;;;
;;;; Revision 1.10 1997/01/16 14:38:27 toy
;;;; Took out part of Tim's last change: Removed tests for :defpackage
;;;; feature. Gcl with M. Kantrowitz's defpackage doesn't work and I'm too
;;;; lazy to figure out why.
;;;;
;;;; Revision 1.9 1997/01/16 14:26:44 toy
;;;; Some more patches from Tim (tfb@aiai.ed.ac.uk): Conditionalize on
;;;; :defpackage too for package stuff.
;;;;
;;;; Revision 1.8 1997/01/16 14:23:59 toy
;;;; Put in changes from Tim (tfb@aiai.ed.ac.uk) to conditionalize on
;;;; Series-ANSI.
;;;;
;;;; Revision 1.7 1997/01/16 14:20:23 toy
;;;; GCL normally doesn't have defpackage, so don't use defpackage form.
;;;; It also doesn't have a "CL" package, so rename "LISP" to
;;;; "COMMON-LISP" with appropriate nicknames.
;;;;
;;;; Revision 1.6 1997/01/13 17:47:19 toy
;;;; Added some changes from Tim Bradshaw (tfb@aiai.ed.ac.uk):
;;;; Replace "LISP:" with "CL:"
;;;; Added :import-from for Genera and Allegro.
;;;; With these changes, everything still works under CMUCL.
;;;;
;;;; Revision 1.5 1997/01/13 16:04:11 toy
;;;; Don't install the package on load. Let the user do it himself.
;;;;
;;;; Revision 1.4 1997/01/10 22:37:03 toy
;;;; A patch from Tim Bradshaw that fixes a bug. The code walker
;;;; improperly handles nth-value. Doesn't seem to have any affect in
;;;; CMUCL but can be seen in others like lispm.
;;;;
;;;; Revision 1.3 1997/01/07 19:09:30 toy
;;;; Changed aux-init to initialize variables better. I think it handles
;;;; just about all cases now.
;;;;
;;;; Modified clean-dcls to handle simple-arrays.
;;;;
;;;; Changed collect so that it handles types better by passing the correct
;;;; type to fragL. This allows better optimization by the compiler (at
;;;; least for CMUCL).
;;;;
;;;; Added code at the end so that the package is installed whenever it's
;;;; loaded. You don't have to explicitly install the package anymore.
;;;; However, there's a bug: It assumes you were originally in the USER
;;;; package. This needs to be fixed.
;;;;
;;;; Revision 1.2 1997/01/07 18:58:51 toy
;;;; Changes from Paul Werkowski to make series work/run under CMUCL.
;;;; Raymond Toy added the defpackage stuff. There are probably other
;;;; changes here, but I wasn't careful to keep everything straight,
;;;; unfortunately.
;;;;
;;;;
;------------------------------------------------------------------------
;;;; Copyright Massachusetts Institute of Technology, Cambridge, Massachusetts.
;;;; Permission to use, copy, modify, and distribute this software and
;;;; its documentation for any purpose and without fee is hereby
;;;; granted, provided that this copyright and permission notice
;;;; appear in all copies and supporting documentation, and that the
;;;; name of M.I.T. not be used in advertising or publicity pertaining
;;;; to distribution of the software without specific, written prior
;;;; permission. M.I.T. makes no representations about the suitability
;;;; of this software for any purpose. It is provided "as is" without
;;;; express or implied warranty.
;;;; M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE,
;;;; INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND
;;;; FITNESS, IN NO EVENT SHALL M.I.T. BE LIABLE FOR ANY SPECIAL,
;;;; INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER
;;;; RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
;;;; ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
;;;; ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE
;;;; OF THIS SOFTWARE.
;;;;------------------------------------------------------------------------
;;;; This file implements efficient computation with series
;;;; expressions in Common Lisp. The functions in this file
;;;; are documented in Appendices A and B of Common Lisp: the Language,
;;;; Second Edition, Guy L. Steele Jr, Digital press, 1990,
;;;; and in even greater detail in
;;;; MIT/AIM-1082 and MIT/AIM-1083 both dated December 1989
;;;; These reports can be obtained by writing to:
;;;;
;;;; Publications
;;;; MIT AI Laboratory
;;;; 545 Tech. Sq.
;;;; Cambridge MA 02139
;;;; This file attempts to be as compatible with standard Common Lisp
;;;; as possible. It has been tested on the following Common Lisps to
;;;; date (1/18/89).
;;;;
;;;; Symbolics CL version 8.
;;;; LUCID CL version 3.0.2 on a sun.
;;;; Allegro CL version 1.2.1 on a Macintosh.
;;;; LispWorks CL version 2.1.
;;;;
;;;; This version has been tested on
;;;;
;;;; CMUCL 18b
;;;; Lispworks CL
;;;; Allegro CL 5.0
;;;;
;;;; The companion file "STEST.LISP" contains several hundred tests.
;;;; You should run these tests after the first time you compile this
;;;; file on a new system.
;;;;
;;;; The companion file "SDOC.TXT" contains brief documentation.
#+(and series-ansi)
(in-package :series)
#-(or series-ansi)
(eval-when (compile load eval)
(in-package "SERIES")
) ; end of eval-when
(eval-when (:compile-toplevel :load-toplevel :execute)
(defvar *suppress-series-warnings* nil
"Suppress warnings when the restrictions are violated.")
(defvar *series-expression-cache* t
"Avoids multiple expansions")
(defvar *last-series-loop* nil
"Loop most recently created by SERIES.")
(defvar *last-series-error* nil
"Info about error found most recently by SERIES.")
;(pushnew :series-plain *features*)
;;; END OF TUNABLES
(defmacro defconst-once (name value &optional documentation)
"Like `defconstant' except that if the variable already has a
value, the old value is not clobbered."
`(defconstant ,name (if (boundp ',name) (symbol-value ',name) ,value)
,@(when documentation (list documentation))))
;; SERIES::INSTALL changes this
(defvar *series-implicit-map* nil
"T enables implicit mapping in optimized expressions")
(defconst-once /ext-conflicts/
#+(or cmu scl) '(collect iterate)
#+allegro-v6.1 '(until)
#-(or cmu scl allegro-v6.1) '())
(defconst-once /series-forms/
'(let let* multiple-value-bind funcall defun)
"Forms redefined by Series.")
#+:gcl
(declaim (declaration dynamic-extent)) ; Man, is GCL broken!
(declaim (declaration indefinite-extent))
(declaim (declaration optimizable-series-function off-line-port
propagate-alterability))
) ; end of eval-when
;;; Generic stuff that should be moved to/imported from EXTENSIONS
;; mkant EXTENSIONS should push :EXTENSIONS in *FEATURES*!!!
(cl:defun atom-or-car (x)
(if (listp x)
(car x)
x))
(cl:defun array-fill-pointer-or-total-size (seq)
(if (array-has-fill-pointer-p seq)
(fill-pointer seq)
(array-total-size seq)))
(eval-when (:compile-toplevel :load-toplevel :execute)
(deftype nonnegative-fixnum ()
`(mod ,most-positive-fixnum))
(deftype nonnegative-integer ()
`(integer 0))
(deftype positive-integer ()
`(integer 1))
(deftype -integer (m &optional (n nil) (under 1))
`(integer ,(- m under) ,@(when n `(,n))))
(deftype integer+ (m &optional (n nil) (over 1))
`(integer ,m ,@(when n `(,(+ n over)))))
(deftype integer- (m &optional (n nil) (over 1))
`(integer ,m ,@(when n `(,(- n over)))))
(deftype -integer- (m &optional (n nil) (over 1) (under 1))
`(integer ,(- m under) ,@(when n `(,(- n over)))))
(deftype mod+ (n &optional (over 1))
`(mod ,(+ n over)))
(deftype null-or (&rest types)
`(or null ,@types))
(deftype uninitialized (typ)
`(null-or ,typ))
(deftype defaulted (typ)
`(null-or ,typ))
(deftype -vector-index ()
`(-integer- 0 ,array-total-size-limit))
(deftype vector-index ()
`(integer- 0 ,array-total-size-limit))
(deftype vector-index+ ()
`(integer 0 ,array-total-size-limit))
(deftype -vector-index+ ()
`(-integer 0 ,array-total-size-limit))
#-:extensions
(progn
(defmacro when-bind ((symbol predicate) &body body)
"Binds the symbol to predicate and executes body only if predicate
is non-nil."
`(cl:let ((,symbol ,predicate))
(when ,symbol
,@body)))
(defmacro bind-if ((symbol predicate) then &optional else)
"Binds the symbol to predicate and executes body only if predicate
is non-nil."
`(cl:let ((,symbol ,predicate))
(if ,symbol
,then
,@(when else `(,else)))))
(defmacro bind-if* ((symbol predicate) then &body else)
"Binds the symbol to predicate and executes body only if predicate
is non-nil."
`(cl:let ((,symbol ,predicate))
(if ,symbol
,then
,@(when else
`(,(if (cdr else)
`(progn ,@else)
else))))))
) ; end of progn
;; DEBUG
(defmacro definline (&rest args) `(cl:defun ,@args))
;; Define an inline function
;; Comment out the #+:ignore line to inline stuff
#+:ignore
(defmacro definline (name &rest args)
`(progn
(declaim (inline ,name))
(cl:defun ,name ,@args)))
(cl:defun eq-car (thing item)
(and (consp thing) (eq (car thing) item)))
(cl:defun copy-list-last (orig)
(if orig
(cl:let* ((lastcons (list nil))
(lst lastcons))
(do ((remains orig (cdr remains)))
((not (consp remains)) (values (cdr lst) (rplacd lastcons remains)))
(setq lastcons (setf (cdr lastcons) (cons (car remains) nil)))))
(values nil nil)))
(cl:defun nmerge-1 (l1 l2)
(do ((x l1 (cdr x))
(y l2 (cdr y))
z)
((or (endp x) (endp y)) (when (endp x) (rplacd z y)))
(rplaca x (nconc (car x) (car y)))
(setq z x))
l1)
(cl:defun nmerge (l1 l2)
(cond ((null l1) l2)
((null l2) l1)
(t (nmerge-1 l1 l2))))
(cl:defun noverlap (n l1 l2)
"Overlap l2 over the last n components of n1."
(cond ((eql n 0) (nconc l1 l2))
((null l1) l2)
(t
(cl:let ((n1 (length l1)))
(if (<= n n1)