scheme中文编程

受javaeye上的《 Ruby中文编程》启发，帖子中有人提到如果if这样的关键字都可以定义成中文，那就是真正的中文编程。那时我就想到，这个其实要在scheme中实现是多么简单，将sicp书中的解释器稍微修改下就可以了，只要修改解析的部分即可。解释器的完整代码放后面，我们先看看有趣的例子： (定义 你  ' 男) (当 ((是 你  ' 男) (打印  ' 男人是泥土做的))     ((是 你  ' 女) (打印  ' 女人是水做的))     (否则          (打印  ' 妖怪啊)))     其实呢，“定义”等价于define，“当”等价于cond，“打印”等价于display，说穿了不值一提，只是有趣罢了。不过设想在某些效率不是攸关的场景嵌入这么一个scheme解释器来定义DSL给业务人员使用，似乎也是不错的主意。当然这里还是scheme的前缀表达式，再修改下就可以像自然语言那样流畅，只不过括号还是少不了呀。     再看几个例子： (使得 ((a  3 )        (b  2 ))        ( +  a b)) (定义 成绩  90 ) (如果 ( >  成绩  80 )       (打印  ' 良好)       (打印  ' 要打PP了)) ((函数(x) (* x x)) 3)  => 9 (定义 (平方 x) (* x x)) (平方 3)               =>9         “使得”就是let，如果就是if，函数就是lambda。这不是中文编程吗？也许可以考虑申请国家专项资金来扶持:D     完整的解释器代码，在drscheme选择R5RS标准下测试通过(代码折叠，请展开)： 解释器源码 (define apply-in-underlying-scheme apply) (define (eval exp env)   ((analyze exp) env)) (define (analyze exp)   (cond ((self-evaluating? exp)          (analyze-self-evaluating exp))         ((quoted? exp)          (analyze-quoted exp))         ((variable? exp)          (analyze-variable exp))         ((assignment? exp)          (analyze-assignment exp))         ((definition? exp)          (analyze-definition exp))         ((if? exp)          (analyze-if exp))         ((lambda? exp)          (analyze-lambda exp))         ((begin? exp)          (analyze-sequence (begin-actions exp)))         ((cond? exp)          (analyze (cond->if exp)))         ((let? exp) (analyze (let->combination exp)))         ((application? exp)(analyze-application exp))         (else            (error "Unknown expression type--ANALYZE" exp)))) (define (apply procedure arguments)   (cond ((primitive-procedure? procedure)          (apply-primitive-procedure procedure arguments))         ((compound-procedure? procedure)          (eval-sequence            (procedure-body procedure)           (extend-environment (procedure-parameters procedure)                               arguments                               (procedure-environment procedure))))         (else            (error "Unknown procedure type --APPLY" procedure)))) (define (self-evaluating? exp)   (cond ((number? exp) #t)        ((string? exp) #t)        (else            #f)))(define (variable? exp) (symbol? exp)) (define (quoted? exp)   (tagged-list? exp 'quote))(define (text-of-quotation exp)   (cadr exp)) (define (tagged-list? exp tag)   (if (pair? exp)       (eq? (car exp) tag)       #f))(define (assignment? exp)   (tagged-list? exp '设置))(define (assignment-variable exp)   (cadr exp)) (define (assignment-value exp)   (caddr exp)) (define (definition? exp)   (tagged-list? exp '定义))(define (definition-variable exp)   (if (symbol? (cadr exp))       (cadr exp)       (caadr exp))) (define (definition-value exp)   (if (symbol? (cadr exp))       (caddr exp)       (make-lambda (cdadr exp)                    (cddr exp)))) (define (lambda? exp)   (tagged-list? exp '函数))(define (lambda-parameters exp)   (cadr exp)) (define (lambda-body exp)   (cddr exp)) (define (make-lambda parameters body)   (cons '函数 (cons parameters body)))(define (if? exp)   (tagged-list? exp '如果))(define (if-predicate exp) (cadr exp)) (define (if-consequent exp) (caddr exp)) (define (if-alternative exp)   (if (not (null? (cdddr exp)))       (cadddr exp)       'false))(define (make-if predicate consequent alternative)   (list '如果 predicate consequent alternative))(define (begin? exp)   (tagged-list? exp '开始))(define (begin-actions exp) (cdr exp)) (define (last-exp? exps) (null? (cdr exps))) (define (first-exp exps) (car exps)) (define (rest-exps exps) (cdr exps)) (define (make-begin seq) (cons '开始 seq))(define (sequence->exp seq)   (cond ((null? seq) seq)         ((last-exp? seq) (first-exp seq))         (else            (make-begin seq)))) (define (application? exp)   (pair? exp)) (define (operator exp)   (car exp)) (define (operands exp)   (cdr exp)) (define (no-operands? ops) (null? ops)) (define (first-operand ops) (car ops)) (define (rest-operands ops) (cdr ops)) (define (let? exp)   (tagged-list? exp '使得))(define (make-define var parameters body)   (list '定义 (cons var parameters) body))(define (let->combination exp)   (if (symbol? (cadr exp))       (let ((var (cadr exp))             (vars (map car (caddr exp)))             (vals (map cadr (caddr exp)))             (pairs (caddr exp))             (body (cadddr exp)))         (cons (make-lambda vars (list (make-define var vars body) body)) vals))       (let ((vars (map car (cadr exp)))             (vals (map cadr (cadr exp)))             (body (caddr exp)))               (cons (make-lambda vars (list body)) vals)))) (define (cond? exp)   (tagged-list? exp '当))(define (cond-clauses exp) (cdr exp)) (define (cond-else-clauses? clause)   (eq? (cond-predicate clause) '否则))(define (cond-extended-clauses? clause)   (and (> (length clause) 2) (eq? (cadr clause) '=>)))(define (extended-cond-test clause)   (car clause)) (define (extended-cond-recipient clause)   (caddr clause))  (define (cond-predicate clause) (car clause)) (define (cond-actions clause) (cdr clause)) (define (cond->if exp)   (expand-clauses (cond-clauses exp))) (define (expand-clauses clauses)   (if (null? clauses)       'false      (let ((first (car clauses))             (rest (cdr clauses)))         (cond ((cond-else-clauses? first)                 (if (null? rest)                     (sequence->exp (cond-actions first))                     (error "else clause is not LAST" clauses)))               ((cond-extended-clauses? first)                (make-if                    (extended-cond-test first)                     (list                       (extended-cond-recipient first)                       (extended-cond-test first))                       (expand-clauses rest)))               (else                (make-if (cond-predicate first)                         (sequence->exp (cond-actions first))                         (expand-clauses rest))))))) (define (true? exp)   (or (eq? exp 'true) exp))(define (false? exp)   (or (eq? exp 'false) exp))(define (make-procedure parameters body env)   (list 'procedure parameters body env))(define (compound-procedure? p)   (tagged-list? p 'procedure))(define (procedure-parameters p)   (cadr p)) (define (procedure-body p)   (caddr p)) (define (procedure-environment p)   (cadddr p)) (define (enclosing-environment env) (cdr env)) (define (first-frame env) (car env)) (define the-empty-environment '())(define (make-frame variables values)   (cons variables values)) (define (frame-variables f)   (car f)) (define (frame-values f)   (cdr f)) (define (add-binding-to-frame! var val frame)   (set-car! frame (cons var (car frame)))   (set-cdr! frame (cons val (cdr frame)))) (define (extend-environment vars vals base-env)   (if (= (length vars) (length vals))       (cons (make-frame vars vals) base-env)       (if (< (length vars) (length vals))           (error "Too many arguments supplied" vars vals)           (error "Too few arguments supplied" vars vals)))) (define (lookup-variable-value var env)   (define (env-loop env)     (define (scan vars vals)       (cond ((null? vars)              (env-loop (enclosing-environment env)))             ((eq? var (car vars))              (car vals))             (else               (scan (cdr vars) (cdr vals)))))     (if (eq? env the-empty-environment)         (error "Unbound variable" var)         (let ((frame (first-frame env)))           (scan (frame-variables frame)                 (frame-values frame)))))   (env-loop env)) (define (set-variable-value! var val env)   (define (env-loop env)     (define (scan vars vals)       (cond ((null? vars)              (env-loop (enclosing-environment env)))             ((eq? var (car vars))              (set-car! vals val))             (else               (scan (cdr vars) (cdr vals)))))     (if (eq? env the-empty-environment)         (error "Unbound variable --SET!" var)         (let ((frame (first-frame env)))           (scan (frame-variables frame)                 (frame-values frame)))))   (env-loop env)) (define (define-variable! var val env)   (let ((frame (first-frame env)))     (define (scan vars vals)       (cond ((null? vars)              (add-binding-to-frame! var val frame))             ((eq? (car vars) var)              (set-car! vals val))             (else                (scan (cdr vars) (cdr vals)))))     (scan (frame-variables frame)           (frame-values frame)))) (define (primitive-procedure? p)   (tagged-list? p 'primitive))(define (primitive-implementation proc) (cadr proc)) (define primitive-procedures   (list (list 'car car)         (list 'cdr cdr)        (list 'cons cons)        (list 'null? null?)        (list '+ +)        (list '- -)        (list '* *)        (list '/ /)        (list '< <)        (list '> >)        (list '是 equal?)        (list '= =)        (list 'assoc assoc)        (list 'cadr cadr)        (list 'cadr caddr)        (list '打印 display)        (list '换行 newline)        (list '映射 map)))(define (primitive-procedure-names)   (map car primitive-procedures)   ) (define (primitive-procedure-objects)   (map (lambda(proc) (list 'primitive (cadr proc))) primitive-procedures))(define (setup-environment)   (let ((initial-env            (extend-environment (primitive-procedure-names)                                (primitive-procedure-objects)                                the-empty-environment)))     (define-variable! 'true #t initial-env)    (define-variable! 'false #f initial-env)    initial-env)) (define the-global-environment (setup-environment)) (define (apply-primitive-procedure proc args)   (apply-in-underlying-scheme (primitive-implementation proc) args)) (define input-prompt ";;; M-Eval input:") (define out-prompt ";;; M-Eval value:") (define (prompt-for-input string)   (newline)   (newline)   (display string)   (newline)) (define (announce-output string)   (newline)   (display string)   (newline)) (define (user-print object)   (if (compound-procedure? object)       (display (list 'compound-procedure                     (procedure-parameters object)                      (procedure-body object)                      '<procedure-env>))      (display object))) (define (drive-loop)   (prompt-for-input input-prompt)   (let ((input (read)))     (let ((output (eval input the-global-environment)))       (announce-output out-prompt)       (user-print output)))   (drive-loop)) ;接下来是分析过程 (define (analyze-self-evaluating exp)   (lambda(env) exp)) (define (analyze-variable exp)   (lambda(env) (lookup-variable-value exp env))) (define (analyze-quoted exp)   (let ((qval (text-of-quotation exp)))     (lambda(env) qval))) (define (analyze-assignment exp)   (let ((var (assignment-variable exp))         (vproc (analyze (assignment-value exp))))     (lambda(env)         (set-variable-value! var (vproc env) env)         'ok)))(define (analyze-definition exp)   (let ((var (definition-variable exp))         (vproc (analyze (definition-value exp))))     (lambda(env)       (define-variable! var (vproc env) env)       'ok)))(define (analyze-if exp)   (let ((pproc (analyze (if-predicate exp)))         (cproc (analyze (if-consequent exp)))         (aproc (analyze (if-alternative exp))))     (lambda(env)       (if (true? (pproc env))           (cproc env)           (aproc env))))) (define (analyze-lambda exp)   (let ((vars (lambda-parameters exp))         (bproc (analyze-sequence (lambda-body exp))))     (lambda(env) (make-procedure vars bproc env)))) (define (analyze-sequence exps)   (define (sequentially proc1 proc2)     (lambda(env) (proc1 env) (proc2 env)))   (define (loop first-proc rest-proc)     (if (null? rest-proc)         first-proc         (loop (sequentially first-proc (car rest-proc))               (cdr rest-proc))))   (let ((procs (map analyze exps))         )     (if (null? procs)         (error "Empty sequence --ANALYZE")         (loop (car procs) (cdr procs))))) (define (analyze-application exp)   (let ((fproc (analyze (operator exp)))         (aprocs (map analyze (operands exp))))     (lambda(env)       (execution-application (fproc env)                              (map (lambda (aproc) (aproc env)) aprocs))))) (define (execution-application proc args)   (cond ((primitive-procedure? proc)          (apply-primitive-procedure proc args))         ((compound-procedure? proc)          ((procedure-body proc)            (extend-environment (procedure-parameters proc)                               args                               (procedure-environment proc))))         (else          (error "Unknown procedure type --EXECUTE--APPLICATION" proc)))) (drive-loop)         文章转自庄周梦蝶  ，原文发布时间 2009-03-20                    相关资源：敏捷开发V1.0.pptx