(define-type SLUG
[Num (n number?)]
[Str (s string?)]
[Id (name symbol?)]
[Bind (names unique-names?) (exprs (list-of SLUG?)) (body SLUG?)]
[Fun (names unique-names?) (body SLUG?)]
[Call (fun-expr SLUG?) (arg-exprs (list-of SLUG?))]
[If (cond-expr SLUG?) (then-expr SLUG?) (else-expr SLUG?)])
(define (unique-list? xs)
(or (null? xs)
(and (not (member (first xs) (rest xs)))
(unique-list? (rest xs)))))
(define unique-names?
(intersection-of (list-of symbol?) unique-list?))
(define (parse-sexpr sexpr transformers)
(define (parse* sexpr) (parse-sexpr sexpr transformers))
(let ([transformer (and (pair? sexpr)
(assq (car sexpr) transformers))])
(if transformer
(parse* ((second transformer) sexpr))
(match sexpr
[(cons 'with-stx more)
(match sexpr
[(list 'with-stx
(list (symbol: name)
(list (symbol: keywords) ...)
more ...)
body)
(parse-sexpr
body
(cons (list name (make-transformer keywords more))
transformers))]
[else (error 'parse-sexpr
"bad `with-stx' syntax in ~s" sexpr)])]
[(number: n) (Num n)]
[(symbol: name) (Id name)]
[(string: s) (Str s)]
[(cons 'bind more)
(match sexpr
[(list 'bind (list (list (symbol: names) nameds) ...) body)
(Bind names (map parse* nameds) (parse* body))]
[else (error 'parse-sexpr "bad `bind' syntax in ~s" sexpr)])]
[(cons 'fun more)
(match sexpr
[(list 'fun (list (symbol: names) ...) body)
(Fun names (parse* body))]
[else (error 'parse-sexpr "bad `fun' syntax in ~s" sexpr)])]
[(cons 'if more)
(match sexpr
[(list 'if cond then else)
(If (parse* cond) (parse* then) (parse* else))]
[else (error 'parse-sexpr "bad `if' syntax in ~s" sexpr)])]
[(list fun args ...) (Call (parse* fun) (map parse* args))]
[else (error 'parse-sexpr "bad syntax in ~s" sexpr)]))))
(define (parse str)
(parse-sexpr (string->sexpr str) global-transformers))
(define-type ENV
[EmptyEnv]
[FrameEnv (frame frame?) (rest ENV?)])
(define-type VAL
[ScmV (x any?)]
[IOV (x IO?)]
[FunV (names unique-names?) (body SLUG?) (env ENV?)]
[ExprV (expr SLUG?)
(env ENV?)
(cache (box-of (union-of false? VAL?)))]
[PrimV (prim procedure?)])
(define-type IO
[Print (string VAL?)]
[ReadLine (receiver VAL?)]
[Begin2 (l VAL?) (r VAL?)]
[NewBox (init VAL?) (receiver VAL?)]
[UnBox (boxed VAL?) (receiver VAL?)]
[SetBox (boxed VAL?) (newval VAL?)])
(define frame?
(list-of (lambda (x)
(and (list? x)
(= 2 (length x))
(symbol? (first x))
(VAL? (second x))))))
(define (extend names values env)
(if (= (length names) (length values))
(FrameEnv (map list names values) env)
(error 'extend "arity mismatch for names: ~s" names)))
(define (lookup name env)
(cases env
[(EmptyEnv) (error 'lookup "no binding for ~s" name)]
[(FrameEnv frame rest)
(let ([cell (assq name frame)])
(if cell
(second cell)
(lookup name rest)))]))
(define (scheme-func->prim scheme-func wrapper strict?)
(PrimV (lambda (args)
(let* ([args (if strict?
(map (lambda (a)
(let ([v (strict a)])
(cases v
[(ScmV v) v]
[else (error 'scheme-func
"bad input: ~s"
a)])))
args)
args)]
[result (apply scheme-func args)])
(if (VAL? result) result (wrapper result))))))
(define (scheme-func->prim-val scheme-func strict?)
(scheme-func->prim scheme-func ScmV strict?))
(define (scheme-func->prim-io scheme-func strict?)
(scheme-func->prim scheme-func IOV strict?))
(define global-environment
(FrameEnv (list (list '+ (scheme-func->prim-val + #t))
(list '- (scheme-func->prim-val - #t))
(list '* (scheme-func->prim-val * #t))
(list '/ (scheme-func->prim-val / #t))
(list '< (scheme-func->prim-val < #t))
(list '> (scheme-func->prim-val > #t))
(list '= (scheme-func->prim-val = #t))
(list 'number->string
(scheme-func->prim-val number->string #t))
(list 'cons (scheme-func->prim-val cons* #f))
(list 'list (scheme-func->prim-val list #f))
(list 'car (scheme-func->prim-val car #t))
(list 'cdr (scheme-func->prim-val cdr #t))
(list 'null? (scheme-func->prim-val null? #f))
(list 'print (scheme-func->prim-io Print #f))
(list 'read (scheme-func->prim-io ReadLine #f))
(list 'begin2 (scheme-func->prim-io Begin2 #f))
(list 'newbox (scheme-func->prim-io NewBox #f))
(list 'unbox (scheme-func->prim-io UnBox #f))
(list 'set-box! (scheme-func->prim-io SetBox #f))
(list 'true (ScmV #t))
(list 'false (ScmV #f))
(list 'null (ScmV null)))
(EmptyEnv)))
(define (named-transformer name keywords templates)
(define (even-list->list-of-2lists l)
(cond [(null? l) '()]
[(null? (cdr l))
(error 'named-transformer "odd number of templates")]
[else (cons (list (first l) (second l))
(even-list->list-of-2lists (cddr l)))]))
(list name (make-transformer keywords
(even-list->list-of-2lists
(map string->sexpr templates)))))
(define global-transformers
(list (named-transformer 'let '()
'("{let {{var val} ...} body}" "{{fun {var ...} body} val ...}"))
(named-transformer 'let* '()
'("{let* {} body}" "body"
"{let* {{id1 expr1} {id expr} ...} body}" "{let {{id1 expr1}} {let* {{id expr} ...} body}}"))
(named-transformer 'do '(<-)
'("{do {id <- {f x ...}} next more ...}" "{f x ... {fun {id} {do next more ...}}}"
"{do {f x ...} next more ...}" "{begin2 {f x ...} {do next more ...}}"
"{do expr}" "expr"))
(named-transformer 'prog '(:=)
'("{prog {f x ...} := body more ...}" "{bind {{f {fun {x ...} body}}} {prog more ...}}"
"{prog v := x more ...}" "{bind {{v x}} {prog more ...}}"
"{prog expr}" "expr"))))
(define (strict v)
(cases v
[(ExprV expr env cache)
(or (unbox cache)
(let ([val (strict (eval expr env))])
(set-box! cache val)
val))]
[else v]))
(define (eval-promise expr env)
(ExprV expr env (box #f)))
(define (eval expr env)
(cases expr
[(Num n) (ScmV n)]
[(Str s) (ScmV s)]
[(Id name) (lookup name env)]
[(Bind names exprs bound-body)
(eval bound-body
(extend names
(map (lambda (e) (eval-promise e env)) exprs)
env))]
[(Fun names bound-body)
(FunV names bound-body env)]
[(Call fun-expr arg-exprs)
(let ([fval (strict (eval fun-expr env))]
[arg-vals (map (lambda (e) (eval-promise e env))
arg-exprs)])
(cases fval
[(PrimV proc) (proc arg-vals)]
[(FunV names body fun-env)
(eval body (extend names arg-vals fun-env))]
[else (error 'eval "function call with a non-function: ~s"
fval)]))]
[(If cond-expr then-expr else-expr)
(eval (if (cases (strict (eval cond-expr env))
[(ScmV v) v] [else #t]) then-expr
else-expr)
env)]))
(define (strict-IO v)
(cases v
[(Print x) (Print (strict x))]
[(ReadLine x) (ReadLine (strict x))]
[(Begin2 x y) (Begin2 (strict x) (strict y))]
[(NewBox x y) (NewBox (strict x) (strict y))]
[(UnBox x y) (UnBox (strict x) (strict y))]
[(SetBox x y) (SetBox (strict x) (strict y))]))
(define (execute-receiver receiver-val return-val)
(cases receiver-val
[(FunV names body env)
(if (= 1 (length names))
(execute
(eval body (extend names (list (ScmV return-val)) env)))
(error 'execute-receiver "expecting a unary function"))]
[else (error 'execute-receiver "expecting a receiver function")]))
(define (perform-i/o v)
(let ([forced (strict-IO v)])
(cases forced
[(Print (ScmV str))
(if (string? str)
(display str)
(error 'perform-i/o
"cannot print a non-string value: ~s" str))]
[(ReadLine receiver)
(execute-receiver receiver (read-line))]
[(Begin2 (IOV io1) (IOV io2))
(perform-i/o io1)
(perform-i/o io2)]
[(NewBox (ScmV init) receiver)
(execute-receiver receiver (box init))]
[(UnBox (ScmV the-box) receiver)
(if (box? the-box)
(execute-receiver receiver (unbox the-box))
(error 'perform-i/o
"cannot unbox a non-box value: ~s" the-box))]
[(SetBox (ScmV the-box) (ScmV newval))
(if (box? the-box)
(set-box! the-box newval)
(error 'perform-i/o
"cannot set-box a non-box value: ~s" the-box))]
[else (error 'perform-i/o "bad input: ~s" forced)])))
(define (execute val)
(let ([val (strict val)])
(cases val
[(IOV v) (perform-i/o v)]
[else (error 'execute "expecting an IO value: ~s" val)])))
(define (run str)
(let ([result (strict (eval (parse str) global-environment))])
(cases result
[(ScmV v) v]
[else (error 'run
"evaluation returned a bad value: ~s" result)])))
(define (run-io str)
(execute (eval (parse str) global-environment)))
(test (run "{{fun {x} {+ x 1}} 4}")
=> 5)
(test (run "{bind {{add3 {fun {x} {+ x 3}}}} {add3 1}}")
=> 4)
(test (run "{bind {{add3 {fun {x} {+ x 3}}}
{add1 {fun {x} {+ x 1}}}}
{bind {{x 3}} {add1 {add3 x}}}}")
=> 7)
(test (run "{bind {{identity {fun {x} x}}
{foo {fun {x} {+ x 1}}}}
{{identity foo} 123}}")
=> 124)
(test (run "{bind {{x 3}}
{bind {{f {fun {y} {+ x y}}}}
{bind {{x 5}}
{f 4}}}}")
=> 7)
(test (run "{{{fun {x} {x 1}}
{fun {x} {fun {y} {+ x y}}}}
123}")
=> 124)
(test (run "{bind {{x {/ 1 0}}} {car {cons 1 null}}}")
=> 1)
(test (run "{with-stx {let {}
{{let {{var val} ...} body}
{{fun {var ...} body} val ...}}}
{with-stx {let* {}
{{let* {} body} body}
{{let* {{id1 expr1} {id expr} ...} body}
{let {{id1 expr1}}
{let* {{id expr} ...}
body}}}}
{let* {{x 1} {y {+ x 1}}} {+ x y}}}}")
=> 3)
(run-io
"{begin2 {print 'What is your name?\n'}
{read {fun {name}
{begin2 {print 'Your name is '''}
{begin2 {print name}
{print '''\n'}}}}}}")
(run-io
"{with-stx {do {<-}
{{do {id <- {read}} next more ...}
{read {fun {id} {do next more ...}}}}
{{do {print str} next more ...}
{begin2 {print str} {do next more ...}}}
{{do expr}
expr}}
{do {print 'What is your name?\n'}
{name <- {read}}
{print 'What is your email?\n'}
{email <- {read}}
{print 'Your address is '''}
{print name}
{print ' <'}
{print email}
{print '>''\n'}}}")
(run-io
"{bind {{incbox {fun {b}
{unbox b
{fun {curval}
{set-box! b {+ 1 curval}}}}}}}
{newbox 0
{fun {i}
{begin2
{incbox i}
{begin2
{print 'i now holds: '}
{unbox i
{fun {v}
{begin2 {print {number->string v}}
{print '\n'}}}}}}}}}")
(run-io
"{with-stx {do {<-}
{{do {id <- {f x ...}} next more ...}
{f x ... {fun {id} {do next more ...}}}}
{{do {f x ...} next more ...}
{begin2 {f x ...} {do next more ...}}}
{{do expr}
expr}}
{bind {{incbox {fun {b}
{do {curval <- {unbox b}}
{set-box! b {+ 1 curval}}}}}}
{do {i <- {newbox 0}}
{incbox i}
{print 'i now holds: '}
{v <- {unbox i}}
{print {number->string v}}
{print '\n'}}}}")
(run "{prog x := 1
y := 2
{foo n} := {+ n x}
x := {+ x 1}
{* x {foo y}}}")
(run-io
"{prog
{twice b} := {do {curval <- {unbox b}}
{set-box! b {* 2 curval}}}
{do {i <- {newbox 1}}
{twice i}
{print 'i now holds: '}
{v <- {unbox i}}
{print {number->string v}}
{twice i}
{print ', and now it holds: '}
{v <- {unbox i}}
{print {number->string v}}
{print '\n'}}}")