Scheme - C - kscm(ksi) - 手続き - 標準ライブラリ(char ライブラリ)の実装

開発環境

• macOS Sierra - Apple (OS)
• Emacs (Text Editor)
• C, Scheme (プログラミング言語)
• Clang/LLVM (コンパイラ, Xcode - Apple)
• 参考書籍等
  • 計算機プログラムの構造と解釈 第2版 (原著)
  • Head First C (原著)
  • 21st Century C
  • Cリファレンスマニュアル (原著)

Cを高級アセンブラーとした、Scheme の コンパイラー(ksc)、インタプリター(ksi)の作成で、標準ライブラリの char ライブラリの手続きのを実装。

今後、標準ライブラリの手続きはとりあえず合成手続きで実装して(compound_procedures.scm)、その後、速度向上の為に基本手続き(primitive_procedures.scm とC言語側)として実装していくことに。(ということで、現段階ではどの手続きも(凄く)遅い。)

コード

kscm

ksi.scm

(begin
  ;; 
  (define (primitive-procedure? proc) (tagged-list? proc 'primitive))
  (define (primitive-implementation proc) (cdr proc))
  (load "./lib/stdlib/base/primitive_procedures.scm")
  (load "./lib/stdlib/char/primitive_procedures.scm")
  (define primitive-procedures
    (list ;; char
          (c-cons 'char-alphabetic? char-alphabetic?)
          (c-cons 'char-ci<=? char-ci<=?)
          (c-cons 'char-ci<? char-ci<?)
          (c-cons 'char-ci=? char-ci=?)
          (c-cons 'char-ci>=? char-ci>=?)
          (c-cons 'char-ci>? char-ci>?)
          (c-cons 'char-downcase char-downcase)
          (c-cons 'char-foldcase char-foldcase)
          (c-cons 'char-lower-case? char-lower-case?)
          (c-cons 'char-numeric? char-numeric?)
          (c-cons 'char-upcase char-upcase)
          (c-cons 'char-upper-case? char-upper-case?)
          (c-cons 'char-whitespace? char-whitespace?)
          (c-cons 'digit-value digit-value)
          ))
  (define (map proc list)
    (if (c-null? list)
        '()
        (c-cons (proc (car list))
                (map proc (cdr list)))))
  (define (primitive-procedure-names) (map car primitive-procedures))
  (define (primitive-procedure-objects)
    (map (lambda (proc)
           (cons '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 (c-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 '(begin
           (load "./lib/stdlib/base/compound_procedures.scm")
           (load "./lib/stdlib/char/compound_procedures.scm"))
        the-global-environment)
           
  (driver-loop)
  )

lib/stdlib/char/primitive_procedures.scm

(begin
  (define (char-alphabetic? . args)
    (if (c-= (c-length args) 1)
        (if (c-char? (c-car args))
            (c-char-alphabetic? (c-car args))
            (error '|(char-alphabetic?) wrong type of argument --| args))
        (error '|(char-alphabetic?) wrong number of arguments --| args)))

  (define (char-ci<=? . 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-ci<=? char (c-car chars))
                        (iter (c-car chars) (c-cdr chars))
                        #f)
                    (error '|(char-ci<=?) wrong type of argument --| args))))
          (if (c-char? (c-car args))
              (iter (c-car args) (c-cdr args))
              (error '|(char-ci<=?) wrong type of argument --| args)))
        (error '|(char-ci<=?) wrong number of arguments --| args)))
  (define (char-ci<? . 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-ci<? char (c-car chars))
                        (iter (c-car chars) (c-cdr chars))
                        #f)
                    (error '|(char-ci<?) wrong type of argument --| args))))
          (if (c-char? (c-car args))
              (iter (c-car args) (c-cdr args))
              (error '|(char-ci<?) wrong type of argument --| args)))
        (error '|(char-ci<?) wrong number of arguments --| args)))
  (define (char-ci=? . 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-ci=? char (c-car chars))
                        (iter (c-car chars) (c-cdr chars))
                        #f)
                    (error '|(char-ci=?) wrong type of argument --| args))))
          (if (c-char? (c-car args))
              (iter (c-car args) (c-cdr args))
              (error '|(char-ci=?) wrong type of argument --| args)))
        (error '|(char-ci=?) wrong number of arguments --| args)))
  (define (char-ci>=? . 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-ci>=? char (c-car chars))
                        (iter (c-car chars) (c-cdr chars))
                        #f)
                    (error '|(char-ci>=?) wrong type of argument --| args))))
          (if (c-char? (c-car args))
              (iter (c-car args) (c-cdr args))
              (error '|(char-ci>=?) wrong type of argument --| args)))
        (error '|(char-ci>=?) wrong number of arguments --| args)))
  (define (char-ci>? . 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-ci>? char (c-car chars))
                        (iter (c-car chars) (c-cdr chars))
                        #f)
                    (error '|(char-ci>?) wrong type of argument --| args))))
          (if (c-char? (c-car args))
              (iter (c-car args) (c-cdr args))
              (error '|(char-ci>?) wrong type of argument --| args)))
        (error '|(char-ci>?) wrong number of arguments --| args)))

  (define (char-downcase . args)
    (if (c-= (c-length args) 1)
        (if (c-char? (c-car args))
            (c-char-downcase (c-car args))
            (error '|(char-downcase) wrong type of argument --| args))
        (error '|(char-downcase) wrong number of arguments --| args)))
  
  (define (char-foldcase . args)
    (if (c-= (c-length args) 1)
        (if (c-char? (c-car args))
            (c-char-foldcase (c-car args))
            (error '|(char-foldcase) wrong type of argument --| args))
        (error '|(char-foldcase) wrong number of arguments --| args)))

  (define (char-lower-case? . args)
    (if (c-= (c-length args) 1)
        (if (c-char? (c-car args))
            (c-char-lower-case? (c-car args))
            (error '|(char-lower-case?) wrong type of argument --| args))
        (error '|(char-lower-case?) wrong number of arguments --| args)))

  (define (char-numeric? . args)
    (if (c-= (c-length args) 1)
        (if (c-char? (c-car args))
            (c-char-numeric? (c-car args))
            (error '|(char-numeric?) wrong type of argument --| args))
        (error '|(char-numeric?) wrong number of arguments --| args)))

  (define (char-upcase . args)
    (if (c-= (c-length args) 1)
        (if (c-char? (c-car args))
            (c-char-upcase (c-car args))
            (error '|(char-upcase) wrong type of argument --| args))
        (error '|(char-upcase) wrong number of arguments --| args)))

  (define (char-upper-case? . args)
    (if (c-= (c-length args) 1)
        (if (c-char? (c-car args))
            (c-char-upper-case? (c-car args))
            (error '|(char-upper-case?) wrong type of argument --| args))
        (error '|(char-upper-case?) wrong number of arguments --| args)))

  (define (char-whitespace? . args)
    (if (c-= (c-length args) 1)
        (if (c-char? (c-car args))
            (c-char-whitespace? (c-car args))
            (error '|(char-whitespace?) wrong type of argument --| args))
        (error '|(char-whitespace?) wrong number of arguments --| args)))
  
  (define (digit-value . args)
    (if (c-= (c-length args) 1)
        (if (c-char? (c-car args))
            (c-digit-value (c-car args))
            (error '|(digit-value) wrong type of argument --| args))
        (error '|(digit-value) wrong number of arguments --| args)))

  )

lib/stdlib/char/compound_procedures.scm

(begin
  (define (string-ci<=? string . list-of-string)
    (define (iter string list-of-string)
      (if (null? list-of-string)
          #t
          (if (string<=? (string-foldcase string)
                         (string-foldcase (car list-of-string)))
              (iter (car list-of-string) (cdr list-of-string))
              #f)))
    (iter string list-of-string))

  (define (string-ci<? string . list-of-string)
    (define (iter string list-of-string)
      (if (null? list-of-string)
          #t
          (if (string<? (string-foldcase string)
                         (string-foldcase (car list-of-string)))
              (iter (car list-of-string) (cdr list-of-string))
              #f)))
    (iter string list-of-string))

  (define (string-ci=? string . list-of-string)
    (define (iter string list-of-string)
      (if (null? list-of-string)
          #t
          (if (string=? (string-foldcase string)
                         (string-foldcase (car list-of-string)))
              (iter (car list-of-string) (cdr list-of-string))
              #f)))
    (iter string list-of-string))

  (define (string-ci>=? string . list-of-string)
    (define (iter string list-of-string)
      (if (null? list-of-string)
          #t
          (if (string>=? (string-foldcase string)
                         (string-foldcase (car list-of-string)))
              (iter (car list-of-string) (cdr list-of-string))
              #f)))
    (iter string list-of-string))

  (define (string-ci>? string . list-of-string)
    (define (iter string list-of-string)
      (if (null? list-of-string)
          #t
          (if (string>? (string-foldcase string)
                         (string-foldcase (car list-of-string)))
              (iter (car list-of-string) (cdr list-of-string))
              #f)))
    (iter string list-of-string))

  (define (string-downcase string) (string-map char-downcase string))
  (define (string-foldcase string) (string-map char-foldcase string))
  (define (string-upcase string) (string-map char-upcase string))
  )