2017年1月16日月曜日

開発環境

Cを高級アセンブラーとした、Scheme の コンパイラー(ksc)、インタプリター(ksi)の作成で、標準ライブラリの base ライブラリの手続きを実装。(vector 関連と入出力関連、その他構文は除く。)

入出力関連の手続きのいくつかは、REPL での挙動とか細かい違いがあるみたいだから、よく理解してから実装することに。

vector については、まだどう実装するか検討中で決めていないから、関連する手続きも未実装。読み込み時にvectorの長さを取得して、その長さ分のヒープのメモリ領域をmallocで確保、長さと要素の対という感じで(bytevector と同様な感じ。読み込み時はリストとして読み込みそれをベクターに変換する。)実装することを検討中。まだ未実装なのは、バイトベクタと違って、ガベージコレクションの修正も必要になるから、慎重に、ということで。

コード

kscm

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 コメント:

コメントを投稿

Comments on Google+: