開発環境
- macOS Sierra - Apple (OS)
- Emacs (Text Editor)
- C, Scheme (プログラミング言語)
- Clang/LLVM (コンパイラ, Xcode - Apple)
- 参考書籍等
Cを高級アセンブラーとした、Scheme の コンパイラー(ksc)、インタプリター(ksi)の作成で、標準ライブラリの base ライブラリの手続きを実装。(vector 関連と入出力関連、その他構文は除く。)
入出力関連の手続きのいくつかは、REPL での挙動とか細かい違いがあるみたいだから、よく理解してから実装することに。
vector については、まだどう実装するか検討中で決めていないから、関連する手続きも未実装。読み込み時にvectorの長さを取得して、その長さ分のヒープのメモリ領域をmallocで確保、長さと要素の対という感じで(bytevector と同様な感じ。読み込み時はリストとして読み込みそれをベクターに変換する。)実装することを検討中。まだ未実装なのは、バイトベクタと違って、ガベージコレクションの修正も必要になるから、慎重に、ということで。
コード
ksi.scm
(begin
(define (error message . objs)
(list 'error-object message objs))
(define (error-object? exp)
(tagged-list? exp 'error-object))
(define (error-object-message exp) (car (cdr exp)))
(define (error-irritants exp) (car (cdr (cdr exp))))
(define (eval exp env)
(if (error-object? exp)
exp
(if
(eof-object? exp)
(exit)
(if
(self-evaluating? exp)
exp
(if
(variable? exp)
(lookup-variable-value exp env)
(if
(quoted? exp)
(text-of-quotation exp)
(if
(lambda? exp)
(make-procedure (lambda-parameters exp)
(lambda-body exp)
env)
(if
(definition? exp)
(eval-definition exp env)
(if
(assignment? exp)
(eval-assignment exp env)
(if
(if? exp)
(eval-if exp env)
(if
(begin? exp)
(eval-sequence (begin-actions exp) env)
(if (and? exp)
(eval (and->if exp) env)
(if (or? exp)
(eval (or->if exp) env)
(if
(load? exp)
(eval (read (open-input-file (car (cdr exp)))) env)
(if
(pair? exp)
(begin
(define op (eval (car exp) env))
(if (error-object? op)
op
(begin
(define ops (list-of-values (cdr exp) env))
(define o (include-error? ops))
(if o
o
(apply op ops)))))
(error "(eval) unknown expression type --"
exp))))))))))))))))
(define (eval-definition exp env)
(if (or (and (c-symbol? (car (cdr exp)))
(= (length exp) 3))
(and (pair? (car (cdr exp)))
(< 2 (length exp))))
(begin
(define o (eval (definition-value exp) env))
(if (error-object? o)
o
(define-variable!
(definition-variable exp)
o
env)
(error "(eval) unknown expression type --" exp)))))
(define (eval-assignment exp env)
(if (= (length exp) 3)
(begin
(define o (eval (assignment-value exp) env))
(if (error-object? o)
o
(set-variable-value! (assignment-variable exp)
o
env)))
(error "(eval) unknown expression type --" exp)))
(define (eval-if exp env)
(if (or (= (length exp) 3)
(= (length exp) 4))
(begin
(define pred (eval (if-predicate exp) env))
(if (error-object? pred)
pred
(if pred
(eval (if-consequent exp) env)
(eval (if-alternative exp) env))))
(error "(eval) unknown expression type --" exp)))
(define (eval-sequence exps env)
(if (null? (cdr exps))
(eval (car exps) env)
(begin
(define o (eval (car exps) env))
(if (error-object? o)
o
(eval-sequence (cdr exps) env)))))
(define (include-error? list)
(if (null? list)
#f
(if (error-object? (car list))
(car list)
(include-error? (cdr list)))))
(define (list-of-values exps env)
(if (null? exps)
'()
(cons (eval (car exps) env)
(list-of-values (cdr exps) env))))
(define (apply procedure arguments)
(if (primitive-procedure? procedure)
(c-apply (primitive-implementation procedure) arguments)
(if (compound-procedure? procedure)
(begin
(define env (extend-environment
(procedure-parameters procedure)
arguments
(procedure-environment procedure)))
(if (error-object? env)
env
(eval-sequence (procedure-body procedure) env)))
(error "unknown procedure type --" procedure))))
(define (self-evaluating? exp)
(or (boolean? exp)
(number? exp)
(vector? exp)
(c-char? exp)
(string? exp)
(bytevector? exp)
(procedure? exp)
(eq? exp (if #f #f))))
(define (variable? exp) (c-symbol? exp))
(define (quoted? exp) (tagged-list? exp 'quote))
(define (text-of-quotation exp) (car (cdr exp)))
(define (tagged-list? exp tag)
(if (pair? exp)
(eq? (car exp) tag)
#f))
(define (lambda? exp) (tagged-list? exp 'lambda))
(define (lambda-parameters exp) (car (cdr exp)))
(define (lambda-body exp) (cdr (cdr exp)))
(define (make-lambda parameters body) (cons 'lambda (cons parameters body)))
(define (if? exp) (tagged-list? exp 'if))
(define (if-predicate exp) (car (cdr exp)))
(define (if-consequent exp) (car (cdr (cdr exp))))
(define (if-alternative exp)
(if (not (null? (cdr (cdr (cdr exp)))))
(car (cdr (cdr (cdr exp))))))
(define (begin? exp) (tagged-list? exp 'begin))
(define (begin-actions exp) (cdr exp))
(define (and? exp) (tagged-list? exp 'and))
(define (and->if exp)
(if (null? exp)
#t
(begin
(define (iter o)
(if (null? (cdr o))
(car o)
(list 'if
(car o)
(iter (cdr o))
'#f)))
(iter exp))))
(define (or? exp) (tagged-list? exp 'or))
(define (or->if exp)
(if (null? exp)
'#f
(list 'if (car exp) (car exp) (cons 'or (cdr exp)))))
(define (load? exp) (tagged-list? exp 'load))
(define (definition? exp) (tagged-list? exp 'define))
(define (definition-variable exp)
(if (c-symbol? (car (cdr exp)))
(car (cdr exp))
(car (car (cdr exp)))))
(define (definition-value exp)
(if (c-symbol? (car (cdr exp)))
(car (cdr (cdr exp)))
(make-lambda (cdr (car (cdr exp)))
(cdr (cdr exp)))))
(define (assignment? exp) (tagged-list? exp 'set!))
(define (assignment-variable exp) (car (cdr exp)))
(define (assignment-value exp) (car (cdr (cdr exp))))
(define (first-frame env) (car env))
(define the-empty-environment '())
(define (make-frame variables values) (cons variables values))
(define (frame-variables frame) (car frame))
(define (frame-values frame) (cdr frame))
(define (add-binding-to-frame! var val frame)
(set-car! frame (cons var (car frame)))
(set-cdr! frame (cons val (cdr frame))))
(define (define-variable! var val env)
((lambda (frame)
(define (scan vars vals)
(if (null? vars)
(add-binding-to-frame! var val frame)
(if (eq? var (car vars))
(set-car! vals val)
(scan (cdr vars) (cdr vals)))))
(scan (frame-variables frame)
(frame-values frame)))
(first-frame env)))
(define (set-variable-value! var val env)
(define (env-loop env)
(define (scan vars vals)
(if (null? vars)
(env-loop (enclosing-environment env))
(if (eq? var (car vars))
(set-car! vals val)
(scan (cdr vars) (cdr vals)))))
(if (eq? env the-empty-environment)
(error "(set!) unbound variable --" var)
((lambda (frame)
(scan (frame-variables frame)
(frame-values frame)))
(first-frame env))))
(env-loop env))
(define (make-procedure parameters body env)
(list 'procedure parameters body env))
(define (compound-procedure? p) (tagged-list? p 'procedure))
(define (procedure-parameters p) (car (cdr p)))
(define (procedure-body p) (car (cdr (cdr p))))
(define (procedure-environment p) (car (cdr (cdr (cdr p)))))
(define (enclosing-environment env) (cdr env))
(define (extend-environment vars vals base-env)
(define (iter vars-0 vals-0 vars-1 vals-1)
(if (c-symbol? vars-0)
(cons (make-frame (cons vars-0 vars-1)
(cons vals-0 vals-1))
base-env)
(if (null? vars-0)
(if (null? vals-0)
(cons (make-frame vars-1 vals-1) base-env)
(error "too many arguments supplied" vars vals))
(if (null? vals-0)
(error "too few arguments supplied" vars vals)
(iter (cdr vars-0)
(cdr vals-0)
(cons (car vars-0) vars-1)
(cons (car vals-0) vals-1))))))
(iter vars vals '() '()))
(define (lookup-variable-value var env)
(define (env-loop env)
(define (scan vars vals)
(if (null? vars)
(env-loop (enclosing-environment env))
(if (eq? var (car vars))
(car vals)
(scan (cdr vars) (cdr vals)))))
(if (eq? env the-empty-environment)
(error "unbound variable --" var)
((lambda (frame)
(scan (frame-variables frame)
(frame-values frame)))
(first-frame env))))
(env-loop env))
(define (numbers? objs)
(if (null? objs)
#t
(if (number? (car objs))
(numbers? (cdr objs))
#f)))
(define (primitive-procedure? proc) (tagged-list? proc 'primitive))
(define (primitive-implementation proc) (car (cdr proc)))
(load "primitive_procedures.scm")
(define primitive-procedures
(list (cons '* *)
(cons '+ +)
(cons '- -)
(cons '/ /)
(cons '< <)
(cons '<= <=)
(cons '= =)
(cons '> >)
(cons '>= >=)
(cons 'abs abs)
(cons 'append append)
(cons 'binary-port? binary-port?)
(cons 'boolean=? boolean=?)
(cons 'boolean? boolean?)
(cons 'bytevector bytevector)
(cons 'bytevector-append bytevector-append)
(cons 'bytevector-copy bytevector-copy)
(cons 'bytevector-length bytevector-length)
(cons 'bytevector-u8-ref bytevector-u8-ref)
(cons 'bytevector-u8-set! bytevector-u8-set!)
(cons 'bytevector? bytevector?)
(cons 'car car)
(cons 'cdr cdr)
(cons 'ceiling ceiling)
(cons 'char->integer char->integer)
(cons 'char<=? char<=?)
(cons 'char<? char<?)
(cons 'char=? char=?)
(cons 'char>=? char>=?)
(cons 'char>? char>?)
(cons 'char? char?)
(cons 'close-input-port close-input-port)
(cons 'close-output-port close-output-port)
(cons 'close-port close-port)
(cons 'complex? complex?)
(cons 'cons cons)
(cons 'current-error-port current-error-port)
(cons 'current-input-port current-input-port)
(cons ''current-output-port current-output-port)
(cons 'denominator denominator)
(cons 'eof-object eof-object)
(cons 'eof-object? eof-object?)
(cons 'eq? eq?)
(cons 'eqv? eqv?)
(cons 'error (lambda args
(if (c-null? args)
(error '|(error) wrong number of arguments --| args)
(c-apply error args))))
(cons 'error-object-irritants
(lambda args
(if (c-= (c-length args) 1)
(if (error-object? (c-car args))
(error-object-irritants (c-car args))
(error
'|(error-object-irritants) wrong type of argument --|
args))
(error
'|(error-object-irritants) wrong number of arguments --|
args))))
(cons 'error-object-message
(lambda args
(if (c-= (c-length args) 1)
(if (error-object? (c-car args))
(error-object-message (c-car args))
(error
'|(error-object-message) wrong type of argument --|
args))
(error
'|(error-object-message) wrong number of arguments --|
args))))
(cons 'error-object?
(lambda args
(if (c-= (c-length args) 1)
(error-object? (c-car args))
(error
'|(error-object?) wrong number of arguments --| args))))
(cons 'even? even?)
(cons 'exact exact)
(cons 'exact? exact?)
(cons 'expt expt)
(cons 'floor floor)
(cons 'flush-output-port flush-output-port)
(cons 'gcd gcd)
(cons 'inexact inexact)
(cons 'input-port-open? input-port-open?)
(cons 'input-port? input-port?)
(cons 'integer->char integer->char)
(cons 'integer? integer?)
(cons 'lcm lcm)
(cons 'length length)
(cons 'list list)
(cons 'list->string list->string)
(cons 'list? list?)
(cons 'make-bytevector make-bytevector)
(cons 'make-list make-list)
(cons 'make-string make-string)
(cons 'negative? negative?)
(cons 'newline newline)
(cons 'null? null?)
(cons 'number? number?)
(cons 'numerator numerator)
(cons 'odd? odd?)
(cons 'output-port-open? output-port-open?)
(cons 'output-port? output-port?)
(cons 'pair? pair?)
(cons 'port? port?)
(cons 'positive? positive?)
(cons 'procedure?
(lambda args
(if (c-= (c-length args) 1)
(or (primitive-procedure? (c-car args))
(compound-procedure? (c-car args)))
(error
'|(procedure?) wrong number of arguments --| args))))
(cons 'raise
(lambda args
(if (c-= (c-length args) 1)
(error '|| (c-car args))
(error
'|(raise) wrong number of arguments --| args))))
(cons 'rational? rational?)
(cons 'read-bytevector read-bytevector)
(cons 'read-char read-char)
(cons 'read-u8 read-u8)
(cons 'real? real?)
(cons 'reverse reverse)
(cons 'round round)
(cons 'set-car! set-car!)
(cons 'set-cdr! set-cdr!)
(cons 'square square)
(cons 'string->list string->list)
(cons 'string->number string->number)
(cons 'string->symbol string->symbol)
(cons 'string->utf8 string->utf8)
(cons 'string-length string-length)
(cons 'string-ref string-ref)
(cons 'string-set! string-set!)
(cons 'string<=? string<=?)
(cons 'string<? string<?)
(cons 'string=? string=?)
(cons 'string>=? string>=?)
(cons 'string>? string>?)
(cons 'string? string?)
(cons 'symbol->string symbol->string)
(cons 'symbol=? symbol=?)
(cons 'textual-port? textual-port?)
(cons 'truncate truncate)
(cons 'utf8->string utf8->string)
(cons 'vector? vector?)
(cons 'write-bytevector write-bytevector)
(cons 'write-char write-char)
(cons 'write-string write-string)
(cons 'write-u8 write-u8)
))
(define (map proc list)
(if (null? list)
'()
(cons (proc (car list))
(map proc (cdr list)))))
(define (primitive-procedure-names) (map car primitive-procedures))
(define (primitive-procedure-objects)
(map (lambda (proc)
(list 'primitive (cdr proc)))
primitive-procedures))
(define (setup-environment)
((lambda (initial-env)
(define-variable! 'quote quote initial-env)
(define-variable! 'lambda lambda initial-env)
(define-variable! 'define define initial-env)
(define-variable! 'set! set! initial-env)
(define-variable! 'if if initial-env)
(define-variable! 'begin begin initial-env)
(define-variable! 'and and initial-env)
(define-variable! 'or or initial-env)
(define-variable! 'load load initial-env)
initial-env)
(extend-environment
(primitive-procedure-names)
(primitive-procedure-objects)
the-empty-environment)))
(define the-global-environment (setup-environment))
(define input-prompt "> ")
(define output-prompt "=> ")
(define input-port (current-input-port))
(define output-port (current-output-port))
(define (driver-loop)
(prompt-for-input input-prompt)
((lambda (input)
((lambda (output)
(announce-output output-prompt)
(user-print output))
(eval input the-global-environment)))
(read input-port))
(driver-loop))
(define (prompt-for-input string)
(display string output-port))
(define (announce-output string)
(display string output-port))
(define (user-print object)
(if (error-object? object)
(begin
(display "Error: ")
(if (not (eq? (error-object-message object)) '||)
(display " "))
(display (error-object-message object))
(define (iter objs)
(if (not (null? objs))
(begin (display " ")
(write (car objs))
(iter (cdr objs)))))
(iter (error-irritants object)))
(if (primitive-procedure? object)
(display '|#<primitive-procedure>| output-port)
(if (compound-procedure? object)
(begin (display '|#<compound-procedure | output-port)
(write (procedure-parameters object) output-port)
(write '> output-port))
(write object output-port))))
(newline output-port))
(eval '(load "compound_procedures.scm") the-global-environment)
(driver-loop)
)
primitive_procedures.scm
(begin
(define (* . args)
(define (iter zs result e?)
(if (c-null? zs)
result
((lambda (z)
(if (c-number? z)
(if (and e? (c-exact? z))
(iter (c-cdr zs)
(c-* result z)
e?)
(iter (c-cdr zs)
(c-* (c-inexact result) (c-inexact z))
#f))
(error '|(*) wrong type of argument --| args)))
(c-car zs))))
(iter args 1 #t))
(define (+ . args)
(define (iter zs result e?)
(if (c-null? zs)
result
((lambda (z)
(if (c-number? z)
(if (and e? (c-exact? z))
(iter (c-cdr zs)
(c-+ result z)
e?)
(iter (c-cdr zs)
(c-+ (c-inexact result) (c-inexact z))
#f))
(error '|(+) wrong type of argument --| args)))
(c-car zs))))
(iter args 0 #t))
(define (- . args)
(define len (c-length args))
(if (c-= len 0)
(error '|(-) wrong number of arguments --| args)
(if (c-= len 1)
(if (c-number? (c-car args))
(if (c-exact? (c-car args))
(c-* -1 (c-car args))
(c-* (c-inexact -1) (c-car args)))
(error '|(-) wrong type of argument --| args))
(begin
(define (iter nums result e?)
(if (c-null? nums)
result
(if (c-number? (c-car nums))
(if (and e? (c-exact? (c-car nums)))
(iter (c-cdr nums)
(c-- result (c-car nums))
#t)
(iter (c-cdr nums)
(c-- (c-inexact result)
(c-inexact (c-car nums)))
#f))
(error '|(-) wrong type of argument --| args))))
(iter (c-cdr args) (c-car args) (c-exact? (c-car args)))))))
(define (/ . args)
(define len (c-length args))
(if (c-= len 0)
(error '|(/) wrong number of arguments --| args)
(if (c-= len 1)
(if (c-number? (c-car args))
(if (c-exact? (c-car args))
(c-/ 1 (c-car args))
(c-/ (c-inexact 1) (c-car args)))
(error '|(/) wrong type of argument --| args))
(begin
(define (iter nums result e?)
(if (c-null? nums)
result
(if (c-number? (c-car nums))
(if (and e? (c-exact? (c-car nums)))
(if (c-= (c-car nums) 0)
(error '|(/) division by zero --| args)
(iter (c-cdr nums)
(c-/ result (c-car nums))
#t))
(iter (c-cdr nums)
(c-/ (c-inexact result)
(c-inexact (c-car nums)))
#f))
(error '|(/) wrong type of argument --| args))))
(iter (c-cdr args) (c-car args) (c-exact? (c-car args)))))))
(define (< . args)
(define len (c-length args))
(if (c-< len 2)
(error '|(<) wrong number of arguments --| args)
(begin
(if (c-real? (c-car args))
(begin
(define (cmp x y)
(if (and (c-exact? x) (c-exact? y))
(c-< x y)
(c-< (c-inexact x) (c-inexact y))))
(define (iter x xs)
(if (c-null? xs)
#t
(if (c-real? (c-car xs))
(if (cmp x (c-car xs))
(iter (c-car xs) (c-cdr xs))
#f)
(error '|(<) wrong type of argument --| args))))
(iter (c-car args) (c-cdr args)))
(error '|(<) wrong type of argument --| args)))))
(define (<= . args)
(define len (c-length args))
(if (c-< len 2)
(error '|(<=) wrong number of arguments --| args)
(begin
(if (c-real? (c-car args))
(begin
(define (cmp x y)
(if (and (c-exact? x) (c-exact? y))
(or (c-= x y) (c-< x y))
(or (c-= (c-inexact x) (c-inexact y))
(c-< (c-inexact x) (c-inexact y)))))
(define (iter x xs)
(if (c-null? xs)
#t
(if (c-real? (c-car xs))
(if (cmp x (c-car xs))
(iter (c-car xs) (c-cdr xs))
#f)
(error '|(<=) wrong type of argument --| args))))
(iter (c-car args) (c-cdr args)))
(error '|(<=) wrong type of argument --| args)))))
(define (= . args)
(define len (c-length args))
(if (c-< len 2)
(error '|(=) wrong number of arguments --| args)
(begin
(if (c-number? (c-car args))
(begin
(define (cmp x y)
(if (and (c-exact? x) (c-exact? y))
(c-= x y)
(c-= (c-inexact x) (c-inexact y))))
(define (iter x xs)
(if (c-null? xs)
#t
(if (c-number? (c-car xs))
(if (cmp x (c-car xs))
(iter (c-car xs) (c-cdr xs))
#f)
(error '|(=) wrong type of argument --| args))))
(iter (c-car args) (c-cdr args)))
(error '|(=) wrong type of argument --| args)))))
(define (> . args)
(define len (c-length args))
(if (c-< len 2)
(error '|(>) wrong number of arguments --| args)
(begin
(if (c-real? (c-car args))
(begin
(define (cmp x y)
(if (and (c-exact? x) (c-exact? y))
(c-< y x)
(c-< (c-inexact y) (c-inexact x))))
(define (iter x xs)
(if (c-null? xs)
#t
(if (c-real? (c-car xs))
(if (cmp x (c-car xs))
(iter (c-car xs) (c-cdr xs))
#f)
(error '|(>) wrong type of argument --| args))))
(iter (c-car args) (c-cdr args)))
(error '|(>) wrong type of argument --| args)))))
(define (>= . args)
(define len (c-length args))
(if (c-< len 2)
(error '|(>=) wrong number of arguments --| args)
(begin
(if (c-real? (c-car args))
(begin
(define (cmp x y)
(if (and (c-exact? x) (c-exact? y))
(or (c-= x y) (c-< y x))
(or (c-= (c-inexact x) (c-inexact y))
(c-< (c-inexact y) (c-inexact x)))))
(define (iter x xs)
(if (c-null? xs)
#t
(if (c-real? (c-car xs))
(if (cmp x (c-car xs))
(iter (c-car xs) (c-cdr xs))
#f)
(error '|(>=) wrong type of argument --| args))))
(iter (c-car args) (c-cdr args)))
(error '|(>=) wrong type of argument --| args)))))
(define (abs . args)
(if (c-= (c-length args) 1)
(if (c-real? (c-car args))
(if (c-< (c-car args) 0)
(c-* -1 (c-car args))
(c-car args))
(error '|(abs) wrong type of argument --| args))
(error '|(abs) wrong number of arguments --| args)))
(define (append . list-of-list)
(if (c-null? list-of-list)
'()
(begin
(define reversed (c-reverse list-of-list))
(define o (c-car reversed))
(if (or (c-null? o) (c-pair? o))
(begin
(define (iter-1 list result)
(if (c-null? list)
result
(iter-1 (c-cdr list)
(c-cons (c-car list) result))))
(define (iter-2 list-of-list result)
(if (c-null? list-of-list)
result
(if (c-list? (c-car list-of-list))
(iter-2 (c-cdr list-of-list)
(iter-1 (c-reverse (c-car list-of-list))
result))
(error '|(append) wrong type of argument --| args))))
(iter-2 (c-cdr reversed) o))
o))))
(define (binary-port? . args)
(if (c-= (c-length args) 1)
(c-binary-port? (c-car args))
(error '|(binary-port?) wrong number of arguments --| args)))
(define (boolean=? . args)
(if (c-< 1 (c-length args))
(begin
(define boolean (c-car args))
(if (c-boolean? boolean)
(begin
(define (iter booleans)
(if (c-null? booleans)
#t
(if (c-boolean? (c-car booleans))
(if (c-eq? (c-car booleans) boolean)
(iter (c-cdr booleans))
#f)
(error '|(boolean=?) wrong type of argument --|
args))))
(iter (c-cdr args)))
(error '|(boolean=?) wrong type of argument --| args)))
(error '|(boolean=?) wrong number of arguments --| args)))
(define (boolean? . args)
(if (c-= (c-length args) 1)
(c-boolean? (c-car args))
(error '|(boolean?) wrong number of arguments --| args)))
(define (bytevector . args)
(define (byte? o) (and (c-integer? o) (c-exact? o) (c-< -1 o) (c-< o 256)))
(define (bytes? bytes)
(if (c-null? bytes)
#t
(if (byte? (c-car bytes))
(bytes? (c-cdr bytes))
#f)))
(if (bytes? args)
(c-apply c-bytevector args)
(error '|(bytevector) wrong type of argument --| args)))
(define (bytevector-append . args)
(define (bytevectors? bytevectors)
(if (c-null? bytevectors)
#t
(if (c-bytevector? (c-car bytevectors))
(bytevectors? (c-cdr bytevectors))
#f)))
(if (bytevectors? args)
(c-apply c-bytevector-append args)
(error '|(bytevector-append) wrong type of argument --| args)))
(define (bytevector-copy . args)
(define len (c-length args))
(if (and (c-< 0 len) (c-< len 4))
(begin
(define bytevector (c-car args))
(if (c-bytevector? bytevector)
(begin
(define bytevector-len (c-bytevector-length bytevector))
(define start (if (c-= len 1)
0
(c-cadr args)))
(define end (if (c-< len 3)
bytevector-len
(c-caddr args)))
(if (and (c-integer? start) (c-exact? start)
(c-integer? end) (c-exact? end)
(c-< -1 start) (c-< end (c-+ bytevector-len 1))
(c-< start end))
(c-bytevector-copy bytevector start end)
(error '|(bytevector-copy) wrong type of argument --| args)))
(error '|(bytevector-copy) wrong type of argument --| args)))
(error '|(bytevector-copy) wrong number of arguments --| args)))
(define (bytevector-length . args)
(if (c-= (c-length args) 1)
(if (c-bytevector? (c-car args))
(c-bytevector-length (c-car args))
(error '|(bytevector-length) wrong type of argument --| args))
(error '|(bytevector-length) wrong number of arguments --| args)))
(define (bytevector-u8-ref . args)
(if (c-= (c-length args) 2)
(begin
(define bv (c-car args))
(define k (c-cadr args))
(if (and (c-bytevector? bv)
(c-integer? k)
(c-exact? k)
(c-< -1 k)
(c-< k (c-bytevector-length bv)))
(c-bytevector-u8-ref bv k)
(error '|(bytevector-u8-ref) wrong type of argument --| args)))
(error '|(bytevector-u8-ref) wrong number of arguments --| args)))
(define (bytevector-u8-set! . args)
(if (c-= (c-length args) 3)
(begin
(define bv (c-car args))
(define k (c-cadr args))
(define byte (c-caddr args))
(if (and (c-bytevector? bv)
(c-integer? k)
(c-exact? k)
(c-< -1 k)
(c-< k (c-bytevector-length bv)))
(c-bytevector-u8-set! bv k byte)
(error '|(bytevector-u8-set!) wrong type of argument --| args)))
(error '|(bytevector-u8-set!) wrong number of arguments --| args)))
(define (bytevector? . args)
(if (c-= (c-length args) 1)
(c-bytevector? (c-car args))
(error '|(bytevector?) wrong number of arguments --| args)))
(define (car . args)
(if (= (c-length args) 1)
(if (c-pair? (c-car args))
(c-car (c-car args))
(error '|(car) wrong type of argument --| args))
(error '|(car) wrong number of arguments --| args)))
(define (cdr . args)
(if (= (c-length args) 1)
(if (c-pair? (c-car args))
(c-cdr (c-car args))
(error '|(cdr) wrong type of argument --| args))
(error '|(cdr) wrong number of arguments --| args)))
(define (ceiling . args)
(if (c-= (c-length args) 1)
(if (c-real? (c-car args))
(c-ceiling (c-car args))
(error '|(ceiling) wrong type of argument --| args))
(error '|(ceiling) wrong number of arguments --| args)))
(define (char->integer . args)
(if (c-= (c-length args) 1)
(if (c-char? (c-car args))
(c-char->integer (c-car args))
(error '|(char->integer) wrong type of argument --| args))
(error '|(char->integer) wrong number of arguments --| args)))
(define (char<=? . args)
(if (c-< 1 (c-length args))
(begin
(define (iter char chars)
(if (c-null? chars)
#t
(if (c-char? (c-car chars))
(if (c-char<=? char (c-car chars))
(iter (c-car chars) (c-cdr chars))
#f)
(error '|(char<=?) wrong type of argument --| args))))
(if (c-char? (c-car args))
(iter (c-car args) (c-cdr args))
(error '|(char<=?) wrong type of argument --| args)))
(error '|(char<=?) wrong number of arguments --| args)))
(define (char<? . args)
(if (c-< 1 (c-length args))
(begin
(define (iter char chars)
(if (c-null? chars)
#t
(if (c-char? (c-car chars))
(if (c-char<? char (c-car chars))
(iter (c-car chars) (c-cdr chars))
#f)
(error '|(char<?) wrong type of argument --| args))))
(if (c-char? (c-car args))
(iter (c-car args) (c-cdr args))
(error '|(char<?) wrong type of argument --| args)))
(error '|(char<?) wrong number of arguments --| args)))
(define (char=? . args)
(if (c-< 1 (c-length args))
(begin
(define (iter char chars)
(if (c-null? chars)
#t
(if (c-char? (c-car chars))
(if (c-char=? char (c-car chars))
(iter (c-car chars) (c-cdr chars))
#f)
(error '|(char=?) wrong type of argument --| args))))
(if (c-char? (c-car args))
(iter (c-car args) (c-cdr args))
(error '|(char=?) wrong type of argument --| args)))
(error '|(char=?) wrong number of arguments --| args)))
(define (char>=? . args)
(if (c-< 1 (c-length args))
(begin
(define (iter char chars)
(if (c-null? chars)
#t
(if (c-char? (c-car chars))
(if (c-char>=? char (c-car chars))
(iter (c-car chars) (c-cdr chars))
#f)
(error '|(char>=?) wrong type of argument --| args))))
(if (c-char? (c-car args))
(iter (c-car args) (c-cdr args))
(error '|(char>=?) wrong type of argument --| args)))
(error '|(char>=?) wrong number of arguments --| args)))
(define (char>? . args)
(if (c-< 1 (c-length args))
(begin
(define (iter char chars)
(if (c-null? chars)
#t
(if (c-char? (c-car chars))
(if (c-char>? char (c-car chars))
(iter (c-car chars) (c-cdr chars))
#f)
(error '|(char>?) wrong type of argument --| args))))
(if (c-char? (c-car args))
(iter (c-car args) (c-cdr args))
(error '|(char>?) wrong type of argument --| args)))
(error '|(char>?) wrong number of arguments --| args)))
(define (char? . args)
(if (c-= (c-length args) 1)
(c-char? (c-car args))
(error '|(char?) wrong number of arguments --| args)))
(define (close-input-port . args)
(if (c-= (c-length args) 1)
(if (c-input-port? (c-car args))
(c-close-port (c-car args))
(error '|(close-input-port) wrong type of argument --| args))
(error '|(close-input-port) wrong number of arguments --| args)))
(define (close-output-port . args)
(if (c-= (c-length args) 1)
(if (c-output-port? (c-car args))
(c-close-port (c-car args))
(error '|(close-output-port) wrong type of argument --| args))
(error '|(close-output-port) wrong number of arguments --| args)))
(define (close-port . args)
(if (c-= (c-length args) 1)
(if (c-port? (c-car args))
(c-close-port (c-car args))
(error '|(close-port) wrong type of argument --| args))
(error '|(close-port) wrong number of arguments --| args)))
(define (complex? . args)
(if (c-= (c-length args) 1)
(c-complex? (c-car args))
(error '|(complex?) wrong number of arguments --| args)))
(define (cons . args)
(if (c-= (c-length args) 2)
(c-cons (c-car args) (c-cadr args))
(error '|(cons) wrong number of arguments --| args)))
(define (current-error-port . args)
(if (c-null? args)
(c-current-error-port)
(error '|(current-error-port) wrong number of arguments --| args)))
(define (current-input-port . args)
(if (c-null? args)
(c-current-input-port)
(error '|(current-input-port) wrong number of arguments --| args)))
(define (current-output-port . args)
(if (c-null? args)
(c-current-output-port)
(error '|(current-output-port) wrong number of arguments --| args)))
(define (denominator . args)
(if (c-= (c-length args) 1)
(if (and (c-number? (c-car args)) (c-exact? (c-car args)))
(c-denominator (c-car args))
(error '|(denominator) wrong type of argument --| args))
(error '|(denominator) wrong number of arguments --| args)))
(define (eof-object . args)
(if (c-null? args)
(c-eof-object)
(error '|(eof-object) wrong number of arguments --| args)))
(define (eof-object? . args)
(if (c-= (c-length args) 1)
(c-eof-object? (c-car args))
(error '|(eof-object?) wrong number of arguments --| args)))
(define (eq? . args)
(if (c-= (c-length args) 2)
(c-eq? (c-car args) (c-cadr args))
(error '|(eq?) wrong number of arguments --| args)))
(define (eqv? . args)
(if (c-= (c-length args) 2)
(c-eqv? (c-car args) (c-cadr args))
(error '|(eqv?) wrong number of arguments --| args)))
(define (even? . args)
(if (c-= (c-length args) 1)
(if (c-integer? (c-car args))
(c-even? (c-car args))
(error '|(even?) wrong type of argument --| args))
(error '|(even?) wrong number of arguments --| args)))
(define (exact . args)
(if (c-= (c-length args) 1)
(if (c-number? (c-car args))
(c-exact (c-car args))
(error '|(exact) wrong type of argument --| args))
(error '|(exact) wrong number of arguments --| args)))
(define (exact? . args)
(if (c-= (c-length args) 1)
(if (c-number? (c-car args))
(c-exact? (c-car args))
(error '|(exact?) wrong type of argument --| args))
(error '|(exact?) wrong number of arguments --| args)))
(define (expt . args)
(if (c-= (c-length args) 2)
(if (and (c-number? (c-car args)) (c-number? (c-cadr args)))
(if (and (c-exact? (c-car args))
(c-exact? (c-cadr args)))
(c-expt (c-car args) (c-cadr args))
(c-expt (c-inexact (c-car args))
(c-inexact (c-cadr args))))
(error '|(expt) wrong type of argument --| args))
(error '|(expt) wrong number of arguments --| args)))
(define (floor . args)
(if (c-= (c-length args) 1)
(if (c-real? (c-car args))
(c-floor (c-car args))
(error '|(floor) wrong type of argument --| args))
(error '|(floor) wrong number of arguments --| args)))
(define (flush-output-port . args)
(define len (c-length args))
(if (c-< 1 len)
(error '|(flush-output-port) wrong number of arguments --| args)
(begin
(define port (if (c-= len 0)
(c-current-output-port)
(c-car args)))
(if (c-output-port? port)
(c-flush-output-port port)
(error '|(flush-output-port) wrong type of argument --| args)))))
(define (gcd . args)
(define (iter n nums e?)
(if (c-null? nums)
(if e?
n
(c-inexact n))
(if (c-integer? (c-car nums))
(if (and e? (c-exact? (c-car nums)))
(iter (c-gcd n (c-car nums))
(c-cdr nums)
e?)
(iter (c-gcd (c-exact n)
(c-exact (c-car nums)))
(c-cdr nums)
#f))
(error '|(gcd) wrong type of argument --| args))))
(iter 0 args #t))
(define (inexact . args)
(if (c-= (c-length args) 1)
(if (c-number? (c-car args))
(c-inexact (c-car args))
(error '|(inexact) wrong type of argument --| args))
(error '|(inexact) wrong number of arguments --| args)))
(define (input-port-open? . args)
(if (c-= (c-length args) 1)
(if (c-input-port? (c-car args))
(c-input-port-open? (c-car args))
(error '|(input-port-open?) wrong type of argument --| args))
(error '|(input-port-open?) wrong number of arguments --| args)))
(define (input-port? . args)
(if (c-= (c-length args) 1)
(c-input-port? (c-car args))
(error '|(input-port?) wrong number of arguments --| args)))
(define (integer->char . args)
(if (c-= (c-length args) 1)
(begin
(define n (c-car args))
(if (and (c-integer? n)
(c-< -1 n)
(c-< n 4294967296))
(c-integer->char n)
(error '|(integer->char) wrong type of argument --| args)))
(error '|(integer->char) wrong number of arguments --| args)))
(define (integer? . args)
(if (c-= (c-length args) 1)
(c-integer? (c-car args))
(error '|(integer?) wrong number of arguments --| args)))
(define (lcm . args)
(define (iter n nums e?)
(if (c-null? nums)
(if e?
n
(c-inexact n))
(if (c-integer? (c-car nums))
(if (and e? (c-exact? (c-car nums)))
(iter (c-lcm n (c-car nums))
(c-cdr nums)
e?)
(iter (c-lcm (c-exact n)
(c-exact (c-car nums)))
(c-cdr nums)
#f))
(error '|(lcm) wrong type of argument --| args))))
(iter 1 args #t))
(define (length . args)
(if (c-= (c-length args) 1)
(if (c-list? (c-car args))
(c-length (c-car args))
(error '|(length) wrong type of argument --| args))
(error '|(length) wrong number of arguments --| args)))
(define (list . args) args)
(define (list? . args)
(if (c-= (c-length args) 1)
(c-list? (c-car args))
(error '|(list?) wrong number of arguments --| args)))
(define (list->string . args)
(if (c-= (c-length args) 1)
(if (c-list? (c-car args))
(begin
(define (chars? list)
(if (c-null? list)
#t
(if (c-char? (c-car list))
(chars? (c-cdr list))
#f)))
(if (chars? (c-car args))
(c-list->string (c-car args))
(error '|(list->string) wrong type of argument --| args)))
(error '|(list->string) wrong type of argument --| args))
(error '|(list->string) wrong number of arguments --| args)))
(define (make-bytevector . args)
(define len (c-length args))
(if (or (c-< len 1) (c-< 2 len))
(error '|(make-bytevector) wrong number of arguments --| args)
(begin
(define k (c-car args))
(define byte (if (c-= len 1)
0
(c-cadr args)))
(if (and (c-integer? k) (c-exact? k) (c-< -1 k)
(c-integer? byte) (c-exact? byte)
(c-< -1 byte) (c-< byte 256))
(c-make-bytevector k byte)
(error '|(make-bytevector) wrong type of argument --| args)))))
(define (make-list . args)
(define len (c-length args))
(if (or (c-< len 1) (c-< 2 len))
(error '|(make-list) wrong number of arguments --| args)
(begin
(define k (c-car args))
(define fill (if (c-= len 1)
'()
(c-cadr args)))
(if (and (c-integer? k) (c-exact? k) (c-< -1 k))
(c-make-list k fill)
(error '|(make-list) wrong type of argument --| args)))))
(define (make-string . args)
(define len (c-length args))
(if (or (c-< len 1) (c-< 2 len))
(error '|(make-string) wrong number of arguments --| args)
(begin
(define k (c-car args))
(define char (if (c-= len 1)
#\space
(c-cadr args)))
(if (and (c-integer? k) (c-exact? k) (c-< -1 k))
(c-make-string k char)
(error '|(make-string) wrong type of argument --| args)))))
(define (negative? . args)
(if (c-= (c-length args) 1)
(if (c-real? (c-car args))
(c-negative? (c-car args))
(error '|(negative?) wrong type of argument --| args))
(error '|(negative?) wrong number of arguments --| args)))
(define (newline . args)
(define len (c-length args))
(if (c-< len 2)
(begin
(define port (if (c-= len 1)
(c-car args)
(c-current-output-port)))
(if (c-output-port? port)
(c-newline port)
(error '|(newline) wrong type of argument --| args)))
(error '|(newline) wrong number of arguments --| args)))
(define (null? . args)
(if (c-= (c-length args) 1)
(c-null? (c-car args))
(error '|(null?) wrong number of arguments --| args)))
(define (number? . args)
(if (c-= (c-length args) 1)
(c-number? (c-car args))
(error '|(number?) wrong number of arguments --| args)))
(define (numerator . args)
(if (c-= (c-length args) 1)
(if (c-exact? (c-car args))
(c-numerator (c-car args))
(error '|(numerator) wrong type of argument --| args))
(error '|(numerator) wrong number of arguments --| args)))
(define (odd? . args)
(if (c-= (c-length args) 1)
(if (c-integer? (c-car args))
(c-odd? (c-car args))
(error '|(odd?) wrong type of argument --| args))
(error '|(odd?) wrong number of arguments --| args)))
(define (output-port-open? . args)
(if (c-= (c-length args) 1)
(if (c-output-port? (c-car args))
(c-output-port-open? (c-car args))
(error '|(output-port-open?) wrong type of argument --| args))
(error '|(output-port-open?) wrong number of arguments --| args)))
(define (output-port? . args)
(if (c-= (c-length args) 1)
(c-output-port? (c-car args))
(error '|(output-port?) wrong number of arguments --| args)))
(define (pair? . args)
(if (c-= (c-length args) 1)
(c-pair? (c-car args))
(error '|(pair?) wrong number of arguments --| args)))
(define (port? . args)
(if (c-= (c-length args) 1)
(c-port? (c-car args))
(error '|(port?) wrong number of arguments --| args)))
(define (positive? . args)
(if (c-= (c-length args) 1)
(if (c-real? (c-car args))
(c-positive? (c-car args))
(error '|(positive?) wrong type of argument --| args))
(error '|(positive?) wrong number of arguments --| args)))
(define (rational? . args)
(if (c-= (c-length args) 1)
(begin
(define obj (c-car args))
(and (c-real? obj) (c-= (c-exact obj) obj)))
(error '|(rational?) wrong number of arguments --| args)))
(define (read-bytevector . args)
(define len (c-length args))
(if (and (c-< 0 len) (c-< len 3))
(begin
(define k (c-car args))
(define port (if (c-= len 2)
(c-cadr args)
(c-current-input-port)))
(if (and (c-integer? k) (c-exact? k) (c-< -1 k)
(c-input-port? port))
(c-read-bytevector k port)
(error '|(read-bytevector) wrong type of argument --| args)))
(error '|(read-bytevector) wrong number of arguments --| args)))
(define (read-char . args)
(define len (c-length args))
(if (c-< len 2)
(begin
(define port (if (c-= len 1)
(c-car args)
(c-current-input-port)))
(if (and (c-input-port? port) (c-input-port-open? port) (c-textual-port? port))
(c-read-char port)
(error '|(read-char) wrong type of argument --| args)))
(error '|(read-char) wrong number of arguments --| args)))
(define (read-u8 . args)
(define len (c-list? args))
(if (c-< len 2)
(begin
(define port (if (c-= len 0)
(c-current-input-port)
(c-car args)))
(if (and (c-input-port? port)
(c-binary-port? port)
(c-input-port-open? port))
(c-read-u8 port)
(error '|(read-u8) wrong type of argument --| args)))
(error '|(read-u8) wrong number of arguments --| args)))
(define (real? . args)
(if (c-= (c-length args) 1)
(c-real? (c-car args))
(error '|(real?) wrong number of arguments --| args)))
(define (reverse . args)
(if (c-= (c-length args) 1)
(if (c-list? (c-car args))
(c-reverse (c-car args))
(error '|(reverse) wrong type of argument --| args))
(error '|(reverse) wrong number of arguments --| args)))
(define (round . args)
(if (c-= (c-length args) 1)
(if (c-real? (c-car args))
(c-round (c-car args))
(error '|(round) wrong type of argument --| args))
(error '|(round) wrong number of arguments --| args)))
(define (set-car! . args)
(if (c-= (c-length args) 2)
(begin
(define pair (c-car args))
(if (c-pair? pair)
(c-set-car! pair (c-cadr args))
(error '|(set-car!) wrong type of argument --| args)))
(error '|(set-car!) wrong number of arguments --| args)))
(define (set-cdr! . args)
(if (c-= (c-length args) 2)
(begin
(define pair (c-car args))
(if (c-pair? pair)
(c-set-cdr! pair (c-cadr args))
(error '|(set-cdr!) wrong type of argument --| args)))
(error '|(set-cdr!) wrong number of arguments --| args)))
(define (square . args)
(if (c-= (c-length args) 1)
(if (c-number? (c-car args))
(c-square (c-car args))
(error '|(square) wrong type of argument --| args))
(error '|(square) wrong number of arguments --| args)))
(define (string->list . args)
(define len (c-length args))
(if (and (c-< 0 len) (c-< len 4))
(begin
(define string (c-car args))
(define start (if (c-< 1 len) (c-cadr args) 0))
(if (c-string? string)
(begin
(define str-len (c-string-length string))
(define end (if (c-= len 3) (c-caddr args) str-len))
(if (and (c-integer? start) (c-exact? start)
(c-integer? end) (c-exact? end))
(if (and (c-< -1 start) (c-< start end)
(c-< end (c-+ str-len 1)))
(c-string->list string start end)
(error '|(string->list) out of range --| args))
(error '|(string->list) wrong type of argument --| args)))
(error '|(string->list) wrong type of argument --| args)))
(error '|(string->list) wrong number of arguments --| args)))
(define (string->number . args)
(define len (c-length args))
(if (and (c-< 0 len) (c-< len 3))
(begin
(define string (c-car args))
(define radix (if (c-= len 1)
10
(c-cadr args)))
(if (and (c-string? string)
(or (c-= radix 2)
(c-= radix 8)
(c-= radix 10)
(c-= radix 16)))
(c-string->number string radix)
(error '|(string->number) wrong type of argument --| args)))
(error '|(string->number) wrong number of arguments --| args)))
(define (string->symbol . args)
(if (c-= (c-length args) 1)
(if (c-string? (c-car args))
(c-string->symbol (c-car args))
(error '|(string->symbol) wrong type of argument --| args))
(error '|(string->symbol) wrong number of arguments --| args)))
(define (string->utf8 . args)
(define len (c-length args))
(if (and (c-< 0 len) (c-< len 4))
(begin
(define string (c-car args))
(define start (if (c-< 1 len)
(c-cadr args)
0))
(if (c-string? string)
(begin
(define str-len (c-string-length string))
(define end (if (c-< 2 len)
(c-caddr args)
str-len))
(if (and (c-integer? start) (c-exact? start)
(c-integer? end) (c-exact? end))
(if (and (c-< -1 start) (c-< start end)
(c-< end (c-+ str-len 1)))
(c-string->utf8 string start end)
(error '|(string->utf8) out of range --| args))
(error '|(string->utf8) wrong type of argument --| args)))
(error '|(string->utf8) wrong type of argument --| args)))
(error '|(string->utf8) wrong number of arguments --| args)))
(define (string-length . args)
(if (c-= (c-length args) 1)
(if (c-string? (c-car args))
(c-string-length (c-car args))
(error '|(string-length) wrong type of argument --| args))
(error '|(string-length) wrong number of arguments --| args)))
(define (string-ref . args)
(if (c-= (c-length args) 2)
(begin
(define string (c-car args))
(define k (c-cadr args))
(if (and (c-string? string)
(c-integer? k) (c-exact? k) (c-< -1 k))
(if (c-< k (c-string-length string))
(c-string-ref string k)
(error '|(string-ref) out of range --| args))
(error '|(string-ref) wrong type of argument --| args)))
(error '|(string-ref) wrong number of arguments --| args)))
(define (string-set! . args)
(if (c-= (c-length args) 3)
(begin
(define string (c-car args))
(define k (c-cadr args))
(define char (c-caddr args))
(if (and (c-string? string)
(c-integer? k) (c-exact? k) (c-< 0 k))
(if (c-< k (c-string-length string))
(c-string-set! string k char)
(error '|(string-set!) out of range --| args))
(error '|(string-set!) wrong type of argument --| args)))
(error '|(string-set!) wrong number of arguments --| args)))
(define (string<=? . args)
(if (c-< 1 (c-length args))
(begin
(define (iter string string-of-list)
(if (c-null? string-of-list)
#t
(if (c-string? (c-car string-of-list))
(if (c-string<=? string (c-car string-of-list))
(iter (c-car string-of-list) (c-cdr string-of-list))
#f)
(error '|(string<=?) wrong type of argument --| args))))
(if (c-string? (c-car args))
(iter (c-car args) (c-cdr args))
(error '|(string<=?) wrong type of argument --| args)))
(error '|(string<=?) wrong number of arguments --| args)))
(define (string<? . args)
(if (c-< 1 (c-length args))
(begin
(define (iter string string-of-list)
(if (c-null? string-of-list)
#t
(if (c-string? (c-car string-of-list))
(if (c-string<? string (c-car string-of-list))
(iter (c-car string-of-list) (c-cdr string-of-list))
#f)
(error '|(string<?) wrong type of argument --| args))))
(if (c-string? (c-car args))
(iter (c-car args) (c-cdr args))
(error '|(string<?) wrong type of argument --| args)))
(error '|(string<?) wrong number of arguments --| args)))
(define (string=? . args)
(if (c-< 1 (c-length args))
(begin
(define (iter string string-of-list)
(if (c-null? string-of-list)
#t
(if (c-string? (c-car string-of-list))
(if (c-string=? string (c-car string-of-list))
(iter (c-car string-of-list) (c-cdr string-of-list))
#f)
(error '|(string=?) wrong type of argument --| args))))
(if (c-string? (c-car args))
(iter (c-car args) (c-cdr args))
(error '|(string=?) wrong type of argument --| args)))
(error '|(string=?) wrong number of arguments --| args)))
(define (string>=? . args)
(if (c-< 1 (c-length args))
(begin
(define (iter string string-of-list)
(if (c-null? string-of-list)
#t
(if (c-string? (c-car string-of-list))
(if (c-string>=? string (c-car string-of-list))
(iter (c-car string-of-list) (c-cdr string-of-list))
#f)
(error '|(string>=?) wrong type of argument --| args))))
(if (c-string? (c-car args))
(iter (c-car args) (c-cdr args))
(error '|(string>=?) wrong type of argument --| args)))
(error '|(string>=?) wrong number of arguments --| args)))
(define (string>? . args)
(if (c-< 1 (c-length args))
(begin
(define (iter string string-of-list)
(if (c-null? string-of-list)
#t
(if (c-string? (c-car string-of-list))
(if (c-string>? string (c-car string-of-list))
(iter (c-car string-of-list) (c-cdr string-of-list))
#f)
(error '|(string>?) wrong type of argument --| args))))
(if (c-string? (c-car args))
(iter (c-car args) (c-cdr args))
(error '|(string>?) wrong type of argument --| args)))
(error '|(string>?) wrong number of arguments --| args)))
(define (string? . args)
(if (c-= (c-length args) 1)
(c-string? (c-car args))
(error '|(string-length) wrong number of arguments --| args)))
(define (symbol->string . args)
(if (c-= (c-length args) 1)
(if (c-symbol? (c-car args))
(c-symbol->string (c-car args))
(error '|(symbol->string) wrong type of argument --| args))
(error '|(symbol->string) wrong number of arguments --| args)))
(define (symbol=? . args)
(if (c-< 1 (c-length args))
(begin
(define (iter symbol symbol-of-list)
(if (c-null? symbol-of-list)
#t
(if (c-symbol? (c-car symbol-of-list))
(if (c-symbol=? symbol (c-car symbol-of-list))
(iter (c-car symbol-of-list) (c-cdr symbol-of-list))
#f)
(error '|(symbol=?) wrong type of argument --| args))))
(if (c-symbol? (c-car args))
(iter (c-car args) (c-cdr args))
(error '|(symbol=?) wrong type of argument --| args)))
(error '|(symbol=?) wrong number of arguments --| args)))
(define (textual-port? . args)
(if (c-= (c-length args) 1)
(c-textual-port? (c-car args))
(error '|(textual-port?) wrong number of arguments --| args)))
(define (truncate . args)
(if (c-= (c-length args) 1)
(if (c-real? (c-car args))
(c-truncate (c-car args))
(error '|(truncate) wrong type of argument --| args))
(error '|(truncate) wrong number of arguments --| args)))
(define (utf8->string . args)
(define len (c-length args))
(if (and (c-< 0 len) (c-< len 4))
(begin
(define bytevector (c-car args))
(define start (if (c-< 1 len)
(c-cadr args)
0))
(if (c-bytevector? bytevector)
(begin
(define bv-len (c-bytevector-length bytevector))
(define end (if (c-= len 3)
(c-caddr args)
bv-len))
(if (and (c-integer? start) (c-exact? start) (c-< -1 start)
(c-integer? end) (c-exact? end) (c-< end (c-+ bv-len 1))
(c-< start end))
(c-utf8->string bytevector start end)
(error '|(utf8->string) wrong type of argument --| args)))
(error '|(utf8->string) wrong type of argument --| args)))
(error '|(utf8->string) wrong number of arguments --| args)))
(define (vector? . args)
(if (c-= (c-length args) 1)
(c-vector? (c-car args))
(error '|(vector?) wrong number of arguments --| args)))
(define (write-bytevector . args)
(define len (c-length args))
(if (and (c-< 0 len) (c-< len 5))
(begin
(define bytevector (c-car args))
(define port (if (c-< 1 len)
(c-cadr args)
(current-output-port)))
(define start (if (c-< 2 len)
(c-caddr args)
0))
(if (and (c-bytevector? bytevector)
(c-binary-port? port)
(c-output-port-open? port))
(begin
(define bv-len (c-bytevector-length bytevector))
(define end (if (c-= len 4)
(c-cadddr args)
bv-len))
(if (and (c-integer? start) (c-exact? start) (c-< -1 start)
(c-integer? end) (c-exact? end) (c-< end (c-+ bv-len 1))
(c-< start end))
(c-write-bytevector bytevector port start end)
(error '|(write-bytevector) wrong type of argument --| args)))
(error '|(write-bytevector) wrong type of argument --| args)))
(error '|(write-bytevector) wrong number of arguments --| args)))
(define (write-char . args)
(define len (c-length args))
(if (and (c-< 0 len) (c-< 3))
(begin
(define char (c-car args))
(define port (if (c-= len 2)
(c-cadr args)
(current-output-port)))
(if (and (c-char? char)
(c-textual-port? port)
(c-output-port-open? port))
(c-write-char char port)
(error '|(write-char) wrong type of argument --| args)))
(error '|(write-char) wrong number of arguments --| args)))
(define (write-string . args)
(define len (c-length args))
(if (and (c-< 0 len) (c-< len 5))
(begin
(define string (c-car args))
(define port (if (c-< 1 len)
(c-cadr args)
(current-output-port)))
(define start (if (c-< 2 len)
(c-caddr args)
0))
(if (and (c-string? string)
(c-textual-port? port)
(c-output-port-open? port))
(begin
(define str-len (c-string-length string))
(define end (if (c-= len 4)
(c-cadddr args)
str-len))
(if (and (c-integer? start) (c-exact? start) (c-< -1 start)
(c-integer? end) (c-exact? end) (c-< end (c-+ str-len 1))
(c-< start end))
(c-write-string string port start end)
(error '|(write-string) wrong type of argument --| args)))
(error '|(write-string) wrong type of argument --| arg)))
(error '|(write-string) wrong number of arguments --| args)))
(define (write-u8 . args)
(define len (c-length args))
(if (and (c-< 0 len) (c-< 3))
(begin
(define byte (c-car args))
(define port (if (c-= len 2)
(c-cadr args)
(current-output-port)))
(if (and (c-integer? byte) (c-exact? byte)
(c-< -1 byte) (c-< byte 256)
(c-binary-port? port)
(c-output-port-open? port))
(c-write-u8 byte port)
(error '|(write-u8) wrong type of argument --| args)))
(error '|(write-u8) wrong number of arguments --| args)))
)
compound_procedures.scm
(begin
(define (assoc obj alist . args)
(define cmp (if (null? args)
(car args)
equal?))
(define (iter alist)
(if (null? alist)
#f
(if (cmp (car (car alist)) obj)
(car alist)
(iter (cdr alist)))))
(iter alist))
(define (assq obj alist) (assoc obj alist eq?))
(define (assv obj alist) (assoc obj alist eqv?))
(define (bytevector-copy! to at from . args)
(define len (length args))
(define start (if (= len 0) 0 (car args)))
(define end (if (= len 2) (cadr args) (bytevector-length from)))
(define (iter i j)
(if (< j end)
(begin
(bytevector-u8-set! to i (bytevector-u8-ref from j))
(iter (+ i 1) (+ j 1)))))
(iter at start))
(define (caar pair) (car (car pair)))
(define (cadr pair) (car (cdr pair)))
(define (cdar pair) (cdr (car pair)))
(define (cddr pair) (cdr (cdr pair)))
(define (equal? obj-1 obj-2)
(if (and (pair? obj-1) (pair? obj-2))
(and (equal? (car obj-1) (car obj-2)) (equal? (cdr obj-1) (cdr obj-2)))
(if (and (vector? obj-1) (vector? obj-2))
(equal? (vector->list obj-1) (vector->list obj-2))
(if (and (string? obj-1) (string? obj-2))
(equal? (string->list obj-1) (string->list obj-2))
(if (and (bytevector? obj-1) (bytevector? obj-2))
(equal? (utf8->string obj-1) (utf8->string obj-2))
(eqv? obj-1 obj-2))))))
(define (exact-integer? z)
(and (number? z) (exact? z) (integer? z)))
(define (floor-quotient n1 n2) (floor (/ n1 n2)))
(define (floor-remainder n1 n2) (- n1 (* (floor-quotient n1 n2) n2)))
(define (for-each proc list . list-of-list)
(define (iter-1 list-of-list)
(if (not (null? list-of-list))
(begin
(apply proc (car list-of-list))
(iter-1 (cdr list-of-list)))))
(define (cxrs cxr list-of-list)
(if (null? list-of-list)
'()
(cons (cxr (car list-of-list))
(cxrs cxr (cdr list-of-list)))))
(define (list->list list-of-list)
(if (memq '() list-of-list)
'()
(cons (cxrs car list-of-list)
(list->list (cxrs cdr list-of-list)))))
(iter-1 (list->list (cons list list-of-list))))
(define (inexact? z) (not (exact? z)))
(define (list-copy obj)
(if (pair? obj)
(begin
(define (iter pair)
(if (pair? pair)
(cons (car pair)
(iter (cdr pair)))
pair))
(iter obj))
obj))
(define (list-ref list k)
(define (iter list i)
(if (= i k)
(car list)
(iter (cdr list) (+ i 1))))
(iter list 0))
(define (list-set! list k obj)
(define (iter list i)
(if (= i k)
(set-car! list obj)
(iter (cdr list) (+ i 1))))
(iter list 0))
(define (list-tail list k)
(if (= k 0)
list
(list-tail (cdr list) (- k 1))))
(define (map proc list . list-of-list)
(define (iter-1 list-of-list)
(if (null? list-of-list)
'()
(cons (apply proc (car list-of-list))
(iter-1 (cdr list-of-list)))))
(define (cxrs cxr list-of-list)
(if (null? list-of-list)
'()
(cons (cxr (car list-of-list))
(cxrs cxr (cdr list-of-list)))))
(define (list->list list-of-list)
(if (memq '() list-of-list)
'()
(cons (cxrs car list-of-list)
(list->list (cxrs cdr list-of-list)))))
(iter-1 (list->list (cons list list-of-list))))
(define (max x . xs)
(define (iter x xs)
(if (null? xs)
x
(if (< x (car xs))
(iter (car xs) (cdr xs))
(iter x (cdr xs)))))
(iter x xs))
(define (member obj list compare)
(if (null? list)
#f
(if (compare obj (car list))
list
(member obj (cdr list) compare))))
(define (memq obj list) (member obj list eq?))
(define (memv obj list) (member obj list memv))
(define (min x . xs)
(define (iter x xs)
(if (null? xs)
x
(if (< x (car xs))
(iter x (cdr xs))
(iter (car xs) (cdr xs)))))
(iter x xs))
(define (not obj) (if obj #f #t))
(define (number->string z . args)
(define radix (if (null? args)
10
(car args)))
(define (digits->char n)
(if (< n 10)
(integer->char (+ n (char->integer #\0)))
(integer->char (+ (- n 10) (char->integer #\a)))))
(define (iter z i result)
(if (= z 0)
(list->string result)
(iter (- z (remainder z (expt radix (+ i 1))))
(+ i 1)
(cons (digits->char (/ (remainder z (expt radix (+ i 1))) (expt radix i)))
result))))
(iter (- z (remainder z radix))
1
(list (digits->char (+ (remainder z radix))))))
(define (rationalize x y)
(define diff (abs y))
(define low (- x diff))
(define high (+ x diff))
(define proc (if (and (exact? x) (exact? y)) exact inexact))
(if (<= (* low high) 0)
(proc 0)
(if (= low high)
(proc low)
(begin
(define sign (if (positive? x) 1 -1))
(define low0 (if (positive? sign) low (abs high)))
(define high0 (if (positive? sign) high (abs low)))
(define (between? x) (and (<= low0 x) (<= x high0)))
(define (stern-brocot-tree pnum pden qnum qden)
(define a (/ (+ pnum qnum)
(+ pden qden)))
(if (between? a)
a
((lambda ()
(define num (numerator a))
(define den (denominator a))
(if (< high0 a)
(stern-brocot-tree pnum pden
num den)
(stern-brocot-tree num den
qnum qden))))))
(proc (* sign (stern-brocot-tree 0 1 1 0)))))))
(define (read-line . args)
(define port (if (null? args)
(current-input-port)
(car args)))
(define (iter result)
(define char (read-char port))
(if (eof-object? char)
(eof-object)
(if (or (eq? char #\newline)
(eq? char #\return))
(list->string (reverse result))
(iter (cons char result)))))
(iter '()))
(define (read-string k . args)
(define port (if (null? args)
(current-input-port)
(car args)))
(if (= k 0)
""
(begin
(define char (read-char port))
(if (eof-object? char)
(eof-object)
(begin
(define (iter i result)
(if (= i k)
(list->string (reverse result))
(begin
(define char (read-char port))
(if (eof-object? char)
(list->string (reverse result))
(iter (+ i 1) (cons char result))))))
(iter 1 (cons char '())))))))
(define (string . list-of-char) (list->string list-of-char))
(define (string-append . list-of-string)
(list->string (apply append (map string->list list-of-string))))
(define (string-copy string . args)
(define len (length args))
(define start (if (< 0 len)
(car args)
0))
(define end (if (= len 2)
(cadr args)
(string-length string)))
(define (iter list-of-char i result)
(if (= end i)
(list->string (reverse result))
(if (<= start i)
(iter (cdr list-of-char)
(+ i 1)
(cons (car list-of-char)
result))
(iter (cdr list-of-char)
(+ i 1)
result))))
(iter (string->list string) 0 '()))
(define (string-copy! to at from . args)
(define len (length args))
(define start (if (< 0 len)
(car args)
0))
(define end (if (= len 2)
(cadr args)
(string-length from)))
(define (iter i j)
(if (< i end)
(begin
(string-set! to j (string-ref from i))
(iter (+ i 1) (+ j 1)))))
(iter start at))
(define (string-fill! string fill . args)
(define len (length args))
(define start (if (< 0 len)
(car args)
0))
(define end (if (= len 2)
(cadr args)
(string-length string)))
(define (iter i)
(if (< i end)
(begin
(string-set! string i fill)
(iter (+ i 1)))))
(iter start))
(define (string-for-each proc string . list-of-string)
(define (iter-1 list-of-list)
(if (not (null? list-of-list))
(begin
(apply proc (car list-of-list))
(iter-1 (cdr list-of-list)))))
(define (cxrs cxr list-of-list)
(if (null? list-of-list)
'()
(cons (cxr (car list-of-list))
(cxrs cxr (cdr list-of-list)))))
(define (list->list list-of-list)
(if (memq '() list-of-list)
'()
(cons (cxrs car list-of-list)
(list->list (cxrs cdr list-of-list)))))
(iter-1 (list->list (map string->list (cons string list-of-string)))))
(define (string-map proc string . list-of-string)
(define (iter-1 list-of-list)
(if (null? list-of-list)
'()
(cons (apply proc (car list-of-list))
(iter-1 (cdr list-of-list)))))
(define (cxrs cxr list-of-list)
(if (null? list-of-list)
'()
(cons (cxr (car list-of-list))
(cxrs cxr (cdr list-of-list)))))
(define (list->list list-of-list)
(if (memq '() list-of-list)
'()
(cons (cxrs car list-of-list)
(list->list (cxrs cdr list-of-list)))))
(list->string (iter-1 (list->list (map string->list (cons string list-of-string))))))
(define (truncate-quotient n1 n2) (truncate (/ n1 n2)))
(define (truncate-remainder n1 n2) (- n1 (* (truncate-quotient n1 n2) n2)))
(define (zero? z) (= z 0))
)
0 コメント:
コメントを投稿