2016年12月27日火曜日

開発環境

Cを高級アセンブラーとした、Scheme の コンパイラー(ksc)、インタプリター(ksi)を作成。インタプリターで正確な整数の読み込み、手続き(cons 、car 、cdr)といくつかの構文を使えるところまで。

kscm

コード

ksc.scm

(begin
  (define (newline port)
    (display #\newline port))
  (define (print-elements list port)
    (if (not (null? list))
        (begin
          (display (car list) port)
          (print-elements (cdr list) port))))
  (define (print-code code port)
    (display '|/** \x5c;file */| port)    
    (newline port)
    (display '|#include <kscm.h>| port)
    (newline port)
    (display
     '|int main (int argc,char *argv[]){init();get_command_line(argc, argv);| port)
    (print-elements (c-caddr code) port)
    (display '|printf("=> ");object_write_stdout(val);puts("");}| port))
  (define undef (if #f 0))
  (define (pair->c obj)
    (c-append '(|(|)
              (obj->c (car obj))
              '(| . |)
              (obj->c (cdr obj))
              '(|)|)))
  (define (obj->c obj)
    (if (number? obj)
        (list obj)
        (if (string? obj)
            (c-string->c obj)
            (if (symbol? obj)
                (c-symbol->c obj)
                (if (pair? obj)
                    (pair->c obj)
                    (if (null? obj)
                        '(|()|)
                        (if (boolean? obj)
                            (list obj)
                            (if (char? obj)
                                (c-char->c obj)))))))))
  (define (const obj)
    (if (eq? obj undef)
        '(undef)
        (if (eof-object? obj)
            '(eof_obj)
            (c-append '(|c_str_to_datum("|)
                      (obj->c obj)
                      '(|")|)))))
  (define (definition-value exp)
    (if (symbol? (c-cadr exp))
        (c-caddr exp)
        (c-make-lambda (c-cdadr exp)
                       (c-cddr exp))))
  (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->if exp)
    (if (null? exp)
        '#f
        (list 'if (car exp) (car exp) (cons 'or (cdr exp)))))
  (define log-port (open-output-file "compiler.log"))
  (define (compile exp target linkage)
    (display exp log-port)
    (newline log-port)
    (if (c-self-evaluating? exp)
        (compile-self-evaluating exp target linkage)
        (if (symbol? exp)
            (compile-variable exp target linkage)
            (if (pair? exp)
                ((lambda (o)
                   (if (symbol? o)
                       (if (eq? o 'quote)
                           (compile-quoted exp target linkage)
                           (if (eq? o 'lambda)
                               (compile-lambda exp target linkage)
                               (if (eq? o 'set!)
                                   (compile-assignment exp
                                                       target linkage)
                                   (if (eq? o 'define)
                                       (compile-definition exp
                                                           target linkage)
                                       (if (eq? o 'if)
                                           (compile-if exp
                                                       target linkage)
                                           (if (eq? o 'begin)
                                               (compile-sequence
                                                (cdr exp)
                                                target
                                                linkage)
                                               (if (eq? o 'and)
                                                   (compile
                                                    (and->if (cdr exp))
                                                    target
                                                    linkage)
                                                   (if (eq? o 'or)
                                                       (compile
                                                        (or->if (cdr exp))
                                                        target
                                                        linkage)
                                                       (compile-application
                                                        exp target linkage
                                                        )))))))))
                       (compile-application exp target linkage)))
                 (car exp))
                (error '|unknown expression type -- compile| exp)))))
  (define (compile-linkage linkage)
    (if (eq? linkage 'return)
        (c-make-instruction-sequence '(cont) '()
                                     '(|goto *cont.cont;|))
        (if (eq? linkage 'next)
            (c-empty-instruction-sequence)
            (c-make-instruction-sequence
             '() '()
             (list '|goto | linkage '|;|)))))
  (define (end-with-linkage linkage instruction-sequence)
    (preserving '(cont)
                instruction-sequence
                (compile-linkage linkage)))
  (define (compile-self-evaluating exp target linkage)
    (end-with-linkage
     linkage
     (c-make-instruction-sequence
      '() (list target)
      (c-append (list '|object_free(&| target '|);|
                      target '| = |)
                (const exp)
                '(|;|)))))
  (define (compile-variable exp target linkage)
    (end-with-linkage
     linkage
     (c-make-instruction-sequence
      '(env) (list target)
      (c-append (list '|object_free(&| target '|);|
                      target '| = lookup_var_val(c_str_to_datum("|)
                (c-symbol->c exp)
                '(|"));|)))))
  (define (compile-quoted exp target linkage)
    (end-with-linkage
     linkage
     (c-make-instruction-sequence
      '() (list target)
      (c-append (list '|object_free(&| target '|);|
                      target '| = |)
                (const (c-cadr exp))
                '(|;|)))))
  (define (compile-assignment exp target linkage)
    ((lambda (var get-value-code)
       (end-with-linkage
        linkage
        (preserving '(env)
                    get-value-code
                    (c-make-instruction-sequence
                     '(env val) (list target)
                     (c-append '(|{Object t = set_var_val(c_str_to_datum("|)
                               (c-symbol->c var)
                               (list '|"));
                                   object_free(&| target '|);|
                                   target '| = t;}|))))))
     (c-cadr exp)
     (compile (c-caddr exp) 'val 'next)))
  (define (compile-definition exp target linkage)
    ((lambda (var get-value-code)
       (end-with-linkage
        linkage
        (preserving '(env)
                    get-value-code
                    (c-make-instruction-sequence
                     '(env val) (list target)
                     (c-append '(|{Object t = def_var_val(c_str_to_datum("|)
                               (c-symbol->c var)
                               (list '|"));
                                   object_free(&| target '|);|
                                   target '| = t;}|))))))
     (c-definition-variable exp)
     (compile (definition-value exp) 'val 'next)))
  (define (compile-if exp target linkage)
    ((lambda (f-branch after-if)
       ((lambda (consequent-linkage)
          ((lambda (p-code c-code a-code)
             (preserving
              '(env cont)
              p-code
              (append-instruction-sequences
               (c-make-instruction-sequence
                '(val) '()
                (list '|if(val.type==BOOLEAN && !val.boolean){
                        goto | f-branch '|;}|))
               (parallel-instruction-sequences
                c-code
                (append-instruction-sequences
                 (c-make-instruction-sequence
                  '() '()
                  (list f-branch '|:;|))
                 a-code))
               (if (eq? linkage 'next)
                   (c-make-instruction-sequence
                    '() '()
                    (list after-if '|:;|))
                   (c-empty-instruction-sequence))
               )))
           (compile (c-cadr exp) 'val 'next)
           (compile (c-caddr exp) target consequent-linkage)
           (compile (c-if-alternative exp) target linkage)))
        (if (eq? linkage 'next) after-if linkage)))
     (make-label 'false_branch)
     (make-label 'after_if)))
  (define (compile-sequence seq target linkage)
    (if (null? (cdr  seq))
        (compile (car seq) target linkage)
        (preserving '(env cont)
                    (compile (car seq) target 'next)
                    (compile-sequence (cdr seq) target linkage))))
  (define (compile-lambda exp target linkage)
    ((lambda (proc-entry after-lambda)
       ((lambda (lambda-linkage)
          (append-instruction-sequences
           (tack-on-instruction-sequence
            (end-with-linkage
             lambda-linkage
             (c-make-instruction-sequence
              '(env) (list target)
              (list '|object_free(&| target '|);|
                    target '| = make_compiled_procedure(&&| proc-entry '|);|)
              ))
            (compile-lambda-body exp proc-entry))
           (if (eq? lambda-linkage after-lambda)
               (c-make-instruction-sequence
                '() '() (list after-lambda '|:;|))
               (c-empty-instruction-sequence))))
        (if (eq? linkage 'next) after-lambda linkage)))
     (make-label 'entry)
     (make-label 'after_lambda)))
  (define (compile-lambda-body exp proc-entry)
    ((lambda (formals)
       (append-instruction-sequences
        (c-make-instruction-sequence
         '(env proc argl) '(env)
         (c-append (list proc-entry
                         '|:env = compiled_procedure_env();
                          env = extend_environment(|)
                   (const formals)
                   '(|);|)))
        (compile-sequence (c-cddr exp) 'val 'return)))
     (c-cadr exp)))
  (define (compile-application exp target linkage)
    (define (iter proc lst)
      (if (null? lst)
          '()
          (cons (proc (car lst))
                (iter proc (cdr lst)))))
    ((lambda (proc-code operand-codes)
       (preserving
        '(env cont)
        proc-code
        (preserving
         '(proc cont)
         (construct-arglist operand-codes)
         (compile-procedure-call target linkage))))
     (compile (car exp) 'proc 'next)
     (iter (lambda (operand) (compile operand 'val 'next)) (cdr exp))))
  (define (construct-arglist operand-codes)
    ((lambda (operand-codes)
       (if (null? operand-codes)
           (c-make-instruction-sequence
            '() '(argl)
            '(|argl = empty;|))
           ((lambda (code-to-get-last-arg)
              (if (null? (cdr operand-codes))
                  code-to-get-last-arg
                  (preserving '(env)
                              code-to-get-last-arg
                              (code-to-get-rest-args
                               (cdr operand-codes)))))
            (append-instruction-sequences
             (car operand-codes)
             (c-make-instruction-sequence
              '(val) '(argl)
              '(|argl = cons(object_copy(val),empty);|))))))
     (c-reverse operand-codes)))
  (define (code-to-get-rest-args operand-codes)
    ((lambda (code-for-next-arg)
       (if (null? (cdr operand-codes))
           code-for-next-arg
           (preserving '(env)
                       code-for-next-arg
                       (code-to-get-rest-args
                        (cdr operand-codes)))))
     (preserving
      '(argl)
      (car operand-codes)
      (c-make-instruction-sequence
       '(val argl) '(argl)
       '(|argl = cons(object_copy(val), argl);|)))))
  (define (compile-procedure-call target linkage)
    ((lambda (primitive-branch after-call)
       ((lambda (compiled-linkage)
          (append-instruction-sequences
           (c-make-instruction-sequence
            '(proc) '()
            (list '|if (proc.type == PROC_APPLY) {
                     proc = apply_proc();
                     argl = apply_argl();
                   }
                   if (proc.type == PROC) { goto |
                  primitive-branch '|;}|))
           (parallel-instruction-sequences
            (compile-proc-appl target compiled-linkage)
            (append-instruction-sequences
             (c-make-instruction-sequence
              '() '()
              (list primitive-branch '|:;|))
             (end-with-linkage
              linkage
              (c-make-instruction-sequence
               '(proc argl)
               (list target)
               (list '|object_free(&| target '|);|
                     target '| = proc.proc(argl); |)
               ))))
           (if (eq? linkage 'next)
               (c-make-instruction-sequence
                '() '() (list after-call '|:;|))
               (c-empty-instruction-sequence))
           ))
        (if (eq? linkage 'next) after-call linkage)))
     (make-label 'primitive_branch)
     (make-label 'after_call)))
  (define (compile-proc-appl target linkage)
    (if (and (eq? target 'val) (not (eq? linkage 'return)))
        (c-make-instruction-sequence
         '(proc) all-regs
         (list '|cont.cont = &&| linkage '|;
                 object_free(&val);
                 val = compiled_procedure_entry(proc);
                 goto *val.cont;|))
        (if (and (not (eq? target 'val))
                 (not (eq? linkage 'return)))
            ((lambda (proc-return)
               (c-make-instruction-sequence
                '(proc) all-regs
                (list '|cont.cont = &&| proc-return '|;
                        object_free(&val);
                        val = compiled_procedure_entry(proc);
                        goto *val.cont;|
                      proc-return '|:
                        object_free(&| target '|);|
                        target '| = val; val.type = NONE;
                        goto | linkage '|;|)))
             (make-label 'proc_return))
            (if (and (eq? target 'val) (eq? linkage 'return))
                (c-make-instruction-sequence
                 '(proc cont) all-regs
                 '(|object_free(&val);
                    val = compiled_procedure_entry(proc);
                    goto *val.cont;|)
                 )
                (if (and (not (eq? target 'val))
                         (eq? linkage 'return))
                    (error
                     '|return linkage, target not val -- compile|
                     target))))))
  (define all-regs '(env proc val argl cont))
  (define (append-instruction-sequences . seqs)
    (define (append-2-sequences seq1 seq2)
      (c-make-instruction-sequence
       (c-list-union (c-registers-needed seq1)
                     (c-list-difference (c-registers-needed seq2)
                                        (c-registers-modified seq1)))
       (c-list-union (c-registers-modified seq1)
                     (c-registers-modified seq2))
       (c-append (c-statements seq1) (c-statements seq2))))
    (define (append-seq-list seqs)
      (if (null? seqs)
          (c-empty-instruction-sequence)
          (append-2-sequences (car seqs)
                              (append-seq-list (cdr seqs)))))
    (append-seq-list seqs))
  (define (preserving regs seq1 seq2)
    (if (null? regs)
        (append-instruction-sequences seq1 seq2)
        ((lambda (first-reg)
           (if (and (c-needs-register? seq2 first-reg)
                    (c-modifies-register? seq1 first-reg))
               (preserving (cdr regs)
                           (c-make-instruction-sequence
                            (c-list-union (list first-reg)
                                          (c-registers-needed seq1))
                            (c-list-difference
                             (c-registers-modified seq1)
                             (list first-reg))
                            (c-append
                             (list '|save(| first-reg '|);|)
                             (c-statements seq1)
                             (list '|object_free(&| first-reg '|);|
                                   first-reg '| =restore();|)))
                           seq2)
               (preserving (cdr regs) seq1 seq2)))
         (car regs))))
  (define (tack-on-instruction-sequence seq body-seq)
    (c-make-instruction-sequence
     (c-registers-needed seq)
     (c-registers-modified seq)
     (c-append (c-statements seq) (c-statements body-seq))))
  (define (parallel-instruction-sequences seq1 seq2)
    (c-make-instruction-sequence
     (c-list-union (c-registers-needed seq1)
                   (c-registers-needed seq2))
     (c-list-union (c-registers-modified seq1)
                   (c-registers-modified seq2))
     (c-append (c-statements seq1) (c-statements seq2))))

  (define input-file (open-input-file "input.scm"))
  (define output-file (open-output-file "output.c"))
  (define data (read input-file))
  (define code (compile data 'val 'next))
  (print-code code output-file)
  'compiled
  )

ksi.scm

((lambda ()
   (define (eval exp env) ((analyze exp) env))
   (define (analyze exp)
     (if (eof-object? exp)
         (exit)
         (if (self-evaluating? exp)
             (analyze-self-evaluating exp)
             (if (variable? exp)
                 (analyze-variable exp)
                 (if (quoted? exp)
                     (analyze-quoted exp)
                     (if (lambda? exp)
                         (analyze-lambda exp)
                         (if (definition? exp)
                             (analyze-definition exp)
                             (if (assignment? exp)
                                 (analyze-assignment exp)
                                 (if (if? exp)
                                     (analyze-if exp)
                                     (if (begin? exp)
                                         (analyze-sequence (begin-actions exp))
                                         (if (application? exp)
                                             (analyze-application exp)
                                             (error
                                              "unknown expression type -- analyze"
                                              exp))))))))))))

   (define (analyze-self-evaluating exp) (lambda (env) exp))
   (define (analyze-variable exp) (lambda (env) (lookup-variable-value exp env)))
   (define (analyze-quoted exp)
     ((lambda (qval)
        (lambda (env) qval))
      (text-of-quotation exp)))
   (define (analyze-lambda exp)
     ((lambda (vars bproc)
        (lambda (env) (make-procedure vars bproc env)))
      (lambda-parameters exp)
      (analyze-sequence (lambda-body exp))))
   (define (analyze-definition exp)
     ((lambda (var vproc)
        (lambda (env)
          (define-variable! var (vproc env) env)))
      (definition-variable exp)
      (analyze (definition-value exp))))
   (define (analyze-assignment exp)
     ((lambda (var vproc)
        (lambda (env)
          (set-variable-value! var (vproc env) env)))
      (assignment-variable exp)
      (analyze (assignment-value exp))))
   (define (analyze-if exp)
     ((lambda (pproc cproc aproc)
        (lambda (env)
          (if (pproc env)
              (cproc env)
              (aproc env))))
      (analyze (if-predicate exp))
      (analyze (if-consequent exp))
      (analyze (if-alternative exp))))
   (define (map proc list)
     (if (null? list)
         '()
         (cons (proc (car list))
               (map proc (cdr list)))))
   (define (analyze-sequence exps)
     (define (sequentially proc1 proc2)
       (lambda (env) (proc1 env) (proc2 env)))
     (define (loop first-proc rest-procs)
       (if (null? rest-procs)
           first-proc
           (loop (sequentially first-proc (car rest-procs))
                 (cdr rest-procs))))
     ((lambda (procs)
        (if (null? procs)
            (error "empty sequence -- analyze"))
        (loop (car procs) (cdr procs)))
      (map analyze exps)))

   (define (analyze-application exp)
     ((lambda (pproc aprocs)
        (lambda (env)
          (execute-application (pproc env)
                               (map (lambda (aproc) (aproc env))
                                    aprocs))))
      (analyze (operator exp))
      (map analyze (operands exp))))
   (define (execute-application proc args)
     (if (primitive-procedure? proc)
         (c-apply (primitive-implementation proc) args)
         (if (compound-procedure? proc)
             ((procedure-body proc)
              (extend-environment (procedure-parameters proc)
                                  args
                                  (procedure-environment proc)))
             (error "unknown procedure type -- execute-application" proc))))

   (define (self-evaluating? exp)
     (or (boolean? exp)
         (number? exp)
         (vector? exp)
         (char? exp)
         (string? exp)
         (bytevector? exp)
         (procedure? exp)
         (eq? exp (if #f '()))))
   (define (variable? exp) (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 (application? exp) (pair? exp))
   (define (operator exp) (car exp))
   (define (operands exp) (cdr exp))
   
   (define (definition? exp) (tagged-list? exp 'define))
   (define (definition-variable exp)
     (if (symbol? (car (cdr exp)))
         (car (cdr exp))
         (car (car (cdr exp)))))
   (define (definition-value exp)
     (if (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 (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 (primitive-procedure? proc) (tagged-list? proc 'primitive))
   (define (primitive-implementation proc) (car (cdr proc)))
   (define primitive-procedures
     (list (list 'car car)
           (list 'cdr cdr)
           (list 'cons cons)
           ))
   (define (primitive-procedure-names) (map car primitive-procedures))
   (define (primitive-procedure-objects)
     (map (lambda (proc)
            (list 'primitive (car (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)
        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 (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))   
   
   (driver-loop)
   ))

入出力結果(Terminal)

$ ./ksi
> '|Hello, World!|
=> |Hello,\x20;World!|
> "Hello, World!"
=> "Hello, World!"
> exit: 0
$

0 コメント:

コメントを投稿

Comments on Google+: