2017年1月9日月曜日

開発環境

Cを高級アセンブラーとした、Scheme の コンパイラー(ksc)、インタプリター(ksi)の作成での、手続きの引数の型、長さのエラー検出の方針を決める。

kscm

なんとなく漠然と書いたコードを、少しずつ綺麗にしたり、とりあえず必要な手続きを追加していく中で、手続きの引数の型、長さのエラーの検出方法を決める。

  • C言語側で書く手続きでは引数の型のチェック、長さのチェックは行わない。
  • Scheme のproc-name という手続きをC言語側書く場合、c-proc-name という名前にする。
  • Scheme 側でc-proc-name という手続きを使って、引数の型のチェック、長さのチェックを行う手続き proc-name を記述する。
  • ksc(コンパイラ)では C言語側で書いた error 手続きを使う。エラーが発生したら終了させる。(C言語のexit関数)
  • ksi(インタプリンタ)では、Scheme 側で error 手続きを上書きして、エラーが発生しても終了させるのではなく、エラーオブジェクトを伝搬させて、エラーを印字、再び read-eval-print-loop の read に戻るようにする。

とりあえずはこの方針で、必要な手続き(C言語側、Scheme 側)を少しずつ追加していくことに。

コード

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? (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 (cons . args)
    (if (c-= (c-length args) 2)
        (c-cons (c-car args) (c-cadr args))
        (error "(cons) wrong number of arguments --" args)))

  (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-list? args) 1)
        (if (c-list? (c-car args))
            (c-list? (c-car args))
            (error '|(list?) wrong type of argument --| args))
        (error "(list?) 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)))


  )

0 コメント:

コメントを投稿

Comments on Google+: