Skip to content

Commit 0139ed1

Browse files
ktakashiktakashi
committed
Removing (rnrs) from (sagittarius object)
1 parent 3ae0aa4 commit 0139ed1

File tree

3 files changed

+94
-129
lines changed

3 files changed

+94
-129
lines changed

‎lib/core/control.scm‎

Lines changed: 85 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,85 @@
1+
;;; -*- Scheme -*-
2+
;;;
3+
;;; core/control.scm - core controls
4+
;;;
5+
;;; Copyright (c) 2026 Takashi Kato <ktakashi@ymail.com>
6+
;;;
7+
;;; Redistribution and use in source and binary forms, with or without
8+
;;; modification, are permitted provided that the following conditions
9+
;;; are met:
10+
;;;
11+
;;; 1. Redistributions of source code must retain the above copyright
12+
;;; notice, this list of conditions and the following disclaimer.
13+
;;;
14+
;;; 2. Redistributions in binary form must reproduce the above copyright
15+
;;; notice, this list of conditions and the following disclaimer in the
16+
;;; documentation and/or other materials provided with the distribution.
17+
;;;
18+
;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
19+
;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
20+
;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
21+
;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
22+
;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
23+
;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
24+
;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
25+
;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
26+
;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
27+
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
28+
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
29+
;;;
30+
31+
#!nounbound
32+
(library (core control)
33+
(export case-lambda)
34+
(import (core)
35+
(core syntax)
36+
(sagittarius))
37+
(define-syntax case-lambda-aux
38+
(lambda (x)
39+
(define (construct args formals clause*)
40+
(define _car #'car)
41+
(define _cdr #'cdr)
42+
(define (parse-formals formal args inits)
43+
(syntax-case formal ()
44+
(() (reverse! inits))
45+
((a . d)
46+
(with-syntax ((arg `(,_car ,args))
47+
(args `(,_cdr ,args)))
48+
(parse-formals #'d #'args
49+
(cons (list #'a #'arg) inits))))
50+
(v
51+
(reverse! (cons (list #'v args) inits)))))
52+
(with-syntax ((((var init) ...) (parse-formals formals args '()))
53+
((clause ...) clause*))
54+
;; Using `lambda` enables type check, immediate apply
55+
;; will be converted to let by the compiler.
56+
#'((lambda (var ...) clause ...) init ...)))
57+
(syntax-case x ()
58+
((_ args n)
59+
#'(assertion-violation #f "unexpected number of arguments" args))
60+
((_ args n ((x ...) b ...) more ...)
61+
(with-syntax ((let-clause (construct #'args #'(x ...) #'(b ...)))
62+
(expect-length (length #'(x ...))))
63+
#'(if (= n expect-length)
64+
let-clause
65+
(case-lambda-aux args n more ...))))
66+
((_ args n ((x1 x2 ... . r) b ...) more ...)
67+
(with-syntax ((let-clause (construct #'args #'(x1 x2 ... . r)
68+
#'(b ...)))
69+
(expect-length (length #'(x1 x2 ...))))
70+
#'(if (>= n expect-length)
71+
let-clause
72+
(case-lambda-aux args n more ...))))
73+
((_ args n (r b ...) more ...)
74+
#'(let ((r args)) b ...)))))
75+
76+
(define-syntax case-lambda
77+
(syntax-rules ()
78+
((_ (fmls b1 b2 ...))
79+
(lambda fmls b1 b2 ...))
80+
((_ (fmls b1 b2 ...) ...)
81+
(lambda args
82+
(let ((n (length args)))
83+
(case-lambda-aux args n (fmls b1 b2 ...) ...))))))
84+
85+
)

‎lib/rnrs/control.scm‎

Lines changed: 1 addition & 124 deletions
Original file line numberDiff line numberDiff line change
@@ -3,127 +3,4 @@
33
(library (rnrs control (6))
44
(export when unless do case-lambda)
55
(import (core)
6-
(core base)
7-
(only (sagittarius) reverse!)
8-
(core syntax))
9-
10-
(define-syntax case-lambda-aux
11-
(lambda (x)
12-
(define (construct args formals clause*)
13-
(define _car #'car)
14-
(define _cdr #'cdr)
15-
(define (parse-formals formal args inits)
16-
(syntax-case formal ()
17-
(() (reverse! inits))
18-
((a . d)
19-
(with-syntax ((arg `(,_car ,args))
20-
(args `(,_cdr ,args)))
21-
(parse-formals #'d #'args
22-
(cons (list #'a #'arg) inits))))
23-
(v
24-
(reverse! (cons (list #'v args) inits)))))
25-
(with-syntax ((((var init) ...) (parse-formals formals args '()))
26-
((clause ...) clause*))
27-
;; Using `lambda` enables type check, immediate apply
28-
;; will be converted to let by the compiler.
29-
#'((lambda (var ...) clause ...) init ...)))
30-
(syntax-case x ()
31-
((_ args n)
32-
#'(assertion-violation #f "unexpected number of arguments" args))
33-
((_ args n ((x ...) b ...) more ...)
34-
(with-syntax ((let-clause (construct #'args #'(x ...) #'(b ...)))
35-
(expect-length (length #'(x ...))))
36-
#'(if (= n expect-length)
37-
let-clause
38-
(case-lambda-aux args n more ...))))
39-
((_ args n ((x1 x2 ... . r) b ...) more ...)
40-
(with-syntax ((let-clause (construct #'args #'(x1 x2 ... . r)
41-
#'(b ...)))
42-
(expect-length (length #'(x1 x2 ...))))
43-
#'(if (>= n expect-length)
44-
let-clause
45-
(case-lambda-aux args n more ...))))
46-
((_ args n (r b ...) more ...)
47-
#'(let ((r args)) b ...)))))
48-
49-
(define-syntax case-lambda
50-
(syntax-rules ()
51-
((_ (fmls b1 b2 ...))
52-
(lambda fmls b1 b2 ...))
53-
((_ (fmls b1 b2 ...) ...)
54-
(lambda args
55-
(let ((n (length args)))
56-
(case-lambda-aux args n (fmls b1 b2 ...) ...))))))
57-
58-
59-
;; implementation from srfi-16
60-
;; (define-syntax case-lambda
61-
;; (syntax-rules ()
62-
;; ((case-lambda (?a1 ?e1 ...) ?clause1 ...)
63-
;; (lambda args
64-
;; (let ((l (length args)))
65-
;; (case-lambda "CLAUSE" args l
66-
;; (?a1 ?e1 ...)
67-
;; ?clause1 ...))))
68-
;; ((case-lambda "CLAUSE" ?args ?l
69-
;; ((?a1 ...) ?e1 ...)
70-
;; ?clause1 ...)
71-
;; (if (= ?l (length '(?a1 ...)))
72-
;; (apply (lambda (?a1 ...) ?e1 ...) ?args)
73-
;; (case-lambda "CLAUSE" ?args ?l
74-
;; ?clause1 ...)))
75-
;; ((case-lambda "CLAUSE" ?args ?l
76-
;; ((?a1 . ?ar) ?e1 ...)
77-
;; ?clause1 ...)
78-
;; (case-lambda "IMPROPER" ?args ?l 1 (?a1 . ?ar) (?ar ?e1 ...)
79-
;; ?clause1 ...))
80-
;; ((case-lambda "CLAUSE" ?args ?l
81-
;; (?a1 ?e1 ...)
82-
;; ?clause1 ...)
83-
;; (let ((?a1 ?args))
84-
;; ?e1 ...))
85-
;; ((case-lambda "CLAUSE" ?args ?l)
86-
;; (syntax-violation 'case-lambda
87-
;; "wrong number of arguments to case-lambda."))
88-
;; ((case-lambda "IMPROPER" ?args ?l ?k ?al ((?a1 . ?ar) ?e1 ...)
89-
;; ?clause1 ...)
90-
;; (case-lambda "IMPROPER" ?args ?l (+ ?k 1) ?al (?ar ?e1 ...)
91-
;; ?clause1 ...))
92-
;; ((case-lambda "IMPROPER" ?args ?l ?k ?al (?ar ?e1 ...)
93-
;; ?clause1 ...)
94-
;; (if (>= ?l ?k)
95-
;; (apply (lambda ?al ?e1 ...) ?args)
96-
;; (case-lambda "CLAUSE" ?args ?l
97-
;; ?clause1 ...)))))
98-
;; implementation from R6RS
99-
;; (define-syntax case-lambda-help
100-
;; (syntax-rules ()
101-
;; ((_ args n)
102-
;; (assertion-violation #f "unexpected number of arguments"))
103-
;; ((_ args n ((x ...) b1 b2 ...) more ...)
104-
;; (if (= n (length '(x ...)))
105-
;; (apply (lambda (x ...) b1 b2 ...) args)
106-
;; (case-lambda-help args n more ...)))
107-
;; ((_ args n ((x1 x2 ... . r) b1 b2 ...) more ...)
108-
;; (if (>= n (length '(x1 x2 ...)))
109-
;; (apply (lambda (x1 x2 ... . r) b1 b2 ...)
110-
;; args)
111-
;; (case-lambda-help args n more ...)))
112-
;; ((_ args n (r b1 b2 ...) more ...)
113-
;; (apply (lambda r b1 b2 ...) args))))
114-
;;
115-
;; (define-syntax case-lambda
116-
;; (syntax-rules ()
117-
;; ((_ (fmls b1 b2 ...))
118-
;; (lambda fmls b1 b2 ...))
119-
;; ((_ (fmls b1 b2 ...) ...)
120-
;; (lambda args
121-
;; (let ((n (length args)))
122-
;; (case-lambda-help args n
123-
;; (fmls b1 b2 ...) ...))))))
124-
125-
) ; [end]
126-
;; end of file
127-
;; Local Variables:
128-
;; coding: utf-8-unix
129-
;; End:
6+
(core control)))

‎lib/sagittarius/object.scm‎

Lines changed: 8 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -2,7 +2,7 @@
22
;;;
33
;;; object.scm - object library
44
;;;
5-
;;; Copyright (c) 2000-2013 Takashi Kato <ktakashi@ymail.com>
5+
;;; Copyright (c) 2013-2026 Takashi Kato <ktakashi@ymail.com>
66
;;;
77
;;; Redistribution and use in source and binary forms, with or without
88
;;; modification, are permitted provided that the following conditions
@@ -29,12 +29,13 @@
2929
;;;
3030

3131
;; Gauche like ref, ~, ->string, ->integer and ->number
32+
#!nounbound
3233
(library (sagittarius object)
3334
(export ref ~ |setter of ref|
3435
->string ->integer ->number object-compare)
35-
(import (rnrs)
36-
(rnrs mutable-pairs)
37-
(rnrs mutable-strings)
36+
(import (core)
37+
(core control)
38+
(core base)
3839
(sagittarius)
3940
(clos user))
4041

@@ -105,7 +106,9 @@
105106
(define-method ->string ((obj <symbol>)) (symbol->string obj))
106107
(define-method ->string ((obj <char>)) (string obj))
107108
(define-method ->string ((obj <top>))
108-
(call-with-string-output-port (lambda (o) (display obj o))))
109+
(let-values (((out e) (open-string-output-port)))
110+
(display obj out)
111+
(e)))
109112

110113
(define-generic ->integer)
111114
(define-method ->integer ((obj <bytevector>)) (bytevector->integer obj))

0 commit comments

Comments
 (0)