Skip to content

Commit 36194dd

Browse files
bksaikibksaiki
committed
kernel: arithmetic
1 parent d8e0345 commit 36194dd

File tree

3 files changed

+151
-34
lines changed

3 files changed

+151
-34
lines changed

‎src/expand.c‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -24,7 +24,7 @@ static obj expand_cond(obj e) {
2424
cls = Mcadr(e);
2525
if (Mnullp(Mcddr(e)) && Mcar(cls) == Mintern("else")) {
2626
// else clause
27-
return Mcadr(cls);
27+
return Mcons(Mbegin_symbol, Mcdr(cls));
2828
} else {
2929
// normal clause
3030
ift = Mcons(Mbegin_symbol, Mcdr(cls));

‎src/kernel.min‎

Lines changed: 107 additions & 25 deletions
Original file line numberDiff line numberDiff line change
@@ -553,6 +553,8 @@
553553
real?
554554
complex?
555555
number?
556+
1+ 1-
557+
+ - * /
556558
= > < >= <=
557559
negative-integer?
558560
positive-integer?
@@ -572,27 +574,106 @@
572574
(define (non-number-error name x)
573575
(raise-argument-error name "number?" x))
574576

575-
; (define (+ . xs)
576-
; (cond
577-
; [(null? xs) 0]
578-
; [(null? (cdr xs))
579-
; (unless (number? (car xs))
580-
; (non-number-error '+ (car xs)))
581-
; (car xs)]
582-
; [(null? (cddr xs))
583-
; (unless (number? (car xs))
584-
; (non-number-error '+ (car xs)))
585-
; (unless (number? (cadr xs))
586-
; (non-number-error '+ (cadr xs)))
587-
; ($fx+ (car xs) (cadr xs))]
588-
; [else
589-
; (unless (number? (car xs))
590-
; (non-number-error '+ (car xs)))
591-
; (let loop ([x (car xs)] [y (cadr xs)] [xs (cddr xs)])
592-
; (
593-
; (unless (number? (cadr xs))
594-
; (non-number-error '+ (cadr xs)))
595-
577+
(define (1+ x)
578+
(unless (number? x)
579+
(non-number-error '1+ x))
580+
($fx1+ x))
581+
582+
(define (1- x)
583+
(unless (number? x)
584+
(non-number-error '1- x))
585+
($fx1- x))
586+
587+
(define (+ . xs)
588+
(cond
589+
[(null? xs) 0]
590+
[(null? (cdr xs))
591+
(unless (number? (car xs))
592+
(non-number-error '+ (car xs)))
593+
(car xs)]
594+
[(null? (cddr xs))
595+
(unless (number? (car xs))
596+
(non-number-error '+ (car xs)))
597+
(unless (number? (cadr xs))
598+
(non-number-error '+ (cadr xs)))
599+
($fx+ (car xs) (cadr xs))]
600+
[else
601+
(unless (number? (car xs))
602+
(non-number-error '+ (car xs)))
603+
(let loop ([x (car xs)] [xs (cdr xs)])
604+
(cond
605+
[(null? xs) x]
606+
[(number? (car xs)) (loop ($fx+ x (car xs)) (cdr xs))]
607+
[else (non-number-error '+ (car xs))]))]))
608+
609+
(define (- x . xs)
610+
(cond
611+
[(null? xs)
612+
(unless (number? x)
613+
(non-number-error '- x))
614+
($fxneg x)]
615+
[(null? (cdr xs))
616+
(unless (number? x)
617+
(non-number-error '- x))
618+
(unless (number? (car xs))
619+
(non-number-error '+ (car xs)))
620+
($fx- x (car xs))]
621+
[else
622+
(unless (number? x)
623+
(non-number-error '- x))
624+
(let loop ([x x] [xs xs])
625+
(cond
626+
[(null? xs) x]
627+
[(number? (car xs)) (loop ($fx- x (car xs)) (cdr xs))]
628+
[else (non-number-error '+ (car xs))]))]))
629+
630+
(define (* . xs)
631+
(cond
632+
[(null? xs) 1]
633+
[(null? (cdr xs))
634+
(unless (number? (car xs))
635+
(non-number-error '* (car xs)))
636+
(car xs)]
637+
[(null? (cddr xs))
638+
(unless (number? (car xs))
639+
(non-number-error '* (car xs)))
640+
(unless (number? (cadr xs))
641+
(non-number-error '* (cadr xs)))
642+
($fx* (car xs) (cadr xs))]
643+
[else
644+
(unless (number? (car xs))
645+
(non-number-error '* (car xs)))
646+
(let loop ([x (car xs)] [xs (cdr xs)])
647+
(cond
648+
[(null? xs) x]
649+
[(number? (car xs)) (loop ($fx* x (car xs)) (cdr xs))]
650+
[else (non-number-error '* (car xs))]))]))
651+
652+
(define (/ x . xs)
653+
(cond
654+
[(null? xs)
655+
(unless (number? x)
656+
(non-number-error '/ x))
657+
(when (zero? x)
658+
(error '/' "division by zero" x))
659+
($fx/ 1 x)]
660+
[(null? (cdr xs))
661+
(unless (number? x)
662+
(non-number-error '- x))
663+
(unless (number? (car xs))
664+
(non-number-error '+ (car xs)))
665+
(when (zero? (car xs))
666+
(error '/' "division by zero" (car xs)))
667+
($fx/ x (car xs))]
668+
[else
669+
(unless (number? x)
670+
(non-number-error '- x))
671+
(let loop ([x x] [xs xs])
672+
(cond
673+
[(null? xs) x]
674+
[(not (number? (car xs))) (non-number-error '+ (car xs))]
675+
[(zero? (car xs)) (error '/' "division by zero" (car xs))]
676+
[else (loop ($fx/ x (car xs)) (cdr xs))]))]))
596677

597678
(define (make-comparator who cmp)
598679
(lambda (x . xs)
@@ -610,11 +691,12 @@
610691
[else
611692
(unless (number? x)
612693
(non-number-error who x))
613-
(loop ([x x] [y (car xs)] [xs (cdr xs)])
694+
(let loop ([x x] [xs xs])
614695
(cond
615-
[(null? xs) (cmp x y)]
616-
[(number? y) (and (cmp x y) (loop y (car xs) (cdr xs)))]
617-
[else (non-number-error who y)]))])))
696+
[(null? xs) #t]
697+
[(not (number? (car xs))) (non-number-error who (car xs))]
698+
[(cmp x (car xs)) (loop (car xs) (cdr xs))]
699+
[else #f]))])))
618700

619701
(define = (make-comparator '= $fx=))
620702
(define > (make-comparator '> $fx>))

‎tests/kernel.c‎

Lines changed: 43 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -154,21 +154,56 @@ int test_equal(void) {
154154
int test_num(void) {
155155
passed = 1;
156156

157+
check_equal("(+)", "0");
158+
check_equal("(+ 1)", "1");
159+
check_equal("(+ 1 2)", "3");
160+
check_equal("(+ 1 2 3)", "6");
161+
check_equal("(1+ 1)", "2");
162+
163+
check_equal("(- 1)", "-1");
164+
check_equal("(- 1 2)", "-1");
165+
check_equal("(- 1 2 3)", "-4");
166+
check_equal("(1- 1)", "0");
167+
168+
check_equal("(*)", "1");
169+
check_equal("(* 1)", "1");
170+
check_equal("(* 1 2)", "2");
171+
check_equal("(* 1 2 3)", "6");
172+
173+
check_equal("(/ 1 1)", "1");
174+
check_equal("(/ 6 3)", "2");
175+
check_equal("(/ 7 3)", "2");
176+
check_equal("(/ 24 2 3)", "4");
177+
178+
check_true("(= 1)");
157179
check_true ("(= 1 1)");
158180
check_false("(= 1 2)");
181+
check_true("(= 1 1 1)");
182+
check_false("(= 1 2 1)");
183+
check_false("(= 1 1 2)");
159184

185+
check_true("(>= 1)");
160186
check_true ("(>= 2 1)");
161187
check_true ("(>= 1 1)");
162188
check_false("(>= 0 1)");
189+
check_true("(>= 2 1 1)");
190+
check_false("(>= 1 2 1)");
191+
check_false("(>= 1 1 2)");
163192

193+
check_true("(<= 1)");
164194
check_false("(<= 2 1)");
165195
check_true ("(<= 1 1)");
166196
check_true ("(<= 0 1)");
197+
check_true("(<= 1 1 2)");
198+
check_false("(<= 1 2 1)");
199+
check_false("(<= 2 1 1)");
167200

201+
check_true("(> 1)");
168202
check_true ("(> 2 1)");
169203
check_false("(> 1 1)");
170204
check_false("(> 0 1)");
171205

206+
check_true("(< 1)");
172207
check_false("(< 2 1)");
173208
check_false("(< 1 1)");
174209
check_true ("(< 0 1)");
@@ -286,7 +321,7 @@ int test_callwv(void) {
286321
check_equal("(call-with-values (lambda () (values)) (lambda xs xs))", "()");
287322
check_equal("(call-with-values (lambda () (values 1)) (lambda xs xs))", "(1)");
288323
check_equal("(call-with-values (lambda () (values 1 2 3)) (lambda xs xs))", "(1 2 3)");
289-
check_equal("(call-with-values (lambda () (values 1 2)) fx+)", "3");
324+
check_equal("(call-with-values (lambda () (values 1 2)) +)", "3");
290325

291326
return passed;
292327
}
@@ -299,26 +334,26 @@ int test_callcc(void) {
299334
check_equal("(let ([x #f]) (cons 1 (call/cc (lambda (k) (set! x k) 2))))", "(1 . 2)");
300335

301336
// from ChezScheme documentation
302-
check_equal("(call/cc (lambda (k) (fx* 5 (k 4))))", "4");
303-
check_equal("(fx+ 2 (call/cc (lambda (k) (fx* 5 (k 4)))))", "6");
337+
check_equal("(call/cc (lambda (k) (* 5 (k 4))))", "4");
338+
check_equal("(+ 2 (call/cc (lambda (k) (* 5 (k 4)))))", "6");
304339
check_equal("(letrec ([product "
305340
"(lambda (xs) "
306341
"(call/cc "
307342
"(lambda (break) "
308343
"(if (null? xs) "
309344
"1 "
310-
"(if (fx= (car xs) 0) "
345+
"(if (= (car xs) 0) "
311346
"(break 0) "
312-
"(fx* (car xs) (product (cdr xs))))))))]) "
347+
"(* (car xs) (product (cdr xs))))))))]) "
313348
"(product '(7 3 8 0 1 9 5)))",
314349
"0");
315350
check_equal("(let ([x (call/cc (lambda (k) k))]) "
316351
"(x (lambda (ignore) \"hi\")))",
317352
"\"hi\"");
318353

319354
check_equal("(letrec ([k* #f] "
320-
"[y (fx1+ (call/cc (lambda (k) (set! k* k) 0)))]) "
321-
"(if (fx< y 5) "
355+
"[y (1+ (call/cc (lambda (k) (set! k* k) 0)))]) "
356+
"(if (< y 5) "
322357
"(k* y) "
323358
"y))",
324359
"5");
@@ -344,7 +379,7 @@ int test_dynamic_wind(void) {
344379
"(set! c c0) "
345380
"'talk1)))) "
346381
"(lambda () (add 'disconnect))) "
347-
"(if (fx< (length path) 4) "
382+
"(if (< (length path) 4) "
348383
"(c 'talk2) "
349384
"(reverse path))))",
350385
"(connect talk1 disconnect connect talk2 disconnect)"

0 commit comments

Comments
 (0)