Essentials of Programming Languages (3ed) 已经是许久以前读的了, 现在记下一些东西, 或许对于后来者有用.
引入了数据的归纳 (或者说递归) 定义, 尤其是BNF文法, 并介绍了与之匹配的编程技术和证明技术 (结构归纳法).
引入了数据抽象的想法, 也就是抽象数据类型和其实现的分离; 介绍了一个定义数据类型的工具, 以及解构的工具; 引入了抽象句法树的想法, 为之后的章节做铺垫.
引入了解释和编译的基本想法, 然后为几个小语言编写了解释器. 介绍了什么是词法作用域 (和动态作用域), 引入了词法寻址 (lexical addressing) 的想法. 在某种意义上, 这就是一个很好的编译的例子.
引入了副作用, 其实就是赋值. 引入了两种不同的语言, 一种显式操作引用 (类似于SML那种), 还有一种和通常的赋值类似. 介绍了一些不同的参数传递机制, 例如按引用调用, 按名调用等.
介绍了延续和延续传递风格 (CPS), 将之前的解释器改为CPS风格的. 对于通常的没有尾调用优化的语言, 引入了蹦床的想法. 使用延续实现了异常和多线程机制.
练习5.30解答. 当然了, 我不会全然按照题目的要求完成. 首先, 我们先给出句法.
<exp> ::= <var>
| (proc (<var>) <exp>)
| (<exp> <exp>)proc而不是lambda, 是为了避免让人误以为这是lambda演算. 然后, 我们给出实现.(define EXP (void))
(define ENV (void))
(define VAL (void))
(define PRO (void))
(define CTX (void))
(define-syntax PUSH
(syntax-rules ()
((_ val var)
(set! var (cons val var)))))
(define-syntax POP
(syntax-rules ()
((_ var)
(let ((val (car var)))
(set! var (cdr var))
val))))
(define (APPLY_ENV)
(cond ((assq EXP ENV)
=> (lambda (p)
(set! VAL (cdr p))))
(else
(error 'APPLY_ENV
"unbound variable ~s" EXP))))
(define (EVAL)
(match EXP
(,var
(guard (symbol? var))
(APPLY_ENV)
(APPLY_CTX))
((proc (,var) ,body)
(set! VAL EXP)
(APPLY_CTX))
((,rator ,rand)
(set! EXP rator)
(PUSH `(RATOR_CTX ,rand) CTX)
(EVAL))))
(define (APPLY_CTX)
(unless (null? CTX)
(define top (POP CTX))
(match top
((RATOR_CTX ,rand)
(set! EXP rand)
(PUSH `(RAND_CTX ,VAL) CTX)
(EVAL))
((RAND_CTX ,proc)
(set! PRO proc)
(APPLY_PRO))
((POP_ENV)
(POP ENV)
(APPLY_CTX)))))
(define (APPLY_PRO)
(match PRO
((proc (,var) ,body)
(set! EXP body)
(PUSH (cons var VAL) ENV)
(PUSH `(POP_ENV) CTX)
(EVAL))))
(define (RUN exp)
(set! EXP exp)
(set! ENV '())
(set! CTX '())
(EVAL))练习5.53. 我仍然没有完全按照题目要求完成. 现在过程interp, apply-ctx, apply-closure都会多接受一个名为tid的参数, 意即线程标识符 (thread identifier).
#lang racket
(require "match.rkt" "env.rkt" "store.rkt" data/queue)
(define (make-counter)
(let ((x -1))
(lambda ()
(set! x (+ x 1))
x)))
(define new-thread-id
(let ((counter (make-counter)))
(lambda ()
`(thread-id ,(counter)))))
(define (make-closure formal body env)
(vector 'closure formal body env))
(define (closure-formal closure)
(vector-ref closure 1))
(define (closure-body closure)
(vector-ref closure 2))
(define (closure-env closure)
(vector-ref closure 3))
(define (set-closure-env! closure env)
(vector-set! closure 3 env))
(define ((apply-closure tid) closure arg ctx)
(let ((formal (closure-formal closure))
(body (closure-body closure))
(env (closure-env closure)))
((interp tid)
body (extend-env formal arg env) ctx)))
(define (decompose binding*)
(if (null? binding*)
(values '() '() '())
(let ((binding (car binding*))
(binding* (cdr binding*)))
(let-values (((f* x* fbody*) (decompose binding*)))
(match binding
((,f (lambda (,x) ,fbody))
(values (cons f f*)
(cons x x*)
(cons fbody fbody*))))))))
(define (extend-env* var* val* env)
(append (map cons var* val*) env))
(define (extend-env-rec f* x* fbody* env)
(let* ((closure*
(map (lambda (x fbody) (make-closure x fbody (void))) x* fbody*))
(ref* (map newref closure*))
(env^ (extend-env* f* ref* env)))
(for-each (lambda (closure)
(set-closure-env! closure env^))
closure*)
env^))
(define global-store (make-store 10000))
(define (newref val)
(global-store 'newref val))
(define (deref ref)
(global-store 'deref ref))
(define (setref ref val)
(global-store 'setref ref val))
(define (make-scheduler name ticks)
(define queue (void))
(define time (void))
(define value (void))
(define (add-thread thread)
(enqueue! queue thread))
(define (run-next-thread)
(if (queue-empty? queue)
(printf "The final answer is ~s." value)
(let ((thread (dequeue! queue)))
(set! time ticks)
(thread))))
(define (expired?)
(zero? time))
(define (count-down)
(set! time (- time 1)))
(define (set-answer answer)
(set! value answer))
(define (initialize)
(set! queue (make-queue))
(set! time ticks)
(set! value (void)))
(define (set-ticks new-ticks)
(set! ticks new-ticks))
(lambda (msg . arg*)
(case msg
;I use apply to make sure the number of arguments
;matches the arity of the operation.
((add-thread) (apply add-thread arg*))
((run-next-thread) (apply run-next-thread arg*))
((expired?) (apply expired? arg*))
((count-down) (apply count-down arg*))
((set-answer) (apply set-answer arg*))
((initialize) (apply initialize arg*))
((set-ticks) (apply set-ticks arg*))
(else (error name "unknown message ~s" msg)))))
(define global-scheduler
(make-scheduler 'global-scheduler 10))
(define (make-mutex closed? queue)
(vector 'mutex closed? queue))
(define (mutex? x)
(and (vector? x)
(= (vector-length x) 3)
(eq? (vector-ref x 0) 'mutex)))
(define (mutex-closed? mutex)
(vector-ref mutex 1))
(define (mutex-queue mutex)
(vector-ref mutex 2))
(define (set-mutex-closed?! mutex closed?)
(vector-set! mutex 1 closed?))
(define (build-mutex)
(make-mutex #f (make-queue)))
(define (wait mutex thread)
(unless (mutex? mutex)
(error 'wait "~s is not a mutex" mutex))
(cond ((mutex-closed? mutex)
(enqueue! (mutex-queue mutex) thread)
(global-scheduler 'run-next-thread))
(else
(set-mutex-closed?! mutex #t)
(thread))))
(define (signal mutex thread)
(unless (mutex? mutex)
(error 'signal "~s is not a mutex" mutex))
(when (mutex-closed? mutex)
(define q (mutex-queue mutex))
(if (queue-empty? q)
(set-mutex-closed?! mutex #f)
(global-scheduler
'add-thread
(dequeue! q))))
(thread))
(define ((apply-ctx tid) ctx val)
(cond ((global-scheduler 'expired?)
(global-scheduler
'add-thread
(lambda ()
((apply-ctx tid) ctx val)))
(global-scheduler
'run-next-thread))
(else
(global-scheduler 'count-down)
(match ctx
((wait-ctx ,ctx)
(wait val
(lambda ()
((apply-ctx tid) ctx (void)))))
((signal-ctx ,ctx)
(signal val
(lambda ()
((apply-ctx tid) ctx (void)))))
((if-ctx ,e2 ,e3 ,env ,ctx)
(if val
((interp tid) e2 env ctx)
((interp tid) e3 env ctx)))
((set!-ctx ,x ,env ,ctx)
(let ((ref (apply-env env x)))
(setref ref val)
((apply-ctx tid) ctx (void))))
((let-ctx ,x ,body ,env ,ctx)
((interp tid)
body
(extend-env x (newref val) env)
ctx))
((begin-ctx ,e* ,env ,ctx)
((interp tid) `(begin . ,e*) env ctx))
((print-ctx ,ctx)
(printf "~s\n" val)
((apply-ctx tid) ctx (void)))
((spawn-ctx ,ctx)
(define new-tid (new-thread-id))
(global-scheduler
'add-thread
(lambda ()
((apply-closure new-tid)
val (newref tid)
'(end-subthread-ctx))))
((apply-ctx tid) ctx new-tid))
((op-ctx-1 ,op ,e2 ,env ,ctx)
((interp tid)
e2 env
`(op-ctx-2 ,op ,val ,ctx)))
((op-ctx-2 ,op ,v1 ,ctx)
(let ((v (case op
((+) (+ v1 val))
((-) (- v1 val))
((*) (* v1 val))
((=) (= v1 val))
((eq?) (eq? v1 val)))))
((apply-ctx tid) ctx v)))
((rator-ctx ,rand ,env ,ctx)
((interp tid)
rand env
`(rand-ctx ,val ,ctx)))
((rand-ctx ,closure ,ctx)
((apply-closure tid)
closure (newref val) ctx))
((end-main-thread-ctx)
(global-scheduler
'set-answer val)
(global-scheduler
'run-next-thread))
((end-subthread-ctx)
(global-scheduler
'run-next-thread))))))
(define ((interp tid) exp env ctx)
(match exp
(,int
(guard (integer? int))
((apply-ctx tid) ctx int))
(,bool
(guard (boolean? bool))
((apply-ctx tid) ctx bool))
((quote ,sym)
(guard (symbol? sym))
((apply-ctx tid) ctx sym))
((void)
((apply-ctx tid) ctx (void)))
(,var
(guard (symbol? var))
((apply-ctx tid)
ctx (deref (apply-env env var))))
((mutex)
((apply-ctx tid) ctx (build-mutex)))
((wait ,e)
((interp tid) e env `(wait-ctx ,ctx)))
((signal ,e)
((interp tid) e env `(signal-ctx ,ctx)))
((if ,e1 ,e2 ,e3)
((interp tid)
e1 env
`(if-ctx ,e2 ,e3 ,env ,ctx)))
((set! ,x ,e)
((interp tid)
e env `(set!-ctx ,x ,env ,ctx)))
((lambda (,var) ,body)
((apply-ctx tid)
ctx (make-closure var body env)))
((let ,x ,e ,body)
((interp tid)
e env
`(let-ctx ,x ,body ,env ,ctx)))
((letrec ,binding* ,body)
(let-values (((f* x* fbody*) (decompose binding*)))
((interp tid)
body (extend-env-rec f* x* fbody* env) ctx)))
((begin ,e)
((interp tid) e env ctx))
((begin ,e . ,e*)
((interp tid)
e env `(begin-ctx ,e* ,env ,ctx)))
((print ,e)
((interp tid) e env `(print-ctx ,ctx)))
((spawn ,e)
((interp tid) e env `(spawn-ctx ,ctx)))
((,op ,e1 ,e2)
(guard (memq op '(+ - * = eq?)))
((interp tid)
e1 env
`(op-ctx-1 ,op ,e2 ,env ,ctx)))
((,rator ,rand)
((interp tid)
rator env
`(rator-ctx ,rand ,env ,ctx)))))
(define run
(case-lambda
((exp)
(global-scheduler 'initialize)
((interp (new-thread-id))
exp (empty-env) '(end-main-thread-ctx)))
((ticks exp)
(global-scheduler 'set-ticks ticks)
(global-scheduler 'initialize)
((interp (new-thread-id))
exp (empty-env) '(end-main-thread-ctx)))))练习5.55. 这里的答案基于笔者之前写下的练习5.53的答案, 以下未出现的定义就是和5.53保持一致.
(define (make-scheduler name ticks)
(define queue (void))
(define time (void))
(define value (void))
(define mailboxs (void))
(define (add-thread thread)
(enqueue! queue thread))
(define (run-next-thread)
(if (queue-empty? queue)
(printf "The final answer is ~s." value)
(let ((thread (dequeue! queue)))
(set! time ticks)
(thread))))
(define (expired?)
(zero? time))
(define (count-down)
(set! time (- time 1)))
(define (set-answer answer)
(set! value answer))
(define (initialize)
(set! queue (make-queue))
(set! time ticks)
(set! value (void))
(set! mailboxs (make-hash)))
(define (set-ticks new-ticks)
(set! ticks new-ticks))
(define (new-mailbox tid)
(when (hash-ref-key mailboxs tid (lambda () #f))
(error name "new-mailbox error: ~s" tid))
(hash-set! mailboxs tid (make-queue)))
(define (remove-mailbox tid)
(hash-remove! mailboxs tid))
(define (send-message tid msg)
(let ((q (hash-ref mailboxs tid (lambda () #f))))
(if q
(begin (enqueue! q msg) #t)
#f)))
(define (receive-message tid env ctx)
(define q (hash-ref mailboxs tid))
(if (queue-empty? q)
(begin
(add-thread
(lambda ()
((interp tid) '(receive) env ctx)))
(run-next-thread))
((apply-ctx tid) ctx (dequeue! q))))
(lambda (msg . arg*)
(case msg
;I use apply to make sure the number of arguments
;matches the arity of the operation.
((add-thread) (apply add-thread arg*))
((run-next-thread) (apply run-next-thread arg*))
((expired?) (apply expired? arg*))
((count-down) (apply count-down arg*))
((send-message) (apply send-message arg*))
((receive-message) (apply receive-message arg*))
((new-mailbox) (apply new-mailbox arg*))
((remove-mailbox) (apply remove-mailbox arg*))
((set-answer) (apply set-answer arg*))
((initialize) (apply initialize arg*))
((set-ticks) (apply set-ticks arg*))
(else (error name "unknown message ~s" msg)))))(define ((apply-ctx tid) ctx val)
(cond ((global-scheduler 'expired?)
(global-scheduler
'add-thread
(lambda ()
((apply-ctx tid) ctx val)))
(global-scheduler
'run-next-thread))
(else
(global-scheduler 'count-down)
(match ctx
((wait-ctx ,ctx)
(wait val
(lambda ()
((apply-ctx tid) ctx (void)))))
((signal-ctx ,ctx)
(signal val
(lambda ()
((apply-ctx tid) ctx (void)))))
((send-ctx-1 ,e2 ,env ,ctx)
((interp tid)
e2 env `(send-ctx-2 ,val ,ctx)))
((send-ctx-2 ,tid0 ,ctx)
(define flag
(global-scheduler
'send-message tid0 val))
((apply-ctx tid) ctx flag))
((if-ctx ,e2 ,e3 ,env ,ctx)
(if val
((interp tid) e2 env ctx)
((interp tid) e3 env ctx)))
((set!-ctx ,x ,env ,ctx)
(let ((ref (apply-env env x)))
(setref ref val)
((apply-ctx tid) ctx (void))))
((let-ctx ,x ,body ,env ,ctx)
((interp tid)
body
(extend-env x (newref val) env)
ctx))
((begin-ctx ,e* ,env ,ctx)
((interp tid) `(begin . ,e*) env ctx))
((print-ctx ,ctx)
(printf "~s\n" val)
((apply-ctx tid) ctx (void)))
((spawn-ctx ,ctx)
(define new-tid (new-thread-id))
(global-scheduler
'new-mailbox new-tid)
(global-scheduler
'add-thread
(lambda ()
((apply-closure new-tid)
val (newref tid)
'(end-subthread-ctx))))
((apply-ctx tid) ctx new-tid))
((op-ctx-1 ,op ,e2 ,env ,ctx)
((interp tid)
e2 env
`(op-ctx-2 ,op ,val ,ctx)))
((op-ctx-2 ,op ,v1 ,ctx)
(let ((v (case op
((+) (+ v1 val))
((-) (- v1 val))
((*) (* v1 val))
((=) (= v1 val))
((eq?) (eq? v1 val)))))
((apply-ctx tid) ctx v)))
((rator-ctx ,rand ,env ,ctx)
((interp tid)
rand env
`(rand-ctx ,val ,ctx)))
((rand-ctx ,closure ,ctx)
((apply-closure tid)
closure (newref val) ctx))
((end-main-thread-ctx)
(global-scheduler
'set-answer val)
(global-scheduler
'remove-mailbox tid)
(global-scheduler
'run-next-thread))
((end-subthread-ctx)
(global-scheduler
'remove-mailbox tid)
(global-scheduler
'run-next-thread))))))(define ((interp tid) exp env ctx)
(match exp
(,int
(guard (integer? int))
((apply-ctx tid) ctx int))
(,bool
(guard (boolean? bool))
((apply-ctx tid) ctx bool))
((quote ,sym)
(guard (symbol? sym))
((apply-ctx tid) ctx sym))
((void)
((apply-ctx tid) ctx (void)))
(,var
(guard (symbol? var))
((apply-ctx tid)
ctx (deref (apply-env env var))))
((mutex)
((apply-ctx tid) ctx (build-mutex)))
((wait ,e)
((interp tid) e env `(wait-ctx ,ctx)))
((signal ,e)
((interp tid) e env `(signal-ctx ,ctx)))
((send ,e1 ,e2)
((interp tid) e1 env `(send-ctx-1 ,e2 ,env ,ctx)))
((receive)
(global-scheduler
'receive-message
tid env ctx))
((if ,e1 ,e2 ,e3)
((interp tid)
e1 env
`(if-ctx ,e2 ,e3 ,env ,ctx)))
((set! ,x ,e)
((interp tid)
e env `(set!-ctx ,x ,env ,ctx)))
((lambda (,var) ,body)
((apply-ctx tid)
ctx (make-closure var body env)))
((let ,x ,e ,body)
((interp tid)
e env
`(let-ctx ,x ,body ,env ,ctx)))
((letrec ,binding* ,body)
(let-values (((f* x* fbody*) (decompose binding*)))
((interp tid)
body (extend-env-rec f* x* fbody* env) ctx)))
((begin ,e)
((interp tid) e env ctx))
((begin ,e . ,e*)
((interp tid)
e env `(begin-ctx ,e* ,env ,ctx)))
((print ,e)
((interp tid) e env `(print-ctx ,ctx)))
((spawn ,e)
((interp tid) e env `(spawn-ctx ,ctx)))
((,op ,e1 ,e2)
(guard (memq op '(+ - * = eq?)))
((interp tid)
e1 env
`(op-ctx-1 ,op ,e2 ,env ,ctx)))
((,rator ,rand)
((interp tid)
rator env
`(rator-ctx ,rand ,env ,ctx)))))(define run
(case-lambda
((exp)
(global-scheduler 'initialize)
(let ((main-thread-id (new-thread-id)))
(global-scheduler
'new-mailbox main-thread-id)
((interp main-thread-id)
exp (empty-env) '(end-main-thread-ctx))))
((ticks exp)
(global-scheduler 'set-ticks ticks)
(global-scheduler 'initialize)
(let ((main-thread-id (new-thread-id)))
(global-scheduler
'new-mailbox main-thread-id)
((interp main-thread-id)
exp (empty-env) '(end-main-thread-ctx))))))> (run
'(letrec ((even? (lambda (parent-id)
(let n (receive)
(if (= n 0)
(send parent-id #t)
(let odd?-id (spawn odd?)
(begin
(send odd?-id (- n 1))
(send parent-id (receive))))))))
(odd? (lambda (parent-id)
(let n (receive)
(if (= n 0)
(send parent-id #f)
(let even?-id (spawn even?)
(begin
(send even?-id (- n 1))
(send parent-id (receive)))))))))
(let even?-id (spawn even?)
(begin
(send even?-id 16)
(receive)))))
The final answer is #t.本章围绕着如何进行延续传递风格变换进行.
介绍了类型, 将类型视为一种静态预测, 即良类型的程序在运行时不会出现类型错误. 之后介绍了最基本的类型检查还有类型推导 (通过合一) 的想法.