これは、2014年Lispアドベントカレンダーの最後12/25に投稿されるはずだった記事です。 年末が特に忙しく、5日も遅れてしましいました。すみません。「遅れちゃったしもういいかなー」とも思ったのですが、 このような記事も見つけてしまいまして、ほかでや…

去年の夏ぐらいに、NodeJS/ブラウザ上で動くArc言語*1処理系「ArcJS」を作りました。 全体として2500行ぐらいでStackVMまで実装してあるので、処理系を作りたい人は参考になるかもしれません。http://smihica.github.io/arc-js/既に実際に仕事で部分的に使っ…

展示の為に、まとまった量のArcのコードを書いてglazeで実行したらsegvが頻発した。 調べてみるとまだ使用中のオブジェクトを解放してしまっていたようである。glazeは環境フレームをstd::vectorにオブジェクトを格納する形で実装していたが、もしかして、 s…

はてなDiaryの一日の文字数制限なのか、途中できられていたので書き直す。 メタScheme ;;; ;;; util ;;; (define (tagged-list? exp tag) (if (pair? exp) (eq? (car exp) tag) #f)) ;;; ;;; environment ;;; ;basic-proc (define the-empty-environment '()…

大体3000行程度のC++になった。 もっとも単純な機能のschemeとなっている。macroやcall/ccはない。GCはboehmGCを使用した。 C++で作るにあたって、一番違ったのはreaderとobjectだった。 そこらへんを見ると参考になるかも。 githubにおいた micro-scheme gi…

(define (make-unbound-variable! var env) (define (env-loop env) (define (scan prev-vars vars prev-vals vals) (cond ((null? vars) (env-loop (enclosing-envrionment env))) ((eq? var (car vars)) (set-cdr! prev-vars (cdr vars)) (set-cdr! prev-v…

(define (env-loop null-proc find-proc name var env) (define (scan vars vals) (cond ((null? vars) (null-proc env)) ((eq? var (car vars)) (find-proc vals)) (else (scan (cdr vars) (cdr vals))))) (if (eq? env the-empty-environment) (error "Unb…

(define (make-frame variables values) (if (= (length variables) (length values)) (reverse (let make-frame-iter ((vars variables) (vals values)) (cons (cons (car vars) (cdr vals)) (make-frame-iter (cdr vars) (cdr vals))))) (error "variables…

;; しょうもない変更だが、let式を変更する。 (let ((a b) (c d) (e f))) ;; -> (let (a b c d e f)) ;; とかけるようにしよう。 (define (let->combination exp) (let ((second (cadr exp))) (let ((named? (symbol? second))) (let ((bindings (if named? …

;; doを作ってみる (do binds (predicate value) body) ;; である。 ;; binds部は ((var-name initialize-value update-expression) ... ) ;; である。 (do ((var-name1 initialize-value1 update-expression1) (var-name2 initialize-value2 update-express…

(define (fib n) (let fib-iter ((a 1) (b 0) (count n)) (if (= count 0) b (fib-iter (+ a b) a (- count 1))))) ;; -> (define (fib n) (let ((a 1) (b 0) (count n)) (define (fib-iter a b count) (if (= count 0) b (fib-iter (+ a b) a (- count 1)))…

(let* ((x 3) (y (+ x 2)) (z (+ x y 5))) (* x z)) ;=> (let ((x 3)) (let ((y (+ x 2))) (let ((z (+ x y 5))) (* x z)))) (define (let*->nested-lets exp) (let ((bindings (cadr exp))) (let binds->lets ((binds bindings)) (if (null? (cdr binds)) (…

(define (let->combination exp) (let ((bindings (cadr exp))) (let ((vars (map car bindings)) (exps (map cadr bindings))) (append (list (append (list 'lambda vars) (cddr exp))) exps)))) (define (eval-let exp env) (eval (let->combitation exp)…

(define (cond->if exp) (expand-clauses (cond-clauses exp))) (define (make-if predicate consequent alternative) (list 'if predicate consequent alternative)) (define (cond-clauses exp) (cdr exp)) (define (cond-predicate clause) (car clause))…

(define (eval-and-sequence exps env) (if (null? exps) 'true (if (true? (eval (first-exp exps) env)) (eval-and-sequence (rest-exps exps) env) 'false))) (define (eval-and exp env) (eval-and-sequence (cdr exp) env)) (put 'eval 'and eval-and) …

(define (eval exp env) (cond ((self-evaluationg? exp) exp) ((variable? exp) (lookup-variable-value exp env)) (else (let ((proc (get 'eval (car exp)))) (if proc (proc exp env) (if (application? exp) (apply (eval (operator exp) env) (list-of…

(define (eval exp env) (cond ((self-evaluationg? exp) exp) ((variable? exp) (lookup-variable-value exp env)) ((quoted? exp) (text-of-quotation exp)) ((assignment? exp) (eval-assignment exp env)) ((call? exp) (apply (eval (operator exp) env…

;; 4.1 ;L->R (define (list-of-values exps env) (if (no-operands? exps) '() (let ((val (eval (first-operand exps) env))) (cons val (list-of-values (rest-operands exps) env))))) ;R->L (define (list-of-values exps env) (if (no-operands? exps)…

並列性の問題は一時とばす。 後で必ず戻る。 4章までワープ

(define (subtracter a b c) (adder c b a)) (define (divider a b c) (multiplier c b a)) (define (c+ x y) (let ((z (make-connector))) (adder x y z) z)) (define (c- x y) (let ((z (make-connector))) (subtracter x y z) z)) (define (c* x y) (let …

図は面倒 心の中に思い描いた。

(define (squarer a b) (define (process-new-value) (if (has-value? b) (if (< (get-value b) 0) (error "square less than 0 -- SQUARER" (get-value b)) (set-value! a (sqrt (get-value b)) me)) (if (has-value? a) (set-value! b (* (get-value a) (g…

(define (squarer a b) (multiplier a a b)) (define a (make-connector)) (define b (make-connector)) (squarer a b) (probe "A" a) (probe "B" b) (set-value! a -3 'user) ;Probe: B = 9 (forget-value! a 'user) (set-value! b 9 'user) ;Probe: B = 9 …

(define (averager a b c) (let ((d (make-connector)) (e (make-connector))) (adder a b d) (multiplier d e c) (constant 0.5 e) 'ok)) (define a (make-connector)) (define b (make-connector)) (define c (make-connector)) (averager a b c) (probe "…

(define the-agenda (make-agenda)) (define a1 (make-wire)) (define a2 (make-wire)) (define output (make-wire)) (probe 'a1 a1) (probe 'a2 a2) (probe 'output output) (and-gate a1 a2 output) (set-signal! a1 0) (set-signal! a2 1) (propagate) (s…

;wireの実装上、信号が切り替わったときにしか登録したactionは実行されないため、 ;もし、ある回路シミュレーターの入力値が変化しなかった場合、出力側が正しくない値だったとしても、actionが実行されず修正されないことが起こりうる。 ;よって初めに、回…

(define (ripple-carry-adder ak bk sk c) (let ((ck (map (lambda (x) (make-wire)) sk))) (let iter (ak bk sk ck) (if (null? (cdr ck)) (full-adder (car ak) (car bk) (car ck) (car sk) c) (begin (full-adder (car ak) (car bk) (car ck) (car sk) (c…

;;意外と思いつかなかった。20分も悩んだ。 (define (or-gate a1 a2 output) (let ((a3 (make-wire)) (a4 (make-wire)) (o1 (make-wire))) (inverter a1 a3) (inverter a2 a4) (and-gate a3 a4 o1) (inverter o1 output) 'ok)) ;;遅延時間は (+ (* inverter-…

(define a (make-wire)) (define b (make-wire)) (define c (make-wire)) (define d (make-wire)) (define e (make-wire)) (define s (make-wire)) (or-gate a b d) (and-gate a b c) (inverter c e) (and-gate d e s) (define (half-adder a b s c) (let ((…

(define (fib n) (cond ((= n 0) 0) ((= n 1) 1) (else (+ (fib (- n 1)) (fib (- n 2)))))) ;(time (fib 35)) ; real 3.050 ; user 3.010 ; sys 0.040 9227465 (define (memorize f) (let ((table (make-table))) (let ((get (table 'lookup-proc)) (put (t…