« back to all changes in this revision
Viewing changes to operations.c
- browse files at revision 4
- compare with another revision
- download diff
- download tarball
- view history from revision 4
- Committer: Bazaar Package Importer
- Author(s): NIIBE Yutaka
- Date: 2006-05-23 21:46:41 UTC
- mfrom: (1.1.1 upstream)
- Revision ID: james.westby@ubuntu.com-20060523214641-6ix4gz34wpiehub8
Tags: 0.5.0-2
* debian/control (Build-Depends): Added ruby.
Thanks to Frederik Schueler. Closes: #368571
* debian/rules (clean): invoke 'distclean' instead of 'clean'.
Thanks to Frederik Schueler. Closes: #368571
* debian/rules (clean): invoke 'distclean' instead of 'clean'.
added
removed
operations.c
1
/*===========================================================================
2
* FileName : operations.c
3
* About : basic scheme procedure
4
*
5
* Copyright (C) 2005 by Kazuki Ohta (mover@hct.zaq.ne.jp)
6
*
7
* All rights reserved.
8
*
9
* Redistribution and use in source and binary forms, with or without
10
* modification, are permitted provided that the following conditions
11
* are met:
12
*
13
* 1. Redistributions of source code must retain the above copyright
14
* notice, this list of conditions and the following disclaimer.
15
* 2. Redistributions in binary form must reproduce the above copyright
16
* notice, this list of conditions and the following disclaimer in the
17
* documentation and/or other materials provided with the distribution.
18
* 3. Neither the name of authors nor the names of its contributors
19
* may be used to endorse or promote products derived from this software
20
* without specific prior written permission.
21
*
22
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS IS''
23
* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
24
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
25
* ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE
26
* LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
27
* CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
28
* GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
29
* HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
30
* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
31
* OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
32
* SUCH DAMAGE.
33
===========================================================================*/
34
/*=======================================
35
System Include
36
=======================================*/
37
#include <string.h>
38
#include <stdlib.h>
39
#include <limits.h>
40
41
/*=======================================
42
Local Include
43
=======================================*/
44
#include "sigscheme.h"
45
#include "sigschemeinternal.h"
46
47
/*=======================================
48
File Local Struct Declarations
49
=======================================*/
50
51
/*=======================================
52
File Local Macro Declarations
53
=======================================*/
54
55
/*=======================================
56
Variable Declarations
57
=======================================*/
58
59
/*=======================================
60
File Local Function Declarations
61
=======================================*/
62
static ScmObj ScmOp_listtail_internal(ScmObj obj, int k);
63
64
static ScmObj map_single_arg(ScmObj proc, ScmObj args);
65
static ScmObj map_multiple_args(ScmObj proc, ScmObj args);
66
67
/*=======================================
68
Function Implementations
69
=======================================*/
70
/*==============================================================================
71
R5RS : 6.1 Equivalence predicates
72
==============================================================================*/
73
ScmObj ScmOp_eqvp(ScmObj obj1, ScmObj obj2)
74
{
75
enum ScmObjType type;
76
DECLARE_FUNCTION("eqv?", ProcedureFixed2);
77
78
if (EQ(obj1, obj2))
79
return SCM_TRUE;
80
81
type = SCM_TYPE(obj1);
82
83
/* different type */
84
if (type != SCM_TYPE(obj2))
85
return SCM_FALSE;
86
87
/* same type */
88
switch (type) {
89
case ScmInt:
90
if ((SCM_INT_VALUE(obj1) == SCM_INT_VALUE(obj2)))
91
return SCM_TRUE;
92
break;
93
94
case ScmChar:
95
return ScmOp_char_equal(obj1, obj2);
96
97
#if SCM_DEBUG
98
case ScmFreeCell:
99
SigScm_Error("eqv? : cannnot compare freecell, gc broken?");
100
break;
101
#endif
102
103
default:
104
break;
105
}
106
107
return SCM_FALSE;
108
}
109
110
ScmObj ScmOp_eqp(ScmObj obj1, ScmObj obj2)
111
{
112
DECLARE_FUNCTION("eq?", ProcedureFixed2);
113
return (EQ(obj1, obj2)) ? SCM_TRUE : SCM_FALSE;
114
}
115
116
ScmObj ScmOp_equalp(ScmObj obj1, ScmObj obj2)
117
{
118
enum ScmObjType type;
119
int i = 0;
120
ScmObj elm1 = SCM_FALSE;
121
ScmObj elm2 = SCM_FALSE;
122
DECLARE_FUNCTION("equal?", ProcedureFixed2);
123
124
if (EQ(obj1, obj2))
125
return SCM_TRUE;
126
127
type = SCM_TYPE(obj1);
128
129
/* different type */
130
if (type != SCM_TYPE(obj2))
131
return SCM_FALSE;
132
133
/* same type */
134
switch (type) {
135
case ScmInt:
136
if ((SCM_INT_VALUE(obj1) == SCM_INT_VALUE(obj2)))
137
return SCM_TRUE;
138
break;
139
140
case ScmChar:
141
return ScmOp_char_equal(obj1, obj2);
142
143
case ScmString:
144
if (strcmp(SCM_STRING_STR(obj1), SCM_STRING_STR(obj2)) == 0)
145
return SCM_TRUE;
146
break;
147
148
case ScmCons:
149
for (; CONSP(obj1) && CONSP(obj2); obj1 = CDR(obj1), obj2 = CDR(obj2))
150
{
151
elm1 = CAR(obj1);
152
elm2 = CAR(obj2);
153
if (!EQ(elm1, elm2)
154
&& (SCM_TYPE(elm1) != SCM_TYPE(elm2)
155
|| FALSEP(ScmOp_equalp(elm1, elm2))))
156
return SCM_FALSE;
157
}
158
/* compare last cdr */
159
return (EQ(obj1, obj2)) ? SCM_TRUE : ScmOp_equalp(obj1, obj2);
160
161
case ScmVector:
162
if (SCM_VECTOR_LEN(obj1) != SCM_VECTOR_LEN(obj2))
163
return SCM_FALSE;
164
165
for (i = 0; i < SCM_VECTOR_LEN(obj1); i++) {
166
elm1 = SCM_VECTOR_CREF(obj1, i);
167
elm2 = SCM_VECTOR_CREF(obj2, i);
168
if (!EQ(elm1, elm2)
169
&& (SCM_TYPE(elm1) != SCM_TYPE(elm2)
170
|| FALSEP(ScmOp_equalp(elm1, elm2))))
171
return SCM_FALSE;
172
}
173
return SCM_TRUE;
174
175
#if SCM_USE_NONSTD_FEATURES
176
case ScmCPointer:
177
if (SCM_C_POINTER_VALUE(obj1) == SCM_C_POINTER_VALUE(obj2))
178
return SCM_TRUE;
179
break;
180
181
case ScmCFuncPointer:
182
if (SCM_C_FUNCPOINTER_VALUE(obj1) == SCM_C_FUNCPOINTER_VALUE(obj2))
183
return SCM_TRUE;
184
break;
185
#endif
186
187
#if SCM_DEBUG
188
case ScmFreeCell:
189
ERR("cannnot compare freecell, gc broken?");
190
break;
191
#endif
192
193
default:
194
break;
195
}
196
197
return SCM_FALSE;
198
}
199
200
/*=======================================
201
R5RS : 6.2 Numbers
202
=======================================*/
203
/*==============================================================================
204
R5RS : 6.2 Numbers : 6.2.5 Numerical Operations
205
==============================================================================*/
206
/* Note: SigScheme supports only the integer part of the numerical tower. */
207
208
ScmObj ScmOp_add(ScmObj left, ScmObj right, enum ScmReductionState *state)
209
{
210
int result = 0;
211
DECLARE_FUNCTION("+", ReductionOperator);
212
switch (*state) {
213
case SCM_REDUCE_PARTWAY:
214
case SCM_REDUCE_LAST:
215
ASSERT_INTP(left);
216
result = SCM_INT_VALUE(left);
217
/* Fall through. */
218
case SCM_REDUCE_1:
219
ASSERT_INTP(right);
220
result += SCM_INT_VALUE(right);
221
/* Fall through. */
222
case SCM_REDUCE_0:
223
break;
224
default:
225
ERR("(internal error) unrecognized state specifier: %d", *state);
226
}
227
228
return Scm_NewInt(result);
229
}
230
231
ScmObj ScmOp_multiply(ScmObj left, ScmObj right, enum ScmReductionState *state)
232
{
233
int result = 1;
234
DECLARE_FUNCTION("*", ReductionOperator);
235
switch (*state) {
236
case SCM_REDUCE_PARTWAY:
237
case SCM_REDUCE_LAST:
238
ASSERT_INTP(left);
239
result = SCM_INT_VALUE(left);
240
/* Fall through. */
241
case SCM_REDUCE_1:
242
ASSERT_INTP(right);
243
result *= SCM_INT_VALUE(right);
244
/* Fall through. */
245
case SCM_REDUCE_0:
246
break;
247
default:
248
ERR("(internal error) unrecognized state specifier: %d", *state);
249
}
250
251
return Scm_NewInt(result);
252
}
253
254
ScmObj ScmOp_subtract(ScmObj left, ScmObj right, enum ScmReductionState *state)
255
{
256
int result = 0;
257
DECLARE_FUNCTION("-", ReductionOperator);
258
switch (*state) {
259
case SCM_REDUCE_PARTWAY:
260
case SCM_REDUCE_LAST:
261
ASSERT_INTP(left);
262
result = SCM_INT_VALUE(left);
263
/* Fall through. */
264
case SCM_REDUCE_1:
265
ASSERT_INTP(right);
266
result -= SCM_INT_VALUE(right);
267
break;
268
269
case SCM_REDUCE_0:
270
ERR("at least 1 argument required");
271
default:
272
ERR("(internal error) unrecognized state specifier: %d", *state);
273
}
274
return Scm_NewInt(result);
275
}
276
277
ScmObj ScmOp_divide(ScmObj left, ScmObj right, enum ScmReductionState *state)
278
{
279
int result = 1;
280
DECLARE_FUNCTION("/", ReductionOperator);
281
switch (*state) {
282
case SCM_REDUCE_PARTWAY:
283
case SCM_REDUCE_LAST:
284
ASSERT_INTP(left);
285
result = SCM_INT_VALUE(left);
286
/* Fall through. */
287
case SCM_REDUCE_1:
288
ASSERT_INTP(right);
289
if (SCM_INT_VALUE(right) == 0)
290
ERR("division by zero");
291
result /= SCM_INT_VALUE(right);
292
break;
293
case SCM_REDUCE_0:
294
ERR("at least 1 argument required");
295
default:
296
ERR("(internal error) unrecognized state specifier: %d", *state);
297
}
298
return Scm_NewInt(result);
299
}
300
301
ScmObj ScmOp_numberp(ScmObj obj)
302
{
303
DECLARE_FUNCTION("number?", ProcedureFixed1);
304
return (INTP(obj)) ? SCM_TRUE : SCM_FALSE;
305
}
306
307
ScmObj ScmOp_equal(ScmObj left, ScmObj right, enum ScmReductionState *state)
308
{
309
DECLARE_FUNCTION("=", ReductionOperator);
310
#define COMPARATOR_BODY(op) \
311
switch (*state) { \
312
case SCM_REDUCE_0: \
313
case SCM_REDUCE_1: \
314
ERR("at least 2 arguments required"); \
315
case SCM_REDUCE_PARTWAY: \
316
case SCM_REDUCE_LAST: \
317
ASSERT_INTP(left); \
318
ASSERT_INTP(right); \
319
if (SCM_INT_VALUE(left) op SCM_INT_VALUE(right)) \
320
return *state == SCM_REDUCE_LAST ? SCM_TRUE : right; \
321
*state = SCM_REDUCE_STOP; \
322
return SCM_FALSE; \
323
default: \
324
ERR("(internal error) unrecognized state specifier: %d", *state); \
325
} \
326
return SCM_INVALID
327
328
COMPARATOR_BODY(==);
329
}
330
331
ScmObj ScmOp_less(ScmObj left, ScmObj right, enum ScmReductionState *state)
332
{
333
DECLARE_FUNCTION("<", ReductionOperator);
334
COMPARATOR_BODY(<);
335
}
336
337
ScmObj ScmOp_less_eq(ScmObj left, ScmObj right, enum ScmReductionState *state)
338
{
339
DECLARE_FUNCTION("<=", ReductionOperator);
340
COMPARATOR_BODY(<=);
341
}
342
343
ScmObj ScmOp_greater(ScmObj left, ScmObj right, enum ScmReductionState *state)
344
{
345
DECLARE_FUNCTION(">", ReductionOperator);
346
COMPARATOR_BODY(>);
347
}
348
349
ScmObj ScmOp_greater_eq(ScmObj left, ScmObj right, enum ScmReductionState *state)
350
{
351
DECLARE_FUNCTION(">=", ReductionOperator);
352
COMPARATOR_BODY(>=);
353
#undef COMPARATOR_BODY
354
}
355
356
ScmObj ScmOp_zerop(ScmObj scm_num)
357
{
358
DECLARE_FUNCTION("zero?", ProcedureFixed1);
359
ASSERT_INTP(scm_num);
360
return (SCM_INT_VALUE(scm_num) == 0) ? SCM_TRUE : SCM_FALSE;
361
}
362
363
ScmObj ScmOp_positivep(ScmObj scm_num)
364
{
365
DECLARE_FUNCTION("positive?", ProcedureFixed1);
366
ASSERT_INTP(scm_num);
367
return (SCM_INT_VALUE(scm_num) > 0) ? SCM_TRUE : SCM_FALSE;
368
}
369
370
ScmObj ScmOp_negativep(ScmObj scm_num)
371
{
372
DECLARE_FUNCTION("negative?", ProcedureFixed1);
373
ASSERT_INTP(scm_num);
374
return (SCM_INT_VALUE(scm_num) < 0) ? SCM_TRUE : SCM_FALSE;
375
}
376
377
ScmObj ScmOp_oddp(ScmObj scm_num)
378
{
379
DECLARE_FUNCTION("odd?", ProcedureFixed1);
380
ASSERT_INTP(scm_num);
381
return (SCM_INT_VALUE(scm_num) & 0x1) ? SCM_TRUE : SCM_FALSE;
382
}
383
384
ScmObj ScmOp_evenp(ScmObj scm_num)
385
{
386
DECLARE_FUNCTION("even?", ProcedureFixed1);
387
ASSERT_INTP(scm_num);
388
return (SCM_INT_VALUE(scm_num) & 0x1) ? SCM_FALSE : SCM_TRUE;
389
}
390
391
ScmObj ScmOp_max(ScmObj left, ScmObj right, enum ScmReductionState *state)
392
{
393
DECLARE_FUNCTION("max", ReductionOperator);
394
if (*state == SCM_REDUCE_0)
395
ERR("at least 1 argument required");
396
ASSERT_INTP(left);
397
ASSERT_INTP(right);
398
399
return SCM_INT_VALUE(left) > SCM_INT_VALUE(right) ? left : right;
400
}
401
402
ScmObj ScmOp_min(ScmObj left, ScmObj right, enum ScmReductionState *state)
403
{
404
DECLARE_FUNCTION("min", ReductionOperator);
405
if (*state == SCM_REDUCE_0)
406
ERR("at least 1 argument required");
407
ASSERT_INTP(left);
408
ASSERT_INTP(right);
409
410
return SCM_INT_VALUE(left) < SCM_INT_VALUE(right) ? left : right;
411
}
412
413
414
ScmObj ScmOp_abs(ScmObj scm_num)
415
{
416
int num = 0;
417
DECLARE_FUNCTION("abs", ProcedureFixed1);
418
419
ASSERT_INTP(scm_num);
420
421
num = SCM_INT_VALUE(scm_num);
422
423
return (num < 0) ? Scm_NewInt(-num) : scm_num;
424
}
425
426
ScmObj ScmOp_quotient(ScmObj scm_n1, ScmObj scm_n2)
427
{
428
int n1 = 0;
429
int n2 = 0;
430
DECLARE_FUNCTION("quotient", ProcedureFixed2);
431
432
ASSERT_INTP(scm_n1);
433
ASSERT_INTP(scm_n2);
434
435
n1 = SCM_INT_VALUE(scm_n1);
436
n2 = SCM_INT_VALUE(scm_n2);
437
438
if (n2 == 0)
439
ERR("division by zero");
440
441
return Scm_NewInt((int)(n1 / n2));
442
}
443
444
ScmObj ScmOp_modulo(ScmObj scm_n1, ScmObj scm_n2)
445
{
446
int n1 = 0;
447
int n2 = 0;
448
int rem = 0;
449
DECLARE_FUNCTION("modulo", ProcedureFixed2);
450
451
ASSERT_INTP(scm_n1);
452
ASSERT_INTP(scm_n2);
453
454
n1 = SCM_INT_VALUE(scm_n1);
455
n2 = SCM_INT_VALUE(scm_n2);
456
457
if (n2 == 0)
458
ERR("division by zero");
459
460
rem = n1 % n2;
461
if (n1 < 0 && n2 > 0) {
462
rem += n2;
463
} else if (n1 > 0 && n2 < 0) {
464
rem += n2;
465
}
466
467
return Scm_NewInt(rem);
468
}
469
470
ScmObj ScmOp_remainder(ScmObj scm_n1, ScmObj scm_n2)
471
{
472
int n1 = 0;
473
int n2 = 0;
474
DECLARE_FUNCTION("remainder", ProcedureFixed2);
475
476
ASSERT_INTP(scm_n1);
477
ASSERT_INTP(scm_n2);
478
479
n1 = SCM_INT_VALUE(scm_n1);
480
n2 = SCM_INT_VALUE(scm_n2);
481
482
if (n2 == 0)
483
ERR("division by zero");
484
485
return Scm_NewInt(n1 % n2);
486
}
487
488
/*==============================================================================
489
R5RS : 6.2 Numbers : 6.2.6 Numerical input and output
490
==============================================================================*/
491
ScmObj ScmOp_number2string(ScmObj num, ScmObj args)
492
{
493
char buf[sizeof(int)*CHAR_BIT + 1];
494
char *p;
495
unsigned int n, r;
496
ScmObj radix;
497
DECLARE_FUNCTION("number->string", ProcedureVariadic1);
498
499
ASSERT_INTP(num);
500
n = SCM_INT_VALUE(num);
501
502
/* r = radix */
503
if (NO_MORE_ARG(args))
504
r = 10;
505
else {
506
radix = POP_ARG(args);
507
ASSERT_NO_MORE_ARG(args);
508
509
ASSERT_INTP(radix);
510
r = SCM_INT_VALUE(radix);
511
#if SCM_STRICT_R5RS
512
if (!(r == 2 || r == 8 || r == 10 || r == 16))
513
#else
514
if (!(2 <= r && r <= 16))
515
#endif
516
ERR_OBJ("invalid or unsupported radix", radix);
517
}
518
519
/* no signs for nondecimals */
520
if (r != 10)
521
n = abs(n);
522
523
/* initialize buffer */
524
p = &buf[sizeof(buf)-1];
525
*p = 0;
526
527
do {
528
if (n % r > 9)
529
*--p = 'A' + n % r - 10;
530
else
531
*--p = '0' + n % r;
532
} while (n /= r);
533
if (r == 10 && SCM_INT_VALUE (num) < 0)
534
*--p = '-';
535
536
return Scm_NewStringCopying(p);
537
}
538
539
/* TODO : support radix */
540
ScmObj ScmOp_string2number(ScmObj string)
541
{
542
char *str = NULL;
543
char *p = NULL;
544
size_t len = 0;
545
DECLARE_FUNCTION("string->number", ProcedureFixed1);
546
547
ASSERT_STRINGP(string);
548
549
str = SCM_STRING_STR(string);
550
len = strlen(str);
551
for (p = str; p < str + len; p++) {
552
if (isdigit(*p) == 0)
553
return SCM_FALSE;
554
}
555
556
return Scm_NewInt((int)atoi(SCM_STRING_STR(string)));
557
}
558
559
/*===================================
560
R5RS : 6.3 Other data types
561
===================================*/
562
/*==============================================================================
563
R5RS : 6.3 Other data types : 6.3.1 Booleans
564
==============================================================================*/
565
ScmObj ScmOp_not(ScmObj obj)
566
{
567
DECLARE_FUNCTION("not", ProcedureFixed1);
568
return (FALSEP(obj)) ? SCM_TRUE : SCM_FALSE;
569
}
570
571
ScmObj ScmOp_booleanp(ScmObj obj)
572
{
573
DECLARE_FUNCTION("boolean?", ProcedureFixed1);
574
return (EQ(obj, SCM_FALSE) || EQ(obj, SCM_TRUE)) ? SCM_TRUE : SCM_FALSE;
575
}
576
577
/*==============================================================================
578
R5RS : 6.3 Other data types : 6.3.2 Pairs and lists
579
==============================================================================*/
580
ScmObj ScmOp_car(ScmObj obj)
581
{
582
DECLARE_FUNCTION("car", PocedureFixed1);
583
#if SCM_COMPAT_SIOD_BUGS
584
if (NULLP(obj))
585
return SCM_NULL;
586
#endif
587
588
ASSERT_CONSP(obj);
589
590
return CAR(obj);
591
}
592
593
ScmObj ScmOp_cdr(ScmObj obj)
594
{
595
DECLARE_FUNCTION("cdr", ProcedureFixed1);
596
#if SCM_COMPAT_SIOD_BUGS
597
if (NULLP(obj))
598
return SCM_NULL;
599
#endif
600
601
ASSERT_CONSP(obj);
602
603
return CDR(obj);
604
}
605
606
ScmObj ScmOp_pairp(ScmObj obj)
607
{
608
DECLARE_FUNCTION("pair?", ProcedureFixed1);
609
return (CONSP(obj)) ? SCM_TRUE : SCM_FALSE;
610
}
611
612
ScmObj ScmOp_cons(ScmObj car, ScmObj cdr)
613
{
614
DECLARE_FUNCTION("cons", ProcedureFixed1);
615
return CONS(car, cdr);
616
}
617
618
ScmObj ScmOp_setcar(ScmObj pair, ScmObj car)
619
{
620
DECLARE_FUNCTION("set-car!", SyntaxFixed2);
621
ASSERT_CONSP(pair);
622
623
SET_CAR(pair, car);
624
625
#if SCM_COMPAT_SIOD
626
return car;
627
#else
628
return SCM_UNDEF;
629
#endif
630
}
631
632
ScmObj ScmOp_setcdr(ScmObj pair, ScmObj cdr)
633
{
634
DECLARE_FUNCTION("set-cdr!", SyntaxFixed2);
635
ASSERT_CONSP(pair);
636
637
SET_CDR(pair, cdr);
638
639
#if SCM_COMPAT_SIOD
640
return cdr;
641
#else
642
return SCM_UNDEF;
643
#endif
644
}
645
646
ScmObj ScmOp_caar(ScmObj lst)
647
{
648
DECLARE_FUNCTION("caar", ProcedureFixed1);
649
return ScmOp_car( ScmOp_car(lst) );
650
}
651
ScmObj ScmOp_cadr(ScmObj lst)
652
{
653
DECLARE_FUNCTION("cadr", ProcedureFixed1);
654
return ScmOp_car( ScmOp_cdr(lst) );
655
}
656
ScmObj ScmOp_cdar(ScmObj lst)
657
{
658
DECLARE_FUNCTION("cdar", ProcedureFixed1);
659
return ScmOp_cdr( ScmOp_car(lst) );
660
}
661
ScmObj ScmOp_cddr(ScmObj lst)
662
{
663
DECLARE_FUNCTION("cddr", ProcedureFixed1);
664
return ScmOp_cdr( ScmOp_cdr(lst) );
665
}
666
ScmObj ScmOp_caddr(ScmObj lst)
667
{
668
DECLARE_FUNCTION("caddr", ProcedureFixed1);
669
return ScmOp_car( ScmOp_cdr( ScmOp_cdr(lst) ));
670
}
671
ScmObj ScmOp_cdddr(ScmObj lst)
672
{
673
DECLARE_FUNCTION("cdddr", ProcedureFixed1);
674
return ScmOp_cdr( ScmOp_cdr( ScmOp_cdr(lst) ));
675
}
676
677
#if SCM_USE_DEEP_CADRS
678
ScmObj ScmOp_caaar(ScmObj lst)
679
{
680
DECLARE_FUNCTION("caaar", ProcedureFixed1);
681
return ScmOp_car( ScmOp_car( ScmOp_car(lst) ));
682
}
683
ScmObj ScmOp_caadr(ScmObj lst)
684
{
685
DECLARE_FUNCTION("caadr", ProcedureFixed1);
686
return ScmOp_car( ScmOp_car( ScmOp_cdr(lst) ));
687
}
688
ScmObj ScmOp_cadar(ScmObj lst)
689
{
690
DECLARE_FUNCTION("cadar", ProcedureFixed1);
691
return ScmOp_car( ScmOp_cdr( ScmOp_car(lst) ));
692
}
693
ScmObj ScmOp_cdaar(ScmObj lst)
694
{
695
DECLARE_FUNCTION("cdaar", ProcedureFixed1);
696
return ScmOp_cdr( ScmOp_car( ScmOp_car(lst) ));
697
}
698
ScmObj ScmOp_cdadr(ScmObj lst)
699
{
700
DECLARE_FUNCTION("cdadr", ProcedureFixed1);
701
return ScmOp_cdr( ScmOp_car( ScmOp_cdr(lst) ));
702
}
703
ScmObj ScmOp_cddar(ScmObj lst)
704
{
705
DECLARE_FUNCTION("cddar", ProcedureFixed1);
706
return ScmOp_cdr( ScmOp_cdr( ScmOp_car(lst) ));
707
}
708
ScmObj ScmOp_caaaar(ScmObj lst)
709
{
710
DECLARE_FUNCTION("caaaar", ProcedureFixed1);
711
return ScmOp_car( ScmOp_car( ScmOp_car( ScmOp_car(lst) )));
712
}
713
ScmObj ScmOp_caaadr(ScmObj lst)
714
{
715
DECLARE_FUNCTION("caaadr", ProcedureFixed1);
716
return ScmOp_car( ScmOp_car( ScmOp_car( ScmOp_cdr(lst) )));
717
}
718
ScmObj ScmOp_caadar(ScmObj lst)
719
{
720
DECLARE_FUNCTION("caadar", ProcedureFixed1);
721
return ScmOp_car( ScmOp_car( ScmOp_cdr( ScmOp_car(lst) )));
722
}
723
ScmObj ScmOp_caaddr(ScmObj lst)
724
{
725
DECLARE_FUNCTION("caaddr", ProcedureFixed1);
726
return ScmOp_car( ScmOp_car( ScmOp_cdr( ScmOp_cdr(lst) )));
727
}
728
ScmObj ScmOp_cadaar(ScmObj lst)
729
{
730
DECLARE_FUNCTION("cadaar", ProcedureFixed1);
731
return ScmOp_car( ScmOp_cdr( ScmOp_car( ScmOp_car(lst) )));
732
}
733
ScmObj ScmOp_cadadr(ScmObj lst)
734
{
735
DECLARE_FUNCTION("cadadr", ProcedureFixed1);
736
return ScmOp_car( ScmOp_cdr( ScmOp_car( ScmOp_cdr(lst) )));
737
}
738
ScmObj ScmOp_caddar(ScmObj lst)
739
{
740
DECLARE_FUNCTION("caddar", ProcedureFixed1);
741
return ScmOp_car( ScmOp_cdr( ScmOp_cdr( ScmOp_car(lst) )));
742
}
743
ScmObj ScmOp_cadddr(ScmObj lst)
744
{
745
DECLARE_FUNCTION("cadddr", ProcedureFixed1);
746
return ScmOp_car( ScmOp_cdr( ScmOp_cdr( ScmOp_cdr(lst) )));
747
}
748
ScmObj ScmOp_cdaaar(ScmObj lst)
749
{
750
DECLARE_FUNCTION("cdaaar", ProcedureFixed1);
751
return ScmOp_cdr( ScmOp_car( ScmOp_car( ScmOp_car(lst) )));
752
}
753
ScmObj ScmOp_cdaadr(ScmObj lst)
754
{
755
DECLARE_FUNCTION("cdaadr", ProcedureFixed1);
756
return ScmOp_cdr( ScmOp_car( ScmOp_car( ScmOp_cdr(lst) )));
757
}
758
ScmObj ScmOp_cdadar(ScmObj lst)
759
{
760
DECLARE_FUNCTION("cdadar", ProcedureFixed1);
761
return ScmOp_cdr( ScmOp_car( ScmOp_cdr( ScmOp_car(lst) )));
762
}
763
ScmObj ScmOp_cdaddr(ScmObj lst)
764
{
765
DECLARE_FUNCTION("cdaddr", ProcedureFixed1);
766
return ScmOp_cdr( ScmOp_car( ScmOp_cdr( ScmOp_cdr(lst) )));
767
}
768
ScmObj ScmOp_cddaar(ScmObj lst)
769
{
770
DECLARE_FUNCTION("cddaar", ProcedureFixed1);
771
return ScmOp_cdr( ScmOp_cdr( ScmOp_car( ScmOp_car(lst) )));
772
}
773
ScmObj ScmOp_cddadr(ScmObj lst)
774
{
775
DECLARE_FUNCTION("cddadr", ProcedureFixed1);
776
return ScmOp_cdr( ScmOp_cdr( ScmOp_car( ScmOp_cdr(lst) )));
777
}
778
ScmObj ScmOp_cdddar(ScmObj lst)
779
{
780
DECLARE_FUNCTION("cdddar", ProcedureFixed1);
781
return ScmOp_cdr( ScmOp_cdr( ScmOp_cdr( ScmOp_car(lst) )));
782
}
783
ScmObj ScmOp_cddddr(ScmObj lst)
784
{
785
DECLARE_FUNCTION("cddddr", ProcedureFixed1);
786
return ScmOp_cdr( ScmOp_cdr( ScmOp_cdr( ScmOp_cdr(lst) )));
787
}
788
#endif /* SCM_USE_DEEP_CADRS */
789
790
ScmObj ScmOp_list(ScmObj args)
791
{
792
DECLARE_FUNCTION("list", ProcedureVariadic0);
793
return args;
794
}
795
796
ScmObj ScmOp_nullp(ScmObj obj)
797
{
798
DECLARE_FUNCTION("null?", ProcedureFixed1);
799
return (NULLP(obj)) ? SCM_TRUE : SCM_FALSE;
800
}
801
802
ScmObj ScmOp_listp(ScmObj obj)
803
{
804
int len = 0;
805
DECLARE_FUNCTION("list?", ProcedureFixed1);
806
807
if (NULLP(obj))
808
return SCM_TRUE;
809
if (!CONSP(obj))
810
return SCM_FALSE;
811
812
len = ScmOp_c_length(obj);
813
814
return (len != -1) ? SCM_TRUE : SCM_FALSE;
815
}
816
817
/*
818
* Notice
819
*
820
* This function is ported from Gauche, by Shiro Kawai(shiro@acm.org)
821
*/
822
/* FIXME:
823
* - Rename to Scm_c_length() since it isn't a Scheme procedure
824
* - Insert its copyright and license into this file properly
825
*/
826
int ScmOp_c_length(ScmObj lst)
827
{
828
ScmObj slow = lst;
829
int len = 0;
830
831
for (;;) {
832
if (NULLP(lst)) break;
833
if (!CONSP(lst)) return -1;
834
if (len != 0 && lst == slow) return -1; /* circular */
835
836
lst = CDR(lst);
837
len++;
838
if (NULLP(lst)) break;
839
if (!CONSP(lst)) return -1;
840
if (lst == slow) return -1; /* circular */
841
842
lst = CDR(lst);
843
slow = CDR(slow);
844
len++;
845
}
846
847
return len;
848
}
849
850
ScmObj ScmOp_length(ScmObj obj)
851
{
852
int len = ScmOp_c_length(obj);
853
DECLARE_FUNCTION("length", ProcedureFixed1);
854
855
if (len < 0)
856
ERR_OBJ("list required but got", obj);
857
858
return Scm_NewInt(len);
859
}
860
861
/*
862
* FIXME: Invalid direct cdr part referencing as lvalue. Don't assume such
863
* specific storage model. It breaks the abstract storage API. For example,
864
* base pointer + offset representation will not work under the lvalue
865
* assumption. Use SET_CDR properly. -- YamaKen 2005-09-23
866
*/
867
ScmObj ScmOp_append(ScmObj args)
868
{
869
ScmObj ret_lst = SCM_NULL;
870
ScmObj *ret_tail = &ret_lst;
871
ScmObj ls;
872
ScmObj obj = SCM_NULL;
873
DECLARE_FUNCTION("append", ProcedureVariadic0);
874
875
if (NULLP(args))
876
return SCM_NULL;
877
878
/* duplicate and merge all but the last argument */
879
for (; !NULLP(CDR(args)); args = CDR(args)) {
880
for (ls = CAR(args); CONSP(ls); ls = CDR(ls)) {
881
obj = CAR(ls);
882
*ret_tail = CONS(obj, SCM_NULL);
883
ret_tail = &CDR(*ret_tail);
884
}
885
if (!NULLP(ls))
886
ERR_OBJ("proper list required but got: ", CAR(args));
887
}
888
889
/* append the last argument */
890
*ret_tail = CAR(args);
891
892
return ret_lst;
893
}
894
895
ScmObj ScmOp_reverse(ScmObj lst)
896
{
897
ScmObj ret_lst = SCM_NULL;
898
DECLARE_FUNCTION("reverse", ProcedureFixed1);
899
900
for (; CONSP(lst); lst = CDR(lst))
901
ret_lst = CONS(CAR(lst), ret_lst);
902
903
if (!NULLP(lst))
904
ERR_OBJ("got improper list: ", lst);
905
906
return ret_lst;
907
}
908
909
static ScmObj ScmOp_listtail_internal(ScmObj lst, int k)
910
{
911
while (k--) {
912
if (!CONSP(lst))
913
return SCM_INVALID;
914
lst = CDR(lst);
915
}
916
917
return lst;
918
}
919
920
ScmObj ScmOp_list_tail(ScmObj lst, ScmObj scm_k)
921
{
922
ScmObj ret;
923
DECLARE_FUNCTION("list-tail", ProcedureFixed2);
924
925
ASSERT_INTP(scm_k);
926
927
ret = ScmOp_listtail_internal(lst, SCM_INT_VALUE(scm_k));
928
if (EQ(ret, SCM_INVALID))
929
ERR_OBJ("out of range or bad list, arglist is: ", CONS(lst, scm_k));
930
931
return ret;
932
}
933
934
ScmObj ScmOp_list_ref(ScmObj lst, ScmObj scm_k)
935
{
936
ScmObj tail = SCM_NULL;
937
DECLARE_FUNCTION("list-ref", ProcedureFixed2);
938
939
ASSERT_INTP(scm_k);
940
941
tail = ScmOp_listtail_internal(lst, SCM_INT_VALUE(scm_k));
942
if (EQ(tail, SCM_INVALID) || NULLP(tail))
943
ERR_OBJ("out of range or bad list, arglist is: ", CONS(lst, scm_k));
944
945
return CAR(tail);
946
}
947
948
#define MEM_OPERATION_BODY(obj, lst, cmpop) \
949
do { \
950
for (; CONSP(lst); lst = CDR(lst)) \
951
if (cmpop(obj, CAR(lst))) \
952
return lst; \
953
return SCM_FALSE; \
954
} while (/* CONSTCOND */ 0)
955
956
ScmObj ScmOp_memq(ScmObj obj, ScmObj lst)
957
{
958
DECLARE_FUNCTION("memq", ProcedureFixed2);
959
960
for (; CONSP(lst); lst = CDR(lst))
961
if (EQ(obj, CAR(lst)))
962
return lst;
963
964
return SCM_FALSE;
965
}
966
967
ScmObj ScmOp_memv(ScmObj obj, ScmObj lst)
968
{
969
DECLARE_FUNCTION("memv", ProcedureFixed2);
970
971
for (; CONSP(lst); lst = CDR(lst))
972
if (NFALSEP(ScmOp_eqvp(obj, CAR(lst))))
973
return lst;
974
975
return SCM_FALSE;
976
}
977
978
ScmObj ScmOp_member(ScmObj obj, ScmObj lst)
979
{
980
DECLARE_FUNCTION("member", ProcedureFixed2);
981
982
for (; CONSP(lst); lst = CDR(lst))
983
if (NFALSEP(ScmOp_equalp(obj, CAR(lst))))
984
return lst;
985
986
return SCM_FALSE;
987
}
988
989
ScmObj ScmOp_assq(ScmObj obj, ScmObj alist)
990
{
991
ScmObj tmp_lst = SCM_NULL;
992
ScmObj tmpobj = SCM_NULL;
993
ScmObj car;
994
DECLARE_FUNCTION("assq", ProcedureFixed2);
995
996
for (tmp_lst = alist; CONSP(tmp_lst); tmp_lst = CDR(tmp_lst)) {
997
tmpobj = CAR(tmp_lst);
998
car = CAR(tmpobj);
999
#if SCM_STRICT_R5RS
1000
ASSERT_CONSP(tmpobj);
1001
if (EQ(CAR(tmpobj), obj))
1002
return tmpobj;
1003
#else
1004
if (CONSP(tmpobj) && EQ(CAR(tmpobj), obj))
1005
return tmpobj;
1006
#endif
1007
}
1008
1009
return SCM_FALSE;
1010
}
1011
1012
ScmObj ScmOp_assv(ScmObj obj, ScmObj alist)
1013
{
1014
ScmObj tmp_lst = SCM_NULL;
1015
ScmObj tmpobj = SCM_NULL;
1016
ScmObj car;
1017
DECLARE_FUNCTION("assv", ProcedureFixed2);
1018
1019
for (tmp_lst = alist; CONSP(tmp_lst); tmp_lst = CDR(tmp_lst)) {
1020
tmpobj = CAR(tmp_lst);
1021
car = CAR(tmpobj);
1022
#if SCM_STRICT_R5RS
1023
ASSERT_CONSP(tmpobj);
1024
if (NFALSEP(ScmOp_eqvp(car, obj)))
1025
return tmpobj;
1026
#else
1027
if (CONSP(tmpobj) && NFALSEP(ScmOp_eqvp(car, obj)))
1028
return tmpobj;
1029
#endif
1030
}
1031
1032
return SCM_FALSE;
1033
}
1034
1035
ScmObj ScmOp_assoc(ScmObj obj, ScmObj alist)
1036
{
1037
ScmObj tmp_lst = SCM_NULL;
1038
ScmObj tmpobj = SCM_NULL;
1039
ScmObj car;
1040
DECLARE_FUNCTION("assoc", ProcedureFixed2);
1041
1042
for (tmp_lst = alist; CONSP(tmp_lst); tmp_lst = CDR(tmp_lst)) {
1043
tmpobj = CAR(tmp_lst);
1044
car = CAR(tmpobj);
1045
#if SCM_STRICT_R5RS
1046
ASSERT_CONSP(tmpobj);
1047
if (NFALSEP(ScmOp_equalp(car, obj)))
1048
return tmpobj;
1049
#else
1050
if (CONSP(tmpobj) && NFALSEP(ScmOp_equalp(car, obj)))
1051
return tmpobj;
1052
#endif
1053
}
1054
1055
return SCM_FALSE;
1056
}
1057
1058
1059
/*==============================================================================
1060
R5RS : 6.3 Other data types : 6.3.3 Symbols
1061
==============================================================================*/
1062
ScmObj ScmOp_symbolp(ScmObj obj)
1063
{
1064
DECLARE_FUNCTION("symbol?", ProcedureFixed1);
1065
return (SYMBOLP(obj)) ? SCM_TRUE : SCM_FALSE;
1066
}
1067
1068
ScmObj ScmOp_symbol2string(ScmObj obj)
1069
{
1070
DECLARE_FUNCTION("symbol->string", ProcedureFixed1);
1071
ASSERT_SYMBOLP(obj);
1072
return Scm_NewStringCopying(SCM_SYMBOL_NAME(obj));
1073
}
1074
1075
ScmObj ScmOp_string2symbol(ScmObj str)
1076
{
1077
DECLARE_FUNCTION("string->symbol", ProcedureFixed1);
1078
ASSERT_STRINGP(str);
1079
return Scm_Intern(SCM_STRING_STR(str));
1080
}
1081
1082
/*==============================================================================
1083
R5RS : 6.3 Other data types : 6.3.4 Characters
1084
==============================================================================*/
1085
ScmObj ScmOp_charp(ScmObj obj)
1086
{
1087
DECLARE_FUNCTION("char?", ProcedureFixed1);
1088
return (CHARP(obj)) ? SCM_TRUE : SCM_FALSE;
1089
}
1090
1091
ScmObj ScmOp_char_equal(ScmObj ch1, ScmObj ch2)
1092
{
1093
DECLARE_FUNCTION("char=?", ProcedureFixed2);
1094
ASSERT_CHARP(ch1);
1095
ASSERT_CHARP(ch2);
1096
1097
if (strcmp(SCM_CHAR_VALUE(ch1), SCM_CHAR_VALUE(ch2)) == 0)
1098
return SCM_TRUE;
1099
1100
return SCM_FALSE;
1101
}
1102
1103
ScmObj ScmOp_char_alphabeticp(ScmObj obj)
1104
{
1105
DECLARE_FUNCTION("char-alphabetic?", ProcedureFixed1);
1106
ASSERT_CHARP(obj);
1107
1108
/* check multibyte */
1109
if (strlen(SCM_CHAR_VALUE(obj)) != 1)
1110
return SCM_FALSE;
1111
1112
/* check alphabet */
1113
if (isalpha(SCM_CHAR_VALUE(obj)[0]) != 0)
1114
return SCM_TRUE;
1115
1116
return SCM_FALSE;
1117
}
1118
1119
ScmObj ScmOp_char_numericp(ScmObj obj)
1120
{
1121
DECLARE_FUNCTION("char-numeric?", ProcedureFixed1);
1122
ASSERT_CHARP(obj);
1123
1124
/* check multibyte */
1125
if (strlen(SCM_CHAR_VALUE(obj)) != 1)
1126
return SCM_FALSE;
1127
1128
/* check digit */
1129
if (isdigit(SCM_CHAR_VALUE(obj)[0]) != 0)
1130
return SCM_TRUE;
1131
1132
return SCM_FALSE;
1133
}
1134
1135
ScmObj ScmOp_char_whitespacep(ScmObj obj)
1136
{
1137
DECLARE_FUNCTION("char-whitespace?", ProcedureFixed1);
1138
ASSERT_CHARP(obj);
1139
1140
/* check multibyte */
1141
if (strlen(SCM_CHAR_VALUE(obj)) != 1)
1142
return SCM_FALSE;
1143
1144
/* check space */
1145
if (isspace(SCM_CHAR_VALUE(obj)[0]) != 0)
1146
return SCM_TRUE;
1147
1148
return SCM_FALSE;
1149
}
1150
1151
ScmObj ScmOp_char_upper_casep(ScmObj obj)
1152
{
1153
DECLARE_FUNCTION("char-upper-case?", ProcedureFixed1);
1154
ASSERT_CHARP(obj);
1155
1156
/* check multibyte */
1157
if (strlen(SCM_CHAR_VALUE(obj)) != 1)
1158
return SCM_FALSE;
1159
1160
/* check uppercase */
1161
if (isupper(SCM_CHAR_VALUE(obj)[0]) != 0)
1162
return SCM_TRUE;
1163
1164
return SCM_FALSE;
1165
}
1166
1167
ScmObj ScmOp_char_lower_casep(ScmObj obj)
1168
{
1169
DECLARE_FUNCTION("char-lower-case?", ProcedureFixed1);
1170
ASSERT_CHARP(obj);
1171
1172
/* check multibyte */
1173
if (strlen(SCM_CHAR_VALUE(obj)) != 1)
1174
return SCM_FALSE;
1175
1176
/* check lowercase */
1177
if (islower(SCM_CHAR_VALUE(obj)[0]) != 0)
1178
return SCM_TRUE;
1179
1180
return SCM_FALSE;
1181
}
1182
1183
ScmObj ScmOp_char_upcase(ScmObj obj)
1184
{
1185
DECLARE_FUNCTION("char-upcase", ProcedureFixed1);
1186
ASSERT_CHARP(obj);
1187
1188
/* check multibyte */
1189
if (strlen(SCM_CHAR_VALUE(obj)) != 1)
1190
return obj;
1191
1192
/* to upcase */
1193
SCM_CHAR_VALUE(obj)[0] = toupper(SCM_CHAR_VALUE(obj)[0]);
1194
1195
return obj;
1196
}
1197
1198
ScmObj ScmOp_char_downcase(ScmObj obj)
1199
{
1200
DECLARE_FUNCTION("char-downcase", ProcedureFixed1);
1201
ASSERT_CHARP(obj);
1202
1203
/* check multibyte */
1204
if (strlen(SCM_CHAR_VALUE(obj)) != 1)
1205
return obj;
1206
1207
/* to upcase */
1208
SCM_CHAR_VALUE(obj)[0] = tolower(SCM_CHAR_VALUE(obj)[0]);
1209
1210
return obj;
1211
}
1212
1213
/*==============================================================================
1214
R5RS : 6.3 Other data types : 6.3.5 Strings
1215
==============================================================================*/
1216
ScmObj ScmOp_stringp(ScmObj obj)
1217
{
1218
DECLARE_FUNCTION("string?", ProcedureFixed1);
1219
return (STRINGP(obj)) ? SCM_TRUE : SCM_FALSE;
1220
}
1221
1222
ScmObj ScmOp_make_string(ScmObj length, ScmObj args)
1223
{
1224
int len = 0;
1225
ScmObj str = SCM_FALSE;
1226
ScmObj filler = SCM_FALSE;
1227
DECLARE_FUNCTION("make-string", ProcedureVariadic1);
1228
1229
ASSERT_INTP(length);
1230
len = SCM_INT_VALUE(length);
1231
if (len == 0)
1232
return Scm_NewStringCopying("");
1233
1234
/* specify filler */
1235
if (NO_MORE_ARG(args)) {
1236
filler = Scm_NewChar(strdup(" "));
1237
} else {
1238
filler = POP_ARG(args);
1239
ASSERT_CHARP(filler);
1240
}
1241
1242
/* make string */
1243
str = Scm_NewStringWithLen(NULL, len);
1244
1245
/* and fill! */
1246
ScmOp_string_fill(str, filler);
1247
1248
return str;
1249
}
1250
1251
ScmObj ScmOp_string(ScmObj args)
1252
{
1253
DECLARE_FUNCTION("string", ProcedureVariadic0);
1254
return ScmOp_list2string(args);
1255
}
1256
1257
ScmObj ScmOp_string_length(ScmObj str)
1258
{
1259
DECLARE_FUNCTION("string-length", ProcedureFixed1);
1260
ASSERT_STRINGP(str);
1261
return Scm_NewInt(Scm_mb_bare_c_strlen(SCM_STRING_STR(str)));
1262
}
1263
1264
ScmObj ScmOp_string_ref(ScmObj str, ScmObj k)
1265
{
1266
int c_index = 0;
1267
char *new_ch = NULL;
1268
ScmMultibyteString mbs;
1269
DECLARE_FUNCTION("string-ref", ProcedureFixed2);
1270
1271
ASSERT_STRINGP(str);
1272
ASSERT_INTP(k);
1273
1274
SCM_MBS_INIT(mbs);
1275
/* get start_ptr and end_ptr */
1276
c_index = SCM_INT_VALUE(k);
1277
SCM_MBS_SET_STR(mbs, SCM_STRING_STR(str));
1278
1279
/* FIXME: This strlen() can be eliminated. */
1280
SCM_MBS_SET_SIZE(mbs, strlen(SCM_STRING_STR(str)));
1281
mbs = Scm_mb_strref(mbs, c_index);
1282
1283
/* copy from start_ptr to end_ptr */
1284
new_ch = (char*)malloc(SCM_MBS_GET_SIZE(mbs) + 1);
1285
memcpy(new_ch, SCM_MBS_GET_STR(mbs), SCM_MBS_GET_SIZE(mbs));
1286
new_ch[SCM_MBS_GET_SIZE(mbs)] = 0;
1287
1288
return Scm_NewChar(new_ch);
1289
}
1290
1291
ScmObj ScmOp_string_set(ScmObj str, ScmObj k, ScmObj ch)
1292
{
1293
int c_start_index = 0;
1294
int prefix_size = 0;
1295
int newch_size = 0;
1296
int postfix_size = 0;
1297
int total_size = 0;
1298
char *new_str = NULL;
1299
ScmMultibyteString mbs;
1300
const char *string_str = NULL;
1301
DECLARE_FUNCTION("string-set!", ProcedureFixed3);
1302
1303
ASSERT_STRINGP(str);
1304
ASSERT_INTP(k);
1305
ASSERT_CHARP(ch);
1306
1307
/* get indexes */
1308
c_start_index = SCM_INT_VALUE(k);
1309
string_str = SCM_STRING_STR(str);
1310
/* FIXME: can string_str be NULL at this point or not? */
1311
if (!string_str) string_str = "";
1312
1313
/* FIXME: strlen() can be eliminiated. */
1314
SCM_MBS_INIT(mbs);
1315
SCM_MBS_SET_STR(mbs, string_str);
1316
SCM_MBS_SET_SIZE(mbs, strlen(string_str));
1317
mbs = Scm_mb_strref(mbs, c_start_index);
1318
1319
/* calculate total size */
1320
prefix_size = SCM_MBS_GET_STR(mbs) - string_str;
1321
newch_size = strlen(SCM_CHAR_VALUE(ch));
1322
postfix_size = strlen(SCM_MBS_GET_STR(mbs) + SCM_MBS_GET_SIZE(mbs));
1323
total_size = prefix_size + newch_size + postfix_size;
1324
1325
/* copy each part */
1326
new_str = (char*)malloc(total_size + 1);
1327
memcpy(new_str, string_str, prefix_size);
1328
memcpy(new_str+prefix_size, SCM_CHAR_VALUE(ch), newch_size);
1329
memcpy(new_str+prefix_size+newch_size,
1330
SCM_MBS_GET_STR(mbs)+SCM_MBS_GET_SIZE(mbs), postfix_size);
1331
1332
if (SCM_STRING_STR(str))
1333
free(SCM_STRING_STR(str));
1334
1335
SCM_STRING_SET_STR(str, new_str);
1336
1337
return str;
1338
}
1339
1340
ScmObj ScmOp_string_equal(ScmObj str1, ScmObj str2)
1341
{
1342
DECLARE_FUNCTION("string=", ProcedureFixed2);
1343
1344
ASSERT_STRINGP(str1);
1345
ASSERT_STRINGP(str2);
1346
1347
if (strcmp(SCM_STRING_STR(str1), SCM_STRING_STR(str2)) == 0)
1348
return SCM_TRUE;
1349
1350
return SCM_FALSE;
1351
}
1352
1353
ScmObj ScmOp_string_substring(ScmObj str, ScmObj start, ScmObj end)
1354
{
1355
int c_start_index = 0;
1356
int c_end_index = 0;
1357
char *new_str = NULL;
1358
ScmMultibyteString mbs;
1359
const char *string_str = NULL;
1360
DECLARE_FUNCTION("substring", ProcedureFixed3);
1361
1362
ASSERT_STRINGP(str);
1363
ASSERT_INTP(start);
1364
ASSERT_INTP(end);
1365
1366
/* get start_ptr and end_ptr */
1367
c_start_index = SCM_INT_VALUE(start);
1368
c_end_index = SCM_INT_VALUE(end);
1369
1370
/* sanity check */
1371
if (c_start_index > c_end_index)
1372
ERR("substring: start index is greater than end index.");
1373
if (c_end_index > SCM_STRING_LEN(str))
1374
ERR_OBJ("index out of range", end);
1375
1376
/* FIXME: strlen() can be eliminated. */
1377
string_str = SCM_STRING_STR(str);
1378
SCM_MBS_INIT(mbs);
1379
SCM_MBS_SET_STR(mbs, string_str);
1380
SCM_MBS_SET_SIZE(mbs, strlen(string_str));
1381
mbs = Scm_mb_substring(mbs, c_start_index, c_end_index - c_start_index);
1382
1383
/* copy from start_ptr to end_ptr */
1384
new_str = (char*)malloc(SCM_MBS_GET_SIZE(mbs) + 1);
1385
memcpy(new_str, SCM_MBS_GET_STR(mbs), SCM_MBS_GET_SIZE(mbs));
1386
new_str[SCM_MBS_GET_SIZE(mbs)] = 0;
1387
1388
return Scm_NewString(new_str);
1389
}
1390
1391
ScmObj ScmOp_string_append(ScmObj args)
1392
{
1393
/* FIXME: transition to new arg extraction mechanism incomplete. */
1394
int total_size = 0;
1395
int total_len = 0;
1396
ScmObj strings = SCM_NULL;
1397
ScmObj obj = SCM_NULL;
1398
char *new_str = NULL;
1399
char *p = NULL;
1400
DECLARE_FUNCTION("string-append", ProcedureFixed1);
1401
1402
if (NO_MORE_ARG(args))
1403
return Scm_NewStringCopying("");
1404
1405
/* count total size of the new string */
1406
for (strings = args; !NULLP(strings); strings = CDR(strings)) {
1407
obj = CAR(strings);
1408
ASSERT_STRINGP(obj);
1409
1410
total_size += strlen(SCM_STRING_STR(obj));
1411
total_len += SCM_STRING_LEN(obj);
1412
}
1413
1414
/* allocate new string */
1415
new_str = (char*)malloc(sizeof(char) * total_size + 1);
1416
1417
/* copy string by string */
1418
p = new_str;
1419
for (strings = args; !NULLP(strings); strings = CDR(strings)) {
1420
obj = CAR(strings);
1421
1422
strcpy(p, SCM_STRING_STR(obj));
1423
p += strlen(SCM_STRING_STR(obj));
1424
}
1425
1426
return Scm_NewStringWithLen(new_str, total_len);
1427
}
1428
1429
ScmObj ScmOp_string2list(ScmObj string)
1430
{
1431
ScmObj head = SCM_NULL;
1432
ScmObj tail = SCM_NULL;
1433
ScmObj next = SCM_NULL;
1434
ScmMultibyteString mbs;
1435
ScmMultibyteCharInfo ch;
1436
char *buf;
1437
DECLARE_FUNCTION("string->list", string);
1438
1439
ASSERT_STRINGP(string);
1440
1441
SCM_MBS_INIT(mbs);
1442
SCM_MBS_SET_STR(mbs, SCM_STRING_STR(string));
1443
SCM_MBS_SET_SIZE(mbs, strlen(SCM_STRING_STR(string)));
1444
1445
while (SCM_MBS_GET_SIZE(mbs)) {
1446
ch = Scm_mb_scan_char(mbs);
1447
buf = malloc(SCM_MBCINFO_GET_SIZE(ch)+1);
1448
memcpy(buf, SCM_MBS_GET_STR(mbs), SCM_MBCINFO_GET_SIZE(ch));
1449
buf[SCM_MBCINFO_GET_SIZE(ch)] = 0;
1450
next = LIST_1(Scm_NewChar(buf));
1451
1452
if (NULLP(tail))
1453
head = tail = next;
1454
else {
1455
SET_CDR(tail, next);
1456
tail = CDR(tail);
1457
}
1458
1459
SCM_MBS_SKIP_CHAR(mbs, ch);
1460
}
1461
1462
return head;
1463
}
1464
1465
ScmObj ScmOp_list2string(ScmObj lst)
1466
{
1467
int len = 0;
1468
int total_size = 0;
1469
ScmObj chars = SCM_NULL;
1470
ScmObj obj = SCM_NULL;
1471
char *new_str = NULL;
1472
char *ch = NULL;
1473
char *p = NULL;
1474
DECLARE_FUNCTION("list->string", ProcedureFixed1);
1475
1476
if (FALSEP(ScmOp_listp(lst)))
1477
ERR_OBJ("list required but got ", lst);
1478
1479
if (NULLP(lst))
1480
return Scm_NewStringCopying("");
1481
1482
/* count total size of the string */
1483
for (chars = lst; !NULLP(chars); chars = CDR(chars)) {
1484
obj = CAR(chars);
1485
ASSERT_CHARP(obj);
1486
1487
total_size += strlen(SCM_CHAR_VALUE(obj));
1488
}
1489
1490
/* allocate new string */
1491
new_str = (char*)malloc(sizeof(char) * total_size + 1);
1492
1493
/* copy char by char */
1494
p = new_str;
1495
for (chars = lst; !NULLP(chars); chars = CDR(chars)) {
1496
obj = CAR(chars);
1497
ch = SCM_CHAR_VALUE(obj);
1498
len = strlen(SCM_CHAR_VALUE(obj));
1499
1500
strcpy(p, ch);
1501
p += len;
1502
}
1503
1504
return Scm_NewString(new_str);
1505
}
1506
1507
ScmObj ScmOp_string_copy(ScmObj string)
1508
{
1509
DECLARE_FUNCTION("string-copy", ProcedureFixed1);
1510
ASSERT_STRINGP(string);
1511
return Scm_NewStringCopying(SCM_STRING_STR(string));
1512
}
1513
1514
ScmObj ScmOp_string_fill(ScmObj string, ScmObj ch)
1515
{
1516
int char_size = 0;
1517
int str_len = 0;
1518
char *new_str = NULL;
1519
char *p = NULL;
1520
int i = 0;
1521
DECLARE_FUNCTION("string-fill!", ProcedureFixed2);
1522
1523
ASSERT_STRINGP(string);
1524
ASSERT_CHARP(ch);
1525
1526
/* create new str */
1527
char_size = strlen(SCM_CHAR_VALUE(ch));
1528
str_len = SCM_STRING_LEN(string);
1529
new_str = (char*)realloc(SCM_STRING_STR(string),
1530
sizeof(char) * str_len * char_size + 1);
1531
for (i = 0, p = new_str; i < char_size * str_len;) {
1532
strcpy(p, SCM_CHAR_VALUE(ch));
1533
1534
p += char_size;
1535
i += char_size;
1536
}
1537
1538
SCM_STRING_SET_STR(string, new_str);
1539
1540
return string;
1541
}
1542
1543
/*==============================================================================
1544
R5RS : 6.3 Other data types : 6.3.6 Vectors
1545
==============================================================================*/
1546
ScmObj ScmOp_vectorp(ScmObj obj)
1547
{
1548
DECLARE_FUNCTION("vector?", ProcedureFixed1);
1549
return (VECTORP(obj)) ? SCM_TRUE : SCM_FALSE;
1550
}
1551
1552
ScmObj ScmOp_make_vector(ScmObj vector_len, ScmObj args)
1553
{
1554
ScmObj *vec = NULL;
1555
ScmObj filler = SCM_FALSE;
1556
int len = 0;
1557
int i = 0;
1558
DECLARE_FUNCTION("make-vector", ProcedureVariadic1);
1559
1560
ASSERT_INTP(vector_len);
1561
1562
/* allocate vector */
1563
len = SCM_INT_VALUE(vector_len);
1564
vec = (ScmObj*)malloc(sizeof(ScmObj) * len);
1565
1566
/* fill vector */
1567
filler = SCM_UNDEF;
1568
if (!NULLP(args))
1569
filler = CAR(args);
1570
1571
for (i = 0; i < len; i++)
1572
vec[i] = filler;
1573
1574
return Scm_NewVector(vec, len);
1575
}
1576
1577
ScmObj ScmOp_vector(ScmObj args)
1578
{
1579
int len = SCM_INT_VALUE(ScmOp_length(args));
1580
int i = 0;
1581
ScmObj *vec = (ScmObj*)malloc(sizeof(ScmObj) * len); /* allocate vector */
1582
DECLARE_FUNCTION("vector", ProcedureVariadic0);
1583
1584
/* set item */
1585
for (i = 0; i < len; i++)
1586
SCM_SHIFT_RAW_1(vec[i], args);
1587
1588
return Scm_NewVector(vec, len);
1589
}
1590
1591
ScmObj ScmOp_vector_length(ScmObj vec)
1592
{
1593
DECLARE_FUNCTION("vector-length", ProcedureFixed1);
1594
1595
ASSERT_VECTORP(vec);
1596
return Scm_NewInt(SCM_VECTOR_LEN(vec));
1597
}
1598
1599
ScmObj ScmOp_vector_ref(ScmObj vec, ScmObj scm_k)
1600
{
1601
DECLARE_FUNCTION("vector-ref", ProcedureFixed2);
1602
1603
ASSERT_VECTORP(vec);
1604
ASSERT_INTP(scm_k);
1605
1606
return SCM_VECTOR_REF(vec, scm_k);
1607
}
1608
1609
ScmObj ScmOp_vector_set(ScmObj vec, ScmObj scm_k, ScmObj obj)
1610
{
1611
DECLARE_FUNCTION("vector-set!", ProcedureFixed3);
1612
ASSERT_VECTORP(vec);
1613
ASSERT_INTP(scm_k);
1614
1615
SCM_VECTOR_SET_REF(vec, scm_k, obj);
1616
1617
return SCM_UNDEF;
1618
}
1619
1620
ScmObj ScmOp_vector2list(ScmObj vec)
1621
{
1622
ScmObj *v = NULL;
1623
ScmObj prev = NULL;
1624
ScmObj next = NULL;
1625
ScmObj head = NULL;
1626
int c_len = 0;
1627
int i = 0;
1628
DECLARE_FUNCTION("vector->list", ProcedureFixed1);
1629
1630
ASSERT_VECTORP(vec);
1631
1632
v = SCM_VECTOR_VEC(vec);
1633
c_len = SCM_VECTOR_LEN(vec);
1634
if (c_len == 0)
1635
return SCM_NULL;
1636
1637
for (i = 0; i < c_len; i++) {
1638
next = CONS(v[i], SCM_NULL);
1639
1640
if (prev) {
1641
SET_CDR(prev, next);
1642
} else {
1643
head = next;
1644
}
1645
1646
prev = next;
1647
}
1648
1649
return head;
1650
}
1651
1652
ScmObj ScmOp_list2vector(ScmObj lst)
1653
{
1654
ScmObj scm_len = SCM_NULL;
1655
ScmObj *v = NULL;
1656
int c_len = 0;
1657
int i = 0;
1658
DECLARE_FUNCTION("list->vector", ProcedureFixed1);
1659
1660
/* TOOD : canbe optimized. scanning list many times */
1661
if (FALSEP(ScmOp_listp(lst)))
1662
ERR_OBJ("list required but got ", lst);
1663
1664
scm_len = ScmOp_length(lst);
1665
c_len = SCM_INT_VALUE(scm_len);
1666
v = (ScmObj*)malloc(sizeof(ScmObj) * c_len);
1667
for (i = 0; i < c_len; i++) {
1668
v[i] = CAR(lst);
1669
lst = CDR(lst);
1670
}
1671
1672
return Scm_NewVector(v, c_len);
1673
}
1674
1675
ScmObj ScmOp_vector_fill(ScmObj vec, ScmObj fill)
1676
{
1677
int c_len = 0;
1678
int i = 0;
1679
DECLARE_FUNCTION("vector-fill!", ProcedureFixed2);
1680
1681
ASSERT_VECTORP(vec);
1682
1683
c_len = SCM_VECTOR_LEN(vec);
1684
for (i = 0; i < c_len; i++) {
1685
SCM_VECTOR_VEC(vec)[i] = fill;
1686
}
1687
1688
return vec;
1689
}
1690
1691
/*=======================================
1692
R5RS : 6.4 Control Features
1693
=======================================*/
1694
ScmObj ScmOp_procedurep(ScmObj obj)
1695
{
1696
DECLARE_FUNCTION("procedure?", ProcedureFixed1);
1697
return (PROCEDUREP(obj)) ? SCM_TRUE : SCM_FALSE;
1698
}
1699
1700
ScmObj ScmOp_map(ScmObj proc, ScmObj args)
1701
{
1702
DECLARE_FUNCTION("map", ProcedureVariadic1);
1703
/* sanity check */
1704
if (NULLP(args))
1705
SigScm_Error("map : wrong number of arguments");
1706
1707
/* fast path for single arg case */
1708
if (NULLP(CDR(args)))
1709
return map_single_arg(proc, CAR(args));
1710
1711
/* multiple args case */
1712
return map_multiple_args(proc, args);
1713
}
1714
1715
static ScmObj map_single_arg(ScmObj proc, ScmObj lst)
1716
{
1717
ScmObj ret = SCM_FALSE;
1718
ScmObj ret_last = SCM_FALSE;
1719
ScmObj mapped_elm = SCM_FALSE;
1720
1721
if (NULLP(lst))
1722
return SCM_NULL;
1723
1724
for (; !NULLP(lst); lst = CDR(lst)) {
1725
if (NFALSEP(ret)) {
1726
/* subsequent */
1727
mapped_elm = CONS(Scm_call(proc, LIST_1(CAR(lst))), SCM_NULL);
1728
SET_CDR(ret_last, mapped_elm);
1729
ret_last = mapped_elm;
1730
} else {
1731
/* first */
1732
ret = CONS(Scm_call(proc, LIST_1(CAR(lst))), SCM_NULL);
1733
ret_last = ret;
1734
}
1735
}
1736
1737
return ret;
1738
}
1739
1740
/*
1741
* FIXME:
1742
* - Simplify and make names appropriate as like as map_singular_arg()
1743
*/
1744
static ScmObj map_multiple_args(ScmObj proc, ScmObj args)
1745
{
1746
ScmObj map_arg = SCM_FALSE;
1747
ScmObj map_arg_last = SCM_FALSE;
1748
ScmObj tmp_lsts = SCM_FALSE;
1749
ScmObj lst = SCM_FALSE;
1750
ScmObj ret = SCM_FALSE;
1751
ScmObj ret_last = SCM_FALSE;
1752
1753
while (1) {
1754
/* construct "map_arg" */
1755
map_arg = SCM_FALSE;
1756
tmp_lsts = args;
1757
for (; !NULLP(tmp_lsts); tmp_lsts = CDR(tmp_lsts)) {
1758
lst = CAR(tmp_lsts);
1759
if (NULLP(lst))
1760
return ret;
1761
1762
if (NFALSEP(map_arg)) {
1763
/* subsequent */
1764
SET_CDR(map_arg_last, CONS(CAR(lst), SCM_NULL));
1765
map_arg_last = CDR(map_arg_last);
1766
} else {
1767
/* first */
1768
map_arg = CONS(CAR(lst), SCM_NULL);
1769
map_arg_last = map_arg;
1770
}
1771
1772
/* update tmp_lsts */
1773
SET_CAR(tmp_lsts, CDR(lst));
1774
}
1775
1776
/* construct "ret" by applying proc to each map_arg */
1777
if (NFALSEP(ret)) {
1778
/* subsequent */
1779
SET_CDR(ret_last, CONS(Scm_call(proc, map_arg), SCM_NULL));
1780
ret_last = CDR(ret_last);
1781
} else {
1782
/* first */
1783
ret = CONS(Scm_call(proc, map_arg), SCM_NULL);
1784
ret_last = ret;
1785
}
1786
}
1787
1788
SigScm_Error("map : invalid argument ", args);
1789
return SCM_NULL;
1790
}
1791
1792
ScmObj ScmOp_for_each(ScmObj proc, ScmObj args)
1793
{
1794
DECLARE_FUNCTION("for-each", ProcedureVariadic1);
1795
ScmOp_map(proc, args);
1796
1797
return SCM_UNDEF;
1798
}
1799
1800
ScmObj ScmOp_force(ScmObj closure)
1801
{
1802
DECLARE_FUNCTION("force", ProcedureFixed1);
1803
1804
ASSERT_CLOSUREP(closure);
1805
1806
return Scm_call(closure, SCM_NULL);
1807
}
1808
1809
ScmObj ScmOp_call_with_current_continuation(ScmObj proc, ScmEvalState *eval_state)
1810
{
1811
DECLARE_FUNCTION("call-with-current-continuation", ProcedureFixedTailRec1);
1812
1813
ASSERT_PROCEDUREP(proc);
1814
1815
return Scm_CallWithCurrentContinuation(proc, eval_state);
1816
}
1817
1818
ScmObj ScmOp_values(ScmObj args)
1819
{
1820
DECLARE_FUNCTION("values", ProcedureVariadic0);
1821
/* Values with one arg must return something that fits an ordinary
1822
* continuation. */
1823
if (CONSP(args) && NULLP(CDR(args)))
1824
return CAR(args);
1825
1826
/* Otherwise, we'll return the values in a packet. */
1827
return SCM_MAKE_VALUEPACKET(args);
1828
}
1829
1830
ScmObj ScmOp_call_with_values(ScmObj producer, ScmObj consumer,
1831
ScmEvalState *eval_state)
1832
{
1833
ScmObj vals;
1834
DECLARE_FUNCTION("call-with-values", ProcedureFixedTailRec2);
1835
1836
ASSERT_PROCEDUREP(producer);
1837
ASSERT_PROCEDUREP(consumer);
1838
1839
vals = Scm_call(producer, SCM_NULL);
1840
1841
if (!VALUEPACKETP(vals)) {
1842
/* got back a single value */
1843
vals = CONS(vals, SCM_NULL);
1844
} else {
1845
/* extract */
1846
vals = SCM_VALUEPACKET_VALUES(vals);
1847
}
1848
1849
return Scm_tailcall(consumer, vals, eval_state);
1850
}
1851
1852
ScmObj ScmOp_dynamic_wind(ScmObj before, ScmObj thunk, ScmObj after)
1853
{
1854
DECLARE_FUNCTION("dynamic-wind", ProcedureFixed3);
1855
1856
ASSERT_PROCEDUREP(before);
1857
ASSERT_PROCEDUREP(thunk);
1858
ASSERT_PROCEDUREP(after);
1859
1860
return Scm_DynamicWind(before, thunk, after);
1861
}
1862
1863
/*============================================================================
1864
SigScheme-Specific Non-R5RS Standard Procedures
1865
============================================================================*/
1866
#if SCM_USE_NONSTD_FEATURES
1867
/*
1868
* TODO:
1869
* - describe compatibility with de facto standard of other Scheme
1870
* implementations (accept env as optional arg, etc)
1871
*/
1872
/* The implementation is fully compatible with SIOD */
1873
ScmObj ScmOp_symbol_boundp(ScmObj sym, ScmObj rest)
1874
{
1875
ScmObj env = SCM_INVALID;
1876
DECLARE_FUNCTION("symbol-bound?", ProcedureVariadic1);
1877
1878
ASSERT_SYMBOLP(sym);
1879
1880
env = POP_ARG(rest);
1881
if (VALIDP(env))
1882
ASSERT_ENVP(env);
1883
else
1884
env = SCM_INTERACTION_ENV;
1885
1886
return (!NULLP(Scm_LookupEnvironment(sym, env))
1887
|| SCM_SYMBOL_BOUNDP(sym)) ? SCM_TRUE : SCM_FALSE;
1888
}
1889
#endif /* SCM_USE_NONSTD_FEATURES */
1890
1891
#if SCM_USE_SRFI1
1892
#include "operations-srfi1.c"
1893
#endif
1894
#if SCM_USE_SRFI2
1895
#include "operations-srfi2.c"
1896
#endif
1897
#if SCM_USE_SRFI6
1898
#include "operations-srfi6.c"
1899
#endif
1900
#if SCM_USE_SRFI8
1901
#include "operations-srfi8.c"
1902
#endif
1903
#if SCM_USE_SRFI23
1904
#include "operations-srfi23.c"
1905
#endif
1906
#if SCM_USE_SRFI34
1907
#include "operations-srfi34.c"
1908
#endif
1909
#if SCM_USE_SRFI38
1910
#include "operations-srfi38.c"
1911
#endif
1912
#if SCM_USE_SRFI60
1913
#include "operations-srfi60.c"
1914
#endif
1915
#if SCM_COMPAT_SIOD
1916
#include "operations-siod.c"
1917
#endif
Loggerhead is a web-based interface for Breezy
Version: 2.0.1