Skip to content
Navigation Menu
{{ message }}
-
Notifications
You must be signed in to change notification settings - Fork 35
Expand file tree
/
Copy pathstring.lisp
More file actions
1322 lines (1226 loc) · 59 KB
/
Copy pathstring.lisp
File metadata and controls
1322 lines (1226 loc) · 59 KB
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; Package:SI; Lowercase:T; Base:8; Cold-Load:T; Readtable:ZL -*-
; ** (c) Copyright 1980 Massachusetts Institute of Technology **
; character lossage of the most severe and pervasive type
;;many of these should be move to microcode!!!! (hah!!)
;NOTES: THINK ABOUT 16-BIT STRINGS.
;The string functions:
#|
(STRING-LENGTH string) returns the number of characters in a given string.
(SUBSTRING string from to) returns an arbitrary substring of a given string, copied.
Omitting <to> means go all the way to the end of the string.
(NSUBSTRING string from to) is like SUBSTRING, but returns a shared substring, not copied.
(STRING-APPEND string ...) concatenates strings.
(STRING-SUBST-CHAR new old string) replaces all occurences of a <old> with <new> in <string>
(STRING-SEARCH-CHAR char string from to) searches a string for a given character.
Returns index if found, else NIL.
(STRING-REVERSE-SEARCH-CHAR char string from to) searches backwards, as above.
(STRING-SEARCH-NOT-CHAR char string from to) searches a string for anything other
than a given char. Returns index if found, else NIL.
(STRING-REVERSE-SEARCH-NOT-CHAR char string from to) searches backwards, as above.
(STRING-SEARCH key string from to) searches for <key> in <string>.
Returns index if found, else NIL.
(STRING-REVERSE-SEARCH key string from to) searches backwards for <key> in <string>.
(STRING-SEARCH-SET charlist string from to) searches in <string> from <from>
for a char in <charlist>.
(STRING-SEARCH-NOT-SET charlist string from to) searches in <string> from <from>
for a char not in <charlist>.
(STRING-REVERSE-SEARCH-SET charlist string from to) searches backwards in <string>
from <from> for a char in <charlist>.
(STRING-REVERSE-SEARCH-NOT-SET charlist string from to) searches backwards in <string>
from <from> for a char not in <charlist>.
(STRING-TRIM charlist string) returns a copy of <string> with all leading and
trailing members of <charlist> truncated.
(STRING-LEFT-TRIM charlist string) is like STRING-TRIM but only hacks leading characters.
(STRING-RIGHT-TRIM charlist string) is analogous.
(STRING-NREVERSE string) reverses the elements of <string>, in place.
(STRING-REVERSE string) returns a copy of <string> with the characters reversed.
(STRING-UPCASE string) returns string copied and converted to all upper case.
(STRING-DOWNCASE string) returns string copied and converted to all lower case.
(string-flipcase string)
(CHAR-UPCASE char) returns the character converted to upper case.
(CHAR-DOWNCASE char) returns the character converted to lower case.
(STRING-REMOVE-FONTS string) returns string without font info (chars truncated to 8 bits)
(STRING-COMPARE s1 s2 &optional (from1 0) (from2 0) to1 to2)
(STRING-LESSP s1 s2) says whether s1 is less than s2, in dictionary ordering.
(ARRAY-TYPE array) returns the type of an array, as a symbol (eg, ART-STRING).
(SUBSTRING-AFTER-CHAR char string) "" if char not in string.
(STRING-PLURALIZE string) returns plural of word in string.
(STRING-EQUAL string1 string2 &optional start1 start2 end1 end2)
returns T if specified portions match.
(STRING something) returns the argument, converted to a string.
(CL:CHARACTER something) returns the argument, converted to a character.
(ZL:CHARACTER something) returns the argument, converted to a fixnum.
(ALPHALESSP something1 something2) is nearly the same as comparing the
two objects' printed representations, as strings.
However, numbers are compared with =.
(ALPHAEQUAL something1 something2) is nearly the same as comparing the
two objects' printed representations, as strings.
However, numbers are compared with =.
SUBSTRING and NSUBSTRING take an optional area argument.
Note that most of the functions in this package will consider a number
to be a string one character long. However, they will never return
a number instead of a string one character long.
Symbols given as arguments will be converted into their pnames.
|#
(DEFSUBST FIXNUM-ARRAYP (OBJECT)
"T if OBJECT is an array whose elements cannot be of arbitrary type."
(AND (ARRAYP OBJECT)
(ARRAY-BITS-PER-ELEMENT (%P-LDB %%ARRAY-TYPE-FIELD OBJECT)))) ;;**********************
;;; This macro is used by string-searching functions to coerce the string args.
(DEFMACRO COERCE-STRING-SEARCH-ARG (ARG-NAME)
`(OR (FIXNUM-ARRAYP ,ARG-NAME)
(SETQ ,ARG-NAME (STRING ,ARG-NAME))))
(DEFMACRO COERCE-STRING-ARG (ARG-NAME)
"Convert ARG-NAME to a string if it isn't one already.
Sets the value of ARG-NAME."
`(OR (STRINGP ,ARG-NAME)
(SETQ ,ARG-NAME (STRING ,ARG-NAME))))
(defmacro require-character (variable)
"Checks the type of VARIABLE to be either a character or an integer.
If the value is initially an integer, it is coerced into a character with
INT-CHAR."
`(progn
(when (typep ,variable 'zl:fixnum)
(setq ,variable (int-char ,variable)))
(check-type ,variable character)))
;This is now microcoded
;(DEFUN INT-CHAR (INTEGER)
; "Returns a character whose value corresponds to INTEGER."
; (%MAKE-POINTER DTP-CHARACTER INTEGER))
(defun array-int->array-char (int-array)
"Mutates an array of integers into an array of characters."
(dotimes (index (array-active-length int-array))
(setf (aref int-array index)
(int-char (aref int-array index)))))
(defun array-int->string (int-array)
"Coerces an array of fixnums into a string. This is a crock."
(let ((ans (make-string (array-active-length int-array))))
(dotimes (index (array-active-length int-array))
(setf (aref ans index)
(int-char (aref int-array index))))
ans))
(DEFUN STRING-APPEND (&REST STRINGS
&AUX (LENGTH 0) (BITS 0) B TY (TYPE 'ART-STRING) FROB)
"Append any number of strings (or vectors). The value is always a newly constructed array.
The value will have be of an array type which can contain the elements of all the STRINGS.
Symbols, characters and numbers are coerced into strings."
(DOLIST (S STRINGS)
(IF (CHARACTERP S) (SETQ S (CHAR-INT S)))
(TYPECASE S
(FIXNUM
(INCF LENGTH 1)
(COND ((< S (^ 2 8)) (SETQ B 8 TY 'ART-STRING))
((< S (^ 2 16.)) (SETQ B 16. TY 'ART-FAT-STRING))
(T (SETQ B %%Q-POINTER TY 'ART-Q)))) ;;**********************
(VECTOR
(INCF LENGTH (LENGTH S))
(SETQ B (ARRAY-ELEMENT-SIZE S) TY (ARRAY-TYPE S)))
(SYMBOL
(INCF LENGTH (LENGTH (SYMBOL-NAME S)))
(SETQ B 8 TY ART-STRING))
((AND INSTANCE (SATISFIES (LAMBDA (STRING)
(SEND STRING :OPERATION-HANDLED-P :STRING-FOR-PRINTING))))
(PUSH (SETQ S (SEND S :STRING-FOR-PRINTING)) FROB)
(INCF LENGTH (LENGTH S))
(SETQ B 8 TY 'ART-STRING))
(T
(FERROR "Cannot convert ~S into a string." S)))
(WHEN (> B BITS)
(SETQ BITS B TYPE TY)))
(SETQ FROB (NREVERSE FROB))
(LET ((STRING (MAKE-ARRAY LENGTH :TYPE TYPE))
(I 0)
COERCED)
(DOLIST (S STRINGS)
(TYPECASE S
(CHARACTER
(SETF (CHAR STRING I) S)
(INCF I 1))
(FIXNUM
(SETF (CHAR STRING I) (INT-CHAR S))
(INCF I 1))
(T (SETQ COERCED (TYPECASE S
(VECTOR S)
(SYMBOL (SYMBOL-NAME S))
(T (POP FROB))))
(COPY-ARRAY-PORTION COERCED 0 (SETQ LENGTH (LENGTH COERCED))
STRING I (INCF I LENGTH)))))
STRING))
(DEFUN STRING-NCONC (MUNG &REST STRINGS &AUX LEN FINAL-LEN S2LEN)
"STRING-NCONC extends the first string and tacks on any number of additional strings.
The first argument must be a string with a fill-pointer.
Returns the first argument, which may have been moved and forwarded,
just like ADJUST-ARRAY-SIZE."
(SETQ FINAL-LEN (SETQ LEN (FILL-POINTER MUNG)))
(DOLIST (STR2 STRINGS)
(SETQ FINAL-LEN (+ FINAL-LEN (STRING-LENGTH STR2))))
(AND (> FINAL-LEN (ARRAY-LENGTH MUNG))
(ADJUST-ARRAY-SIZE MUNG FINAL-LEN))
(DOLIST (STR2 STRINGS)
(TYPECASE STR2
(CHARACTER
(VECTOR-PUSH STR2 MUNG)
(INCF LEN 1))
(FIXNUM
(VECTOR-PUSH (INT-CHAR STR2) MUNG)
(INCF LEN 1))
(T (SETQ STR2 (IF (STRINGP STR2) STR2 (STRING STR2)) S2LEN (LENGTH STR2))
(COPY-ARRAY-PORTION STR2 0 S2LEN MUNG LEN (INCF LEN S2LEN))
(SETF (FILL-POINTER MUNG) LEN))))
MUNG)
(DEFUN NSUBSTRING (STRING FROM &OPTIONAL TO (AREA NIL)
&AUX LENGTH ARRAYTYPE)
"Return a displaced array whose data is part of STRING, from FROM to TO.
If you modify the contents of the displaced array, the original string changes.
If TO is omitted or NIL, the substring runs up to the end of the string.
If AREA is specified, the displaced array is made in that area."
(COERCE-STRING-ARG STRING)
(OR TO (SETQ TO (LENGTH STRING)))
(ASSERT ( 0 FROM TO (LENGTH STRING))
(FROM TO STRING)
"Args ~S and ~S out of range for ~S."
FROM TO STRING)
(SETQ LENGTH (- TO FROM))
(SETQ ARRAYTYPE (ARRAY-TYPE STRING))
(COND ((NOT (ARRAY-INDEXED-P STRING))
(MAKE-ARRAY LENGTH :TYPE ARRAYTYPE
:AREA AREA
:DISPLACED-TO STRING
:DISPLACED-INDEX-OFFSET FROM))
;; Otherwise, probably a substring of a substring
(T
(MAKE-ARRAY LENGTH :TYPE ARRAYTYPE
:AREA AREA
:DISPLACED-TO (ARRAY-INDIRECT-TO STRING)
;; Point to array pointed to originally
:DISPLACED-INDEX-OFFSET
(+ FROM (ARRAY-INDEX-OFFSET STRING))))))
(DEFUN SUBSTRING (STRING FROM &OPTIONAL TO (AREA NIL))
"Return a copy of part of STRING, from FROM to TO.
If TO is omitted, the copied part is up to the end of the string.
If AREA is specified, the new string is made in that area."
;; Nice and modular but conses up the wazoo
;; (STRING-APPEND (NSUBSTRING STRING FROM TO))
;; What's wrong with consing up wazoos? Do they take up lots of space?
;; No, but they make a lot of noise.
(COERCE-STRING-ARG STRING)
(OR TO (SETQ TO (LENGTH STRING)))
(ASSERT ( 0 FROM TO (LENGTH STRING))
(FROM TO STRING)
"Args ~S and ~S out of range for ~S."
FROM TO STRING)
(LET ((RES (MAKE-ARRAY (- TO FROM) :TYPE (%P-LDB-OFFSET %%ARRAY-TYPE-FIELD STRING 0) ;;*********
:AREA AREA)))
(COPY-ARRAY-PORTION STRING FROM TO
RES 0 (ARRAY-LENGTH RES))
RES))
(DEFUN SUBSTRING-AFTER-CHAR (CHAR STRING &OPTIONAL START END AREA)
"Return the part of STRING that follows the first occurrence of CHAR after START.
Only the part of STRING up to END is searched, and the substring stops there too.
The value is a newly created string, in area AREA (or the default area)."
(OR START (SETQ START 0))
(OR END (SETQ END (STRING-LENGTH STRING)))
(LET ((IDX (STRING-SEARCH-CHAR CHAR STRING START END)))
(IF (NULL IDX) ""
(SUBSTRING STRING (1+ IDX) END AREA))))
(DEFUN STRING-LENGTH (STRING)
"Return the length of STRING, in characters."
(TYPECASE STRING
(STRING
(LENGTH STRING))
((OR INTEGER CHARACTER)
1)
(SYMBOL
(LENGTH (SYMBOL-NAME STRING)))
((AND INSTANCE (SATISFIES (LAMBDA (STRING)
(SEND STRING :OPERATION-HANDLED-P :STRING-FOR-PRINTING))))
(STRING-LENGTH (SEND STRING :STRING-FOR-PRINTING)))
(T
(FERROR "Cannot convert ~S into a string." STRING))))
(DEFUN STRING-EQUAL (STRING1 STRING2 &REST ARGS) ;CL compatible
"T if STRING1 and STRING2's contents are the same.
Case is ignored in comparing characters.
The keyword arguments allow you to compare only part of a string.
The range of STRING1 to be compared runs from START1 to END1
and the range of STRING2 runs from START2 to END2.
If END1 or END2 omitted or NIL, the end of that string is used."
(DECLARE (ARGLIST STRING1 STRING2 &KEY (START1 0) END1 (START2 0) END2))
(LET (IDX1 IDX2 LIM1 LIM2
(ALPHABETIC-CASE-AFFECTS-STRING-COMPARISON NIL))
(IF (KEYWORDP (CAR ARGS))
(SETQ IDX1 (GETF ARGS ':START1)
IDX2 (GETF ARGS ':START2)
LIM1 (GETF ARGS ':END1)
LIM2 (GETF ARGS ':END2))
(LIST-MATCH-P ARGS `(,IDX1 ,IDX2 ,LIM1 ,LIM2)))
(OR IDX1 (SETQ IDX1 0))
(OR IDX2 (SETQ IDX2 0))
(COERCE-STRING-ARG STRING1)
(COERCE-STRING-ARG STRING2)
(COND ((OR LIM1 LIM2)
(OR LIM1 (SETQ LIM1 (LENGTH STRING1)))
(OR LIM2 (SETQ LIM2 (LENGTH STRING2)))
(AND (= (SETQ LIM1 (- LIM1 IDX1)) (- LIM2 IDX2))
(%STRING-EQUAL STRING1 IDX1 STRING2 IDX2 LIM1))) ;;**********************
(T (%STRING-EQUAL STRING1 IDX1 STRING2 IDX2 NIL))))) ;;**********************
(DEFUN STRING= (STRING1 STRING2 &KEY (START1 0) END1 (START2 0) END2) ;CL compatible
"T if STRING1 and STRING2's contents are the same, case being significant.
The keyword arguments allow you to compare only part of a string.
The range of STRING1 to be compared runs from START1 to END1
and the range of STRING2 runs from START2 to END2.
If END1 or END2 omitted or NIL, the end of that string is used."
(LET ((ALPHABETIC-CASE-AFFECTS-STRING-COMPARISON T))
(COERCE-STRING-ARG STRING1)
(COERCE-STRING-ARG STRING2)
(COND ((OR END1 END2)
(OR END1 (SETQ END1 (LENGTH STRING1)))
(OR END2 (SETQ END2 (LENGTH STRING2)))
(AND (= (SETQ END1 (- END1 START1)) (- END2 START2))
(%STRING-EQUAL STRING1 START1 STRING2 START2 END1))) ;;**********************
(T (%STRING-EQUAL STRING1 START1 STRING2 START2 NIL))))) ;;**********************
(DEFUN STRING-NOT-EQUAL (STRING1 STRING2 &KEY (START1 0) END1 (START2 0) END2) ;CL compatible
"True if STRING1 (or substring) is different from STRING2 (or substring).
The value is actually the index of the first difference between the strings.
Keyword arg :START1 is where to start comparing, in STRING1, and :END1 where to stop.
Similar for :START2 and :END2. Case is ignored when comparing letters."
(LET ((V (STRING-COMPARE STRING1 STRING2 START1 START2 END1 END2)))
(UNLESS (ZEROP V) (1- (ABS V)))))
(defun string-matchp (string1 string2)
"Like STRING-EQUAL but STRING1 can have wildchar indicators:
`%' = match one character, `*' = match any number of characters from STRING2"
;; 17-Mar-86 17:16:08 -gjc
(IF (or (string-search #\* string1)
(string-search #\% string1))
(string-matchp-1 string1 0 (string-length string1)
string2 0 (string-length string2))
(string-equal string1 string2)))
(defun string-matchp-1 (string1 i1 n1 string2 i2 n2)
(prog (temp)
loop
(if (and (= i1 n1) (= i2 n2)) (return t))
(if (= i1 n1) (return nil))
(if (= i2 n2) (go check-star))
(when (or (char-equal (setq temp (aref string1 i1)) #\%)
(char-equal temp (aref string2 i2)))
(setq i1 (1+ i1) i2 (1+ i2))
(go loop))
check-star
(if (char-equal (aref string1 i1) #\*)
(cond ((= (1+ i1) n1) (return t))
((= i2 n2) (return nil))
((string-matchp-1 string1 (1+ i1) n1 string2 (1+ i2) n2)
(return t))
((string-matchp-1 string1 i1 n1 string2 (1+ i2) n2)
(return t))
('else
(setq i1 (1+ i1))
(go loop)))
(return nil))))
(DEFSUBST MAKE-STRING (LENGTH &REST KEYWORD-ARGS)
"Creates and returns a string of LENGTH elements, all set to INITIAL-ELEMENT.
If INITIAL-VALUE is not supplied, the elements contain the character with code 0."
(DECLARE (ARGLIST LENGTH &KEY INITIAL-ELEMENT &ALLOW-OTHER-KEYS))
(APPLY #'MAKE-ARRAY LENGTH :TYPE ART-STRING KEYWORD-ARGS))
(DEFUN ARRAY-TYPE (ARRAY)
"Return the name of the array-type of ARRAY.
The value is a symbol such as ART-Q."
(CHECK-TYPE ARRAY ARRAY)
(NTH (%P-LDB-OFFSET %%ARRAY-TYPE-FIELD ARRAY 0) ARRAY-TYPES)) ;;**********************
(DEFUN STRING-SEARCH-CHAR (CHAR STRING &OPTIONAL (FROM 0) TO (CONSIDER-CASE alphabetic-case-affects-string-comparison)
&AUX (ALPHABETIC-CASE-AFFECTS-STRING-COMPARISON CONSIDER-CASE))
"Returns the index in STRING of the first occurrence of CHAR past FROM, or NIL if none.
If TO is non-NIL, the search stops there, and the value is NIL
if CHAR is not found before there.
Case matters during character comparison if CONSIDER-CASE is non-NIL."
(CHECK-TYPE CHAR (OR CHARACTER FIXNUM) "a character")
(COERCE-STRING-SEARCH-ARG STRING)
(OR TO (SETQ TO (LENGTH STRING)))
(%STRING-SEARCH-CHAR CHAR STRING FROM TO)) ;;**********************
(DEFUN STRING-REVERSE-SEARCH-CHAR (CHAR STRING &OPTIONAL FROM (TO 0) CONSIDER-CASE)
"Returns the index in STRING of the last occurrence of CHAR before FROM, or NIL if none.
If TO is non-zero, the search stops there, and the value is NIL
if CHAR does not appear after there. TO should normally be less than FROM.
If FROM is omitted or NIL, the default is the end of the string.
Case matters during character comparison if CONSIDER-CASE is non-NIL."
(IF (FIXNUMP CHAR) (SETQ CHAR (INT-CHAR CHAR)))
(CHECK-TYPE CHAR CHARACTER)
(COERCE-STRING-SEARCH-ARG STRING)
(OR FROM (SETQ FROM (LENGTH STRING)))
(IF CONSIDER-CASE
(DO ((I (1- FROM) (1- I)))
((< I TO) NIL)
(AND (CHAR= CHAR (CHAR STRING I))
(RETURN I)))
(DO ((I (1- FROM) (1- I)))
((< I TO) NIL)
(AND (CHAR-EQUAL CHAR (CHAR STRING I))
(RETURN I)))))
(DEFUN STRING-SEARCH-NOT-CHAR (CHAR STRING &OPTIONAL (FROM 0) TO CONSIDER-CASE)
"Returns the index in STRING of the first character past FROM not equal to CHAR, or NIL.
If TO is non-NIL, the search stops there, and the value is NIL
if a character different from CHAR is not found before there.
Case matters during character comparison if CONSIDER-CASE is non-NIL."
(IF (FIXNUMP CHAR) (SETQ CHAR (INT-CHAR CHAR)))
(CHECK-TYPE CHAR CHARACTER)
(COERCE-STRING-SEARCH-ARG STRING)
(OR TO (SETQ TO (LENGTH STRING)))
(IF CONSIDER-CASE
(DO ((I FROM (1+ I)))
(( I TO) NIL)
(OR (CHAR= CHAR (CHAR STRING I))
(RETURN I)))
(DO ((I FROM (1+ I)))
(( I TO) NIL)
(OR (CHAR-EQUAL CHAR (CHAR STRING I))
(RETURN I)))))
(DEFUN STRING-REVERSE-SEARCH-NOT-CHAR (CHAR STRING &OPTIONAL FROM (TO 0) CONSIDER-CASE)
"Returns the index in STRING of the last character before FROM not equal to CHAR, or NIL.
If TO is non-zero, the search stops there, and the value is NIL
if no character different from CHAR appears after there.
TO should normally be less than FROM.
If FROM is omitted or NIL, the default is the end of the string.
Case matters during character comparison if CONSIDER-CASE is non-NIL."
(IF (FIXNUMP CHAR) (SETQ CHAR (INT-CHAR CHAR)))
(CHECK-TYPE CHAR CHARACTER)
(COERCE-STRING-SEARCH-ARG STRING)
(OR FROM (SETQ FROM (LENGTH STRING)))
(IF CONSIDER-CASE
(DO ((I (1- FROM) (1- I)))
((< I TO) NIL)
(OR (CHAR= CHAR (CHAR STRING I))
(RETURN I)))
(DO ((I (1- FROM) (1- I)))
((< I TO) NIL)
(OR (CHAR-EQUAL CHAR (CHAR STRING I))
(RETURN I)))))
(DEFUN STRING-SEARCH (KEY STRING &OPTIONAL (FROM 0) TO (KEY-FROM 0) KEY-TO
(CONSIDER-CASE alphabetic-case-affects-string-comparison)
&AUX (ALPHABETIC-CASE-AFFECTS-STRING-COMPARISON CONSIDER-CASE)
KEY-LEN)
"Returns the index in STRING of the first occurrence of KEY past FROM, or NIL.
If TO is non-NIL, the search stops there, and the value is NIL
if no occurrence of KEY is found before there.
KEY-FROM and KEY-TO may be used to specify searching for just a substring of KEY.
CONSIDER-CASE if non-NIL means we distinguish letters by case."
(COERCE-STRING-SEARCH-ARG STRING)
(COERCE-STRING-ARG KEY) ;??
(UNLESS KEY-TO
(SETQ KEY-TO (LENGTH KEY)))
(SETQ KEY-LEN (- KEY-TO KEY-FROM))
(OR TO (SETQ TO (LENGTH STRING)))
(COND ((= KEY-FROM KEY-TO)
(AND ( FROM TO) FROM))
(T
(SETQ TO (1+ (- TO KEY-LEN))) ;Last position at which key may start + 1
(PROG (CH1)
(WHEN (MINUSP TO) (RETURN NIL))
(SETQ CH1 (CHAR KEY KEY-FROM))
LOOP ;Find next place key might start
(OR (SETQ FROM (%STRING-SEARCH-CHAR CH1 STRING FROM TO)) ;;********************
(RETURN NIL))
(AND (%STRING-EQUAL KEY KEY-FROM STRING FROM KEY-LEN) ;;********************
(RETURN FROM))
(INCF FROM) ;Avoid infinite loop. %STRING-SEARCH-CHAR
(GO LOOP))))) ; does right thing if from to.
(DEFUN STRING-REVERSE-SEARCH (KEY STRING &OPTIONAL FROM (TO 0) (KEY-FROM 0) KEY-TO
(CONSIDER-CASE alphabetic-case-affects-string-comparison)
&AUX (ALPHABETIC-CASE-AFFECTS-STRING-COMPARISON CONSIDER-CASE)
KEY-LEN)
"Returns the index in STRING of the last occurrence before FROM of KEY, or NIL.
If TO is non-zero, the search stops there, and the value is NIL
if no occurrence of KEY is found after there.
TO should normally be less than FROM.
If FROM is omitted or NIL, the default is the end of the string.
KEY-FROM and KEY-TO may be used to specify searching for just a substring of KEY.
CONSIDER-CASE if non-NIL means we distinguish letters by case."
(COERCE-STRING-SEARCH-ARG STRING)
(COERCE-STRING-ARG KEY) ;??
(UNLESS KEY-TO (SETQ KEY-TO (LENGTH KEY)))
(SETQ KEY-LEN (- KEY-TO KEY-FROM))
(OR FROM (SETQ FROM (LENGTH STRING)))
(SETQ TO (+ TO (1- KEY-LEN))) ;First position at which last char of key may be
(IF (ZEROP KEY-LEN)
FROM
(DO ((N (1- FROM) (1- N))
(CH1 (CHAR KEY (1- KEY-TO))))
((< N TO) NIL)
(AND (CHAR-EQUAL (CHAR STRING N) CH1)
(%STRING-EQUAL KEY KEY-FROM STRING (1+ (- N KEY-LEN)) KEY-LEN) ;;**********************
(RETURN (1+ (- N KEY-LEN)))))))
(DEFUN STRING-UPCASE (STRING &KEY (START 0) END) ;CL compatible
"Return a copy of STRING with all characters converted to upper case.
START and END can be used to control which part of STRING is
converted, but the entire string will be copied.
Fonts in the characters are not changed."
(SETQ STRING (STRING-APPEND STRING)) ;Copy so we don't mung original string
;Note COPY-SEQ is incorrect here.
(DO ((LEN (OR END (LENGTH STRING)))
(CHAR)
(I START (1+ I)))
((= I LEN))
(SETQ CHAR (CHAR STRING I))
(WHEN (LOWER-CASE-P CHAR)
(SETF (CHAR STRING I) (CHAR-UPCASE CHAR))))
STRING)
(DEFUN STRING-DOWNCASE (STRING &KEY (START 0) END) ;CL compatible
"Return a copy of STRING with all letters converted to lower case.
START and END can be used to control which part of STRING is
converted, but the entire string will be copied.
Fonts in the characters are not changed."
(SETQ STRING (STRING-APPEND STRING)) ;Copy so we don't mung original string
;Note COPY-SEQ is incorrect here.
(DO ((LEN (OR END (LENGTH STRING)))
(CHAR)
(I START (1+ I)))
((= I LEN))
(SETQ CHAR (CHAR STRING I))
(WHEN (UPPER-CASE-P CHAR)
(SETF (CHAR STRING I) (CHAR-DOWNCASE CHAR))))
STRING)
(defun string-flipcase (string &optional (start 0) end (copy-p t))
"Invert the case (upperlower) of characters in STRING.
Does not affect characters which are not alphabetic.
Symbol*cs braindamage means that this does not take the same argument pattern as
STRING-UP//DOWNCASE."
(if copy-p (setq string (string-append string)))
(do ((len (or end (length string)))
(char)
(i start (1+ i)))
((= i len))
(setq char (char string i))
(cond ((upper-case-p char) (setf (char string i) (char-downcase char)))
((lower-case-p char) (setf (char string i) (char-upcase char)))))
string)
(DEFUN STRING-CAPITALIZE (STRING &OPTIONAL &KEY (START 0) END SPACES) ;CL compatible
"In STRING, turn hyphens to spaces and make each word be capitalized.
START and END limit the portion of the string converted,
but in any case the entire string is copied.
If SPACES is T, hyphens are changed to spaces."
(SETQ STRING (STRING-APPEND STRING)) ;Copy so we don't mung original string
;Note COPY-SEQ is incorrect here.
(DO ((I START (1+ I))
(LEN (OR END (LENGTH STRING)))
PREV-LETTER CH)
((= I LEN))
(SETQ CH (CHAR STRING I))
(COND ((AND SPACES (CHAR= CH #/-))
(SETF (CHAR STRING I) #/SPACE)
(SETQ PREV-LETTER NIL))
((UPPER-CASE-P CH)
(WHEN PREV-LETTER
(SETF (CHAR STRING I) (CHAR-DOWNCASE CH)))
(SETQ PREV-LETTER T))
((LOWER-CASE-P CH)
(UNLESS PREV-LETTER
(SETF (CHAR STRING I) (CHAR-UPCASE CH)))
(SETQ PREV-LETTER T))
((DIGIT-CHAR-P CH)
(SETQ PREV-LETTER T))
(T (SETQ PREV-LETTER NIL))))
STRING)
(DEFUN NSTRING-UPCASE (STRING &KEY (START 0) END) ;CL compatible
"Return a copy of STRING with all characters converted to upper case.
START and END can be used to control which part of STRING is
converted, but the entire string will be copied.
Fonts in the characters are not changed."
(DO ((LEN (OR END (LENGTH STRING)))
(CHAR)
(I START (1+ I)))
((= I LEN))
(SETQ CHAR (CHAR STRING I))
(WHEN (LOWER-CASE-P CHAR)
(SETF (CHAR STRING I) (CHAR-UPCASE CHAR))))
STRING)
(DEFUN NSTRING-DOWNCASE (STRING &KEY (START 0) END) ;CL compatible
"Return a copy of STRING with all letters converted to lower case.
START and END can be used to control which part of STRING is
converted, but the entire string will be copied.
Fonts in the characters are not changed."
(DO ((LEN (OR END (LENGTH STRING)))
(CHAR)
(I START (1+ I)))
((= I LEN))
(SETQ CHAR (CHAR STRING I))
(WHEN (UPPER-CASE-P CHAR)
(SETF (CHAR STRING I) (CHAR-DOWNCASE CHAR))))
STRING)
(DEFUN NSTRING-CAPITALIZE (STRING &OPTIONAL &KEY (START 0) END SPACES) ;CL compatible
"In STRING, turn hyphens to spaces and make each word be capitalized.
START and END limit the portion of the string converted,
but in any case the entire string is copied.
If SPACES is T, hyphens are changed to spaces."
(DO ((I START (1+ I))
(LEN (OR END (LENGTH STRING)))
PREV-LETTER CH)
((= I LEN))
(SETQ CH (CHAR STRING I))
(COND ((AND SPACES (= CH #/-))
(SETF (CHAR STRING I) #/SPACE)
(SETQ PREV-LETTER NIL))
((UPPER-CASE-P CH)
(WHEN PREV-LETTER
(SETF (CHAR STRING I) (CHAR-DOWNCASE CH)))
(SETQ PREV-LETTER T))
((LOWER-CASE-P CH)
(UNLESS PREV-LETTER
(SETF (CHAR STRING I) (CHAR-UPCASE CH)))
(SETQ PREV-LETTER T))
((DIGIT-CHAR-P CH)
(SETQ PREV-LETTER T))
(T (SETQ PREV-LETTER NIL))))
STRING)
(DEFUN STRING-CAPITALIZE-WORDS (STRING &OPTIONAL (COPY-P T) (SPACES T))
"In STRING, turn hyphens to spaces and make each word be capitalized.
If SPACES is NIL, hyphens are not changed.
Copies the original string unless COPY-P is NIL, meaning mung the original."
(OR (AND (NOT COPY-P) (STRINGP STRING))
(SETQ STRING (STRING-APPEND STRING)))
(NSTRING-CAPITALIZE STRING :SPACES SPACES))
(DEFUN STRING-REMOVE-FONTS (STRING)
"Return a copy of STRING, with all characters changed to font 0.
If STRING already has all characters in font 0, it may not be copied."
(IF (AND (VECTORP STRING)
(EQ (ARRAY-TYPE STRING) 'ART-STRING))
STRING
(LET ((NEWSTRING (MAKE-STRING (LENGTH STRING))))
;; this ignores high bits
(COPY-ARRAY-CONTENTS STRING NEWSTRING)
NEWSTRING)))
(DEFUN STRING-NREVERSE (STRING &AUX LEN)
"Destructively modify string by reversing the order of its elements.
Actually, this will work on any one-dimensional array."
(TYPECASE STRING
((OR FIXNUM CHARACTER))
(T (TYPECASE STRING
(VECTOR)
(SYMBOL
; no longer needed since pnames are now in a read-only area
; ;; Special treatment to avoid munging symbols
; (WHEN (SYMBOL-PACKAGE STRING)
; (FERROR "Illegal to mung the PNAME of an interned symbol."))
(SETQ STRING (SYMBOL-NAME STRING)))
(T (COERCE-STRING-ARG STRING)))
(SETQ LEN (LENGTH STRING))
(DO ((I 0 (1+ I))
(J (1- LEN) (1- J)))
((< J I))
(SWAPF (CHAR STRING I) (CHAR STRING J)))))
STRING)
(DEFUN STRING-REVERSE (STRING)
"Return a string whose elements are those of STRING, in reverse order.
Actually, this will work on any one-dimensional array."
(STRING-NREVERSE (IF (STRINGP STRING) (COPY-SEQ STRING) (STRING STRING))))
;;; Internal function.
(DEFUN ARRAY-MEM (FUNCTION ITEM ARRAY)
(DOTIMES (I (LENGTH ARRAY))
(IF (FUNCALL FUNCTION ITEM (CL:AREF ARRAY I))
(RETURN T))))
(DEFUN STRING-SEARCH-SET (CHAR-SET STRING &OPTIONAL (FROM 0) TO CONSIDER-CASE)
"Returns the index in STRING of the first char past FROM that's in CHAR-SET, or NIL.
CHAR-SET can be a list of characters or a string.
If TO is non-NIL, the search stops there, and the value is NIL
if no occurrence of a char in CHAR-SET is found before there.
Case matters during character comparison if CONSIDER-CASE is non-NIL."
(CTYPECASE CHAR-SET
((OR CHARACTER FIXNUM)
(STRING-SEARCH-CHAR CHAR-SET STRING FROM TO CONSIDER-CASE))
(SEQUENCE
(IF (NULL CHAR-SET)
NIL
(COERCE-STRING-SEARCH-ARG STRING)
(OR TO (SETQ TO (LENGTH STRING)))
(DO ((I FROM (1+ I))
(FUN (IF (CL:LISTP CHAR-SET) #'MEM #'ARRAY-MEM)))
(( I TO) NIL)
(AND (IF CONSIDER-CASE
(FUNCALL FUN #'CHAR= (CHAR STRING I) CHAR-SET)
(FUNCALL FUN #'CHAR-EQUAL (CHAR STRING I) CHAR-SET))
(RETURN I)))))))
(DEFUN STRING-REVERSE-SEARCH-SET (CHAR-SET STRING &OPTIONAL FROM (TO 0) CONSIDER-CASE)
"Returns the index in STRING of the last char before FROM that's in CHAR-SET, or NIL.
CHAR-SET can be a list of characters or a string.
If TO is non-NIL, the search stops there, and the value is NIL
if no occurrence of a char in CHAR-SET is found after there.
TO is normally less than FROM.
Case matters during character comparison if CONSIDER-CASE is non-NIL."
(CTYPECASE CHAR-SET
((OR CHARACTER FIXNUM)
(STRING-REVERSE-SEARCH-CHAR CHAR-SET STRING FROM TO CONSIDER-CASE))
(SEQUENCE
(IF (NULL CHAR-SET)
NIL
(COERCE-STRING-SEARCH-ARG STRING)
(OR FROM (SETQ FROM (LENGTH STRING)))
(DO ((I (1- FROM) (1- I))
(FUN (IF (CL:LISTP CHAR-SET) #'MEM #'ARRAY-MEM)))
((< I TO) NIL)
(AND (IF CONSIDER-CASE
(FUNCALL FUN #'CHAR= (CHAR STRING I) CHAR-SET)
(FUNCALL FUN #'CHAR-EQUAL (CHAR STRING I) CHAR-SET))
(RETURN I)))))))
(DEFUN STRING-SEARCH-NOT-SET (CHAR-SET STRING &OPTIONAL (FROM 0) TO CONSIDER-CASE)
"Returns the index in STRING of the first char past FROM that's NOT in CHAR-SET, or NIL.
CHAR-SET can be a list of characters or a string.
If TO is non-NIL, the search stops there, and the value is NIL
if no occurrence of a char not in CHAR-SET is found before there.
Case matters during character comparison if CONSIDER-CASE is non-NIL."
(CTYPECASE CHAR-SET
((OR CHARACTER FIXNUM)
(STRING-SEARCH-NOT-CHAR CHAR-SET STRING FROM TO CONSIDER-CASE))
(SEQUENCE
(IF (NULL CHAR-SET)
NIL
(COERCE-STRING-SEARCH-ARG STRING)
(OR TO (SETQ TO (LENGTH STRING)))
(DO ((I FROM (1+ I))
(FUN (IF (CL:LISTP CHAR-SET) #'MEM #'ARRAY-MEM)))
(( I TO) NIL)
(OR (IF CONSIDER-CASE
(FUNCALL FUN #'CHAR= (CHAR STRING I) CHAR-SET)
(FUNCALL FUN #'CHAR-EQUAL (CHAR STRING I) CHAR-SET))
(RETURN I)))))))
(DEFUN STRING-REVERSE-SEARCH-NOT-SET (CHAR-SET STRING &OPTIONAL FROM (TO 0) CONSIDER-CASE)
"Returns the index in STRING of the last char before FROM that's NOT in CHAR-SET, or NIL.
CHAR-SET can be a list of characters or a string.
If TO is non-NIL, the search stops there, and the value is NIL
if no occurrence of a char not in CHAR-SET is found after there.
TO is normally less than FROM.
Case matters during character comparison if CONSIDER-CASE is non-NIL."
(CTYPECASE CHAR-SET
((OR CHARACTER FIXNUM)
(STRING-REVERSE-SEARCH-NOT-CHAR CHAR-SET STRING FROM TO CONSIDER-CASE))
(SEQUENCE
(IF (NULL CHAR-SET)
NIL
(COERCE-STRING-SEARCH-ARG STRING)
(OR FROM (SETQ FROM (LENGTH STRING)))
(DO ((I (1- FROM) (1- I))
(FUN (IF (CL:LISTP CHAR-SET) #'MEM #'ARRAY-MEM)))
((< I TO) NIL)
(OR (IF CONSIDER-CASE
(FUNCALL FUN #'CHAR= (CHAR STRING I) CHAR-SET)
(FUNCALL FUN #'CHAR-EQUAL (CHAR STRING I) CHAR-SET))
(RETURN I)))))))
(DEFUN STRING-TRIM (CHAR-SET STRING &AUX I J) ;CL compatible
"Return a copy of STRING with all characters in CHAR-SET removed at both ends.
CHAR-SET can be a list of characters or a string.
As of now, case is ignored in comparisons."
(COERCE-STRING-ARG STRING)
(SETQ I (STRING-SEARCH-NOT-SET CHAR-SET STRING 0 NIL T))
(IF (NULL I) ""
(SETQ J (STRING-REVERSE-SEARCH-NOT-SET CHAR-SET STRING NIL 0 T))
(SUBSTRING STRING I (1+ J))))
(DEFUN STRING-LEFT-TRIM (CHAR-SET STRING &AUX I) ;CL compatible
"Return a copy of STRING with all characters in CHAR-SET removed at the beginning.
CHAR-SET can be a list of characters or a string.
As of now, case is ignored in comparisons."
(COERCE-STRING-ARG STRING)
(SETQ I (STRING-SEARCH-NOT-SET CHAR-SET STRING 0 NIL T))
(IF I
(SUBSTRING STRING I (STRING-LENGTH STRING))
""))
(DEFUN STRING-RIGHT-TRIM (CHAR-SET STRING &AUX I) ;CL compatible
"Return a copy of STRING with all characters in CHAR-SET removed at the end.
CHAR-SET can be a list of characters or a string.
As of now, case is ignored in comparisons."
(COERCE-STRING-ARG STRING)
(SETQ I (STRING-REVERSE-SEARCH-NOT-SET CHAR-SET STRING NIL 0 T))
(IF I
(SUBSTRING STRING 0 (1+ I))
""))
(DEFUN STRING-SUBST-CHAR (NEW OLD STRING &OPTIONAL (COPY-P T) (RETAIN-FONT-P T))
"Substitute the NEW character at every occurence of OLD in STRING.
Copies the original string unless COPY-P is NIL, meaning mung the original.
If RETAIN-FONT-P is T, then the font of each repective OLD character is retained.
As of now, case is ignored in comparisons."
(OR (AND (NOT COPY-P) (STRINGP STRING))
(SETQ STRING (STRING-APPEND STRING)))
(LET ((END (STRING-LENGTH STRING)))
(DO ((NEW (CHARACTER NEW))
(OLD (CHARACTER OLD))
(I (%STRING-SEARCH-CHAR OLD STRING 0 END) (%STRING-SEARCH-CHAR OLD STRING I END)) ;******
TEM)
((NULL I))
(SETQ TEM (CHAR STRING I))
(SETF (CHAR STRING I)
(IF RETAIN-FONT-P
(MAKE-CHAR NEW (CHAR-BITS TEM) (CHAR-FONT TEM))
NEW))))
STRING)
;;; T means case matters in string comparisons, NIL means it is ignored.
;;; This is bound to T by certain routines, such as INTERN, but I do not
;;; recommend changing its global value to T rather than NIL; many system
;;; functions, or at least their user interfaces, assume that string
;;; comparison is case-insensitive.
;;>> What a crock
(DEFVAR-RESETTABLE ALPHABETIC-CASE-AFFECTS-STRING-COMPARISON () ()
"Microcode flag which controls whether %STRING-EQUAL and %STRING-SEARCH consider case.")
(DEFUN STRING-COMPARE (STR1 STR2 &OPTIONAL (IDX1 0) (IDX2 0) LIM1 LIM2
(CONSIDER-CASE ALPHABETIC-CASE-AFFECTS-STRING-COMPARISON))
"Compares the two substrings in dictionary order.
Returns a positive number if STR1>STR2.
Returns zero if STR1=STR2.
Returns a negative number if STR1<STR2.
If the strings are not equal, the absolute value of the number returned is
one more than the index (in STR1) at which the difference occured.
It is possible to compare only part of a string.
Only the part of STR1 from IDX1 to LIM1 is compared;
only the part of STR2 from IDX2 to LIM2 is compared."
(COERCE-STRING-ARG STR1)
(COERCE-STRING-ARG STR2)
(OR LIM1 (SETQ LIM1 (LENGTH STR1)))
(OR LIM2 (SETQ LIM2 (LENGTH STR2)))
(PROG ()
L (AND ( IDX1 LIM1)
(RETURN (IF (< IDX2 LIM2) (MINUS (1+ IDX1)) 0)))
(AND ( IDX2 LIM2)
(RETURN (1+ IDX1)))
(WHEN (IF CONSIDER-CASE
(CHAR= (CHAR STR1 IDX1) (CHAR STR2 IDX2))
(CHAR-EQUAL (CHAR STR1 IDX1) (CHAR STR2 IDX2)))
(INCF IDX1) (INCF IDX2)
(GO L))
(IF (IF CONSIDER-CASE
(CHAR< (CHAR STR1 IDX1) (CHAR STR2 IDX2))
(< (CHAR-UPCASE (CHAR STR1 IDX1)) (CHAR-UPCASE (CHAR STR2 IDX2))))
(RETURN (MINUS (1+ IDX1)))
(RETURN (1+ IDX1)))))
(DEFUN STRING< (STRING1 STRING2 &KEY (START1 0) END1 (START2 0) END2) ;CL compatible
"True if STRING1 (or substring) is less than STRING2 (or substring) in dictionary order.
The value is actually the index of the first difference between the strings.
Keyword arg :START1 is where to start comparing, in STRING1, and :END1 where to stop.
Similar for :START2 and :END2. Case is significant in the comparison."
(LET ((V (STRING-COMPARE STRING1 STRING2 START1 START2 END1 END2 T)))
(IF (MINUSP V) (1- (ABS V)))))
(DEFUN STRING> (STRING1 STRING2 &KEY (START1 0) END1 (START2 0) END2) ;CL compatible
"True if STRING1 (or substring) is greater than STRING2 (or substring) in dictionary order.
The value is actually the index of the first difference between the strings.
Keyword arg :START1 is where to start comparing, in STRING1, and :END1 where to stop.
Similar for :START2 and :END2. Case is significant in the comparison."
(LET ((V (STRING-COMPARE STRING1 STRING2 START1 START2 END1 END2 T)))
(IF (PLUSP V) (1- (ABS V)))))
;; Copied from LAD: RELEASE-3.SYS2; STRING.LISP#161 on 2-Oct-86 04:36:54
(DEFUN STRING<= (STRING1 STRING2 &KEY (START1 0) END1 (START2 0) END2) ;CL compatible
"True if STRING1 (or substring) is STRING2 (or substring) in dictionary order.
The value is actually the index of the first difference between the strings,
or their length if they match.
Keyword arg :START1 is where to start comparing, in STRING1, and :END1 where to stop.
Similar for :START2 and :END2. Case is significant in the comparison."
(LET ((V (STRING-COMPARE STRING1 STRING2 START1 START2 END1 END2 T)))
(COND ((MINUSP V) (- (ABS V) 1))
((ZEROP V) (- (OR END1 (LENGTH STRING1)) START1)))))
(DEFUN STRING>= (STRING1 STRING2 &KEY (START1 0) END1 (START2 0) END2) ;CL compatible
"True if STRING1 (or substring) is STRING2 (or substring) in dictionary order.
The value is actually the index of the first difference between the strings,
or their length if they match.
Keyword arg :START1 is where to start comparing, in STRING1, and :END1 where to stop.
Similar for :START2 and :END2. Case is significant in the comparison."
(LET ((V (STRING-COMPARE STRING1 STRING2 START1 START2 END1 END2 T)))
(COND ((PLUSP V) (1- V))
((ZEROP V) (- (OR END1 (LENGTH STRING1)) START1)))))
(DEFF STRING 'STRING>=)
;can't use (not (string= ...)) since need value returned
(DEFUN STRING//= (STRING1 STRING2 &KEY (START1 0) END1 (START2 0) END2) ;CL STRING/=
"True if STRING1 (or substring) and STRING2 (or substring) are different.
The value is actually the index of the first difference between the strings.
Keyword arg :START1 is where to start comparing, in STRING1, and :END1 where to stop.
Similar for :START2 and :END2. Case is significant in the comparison."
(LET ((V (STRING-COMPARE STRING1 STRING2 START1 START2 END1 END2 T)))
(UNLESS (ZEROP V) (1- (ABS V)))))
(DEFF STRING 'STRING//=)
(DEFUN STRING-LESSP (STRING1 STRING2 &KEY (START1 0) END1 (START2 0) END2) ;CL compatible
"True if STRING1 (or substring) is less than STRING2 (or substring) in dictionary order.
The value is actually the index of the first difference between the strings.
Keyword arg :START1 is where to start comparing, in STRING1, and :END1 where to stop.
Similar for :START2 and :END2. Case is ignored when comparing letters."
(LET ((V (STRING-COMPARE STRING1 STRING2 START1 START2 END1 END2 NIL)))
(IF (MINUSP V) (1- (ABS V)))))
(DEFUN STRING-GREATERP (STRING1 STRING2 &KEY (START1 0) END1 (START2 0) END2) ;CL compatible
"True if STRING1 (or substring) is greater than STRING2 (or substring) in dictionary order.
The value is actually the index of the first difference between the strings.
Keyword arg :START1 is where to start comparing, in STRING1, and :END1 where to stop.
Similar for :START2 and :END2. Case is ignored when comparing letters."
(LET ((V (STRING-COMPARE STRING1 STRING2 START1 START2 END1 END2 NIL)))
(IF (PLUSP V) (1- (ABS V)))))
;; Copied from LAD: RELEASE-3.SYS2; STRING.LISP#161 on 2-Oct-86 04:36:56
(DEFUN STRING-NOT-GREATERP (STRING1 STRING2 &KEY (START1 0) END1 (START2 0) END2) ;CL compatible
"True if STRING1 (or substring) is to STRING2 (or substring) in dictionary order.
The value is actually the index of the first difference between the strings,
or their length if they match.
Keyword arg :START1 is where to start comparing, in STRING1, and :END1 where to stop.
Similar for :START2 and :END2. Case is ignored when comparing letters."
(LET ((V (STRING-COMPARE STRING1 STRING2 START1 START2 END1 END2 NIL)))
(COND ((MINUSP V) (- (ABS V) 1))
((ZEROP V) (- (OR END1 (LENGTH STRING1)) START1)))))
(DEFUN STRING-NOT-LESSP (STRING1 STRING2 &KEY (START1 0) END1 (START2 0) END2) ;CL compatible
"True if STRING1 (or substring) is to STRING2 (or substring) in dictionary order.
The value is actually the index of the first difference between the strings,
or their length if they match.
Keyword arg :START1 is where to start comparing, in STRING1, and :END1 where to stop.
Similar for :START2 and :END2. Case is ignored when comparing letters."
(LET ((V (STRING-COMPARE STRING1 STRING2 START1 START2 END1 END2 NIL)))
(COND ((PLUSP V) (1- V))
((ZEROP V) (- (OR END1 (LENGTH STRING1)) START1)))))
(DEFUN ALPHALESSP (X Y)
"T if printed representation of X is less than that of Y.
Characters and numbers come before symbols//strings, before random objects, before lists.
Characters and numbers are compared using CHAR<; symbols//strings with STRING-LESSP;
random objecs by printing them(!); lists are compared recursively."
(IF (fixnump X) (SETQ X (INT-CHAR X)))
(IF (fixnump Y) (SETQ Y (INT-CHAR Y)))
(COND ((CHARACTERP X)
(OR (NOT (CHARACTERP Y))
(CHAR< X Y)))
((CHARACTERP Y) NIL)
((OR (SYMBOLP X) (STRINGP X))
(OR (NOT (OR (SYMBOLP Y) (STRINGP Y)))
(STRING-LESSP X Y)))
((OR (SYMBOLP Y) (STRINGP Y)) NIL)
((ATOM X) (OR (CONSP Y)
(STRING-LESSP (FORMAT NIL "~S" X) (FORMAT NIL "~S" Y))))
((ATOM Y) NIL)
(T (DO ((X1 X (CDR X1)) (Y1 Y (CDR Y1)))
((NULL Y1))
(OR X1 (RETURN T))
(AND (ALPHALESSP (CAR X1) (CAR Y1)) (RETURN T))
(AND (ALPHALESSP (CAR Y1) (CAR X1)) (RETURN NIL))))))
(DEFUN ALPHAEQUAL (X Y)
"T if X and Y print the same, or nearly so.
Exceptions: numbers and characters are compared using =
and a symbol and its pname compare as equal."
(IF (NUMBERP X) (SETQ X (INT-CHAR X)))
(IF (NUMBERP Y) (SETQ Y (INT-CHAR Y)))
(TYPECASE X
(CHARACTER
(AND (CHARACTERP Y)
(= X Y)))
((OR SYMBOL STRING)
(AND (OR (SYMBOLP Y) (STRINGP Y))
(STRING-EQUAL X Y)))
(ATOM
(AND (ATOM Y)
(STRING-EQUAL (FORMAT NIL "~S" X) (FORMAT NIL "~S" Y))))
(T (DO ((X1 X (CDR X1)) (Y1 Y (CDR Y1)))
((NULL X1) (NULL Y1))
(OR Y1 (RETURN NIL))
(OR (ALPHAEQUAL (CAR X1) (CAR Y1)) (RETURN NIL))))))
(DEFUN STRING (X) ;CL compatible
"Convert X to a string if possible."
(IF (fixnump X) (SETQ X (INT-CHAR X)))
(TYPECASE X
(STRING X)
(SYMBOL (SYMBOL-NAME X))
(STRING-CHAR
(VALUES (MAKE-STRING 1 :INITIAL-ELEMENT X)))
(INSTANCE
(SEND X :SEND-IF-HANDLES :STRING-FOR-PRINTING))
(T
(if (fixnum-arrayp x)
(let ((ans (make-string (array-active-length x))))
(dotimes (index (array-active-length x))
(setf (aref ans index)
(int-char (aref x index))))
ans)
(FERROR "Cannot convert ~S into a string." X)))))
(DEFUN ZL:CHARACTER (X)
"Convert X to a fixnum representing character if possible.
This is the same as (CHAR-INT (CL:CHARACTER X))"
(COND ((NUMBERP X)
X)
You can’t perform that action at this time.